<mdl.comp>/newrep.mud.60

   1 <PACKAGE "NEWREP">
   2
   3 <ENTRY PROG-REP-GEN RETURN-GEN AGAIN-GEN TAG-GEN GO-GEN CLEANUP-STATE
   4        AGAIN-UP RETURN-UP PROG-START-AC>
   5
   6 <USE "CODGEN" "COMCOD" "CACS" "CHKDCL" "COMPDEC" "CUP">
   7
   8 " Generate code for a poor innocent PROG or REPEAT."
   9
  10
  11 "\f"
  12
  13 <DEFINE PROG-REP-GEN (PNOD PWHERE
  14                       "AUX" (BSTB .BSTB) (NTSLOTS .NTSLOTS) XX (SPECD <>)
  15                             START:TAG (STB .STK) (STK (0 !.STK))
  16                             (NTMPS
  17                              <COND (.PRE .TMPS)
  18                                    (<STACK:L .STK .BSTB>)
  19                                    (ELSE (0))>) (TMPS .TMPS) BTP (BASEF .BASEF)
  20                             EXIT EXIT:OFF AGAIN (FRMS .FRMS) (OPRE .PRE) DEST
  21                             (CD <>) (AC-HACK .AC-HACK) (K <KIDS .PNOD>)
  22                             (SPEC-LIST .SPEC-LIST) TEM (ONS .NTSLOTS)
  23                             (ORPNOD <AND <ASSIGNED? RPNOD> .RPNOD>) RPNOD
  24                             SACS)
  25         #DECL ((NTSLOTS STB) <SPECIAL LIST> (BASEF PNOD RPNOD) <SPECIAL NODE>
  26                (PWHERE DEST) <OR ATOM DATUM> (SPECD PRE) <SPECIAL ANY>
  27                (STK FRMS) <SPECIAL LIST> (BTP NSTB) LIST
  28                (AC-HACK) <SPECIAL <PRIMTYPE LIST>> (TMPS) <SPECIAL LIST>
  29                (START:TAG) <SPECIAL ATOM> (K) <LIST [REST NODE]>
  30                (SPEC-LIST) <SPECIAL LIST>)
  31         <REGSTO <> <>>
  32         <COND (<N==? <NODE-SUBR .PNOD> ,BIND> <SET RPNOD .PNOD>)
  33               (.ORPNOD <SET RPNOD .ORPNOD>)>
  34         <PUT .PNOD ,SPECS-START <- <SPECS-START .PNOD> .TOT-SPEC>>
  35         <SET TMPS .NTMPS>
  36         <BEGIN-FRAME <TMPLS .PNOD> <ACTIVATED .PNOD> <PRE-ALLOC .PNOD>>
  37         <SET DEST
  38              <COND (<==? .PWHERE FLUSHED> FLUSHED)
  39                    (ELSE <GOODACS .PNOD .PWHERE>)>>
  40         <PROG ((PRE .PRE) (TOT-SPEC .TOT-SPEC))
  41               #DECL ((PRE) <SPECIAL ANY> (TOT-SPEC) <SPECIAL FIX>)
  42               <OR .PRE
  43                   <EMIT-PRE <NOT <OR <ACTIVATED .PNOD> <0? <SSLOTS .BASEF>>>>>>
  44               <COND (<ACTIVATED .PNOD>
  45                      <REGSTO T>
  46                      <SET TOT-SPEC 0>
  47                      <SET SPEC-LIST ()>
  48                      <ADD:STACK ,FRAMLN>
  49                      <SET FRMID <+ .FRMID 1>>
  50                      <PUT .FRMS 5 .NTSLOTS>
  51                      <SET FRMS
  52                           (.FRMID
  53                            <SET STK (0 !.STK)>
  54                            .PNOD
  55                            <COND (.PRE FUZZ)
  56                                  (<STACK:L .STK <2 .FRMS>>)
  57                                  (ELSE FUZZ)>
  58                            (<FORM GVAL <TMPLS .PNOD>>)
  59                            !.FRMS)>
  60                      <SET PRE <>>
  61                      <SET AC-HACK <>>
  62                      <SET BASEF .PNOD>
  63                      <SET NTSLOTS (<FORM GVAL <TMPLS .PNOD>>)>
  64                      <COND (<NOT <==? .PWHERE FLUSHED>>
  65                             <SET DEST <FUNCTION:VALUE>>)>
  66                      <BUILD:FRAME <SET EXIT:OFF <MAKE:TAG "EXIT">>>
  67                      <SET TMPS (2)>
  68                      <SET BSTB .STK>)>
  69               <SET EXIT <MAKE:TAG "EXIT">>
  70               <PUT .PNOD ,STK-B .STB>
  71               <COND (<AND <NOT .PRE> <NOT <ACTIVATED .PNOD>>>
  72                      <SET NTSLOTS (<FORM GVAL <TMPLS .PNOD>> !.NTSLOTS)>)>
  73               <BIND-CODE .PNOD>
  74               <SET SPEC-LIST (.PNOD .SPECD <SPECS-START .PNOD> !.SPEC-LIST)>
  75               <SET BTP .STK>
  76               <OR .OPRE <SET BASEF .PNOD>>
  77               <SET STK (0 !.STK)>
  78               <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
  79                      <PROG-START-AC .PNOD>)
  80                     (ELSE <SET SACS <SAVE:RES>> <REGSTO <>>)>
  81               <LABEL:TAG <SET AGAIN <MAKE:TAG "AGAIN">>>
  82               <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
  83                      <CALL-INTERRUPT>)>
  84               <PUT .PNOD ,BTP-B .BTP>
  85               <PUT .PNOD ,DST .DEST>
  86               <PUT .PNOD ,SPCS-X .SPECD>
  87               <PUT .PNOD ,ATAG .AGAIN>
  88               <PUT .PNOD ,RTAG .EXIT>
  89               <PUT .PNOD ,PRE-ALLOC .PRE>
  90               <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
  91                      <COND (<OR <==? <NODE-SUBR .PNOD> ,REPEAT>
  92                                 <==? .DEST FLUSHED>>
  93                             <RET-TMP-AC <SET TEM <SEQ-GEN .K FLUSHED T T>>>)
  94                            (ELSE
  95                             <SET TEM <SET CD <SEQ-GEN .K .DEST T T>>>
  96                             <COND (<==? .TEM ,NO-DATUM>
  97                                    <COND (<EMPTY? <CDST .PNOD>>
  98                                           <SET CD ,NO-DATUM>)
  99                                          (ELSE <SET CD <CDST .PNOD>>)>)>)>)
 100                     (ELSE
 101                      <COND (<==? .DEST FLUSHED>
 102                             <RET-TMP-AC <SET TEM <SEQ-GEN .K .DEST T>>>
 103                             <COND (<NOT <==? .TEM ,NO-DATUM>>)>)
 104                            (ELSE
 105                             <SET TEM <SET CD <SEQ-GEN .K .DEST T>>>
 106                             <COND (<==? .TEM ,NO-DATUM>
 107                                    <COND (<EMPTY? <CDST .PNOD>>
 108                                           <SET CD ,NO-DATUM>)
 109                                          (ELSE <SET CD <CDST .PNOD>>)>)>)>)>
 110               <OR <ASSIGNED? NPRUNE> <PUT .PNOD ,KIDS ()>>
 111               <AND .CD <TYPE? .CD DATUM> <PROG ()
 112                                                <ACFIX .DEST .CD>>>
 113               <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT>
 114                           <N==? .TEM ,NO-DATUM>>
 115                      <COND (<ACTIVATED .PNOD> <PROG:END>)
 116                            (.OPRE
 117                             <POP:LOCS .STK .STB>
 118                             <UNBIND:FUNNY <SPECS-START .PNOD> !.NTSLOTS>)
 119                            (ELSE <UNBIND:LOCS .STK .STB>)>)
 120                     (<==? <NODE-SUBR .PNOD> ,REPEAT>
 121                      <AGAIN-UP .PNOD>
 122                      <BRANCH:TAG .AGAIN>)>
 123               <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT> <AGND .PNOD>>
 124                      <RETURN-UP .PNOD>)>
 125               <COND (<AND <N==? <NODE-SUBR .PNOD> ,REPEAT> <NOT <AGND .PNOD>>>
 126                      <NON-LOOP-CLEANUP .PNOD>
 127                      <PROG ((STK .STB) (NTSLOTS .ONS))
 128                            #DECL ((NTSLOTS STK) <SPECIAL LIST>)
 129                            <VAR-STORE>>)>
 130               <COND (<OR <AGND .PNOD> <==? <NODE-SUBR .PNOD> ,REPEAT>>
 131                      <CLEANUP-STATE .PNOD>)
 132                     (ELSE <CHECK:VARS .SACS T>)>
 133               <COND (<AND <==? <NODE-SUBR .PNOD> ,REPEAT>
 134                           <NOT <==? .DEST FLUSHED>>>
 135                      <MOVE:ARG .DEST .DEST>)>
 136               <COND (<AND <TYPE? .DEST DATUM>
 137                           <ISTYPE? <DATTYP .DEST>>
 138                           .CD
 139                           <TYPE? <DATTYP .CD> AC>>
 140                      <RET-TMP-AC <DATTYP .CD> .CD>)>
 141               <LABEL:TAG .EXIT>
 142               <COND (<ACTIVATED .PNOD> <LABEL:OFF .EXIT:OFF>)
 143                     (ELSE <SET TEM .TOT-SPEC>)>>
 144         <OR <ACTIVATED .PNOD> <SET TOT-SPEC .TEM>>
 145         <SET STK .STB>
 146         <COND (.CD
 147                <AND <TYPE? <DATTYP .DEST> AC>
 148                     <FIX-ACLINK <DATTYP .DEST> .DEST .CD>>
 149                <AND <TYPE? <DATVAL .DEST> AC>
 150                     <FIX-ACLINK <DATVAL .DEST> .DEST .CD>>)>
 151         <SET XX <MOVE:ARG .DEST .PWHERE>>
 152         <END-FRAME>
 153         .XX>
 154
 155 "\f"
 156
 157 " Generate code for a RETURN."
 158
 159 <DEFINE RETURN-GEN (NOD WHERE
 160                     "AUX" (SPECD .SPECD) N NN (CD1 <>) DEST (NF 0)
 161                           NOT-HANDLED-PROG (NT .NTSLOTS))
 162         #DECL ((NOD N RPNOD) NODE (WHERE) <OR ATOM DATUM> (CD1) <OR DATUM
 163                                                                     FALSE>
 164                (SPECD) <SPECIAL ANY> (NF) FIX)
 165         <PROG ()
 166               <COND (<1? <LENGTH <KIDS .NOD>>> <SET N .RPNOD>)
 167                     (<SET NN <RET-AGAIN-ONLY <NODE-NAME <2 <KIDS .NOD>>>>>
 168                      <SET N .NN>)
 169                     (ELSE <RETURN <SUBR-GEN .NOD .WHERE>>)>
 170               <SET NOT-HANDLED-PROG
 171                    <NOT <OR <==? <NODE-SUBR .N> ,REPEAT>
 172                             <AND <==? <NODE-SUBR .N> ,PROG> <AGND .N>>>>>
 173               <COND (<==? <SET DEST <DST .N>> FLUSHED>
 174                      <RET-TMP-AC <GEN <1 <KIDS .NOD>> FLUSHED>>)
 175                     (ELSE
 176                      <PUT .N
 177                           ,CDST
 178                           <SET CD1 <GEN <1 <KIDS .NOD>> <DATUM !.DEST>>>>
 179                      <RET-TMP-AC .CD1>
 180                      <ACFIX <DST .N> .CD1>)>
 181               <AND .NOT-HANDLED-PROG <VAR-STORE>>
 182               <COND (<ACTIVATED .N>
 183                      <REPEAT ((L .FRMS))
 184                              #DECL ((L) LIST)
 185                              <COND (<==? <3 .L> .N> <RETURN>)>
 186                              <AND <EMPTY? <SET L <REST .L 5>>> <RETURN>>
 187                              <SET NT <5 .L>>
 188                              <SET NF <+ .NF 1>>>
 189                      <GO:BACK:FRAMES .NF>
 190                      <OR .NOT-HANDLED-PROG <RETURN-UP .N>>
 191                      <PROG:END>)
 192                     (ELSE
 193                      <REPEAT ((LL .SPEC-LIST))
 194                              #DECL ((LL) LIST)
 195                              <AND <2 .LL> <RETURN <SET SPECD T>>>
 196                              <AND <==? <1 .LL> .N> <RETURN>>
 197                              <SET LL <REST .LL 3>>>
 198                      <COND (<TYPE? .CD1 DATUM>
 199                             <COND (<TYPE? <DATTYP .CD1> AC>
 200                                    <PUT <DATTYP .CD1> ,ACPROT T>)>
 201                             <COND (<TYPE? <DATVAL .CD1> AC>
 202                                    <PUT <DATVAL .CD1> ,ACPROT T>)>)>
 203                      <COND (<PRE-ALLOC .N>
 204                             <POP:LOCS .STK <STK-B .N>>
 205                             <UNBIND:FUNNY <SPECS-START .N> !.NT>)
 206                            (ESLE <UNBIND:LOCS .STK <STK-B .N>>)>
 207                      <COND (<TYPE? .CD1 DATUM>
 208                             <COND (<TYPE? <DATTYP .CD1> AC>
 209                                    <PUT <DATTYP .CD1> ,ACPROT <>>)>
 210                             <COND (<TYPE? <DATVAL .CD1> AC>
 211                                    <PUT <DATVAL .CD1> ,ACPROT <>>)>)>
 212                      <OR .NOT-HANDLED-PROG
 213                          <PROG ((STB <STK-B .N>))
 214                                #DECL ((STB) <SPECIAL LIST>)
 215                                <RETURN-UP .N>>>
 216                      <BRANCH:TAG <RTAG .N>>)>
 217               ,NO-DATUM>>
 218
 219 <DEFINE GO:BACK:FRAMES (NF)
 220         #DECL ((NF) FIX)
 221         <OR <0? .NF>
 222             <REPEAT ()
 223                     <EMIT '<`MOVE  `TB*  |OTBSAV  `(TB) >>
 224                     <COND (<0? <SET NF <- .NF 1>>> <RETURN>)>>>>
 225
 226 "\f"
 227
 228 " Generate code for an AGAIN."
 229
 230 <DEFINE AGAIN-GEN (NOD WHERE
 231                    "AUX" N NN (SPECD .SPECD) (PRE <>) NOT-HANDLED-PROG)
 232    #DECL ((NOD N RPNOD) NODE (SPECD) <SPECIAL ANY>)
 233    <PROG ()
 234          <COND (<EMPTY? <KIDS .NOD>> <SET N .RPNOD>)
 235                (<SET NN <RET-AGAIN-ONLY <NODE-NAME <1 <KIDS .NOD>>>>>
 236                 <SET N .NN>)
 237                (ELSE <VAR-STORE <>> <RETURN <SUBR-GEN .NOD .WHERE>>)>
 238          <COND (<SET NOT-HANDLED-PROG
 239                      <NOT <OR <==? <NODE-SUBR .N> ,PROG>
 240                               <==? <NODE-SUBR .N> ,REPEAT>
 241                               <==? <NODE-SUBR .N> ,BIND>>>>
 242                 <VAR-STORE>)>
 243          <COND (<N==? .N <1 .SPEC-LIST>>
 244                 <REPEAT ((L1 ()) (LL .SPEC-LIST))
 245                         #DECL ((LL L1) LIST)
 246                         <AND <EMPTY? <SET L1 <REST .LL 3>>> <RETURN>>
 247                         <AND <2 .LL> <SET SPECD <3 .LL>>>
 248                         <COND (<==? <4 .LL> .N>
 249                                <RETURN <SET PRE <PRE-ALLOC <1 .LL>>>>)
 250                               (ELSE <SET LL .L1>)>>)>
 251          <COND (.PRE <POP:LOCS .STK <BTP-B .N>> <UNBIND:FUNNY .SPECD !.NTSLOTS>)
 252                (ELSE <UNBIND:LOCS .STK <BTP-B .N>>)>
 253          <OR .NOT-HANDLED-PROG <PROG ((STK <BTP-B .N>)) #DECL ((STK) <SPECIAL LIST>)
 254                                         <AGAIN-UP .N>>>
 255          <BRANCH:TAG <ATAG .N>>
 256          ,NO-DATUM>>
 257
 258 " Generate code for a GO in a PROG/REPEAT."
 259
 260 <DEFINE GO-GEN (NOD WHERE "AUX" (N <1 <KIDS .NOD>>) (RT <RESULT-TYPE .N>))
 261         #DECL ((NOD N) NODE (WHERE) <OR ATOM DATUM>)
 262         <VAR-STORE>
 263         <COND (<==? .RT ATOM>
 264                <POP:LOCS .STK <BTP-B .RPNOD>>
 265                <REGSTO T>
 266                <BRANCH:TAG <UNIQUE:TAG <NODE-NAME <1 <KIDS .NOD>>> <>>>)
 267               (ELSE
 268                <RET-TMP-AC <STACK:ARGUMENT <GEN .N DONT-CARE>>>
 269                <REGSTO T>
 270                <EMIT '<MCALL!-OP!-PACKAGE 1 GO>>)>
 271         ,NO-DATUM>
 272
 273 <DEFINE TAG-GEN (NOD WHERE
 274                  "AUX" (ATM <UNIQUE:TAG <NODE-NAME <1 <KIDS .NOD>>> <>>))
 275         #DECL ((NOD) NODE)
 276         <EMIT <INSTRUCTION `MOVEI  `O  .ATM>>
 277         <EMIT '<`SUBI  `O  `(M) >>
 278         <EMIT '<`PUSH  `TP*  <TYPE-WORD!-OP!-PACKAGE FIX>>>
 279         <EMIT '<`PUSH  `TP*  0>>
 280         <REGSTO T>
 281         <EMIT '<`PUSHJ  `P*  |MAKACT >>
 282         <EMIT '<`PUSH  `TP*  `A >>
 283         <EMIT '<`PUSH  `TP*  `B >>
 284         <EMIT '<MCALL!-OP!-PACKAGE 2 TAG>>
 285         <MOVE:ARG <FUNCTION:VALUE T> .WHERE>>
 286
 287
 288 " Generate code to flush stack for leaving a PROG etc."
 289
 290 <DEFINE PROG:UNBIND ()
 291         #DECL ((STK STB) LIST (PNOD) NODE)
 292         <COND (.PRE
 293                <POP:LOCS .STK .STB>
 294                <UNBIND:FUNNY <SPECS-START .PNOD> !.NTSLOTS>)
 295               (ELSE <UNBIND:LOCS .STK .STB>)>>
 296
 297 "\f"
 298
 299 "ROUTINES TO ALLOW KEEPING VARIABLES IN AC'S THRU LOOPS.  THE OUTINES KEEP INFORMATION
 300  IN THE PROG NODE TELLING INFORMATION AT VARIOUS POINTS (I.E. AGAIN AND RETURN POINTS).
 301  VARIABLES KEPT IN ACS WILL CONTAIN POINTERS TO THE PROG NODES INVOLVED AND THE DECISION
 302  WILL BE MADE TO KEEP THEM IN AC'S WHEN THEY ARE FIRST REFERENCED.  AGAINS AND RETURNS
 303  WILL EMIT NULL MACROS AND A FIXUP ROUTINE WILL BE USED AT THE END TO COERCE THE STATES
 304  CORRECTLY."
 305
 306 "ROUTINE TO INITIALIZE STATE INFORMATION ON ENTERING LOOPS.  IT TAKES A PROG/REPEAT NODE
 307  AND WILL UPDATE INFORMATION CONTAING SLOTS AS WELL AS PUTTING THE NODE INTO PROG-AC
 308  SLOTS OF APPROPRIATE SYMTABS. THE SLOTS MAY CONTAIN MULTIPLE PROG NODES BUT THE ONE
 309  CURRENTLY BEING HACKED WILL BE FIRST.  IF FLUSHING A VAR THE ENTIRE SLOT WILL BE
 310  FLUSHED."
 311
 312 <DEFINE PROG-START-AC (PNOD "AUX" (PVARS ()) ONSYMT OPROG-AC OPOTLV)
 313         #DECL ((PNOD) NODE)
 314         <MAPF <>
 315               <FUNCTION (AC "AUX" SYMT)
 316                       #DECL ((AC) AC)
 317                       <COND (<SET SYMT <CLEAN-AC .AC>>
 318                              <COND (<NOT <MEMQ .PNOD <PROG-AC .SYMT>>>
 319                                     <SET ONSYMT <NUM-SYM .SYMT>>
 320                                     <SMASH-NUM-SYM .SYMT>
 321                                     <SET OPROG-AC <PROG-AC .SYMT>>
 322                                     <SET OPOTLV <POTLV .SYMT>>
 323                                     <PUT .SYMT ,POTLV <>>
 324                                     <PUT .SYMT
 325                                          ,PROG-AC
 326                                          (.PNOD
 327                                           TMP
 328                                           <STORED .SYMT>
 329                                           <DATUM <DATTYP <INACS .SYMT>>
 330                                                  <DATVAL <INACS .SYMT>>>)>
 331                                     <SET PVARS
 332                                          (.SYMT
 333                                           .ONSYMT
 334                                           .OPROG-AC
 335                                           .OPOTLV
 336                                           !.PVARS)>)>)>>
 337               ,ALLACS>
 338         <PUT .PNOD ,LOOP-VARS ()>
 339         <PUT .PNOD ,AGAIN-STATES ()>
 340         <PUT .PNOD ,RETURN-STATES ()>
 341         <PUT .PNOD ,PROG-VARS .PVARS>
 342         <VAR-STORE <>>
 343         <REPEAT ((PTR .PVARS) SYMT)
 344                 <COND (<EMPTY? .PTR> <RETURN>)>
 345                 <SET SYMT <SYM-SLOT .PTR>>
 346                 <OR <STORED-SLOT <PROG-AC .SYMT>>
 347                     <PUT <PROG-AC .SYMT> ,NUM-SYM-SLOT <2 <NUM-SYM .SYMT>>>>
 348                 <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>>
 349
 350 <DEFINE CLEAN-AC (AC "AUX" ACRES INAC OAC)
 351    #DECL ((AC) AC (INAC) DATUM)
 352    <COND
 353     (<SET ACRES <ACRESIDUE .AC>>
 354      <PUT .AC ,ACRESIDUE <>>
 355      <MAPF <>
 356       <FUNCTION (SYM)
 357          <COND
 358           (<TYPE? .SYM SYMTAB>
 359            <MAPF <>
 360                  <FUNCTION (SYMT)
 361                          <COND (<N==? .SYMT .SYM>
 362                                 <COND (<OR <NOT <TYPE? .SYMT SYMTAB>>
 363                                            <STORED .SYMT>>
 364                                        <SMASH-INACS .SYMT <>>)
 365                                       (ELSE <STOREV .SYMT T>)>)>>
 366                  .ACRES>
 367            <COND
 368             (<AND <SET INAC <INACS .SYM>>
 369                   <OR <AND <==? <DATTYP .INAC> .AC>
 370                            <TYPE? <SET OAC <DATVAL .INAC>> AC>>
 371                       <AND <==? <DATVAL .INAC> .AC>
 372                            <TYPE? <SET OAC <DATTYP .INAC>> AC>>>>
 373              <MAPF <>
 374                    <FUNCTION (SYMT)
 375                            <COND (<N==? .SYMT .SYM>
 376                                   <COND (<OR <NOT <TYPE? .SYMT SYMTAB>>
 377                                              <STORED .SYMT>>
 378                                          <SMASH-INACS .SYMT <>>)
 379                                         (ELSE <STOREV .SYMT T>)>)>>
 380                    <ACRESIDUE .OAC>>
 381              <PUT .OAC ,ACRESIDUE (.SYM)>)>
 382            <PUT .AC ,ACRESIDUE (.SYM)>
 383            <MAPLEAVE <1 <ACRESIDUE .AC>>>)
 384           (ELSE <SMASH-INACS .SYM <>> <>)>>
 385       .ACRES>)>>
 386
 387 <DEFINE AGAIN-UP (PNOD "OPTIONAL" (RET <>) "AUX" CSTATE)
 388         #DECL ((PNOD) NODE (RET) <OR ATOM FALSE>)
 389         <SET CSTATE <CURRENT-AC-STATE>>
 390         <PUT .PNOD
 391              ,AGAIN-STATES
 392              (.CSTATE .CODE:PTR <STACK:INFO> .RET !<AGAIN-STATES .PNOD>)>>
 393
 394 <DEFINE RETURN-UP (PNOD "OPTIONAL" (STK .STB) "AUX" CSTATE)
 395         #DECL ((PNOD) NODE (STK) <SPECIAL LIST>)
 396         <COND (<NOT <AND <OR <==? <NODE-SUBR .PNOD> ,PROG>
 397                              <==? <NODE-SUBR .PNOD> ,BIND>>
 398                          <NOT <AGND .PNOD>>>>
 399                <SET CSTATE <CURRENT-AC-STATE .PNOD>>
 400                <PUT .PNOD
 401                     ,RETURN-STATES
 402                     (.CSTATE
 403                      .CODE:PTR
 404                      <STACK:INFO>
 405                      T
 406                      !<RETURN-STATES .PNOD>)>)>>
 407
 408 <DEFINE STACK:INFO ()
 409         (.FRMS .BSTB .NTSLOTS .STK)>
 410 "\f"
 411
 412 "OK FOLKS HERE IT IS.  THIS IS THE ROUTINE THAT MERGES ALL THE STATES IN LOOPS
 413  AND DOES THE RIGHT THING IN ALL CASES (MAYBE?).  IT TAKES A PROG AND MAKES SURE
 414  THAT STATES ARE CONSISTENT AT AGAIN AND RETURN POINTS.  FOR AGAIN POINTS IT
 415  MAKES SURE THAT ALL LOOP VARIABLES IN THE RIGHT ACS."
 416
 417 <DEFINE CLEANUP-STATE (PNOD
 418                        "AUX" (LOOPVARS <LOOP-VARS .PNOD>)
 419                              (AGAIN-ST <AGAIN-STATES .PNOD>)
 420                              (RETURN-ST <RETURN-STATES .PNOD>))
 421         #DECL ((PNOD) NODE (RETURN-ST) <SPECIAL LIST>)
 422         <FIXUP-STORES .AGAIN-ST>
 423         <FIXUP-STORES .RETURN-ST>
 424         <CLEANUP-VARS <PROG-VARS .PNOD>>
 425         <LOOP-REPEAT .LOOPVARS .AGAIN-ST>
 426         <LOOP-RETURN .RETURN-ST>>
 427
 428 <DEFINE LOOP-REPEAT (LOOPVARS AGAIN-ST)
 429    <REPEAT ((APTR .AGAIN-ST) REST-CODE-PTR)
 430            #DECL ((APTR)
 431                   <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>
 432                   (REST-CODE-PTR)
 433                   LIST)
 434            <COND (<EMPTY? .APTR> <RETURN>)>
 435            <SET REST-CODE-PTR <REST <SAVED-CODE:PTR .APTR>>>
 436            <LOOP-RESTORE <LIST !.LOOPVARS>
 437                          <SAVED-CODE:PTR .APTR>
 438                          <SAVED-AC-STATE .APTR>
 439                          <SAVED-STACK-STATE .APTR>
 440                          <SAVED-RET-FLAG .APTR>>
 441            <COND
 442             (<SAVED-RET-FLAG .APTR>
 443              <SET RETURN-ST
 444                   (<SAVED-AC-STATE .APTR>
 445                    <MAPR <>
 446                          <FUNCTION (CP "AUX" (RCP <REST .CP>))
 447                                  #DECL ((CP) <LIST ANY> (RCP) LIST)
 448                                  <COND (<==? .RCP .REST-CODE-PTR>
 449                                         <MAPLEAVE .CP>)>>
 450                          <SAVED-CODE:PTR .APTR>>
 451                    <SAVED-STACK-STATE .APTR>
 452                    T
 453                    !.RETURN-ST)>)>
 454            <SET APTR <REST .APTR ,LENGTH-CONTROL-STATE>>>>
 455
 456 <DEFINE LOOP-RESTORE (LPV INST ACS STACK-INFO RET)
 457         #DECL ((LPV INST STACK-INFO) <PRIMTYPE LIST> (ACS) REP-STATE
 458                (RET) <OR ATOM FALSE>)
 459         <PROG ((SCODE:PTR .INST) (BSTB <SAVED-BSTB .STACK-INFO>)
 460                (FRMS <SAVED-FRMS .STACK-INFO>)
 461                (NTSLOTS <SAVED-NTSLOTS .STACK-INFO>)
 462                (STK <SAVED-STK .STACK-INFO>))
 463               #DECL ((NTSLOTS BSTB FRMS STK SCODE:PTR) <SPECIAL LIST>)
 464               <STORE-SAVED-ACS .LPV .ACS>
 465               <MOVE-AROUND-ACS .LPV .ACS .RET>
 466               <GET-ACS-FROM-STACK .LPV .ACS>>>
 467
 468 <DEFINE MOVE-AROUND-ACS (LPV ACS RET)
 469         #DECL ((LPV) LIST (ACS) REP-STATE (RET) <OR ATOM FALSE>)
 470         <REPEAT ((LPVP .LPV) CSYMT CINACS INAC)
 471                 #DECL ((SYMT) SYMTAB (CINACS) DATUM)
 472                 <COND (<EMPTY? .LPVP> <RETURN>)>
 473                 <SET CSYMT <LSYM-SLOT .LPVP>>
 474                 <SET CINACS <LINACS-SLOT .LPVP>>
 475                 <COND (<SET INAC <AC? .CSYMT .ACS>>
 476                        <PUT .LPVP ,LSYM-SLOT <>>
 477                        <COND (<OR <=? .INAC .CINACS>
 478                                   <AND <TYPE? <DATTYP .CINACS> ATOM>
 479                                        <==? <DATVAL .CINACS> <DATVAL .INAC>>>>)
 480                              (<TYPE? <DATTYP .CINACS> ATOM>
 481                               <ONE-EXCH-AC .CINACS
 482                                            .INAC
 483                                            .ACS
 484                                            .CSYMT
 485                                            .RET
 486                                            .LPV>)
 487                              (<TWO-AC-EXCH .CINACS
 488                                            .INAC
 489                                            .ACS
 490                                            .CSYMT
 491                                            .RET
 492                                            .LPV>)>)>
 493                 <SET LPVP <REST .LPVP ,LOOPVARS-LENGTH>>>>
 494
 495 <DEFINE ONE-EXCH-AC (DEST-INAC CURR-INAC ACS CSYMT RET LPV
 496                      "AUX" (DEST-AC <DATVAL .DEST-INAC>)
 497                            (NOEXCH
 498                             <AND <NOT <AND .RET <ACLINK .DEST-AC>>>
 499                                  <EMPTY? <NTH .ACS <ACNUM .DEST-AC>>>>))
 500         #DECL ((DEST-INAC CURR-INAC) <DATUM ANY AC> (ACS) REP-STATE
 501                (DEST-AC) AC)
 502         <SEMIT <INSTRUCTION <COND (.NOEXCH `MOVE ) (ELSE `EXCH )>
 503                             <ACSYM <DATVAL .DEST-INAC>>
 504                             <ADDRSYM <DATVAL .CURR-INAC>>>>
 505         <SWAP-INAC <DATVAL .CURR-INAC>
 506                    <DATVAL .DEST-INAC>
 507                    .ACS
 508                    .CSYMT
 509                    .RET
 510                    .NOEXCH
 511                    .LPV>>
 512
 513 <DEFINE TWO-AC-EXCH (DEST-INAC CURR-INAC ACS CSYMT RET LPV
 514                      "AUX" (DTAC <DATTYP .DEST-INAC>)
 515                            (DVAC <DATVAL .DEST-INAC>)
 516                            (TDONTEXCH
 517                             <AND <NOT <AND .RET <ACLINK .DTAC>>>
 518                                  <NTH .ACS <ACNUM .DTAC>>>)
 519                            (VDONTEXCH
 520                             <AND <NOT <AND .RET <ACLINK .DVAC>>>
 521                                  <NTH .ACS <ACNUM .DVAC>>>))
 522    #DECL ((DEST-INAC CURR-INAC) DATUM)
 523    <COND
 524     (<TYPE? <DATTYP .CURR-INAC> AC>
 525      <COND
 526       (<==? <DATTYP .CURR-INAC> .DTAC>
 527        <ONE-EXCH-AC .DEST-INAC .CURR-INAC .ACS .CSYMT .RET .LPV>)
 528       (<==? .DTAC <DATVAL .CURR-INAC>>
 529        <SEMIT <INSTRUCTION <COND (.TDONTEXCH `MOVE ) (ELSE `EXCH )>
 530                            <ACSYM .DTAC>
 531                            <ADDRSYM <DATTYP .CURR-INAC>>>>
 532        <SWAP-INAC <DATTYP .CURR-INAC>
 533                   <DATTYP .DEST-INAC>
 534                   .ACS
 535                   .CSYMT
 536                   .RET
 537                   .TDONTEXCH
 538                   .LPV>
 539        <COND (<==? .DVAC <DATVAL .CURR-INAC>>)
 540              (ELSE
 541               <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
 542                                   <ACSYM .DVAC>
 543                                   <ADDRSYM <DATVAL .CURR-INAC>>>>
 544               <SWAP-INAC <DATVAL .CURR-INAC>
 545                          <DATVAL .DEST-INAC>
 546                          .ACS
 547                          .CSYMT
 548                          .RET
 549                          .VDONTEXCH
 550                          .LPV>)>)
 551       (ELSE
 552        <SEMIT <INSTRUCTION <COND (.TDONTEXCH `MOVE ) (ELSE `EXCH )>
 553                            <ACSYM .DTAC>
 554                            <ADDRSYM <DATTYP .CURR-INAC>>>>
 555        <SWAP-INAC <DATTYP .CURR-INAC>
 556                   <DATTYP .DEST-INAC>
 557                   .ACS
 558                   .CSYMT
 559                   .RET
 560                   .TDONTEXCH
 561                   .LPV>
 562        <COND (<==? <DATVAL .DEST-INAC> <DATVAL .CURR-INAC>>)
 563              (ELSE
 564               <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
 565                                   <ACSYM .DVAC>
 566                                   <ADDRSYM <DATVAL .CURR-INAC>>>>
 567               <SWAP-INAC <DATVAL .CURR-INAC>
 568                          <DATVAL .DEST-INAC>
 569                          .ACS
 570                          .CSYMT
 571                          .RET
 572                          .VDONTEXCH
 573                          .LPV>)>)>)
 574     (<COND (<==? <DATVAL .CURR-INAC> .DVAC>)
 575            (ELSE
 576             <SEMIT <INSTRUCTION <COND (.VDONTEXCH `MOVE ) (ELSE `EXCH )>
 577                                 <ACSYM .DVAC>
 578                                 <ADDRSYM <DATVAL .CURR-INAC>>>>
 579             <SWAP-INAC <DATVAL .CURR-INAC>
 580                        <DATVAL .DEST-INAC>
 581                        .ACS
 582                        .CSYMT
 583                        .RET
 584                        .VDONTEXCH
 585                        .LPV>)>
 586      <SEMIT <INSTRUCTION `MOVE  <ACSYM .DTAC> !<ADDR:TYPE .CURR-INAC>>>)>>
 587
 588 "\f"
 589
 590 <DEFINE CURRENT-AC-STATE ("OPTIONAL" (RETPNOD <>) "AUX" (BST ()) PAC)
 591    #DECL ((VALUE) REP-STATE)
 592    <COND (.RETPNOD <SET BST <BINDING-STRUCTURE .RETPNOD>>)>
 593    <MAPF ,LIST
 594     <FUNCTION (AC "AUX" (ACR <ACRESIDUE .AC>) (SACR ()))
 595        <MAPF <>
 596         <FUNCTION (SYMT)
 597            <COND
 598             (<AND <TYPE? .SYMT SYMTAB> <NOT <MEMQ .SYMT .BST>>>
 599              <SET SACR
 600                   (.SYMT
 601                    <SINACS .SYMT>
 602                    <COND (<STORED .SYMT>
 603                           <OR <NOT <TYPE? <NUM-SYM .SYMT> LIST>>
 604                               <NOT <1 <NUM-SYM .SYMT>>>
 605                               <L? <LENGTH <NUM-SYM .SYMT>> 2>
 606                               <2 <NUM-SYM .SYMT>>>)>
 607                    <AND <SET PAC <PROG-AC .SYMT>>
 608                         <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>
 609                    !.SACR)>)>>
 610         .ACR>
 611        .SACR>
 612     ,ALLACS>>
 613
 614
 615 <DEFINE LVAL-UP (SYMT "OPTIONAL" (PSLOT <PROG-AC .SYMT>) "AUX" PNAC)
 616    #DECL ((SYMT) SYMTAB)
 617    <COND
 618     (<AND .PSLOT
 619           <SET PNAC <PROG-SLOT .PSLOT>>
 620           <NOT <MEMQ .SYMT <LOOP-VARS .PNAC>>>>
 621      <COND (<INACS .SYMT>
 622             <PUT .PNAC
 623                  ,LOOP-VARS
 624                  (.SYMT <INACS-SLOT .PSLOT> !<LOOP-VARS .PNAC>)>
 625             <COND (<STORED-SLOT .PSLOT>) (<KILL-STORE <NUM-SYM-SLOT .PSLOT>>)>
 626             <COND (<NOT <POTLV .SYMT>> <PUT .SYMT ,STORED <>>)>
 627             <REPEAT ((PTR <PROG-VARS .PNAC>))
 628                     #DECL ((PTR) LIST)
 629                     <COND (<EMPTY? .PTR> <RETURN>)>
 630                     <COND (<==? .SYMT <SYM-SLOT .PTR>>
 631                            <LVAL-UP .SYMT <SAVED-PROG-AC-SLOT .PTR>>
 632                            <RETURN>)>
 633                     <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>)
 634            (ELSE <KILL-LOOP-AC .SYMT>)>)>>
 635
 636 "\f"
 637
 638 <DEFINE STORE-SAVED-ACS (LPV ACS "AUX" CINAC)
 639    #DECL ((LPV) LIST (ACS) REP-STATE)
 640    <MAPF <>
 641     <FUNCTION (ONE-ACS AC)
 642             #DECL ((ONE-ACS) LIST)
 643             <REPEAT ((PTR .ONE-ACS) SYMT)
 644                     #DECL ((PTR) LIST (SYMT) SYMBOL)
 645                     <COND (<EMPTY? .PTR> <RETURN>)
 646                           (<AND <NOT <MEMQ <SET SYMT <CSYMT-SLOT .PTR>> .LPV>>
 647                                 <NOT <AND <TYPE? <DATTYP <SET CINAC <CINACS-SLOT .PTR>>>
 648                                                  AC>
 649                                           <==? .AC <DATTYP .CINAC>>
 650                                           <TYPE? <DATVAL .CINAC> AC>>>>
 651                            <SPEC-STOREV .SYMT .CINAC <CSTORED-SLOT .PTR>>
 652                            <PUT .PTR ,CSTORED-SLOT T>)>
 653                     <SET PTR <REST .PTR ,LENGTH-CSTATE>>>>
 654     .ACS
 655     ,ALLACS>>
 656
 657 <DEFINE AC? (SYMT ACS)
 658         #DECL ((SYMT) SYMTAB (ACS) LIST)
 659         <MAPF <>
 660               <FUNCTION (AC)
 661                       #DECL ((AC) LIST)
 662                       <REPEAT ((PTR .AC))
 663                               #DECL ((PTR) LIST)
 664                               <COND (<EMPTY? .PTR> <RETURN <>>)>
 665                               <COND (<==? <CSYMT-SLOT .PTR> .SYMT>
 666                                      <MAPLEAVE <CINACS-SLOT .PTR>>)>
 667                               <SET PTR <REST .PTR ,LENGTH-CSTATE>>>>
 668               .ACS>>
 669
 670 "THIS ROUTINE SWAPS PORTIONS OF DATUMS.  IT TAKES TWO ACS AND THE ACS LIST AND SWAPS THE
 671  INFORMATION IN THE ACS LIST. AC2 IS THE GOAL AC AND ENDS UP CONTAINING ONLY ONE DATUM."
 672
 673 <DEFINE SWAP-INAC (AC1 AC2 ACS SYMT RET NOEXCH LPV
 674                    "AUX" (NUM1 <ACNUM .AC1>) (NUM2 <ACNUM .AC2>) SWDAT1 SWDAT2
 675                          (ACL1 <ACLINK .AC1>) (ACL2 <ACLINK .AC2>) (PUTR ()))
 676    #DECL ((AC1 AC2) AC (NUM1 NUM2) FIX (ACS) REP-STATE (RET) <OR ATOM FALSE>
 677           (LPV) LIST)
 678    <COND (<AND .RET <NOT .NOEXCH>>
 679           <SWAP-DATUMS .ACL1 .AC1 .AC2>
 680           <SWAP-DATUMS .ACL2 .AC2 .AC1>
 681           <PUT .AC2 ,ACLINK .ACL1>
 682           <PUT .AC1 ,ACLINK .ACL2>)>
 683    <SET SWDAT1 <NTH .ACS .NUM1>>
 684    <SET SWDAT2 <NTH .ACS .NUM2>>
 685    <REPEAT ((PTR .SWDAT1) SUB-PTR)
 686      #DECL ((PTR) LIST)
 687      <COND (<EMPTY? .PTR> <RETURN>)>
 688      <COND
 689       (<AND
 690         <SET SUB-PTR <MEMQ .AC1 <CINACS-SLOT .PTR>>>
 691         <OR
 692          <NOT .NOEXCH>
 693          <==? .SYMT <CSYMT-SLOT .PTR>>
 694          <REPEAT ((S <CSYMT-SLOT .PTR>) (LP .LPV)
 695                   (DV <==? .AC1 <DATVAL <CINACS-SLOT .PTR>>>))
 696            #DECL ((LP) LIST)
 697            <COND (<EMPTY? .LP> <RETURN>)>
 698            <COND (<==? <LSYM-SLOT .LP> .S>
 699                   <COND (.DV <RETURN <==? <DATVAL <LINACS-SLOT .LP>> .AC2>>)
 700                         (ELSE
 701                          <RETURN <==? <DATTYP <LINACS-SLOT .LP>> .AC2>>)>)>
 702            <SET LP <REST .LP ,LOOPVARS-LENGTH>>>>>
 703        <SET PUTR (.SUB-PTR .AC2 !.PUTR)>)>
 704      <SET PTR <REST .PTR ,LENGTH-CSTATE>>>
 705    <COND (<NOT .NOEXCH>
 706           <REPEAT ((PTR .SWDAT2) SUB-PTR)
 707                   #DECL ((PTR) LIST)
 708                   <COND (<EMPTY? .PTR> <RETURN>)>
 709                   <COND (<SET SUB-PTR <MEMQ .AC2 <CINACS-SLOT .PTR>>>
 710                          <SET PUTR (.SUB-PTR .AC1 !.PUTR)>)>
 711                   <SET PTR <REST .PTR ,LENGTH-CSTATE>>>)>
 712    <REPEAT ()
 713            <COND (<EMPTY? .PUTR> <RETURN>)>
 714            <PUT <1 .PUTR> 1 <2 .PUTR>>
 715            <SET PUTR <REST .PUTR 2>>>
 716    <COND (<NOT .NOEXCH> <PUT .ACS .NUM1 .SWDAT2>)>
 717    <PUT .ACS .NUM2 .SWDAT1>>
 718
 719 <DEFINE SWAP-DATUMS (ACL ACOLD ACNEW)
 720         #DECL ((ACL) <OR FALSE <LIST [REST DATUM]>>)
 721         <MAPF <>
 722               <FUNCTION (DAT "AUX" ACLTEM)
 723                       #DECL ((DAT) DATUM)
 724                       <COND (<SET ACLTEM <MEMQ .ACOLD .DAT>>
 725                              <PUT .ACLTEM 1 .ACNEW>)
 726                             (ELSE <MESSAGE INCONSISTENCY "BAD ACLINK">)>>
 727               .ACL>>
 728
 729 <DEFINE GET-ACS-FROM-STACK (LPV ACS)
 730    #DECL ((LPV) LIST (ACS) REP-STATE)
 731    <REPEAT ((LPVP .LPV) DAT DAT2)
 732            #DECL ((LPVP) LIST (DAT) DATUM)
 733            <COND (<EMPTY? .LPVP> <RETURN>)>
 734            <COND (<LSYM-SLOT .LPVP>
 735                   <PUT  <LSYM-SLOT .LPVP> ,INACS <>>
 736                   <SET DAT2 <LADDR <LSYM-SLOT .LPVP> <> <>>>
 737                   <SET DAT <LINACS-SLOT .LPVP>>
 738                   <COND (<TYPE? <DATTYP .DAT> AC>
 739                          <SEMIT <INSTRUCTION
 740                                  `MOVE
 741                                  <ACSYM <DATTYP .DAT>>
 742                                  !<ADDR:TYPE .DAT2>>>)>
 743                   <SEMIT <INSTRUCTION `MOVE
 744                                       <ACSYM <DATVAL .DAT>>
 745                                       !<ADDR:VALUE .DAT2>>>)>
 746            <SET LPVP <REST .LPVP ,LOOPVARS-LENGTH>>>>
 747
 748 "\f"
 749
 750 <DEFINE NON-LOOP-CLEANUP (N "AUX" (B <BINDING-STRUCTURE .N>))
 751         #DECL ((N) NODE (B) <LIST [REST SYMTAB]>)
 752         <MAPF <>
 753               <FUNCTION (S "AUX" (INA <INACS .S>))
 754                 #DECL ((S) SYMTAB)
 755                 <COND (.INA
 756                        <COND (<TYPE? <DATTYP .INA> AC>
 757                               <FLUSH-RESIDUE <DATTYP .INA> .S>)>
 758                        <COND (<TYPE? <DATVAL .INA> AC>
 759                               <FLUSH-RESIDUE <DATVAL .INA> .S>)>)>
 760                 <PUT .S ,INACS <>>
 761                 <PUT .S ,STORED T>>
 762               .B>>
 763
 764 "ROUTINES TO HANDLE LOOP-RETURNS."
 765
 766 <DEFINE LOOP-RETURN (RETINFO "AUX" LST)
 767         #DECL ((LST RETINFO) LIST)
 768         <MAPF <>
 769               <FUNCTION (AC "AUX" ACR)
 770                       #DECL ((AC) AC)
 771                       <PUT .AC ,ACLINK <>>
 772                       <COND (<SET ACR <ACRESIDUE .AC>>
 773                              <MAPF <>
 774                                    <FUNCTION (IT) <SMASH-INACS .IT <> <>>>
 775                                    .ACR>)>
 776                       <PUT .AC ,ACRESIDUE <>>>
 777               ,ALLACS>
 778         <COND (<NOT <EMPTY? .RETINFO>>
 779                <SET LST <MERGE-RETURNS .RETINFO>>
 780                <REPEAT ((PTR .RETINFO))
 781                        #DECL ((PTR) LIST)
 782                        <COND (<EMPTY? .PTR> <RETURN>)>
 783                        <MERGE-SINGLE-RETURN
 784                         <SAVED-AC-STATE .PTR>
 785                         <SAVED-CODE:PTR .PTR>
 786                         .LST
 787                         <SAVED-STACK-STATE .PTR>>
 788                        <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>)>>
 789
 790 "ROUTINE TO FIGURE OUT A MERGE BETWEEN DIFFERENT RETURN POINTS.  IN THE END A LIST OF
 791  THINGS TO REMAIN IN AC'S ARE PRODUCED."
 792
 793 <DEFINE MERGE-RETURNS (RETINFO "AUX" (ACKEEP ()))
 794    #DECL ((ACKEEP) LIST
 795           (RETINFO) <LIST [REST
 796                            REP-STATE
 797                            <PRIMTYPE LIST>
 798                            LIST
 799                            <OR ATOM FALSE>]>)
 800    <REPEAT ((CNT 1) MERGER)
 801            #DECL ((CNT) FIX)
 802            <SET MERGER <LIST !<NTH <SAVED-AC-STATE .RETINFO> .CNT>>>
 803            <COND (<NOT <EMPTY? .MERGER>>
 804                   <REPEAT ((PTR <REST .RETINFO ,LENGTH-CONTROL-STATE>))
 805                           <COND (<EMPTY? .PTR> <RETURN>)>
 806                           <SET MERGER
 807                                <MERG-IT .MERGER
 808                                         <NTH <SAVED-AC-STATE .PTR> .CNT>>>
 809                           <COND (<EMPTY? .MERGER> <RETURN>)>
 810                           <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>)>
 811            <COND (<NOT <EMPTY? .MERGER>> <SET ACKEEP (!.MERGER !.ACKEEP)>)>
 812            <COND (<G? <SET CNT <+ .CNT 1>> 5> <RETURN>)>>
 813    .ACKEEP>
 814
 815 "ROUTINE TO FIGURE OUT IF THINGS MERGE"
 816
 817 <DEFINE MERG-IT (CURR-STATE NEW-STATE
 818                  "AUX" (OLD-STATE .CURR-STATE) SPTR INAC1 INAC2)
 819         #DECL ((CURR-STATE NEW-STATE) LIST)
 820         <COND (<AND <SET SPTR <MEMQ <CSYMT-SLOT .CURR-STATE> .NEW-STATE>>
 821                     <OR <=? <SET INAC1 <CINACS-SLOT .CURR-STATE>>
 822                             <SET INAC2 <CINACS-SLOT .SPTR>>>
 823                         <AND <==? <DATVAL .INAC1> <DATVAL .INAC2>>
 824                              <OR <AND <ISTYPE? <DATTYP .INAC1>>
 825                                       <PUT .SPTR ,CINACS-SLOT .INAC1>>
 826                                  <AND <ISTYPE? <DATTYP .INAC2>>
 827                                       <PUT .CURR-STATE
 828                                            ,CINACS-SLOT
 829                                            .INAC2>>>>>>
 830                <COND (<AND <CSTORED-SLOT .CURR-STATE> <CSTORED-SLOT .SPTR>>)
 831                      (<PUT .CURR-STATE ,CSTORED-SLOT <>>
 832                       <PUT .SPTR ,CSTORED-SLOT <>>)>)
 833               (<SET CURR-STATE <REST .CURR-STATE ,LENGTH-CSTATE>>)>
 834         <REPEAT ((PTR .CURR-STATE))
 835                 #DECL ((PTR) LIST)
 836                 <COND (<EMPTY? .PTR> <RETURN>)>
 837                 <COND (<AND <SET SPTR <MEMQ <CSYMT-SLOT .PTR> .NEW-STATE>>
 838                             <=? <CINACS-SLOT .SPTR> <CINACS-SLOT .CURR-STATE>>>
 839                        <COND (<AND <CSTORED-SLOT .CURR-STATE>
 840                                    <CSTORED-SLOT .SPTR>>)
 841                              (<PUT .CURR-STATE ,CSTORED-SLOT <>>
 842                               <PUT .SPTR ,CSTORED-SLOT <>>)>)
 843                       (ELSE  ;"THIS ELSE USED TO B <CSTORED-STATE .CURR-STATE>"
 844                        <COND (<==? .PTR .CURR-STATE>
 845                               <SET OLD-STATE .CURR-STATE>
 846                               <SET CURR-STATE
 847                                    <REST .CURR-STATE ,LENGTH-CSTATE>>)
 848                              (ELSE
 849                               <PUTREST <REST .OLD-STATE <- ,LENGTH-CSTATE 1>>
 850                                        <REST .PTR ,LENGTH-CSTATE>>
 851                               <SET PTR .OLD-STATE>)>)>
 852                 <SET OLD-STATE .PTR>
 853                 <SET PTR <REST .PTR ,LENGTH-CSTATE>>>
 854         .CURR-STATE>
 855
 856 <DEFINE MERGE-SINGLE-RETURN (THISRETURN INS MERGEDRETURN STACK-INFO
 857                              "AUX" SYMT (MS ()))
 858    #DECL ((INS THISRETURN MERGEDRETURN STACK-INFO) LIST
 859           (MS) <LIST [REST SYMTAB]>)
 860    <PROG ((SCODE:PTR .INS) (FRMS <SAVED-FRMS .STACK-INFO>)
 861           (BSTB <SAVED-BSTB .STACK-INFO>) (NTSLOTS <SAVED-NTSLOTS .STACK-INFO>)
 862           (STK <SAVED-STK .STACK-INFO>))
 863      #DECL ((FRMS BSTB NTSLOTS STK SCODE:PTR) <SPECIAL LIST>)
 864      <MAPF <>
 865       <FUNCTION (CP AC)
 866          #DECL ((AC) AC)
 867          <REPEAT ()
 868                  <COND (<EMPTY? .CP> <RETURN>)>
 869                  <COND (<AND <NOT <MEMQ <SET SYMT <CSYMT-SLOT .CP>>
 870                                         .MERGEDRETURN>>
 871                              <OR <==? .AC <DATVAL <CINACS-SLOT .CP>>>
 872                                  <NOT <TYPE? <DATVAL <CINACS-SLOT .CP>> AC>>>>
 873                         <SPEC-STOREV .SYMT <CINACS-SLOT .CP> <CSTORED-SLOT .CP>>
 874                         <FLUSH-RESIDUE .AC .SYMT>
 875                         <SET MS (.SYMT !.MS)>)
 876                        (<MEMQ .SYMT .MS> <FLUSH-RESIDUE .AC .SYMT>)
 877                        (ELSE
 878                         <PUT .SYMT ,STORED <CSTORED-SLOT .CP>>
 879                         <SMASH-INACS .SYMT <CINACS-SLOT .CP>>
 880                         <SMASH-ITEM-INTO-DATUM .SYMT <CINACS-SLOT .CP>>)>
 881                  <SET CP <REST .CP ,LENGTH-CSTATE>>>>
 882       .THISRETURN
 883       ,ALLACS>>>
 884
 885 <DEFINE SPEC-STOREV (SYMT INAC STORED)
 886         <SMASH-INACS .SYMT .INAC>
 887         <SMASH-ITEM-INTO-DATUM .SYMT .INAC>
 888         <FLUSH-SYMTAB-FROM-AC .SYMT>
 889         <COND (<TYPE? .SYMT SYMTAB>
 890                <AND <NOT .STORED>
 891                     <MAPF <>
 892                           ,SEMIT
 893                           <PROG ((CODE:TOP (())) (CODE:PTR .CODE:TOP))
 894                                 #DECL ((CODE:TOP CODE:PTR) <SPECIAL LIST>)
 895                                 <PUT .SYMT ,STORED <>>
 896                                 <STOREV .SYMT>
 897                                 <REST .CODE:TOP>>>>
 898                <PUT .SYMT ,STORED T>)>
 899         <SMASH-INACS .SYMT <>>>
 900
 901 <DEFINE CLEANUP-SYMT (SYM)
 902         #DECL ((SYM) SYMTAB)
 903         <PUT .SYM ,PROG-AC <>>
 904         <PUT .SYM ,NUM-SYM T>>
 905
 906 <DEFINE SEMIT (FRM)
 907         #DECL ((SCODE:PTR CODE:PTR) LIST)
 908         <PUTREST .SCODE:PTR (.FRM !<REST .SCODE:PTR>)>
 909         <COND (<==? .CODE:PTR .SCODE:PTR> <SET CODE:PTR <REST .CODE:PTR>>)>
 910         <SET SCODE:PTR <REST .SCODE:PTR>>>
 911
 912 "\f"
 913
 914 <DEFINE FLUSH-SYMTAB-FROM-AC (SYMT "AUX" (INAC <SINACS .SYMT>) AC)
 915         <COND (<TYPE? <SET AC <DATTYP .INAC>> AC>
 916                <FLUSH-RESIDUE .AC .SYMT>)>
 917         <COND (<TYPE? <SET AC <DATVAL .INAC>> AC>
 918                <FLUSH-RESIDUE .AC .SYMT>)>>
 919
 920 <DEFINE SMASH-ITEM-INTO-DATUM (SYM DAT "AUX" AC)
 921         #DECL ((SYM) SYMBOL (DAT) DATUM)
 922         <COND (<TYPE? <SET AC <DATTYP .DAT>> AC>
 923                <OR <MEMQ .SYM <ACRESIDUE .AC>>
 924                    <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>
 925         <COND (<TYPE? <SET AC <DATVAL .DAT>> AC>
 926                <OR <MEMQ .SYM <ACRESIDUE .AC>>
 927                    <PUT .AC ,ACRESIDUE (.SYM !<ACRESIDUE .AC>)>>)>>
 928
 929
 930 <DEFINE CLEANUP-VARS (VARLST)
 931         #DECL ((VARLST) LIST)
 932         <REPEAT ((PTR .VARLST) VAR)
 933                 <COND (<EMPTY? .PTR> <RETURN>)>
 934                 <PUT <SET VAR <SYM-SLOT .PTR>>
 935                      ,NUM-SYM
 936                      <SAVED-NUM-SYM-SLOT .PTR>>
 937                 <PUT .VAR ,PROG-AC <SAVED-PROG-AC-SLOT .PTR>>
 938                 <PUT .VAR ,POTLV <SAVED-POTLV-SLOT .PTR>>
 939                 <SET PTR <REST .PTR ,LENGTH-PROG-VARS>>>>
 940
 941 <DEFINE FIXUP-STORES (STATE)
 942    #DECL ((STATE) <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>)
 943    <REPEAT ((PTR .STATE))
 944      #DECL ((PTR) <LIST [REST REP-STATE <PRIMTYPE LIST> LIST <OR ATOM FALSE>]>)
 945      <COND (<EMPTY? .PTR> <RETURN>)>
 946      <MAPR <>
 947       <FUNCTION (STATE-ITEMS "AUX" SYMT PAC (STATE-ITEM <1 .STATE-ITEMS>))
 948          #DECL ((STATE-ITEMS) REP-STATE
 949                 (STATE-ITEM)
 950                  <LIST [REST SYMTAB DATUM <OR FALSE ATOM> <OR ATOM FALSE>]>
 951                 (PAC) <OR FALSE LIST> (SYMT) SYMTAB)
 952          <REPEAT ()
 953            <COND (<EMPTY? .STATE-ITEM> <RETURN>)>
 954            <SET SYMT <CSYMT-SLOT .STATE-ITEM>>
 955            <COND (<OR <CPOTLV-SLOT .STATE-ITEM>
 956                       <N==? <CSTORED-SLOT .STATE-ITEM> T>>
 957                   <COND (<OR <AND <N==? <CSTORED-SLOT .STATE-ITEM> T>
 958                                   <MEMQ <CSTORED-SLOT .STATE-ITEM> .KILL-LIST>>
 959                              <AND <CPOTLV-SLOT .STATE-ITEM>
 960                                   <CSTORED-SLOT .STATE-ITEM>
 961                                   <SET PAC <PROG-AC .SYMT>>
 962                                   <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>
 963                                   <NOT <STORED-SLOT .PAC>>>>
 964                          <PUT .STATE-ITEM ,CSTORED-SLOT <>>)>)>
 965            <COND (<AND <CPOTLV-SLOT .STATE-ITEM>
 966                        <OR <NOT <SET PAC <PROG-AC .SYMT>>>
 967                            <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>>
 968                   <SET STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>>)
 969                  (<RETURN>)>>
 970          <COND
 971           (<NOT <EMPTY? .STATE-ITEM>>
 972            <REPEAT ((START-STATE .STATE-ITEM)
 973                     (STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>))
 974              <COND (<EMPTY? .STATE-ITEM> <RETURN>)>
 975              <SET SYMT <CSYMT-SLOT .STATE-ITEM>>
 976              <COND
 977               (<OR <CPOTLV-SLOT .STATE-ITEM>
 978                    <N==? <CSTORED-SLOT .STATE-ITEM> T>>
 979                <COND (<OR <AND <N==? <CSTORED-SLOT .STATE-ITEM> T>
 980                                <MEMQ <CSTORED-SLOT .STATE-ITEM> .KILL-LIST>>
 981                           <AND <CPOTLV-SLOT .STATE-ITEM>
 982                                <CSTORED-SLOT .STATE-ITEM>
 983                                <SET PAC <PROG-AC .SYMT>>
 984                                <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>
 985                                <NOT <STORED-SLOT .PAC>>>>
 986                       <PUT .STATE-ITEM ,CSTORED-SLOT <>>)>)>
 987              <COND (<AND <CPOTLV-SLOT .STATE-ITEM>
 988                          <OR <NOT <SET PAC <PROG-AC .SYMT>>>
 989                              <NOT <MEMQ .SYMT <LOOP-VARS <PROG-SLOT .PAC>>>>>>
 990                     <PUTREST .START-STATE <REST .STATE-ITEM ,LENGTH-CSTATE>>)>
 991              <SET STATE-ITEM <REST .STATE-ITEM ,LENGTH-CSTATE>>
 992              <SET START-STATE <REST .START-STATE ,LENGTH-CSTATE>>>)>
 993          <PUT .STATE-ITEMS 1 .STATE-ITEM>>
 994       <SAVED-AC-STATE .PTR>>
 995      <SET PTR <REST .PTR ,LENGTH-CONTROL-STATE>>>>
 996
 997 <ENDPACKAGE>
 998 \f