mim/development/mim/vaxc/toplev.mud

   1 <SETG HAS-RESULT <>>
   2
   3 <DEFINE MIMOC (CODLIST "OPTIONAL" (NEW-MSUBR T) "AUX" STATUS ARGS
   4                (CODPTR .CODLIST))
   5         #DECL ((CODLIST) <LIST [REST <OR FORM ATOM>]> (RESET-ALL) BOOLEAN
   6                (CODPTR) <SPECIAL LIST>)
   7         <INIT-ALL-STUFF .NEW-MSUBR>
   8         <SETG FLUSH-NEXT 0>
   9         <REPEAT (NUM APL CODITEM PPTR OSTATUS (LABEL? <>)
  10                  (FROB? <>) (FIRST? T) (PROTECT? <>) TF)
  11                 <SET CODITEM <1 .CODPTR>>
  12                 <SET PPTR .CODPTR>
  13                 <SET CODPTR <REST .CODPTR>>
  14                 <AND <GASSIGNED? MAX-SPACE> ,MAX-SPACE <PUTREST .PPTR ()>>
  15                 <COND (<G? ,FLUSH-NEXT 0>
  16                        <SETG FLUSH-NEXT <- ,FLUSH-NEXT 1>>
  17                        <COND (<EMPTY? .CODPTR> <RETURN>) (<AGAIN>)>)>
  18                 <UNPROTECT-ACS>
  19                 <CLEAR-DEATH>
  20                 <COND (<GETPROP .CODITEM DONE>)
  21                       (<TYPE? .CODITEM FORM>
  22                        <COND (<OR <NOT <GASSIGNED? <1 .CODITEM>>>
  23                                   <NOT <TYPE? <SET NUM ,<1 .CODITEM>> FIX>>>
  24                               <ERROR "UNKNOWN" .CODITEM>)>
  25                        <COND (<L? .NUM 0>
  26                               <SET PROTECT? T>
  27                               <SET NUM <- .NUM>>)
  28                              (T
  29                               <SET PROTECT? <>>)>
  30                        <SET APL <NTH ,OP-APPLY-VECTOR .NUM>>
  31                        <COND (<AND
  32                                <SET TF <OR <MEMQ + .CODITEM>
  33                                            <MEMQ - .CODITEM>>>
  34                                <PROG ((OUTST ,OUTST-LABEL-TABLE)
  35                                       (LAB <2 .TF>))
  36                                  #DECL ((OUTST) VECTOR)
  37                                  <MAPF <>
  38                                    <FUNCTION (LREF)  #DECL ((LREF) LABEL-REF)
  39                                      <COND (<==? <LABEL-REF-NAME .LREF> .LAB>
  40                                             <COND (<LABEL-REF-LOOP-LABEL .LREF>
  41                                                    <MAPLEAVE T>)
  42                                                   (<MAPLEAVE <>>)>)>>
  43                                    .OUTST>>>)
  44                              (<SET-DEATH .CODPTR>)>
  45                        <COND (<==? .NUM ,BAD-OPERATION>
  46                               <ERROR "BAD OPERATION" MIMOC .CODITEM>)>
  47                        <COND (<AND <==? .NUM ,DEAD!-MIMOP> <NOT .LABEL?>>
  48                               <SET OSTATUS .STATUS>)
  49                              (<SET OSTATUS <>>)>
  50                        <COND (.FIRST?
  51                               <SET FIRST? <>>
  52                               <SET FROB? <>>)
  53                              (<NOT .FROB?>
  54                               <COND (<N==? <SET FROB? <FIRST-PROCESS .CODPTR>>
  55                                            TEMP!-MIMOP>
  56                                      <ILDB-LOOKAHEAD .CODPTR>)>)>
  57                        <COND (<MEMQ .NUM ,PASS-OPS>
  58                               <SET STATUS <APPLY .APL !<REST .CODITEM>>>)
  59                              (ELSE
  60                               <SET ARGS <PROCESS-ARGS <REST .CODITEM> .NUM
  61                                                       .PROTECT?>>
  62                               <SET STATUS <APPLY .APL !.ARGS>>)>
  63                        <COND (<OR <NOT .FROB?>
  64                                   <==? <1 .CODITEM> MAKTUP!-MIMOP>
  65                                   <==? <1 .CODITEM> OPT-DISPATCH!-MIMOP>>
  66                               <COND (<N==? <SET FROB? <FIRST-PROCESS .CODPTR>>
  67                                             TEMP!-MIMOP>
  68                                      <ILDB-LOOKAHEAD .CODPTR>)>)>
  69                        <COND (.OSTATUS <SET STATUS .OSTATUS> <SET OSTATUS <>>)
  70                              (<NOT .STATUS>
  71                               <SET STATUS NORMAL>)>
  72                        <SET LABEL? <>>)
  73                       (<TYPE? .CODITEM ATOM>
  74                        <SET LABEL? T>
  75                        <GEN-LABEL .CODITEM .STATUS>)
  76                       (<ERROR "BAD CODE ITEM" MIMOC>)>
  77                 <COND (<EMPTY? .CODPTR> <RETURN>)>>
  78         <PUSH-TEMPS>
  79         T>
  80
  81 <DEFINE SET--DEATH (CODPTR "OPT" (REALLY-DEAD <>) "AUX" (N ,FLUSH-NEXT))
  82    #DECL ((CODPTR) LIST (N) FIX)
  83    <MAPF <>
  84     <FCN
  85      (CODITEM "AUX" VAR)
  86      <COND
  87       (<TYPE? .CODITEM FORM>
  88        <COND (<AND <L? <SET N <- .N 1>> 0> <NOT <GETPROP .CODITEM DONE>>>
  89               <COND (<==? <1 .CODITEM> DEAD!-MIMOP>
  90                      <MAPF <>
  91                       <FCN (ATM)
  92                            <COND (<TYPE? .ATM VARTBL>
  93                                   <VARTBL-DEAD? .ATM T>
  94                                   <COND (.REALLY-DEAD <DEAD-VAR .ATM>)>)>>
  95                       <REST .CODITEM>>)
  96                     (<MAPLEAVE>)>)>)
  97       (<MAPLEAVE>)>>
  98     .CODPTR>>
  99
 100 <SETG ARGVEC <IVECTOR ,MAX-NUMBER-ARGS>>
 101
 102 <DEFINE FIRST-PROCESS FP (L "AUX" VAL)
 103    #DECL ((L) <LIST [REST <OR FORM ATOM>]>)
 104    <SET VAL
 105     <MAPF <>
 106       <FUNCTION (X)
 107             <COND
 108              (<AND <TYPE? .X FORM>
 109                    <GASSIGNED? <1 .X>>>
 110               <COND
 111                (<NOT <MEMQ ,<1 .X> ,PASS-OPS>>
 112                 <REPEAT ((PTR <REST .X>) ITEM ARG TTYP)
 113                       <COND (<EMPTY? .PTR> <RETURN>)>
 114                       <COND (<==? <SET ITEM <1 .PTR>> =>
 115                              <1 .PTR <CHTYPE .ITEM RES-IND>>
 116                              <SET PTR <REST .PTR>>
 117                              <SET ITEM <1 .PTR>>
 118                              <COND (<==? .ITEM STACK>)
 119                                    (<SET ITEM <FIND-VAR .ITEM>> <1 .PTR .ITEM>)
 120                                    (<ERROR "NOT A VARIABLE"
 121                                            <1 .PTR>
 122                                            PROCESS-ARGS>)>)
 123                             (<TYPE? .ITEM ATOM>
 124                              <COND (<SET ARG <FIND-VAR .ITEM>>
 125                                     <VARTBL-DEAD? .ARG <>>
 126                                     <1 .PTR .ARG>)>)
 127                             (<AND <TYPE? .ITEM FORM>
 128                                   <==? <LENGTH .ITEM> 2>
 129                                   <==? <1 .ITEM> TYPE>
 130                                   <==? <1 .X> CHTYPE!-MIMOP>>
 131                              <COND (<SET ARG <FIND-VAR <2 .ITEM>>>
 132                                     <1 .PTR <FORM TYPE .ARG>>
 133                                     <VARTBL-DEAD? .ARG <>>)>)
 134                             (<AND <TYPE? .ITEM FORM>
 135                                   <==? <LENGTH .ITEM> 2>
 136                                   <OR <==? <SET TTYP <1 .ITEM>> QUOTE>
 137                                       <==? .TTYP TYPE-CODE>>
 138                                   <TYPE? <2 .ITEM> ATOM>>
 139                              <SET ITEM <2 .ITEM>>
 140                              <AND <==? .TTYP TYPE-CODE>
 141                                   <SET TTYP <CHECK-MIMOP-TYPE .ITEM>>
 142                                   <SET ITEM .TTYP>>
 143                              <1 .PTR .ITEM>)>
 144                       <SET PTR <REST .PTR>>>)
 145                (<==? <1 .X> TEMP!-MIMOP>
 146                 <PROG ((FIRST-PROCESS? T))
 147                       #DECL ((FIRST-PROCESS?) <SPECIAL ATOM>)
 148                       <TEMP-PROCESS !<REST .X>>>
 149                 <MAPR <>
 150                       <FUNCTION (L "AUX" (X <1 .L>))
 151                                 #DECL ((L) LIST)
 152                                 <COND (<TYPE? .X LIST>
 153                                        <COND (<TYPE? <1 .X> ADECL>
 154                                               <1 .X <FIND-VAR <1 <1 .X>>>>)
 155                                              (T
 156                                               <1 .X <FIND-VAR <1 .X>>>)>)
 157                                       (<TYPE? .X ADECL> <1 .L <FIND-VAR <1 .X>>>)
 158                                       (T <1 .L <FIND-VAR .X>>)>>
 159                       <REST .X>>)
 160                (<OR <==? <1 .X> MAKTUP!-MIMOP>
 161                     <==? <1 .X> OPT-DISPATCH!-MIMOP>>
 162                 <MAPLEAVE TEMP!-MIMOP>)>)>>
 163     .L>>
 164     .VAL>
 165
 166 <DEFINE PROCESS-ARGS (LST NUM PROTECT? "AUX" (CNT 1) (ARGS ,ARGVEC) ARG TTYP DISP)
 167         #DECL ((LST) LIST (NUM) FIX)
 168         <SETG HAS-RESULT <>>
 169         <REPEAT ((PTR .LST) ITEM)
 170                 <COND (<EMPTY? .PTR> <RETURN>)>
 171                 <COND (<TYPE? <SET ITEM <1 .PTR>> RES-IND>
 172                        <SET PTR <REST .PTR>>
 173                        <SET ITEM <1 .PTR>>
 174                        <COND (<==? .NUM ,CHANNEL-OP!-MIMOP>
 175                               <SETG HAS-RESULT .ITEM>
 176                               <SET PTR <REST .PTR>>
 177                               <AGAIN>)
 178                              (<==? .ITEM STACK>)
 179                              (<MEMQ .NUM ,DEAD-MIM-CODES>
 180                               <VARTBL-DEAD? .ITEM T>)>)
 181                       (<TYPE? .ITEM VARTBL>
 182                        <COND (.PROTECT? <PROTECT-VAL .ITEM>)>
 183                        <VARTBL-DEAD? .ITEM <>>)
 184                       (<AND <TYPE? .ITEM FORM>
 185                             <==? <LENGTH .ITEM> 2>
 186                             <==? <1 .ITEM> TYPE>
 187                             <==? .NUM ,CHTYPE!-MIMOP>>
 188                        <COND (.PROTECT? <PROTECT-VAL <2 .ITEM>>)>
 189                        <VARTBL-DEAD? <2 .ITEM> <>>)>
 190                 <COND (<G? .CNT <LENGTH .ARGS>>
 191                        <SETG ARGVEC <IVECTOR <+ <LENGTH .ARGS> 50>>>
 192                        <SET ARGS <SUBSTRUC .ARGS 0 <LENGTH .ARGS> ,ARGVEC>>)>
 193                 <PUT .ARGS .CNT .ITEM>
 194                 <SET CNT <+ .CNT 1>>
 195                 <SET PTR <REST .PTR>>>
 196         <SET DISP <- <LENGTH .ARGS> <- .CNT 1>>>
 197         <SUBSTRUC .ARGS 0 <- .CNT 1> <REST .ARGS .DISP>>>
 198
 199 <GDECL (DEAD-MIM-CODES) <UVECTOR [REST FIX]>>
 200
 201 <DEFINE INIT-ALL-STUFF (RESET-ALL)
 202         #DECL ((RESET-ALL) BOOLEAN)
 203         <SETG MAKTUP-FLAG <>>
 204         <SETG ICALL-LEVEL 0>
 205         <RESET-AC-STACK-MODEL>
 206         <RESET-CODE>
 207         <COND (.RESET-ALL
 208                <RESET-FCODE>
 209                <RESET-CONSTANTS>
 210                <INIT-MVEC-STUFF>
 211                <INIT-UNRESOLVED-CALLS>
 212                <INIT-CALL-ENTRYS>)>
 213         <INIT-LABEL-TABLE .RESET-ALL>
 214         <RESET-CALL-TABLE>
 215         <INIT-VAR-LIST>
 216         <INIT-INTERNAL-ENTRYS>
 217         <SETG TEMP-PATCH -1>
 218         <RESET-FRAME-LABEL-TABLE>
 219         <INIT-PATCH-TABLE>
 220         <RESET-PUSH-LABEL-TABLE>
 221         <RESET-MOVE-LABEL-TABLE>>
 222
 223 <DEFINE FCN-PROCESS (NAME DCLS
 224                      "TUPLE" VARS
 225                      "AUX" (VARLST ()) (NVARLST ())
 226                            (LAB <MAKE-LABEL "FNAME">))
 227         #DECL ((DCLS) LIST (VARS) <TUPLE [REST ATOM]>)
 228         <SETG FUNCTION-DECL .DCLS>
 229         <COND (<=? <1 .DCLS> "VALUE">
 230                <SET DCLS <REST .DCLS 2>>)>
 231         <SETG FUNCTION-NAME .NAME>
 232         <SETG ICALL-LABELS ()>
 233         <REPEAT (VAR VDCL TBL)
 234                 <COND (<EMPTY? .VARS> <RETURN>)>
 235                 <SET VAR <1 .VARS>>
 236                 <COND (<TYPE? <SET VDCL <1 .DCLS>> STRING>
 237                        <SET DCLS <REST .DCLS>>
 238                        <SET VDCL <1 .DCLS>>)>
 239                 <SET TBL <CREATE-VAR .VAR <>>>
 240                 <COND (<EMPTY? .VARLST>
 241                        <SET VARLST (.TBL)>
 242                        <SET NVARLST .VARLST>)
 243                       (ELSE
 244                        <PUTREST .NVARLST (.TBL)>
 245                        <SET NVARLST <REST .NVARLST>>)>
 246                 <INDICATE-VAR-DECL .TBL <ISTYPE? .VDCL>>
 247                 <SET VARS <REST .VARS>>
 248                 <SET DCLS <REST .DCLS>>>
 249         <SETG ARGLIST-VARS .VARLST>
 250         <EMIT-LABEL .LAB <>>
 251         <ADD-INTERNAL-ENTRY -1 .LAB>
 252         NORMAL>
 253
 254 <DEFINE TEMP-PROCESS ("TUPLE" TEMPS
 255                       "AUX" ADL SLABEL
 256                             (NOT-YET?
 257                              <AND <ASSIGNED? FIRST-PROCESS?>
 258                                   .FIRST-PROCESS?>))
 259    #DECL ((TEMPS) <TUPLE [REST <OR VARTBL ATOM ADECL LIST>]>)
 260    <COND (<NOT .NOT-YET?>
 261           <SET SLABEL <MAKE-LABEL>>
 262           <EMIT-LABEL .SLABEL <>>
 263           <INDICATE-TEMP-PATCH <ADD-PATCH TEMPORARIES>>)>
 264    <MAPF <>
 265          <FCN (TMP "AUX" TBL TC)
 266               <COND (<TYPE? .TMP VARTBL> <CREATE-VAR .TMP T .NOT-YET?>)
 267                     (<TYPE? .TMP ATOM> <CREATE-VAR .TMP T .NOT-YET?>)
 268                     (<TYPE? .TMP LIST>
 269                      <COND (<TYPE? <SET ADL <1 .TMP>> ADECL>
 270                             <SET TBL <CREATE-VAR <1 .ADL> T .NOT-YET?>>
 271                             <INDICATE-VAR-DECL .TBL <2 .ADL>>)
 272                            (ELSE <SET TBL <CREATE-VAR .ADL T .NOT-YET?>>)>
 273                      <COND (<NOT .NOT-YET?>
 274                             <COND (<AND <TYPE? <SET TC <2 .TMP>> FORM>
 275                                         <==? <LENGTH .TC> 2>
 276                                         <==? <1 .TC> QUOTE>
 277                                         <TYPE? <2 .TC> ATOM>>
 278                                    <SET TC <2 .TC>>)>
 279                             <INDICATE-VAR-INIT .TBL .TC>)>)
 280                     (<TYPE? .TMP ADECL>
 281                      <SET TBL <CREATE-VAR <1 .TMP> T .NOT-YET?>>
 282                      <INDICATE-VAR-DECL .TBL <2 .TMP>>)
 283                     (<ERROR "BAD TEMP STATEMENT" TEMP-PROCESS>)>>
 284          .TEMPS>
 285    NORMAL>
 286
 287 <DEFINE ISTYPE? (DCL)
 288         #DECL ((DCL) <OR ATOM FORM>)
 289         <COND (<TYPE? .DCL ATOM> <AND <VALID-TYPE? .DCL> .DCL>)
 290               (<AND <TYPE? <SET DCL <1 .DCL>> ATOM> <VALID-TYPE? .DCL>> .DCL)>>
 291
 292 <DEFINE END-GEN () UNCONDITIONAL-BRANCH>
 293
 294 <DEFINE UCBRANCH-GEN (DIR LABEL)
 295         #DECL ((DIR LABEL) ATOM)
 296         <GEN-BRANCH ,INST-BRB .LABEL UNCONDITIONAL-BRANCH>
 297         UNCONDITIONAL-BRANCH>
 298
 299 <DEFINE LOCATION-GEN (DIR LABEL RES "AUX" VAC)
 300         #DECL ((DIR LABEL) ATOM (RES) VARTBL)
 301         <PROTECT <SET VAC <GET-AC ANY-AC T>>>
 302         <EMIT-MOVE-LABEL .LABEL <MA-REG .VAC>>
 303         <DEST-DECL .VAC .RES FIX>
 304         NORMAL>
 305
 306 <DEFINE LOAD-VAR-APP (VAR
 307                       "OPTIONAL" (MUNG T) (DCL <VARTBL-DECL .VAR>) (USE? T))
 308         #DECL ((VAR) VARTBL)
 309         <COND (<OR <NOT .DCL> <STRUCTURED-TYPE? .DCL>>
 310                <LOAD-VAR .VAR VALUE .MUNG PREF-VAL .DCL .USE?>)
 311               (ELSE <LOAD-VAR .VAR VALUE .MUNG PREF-VAL .DCL .USE?>)>>
 312
 313 <DEFINE PROCESS-DESTINATION-HINT (HINT DEST "AUX" DCL)
 314         #DECL ((HINT) <OR FALSE HINT ATOM> (DEST) <OR ATOM VARTBL>)
 315         <COND (<AND <TYPE? .DEST VARTBL>
 316                     <COND (<TYPE? .HINT LIST>
 317                            <SET DCL <PARSE-HINT .HINT TYPE>>)
 318                           (<TYPE? .HINT ATOM> <SET DCL .HINT>)>>
 319                <INDICATE-VAR-TEMP-DECL .DEST .DCL>)>>
 320
 321 <DEFINE MOVE-TYPE (VAL TEADDR
 322                    "OPTIONAL" (CEADDR <>)
 323                    "AUX" DCL RADDR ADDR1 LVAR)
 324    #DECL ((VAL) ANY (TEADDR) <OR AC EFF-ADDR> (CEADDR) <OR FALSE EFF-ADDR>)
 325    <COND (<TYPE? .TEADDR AC> <SET RADDR <MA-REG .TEADDR>>)
 326          (<SET RADDR .TEADDR>)>
 327    <COND (<TYPE? .VAL VARTBL>
 328           <COND (<OR <SAFE-TYPE-WORD? .VAL>
 329                      <AND <SET LVAR <FIND-CACHE-VAR .VAL>>
 330                           <OR <AND <NOT <LINKVAR-TYPE-AC .LVAR>>
 331                                    <NOT <LINKVAR-TYPE-WORD-AC .LVAR>>
 332                                    <NOT <LINKVAR-COUNT-AC .LVAR>>
 333                                    <NOT <VARTBL-DECL .VAL>>>
 334                               <AND <LINKVAR-TYPE-STORED .LVAR>
 335                                    <LINKVAR-COUNT-STORED .LVAR>>>>>
 336                  <EMIT-MOVE <VAR-TYPE-ADDRESS .VAL TYPE-WORD> .RADDR LONG>
 337                  <AND <TYPE? .TEADDR AC>
 338                       <LOAD-AC .TEADDR <VAR-TYPE-ADDRESS .VAL TYPE-WORD>>>)
 339                 (<SET DCL <VARTBL-DECL .VAL>>
 340                  <COND (<COUNT-NEEDED? .DCL>
 341                         <SET ADDR1 <VAR-COUNT-ADDRESS .VAL>>
 342                         <COND (<TYPE? .TEADDR AC>
 343                                <EMIT-MOVE <TYPE-WORD .DCL> .RADDR LONG>
 344                                <EMIT ,INST-BISW2 .ADDR1 <MA-REG .TEADDR>>
 345                                <USE-AC .TEADDR>)
 346                               (ELSE
 347                                <EMIT-MOVE .ADDR1 .CEADDR WORD>
 348                                <EMIT-MOVE <TYPE-CODE .DCL WORD>
 349                                           .TEADDR
 350                                           WORD>)>)
 351                        (ELSE
 352                         <EMIT-MOVE <TYPE-WORD .DCL> .RADDR LONG>
 353                         <AND <TYPE? .TEADDR AC>
 354                              <LOAD-AC .TEADDR <TYPE-WORD .DCL>>>)>)
 355                 (<ERROR "NO TYPE WORD" MOVE-TYPE>)>)
 356          (<FIX-CONSTANT? .VAL>
 357           <EMIT-MOVE <TYPE-WORD <TYPE .VAL>> .RADDR LONG>
 358           <AND <TYPE? .TEADDR AC> <LOAD-AC .TEADDR <TYPE-WORD <TYPE .VAL>>>>)
 359          (ELSE
 360           <SET ADDR1 <ADDR-TYPE-M <ADD-MVEC .VAL>>>
 361           <EMIT-MOVE .ADDR1 .TEADDR LONG>
 362           <AND <TYPE? .TEADDR AC> <LOAD-AC .TEADDR .ADDR1>>)>>
 363
 364 <DEFINE GEN-CONSTANT (RCNS VALUE-AC TYPE-AC GEN-PREF
 365                       "AUX" (CNS .RCNS) VAC TAC (TYP <TYPE .CNS>))
 366         #DECL ((CNS) ANY (VALUE-AC TYPE-AC) <OR ATOM AC> (GEN-PREF) ATOM)
 367         <PROTECT <SET VAC <GET-AC .VALUE-AC T>>>
 368         <MOVE-VALUE .CNS .VAC>
 369         <COND (<AND <N==? .GEN-PREF TYPE-WORD> <NOT <COUNT-NEEDED? .TYP>>>
 370                <SETG CONSTANT-TYPE-AC <>>
 371                <SETG CONSTANT-COUNT-AC <>>)
 372               (ELSE
 373                <SET TAC <GET-AC PREF-TYPE>>
 374                <MUNG-AC .TAC>
 375                <COND (<==? .GEN-PREF TYPE-WORD>
 376                       <COND (<SET CNS <FIX-CONSTANT? .CNS>>
 377                              <EMIT-MOVE <TYPE-WORD .TYP> <MA-REG .TAC> LONG>
 378                              <LOAD-AC .TAC <TYPE-WORD .TYP>>)
 379                             (ELSE
 380                              <EMIT-MOVE <ADDR-TYPE-MQUOTE .RCNS>
 381                                         <MA-REG .TAC>
 382                                         LONG>
 383                              <LOAD-AC .TAC <ADDR-TYPE-MQUOTE .RCNS>>)>
 384                       <SETG CONSTANT-TYPE-AC .TAC>)
 385                      (ELSE
 386                       <LOAD-CONSTANT .TAC <LENGTH .RCNS>>
 387                       <SETG CONSTANT-COUNT-AC .TAC>)>)>
 388         .VAC>
 389
 390 <DEFINE LOAD-CONSTANT (DEST RVAL "AUX" VAL ADDR)
 391         #DECL ((AC) AC (VAL) FIX)
 392         <COND (<TYPE? .DEST AC> <SET ADDR <MA-REG .DEST>>)
 393               (ELSE <SET ADDR .DEST>)>
 394         <SET VAL <FIX-CONSTANT? .RVAL>>
 395         <COND (<0? .VAL> <EMIT ,INST-CLRL .ADDR>)
 396               (<AND <G=? .VAL 1> <L=? .VAL 63>>
 397                <EMIT ,INST-MOVL <MA-LIT .VAL> .ADDR>)
 398               (<AND <G=? .VAL -63> <L=? .VAL -1>>
 399                <EMIT ,INST-MNEGL <MA-LIT <- .VAL>> .ADDR>)
 400               (<AND <G=? .VAL 64> <L=? .VAL 255>>
 401                <EMIT ,INST-MOVZBL <MA-BYTE-IMM .VAL> .ADDR>)
 402               (<AND <G=? .VAL -127> <L=? .VAL -64>>
 403                <EMIT ,INST-CVTBL <MA-BYTE-IMM .VAL> .ADDR>)
 404               (<AND <G=? .VAL 255> <L=? .VAL ,MAXP16C>>
 405                <EMIT ,INST-MOVZWL <MA-WORD-IMM .VAL> .ADDR>)
 406               (<AND <G=? .VAL ,MIN16C> <L=? .VAL -128>>
 407                <EMIT ,INST-CVTWL <MA-WORD-IMM .VAL> .ADDR>)
 408               (<TYPE? .RVAL FLOAT>
 409                <COND (<G=? .RVAL 0.0>
 410                       <EMIT ,INST-MOVF <FLOAT-IMM .VAL> .ADDR>)
 411                      (ELSE
 412                       <EMIT ,INST-MNEGF <FLOAT-IMM <FLOATCONVERT <- .RVAL>>>
 413                             .ADDR>)>)
 414               (ELSE <EMIT ,INST-MOVL <MA-LONG-IMM .VAL> .ADDR>)>>
 415
 416 <DEFINE DEST-DECL (AC DEST DCL "OPTIONAL" (STATUS? <>))
 417         #DECL ((AC) AC (DEST) <OR ATOM VARTBL> (DCL) ATOM
 418                (STATUS?) <OR FALSE ATOM>)
 419         <COND (<==? .DEST STACK> <PUSH-PAIR .DCL .AC> <CLEAR-STATUS>)
 420               (<TYPE? .DEST VARTBL>
 421                <DEAD-VAR .DEST>
 422                <LINK-VAR-TO-AC .DEST .AC VALUE <>>
 423                <INDICATE-CACHED-VARIABLE-DECL .DEST .DCL>
 424                <COND (.STATUS?
 425                       <SET-STATUS-AC .AC>
 426                       <SET-STATUS-VAR .DEST .STATUS?>)>)>>
 427
 428 <DEFINE DEST-COUNT-DECL (VAC CAC DEST DCL "OPTIONAL" (STATUS? <>))
 429         #DECL ((VAC CAC) AC (DEST) <OR ATOM VARTBL> (DCL) ATOM
 430                (STATUS?) <OR FALSE ATOM>)
 431         <COND (<==? .DEST STACK>
 432                <PUSH-PAIR-WITH-CNT .DCL .VAC .CAC>
 433                <CLEAR-STATUS>)
 434               (<TYPE? .DEST VARTBL>
 435                <DEAD-VAR .DEST>
 436                <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
 437                <INDICATE-CACHED-VARIABLE-DECL .DEST .DCL>
 438                <LINK-VAR-TO-AC .DEST .CAC COUNT <>>
 439                <COND (.STATUS?
 440                       <SET-STATUS-AC .VAC>
 441                       <SET-STATUS-VAR .DEST .STATUS?>)>)>>
 442
 443 <DEFINE DEST-PAIR (VAC CAC DEST "OPTIONAL" (STATUS? <>))
 444         #DECL ((CAC VAC) AC (DEST) <OR ATOM VARTBL> (STATUS?) <OR FALSE ATOM>)
 445         <COND (<==? .DEST STACK>
 446                <AND ,GC-MODE
 447                     <EMIT ,INST-BICW2
 448                           <MA-IMM ,SHORT-TYPE-MASK>
 449                           <MA-REG .CAC>>>
 450                <COND (<==? <+ <AC-NUMBER .CAC> 1> <AC-NUMBER .VAC>>
 451                       <EMIT-PUSH <MA-REG .CAC> DOUBLE>)
 452                      (ELSE
 453                       <EMIT-PUSH <MA-REG .CAC> LONG>
 454                       <EMIT-PUSH <MA-REG .VAC> LONG>)>
 455                <CLEAR-STATUS>)
 456               (<TYPE? .DEST VARTBL>
 457                <DEAD-VAR .DEST>
 458                <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
 459                <LINK-VAR-TO-AC .DEST .CAC TYPE-WORD <>>
 460                <COND (.STATUS?
 461                       <SET-STATUS-AC .VAC>
 462                       <SET-STATUS-VAR .DEST VALUE>)>)>>
 463
 464 <DEFINE DEST-TYPE-VALUE (VAC TAC DEST "OPTIONAL" (STATUS? <>) LVAR)
 465         #DECL ((VAC TAC) AC (DEST) <OR ATOM VARTBL> (STATUS?) <OR FALSE ATOM>
 466                (LVAR) LINKVAR)
 467         <COND (<==? .DEST STACK>
 468                <EMIT-PUSH <MA-REG .TAC> WORD>
 469                <CLEAR-PUSH WORD>
 470                <EMIT-PUSH <MA-REG .VAC> LONG>
 471                <CLEAR-STATUS>)
 472               (<TYPE? .DEST VARTBL>
 473                <DEAD-VAR .DEST>
 474                <LINK-VAR-TO-AC .DEST .VAC VALUE <>>
 475                <LINK-VAR-TO-AC .DEST .TAC TYPE <>>
 476                <SET LVAR <FIND-CACHE-VAR .DEST>>
 477                <PUT .LVAR ,LINKVAR-COUNT-STORED T>
 478                <COND (.STATUS?
 479                       <SET-STATUS-AC .VAC>
 480                       <SET-STATUS-VAR .DEST VALUE>)>)>>
 481
 482 <DEFINE PUSH-PAIR (TYP VAC)
 483         #DECL ((TYP) ATOM (VAC) AC)
 484         <EMIT-PUSH <TYPE-WORD .TYP> LONG>
 485         <EMIT-PUSH <MA-REG .VAC> LONG>>
 486
 487 <DEFINE PUSH-PAIR-WITH-CNT (DCL VAC DAC)
 488         #DECL ((VAC DAC) AC (DCL) ATOM)
 489         <EMIT-PUSH <TYPE-CODE .DCL> WORD>
 490         <EMIT-PUSH <MA-REG .DAC> WORD>
 491         <EMIT-PUSH <MA-REG .VAC> LONG>>
 492
 493 <DEFINE PUSH-GEN (VAL)
 494         #DECL ((VAL) ANY)
 495         <COND (<TYPE? .VAL VARTBL> <PUSH-VAR .VAL>) (<PUSH-CONSTANT .VAL>)>
 496         NORMAL>
 497
 498 <DEFINE POP-GEN (RES "AUX" VAC TAC)
 499         #DECL ((RES) VARTBL)
 500         <SET TAC <GET-AC DOUBLE>>
 501         <EMIT-POP .TAC DOUBLE>
 502         <DEST-PAIR <NEXT-AC .TAC> .TAC .RES>>
 503
 504 <DEFINE INIT-OPERATIONS ()
 505         <SETG OP-APPLY-VECTOR <IVECTOR ,MAX-NUMBER-OPS ,BAD-OPERATION>>
 506         <SETG OP-COUNT 1>
 507         <SETG MIMOP-OBLIST <MOBLIST MIMOP 51>>
 508         <SETG VAR-OBLIST <MOBLIST VARS 51>>>
 509
 510 <DEFINE DEFINE-MIMOP (NAME FCN "OPT" (PROTECT? <>) "AUX" (CNT ,OP-COUNT) ANAME)
 511         #DECL ((NAME) STRING)
 512         <COND (<G? .CNT ,MAX-NUMBER-OPS>
 513                <ERROR "TOO MANY OPERATIONS" DEFINE-MIMOP>)>
 514         <PUT ,OP-APPLY-VECTOR .CNT .FCN>
 515         <SET ANAME
 516              <OR <LOOKUP .NAME ,MIMOP-OBLIST> <INSERT .NAME ,MIMOP-OBLIST>>>
 517         <SETG .ANAME <COND (.PROTECT? <- .CNT>)
 518                            (.CNT)>>
 519         <SETG OP-COUNT <+ .CNT 1>>>
 520
 521 <DEFINE STRUCTURED-TYPE? (DCL)
 522         #DECL ((DCL) ATOM)
 523         <COND (<ISTYPE? .DCL>
 524                <MEMQ <TYPEPRIM .DCL>
 525                      '[OFFSET RECORD UVECTOR STRING LIST VECTOR ATOM]>)
 526               (T)>>
 527
 528 <DEFINE COUNT-NEEDED? (DCL)
 529         #DECL ((DCL) ATOM)
 530         <SET DCL <CLEAN-DECL .DCL>>
 531         <AND <ISTYPE? .DCL>
 532              <MEMQ <TYPEPRIM .DCL>
 533                    '[OFFSET STRING VECTOR RECORD UVECTOR TUPLE BYTES]>>>
 534
 535 <DEFINE PARSE-HINT (HINT NAME "AUX" HTYP VAL)
 536         #DECL ((HINT) HINT (NAME) ATOM)
 537         <COND (<AND <TYPE? <SET HTYP <1 .HINT>> FORM>
 538                     <==? <LENGTH .HTYP> 2>
 539                     <==? <1 .HTYP> QUOTE>>
 540                <SET HTYP <2 .HTYP>>)>
 541         <COND (<==? .HTYP .NAME>
 542                <COND (<AND <==? .HTYP TYPE>
 543                            <NOT <VALID-TYPE? <2 .HINT>>>
 544                            <SET VAL <CHECK-MIMOP-TYPE <2 .HINT>>>>
 545                       .VAL)
 546                      (<2 .HINT>)>)>>
 547
 548 <DEFINE ADD-TO-AC (VAC VADDR)
 549         #DECL ((VAC) AC (VADDR) EFF-ADDR)
 550         <EMIT ,INST-ADDL2 .VADDR <MA-REG .VAC>>>
 551
 552 <DEFINE SUB-FROM-AC (VAC VADDR)
 553         #DECL ((VAC) AC (VADDR) EFF-ADDR)
 554         <EMIT ,INST-SUBL2 .VADDR <MA-REG .VAC>>>
 555
 556 <DEFINE MOVE-VALUE (VAL EADDR "AUX" FX? ADDR1)
 557         #DECL ((VAL) ANY (EADDR) <OR AC EFF-ADDR>)
 558         <COND (<TYPE? .VAL VARTBL>
 559                <SET ADDR1 <VAR-VALUE-ADDRESS .VAL>>
 560                <COND (<TYPE? .EADDR AC>
 561                       <EMIT-MOVE .ADDR1 <MA-REG .EADDR> LONG>
 562                       <LOAD-AC .EADDR .ADDR1>)
 563                      (<EMIT-MOVE .ADDR1 .EADDR LONG>)>)
 564               (<FIX-CONSTANT? .VAL> <LOAD-CONSTANT .EADDR .VAL>)
 565               (ELSE
 566                <SET ADDR1 <ADDR-VALUE-MQUOTE .VAL>>
 567                <COND (<TYPE? .EADDR AC>
 568                       <EMIT-MOVE .ADDR1 <MA-REG .EADDR> LONG>
 569                       <LOAD-AC .EADDR .ADDR1>)
 570                      (<EMIT-MOVE .ADDR1 .EADDR LONG>)>)>>
 571
 572
 573
 574 <DEFINE ADD-CONSTANT-TO-AC (VAL DEST
 575                             "AUX" SDATA (ACADDR <MA-REG .DEST>) SZ DADDR)
 576         #DECL ((VAL) FIX (DEST) AC)
 577         <SET VAL <FIX-CONSTANT? .VAL>>
 578         <COND (<0? .VAL>)
 579               (<==? .VAL 1> <EMIT ,INST-INCL .ACADDR>)
 580               (<==? .VAL -1> <EMIT ,INST-DECL .ACADDR>)
 581               (<AND <G=? .VAL 0> <L=? .VAL 63>>
 582                <EMIT ,INST-ADDL2 <MA-LIT .VAL> .ACADDR>)
 583               (<AND <G=? .VAL -63> <L=? .VAL 0>>
 584                <EMIT ,INST-SUBL2 <MA-LIT <- .VAL>> .ACADDR>)
 585               (ELSE <EMIT ,INST-ADDL2 <MA-LONG-IMM .VAL> .ACADDR>)>>
 586
 587 <DEFINE CLEAN-DECL (DCL "AUX" (NAME <SPNAME .DCL>) (SNAME .NAME))
 588         #DECL ((DCL) ATOM)
 589         <COND (<AND <G? <LENGTH .NAME> 2>
 590                     <==? <2 .NAME> !\$>
 591                     <==? <1 .NAME> !\T>
 592                     <SET NAME <LOOKUP <REST .NAME 2> <ROOT>>>
 593                     <OR <ISTYPE? .NAME> <MEMQ .NAME '[LBIND GBIND]>>>
 594                .NAME)
 595               (<ISTYPE? .DCL> .DCL)
 596               (<LOOKUP .SNAME <ROOT>>)
 597               (.DCL)>>
 598
 599 <DEFINE CHECK-MIMOP-TYPE (ITEM)
 600         #DECL ((ITEM) ATOM)
 601         <COND (<AND <==? <OBLIST? .ITEM> ,MIMOP-OBLIST>
 602                     <NOT <VALID-TYPE? .ITEM>>
 603                     <SET ITEM <LOOKUP <SPNAME .ITEM> <ROOT>>>
 604                     <VALID-TYPE? .ITEM>>
 605                .ITEM)>>
 606
 607 <DEFINE PRINT-MSUBR (BYTEOFF "OPTIONAL" (OUTCHAN .OUTCHAN))
 608         #DECL ((OUTCHAN) CHANNEL)
 609         <COND (<NOT ,BOOT-MODE>
 610                <PRINC "<SETG \1a" .OUTCHAN>
 611                <PRIN1 ,FUNCTION-NAME .OUTCHAN>
 612                <PRINC " " .OUTCHAN>)>
 613         <PRINC "#MSUBR [" .OUTCHAN>
 614         <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
 615         <PRINC !\  .OUTCHAN>
 616         <PRIN1 ,FUNCTION-NAME .OUTCHAN>
 617         <PRINC !\  .OUTCHAN>
 618         <PRIN1 ,FUNCTION-DECL .OUTCHAN>
 619         <PRINC !\  .OUTCHAN>
 620         <PRIN1 .BYTEOFF .OUTCHAN>
 621         <PRINC !\] .OUTCHAN>
 622         <OR ,BOOT-MODE <PRINC ">" .OUTCHAN>>
 623         <CRLF .OUTCHAN>>
 624
 625 <MSETG INFINITY <CHTYPE <MIN> FIX>>
 626
 627 <DEFINE PRINT-IMSUBR ("OPTIONAL" (OUTCHAN .OUTCHAN) "AUX" (LLEN
 628                                                            <M-HLEN .OUTCHAN>))
 629         #DECL ((OUTCHAN) CHANNEL)
 630         <CRLF .OUTCHAN>
 631         <COND (<NOT ,BOOT-MODE>
 632                <PRINC "<SETG \1a" .OUTCHAN>
 633                <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
 634                <PRINC " " .OUTCHAN>)>
 635         <PRINC "#IMSUBR [" .OUTCHAN>
 636         <COND (,BOOT-MODE <PRINT-HEX-CODE .OUTCHAN>)
 637               (ELSE <PRINT-NHEX-CODE .OUTCHAN>)>
 638         <PRINC !\  .OUTCHAN>
 639         <PRIN1 ,INTERNAL-MSUBR-NAME .OUTCHAN>
 640         <PRINC !\  .OUTCHAN>
 641         <PRINT-MVEC-ELEMENTS .OUTCHAN>
 642         <PRINC !\] .OUTCHAN>
 643         <OR ,BOOT-MODE <PRINC ">" .OUTCHAN>>
 644         <CRLF .OUTCHAN>>
 645
 646 <GDECL (MSUBR-BUF) STRING (MSUBR-PTR) FIX>
 647 <DEFINE PRINT-NHEX-CODE ("OPTIONAL" (OUTCHAN .OUTCHAN) (PTR 1)
 648                                     (MAXPTR ,FBYTE-OFFSET)
 649                                     (LEN </ <+ .MAXPTR 1> 4>))
 650         #DECL ((OUTCHAN) CHANNEL (PTR MAXPTR) FIX)
 651         <COND (<NOT <GASSIGNED? MSUBR-BUF>>
 652                <SETG MSUBR-BUF <ISTRING 1024>>)
 653               (<SETG MSUBR-BUF <TOP ,MSUBR-BUF>>)>
 654         <SETG MSUBR-PTR 0>
 655         <SETG MSUBR-CHAN .OUTCHAN>
 656         <WRITE-BYTE !\|>
 657         <PRINTBYTE </ .LEN 65536>>
 658         <PRINTBYTE </ <MOD .LEN 65536> 256>>
 659         <PRINTBYTE <MOD .LEN 256>>
 660         <REPEAT (WD)
 661                 <COND (<L=? <+ .PTR 3> .MAXPTR>
 662                        <PRINTBYTE <NTH-FCODE <+ .PTR 3>>>)
 663                       (ELSE <PRINTBYTE 0>)>
 664                 <COND (<L=? <+ .PTR 2> .MAXPTR>
 665                        <PRINTBYTE <NTH-FCODE <+ .PTR 2>>>)
 666                       (ELSE <PRINTBYTE 0>)>
 667                 <COND (<L=? <+ .PTR 1> .MAXPTR>
 668                        <PRINTBYTE <NTH-FCODE <+ .PTR 1>>>)
 669                       (ELSE <PRINTBYTE 0>)>
 670                 <PRINTBYTE <NTH-FCODE .PTR>>
 671                 <COND (<G? <SET PTR <+ .PTR 4>> .MAXPTR> <RETURN>)>>
 672         <WRITE-BYTE !\|>
 673         <CHANNEL-OP .OUTCHAN WRITE-BUFFER <TOP ,MSUBR-BUF> ,MSUBR-PTR>>
 674
 675 <DEFINE PRINTBYTE (NUM)
 676         #DECL ((NUM) FIX)
 677         <WRITE-BYTE <ASCII <+ <ASCII !\A> <CHTYPE <LSH .NUM -5> FIX>>>>
 678         <WRITE-BYTE <ASCII <+ <ASCII !\A> <CHTYPE <ANDB .NUM 31> FIX>>>>>
 679
 680 <DEFINE WRITE-BYTE (BYTE "AUX" (S ,MSUBR-BUF))
 681   #DECL ((BYTE) CHARACTER (S) STRING)
 682   <COND (<EMPTY? .S>
 683          <SET S <TOP .S>>
 684          <CHANNEL-OP ,MSUBR-CHAN WRITE-BUFFER .S ,MSUBR-PTR>
 685          <SETG MSUBR-PTR 0>)>
 686   <1 .S .BYTE>
 687   <SETG MSUBR-BUF <REST .S>>
 688   <SETG MSUBR-PTR <+ ,MSUBR-PTR 1>>>