mim/development/mim/20c/newgc.mud

   1 <COND (<NOT <GASSIGNED? WIDTH-MUNG>> <FLOAD "MIMOC20DEFS.MUD">)>
   2
   3 <SETG NUM-TEMPS 4>
   4
   5 <SETG NUM-L-TEMPS 2>
   6
   7 <SETG MARK-BIT 65536>
   8
   9 <SETG FLEN 7>
  10
  11 <SETG LIST-LEN 3>
  12
  13 <SETG ATOM-LEN 5>
  14
  15 <SETG GBIND-LEN 5>
  16
  17 <SETG LBIND-LEN 8>
  18
  19 <MANIFEST NUM-TEMPS NUM-L-TEMPS MARK-BIT FLEN LIST-LEN ATOM-LEN GBIND-LEN
  20           LBIND-LEN>
  21
  22 <DEFINE CGC-RECORD!-MIMOC (L
  23                            "AUX" (VAR <1 .L>) (ALLOC-ATOM <2 .L>)
  24                                  (END-ATOM <3 .L>) (NEXT-ATOM <4 .L>)
  25                                  (BOUNDS-ATOM <5 .L>) (RES <7 .L>) RLEN STK?
  26                                  ALLOCADDR ENDADDR (BOUNDS-LAB <GENLBL "B">)
  27                                  (IB-LAB <GENLBL "I">) (F-LAB <GENLBL "F">)
  28                                  (EXIT-LAB <GENLBL "E">) (M-LAB <GENLBL "M">)
  29                                  (F1 <GENLBL "?FRM">) (B1 <GENLBL "?FRM">)
  30                                  (HINT <EXTRAMEM RECORD-TYPE .L>))
  31         #DECL ((END-ATOM ALLOC-ATOM BOUND-ATOM NEXT-ATOM) !<FORM ATOM ATOM>
  32                (HINT) <PRIMTYPE LIST> (RLEN) FIX (L) LIST)
  33         <FLUSH-ACS>
  34         <SET ENDADDR <OBJ-VAL <CHTYPE <2 .END-ATOM> XGLOC>>>
  35         <SET ALLOCADDR <OBJ-VAL <CHTYPE <2 .ALLOC-ATOM> XGLOC>>>
  36         <COND (<AND .HINT <==? <1 .HINT> RECORD-TYPE>> <SET HINT <2 .HINT>>)>
  37         <COND (<==? .HINT ATOM> <SET RLEN ,ATOM-LEN> <SET STK? <>>)
  38               (<==? .HINT GBIND> <SET RLEN ,GBIND-LEN> <SET STK? <>>)
  39               (<==? .HINT LBIND> <SET RLEN ,LBIND-LEN> <SET STK? T>)
  40               (T <ERROR BAD-HINT-FOR-CGC-RECORD!-ERRORS .HINT CGC-RECORD-GEN>)>
  41         <COND (.STK?
  42                <OCEMIT CAMG TP* !<OBJ-VAL .VAR>>
  43                                              ;"See if this guy is on the stack"
  44                <OCEMIT JRST <XJUMP .BOUNDS-LAB>>
  45                <OCEMIT MOVSI A1* <TYPE-CODE FALSE>>
  46                <OCEMIT MOVEI A2* 0>
  47                <OCEMIT JRST <XJUMP .EXIT-LAB>>
  48                <LABEL .BOUNDS-LAB>
  49                <FRAME!-MIMOC (.B1 <2 .BOUNDS-ATOM>)>
  50                <OCEMIT PUSH TP* !<OBJ-TYP .VAR>>
  51                <COND (,WINNING-VICTIM
  52                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
  53                <OCEMIT PUSH TP* !<OBJ-VAL .VAR>>
  54                <COND (,WINNING-VICTIM
  55                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
  56                <CALL!-MIMOC (.BOUNDS-ATOM 1 .B1)>
  57                <OCEMIT JUMPN A2* <XJUMP .IB-LAB>>
  58                <OCEMIT MOVSI A1* <TYPE-CODE FIX>>
  59                <OCEMIT MOVE A2* !<OBJ-VAL .VAR>>
  60                <OCEMIT JRST <XJUMP .EXIT-LAB>>
  61                <LABEL .IB-LAB>)>
  62         <OCEMIT MOVE O1* !<OBJ-VAL .VAR>>
  63         <OCEMIT MOVE O* .RLEN '(O1*)>
  64         <OCEMIT TLON O* ,MARK-BIT>
  65         <OCEMIT JRST <XJUMP .M-LAB>>
  66         <OCEMIT MOVE A1* !<OBJ-TYP .VAR>>
  67         <OCEMIT MOVE A2* <+ .RLEN 1> '(O1*)>
  68         <OCEMIT JRST <XJUMP .EXIT-LAB>>               ;"Jump if already marked"
  69         <LABEL .M-LAB>
  70         <OCEMIT MOVEM O* .RLEN '(O1*)>
  71         <OCEMIT DMOVE B1* @ !.ALLOCADDR>
  72         <OCEMIT MOVE O2* B2*>
  73         <OCEMIT ADDI O2* <+ .RLEN 2>>
  74         <OCEMIT DMOVE C1* @ !.ENDADDR>
  75         <OCEMIT CAMG O2* C2*>
  76         <OCEMIT JRST <XJUMP .F-LAB>>
  77         <FRAME!-MIMOC (.F1 <2 .NEXT-ATOM>)>
  78         <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
  79         <COND (,WINNING-VICTIM
  80                <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
  81         <OCEMIT PUSH TP* !<OBJ-VAL <+ .RLEN 2>>>
  82         <COND (,WINNING-VICTIM
  83                <SETG STACK-DEPTH <+ ,STACK-DEPTH 1>>)>
  84         <CALL!-MIMOC (.NEXT-ATOM 1 .F1)>
  85         <OCEMIT MOVE O1* !<OBJ-VAL .VAR>>
  86         <OCEMIT DMOVE B1* @ !.ALLOCADDR>
  87         <OCEMIT MOVE O2* B2*>
  88         <OCEMIT ADDI O2* <+ .RLEN 2>>
  89         <LABEL .F-LAB>
  90         <OCEMIT MOVEM B2* <+ .RLEN 1> '(O1*)>
  91         <OCEMIT MOVE T* !.ALLOCADDR>
  92         <OCEMIT MOVEM O2* 1 '(T*)>
  93         <OCEMIT DMOVE C1* .RLEN '(O1*)>
  94         <OCEMIT TLZ C1* ,MARK-BIT>
  95         <OCEMIT DMOVEM C1* .RLEN '(B2*)>
  96         <OCEMIT MOVE A2* B2*>
  97         <OCEMIT MOVSI A1* <TYPE-CODE FIX>>
  98         <LABEL .EXIT-LAB>
  99         <COND (<==? .RES STACK>
 100                <COND (,WINNING-VICTIM
 101                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 102                <OCEMIT PUSH TP* A1*>
 103                <OCEMIT PUSH TP* A2*>)
 104               (ELSE <LOAD-AC .RES BOTH T T <GET-AC A1*>>)>>
 105
 106 <DEFINE CGC-BYTES!-MIMOC (L "AUX" (VAR <1 .L>) (ALLOC-ATOM <2 .L>)
 107                                   (END-ATOM <3 .L>) (NEXT-ATOM <4 .L>)
 108                                   (RES <6 .L>))
 109         #DECL ((L) LIST)
 110         <FLUSH-ACS>
 111         <OCEMIT DMOVE A1* !<OBJ-TYP .VAR>>
 112         <OCEMIT ANDI A1* *777777*>
 113         <OCEMIT IBP A1* A2*>                    ;"Byte pointer to dope words."
 114         <OCEMIT TLZ A1* *770000*>               ;"A1* points one before dopeword."
 115         <OCEMIT SUB A2* A1*>                    ;"A2* added to new dw pntr wins"
 116         <CGC-UV-ST .VAR .ALLOC-ATOM .END-ATOM .NEXT-ATOM .RES>>
 117
 118 <SETG CGC-STRING!-MIMOC ,CGC-BYTES!-MIMOC>
 119
 120 <DEFINE CGC-UVECTOR!-MIMOC (L "AUX" (VAR <1 .L>) (ALLOC-ATOM <2 .L>)
 121                                     (END-ATOM <3 .L>) (NEXT-ATOM <4 .L>)
 122                                     (RES <6 .L>))
 123         #DECL ((L) LIST)
 124         <OCEMIT DMOVE A1* !<OBJ-TYP .VAR>>
 125         <OCEMIT HRREI A1* -1 '(A1*)>
 126         <OCEMIT ADD A1* A2*>
 127         <OCEMIT SUB A2* A1*>
 128         <CGC-UV-ST .VAR .ALLOC-ATOM .END-ATOM .NEXT-ATOM .RES>>
 129
 130 ; "Call this guy with A1* pointing to dope word and A2* being what is added to new
 131    dw pointer to win.  All ACs are available"
 132
 133 <DEFINE CGC-UV-ST (VAR ALLOC-ATOM END-ATOM NEXT-ATOM RES
 134                    "AUX" ENDADDR ALLOCADDR (M-LAB <GENLBL "M">)
 135                          (F-LAB <GENLBL "F">) (F1 <GENLBL "?FRM">))
 136         #DECL ((VAR RES) ATOM (NEXT-ATOM ALLOC-ATOM END-ATOM) !<FORM ATOM ATOM>)
 137         <SET ENDADDR <OBJ-VAL <CHTYPE <2 .END-ATOM> XGLOC>>>
 138         <SET ALLOCADDR <OBJ-VAL <CHTYPE <2 .ALLOC-ATOM> XGLOC>>>
 139                                  ;"Pointers to GVAL slots for AL and END-SPACE"
 140         <OCEMIT MOVE O1* 1 '(A1*)>
 141         <OCEMIT TLOE O1* ,MARK-BIT>                   ;"Check and set mark bit"
 142         <OCEMIT JRST <XJUMP .M-LAB>>                          ;"Jump if marked"
 143         <OCEMIT MOVEM O1* 1 '(A1*)>                 ;"Store back with mark bit"
 144         <OCEMIT MOVEI O* 2 '(O1*)>           ;"Add 2 to length for total words"
 145         <OCEMIT MOVE O2* !.ALLOCADDR>                    ;"Point to ALLOC slot"
 146         <OCEMIT ADD O* 1 '(O2*)>                          ;"Possible new ALLOC"
 147         <OCEMIT MOVE T* !.ENDADDR>                      ;"Now compare with end"
 148         <OCEMIT CAMG O* 1 '(T*)>
 149         <OCEMIT JRST <XJUMP .F-LAB>>                        ;"Jump if will fit"
 150         <OCEMIT SUB O* 1 '(O2*)>                    ;"Make O* be # words again"
 151         <OCEMIT PUSH TP* O*>                               ;"Save useful stuff"
 152         <OCEMIT PUSH TP* A1*>
 153         <OCEMIT PUSH TP* A2*>
 154         <COND (,WINNING-VICTIM
 155                <SETG STACK-DEPTH <+ ,STACK-DEPTH 3>>)>
 156         <FRAME!-MIMOC (.F1 <2 .NEXT-ATOM>)>
 157         <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 158         <OCEMIT PUSH TP* O*>                  ;"Pass space needed to NEXT-ATOM"
 159         <COND (,WINNING-VICTIM
 160                <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 161         <CALL!-MIMOC (.NEXT-ATOM 1 .F1)>
 162         <OCEMIT MOVE O2* !.ALLOCADDR>                          ;"Restore stuff"
 163         <OCEMIT MOVE O* -2 '(TP*)>
 164         <OCEMIT MOVE A1* -1 '(TP*)>
 165         <OCEMIT MOVE A2* '(TP*)>
 166         <OCEMIT ADD O* 1 '(O2*)>                             ;"O* is new ALLOC"
 167         <OCEMIT SUBI TP* 3>
 168         <COND (,WINNING-VICTIM
 169                <SETG STACK-DEPTH <- ,STACK-DEPTH 3>>)>
 170         <LABEL .F-LAB>
 171         <OCEMIT MOVEM O* 1 '(O2*)>                           ;"Store new ALLOC"
 172         <OCEMIT SUBI O* 2>                            ;"Now point to first dw."
 173         <OCEMIT MOVEM O* 2 '(A1*)>                          ;"Store relocation"
 174         <OCEMIT MOVE C1* O*>                                   ;"Copy for XBLT"
 175         <OCEMIT HRRZ B1* 1 '(A1*)>
 176         <OCEMIT XMOVEI B2* 1 '(A1*)>
 177         <OCEMIT MOVE O* 1 '(A1*)>
 178         <OCEMIT TLZ O* ,MARK-BIT>
 179         <OCEMIT MOVEM O* '(C1*)>
 180         <OCEMIT MOVNS O* B1*>
 181         <OCEMIT XBLT B1* !<OBJ-VAL 2147483648>>
 182         <LABEL .M-LAB>
 183         <OCEMIT ADD A2* 2 '(A1*)>
 184         <OCEMIT SUBI A2* 1>
 185         <COND (<==? .RES STACK>
 186                <OCEMIT PUSH TP* !<OBJ-TYP .VAR>>
 187                <OCEMIT PUSH TP* A2*>
 188                <COND (,WINNING-VICTIM
 189                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 190               (ELSE
 191                <OCEMIT MOVE A1* !<OBJ-TYP .VAR>>
 192                <LOAD-AC .RES BOTH T T <GET-AC A1*>>)>>
 193
 194 <DEFINE CGC-VECTOR!-MIMOC (L
 195                            "AUX" (VAR <1 .L>) (ALLOC-ATOM <2 .L>)
 196                                  (END-ATOM <3 .L>) (NEXT-ATOM <4 .L>)
 197                                  (MARK-ATOM <5 .L>) (RES <7 .L>) ENDADDR
 198                                  ALLOCADDR (NF-LAB <GENLBL "NF">)
 199                                  (F-LAB <GENLBL "F">) (F1 <GENLBL "?FRM">)
 200                                  (LOOP-LAB <GENLBL "LOOP">)
 201                                  (NM-LAB <GENLBL "NM">) (F2 <GENLBL "?FRM">)
 202                                  (DONE-LAB <GENLBL "DONE">)
 203                                  (M-LAB <GENLBL "M">))
 204         #DECL ((END-ATOM ALLOC-ATOM NEXT-ATOM MARK-ATOM) !<FORM ATOM ATOM>
 205                (L) LIST)
 206         <SET ENDADDR <OBJ-VAL <CHTYPE <2 .END-ATOM> XGLOC>>>
 207         <SET ALLOCADDR <OBJ-VAL <CHTYPE <2 .ALLOC-ATOM> XGLOC>>>
 208                                  ;"Pointers to GVAL slots for AL and END-SPACE"
 209         <FLUSH-ACS>
 210         <OCEMIT HRRZ A1* !<OBJ-TYP .VAR>>
 211         <OCEMIT ASH A1* 1>                                ;"To number of words"
 212         <OCEMIT MOVE A2* A1*>
 213         <OCEMIT ADD A2* !<OBJ-VAL .VAR>>           ;"A1* is #words, A2* 1st dw"
 214         <OCEMIT MOVE O1* '(A2*)>                               ;"Check marking"
 215         <OCEMIT SUBI A1* '(O1*)>
 216         <OCEMIT TLOE O1* ,MARK-BIT>
 217         <OCEMIT JRST <XJUMP .M-LAB>>
 218         <OCEMIT ADDI TP* ,NUM-TEMPS>                          ;"Allocate temps"
 219         <COND (,WINNING-VICTIM
 220                <SETG STACK-DEPTH <+ ,STACK-DEPTH ,NUM-TEMPS>>)>
 221         <OCEMIT MOVEM O1* '(A2*)>                                ;"Mark bit on"
 222         <OCEMIT MOVEI O2* 2 '(O1*)>                    ;"O2 total size with dw"
 223         <OCEMIT MOVE T* !.ALLOCADDR>                       ;"Compute new ALLOC"
 224         <OCEMIT ADD O2* 1 '(T*)>
 225         <OCEMIT MOVE B1* !.ENDADDR>
 226         <OCEMIT HRRZM O1* '(TP*)>
 227         <OCEMIT MOVEM A2* -1 '(TP*)>
 228         <OCEMIT MOVEM A1* -2 '(TP*)>
 229         <OCEMIT CAMG O2* 1 '(B1*)>                         ;"Skip if area full"
 230         <OCEMIT JRST <XJUMP .F-LAB>>
 231         <FRAME!-MIMOC (.F1 <2 .NEXT-ATOM>)>
 232         <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 233         <OCEMIT MOVEI O1* 2 '(O1*)>
 234         <OCEMIT PUSH TP* O1*>
 235         <COND (,WINNING-VICTIM
 236                <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 237         <CALL!-MIMOC (.NEXT-ATOM 1 .F1)>        ;"Call to use next AREA"
 238         <OCEMIT MOVE T* !.ALLOCADDR>
 239         <OCEMIT MOVE O2* '(TP*)>
 240         <OCEMIT ADDI O2* 2>
 241         <OCEMIT ADD O2* 1 '(T*)>
 242         <OCEMIT MOVE A2* -1 '(TP*)>
 243         <LABEL .F-LAB>
 244         <OCEMIT MOVEM O2* 1 '(T*)>                           ;"Store new ALLOC"
 245         <OCEMIT XMOVEI O1* -2 '(O2*)>                           ;"Fudge for dw"
 246         <OCEMIT MOVEM O1* 1 '(A2*)>                            ;"Store new loc"
 247         <OCEMIT MOVE O* '(A2*)>
 248         <OCEMIT TLZ O* ,MARK-BIT>
 249         <OCEMIT MOVEM O* '(O1*)>                       ;"Store new dw not marked"
 250         <OCEMIT MOVE O2* '(TP*)>
 251         <OCEMIT SUB A2* O2*>
 252         <OCEMIT MOVEM A2* -1 '(TP*)>
 253         <OCEMIT SUB O1* O2*>
 254         <OCEMIT MOVEM O1* -3 '(TP*)>
 255         <OCEMIT ASH O2* -1>                               ;"Number of elements"
 256         <OCEMIT MOVEM O2* '(TP*)>
 257         <LABEL .LOOP-LAB>
 258         <OCEMIT SOSGE '(TP*)>
 259         <OCEMIT JRST <XJUMP .DONE-LAB>>
 260         <OCEMIT DMOVE A1* @ -1 '(TP*)>
 261         <OCEMIT HLRZ O* A1*>
 262         <OCEMIT ANDI O* 7>
 263         <OCEMIT JUMPE O* <XJUMP .NM-LAB>>
 264         <FRAME!-MIMOC (.F2 <2 .MARK-ATOM>)>
 265         <OCEMIT PUSH TP* A1*>
 266         <OCEMIT PUSH TP* A2*>
 267         <COND (,WINNING-VICTIM
 268                <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 269         <CALL!-MIMOC (.MARK-ATOM 1 .F2)>
 270         <LABEL .NM-LAB>
 271         <OCEMIT DMOVEM A1* @ -3 '(TP*)>
 272         <OCEMIT MOVEI O* 2>
 273         <OCEMIT ADDM O* -1 '(TP*)>
 274         <OCEMIT ADDM O* -3 '(TP*)>
 275         <OCEMIT JRST <XJUMP .LOOP-LAB>>
 276         <LABEL .DONE-LAB>
 277         <OCEMIT MOVE A2* -1 '(TP*)>
 278         <OCEMIT MOVE A1* -2 '(TP*)>
 279         <OCEMIT SUBI TP* ,NUM-TEMPS>
 280         <COND (,WINNING-VICTIM
 281                <SETG STACK-DEPTH <- ,STACK-DEPTH ,NUM-TEMPS>>)>
 282         <LABEL .M-LAB>
 283         <OCEMIT MOVE A2* 1 '(A2*)>
 284         <OCEMIT HRRZ O1* '(A2*)>
 285         <OCEMIT ADD O1* A1*>
 286         <OCEMIT SUB A2* O1*>
 287         <COND (<==? .RES STACK>
 288                <OCEMIT PUSH TP* !<OBJ-TYP .VAR>>
 289                <OCEMIT PUSH TP* A2*>
 290                <COND (,WINNING-VICTIM
 291                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 292               (ELSE
 293                <OCEMIT MOVE A1* !<OBJ-TYP .VAR>>
 294                <LOAD-AC .RES BOTH T T <GET-AC A1*>>)>>
 295
 296 <DEFINE CGC-LIST!-MIMOC (L
 297                          "AUX" (VAR <1 .L>) (ALLOC-ATOM <2 .L>)
 298                                (END-ATOM <3 .L>) (NEXT-ATOM <4 .L>)
 299                                (BOUNDS-ATOM <5 .L>) (MARK-ATOM <6 .L>)
 300                                (LN <LENGTH .L>) (RES <NTH .L .LN>) ENDADDR
 301                                ALLOCADDR (M-LAB <GENLBL "M">)
 302                                (DONE-LAB <GENLBL "D">)
 303                                (LOOP-LAB <GENLBL "LOOP">) (F-LAB <GENLBL "F">)
 304                                (NB-LAB <GENLBL "NB">) (MC-LAB <GENLBL "MC">)
 305                                (F1 <GENLBL "?FRM">) (F2 <GENLBL "?FRM">)
 306                                (F3 <GENLBL "?FRM">) (UNDO-ABLE <>))
 307         #DECL ((LN) FIX (L) LIST
 308                (BOUNDS-ATOM MARK-ATOM NEXT-ATOM ALLOC-ATOM END-ATOM)
 309                !<FORM ATOM ATOM>)
 310         <COND (<AND <==? .LN 9> <7 .L>> <SET UNDO-ABLE T>)>
 311                 ;"UNDO-ABLE being true means old cdr clobbers new type word
 312                   so its not lost if the world has to be undone"
 313         <SET ENDADDR <OBJ-VAL <CHTYPE <2 .END-ATOM> XGLOC>>>
 314         <SET ALLOCADDR <OBJ-VAL <CHTYPE <2 .ALLOC-ATOM> XGLOC>>>
 315                                  ;"Pointers to GVAL slots for AL and END-SPACE"
 316         <FLUSH-ACS>
 317         <OCEMIT ADDI TP* ,NUM-L-TEMPS>
 318         <COND (,WINNING-VICTIM
 319                <SETG STACK-DEPTH <+ ,STACK-DEPTH ,NUM-L-TEMPS>>)>
 320         <OCEMIT MOVE B1* !<OBJ-VAL .VAR>>
 321         <OCEMIT SETZM '(TP*)>
 322         <LABEL .LOOP-LAB>
 323         <OCEMIT DMOVE A1* 1 '(B1*)>
 324         <OCEMIT TLOE A1* ,MARK-BIT>
 325         <OCEMIT JRST <XJUMP .M-LAB>>
 326         <OCEMIT MOVEM A1* 1 '(B1*)>      ;"Mark bit set, need to hack this up."
 327         <OCEMIT DMOVE O1* @ !.ALLOCADDR>
 328         <OCEMIT MOVE C2* O2*>
 329         <OCEMIT ADDI O2* ,LIST-LEN>
 330         <OCEMIT MOVE T* !.ENDADDR>
 331         <OCEMIT CAMG O2* 1 '(T*)>
 332         <OCEMIT JRST <XJUMP .F-LAB>>
 333         <OCEMIT MOVEM B1* -1 '(TP*)>
 334         <FRAME!-MIMOC (.F1 <2 .NEXT-ATOM>)>
 335         <OCEMIT PUSH TP* !<TYPE-WORD FIX>>
 336         <OCEMIT PUSH TP* !<OBJ-VAL ,LIST-LEN>>
 337         <COND (,WINNING-VICTIM
 338                <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 339         <CALL!-MIMOC (.NEXT-ATOM 1 .F1)>
 340         <OCEMIT DMOVE O1* @ !.ALLOCADDR>
 341         <OCEMIT MOVE C2* O2*>
 342         <OCEMIT ADDI O2* ,LIST-LEN>
 343         <OCEMIT MOVE B1* -1 '(TP*)>
 344         <OCEMIT DMOVE A1* 1 '(B1*)>
 345         <LABEL .F-LAB>
 346         <OCEMIT DMOVEM O1* @ !.ALLOCADDR>
 347         <OCEMIT SKIPE O1* '(TP*)>           ;"Pick up pointer to previous cell"
 348         <OCEMIT MOVEM C2* '(O1*)>        ;"Fix up cdr pointer in previous cell"
 349         <OCEMIT MOVEM C2* '(TP*)>                  ;"New previous cell pointer"
 350         <OCEMIT MOVE C1* '(B1*)>                         ;"Pick up cdr pointer"
 351         <OCEMIT MOVEM C2* '(B1*)>                    ;"Relocation for old cell"
 352         <OCEMIT MOVEM C1* '(C2*)>
 353                          ;"Make sure new cell doesn't have garbage in cdr slot"
 354         <OCEMIT TLZ A1* ,MARK-BIT>                     ;"Clear mark bit in CAR"
 355         <OCEMIT HLRZ O* A1*>
 356         <OCEMIT ANDI O* 7>                   ;"See if car's type needs marking"
 357         <OCEMIT MOVEM C1* -1 '(TP*)>                    ;"Save old cdr pointer"
 358         <OCEMIT JUMPE O* <XJUMP .MC-LAB>>
 359         <FRAME!-MIMOC (.F2 <2 .MARK-ATOM>)>
 360         <OCEMIT PUSH TP* A1*>
 361         <OCEMIT PUSH TP* A2*>
 362         <COND (,WINNING-VICTIM
 363                <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 364         <CALL!-MIMOC (.MARK-ATOM 1 .F2)>                    ;"Mark the guy"
 365         <OCEMIT MOVE C1* -1 '(TP*)>
 366         <LABEL .MC-LAB>
 367         <OCEMIT MOVE O1* '(TP*)>
 368         <COND (.UNDO-ABLE
 369                <OCEMIT MOVEM C1* 1 '(O1*)>      ;"Save old CDR...KLUDGE"
 370                <OCEMIT MOVEM A2* 2 '(O1*)>)
 371               (ELSE <OCEMIT DMOVEM A1* 1 '(O1*)>)>
 372         <OCEMIT JUMPE C1* <XJUMP .DONE-LAB>>           ;"All done if empty cdr"
 373         <FRAME!-MIMOC (.F3 <2 .BOUNDS-ATOM>)>
 374         <OCEMIT PUSH TP* !<TYPE-WORD LIST>>
 375         <OCEMIT PUSH TP* C1*>
 376         <COND (,WINNING-VICTIM
 377                <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>
 378         <CALL!-MIMOC (.BOUNDS-ATOM 1 .F3)>;"Check bounds of list cdr"
 379         <OCEMIT MOVE B1* -1 '(TP*)>
 380         <OCEMIT JUMPN A2* <XJUMP .LOOP-LAB>>          ;"Loop back if in bounds"
 381         <OCEMIT JRST <XJUMP .DONE-LAB>>
 382         <LABEL .M-LAB>
 383         <OCEMIT SKIPN C1* '(TP*)>               ;"Pick up pointer to last cell"
 384         <OCEMIT JRST <XJUMP .DONE-LAB>>        ;"None, just clean up and leave"
 385         <OCEMIT MOVE O* '(B1*)>                           ;"Clean up last cell"
 386         <OCEMIT MOVEM O* '(C1*)>
 387         <LABEL .DONE-LAB>
 388         <OCEMIT SUBI TP* ,NUM-L-TEMPS>
 389         <COND (,WINNING-VICTIM
 390                <SETG STACK-DEPTH <- ,STACK-DEPTH ,NUM-L-TEMPS>>)>
 391         <OCEMIT DMOVE A1* !<OBJ-TYP .VAR>>
 392         <OCEMIT MOVE A2* '(A2*)>
 393         <COND (<==? .RES STACK>
 394                <OCEMIT PUSH TP* A1*>
 395                <OCEMIT PUSH TP* A2*>
 396                <COND (,WINNING-VICTIM
 397                       <SETG STACK-DEPTH <+ ,STACK-DEPTH 2>>)>)
 398               (ELSE <LOAD-AC .RES BOTH T T <GET-AC A1*>>)>>