<mdl.comp>/comcod.mud.45

   1 <PACKAGE "COMCOD">
   2
   3 <ENTRY MOVE:ARG ADDR:TYPE ADDR:VALUE MOVE:VALUE STEMP:ADDR MOVE:TYP EMIT
   4         D:B:TAG SEGMENT:LIST TUPLE:FINAL STORE:BIND LOCAL-TAGS TEST:ARGPNTR
   5         REFERENCE BRANCH:TAG PSLOT COPY:ARGPNTR BIND:END TIME:STACK
   6         ACT:FINAL PUSH:BIND TIME:CHECK START:TAG ISTAG? FAST:GVAL
   7         REFERENCE:ARGPNTR REFERENCE:ARG POP:LOCS SEGMENT:STACK PUSH:PAIR
   8         MAKE:ENV LABEL:TAG FAST:SETG BUMP:CNTR MAKE:ACT REFERENCE:STACK
   9         SPEC:REFERENCE:STACK ADDRESS:PAIR PCOUNTER STACK:ARGUMENT
  10         SALLOC:SLOTS FAST:VAL GEN:FALSE SUBR:CALL STORE:PAIR FIX-ACLINK
  11         BUMP:ARGPNTR COUNTP SEGMENT:FINAL TEST:ARG FUNCTION:VALUE
  12         REFERENCE:UNBOUND ACT:INITIAL UNBIND:LOCS FIX:ADDR FAST:SET PUSH:ATB
  13         UNIQUE:TAG ALLOC:SLOTS ADDR:TYPE1 PROG:END ADDR:VALUE1 FUNCTION:INITIAL
  14         REFERENCE:ADR ALLOCATE:SLOTS GETUVT UNBIND:FUNNY LABEL:OFF IMCHK
  15         CODE:PTR CODE:TOP BUILD:FRAME FRAMLN  CHECK-LOCAL-TAGS GROUP:INITIAL
  16         INT:LOSER:INITIAL INT:INITIAL SUB:INT:INITIAL FCN:INT:INITIAL
  17         SUB:INITIAL FS:INT:INITIAL RDCL INT:FINAL FS:INT:FINAL FCNSUB:FINAL
  18         ASSEM? TAG:COUNT>
  19
  20 <USE "CACS" "COMPDEC" "NPRINT" "CODGEN" "PEEPH" "CODING" "CHKDCL" "CUP">
  21
  22 <BLOCK (<ROOT>)>
  23
  24 CSOURCE
  25
  26 <ENDBLOCK>
  27
  28 <BLOCK (!.OBLIST <GET PACKAGE OBLIST>)>
  29
  30
  31
  32 "***** BEGINNING OF THE IMPLEMENTATION SECTION *****"
  33
  34 <DEFINE EMIT (INSTR)
  35         #DECL ((CODE:PTR) LIST)
  36         <PUTREST .CODE:PTR (.INSTR)>
  37         <SET CODE:PTR <REST .CODE:PTR>>>
  38
  39 <SETG BIND-BEGIN [<FORM (<CHTYPE <TYPE-C ATOM> FIX>) -1>]>
  40
  41 "Special datum meaning nothing returned."
  42
  43 <SETG NO-DATUM <CHTYPE (FLUSHED FLUSHED) DATUM>>
  44
  45 <NEWTYPE ADDRESS:C LIST>
  46
  47 <DEFINE ADDRESS:C ("TUPLE" T) <CHTYPE (!.T) ADDRESS:C>>
  48
  49 <NEWTYPE ADDRESS:PAIR LIST>
  50
  51 <DEFINE ADDRESS:PAIR ("TUPLE" T) <CHTYPE (!.T) ADDRESS:PAIR>>
  52
  53 <NEWTYPE TYPED:ADDRESS LIST>
  54
  55 <DEFINE TYPED:ADDRESS (TYP ADR)
  56         <CHTYPE (.TYP !<REFERENCE .ADR>) TYPED:ADDRESS>>
  57
  58 <NEWTYPE IRSUBR LIST>
  59
  60 ;"FUNNY FUDGES "
  61
  62 <OR <GASSIGNED? TDEFER!-OP> <SETG TDEFER!-OP <SQUOTA |TDEFER >>>
  63
  64 <OR <GASSIGNED? TTP!-OP> <SETG TTP!-OP <SQUOTA |TTP >>>
  65
  66 <OR <GASSIGNED? TTB!-OP> <SETG TTB!-OP <SQUOTA |TTB >>>
  67
  68 <SETG FRAMACT 9>
  69
  70 <SETG FRAMLN 7>
  71
  72 <DEFINE MAKE:TAG ("OPTIONAL" (STR "TAG") ATM)
  73         #DECL ((STR) STRING (ATM) ATOM (TAG:COUNT) FIX)
  74         <SET STR <STRING .STR <UNPARSE .TAG:COUNT>>>
  75         <SET TAG:COUNT <+ .TAG:COUNT 1>>
  76         <GUNASSIGN <SET ATM
  77                         <OR <LOOKUP .STR ,TMP:OBL> <INSERT .STR ,TMP:OBL>>>>
  78         .ATM>
  79
  80 <DEFINE BRANCH:TAG (TAG) <EMIT <INSTRUCTION `JRST  .TAG>>>
  81
  82 <DEFINE LABEL:TAG (TAG) <EMIT .TAG>>
  83
  84 <DEFINE ISTAG? (ATM)
  85         #DECL ((LOCAL-TAGS) LIST)
  86         <MAPF <>
  87               <FUNCTION (LL)
  88                       #DECL ((LL) <LIST ATOM>)
  89                       <COND (<==? <1 .LL> .ATM> <MAPLEAVE T>)>>
  90               .LOCAL-TAGS>>
  91
  92 <DEFINE UNIQUE:TAG (ATM DEF?)
  93         #DECL ((ATM) ATOM (DEF?) <OR ATOM FALSE> (LOCAL-TAGS) LIST)
  94         <COND (<MAPF <>
  95                      <FUNCTION (L)
  96                              #DECL ((L) <LIST ATOM ATOM <OR FALSE ATOM>>)
  97                              <COND (<==? <1 .L> .ATM>
  98                                     <COND (<AND .DEF? <3 .L>>
  99                                            <MESSAGE ERROR
 100                                                     "MULTIPLY DEFINED TAG "
 101                                                     .ATM>)>
 102                                     <AND .DEF? <PUT .L 3 T>>
 103                                     <MAPLEAVE <2 .L>>)>>
 104                      .LOCAL-TAGS>)
 105               (ELSE
 106                <SET LOCAL-TAGS
 107                     ((.ATM <SET ATM <MAKE:TAG <PNAME .ATM>>> .DEF?)
 108                      !.LOCAL-TAGS)>
 109                .ATM)>>
 110
 111 <DEFINE CHECK-LOCAL-TAGS (L "AUX" (LOSERS ()))
 112         #DECL ((L LOSERS) LIST)
 113         <MAPF <>
 114               <FUNCTION (LL)
 115                       #DECL ((LL) <LIST ATOM ATOM <OR ATOM FALSE>>)
 116                       <COND (<NOT <3 .LL>> <SET LOSERS (<1 .LL> !.LOSERS)>)>>
 117               .L>
 118         <COND (<NOT <EMPTY? .LOSERS>>
 119                <MESSAGE ERROR " UNDEFINED LABEL (S) " .LOSERS>)>>
 120
 121 <DEFINE LABEL:OFF (TAG)
 122         <COND (.GLUE <LABEL:TAG .TAG>)
 123               (<EMIT <INSTRUCTION
 124                       PSEUDO!-OP
 125                       <FORM SETG
 126                             .TAG
 127                             '<ANDB 262143 <CHTYPE .HERE!-OP FIX>>>>>)>>
 128
 129 <DEFINE TRUE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC T <>>>
 130
 131 <DEFINE FALSE:BRANCH:TAG (TAG SRC) <D:B:TAG .TAG .SRC <> <>>>
 132
 133 <DEFINE D:B:TAG (TAG SRC DIR TYP "AUX" DT)
 134         #DECL ((SRC) DATUM (DIR) <OR FALSE ATOM>)
 135         <COND (<AND .TYP
 136                     <SET DT <ISTYPE? <TYPE-AND .TYP '<NOT FALSE>>>>
 137                     <OR <MEMQ .DT '![CHANNEL RSUBR ATOM!]>
 138                         <AND <MEMQ <TYPEPRIM .DT> '![UVECTOR VECTOR!]>
 139                              <G? <MINL .DT> 0>>>>
 140                <COND (<TYPE? <SET DT <DATVAL .SRC>> AC>
 141                       <EMIT <INSTRUCTION <COND (.DIR `JUMPL ) (ELSE `JUMPGE )>
 142                                          <ACSYM .DT>
 143                                          .TAG>>)
 144                      (ELSE
 145                       <EMIT <INSTRUCTION <COND (.DIR `SKIPGE ) (ELSE `SKIPL )>
 146                                          !<ADDR:VALUE .SRC>>>
 147                       <BRANCH:TAG .TAG>)>)
 148               (ELSE
 149                <EMIT <INSTRUCTION GETYP!-OP `O*  !<ADDR:TYPE .SRC>>>
 150                <EMIT <INSTRUCTION <COND (.DIR `CAIE ) (ELSE `CAIN )>
 151                                   `O*
 152                                   '<TYPE-CODE!-OP FALSE>>>
 153                <BRANCH:TAG .TAG>)>>
 154
 155 <DEFINE GEN:FALSE () <EMIT <INSTRUCTION `PUSHJ  `P*  |RTFALS >>>
 156
 157 <DEFINE SUBR:CALL (ADR ARG-NUMBER)
 158         <EMIT <INSTRUCTION MCALL!-OP .ARG-NUMBER .ADR>>>
 159
 160 <DEFINE FUNCTION:VALUE ("OPTIONAL" (ALLOC <>) "AUX" (DAT <DATUM ,AC-A ,AC-B>))
 161         <COND (.ALLOC
 162                <SGETREG <DATTYP .DAT> .DAT>
 163                <SGETREG <DATVAL .DAT> .DAT>)>
 164         .DAT>
 165
 166 <SETG TMP:OBL <MOBLIST <OR <LOOKUP "TMP" <ROOT>> <INSERT "TMP" <ROOT>>>>>
 167
 168 <DEFINE ADDR:TYPE (DAT "AUX" (TYP <DATTYP .DAT>))
 169         #DECL ((DAT) <DATUM ANY ANY>)
 170         <ADDR:TYPE1 .TYP>>
 171
 172 <DEFINE ADDR:TYPE1 (ADR "AUX" TT)
 173         <COND (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
 174               (<TYPE? .ADR ATOM> (<TYPE:SYM .ADR>))
 175               (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 0>)
 176               (<TYPE? .ADR ADDRESS:C> .ADR)
 177               (<TYPE? .ADR ADDRESS:PAIR> (<1 .ADR>))
 178               (<TYPE? .ADR OFFPTR>
 179                <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
 180                                                            `TB )>
 181                       (<1 .ADR> `(TB) ))
 182                      (ELSE
 183                       <TOACV <2 .ADR>>                  ;"FORCE INDEX INTO REG "
 184                       <COND (<AND <MEMQ <SET TT <3 .ADR>> <ALLTYPES>>
 185                                   <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
 186                              (<GETUVT <DATVAL <2 .ADR>>>))
 187                             (ELSE
 188                              (<1 .ADR>
 189                               !<COND (<==? <LENGTH .ADR> 4> <4 .ADR>)
 190                                      (ELSE (0))>
 191                               (<ADDRSYM <DATVAL <2 .ADR>>>)))>)>)>>
 192
 193 <DEFINE GETUVT (AC "OPTIONAL" (TOAC ,ACO) (NS <>) "AUX" TAC (P <ACPROT .AC>))
 194         #DECL ((AC TAC TOAC) AC)
 195         <PUT .AC ,ACPROT T>
 196         <EMIT <INSTRUCTION `HLRE
 197                            <ACSYM <SET TAC <GETREG <>>>>
 198                            <ADDRSYM .AC>>>
 199         <EMIT <INSTRUCTION `SUBM  <ACSYM .AC> <ADDRSYM .TAC>>>
 200         <PUT .AC ,ACPROT .P>
 201         <EMIT <INSTRUCTION GETYP!-OP <ACSYM .TOAC> (<ADDRSYM .TAC>)>>
 202         <OR .NS <EMIT <INSTRUCTION `HRLZS  <ADDRSYM .TOAC>>>>
 203         <ADDRSYM .TOAC>>
 204
 205 <DEFINE TYPE:SYM (NAME) <FORM TYPE-WORD!-OP .NAME>>
 206
 207 <DEFINE ADDR:VALUE (DAT "AUX" (VAL <DATVAL .DAT>))
 208         #DECL ((DAT) <DATUM ANY ANY>)
 209         <ADDR:VALUE1 .VAL>>
 210
 211 <DEFINE ADDR:VALUE1 (ADR)
 212         <COND (<TYPE? .ADR ADDRESS:C> (!.ADR 1))
 213               (<TYPE? .ADR ADDRESS:PAIR> <REST .ADR>)
 214               (<TYPE? .ADR AC> (<ADDRSYM .ADR>))
 215               (<TYPE? .ADR TEMP> <TEMP:ADDR .ADR 1>)
 216               (<TYPE? .ADR OFFPTR>
 217                <COND (<=? <DATVAL <2 .ADR>> #ADDRESS:PAIR (|$TTB
 218                                                            `TB )>
 219                       (<+ <1 .ADR> 1> `(TB) ))
 220                      (ELSE
 221                       <TOACV <2 .ADR>>
 222                       (!<COND (<==? <LENGTH .ADR> 4> <4 .ADR>) (ELSE (0))>
 223                        <+ 1 <1 .ADR>>
 224                        (<ADDRSYM <DATVAL <2 .ADR>>>)))>)
 225               (ELSE <MESSAGE INCONSISTENCY "BAD ADDRESS "> ())>>
 226
 227
 228 <DEFINE TEMP:ADDR (TM OFF "AUX" DAT)
 229         #DECL ((DAT) <OR FALSE DATUM> (TM) TEMP (OFF) FIX (FCN) NODE)
 230         <COND (<SET DAT <TMPAC .TM>>
 231                <COND (<0? .OFF> <ADDR:TYPE1 <DATTYP .DAT>>)
 232                      (<1? .OFF> <ADDR:VALUE1 <DATVAL .DAT>>)
 233                      (<MESSAGE "INCONSISTENCY" "TEMPORARY OFFSET BAD">)>)
 234               (<COND (<=? .AC-HACK '(STACK)>
 235                       (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
 236                                   (<TMPNO .TM> !.TMPS)>
 237                        '`(TP) ))
 238                      (ELSE
 239                       <REFERENCE:STACK:ADR
 240                        (.OFF <TMPNO .TM>
 241                         <COND (<=? .AC-HACK '(FUNNY-STACK)>
 242                                <* <TOTARGS .FCN> -2>)
 243                               (ELSE 0)> !.TMPS) .AC-HACK>)>)>>
 244
 245 <DEFINE STEMP:ADDR (TM "OPTIONAL" (OFF 0))
 246         #DECL ((TM) TEMP (OFF) FIX (FCN) NODE)
 247         <COND (<=? .AC-HACK '(STACK)>
 248                (!<FIX:ADDR (-1 <- .OFF> !<STACK:L .STK .BSTB>)
 249                            (<TMPNO .TM> !.TMPS)>
 250                 '`(TP) ))
 251               (ELSE
 252                <REFERENCE:STACK:ADR
 253                 (.OFF <TMPNO .TM>
 254                         <COND (<=? .AC-HACK '(FUNNY-STACK)>
 255                                <* <TOTARGS .FCN> -2>)
 256                               (ELSE 0)> !.TMPS) .AC-HACK>)>>
 257
 258 "FIX:ADDR TAKES TWO ARGUMENTS. THESE ARE A NEGATIVE AND POSITIVE OFFSETS ON THE STACK
 259  AND BUILDS A COMPOSITE OFFSET ELIMINATING DUPLICATION"
 260
 261 <DEFINE FIX:ADDR (NEGS OPOS
 262                   "AUX" (POS <LIST !.OPOS>) (NUM 0) (NPOS ()) (NNEGS ()) LN)
 263         #DECL ((NEGS POS) LIST (NUM) FIX (NNEGS) LIST)
 264         <MAPF <>
 265               <FUNCTION (NEG1 "AUX" NEGX)
 266                       <COND (<TYPE? .NEG1 FIX> <SET NUM <- .NUM .NEG1>>)
 267                             (<AND <TYPE? .NEG1 FORM ATOM>
 268                                   <SET NEGX <MEMBER .NEG1 .POS>>>
 269                              <SET LN <- <LENGTH .POS> <LENGTH .NEGX> -1>>
 270                              <SET POS <DEL .POS .LN>>)
 271                             (ELSE <SET NNEGS (.NEG1 !.NNEGS)>)>>
 272               .NEGS>
 273         <MAPF <>
 274               <FUNCTION (NPOS1)
 275                       <COND (<TYPE? .NPOS1 FIX> <SET NUM <+ .NUM .NPOS1>>)
 276                             (<SET NPOS (.NPOS1 !.NPOS)>)>>
 277               .POS>
 278         <COND (<NOT <EMPTY? .NNEGS>> (<FORM - .NUM !.NNEGS> !.NPOS))
 279               (ELSE (.NUM !.NPOS))>>
 280
 281 <DEFINE DEL (IT NUM)
 282         #DECL ((IT) <LIST ANY> (NUM) FIX)
 283         <COND (<==? .NUM 1> <REST .IT>)
 284               (ELSE <PUTREST <REST .IT <- .NUM 2>> <REST .IT .NUM>> .IT)>>
 285
 286 <DEFINE REFERENCE:ADR (OBJECT "EXTRA" TTYPE)
 287         <COND (<AND <==? <PRIMTYPE .OBJECT> WORD>
 288                     <SET TTYPE <FORM TYPE-WORD!-OP <TYPE .OBJECT>>>>
 289                <ADDRESS:PAIR .TTYPE [.OBJECT]>)
 290               (<AND <==? <PRIMTYPE .OBJECT> LIST> <EMPTY? .OBJECT>>
 291                <ADDRESS:PAIR <FORM TYPE-WORD!-OP <TYPE .OBJECT>> '[0]>)
 292               (ELSE
 293                <ADDRESS:C <FORM MQUOTE!-OP <FORM QUOTE .OBJECT>> -1>)>>
 294
 295 <DEFINE REFERENCE (OBJ "AUX" ADR)
 296         #DECL ((VALUE) <DATUM ANY ANY>)
 297         <SET ADR <REFERENCE:ADR .OBJ>>
 298         <DATUM .ADR .ADR>>
 299
 300 <DEFINE STACK:ARGUMENT (DAT "AUX" TEM)
 301         #DECL ((DAT) <DATUM ANY ANY>)
 302         <COND (<N==? .DAT ,NO-DATUM>
 303                <EMIT <INSTRUCTION `PUSH  `TP*  !<ADDR:TYPE .DAT>>>
 304                <SET TEM <ADDR:VALUE .DAT>>
 305                <EMIT <INSTRUCTION `PUSH
 306                                   `TP*
 307                                   !.TEM
 308                                   !<COND (<MEMQ '`(TP)  .TEM> '(-1))>>>)>
 309         .DAT>
 310
 311 <DEFINE STACK:ADR (ADR)
 312         <EMIT <INSTRUCTION `PUSH  `TP*  !<ADDR:TYPE1 .ADR>>>
 313         <EMIT <INSTRUCTION `PUSH  `TP*  !<ADDR:VALUE1 .ADR>>>
 314         .ADR>
 315
 316 <DEFINE MOVE:ARG (FROM1 TO1
 317                   "OPTIONAL" (KEEP <>)
 318                   "AUX" TMP TT TO TAC T1 TMP1 T2 FROM (NOTYET <>) (NOTYET2 <>)
 319                         VAL LSEXCH)
 320    #DECL ((TMP FROM TO) <<PRIMTYPE LIST> ANY ANY> (TAC) AC (VAL) FIX)
 321    <PROG ()
 322      <COND
 323       (<TYPE? .TO1 ATOM> <AND <==? .TO1 FLUSHED> <RET-TMP-AC .FROM1>> FLUSHED)
 324       (<==? .FROM1 ,NO-DATUM> <RETURN ,NO-DATUM>)
 325       (<AND <SET FROM .FROM1> <SET TMP1 <ACS? <SET TO .TO1>>> <SET TMP .TMP1>>
 326        <COND (<==? <SET TT <DATTYP .TMP>> ANY-AC>
 327               <COND (<TYPE? <DATTYP .FROM> AC> <SET TT <DATTYP .FROM>>)
 328                     (ELSE <SET TT <GETREG <>>>)>
 329               <REPEAT ((L ()))
 330                       #DECL ((L) <LIST [REST AC]>)
 331                       <COND (<MEMQ .TT .TO>
 332                              <SET L (.TT !.L)>
 333                              <PUT .TT ,ACPROT T>
 334                              <SET TT <GETREG <>>>)
 335                             (ELSE
 336                              <PUT .TMP ,DATTYP .TT>
 337                              <MAPF <>
 338                                    <FUNCTION (TT)
 339                                            #DECL ((TT) AC)
 340                                            <PUT .TT ,ACPROT <>>>
 341                                    .L>
 342                              <RETURN>)>>)>
 343        <AND <==? <SET T1 <DATVAL .TMP>> ANY-AC>
 344            <COND (<TYPE? <DATVAL .FROM> AC>
 345                   <PUT .TMP ,DATVAL <SET T1 <DATVAL .FROM>>>)
 346                  (ELSE
 347                   <COND (<TYPE? .TT AC>
 348                          <SET TAC .TT>
 349                          <SET T2 <ACPROT .TAC>>
 350                          <PUT .TAC ,ACPROT T>)>
 351                   <PUT .TMP ,DATVAL <SET T1 <GETREG <>>>>
 352                   <COND (<TYPE? .TT AC>
 353                          <SET TAC .TT>
 354                          <PUT .TAC ,ACPROT .T2>)>)>>
 355        <COND (<AND <TYPE? <DATTYP .FROM> AC>
 356                    <TYPE? <DATVAL .FROM> AC>
 357                    <==? .T1 <DATTYP .FROM>>
 358                    <OR <TYPE? .TT ATOM> <==? .TT <DATVAL .FROM>>>>
 359               <EMIT <INSTRUCTION `EXCH  <ACSYM .T1> <ADDRSYM <DATVAL .FROM>>>>
 360               <SET LSEXCH <EXCH-ACL .T1 <SET T2 <DATVAL .FROM>> <ACLINK .T1>>>
 361               <SET LSEXCH <EXCH-ACL .T2 .T1 <ACLINK .T2> .LSEXCH>>
 362               <MAPF <>
 363                     <FUNCTION (S "AUX" (SNA <SINACS .S>))
 364                             <COND (<NOT <MEMQ .SNA .LSEXCH>>
 365                                    <SET LSEXCH (.SNA !.LSEXCH)>
 366                                    <EXCH-AC .T1 .T2 <SINACS .S>>)>>
 367                     <ACRESIDUE <DATVAL .FROM>>>)>
 368        <AND <TYPE? .TT ATOM>
 369             <TYPE? <DATTYP .FROM> AC>
 370             <PUT .TMP ,DATTYP <SET TT <DATTYP .FROM>>>>
 371        <AND <TYPE? .TT AC>
 372            <SET TAC .TT>
 373            <COND (<==? .TAC <DATTYP .FROM>> <FIX-ACLINK .TAC .TO .FROM>)
 374                  (<NOT <AND <NOT .KEEP> <ACLINK .TAC> <ACMEMQ .TAC .FROM>>>
 375                   <SGETREG .TAC .TO>)
 376                  (ELSE <SET NOTYET T>)>>
 377        <AND <TYPE? .T1 AC>
 378            <SET TAC .T1>
 379            <COND (<==? <DATVAL .FROM> .TAC> <FIX-ACLINK .TAC .TO .FROM>)
 380                  (<NOT <AND <NOT .KEEP>
 381                             <NOT .NOTYET>
 382                             <ACLINK .TAC>
 383                             <ACMEMQ .TAC .FROM>>>
 384                   <SGETREG .TAC .TO>)
 385                  (ELSE <SET NOTYET2 T>)>>
 386        <COND (<OR .NOTYET .NOTYET2>
 387               <RET-TMP-AC .FROM>
 388               <COND (.NOTYET
 389                      <SGETREG .TT .TO>
 390                      <MOVE:VALUE <DATVAL .FROM> .T1>
 391                      <MOVE:TYP <DATTYP .FROM> .TT>)
 392                     (ELSE
 393                      <SGETREG .T1 .TO>
 394                      <MOVE:TYP <DATTYP .FROM> .TT>
 395                      <MOVE:VALUE <DATVAL .FROM> .T1>)>
 396               <PUT .FROM ,DATTYP FIX>
 397               <PUT .FROM ,DATVAL DONT-CARE>)
 398              (ELSE
 399               <MOVE:TYP <DATTYP .FROM> .TT>
 400               <MOVE:VALUE <DATVAL .FROM> .T1>)>
 401        <REPEAT ((L .TO))
 402                #DECL ((L) <PRIMTYPE LIST>)
 403                <AND <EMPTY? .L> <RETURN .TO>>
 404                <OR <==? .TMP .L>
 405                        <PROG ()
 406                              <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
 407                              <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>>>
 408                <SET L <REST .L 2>>>)
 409       (<SET TMP1 <ACS? .FROM>>
 410        <SET TMP .TMP1>
 411        <REPEAT ((L .TO))
 412                #DECL ((L) <PRIMTYPE LIST>)
 413                <MOVE:TYP <DATTYP .TMP> <DATTYP .L>>
 414                <MOVE:VALUE <DATVAL .TMP> <DATVAL .L>>
 415                <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
 416       (ELSE
 417        <COND (<NOT <OR <TYPE? <DATTYP .TO> ATOM>
 418                        <AND <==? <LENGTH .TO> 2>
 419                             <=? <DATTYP .TO> <DATTYP .FROM>>>>>
 420               <MOVE:TYP <DATTYP .FROM> ,ACO>
 421               <REPEAT ((L .TO))
 422                       #DECL ((L) <PRIMTYPE LIST>)
 423                       <MOVE:TYP ,ACO <DATTYP .L>>
 424                       <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>
 425        <COND
 426         (<NOT <OR <TYPE? <DATVAL .TO> ATOM>
 427                   <AND <==? <LENGTH .TO> 2> <=? <DATVAL .TO> <DATVAL .FROM>>>>>
 428          <COND (<AND <TYPE? <DATVAL .FROM> ADDRESS:PAIR>
 429                      <OR <==? <SET VAL <CHTYPE <1 <2 <DATVAL .FROM>>> FIX>> -1>
 430                          <0? .VAL>>>
 431                 <REPEAT ((L .TO))
 432                         #DECL ((L) <PRIMTYPE LIST>)
 433                         <EMIT <INSTRUCTION <COND (<0? .VAL> `SETZM )
 434                                                  (ELSE `SETOM )>
 435                                            !<ADDR:VALUE .L>>>
 436                         <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)
 437                (ELSE
 438                 <MOVE:VALUE <DATVAL .FROM> ,ACO>
 439                 <REPEAT ((L .TO))
 440                         #DECL ((L) <PRIMTYPE LIST>)
 441                         <MOVE:VALUE ,ACO <DATVAL .L>>
 442                         <AND <EMPTY? <SET L <REST .L 2>>> <RETURN>>>)>)>)>
 443      <COND (<TYPE? .TO1 DATUM>
 444             <MAPF <>
 445                   <FUNCTION (X) <COND (<TYPE? .X AC> <PUT .X ,ACPROT <>>)>>
 446                   .TO>)>
 447      <COND (<AND <NOT .KEEP> <NOT <TYPE? .TO1 ATOM>>>
 448             <REPEAT ((L .FROM))
 449                     #DECL ((L) <PRIMTYPE LIST>)
 450                     <OR <MEMQ <1 .L> .TO> <RET-TMP-AC <1 .L> .FROM>>
 451                     <AND <EMPTY? <SET L <REST .L>>> <RETURN .TO>>>)
 452            (<TYPE? .TO1 ATOM> .FROM1)
 453            (ELSE .TO1)>>>
 454
 455 <DEFINE MOVE:TYP (ADDRF ADDRT "AUX" TT TAC)
 456         #DECL ((TAC) AC)
 457         <COND (<=? .ADDRF .ADDRT>)
 458               (<TYPE? .ADDRT AC>
 459                <SET TAC .ADDRT>
 460                <PUT .TAC ,ACPROT T>
 461                <COND (<AND <TYPE? .ADDRF OFFPTR>
 462                            <MEMQ <SET TT <3 .ADDRF>> <ALLTYPES>>
 463                            <MEMQ <TYPEPRIM .TT> '![STORAGE UVECTOR!]>>
 464                       <TOACV <2 .ADDRF>>
 465                       <GETUVT <DATVAL <2 .ADDRF>> .TAC>)
 466                      (ELSE
 467                       <EMIT <INSTRUCTION `MOVE
 468                                          <ACSYM .TAC>
 469                                          !<ADDR:TYPE1 .ADDRF>>>)>
 470                <PUT .TAC ,ACPROT <>>)
 471               (<TYPE? .ADDRF AC>
 472                <SET TAC .ADDRF>
 473                <PUT .TAC ,ACPROT T>
 474                <OR <TYPE? .ADDRT ATOM>
 475                        <EMIT <INSTRUCTION `MOVEM
 476                                           <ACSYM .TAC>
 477                                           !<ADDR:TYPE1 .ADDRT>>>>
 478                <PUT .TAC ,ACPROT <>>)
 479               (<NOT <TYPE? .ADDRT ATOM>>
 480                <MOVE:TYP .ADDRF ,ACO>
 481                <MOVE:TYP ,ACO .ADDRT>)>>
 482
 483 <DEFINE MOVE:VALUE (ADDRF ADDRT "AUX" TAC)
 484         #DECL ((TAC) AC)
 485         <COND (<=? .ADDRT .ADDRF>)
 486               (<TYPE? .ADDRT AC>
 487                <SET TAC .ADDRT>
 488                <PUT .TAC ,ACPROT T>
 489                <IMCHK '(`MOVE  `MOVEI  `MOVNI  `MOVSI )
 490                       <ACSYM .TAC>
 491                       .ADDRF>
 492                <PUT .TAC ,ACPROT <>>)
 493               (<TYPE? .ADDRF AC>
 494                <SET TAC .ADDRF>
 495                <PUT .TAC ,ACPROT T>
 496                <OR <TYPE? .ADDRT ATOM>
 497                        <EMIT <INSTRUCTION `MOVEM
 498                                           <ACSYM .TAC>
 499                                           !<ADDR:VALUE1 .ADDRT>>>>
 500                <PUT .TAC ,ACPROT <>>)
 501               (<NOT <TYPE? .ADDRT ATOM>>
 502                <MOVE:VALUE .ADDRF ,ACO>
 503                <MOVE:VALUE ,ACO .ADDRT>)>>
 504
 505 <DEFINE ACMEMQ (TAC DAT "AUX" (T1 <DATTYP .DAT>) (TT <DATVAL .DAT>))
 506         #DECL ((TAC) AC (DAT) DATUM)
 507         <OR <==? .T1 .TAC>
 508             <==? .TT .TAC>
 509             <AND <OR <ISTYPE? .T1> <==? .T1 .TT>>
 510                  <TYPE? .TT OFFPTR>
 511                  <TOACV <2 .TT>>
 512                  <==? <DATVAL <2 .TT>> .TAC>>>>
 513
 514 <DEFINE EXCH-ACL (AC1 AC2 L "OPTIONAL" (LST ()))
 515         #DECL ((AC1 AC2) AC (L) <LIST [REST DATUM]>)
 516         <MAPF <>
 517               <FUNCTION (D)
 518                       #DECL ((D) DATUM)
 519                       <COND (<NOT <MEMQ .D .LST>>
 520                              <EXCH-AC .AC1 .AC2 .D>
 521                              <SET LST (.D !.LST)>)>>
 522               .L>
 523         .LST>
 524
 525 <DEFINE EXCH-AC (AC1 AC2 D "AUX" TMP)
 526         #DECL ((AC1 AC2) AC (D) DATUM)
 527         <COND (<AND <==? .AC1 <DATTYP .D>> <==? .AC2 <DATVAL .D>>>
 528                <PUT .D ,DATVAL .AC1>
 529                <PUT .D ,DATTYP .AC2>)
 530               (<SET TMP <MEMQ .AC1 .D>>
 531                <PUT .TMP 1 .AC2>
 532                <PUT .AC2 ,ACLINK (.D !<ACLINK .AC2>)>
 533                <PUT .AC1
 534                     ,ACLINK
 535                     <MAPF ,LIST
 536                           <FUNCTION (DAT)
 537                                   <COND (<N==? .DAT .D> <MAPRET .DAT>)
 538                                         (<MAPRET>)>>
 539                           <ACLINK .AC1>>>)
 540               (<SET TMP <MEMQ .AC2 .D>>
 541                <PUT .TMP 1 .AC1>
 542                <PUT .AC1 ,ACLINK (.D !<ACLINK .AC1>)>
 543                <PUT .AC2
 544                     ,ACLINK
 545                     <MAPF ,LIST
 546                           <FUNCTION (DAT)
 547                                   <COND (<==? .DAT .D> <MAPRET>)
 548                                         (ELSE <MAPRET .DAT>)>>
 549                           <ACLINK .AC2>>>)>>
 550
 551 <DEFINE FIX-ACLINK (AC TO FROM "AUX" (L <MEMQ .FROM <ACLINK .AC>>))
 552         #DECL ((AC) AC (L) <PRIMTYPE LIST>)
 553         <COND (.L <PUT .L 1 .TO>)
 554               (ELSE <PUT .AC ,ACLINK (.TO !<ACLINK .AC>)>)>>
 555
 556 <DEFINE ACS? (DAT)
 557         #DECL ((DAT) <PRIMTYPE LIST>)
 558         <REPEAT ()
 559                 <AND <EMPTY? .DAT> <RETURN <>>>
 560                 <COND (<OR <TYPE? <DATVAL .DAT> AC> <==? <DATVAL .DAT> ANY-AC>>
 561                        <RETURN .DAT>)
 562                       (<AND <TYPE? <DATVAL .DAT> ATOM>
 563                             <OR <TYPE? <DATTYP .DAT> AC>
 564                                 <==? <DATTYP .DAT> ANY-AC>>>
 565                        <RETURN .DAT>)>
 566                 <SET DAT <REST .DAT 2>>>>
 567
 568 <DEFINE IMCHK (INS AC ISRC "OPTIONAL" (COM <>)
 569                            "AUX" SRC VAL (LN <LENGTH .INS>))
 570    #DECL ((AC) <PRIMTYPE WORD> (VAL LN) FIX (INS) <LIST ANY ANY>
 571           (SRC) <<PRIMTYPE LIST> ANY <VECTOR <PRIMTYPE WORD>>>)
 572    <COND (<AND <TYPE? .ISRC ADDRESS:PAIR>
 573                <NOT <EMPTY? <REST .ISRC>>>
 574                <TYPE? <2 .ISRC> VECTOR>
 575                <SET SRC .ISRC>>
 576           <SET VAL <CHTYPE <1 <2 .SRC>> FIX>>
 577           <COND (<AND <G=? .VAL 0>
 578                       <L? .VAL 262144>
 579                       <TYPE? <2 .INS> OPCODE!-OP>>
 580                  <EMIT <INSTRUCTION <2 .INS> .AC .VAL>>)
 581                 (<AND <G=? .LN 3>
 582                       <N==? <CHTYPE .VAL WORD> #WORD *400000000000*>
 583                       <L? <ABS .VAL> 262144>
 584                       <TYPE? <3 .INS> OPCODE!-OP>>
 585                                          ;"Was negative immediate ins supplied?"
 586                  <EMIT <INSTRUCTION <3 .INS> .AC <- <ABS .VAL> <COND (.COM 1)
 587                                                                      (0)>>>>)
 588                 (<AND <==? .LN 4>
 589                       <0? <CHTYPE <GETBITS .VAL <BITS 18>> FIX>>>
 590                  <EMIT <INSTRUCTION <4 .INS>
 591                                     .AC
 592                                     <CHTYPE <GETBITS .VAL <BITS 18 18>> FIX>>>)
 593                 (ELSE
 594                  <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .SRC>>>)>)
 595          (ELSE
 596           <EMIT <INSTRUCTION <1 .INS> .AC !<ADDR:VALUE1 .ISRC>>>)>>
 597
 598 <DEFINE GROUP:INITIAL (NAME)
 599         <EMIT <INSTRUCTION TITLE .NAME>>
 600         <EMIT <INSTRUCTION DECLARE!-OP '("VALUE" ATOM)>>
 601         <EMIT <INSTRUCTION `MOVE  `A*  <FORM MQUOTE!-OP .NAME> -1>>
 602         <EMIT <INSTRUCTION `MOVE  `B*  <FORM MQUOTE!-OP .NAME>>>
 603         <EMIT <INSTRUCTION `JRST  |FINIS >>>
 604
 605 <DEFINE FUNCTION:INITIAL (NAME)
 606         <AND .NAME <EMIT <INSTRUCTION TITLE .NAME <>>>>
 607         <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>>  ;"Initial declarations.">
 608
 609 <DEFINE SUB:INITIAL (NAME "AUX" DC)
 610         #DECL ((DC) <FORM ATOM>)
 611         <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
 612         <SET RDCL <REST .DC>>>
 613
 614 <DEFINE INT:INITIAL (NAME) <SET RDCL <CHTYPE (0 0) IRSUBR>>>
 615
 616 <DEFINE SUB:INT:INITIAL (NAME "AUX" DC)
 617         #DECL ((DC) <FORM ATOM>)
 618         <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
 619         <SET RDCL <REST .DC>>>
 620
 621 <DEFINE FCN:INT:INITIAL (NAME)
 622         <EMIT <INSTRUCTION TITLE .NAME <>>>
 623         <EMIT <SET RDCL <INSTRUCTION DECLARE!-OP 0>>>>
 624
 625 <DEFINE INT:LOSER:INITIAL (NAME FCN
 626                            "AUX" (ACSTR <1 <ACS .FCN>>) (TR <TOTARGS .FCN>)
 627                                  (RQ <REQARGS .FCN>) (INAME <NODE-NAME .FCN>) TG
 628                                  DC)
 629    #DECL ((FCN) NODE (TR RQ) FIX (INAME) UVECTOR)
 630    <COND (<=? .ACSTR '(STACK)>
 631           <COND (<EMPTY? <REST .INAME>>
 632                  <LABEL:TAG <1 .INAME>>
 633                  <EMIT '<`SUBM  `M*  `(P) >>
 634                  <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)
 635                 (ELSE
 636                  <SET TG <MAKE:TAG>>
 637                  <MAPR <>
 638                        <FUNCTION (NN "AUX" (LAST <EMPTY? <REST .NN>>))
 639                                <LABEL:TAG <1 .NN>>
 640                                <EMIT <INSTRUCTION `MOVEI  `A*  .TR>>
 641                                <COND (.LAST <LABEL:TAG .TG>)
 642                                      (ELSE <BRANCH:TAG .TG>)>
 643                                <SET TR <- .TR 1>>>
 644                        .INAME>
 645                  <EMIT '<`SUBM  `M*  `(P) >>
 646                  <EMIT <INSTRUCTION ACALL!-OP `A*  .NAME>>)>)
 647          (ELSE
 648           <LABEL:TAG <1 .INAME>>
 649           <EMIT '<`SUBM  `M*  `(P) >>
 650           <MAPF <>
 651                 <FUNCTION (L)
 652                         #DECL ((L) LIST)
 653                         <RET-TMP-AC <STACK:ARGUMENT <DATUM <1 .L> <2 .L>>>>>
 654                 .ACSTR>
 655           <EMIT <INSTRUCTION MCALL!-OP .TR .NAME>>)>
 656    <EMIT '<`JRST  |MPOPJ >>
 657    <EMIT <SET DC <INSTRUCTION SUB-ENTRY!-OP .NAME 0>>>
 658    <SET RDCL <REST .DC>>>
 659
 660 <DEFINE FCNSUB:FINAL (NOD) <EMIT <INSTRUCTION `JRST  |FINIS >>>
 661
 662 <DEFINE FS:INT:FINAL (ACS)
 663         <COND (<=? .ACS '(STACK)> <EMIT '<`JRST  |MPOPJ >>)
 664               (ELSE <EMIT '<`JRST  |FMPOPJ >>)>>
 665
 666 <DEFINE INT:FINAL (NOD)
 667         #DECL ((RDCL) <LIST ANY> (NOD) NODE)
 668         <EMIT <INSTRUCTION `JRST  |MPOPJ >>
 669         <PUT .RDCL 1 .NOD>
 670         .RDCL>
 671
 672
 673 <DEFINE ASSEM? (SRC-FLG "OPTIONAL" (BIN-FLG .BIN-FLG) "AUX" X (T <TIME>))
 674         #DECL ((CODE:TOP) <LIST ANY>)
 675         <COND (<AND <ASSIGNED? CSOURCE> .CSOURCE>
 676                <PRT <REST .CODE:TOP>>)>
 677         <PUTREST .CODE:TOP <SET X <CDUP <REST .CODE:TOP>>>>
 678         <EXP-MAC .CODE:TOP>
 679         <COND (.PEEP <PEEP .X !.X> <TERPRI>)>
 680         <COND (.BIN-FLG
 681                <ASSEMBLE1!-CODING!-PACKAGE .X <1 .OBLIST> <> .SRC-FLG>)
 682               (ELSE .X)>>
 683
 684
 685 <DEFINE BLOCK:INITIAL () T>
 686
 687 <DEFINE BLOCK:FINAL () T>
 688
 689 <DEFINE PROG:END () <EMIT <INSTRUCTION `JRST  |FINIS >>>
 690
 691 <DEFINE UNBIND:FUNNY (N "TUPLE" Y)
 692         <AND .SPECD
 693             <EMIT <INSTRUCTION `MOVEI
 694                                `E*
 695                                .N
 696                                !.Y
 697                                <COND (.AC-HACK 1) (ELSE 0)>
 698                                <COND (.AC-HACK '`(FRM) ) (ELSE '`(TB) )>>>
 699             <EMIT <INSTRUCTION `PUSHJ  `P*  |SSPEC1 >>>>
 700
 701 <DEFINE UNBIND:LOCS (FROM TO "OPTIONAL" (FLG <>))
 702         <COND (<NOT .FLG>
 703                <AND <POP:LOCS .FROM .TO>
 704                      .SPECD
 705                      <EMIT <INSTRUCTION `PUSHJ  `P*  |SSPECS >>>)
 706               (.SPECD
 707                <EMIT '<`MOVE `TP* `FRM>>
 708                <EMIT '<`PUSHJ `P* |SSPECS>>)>>
 709
 710 <DEFINE POP:LOCS (FROM TO "AUX" (OTHERS ()) (AMNT 0) (PST 0) REG (PSTN 0) TEM)
 711    #DECL ((FROM TO) LIST (AMNT PST PSTN) FIX (REG) AC)
 712    <REPEAT ((FROM .FROM))            ;"First count known locals and # of slots."
 713            #DECL ((FROM) LIST)
 714            <AND <==? .TO .FROM> <RETURN>>
 715            <COND (<TYPE? <SET TEM <1 .FROM>> FIX> <SET AMNT <+ .AMNT .TEM>>)
 716                  (<==? .TEM PSLOT> <SET PSTN <+ .PSTN 1>>)
 717                  (<==? .TEM PSTACK> <SET PST <+ .PST 1>>)
 718                  (ELSE <SET OTHERS (.TEM !.OTHERS)>)>
 719            <SET FROM <REST .FROM>>>
 720    <COND
 721     (<0? .PST>
 722      <OR <AND <0? .AMNT> <EMPTY? .OTHERS>>
 723              <EMIT <INSTRUCTION DEALLOCATE (.AMNT !.OTHERS)>>>
 724      <OR <0? .PSTN>
 725              <EMIT <INSTRUCTION `SUB  `P*  [<FORM .PSTN (.PSTN)>]>>>)
 726     (ELSE
 727      <SET REG <GETREG <>>>
 728      <COND
 729       (<AND <1? .PST> <0? .PSTN>>
 730        <EMIT <INSTRUCTION `POP  `P*  <ADDRSYM .REG>>>)
 731       (ELSE
 732        <REPEAT ((OFFS 0) (FST T))
 733                #DECL ((OFFS) FIX)
 734                <COND (<==? <SET TEM <1 .FROM>> PSLOT> <SET OFFS <+ .OFFS 1>>)
 735                      (<==? .TEM PSTACK>
 736                       <COND (.FST
 737                              <EMIT <INSTRUCTION `MOVEI
 738                                                 <ACSYM .REG>
 739                                                 `@
 740                                                 <- .OFFS>
 741                                                 '`(P) >>
 742                              <SET FST <>>)
 743                             (ELSE
 744                              <EMIT <INSTRUCTION `ADDI
 745                                                 <ACSYM .REG>
 746                                                 `@
 747                                                 <- .OFFS>
 748                                                 '`(P) >>)>)>
 749                <AND <==? .TO <SET FROM <REST .FROM>>> <RETURN>>>
 750        <EMIT <INSTRUCTION `SUB
 751                           `P*
 752                           [<FORM <SET PST <+ .PSTN .PST>> (.PST)>]>>)>
 753      <EMIT <INSTRUCTION `ADDI
 754                         <ACSYM .REG>
 755                         !.OTHERS
 756                         .AMNT
 757                         (<ADDRSYM .REG>)>>
 758      <EMIT <INSTRUCTION `HRLI  <ACSYM .REG> (<ADDRSYM .REG>)>>
 759      <EMIT <INSTRUCTION `SUB  `TP*  <ADDRSYM .REG>>>)>
 760    <NOT <AND <0? .AMNT> <0? .PST>>>>
 761
 762 ;"This is machine dependant code associated with setting up argument TUPLEs."
 763
 764 <DEFINE COPY:ARGPNTR ()
 765         <EMIT <INSTRUCTION `MOVE  `C*  `AB >>
 766         <EMIT <INSTRUCTION `MOVEI  `D*  0>>        ;"D will count args pushed.">
 767
 768 <DEFINE BUMP:ARGPNTR ("OPTIONAL" (N 1))
 769         #DECL ((N) FIX)
 770         <SET N <* .N 2>>
 771         <EMIT <INSTRUCTION `ADD  `C*  [<FORM .N (.N)>]>>
 772                                                        ;"Bump an AOBJN pointer">
 773
 774 <DEFINE BUMP:CNTR ("OPTIONAL" (N 1))
 775         #DECL ((N) FIX)
 776         <SET N <* .N 2>>
 777         <EMIT <INSTRUCTION `ADDI  `D*  .N>>>
 778
 779 <DEFINE TEST:ARGPNTR (TAG) <EMIT <INSTRUCTION `JUMPGE  `C*  .TAG>>>
 780
 781 <DEFINE REFERENCE:ARGPNTR ()
 782         #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
 783         <DATUM #ADDRESS:C (`(C) ) #ADDRESS:C (`(C) )>>
 784
 785 <DEFINE TUPLE:FINAL ("AUX" (VAL <FUNCTION:VALUE T>))
 786         #DECL ((VALUE) <DATUM AC AC>)
 787         <EMIT <INSTRUCTION `PUSHJ  `P*  |MAKTUP >>
 788         .VAL>
 789
 790 <DEFINE REFERENCE:STACK:ADR (N "OPTIONAL" (AC-HACK .AC-HACK))
 791         <COND (.AC-HACK <ADDRESS:C 1 `(FRM)  !.N>)
 792               (ELES <ADDRESS:C `(TB)  !.N>)>>
 793
 794 <DEFINE REFERENCE:STACK (N "AUX" (TT <REFERENCE:STACK:ADR .N>))
 795         #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C>)
 796         <DATUM .TT .TT>>
 797
 798 ;"Machine dependant stuff for activations and environemnts"
 799
 800 <DEFINE SPEC:REFERENCE:STACK (AC-HACK ADDRESS
 801                               "AUX" (TT
 802                                      <REFERENCE:STACK:ADR .ADDRESS .AC-HACK>))
 803         <DATUM .TT .TT>>
 804
 805 <DEFINE MAKE:ENV ("AUX" (VAL <FUNCTION:VALUE T>))
 806         <EMIT <INSTRUCTION `PUSHJ  `P*  |MAKENV >>
 807         .VAL>
 808
 809 <DEFINE ACT:INITIAL ()
 810         <SET START:TAG <MAKE:TAG>>
 811         <COND (.GLUE
 812                <EMIT <INSTRUCTION `MOVEI  `O*  .START:TAG>>
 813                <EMIT '<`SUB  `O*  `M >>
 814                <EMIT '<`HRLI  `O*  TTP!-OP>>
 815                <EMIT '<`PUSH  `TP*  `O* >>)
 816               (ELSE
 817                <EMIT <INSTRUCTION `PUSH  `TP*  [<FORM (TTP!-OP) .START:TAG>]>>)>
 818         <EMIT <INSTRUCTION `PUSH  `TP*  [0]>>>
 819
 820 <DEFINE ACT:FINAL ()
 821         <EMIT <INSTRUCTION `MOVEM  `TP*  `(TB)  1>>
 822         <LABEL:OFF .START:TAG>>
 823
 824 <DEFINE MAKE:ACT ("AUX" (VAL <FUNCTION:VALUE T>))
 825         <EMIT <INSTRUCTION `PUSHJ  `P*  |MAKACT >>
 826         .VAL>
 827
 828 <DEFINE BUILD:FRAME (PC)
 829         <EMIT <INSTRUCTION `MOVEI  `A*  .PC>>
 830         <AND .GLUE <EMIT '<`SUB  `A*  `M >>>
 831         <EMIT <INSTRUCTION `PUSHJ  `P*  |BFRAME >>>
 832
 833 ;"Machine dependent segment hacking code."
 834
 835 <DEFINE SEGMENT:LIST (N FLG)
 836         <OR .FLG <EMIT <INSTRUCTION `PUSH  `P*  [.N]>>>
 837         <EMIT <INSTRUCTION `MOVEI  `O*  |SEGLST >>
 838         <EMIT <INSTRUCTION `PUSHJ  `P*  |RCALL >>
 839         <EMIT <INSTRUCTION `SUB  `P*  [<FORM 1 (1)>]>>>
 840
 841 <DEFINE SEGMENT:STACK (TAG FLG)
 842         <OR .FLG <EMIT <INSTRUCTION `PUSH  `P*  [.TAG]>>>
 843         <EMIT <INSTRUCTION `MOVEI  `O*  |SEGMNT >>
 844         <EMIT <INSTRUCTION `PUSHJ  `P*  |RCALL >>>
 845
 846 <DEFINE SEGMENT:FINAL (SUBR)
 847         <EMIT <INSTRUCTION `POP  `P*  `A >>
 848         <EMIT <INSTRUCTION ACALL!-OP `A*  .SUBR>>>
 849
 850 <DEFINE PCOUNTER (N) <EMIT <INSTRUCTION `PUSH  `P*  [.N]>>>
 851
 852 <DEFINE COUNTP () <EMIT <INSTRUCTION `AOS  `(P) >>>
 853
 854 <DEFINE PUSH:BIND (ATM VAL DC)
 855         <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>
 856         <STACK:ARGUMENT .VAL>
 857         <STACK:ADR <REFERENCE:ADR .DC>>>
 858
 859 <DEFINE PUSH:PAIR (VAL) <STACK:ARGUMENT .VAL>>
 860
 861 <DEFINE PUSH:ATB (ATM)
 862         <STACK:ADR <ADDRESS:PAIR ,BIND-BEGIN !<REFERENCE:ADR .ATM> 1>>>
 863
 864 <DEFINE STORE:BIND (SYM VAL)
 865         <RET-TMP-AC <MOVE:ARG .VAL <FUNCTION:VALUE>>>
 866         <REGSTO T>
 867         <EMIT <INSTRUCTION
 868                `MOVEI
 869                `E*
 870                !<REFERENCE:STACK:ADR (<- <ADDR-SYM .SYM> 2> !.NTSLOTS)>>>
 871         <EMIT <INSTRUCTION `MOVE
 872                            `C*
 873                            !<REFERENCE:ADR <NAME-SYM .SYM>>
 874                            1>>
 875         <EMIT <INSTRUCTION `MOVE
 876                            `D*
 877                            !<REFERENCE:ADR <DECL-SYM .SYM>>
 878                            1>>
 879         <EMIT <INSTRUCTION `PUSHJ  `P*  |IBIND >>>
 880
 881 <DEFINE STORE:PAIR (SYM VAL)
 882         <MOVE:ARG .VAL
 883                   <REFERENCE:STACK (<ADDR-SYM .SYM> !.NTSLOTS)>>>
 884
 885 <DEFINE BIND:END () <EMIT <INSTRUCTION `PUSHJ  `P*  |SPECBN >>>
 886
 887 <DEFINE REFERENCE:UNBOUND ()
 888         #DECL ((VALUE) <DATUM ATOM ADDRESS:PAIR>)
 889         <DATUM UNBOUND
 890                <ADDRESS:PAIR '<TYPE-WORD!-OP UNBOUND> '[-1]>>>
 891
 892 <DEFINE REFERENCE:ARG (NUMBER "AUX" TEM)
 893         #DECL ((VALUE) <DATUM ADDRESS:C ADDRESS:C> (NUMBER) FIX)
 894         <SET TEM <ADDRESS:C `(AB)  <* 2 <- .NUMBER 1>>>>
 895         <DATUM .TEM .TEM>>
 896
 897 <DEFINE TEST:ARG (NUMBER TAG)
 898         <EMIT <INSTRUCTION `CAMLE  `AB*  [<FORM (<+ 1 <* -2 .NUMBER>>)>]>>
 899         <EMIT <INSTRUCTION `JRST  .TAG>>>
 900
 901 <DEFINE SALLOC:SLOTS ("TUPLE" TSLOTS)
 902         <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
 903
 904 <DEFINE ALLOC:SLOTS ("TUPLE" TSLOTS "AUX" (TOTARGS <+ <* <TOTARGS .FCN> 2> 2>))
 905         <COND (<=? .AC-HACK '(FUNNY-STACK)>
 906                <EMIT <INSTRUCTION `PUSH  `TP*  [<FORM (TTP!-MUDDLE) .TOTARGS>]>>
 907                <EMIT <INSTRUCTION `PUSH  `TP*  `FRM >>
 908                <EMIT <INSTRUCTION `MOVE  `FRM*  `TP >>)>
 909         <EMIT <INSTRUCTION ALLOCATE:SLOTS !.TSLOTS>>>
 910
 911 <DEFINE FAST:VAL () <EMIT <INSTRUCTION `PUSHJ  `P*  |CILVAL >>>
 912
 913 <DEFINE FAST:SET () <EMIT <INSTRUCTION `PUSHJ  `P*  |CISET >>>
 914
 915 <DEFINE FAST:GVAL () <EMIT <INSTRUCTION `PUSHJ  `P*  |CIGVAL >>>
 916
 917 <DEFINE FAST:SETG () <EMIT <INSTRUCTION `PUSHJ  `P*  |CSETG >>>
 918
 919 ;"Special code for READ EOF hacks."
 920
 921 <DEFINE TIME:STACK ()
 922         <EMIT <INSTRUCTION `HLRZ  `O*  `TB >>
 923         <EMIT <INSTRUCTION `PUSH  `P*  `O* >>
 924         <EMIT <INSTRUCTION `PUSH  `TP*  '<TYPE-WORD!-OP TIME>>>
 925         <EMIT <INSTRUCTION `PUSH  `TP*  `O* >>>
 926
 927 <DEFINE TIME:CHECK ("AUX" BR)
 928         <EMIT <INSTRUCTION GETYP!-OP `O*  `A >>
 929         <EMIT <INSTRUCTION `POP  `P*  `C >>
 930         <EMIT <INSTRUCTION `CAIN  `O*  '<TYPE-CODE!-OP TIME>>>
 931         <EMIT <INSTRUCTION `CAIE  `B*  '`(C) >>
 932         <EMIT <INSTRUCTION `JRST  <SET BR <MAKE:TAG>>>>
 933         .BR>
 934
 935 <ENDBLOCK>
 936 <ENDPACKAGE>