mim/development/mim/20c/part1.mud

   1 <COND (<NOT <GASSIGNED? WIDTH-MUNG>>
   2        <FLOAD "MIMOC20DEFS.MUD">
   3        <FLOAD "MSGLUE-PM.MUD">)>
   4
   5 <DEFINE GLUE-FIXUP ()
   6         <MAPF <>
   7               <FUNCTION (FROB "AUX" (LBL <5 .FROB>))
   8                    #DECL ((FROB) <LIST ATOM LIST FIX LIST LIST>
   9                           (LBL) LIST)
  10                    <FIXUP-ONE-GLUE <4 .FROB> .LBL>
  11                    <FIXUP-CONSTANTS <4 .FROB>>>
  12               ,GLUE-LIST>>
  13
  14 <DEFINE FIXUP-ONE-GLUE (CODE LBL "AUX" (N 0))
  15    #DECL ((CODE LBL) LIST)
  16    <MAPR <>
  17     <FUNCTION (LST "AUX" (INS <1 .LST>) ITM CONST LB FC)
  18        #DECL ((LST) LIST (CONST) CONSTANT (FC) CONSTANT-BUCKET
  19               (INS) <OR ATOM INST CONSTANT CONST-W-LOCAL> (ITM) ANY)
  20        <COND (<NOT <TYPE? .INS ATOM>> <SET N <+ .N 1>>)>
  21        <COND
  22         (<TYPE? .INS INST>
  23          <COND
  24           (<TYPE? <SET ITM <1 .INS>> GFRM SGFRM SBFRM>
  25            <COND (<==? <SET ITM <CHTYPE .ITM ATOM>> COMPERR>
  26                   <SET CONST <CHTYPE <+ ,SETZ 106> CONSTANT>>)
  27                  (<OR <==? .ITM UNWCONT> <==? .ITM IOERR>>
  28                   <SET CONST <CHTYPE <+ ,SETZ-IND <OPCODE .ITM>> CONSTANT>>)
  29                  (<OR <NOT <SET LB <OR <FIND-LABEL .ITM>
  30                                        <LONG-FIND-LABEL .ITM .LBL>>>>
  31                       <NOT <SET LB <LAB-IND .LB>>>>
  32                   <MIMOCERR BAD-FRM-LABEL!-ERRORS .ITM>)
  33                  (ELSE
  34                   <SET CONST
  35                        <CHTYPE <+ <CHTYPE .LB FIX>
  36                                   <COND (<TYPE? <1 .INS> GFRM> ,SETZ-R)
  37                                         (<TYPE? <1 .INS> SBFRM> ,SETZQ-R)
  38                                         (ELSE ,SETZX-R)>>
  39                                 CONSTANT>>)>
  40            <SET FC <1 ,FREE-CONSTS>>
  41            <CB-VAL .FC .CONST>
  42            <SETG FREE-CONSTS <REST ,FREE-CONSTS>>
  43            <SET ITM <CHTYPE [.FC] REF>>
  44            <PUT .LST 1 <COND (<TYPE? <1 .INS> SBFRM> <CHTYPE [MOVE O* .ITM] INST>)
  45                              (ELSE <CHTYPE [PUSH TP* .ITM] INST>)>>)
  46           (<TYPE? .ITM GCAL>
  47            <COND (,MAX-SPACE
  48                   <PUT .LST 1 <CHTYPE [JRST 0 '(R*)] INST>>
  49                   <SETG GCALS ((.N <CHTYPE .ITM ATOM> <3 .INS>) !,GCALS)>)
  50                  (ELSE
  51                   <PUT .LST 1
  52                         <CHTYPE [JRST <GFIND <CHTYPE .ITM ATOM> <3 .INS>> '(R*)]
  53                                 INST>>)>)>)>>
  54     .CODE>>
  55
  56 <DEFINE FIND-CALL (ATM LIST)
  57   #DECL ((ATM) ATOM (LIST) <LIST [REST ATOM]>)
  58   <REPEAT ()
  59     <COND (<EMPTY? .LIST> <RETURN <>>)>
  60     <COND (<SAME-NAME? .ATM <1 .LIST>> <RETURN .LIST>)>
  61     <SET LIST <REST .LIST>>>>
  62
  63 <DEFINE FIND-OPT (ATM LIST)
  64   #DECL ((ATM) ATOM (LIST) <LIST [REST ATOM <PRIMTYPE LIST>]>)
  65   <REPEAT ()
  66     <COND (<EMPTY? .LIST> <RETURN <>>)>
  67     <COND (<SAME-NAME? .ATM <1 .LIST>> <RETURN <REST .LIST>>)>
  68     <SET LIST <REST .LIST 2>>>>
  69
  70 <DEFINE SAME-NAME? (X Y "AUX" S1 S2)
  71   #DECL ((X Y) ATOM (S1 S2) STRING)
  72   <COND (<NOT ,INT-MODE>
  73          <==? .X .Y>)
  74         (T
  75          <SET S1 <SPNAME .X>>
  76          <SET S2 <SPNAME .Y>>
  77          <OR <==? .X .Y>
  78              <AND <G? <LENGTH .S1> 2>
  79                   <==? <1 .S1> !\T>
  80                   <==? <2 .S1> !\$>
  81                   <=? <REST .S1 2> .S2>>
  82              <AND <G? <LENGTH .S2> 2>
  83                   <==? <1 .S2> !\T>
  84                   <==? <2 .S2> !\$>
  85                   <=? <REST .S2 2> .S1>>>)>>
  86
  87 <DEFINE GFIND (NAM LBL?)
  88         #DECL ((NAM) ATOM (LBL?) <OR ATOM FALSE>)
  89         <COND (<MAPF <>
  90                      <FUNCTION (L "AUX" X)
  91                           #DECL ((L) <LIST ATOM LIST FIX>)
  92                           <COND (<SAME-NAME? <1 .L> .NAM>
  93                                  <COND (.LBL?
  94                                         <COND (<AND <SET X
  95                                                          <FIND-LABEL .LBL?>>
  96                                                     <SET X <LAB-IND .X>>>
  97                                                <MAPLEAVE .X>)
  98                                               (ELSE
  99                                                <MIMOCERR BAD-OPT-LABEL!-ERRORS
 100                                                          .LBL?>)>)
 101                                        (ELSE <MAPLEAVE <3 .L>>)>)>>
 102                      ,GLUE-LIST>)
 103               (ELSE
 104                <MIMOCERR CANT-FIND-GL-ENTRY!-ERRORS .NAM>)>>
 105
 106 <DEFINE CALL-ANA (L "AUX" (ANA-L ()))
 107         #DECL ((L ANA-L) LIST)
 108         <MAPF <>
 109               <FUNCTION (ITM "AUX" ONE LBL TEM IT X)
 110                    #DECL ((ITM) <OR ATOM FORM> (ONE LBL) ATOM)
 111                    <COND (<AND <TYPE? .ITM FORM>
 112                                <NOT <EMPTY? .ITM>>>
 113                           <COND (<OR <==? <SET ONE <1 .ITM>> FRAME>
 114                                      <==? .ONE SFRAME>>
 115                                  <SET ANA-L (.ITM !.ANA-L)>)
 116                                 (<OR <==? .ONE CALL> <==? .ONE SCALL>>
 117                                  <COND (<AND <TYPE? <SET IT <2 .ITM>> FORM>
 118                                              <==? <LENGTH .IT> 2>
 119                                              <==? <1 .IT> QUOTE>
 120                                              <PROG () <SET IT <2 .IT>> T>
 121                                              <OR <AND ,GLUE-MODE
 122                                                       <FIND-CALL .IT
 123                                                                  ,PRE-NAMES>>
 124                                                  <SUBRIFY? .IT>>
 125                                              <NOT <MEMQ .IT
 126                                                         '[GVAL GASSIGNED?]>>>
 127                                         <COND (<NOT <AND <TYPE? <SET TEM
 128                                                                     <1 .ANA-L>>
 129                                                                FORM>
 130                                                          <G? <LENGTH .TEM> 1>
 131                                                          <TYPE? <SET X
 132                                                                      <2 .TEM>>
 133                                                                FORM>
 134                                                          <==? <LENGTH .X> 2>
 135                                                          <==? <1 .X> QUOTE>
 136                                                          <==? .IT <2 .X>>>>
 137                                                <MIMOCERR
 138                                                 BAD-FRAME-CALL-MATCH!-ERRORS
 139                                                 .ITM .TEM>)
 140                                               (ELSE
 141                                                <PUTREST
 142                                                  .TEM
 143                                                  (<SET LBL
 144                                                        <GENLBL "?FRM">>
 145                                                   .IT)>
 146                                                <PUTREST <REST .ITM
 147                                                               <- <LENGTH .ITM>
 148                                                                  1>>
 149                                                         (.LBL)>)>)>
 150                                  <SET ANA-L <REST .ANA-L>>)
 151                                 (<==? .ONE ACALL>
 152                                  <SET ANA-L <REST .ANA-L>>)>)>>
 153               .L>>
 154
 155 <DEFINE MIMOC (L "OPT" (WINNER <>)
 156                  "AUX" NAME (OBLIST .OBLIST) (OUTCHAN .OUTCHAN) PO
 157                  "NAME" MACT)
 158    #DECL ((L) <LIST [REST <OR ATOM FORM>]> (NAME) ATOM
 159           (MACT) <SPECIAL ANY> (OUTCHAN OBLIST) <SPECIAL ANY>)
 160    <COND (,NO-AC-FUNNYNESS <SETG PASS1 <>>) (ELSE <SETG PASS1 T>)>
 161    <SETG NEXT-LOOP <SETG LAST-UNCON <>>>
 162    <SETG AC-STAMP <SETG VISIT-COUNT 0>>
 163    <SETG LABELS ()>
 164    <PRE-HACK .L>
 165    <PROG ((LSEQ ,LBLSEQ) (OLD-LOCS ()))
 166      <FLUSH-ACS>
 167      <SETG STACK-DEPTH 0>
 168      <SETG CHANGED <>>
 169      <COND (.WINNER <SETG WINNING-VICTIM 2>)
 170            (ELSE <SETG WINNING-VICTIM <>>)>
 171      <MAPR <>
 172       <FUNCTION (MIML "AUX" (ITM <1 .MIML>) OP ITML M LB DCLIST (OPT? <>))
 173          #DECL ((MIML) <SPECIAL LIST> (ITM) <OR ATOM FORM>
 174                 (M) <OR FALSE <LIST ATOM ATOM>> (DCLIST) LIST)
 175          <COND (,ACA-AC
 176                 <AC-ITEM ,ACA-AC ,ACA-ITEM>
 177                 <COND (,ACA-BOTH <AC-ITEM ,ACA-BOTH ,ACA-ITEM>)>
 178                 <SETG ACA-AC <>>)>
 179          <SETG FIRST-AC T>
 180          <COND
 181           (<TYPE? .ITM ATOM>
 182            <COND
 183             (<SET M <MEMQ .ITM ,ICALL-TAGS>>
 184              <PUSHJ-VAL <3 .M>>
 185              <SETG LAST-UNCON <>>
 186              <LABEL <2 .M> <> .MIML>
 187              <COND (<0? <SETG ICALL-FLAG <- ,ICALL-FLAG 1>>>
 188                     <SETG ICALL-FLAG <>>)>
 189              <COND (<NOT ,PASS1>
 190                     <FIXUP-LOCALS <REST <CHTYPE <1 ,ALL-ICALL-TEMPS> LIST>>>)>
 191              <PUTREST <1 ,ALL-ICALL-TEMPS> ()>
 192              <SETG ALL-ICALL-TEMPS <REST ,ALL-ICALL-TEMPS>>
 193              <SETG TEMP-CC <1 ,ALL-TEMP-CC>>
 194              <SETG ALL-TEMP-CC <REST ,ALL-TEMP-CC>>)>
 195            <COND (,PASS1 <SET LB <LABEL .ITM <> .MIML>> <SAVE-LABEL-STATE .LB>)
 196                  (,NO-AC-FUNNYNESS <SAVE-ACS> <SET LB <LABEL .ITM <> .MIML>>)
 197                  (ELSE
 198                   <SET LB <FIND-LABEL .ITM>>
 199                   <ESTABLISH-LABEL-STATE .LB>
 200                   <SET LB <LABEL .ITM <> .MIML>>)>
 201            <SETG NEXT-LOOP <>>
 202            <SETG LAST-UNCON <>>)
 203           (T
 204            <SET ITML <LENGTH .ITM>>
 205            <COND
 206             (<0? .ITML> <MIMOCERR BAD-SYNTAX!-ERRORS .ITM>)
 207             (<NOT <TYPE? <SET OP <1 .ITM>> ATOM>>
 208              <MIMOCERR BAD-SYNTAX!-ERRORS .ITM>)
 209             (<MEMQ .OP '[FCN GFCN]>
 210              <AND ,V1 <NOT ,PASS1> <PRINT .ITM>>
 211              <FLUSH-ACS>
 212              <COND (<L? .ITML 3> <MIMOCERR BAD-SYNTAX!-ERRORS .ITM>)
 213                    (T
 214                     <SET DCLIST <REST <CHTYPE <3 .ITM> LIST> 2>>
 215                     <SETG LOCALS
 216                           (T
 217                            !<MAPF ,LIST
 218                                   <FUNCTION (ATM "AUX" DC)
 219                                           <PROG ()
 220                                                 <COND (<TYPE? <SET DC <1 .DCLIST>>
 221                                                               STRING>
 222                                                        <COND (<=? .DC "OPTIONAL">
 223                                                               <SET OPT? T>)
 224                                                              (<==? .DC "TUPLE">
 225                                                               <SET OPT? <>>)>
 226                                                        <SET DCLIST <REST .DCLIST>>
 227                                                        <AGAIN>)>>
 228                                           <COND (,WINNING-VICTIM
 229                                                  <SETG WINNING-VICTIM
 230                                                        <+ ,WINNING-VICTIM 2>>)>
 231                                           <SET DCLIST <REST .DCLIST>>
 232                                           <CHTYPE [.ATM
 233                                                    <COND (.OPT? OARG) (ELSE ARG)>
 234                                                    <CHTYPE
 235                                                     <SETG LBLSEQ <+ ,LBLSEQ 1>>
 236                                                     LOCAL-NAME>
 237                                                    <DECL-HACK .DC>
 238                                                    <>
 239                                                    <>]
 240                                                   LOCAL>>
 241                                   <REST .ITM 3>>)>
 242                     <SETG ALL-TEMP-CC ()>
 243                     <SETG TYPED-LOCALS ()>
 244                     <SETG NRARGS <- <LENGTH .ITM> 3>>
 245                     <SET NAME <2 .ITM>>
 246                     <SETG CODE (T)>
 247                     <SETG CC ,CODE>
 248                     <COND (<NOT ,GLUE-MODE>
 249                            <SETG CONSTANT-VECTOR ()>
 250                            <SETG FREE-CONSTS ()>
 251                            <MAPR <>
 252                                  <FUNCTION (B:<VECTOR LIST>)
 253                                       <PUT .B 1 ()>> ,CONSTANT-TABLE>
 254                            <SETG MVECTOR (T .NAME <3 .ITM>)>
 255                            <MAPR <>
 256                                  <FUNCTION (B:<VECTOR LIST>)
 257                                       <PUT .B 1 ()>> ,MV-TABLE>
 258                            <SETG MV-COUNT 0>
 259                            <SETG FINAL-LOCALS ()>
 260                            <SETG MV <REST ,MVECTOR 2>>)
 261                           (T
 262                            <SETG GLUE-NAME .NAME>
 263                            <SETG GLUE-DECL <3 .ITM>>
 264                            <SETG GCALS <SETG GREFS ()>>)>
 265                     <SETG ICALL-FLAG <>>
 266                     <SETG ICALL-TAGS ()>
 267                     <SETG LOOPTAGS ()>
 268                     <SETG LOCATIONS ()>
 269                     <SETG OPT-LIST <>>)>)
 270             (<==? .OP TEMP>
 271              <AND ,V1 <NOT ,PASS1> <PRINT .ITM> <CRLF>>
 272              <SET ITM <SORT-TEMPS .ITM>>
 273              <TEMP-INIT <REST .ITM> <> .OLD-LOCS>
 274              <COND (,WINNING-VICTIM
 275                     <SETG WINNING-VICTIM <+ ,WINNING-VICTIM
 276                                             <* <LENGTH .ITM> 2> -2>>)>)
 277             (<==? .OP OPT-DISPATCH> <OPT-INIT <REST .ITM>>)
 278             (<==? .OP MAKTUP>
 279              <AND ,V1 <NOT ,PASS1> <PRINT .ITM> <CRLF>>
 280              <SET ITM <SORT-TEMPS .ITM>>
 281              <TEMP-INIT <REST .ITM> T .OLD-LOCS>)
 282             (<G? ,NEXT-FLUSH 0>
 283              <COND (<AND ,V1 <NOT ,PASS1>> <PRINT .ITM>)>
 284              <COND (<N==? .OP DEAD> <SETG NEXT-FLUSH <- ,NEXT-FLUSH 1>>)>)
 285             (T
 286              <COND (<N==? .OP DEAD> <SETG NEXT-LOOP <>> <SETG LAST-UNCON <>>)>
 287              <OC .ITM .OBLIST>
 288              <AC-TIME <GET-AC T*> <CHTYPE <MIN> FIX>>)>)>>
 289       .L>
 290      <COND (,PASS1
 291             <SETG LBLSEQ .LSEQ>
 292             <SET OLD-LOCS ,LOCALS>
 293             <MERGE-LABEL-STATES>
 294             <COND (<NOT ,CHANGED> <SETG PASS1 <>>)
 295                   (<GASSIGNED? LOOP-DEBUG>
 296                    <COND (<==? ,LOOP-DEBUG 1>
 297                           <PRINC "Changed: ">
 298                           <PRIN1 ,CHANGED>
 299                           <CRLF>)
 300                          (ELSE <ERROR ,CHANGED>)>)>
 301             <AGAIN>)>>
 302    <FIXUP-LOCALS <REST ,LOCALS>>
 303    <COND (,PEEP-ENABLED <SETG CODE <PPOLE ,CODE !<REST ,CODE>>>)>
 304    <FIXUP-REFS>
 305    <COND (,OPT-LIST
 306           <COND (<AND ,GLUE-MODE <SET PO <FIND-OPT .NAME ,PRE-OPTS>> <1 .PO>>
 307                  <MAPF <> <FUNCTION (A1 A2) #DECL ((A1 A2) ATOM)
 308                                <SETG .A1 ,.A2>>
 309                        <REST <1 .PO> 3> <REST ,OPT-LIST 2>>)>
 310           <MAPR <>
 311                 <FUNCTION (C L "AUX" (X <1 .C>) LI)
 312                         #DECL ((C L) LIST (X) <OR INST ATOM>)
 313                         <COND (<AND <TYPE? .X INST>
 314                                     <==? <LENGTH .X> 2>
 315                                     <==? <1 .X> DISPATCH>>
 316                                <PUT .C
 317                                     1
 318                                     <CHTYPE [SETZ
 319                                              <SET LI <LAB-IND <FIND-LABEL <2 .X>>>>
 320                                              '(R*)]
 321                                             INST>>
 322                                <PUT .L 1 .LI>)
 323                               (T <MAPLEAVE T>)>>
 324                 <REST ,CODE <+ ,OPT-OFFSET 2>> <REST ,OPT-LIST 2>>)>>
 325
 326 <DEFINE DECL-HACK (TYP)
 327         <PROG ((TY <>))
 328               <COND (<TYPE? .TYP FORM SEGMENT>
 329                      <COND (<AND <==? <LENGTH .TYP> 2> <==? <1 .TYP> QUOTE>>
 330                             <SET TYP <TYPE <2 .TYP>>>)
 331                            (<==? <1 .TYP> OR>
 332                             <SET TYP <DECL-HACK <2 <SET TY .TYP>>>>
 333                             <MAPF <>
 334                                   <FUNCTION (Z)
 335                                        <COND (<N==? .TYP <DECL-HACK .Z>>
 336                                               <MAPLEAVE <SET TYP <>>>)>>
 337                                   <REST .TY 2>>)
 338                            (ELSE <SET TYP <1 <SET TY .TYP>>>)>)>
 339               <COND (<TYPE? .TYP ATOM>
 340                      <COND (<OR <AND <VALID-TYPE? .TYP>
 341                                      <MEMQ <TYPEPRIM .TYP> '[WORD FIX LIST]>>
 342                                 <MEMQ .TYP ,TYPE-LENGTHS>> .TYP)
 343                            (<AND <SET TYP <GETPROP .TYP DECL>>
 344                                  <N=? .TY .TYP>>
 345                             <AGAIN>)>)>>>
 346
 347
 348 <DEFINE SORT-TEMPS (TEMPL "AUX" (ALIST '())(NON-ALIST '()))
 349   #DECL ((TEMPL) <PRIMTYPE LIST> (ALIST NON-ALIST) LIST)
 350   <MAPR <>
 351         <FUNCTION (L "AUX" (TEMP <1 .L>))
 352           <COND (<==? .TEMP =>
 353                  <COND (<EMPTY? .ALIST> <SET ALIST .L>)
 354                        (ELSE
 355                         <PUTREST <REST .ALIST <- <LENGTH .ALIST> 1>>
 356                                  .L>)>
 357                  <MAPLEAVE>)
 358                 (<TYPE? .TEMP ATOM>
 359                  <SET ALIST (.TEMP !.ALIST)>)
 360                 (ELSE <SET NON-ALIST (.TEMP !.NON-ALIST)>)>>
 361         <REST .TEMPL>>
 362   <COND (<NOT <EMPTY? .NON-ALIST>>
 363          <PUTREST <REST .NON-ALIST <- <LENGTH .NON-ALIST> 1>>
 364                   .ALIST>)
 365         (ELSE <SET NON-ALIST .ALIST>)>
 366   <CHTYPE (<1 .TEMPL> !.NON-ALIST) FORM>>
 367
 368 <DEFINE OPT-INIT (OPT "AUX" (OFF 1) MAX MAGIC)
 369         #DECL ((OPT) <LIST FIX <OR FIX FALSE> [REST ATOM]> (OFF MAGIC) FIX
 370                (MAX) <OR FALSE FIX>)
 371         <COND (<SET MAX <2 .OPT>>
 372                <SET OFF <+ .OFF 3>>
 373                <OCEMIT CAILE O2* .MAX>
 374                <OCEMIT JRST <XJUMP <NTH .OPT <LENGTH .OPT>>>>
 375                <OCEMIT MOVEI O1*
 376                        <+ <- 5 <1 .OPT>> <COND (,GLUE-MODE ,GLUE-PC) (T 0)>>
 377                        '(R*)>
 378                <OCEMIT ADD O1* O2*>
 379                <OCEMIT JRST @ '(O1*)>)
 380               (ELSE
 381                <OCEMIT ADDI
 382                        O2*
 383                        <+ <- 2 <1 .OPT>> <COND (,GLUE-MODE ,GLUE-PC) (T 0)>>
 384                        '(R*)>
 385                <OCEMIT JRST @ '(O2*)>)>
 386         <MAPF <> <FUNCTION (X) <OCEMIT DISPATCH .X>> <REST <SETG OPT-LIST .OPT> 2>>
 387         <SETG OPT-OFFSET .OFF>>
 388
 389 <DEFINE TEMP-INIT (LST
 390                    "OPTIONAL" (TUP <>) (OLD ())
 391                    "AUX" (STK TP*) (CNT 0) (TCC ,CC))
 392    #DECL ((LST) LIST (CNT) FIX (TUP) <OR FALSE ATOM>)
 393    <COND (.TUP
 394           <OCEMIT MOVE O* O2*>
 395           <OCEMIT MOVEI O1* ,NRARGS>
 396           <OCEMIT MOVEI O2* <- <LENGTH .LST> 2>>
 397           <PUSHJ MAKTUP <NTH .LST <LENGTH .LST>>>
 398           <OCEMIT XMOVEI B1* <+ 1 <* ,NRARGS 2>> '(F*)>
 399           <SET STK B1*>)>
 400    <COND (,ICALL-FLAG
 401           <SETG ALL-TEMP-CC (,TEMP-CC !,ALL-TEMP-CC)>
 402           <SETG ALL-ICALL-TEMPS
 403                 (<REST ,ICALL-TEMPS <- <LENGTH ,ICALL-TEMPS> 1>>
 404                  !,ALL-ICALL-TEMPS)>)
 405          (ELSE <SETG ALL-ICALL-TEMPS (<SETG ICALL-TEMPS (T)>)>)>
 406    <SETG TEMP-CC .TCC>
 407    <MAPF <>
 408          <FUNCTION (TEMP "AUX" VAR TYP FROB (VAL #LOSE *000000000000*) LCL)
 409                  #DECL ((TEMP)
 410                         <OR ATOM
 411                             <ADECL ATOM ATOM>
 412                             <LIST <OR ATOM <ADECL ATOM ATOM>> ANY>>
 413                         (VAR)
 414                         ATOM
 415                         (TYP)
 416                         <OR ATOM FALSE>
 417                         (FROB)
 418                         <OR ADECL ATOM>
 419                         (VAL)
 420                         ANY
 421                         (LCL)
 422                         <OR FALSE LOCAL>)
 423                  <COND (<==? .TEMP => <MAPLEAVE T>)>
 424                  <COND (<TYPE? .TEMP ADECL>
 425                         <SET VAR <1 .TEMP>>
 426                         <SET TYP <2 .TEMP>>)
 427                        (<TYPE? .TEMP LIST>
 428                         <COND (<TYPE? <SET FROB <1 .TEMP>> ADECL>
 429                                <SET VAR <1 .FROB>>
 430                                <SET TYP <2 .FROB>>)
 431                               (T <SET VAR .FROB>)>
 432                         <SET VAL <2 .TEMP>>)
 433                        (T <SET VAR .TEMP>)>
 434                  <SET LCL <LMEMQ .VAR .OLD>>
 435                  <SET LCL
 436                       <CHTYPE [.VAR
 437                                <COND (.LCL <LUPD .LCL>)>
 438                                <CHTYPE <SETG LBLSEQ <+ ,LBLSEQ 1>> LOCAL-NAME>
 439                                <COND (<ASSIGNED? TYP> <SET TYP <DECL-HACK .TYP>>)
 440                                      (ELSE <>)>
 441                                <>
 442                                <>]
 443                               LOCAL>>
 444                  <COND (<NOT <TYPE? .VAL LOSE>> <LUPD .LCL TEMP>)>
 445                  <COND (,ICALL-FLAG
 446                         <PUTREST <REST ,ICALL-TEMPS
 447                                        <- <LENGTH ,ICALL-TEMPS> 1>>
 448                                  (.LCL)>)
 449                        (T
 450                         <PUTREST <REST ,LOCALS <- <LENGTH ,LOCALS> 1>>
 451                                  (.LCL)>)>
 452                  <COND (<AND <ASSIGNED? TYP> .TYP>
 453                         <OCEMIT PUSH .STK !<TYPE-WORD .TYP>>
 454                         <SETG TYPED-LOCALS (.LCL !,TYPED-LOCALS)>
 455                         <AND <TYPE? .VAL LOSE> <SET VAL 0>>)
 456                        (<TYPE? .VAL LOSE>
 457                         <OCEMIT PUSH .STK !<OBJ-VAL 0>>
 458                         <SET VAL 0>)
 459                        (T <OCEMIT PUSH .STK !<OBJ-LOC .VAL 0>>)>
 460                  <OCEMIT PUSH .STK !<OBJ-VAL .VAL>>>
 461          .LST>
 462    <COND (<==? .STK B1*> <AC-TIME <GET-AC B1*> 0>)>>
 463
 464 <DEFINE PRE-HACK (L "AUX" LR)
 465         #DECL ((L LR) LIST)
 466         <SETG THE-BIG-LABELS ()>
 467         <REPEAT (WIN (FIX-LABS <>) (FIRST T))
 468                 #DECL ((FIRST WIN) <OR ATOM FALSE>)
 469                 <SET WIN <>>
 470                 <SET LR
 471                      <MAPR ,LIST
 472                            <FUNCTION (LL "AUX" (FRM <1 .LL>) M N I A LBL)
 473                                 #DECL ((FRM) <OR FORM ATOM> (M) <OR FALSE LIST>
 474                                        (LBL) ATOM (N) <OR FALSE LIST> (I) FORM
 475                                        (LL) LIST (A) ANY)
 476                                 <COND (<TYPE? .FRM ATOM>
 477                                        <MAPRET>)>
 478                                 <COND (.FIRST <REMOVE-FUNNY-DEADS .FRM>)>
 479                                 <COND (<OR <==? <1 .FRM> OPT-DISPATCH>
 480                                            <==? <1 .FRM> DISPATCH>>
 481                                        <COND (.FIX-LABS
 482                                               <MAPR <>
 483                                                     <FUNCTION (FP)
 484                                                          <PUT .FP 1
 485                                                               <FIX-LAB <1 .FP>>>>
 486                                                     <REST .FRM 3>>)>
 487                                        <MAPRET !<REST .FRM 3>>)
 488                                       (<OR <SET M <MEMQ + .FRM>>
 489                                            <SET M <MEMQ - .FRM>>
 490                                            <AND <==? <1 .FRM> NTHR>
 491                                                 <TYPE?
 492                                                     <SET A <NTH .FRM
 493                                                                 <LENGTH .FRM>>>
 494                                                     LIST>
 495                                                 <==? <1 .A> BRANCH-FALSE>
 496                                                 <SET M <REST .A>>>>
 497                                        <COND (<OR <==? <SET LBL <2 .M>> COMPERR>
 498                                                   <==? .LBL UNWCONT>
 499                                                   <==? .LBL IOERR>>
 500                                               <MAPRET .LBL>)
 501                                              (.FIX-LABS
 502                                               <PUT .M 2 <FIX-LAB .LBL>>
 503                                               <MAPRET .LBL>)
 504                                              (<SET N <MEMQ .LBL .L>>)
 505                                              (T <MIMOCERR BAD-LABEL!-ERRORS
 506                                                        .LBL>)>
 507                                        <COND (<==? <1 <SET I <NEXTINS .N>>>
 508                                                    JUMP>
 509                                               <PUT .M 2 <3 .I>>
 510                                               <MAPRET <2 .M>>)
 511                                              (<AND <==? <1 .FRM> JUMP>
 512                                                    <==? <1 .I> RETURN>>
 513                                               <PUT .LL 1 .I>
 514                                               <MAPRET>)
 515                                              (T
 516                                               <MAPRET .LBL>)>)
 517                                       (<==? <1 .FRM> ICALL>
 518                                        <COND (.FIX-LABS
 519                                               <PUT .FRM 2 <FIX-LAB <2 .FRM>>>)>
 520                                        <MAPRET <2 .FRM>>)
 521                                       (T <MAPRET>)>>
 522                            .L>>
 523                 <SET FIRST <>>
 524                 <REPEAT ((L .L) (OL .L) ITM (NEXT-LOOP <>))
 525                         #DECL ((L OL) LIST (ITM) ANY)
 526                         <COND (<EMPTY? .L> <RETURN>)
 527                               (<TYPE? <SET ITM <1 .L>> ATOM>
 528                                <COND (.FIX-LABS
 529                                       <PUT .L 1 <SET ITM <FIX-LAB .ITM>>>
 530                                       <MAKE-LABEL .ITM <> .L .NEXT-LOOP>
 531                                       <SET OL .L>)
 532                                      (<NOT <MEMQ .ITM .LR>>
 533                                       <PUTREST .OL <REST .L>>
 534                                       <SET L .OL>
 535                                       <SET WIN T>)
 536                                      (ELSE <SET OL .L>)>)
 537                               (<AND .FIX-LABS
 538                                     <TYPE? .ITM FORM>
 539                                     <==? <1 .ITM> ACTIVATION>>
 540                                <SETG THE-BIG-LABELS (<SET ITM <GENLBL "ACT">>
 541                                                      !,THE-BIG-LABELS)>
 542                                <MAKE-LABEL .ITM  <> .L T>
 543                                <SET OL .L>)
 544                               (<AND <TYPE? .ITM FORM> <==? <1 .ITM> LOOP>>
 545                                <SET NEXT-LOOP T>
 546                                <SET L <REST <SET OL .L>>>
 547                                <AGAIN>)
 548                               (<AND <TYPE? .ITM FORM>
 549                                     <==? <1 .ITM> JUMP>
 550                                     <TYPE? <SET ITM <1 .OL>> FORM>
 551                                     <==? <1 .ITM> JUMP>>
 552                                <PUTREST .OL <REST .L>>
 553                                <SET WIN T>)
 554                               (<AND <TYPE? <SET ITM <1 .L>> FORM>
 555                                     <==? <1 .ITM> JUMP>
 556                                     <G? <LENGTH .L> 1>
 557                                     <==? <2 .L> <3 .ITM>>>
 558                                <PUTREST .OL <REST .L>>
 559                                <SET WIN T>)
 560                               (<AND <TYPE? .ITM FORM>
 561                                     <==? <1 .ITM> JUMP>
 562                                     <G? <LENGTH .L> 1>
 563                                     <NOT <TYPE? <2 .L> ATOM>>>
 564                                <PUTREST .L <REST .L 2>>
 565                                <SET WIN T>)
 566                               (<AND <TYPE? .ITM FORM>
 567                                     <OR <==? <1 .ITM> RETURN>
 568                                         <==? <1 .ITM> RTUPLE>
 569                                         <==? <1 .ITM> AGAIN>
 570                                         <==? <1 .ITM> RETRY>
 571                                         <==? <1 .ITM> MRETURN>>>
 572                                <REPEAT ((LL <REST .L>)) #DECL ((LL) LIST)
 573                                        <COND (<OR <EMPTY? .LL>
 574                                                   <TYPE? <SET ITM <1 .LL>>
 575                                                          ATOM>>
 576                                               <COND (<N==? <REST .L> .LL>
 577                                                      <SET WIN T>
 578                                                      <PUTREST .L .LL>)>
 579                                               <RETURN>)>
 580                                        <COND (<==? <1 .ITM> DEAD>
 581                                               <COND (<N==? <REST .L> .LL>
 582                                                      <SET WIN T>
 583                                                      <PUTREST .L .LL>)>
 584                                               <SET L .LL>)>
 585                                        <SET LL <REST .LL>>>
 586                                <SET OL .L>)
 587                               (T <SET OL .L>)>
 588                         <SET NEXT-LOOP <>>
 589                         <SET L <REST .L>>>
 590                 <COND (.FIX-LABS <RETURN>)
 591                       (<NOT .WIN> <SET FIX-LABS T>)>>>
 592
 593 <DEFINE REMOVE-FUNNY-DEADS (FRM:FORM "AUX" (N:FIX <LENGTH .FRM>))
 594         <REPEAT (L FOO)
 595                 <COND (<AND <TYPE? <SET L <NTH .FRM .N>> LIST>
 596                             <NOT <EMPTY? .L>>
 597                             <OR <==? <SET FOO <1 .L>> DEAD-FALL>
 598                                 <==? .FOO DEAD-JUMP>>>
 599                        <PUTREST <REST .FRM <- .N 2>> <REST .FRM .N>>
 600                        <SET N <- .N 1>>)
 601                       (ELSE
 602                        <SET N <- .N 1>>)>
 603                 <COND (<L=? .N 1> <RETURN>)>>>
 604
 605 <DEFINE FIX-LAB (X) <SET X <SPNAME .X>> <OR <LOOKUP .X ,LABEL-OBLIST>
 606                                             <INSERT .X ,LABEL-OBLIST>>>
 607
 608
 609 <DEFINE FIXUP-REFS ("AUX" (C <REST ,CODE>) (PC 0) FOO M TG
 610                           (OFF <COND (,GLUE-MODE ,GLUE-PC) (T 0)>) R
 611                           (WV ,WINNING-VICTIM))
 612    #DECL ((LABELS) LIST (PC OFF) FIX (C) LIST (FOO R) ANY
 613           (M) <OR FALSE LAB LIST>)
 614    <MAPF <>
 615          <FUNCTION (C "AUX" R M X)
 616                  #DECL ((M) <OR FALSE LAB>)
 617                  <COND (<TYPE? .C INST>
 618                         <COND (<TYPE? <SET R <NTH .C <LENGTH .C>>> REF>
 619                                <COND (<AND <TYPE? <SET X <1 .R>> ATOM>
 620                                            <SET M <FIND-LABEL .X>>>
 621                                       <PUT .M ,LAB-IND 0>)>)
 622                               (<TYPE? .R FORM GVAL>
 623                                <PUT .C <LENGTH .C> <EVAL .R>>)>)>>
 624          .C>
 625    <REPEAT ()
 626            <COND (<EMPTY? .C> <RETURN <SETG CODE-LENGTH .PC>>)
 627                  (<AND <TYPE? <SET FOO <1 .C>> ATOM> <SET M <FIND-LABEL .FOO>>>
 628                   <PUT .M ,LAB-IND <+ .PC .OFF>>)
 629                  (ELSE <SET PC <+ .PC 1>>)>
 630            <SET C <REST .C>>>
 631    <MAPR <>
 632     <FUNCTION (COD "AUX" (C <1 .COD>) R NPC (FLG <>))
 633        #DECL ((COD) LIST (C R) ANY (NPC) FIX (FLG) <OR ATOM FALSE>)
 634        <COND (<AND <TYPE? .C INST>
 635                    <OR <TYPE? <SET R <2 .C>> REF>
 636                        <AND <G? <LENGTH .C > 2>
 637                             <TYPE? <SET R <3 .C>> REF>
 638                             <SET FLG T>>>>
 639               <SET TG <1 <CHTYPE .R REF>>>
 640               <SET M <>>
 641               <COND (<OR <NOT <TYPE? .TG ATOM>>
 642                          <NOT <SET M <MEMQ .TG <REST ,CODE>>>>>)
 643                     (T <SET NPC <LAB-IND <FIND-LABEL <1 <CHTYPE .R REF>>>>>)>
 644               <COND (<NOT .M>
 645                      <COND (<==? .TG COMPERR>
 646                             <COND (.FLG <PUT .C 3 106>) (T <PUT .C 2 106>)>)
 647                            (<OR <==? .TG UNWCONT> <==? .TG IOERR>>
 648                             <COND (.FLG
 649                                    <PUT .COD
 650                                         1
 651                                         <CHTYPE [<1 .C> <2 .C> @ <OPCODE .TG>]
 652                                                 INST>>)
 653                                   (ELSE
 654                                    <PUT .COD
 655                                         1
 656                                         <CHTYPE [JRST @ <OPCODE .TG>] INST>>)>)
 657                            (<NOT <TYPE? .TG CONSTANT-BUCKET>>
 658                             <MIMOCERR UNKNOWN-LABEL!-ERRORS
 659                                       <1 <CHTYPE .R REF>>>)>)
 660                     (.FLG
 661                      <PUT .COD 1 <CHTYPE [<1 .C> <2 .C> .NPC '(R*)] INST>>)
 662                     (T <PUT .COD 1 <CHTYPE [JRST .NPC '(R*)] INST>>)>)>>
 663     <REST ,CODE>>>
 664
 665 <DEFINE WRITE-MSUBR (OC "OPTIONAL" (LOWERSTR <>) (F-OR-G <>)
 666                      "AUX" NUM (MVECTOR ,MVECTOR) (OUTCHAN .OC)
 667                            (OB ,OUTPUT-BUFFER))
 668         #DECL ((NAME) ATOM (DECL) <PRIMTYPE LIST> (MVECTOR) LIST
 669                (NUM) FIX (OUTCHAN) <SPECIAL CHANNEL> (OB) STRING)
 670         <AND ,INT-MODE <PRINTTYPE ATOM ,ATOM-PRINT>>
 671         <COND (<NOT .LOWERSTR>
 672                <SET LOWERSTR
 673                     <MAPF ,STRING
 674                           <FUNCTION (CHR "AUX" (ICHR <ASCII .CHR>))
 675                                  #DECL ((CHR) CHARACTER (ICHR) FIX)
 676                                  <COND (<AND <L=? .ICHR <ASCII !\Z>>
 677                                              <G=? .ICHR <ASCII !\A>>>
 678                                         <ASCII <+ .ICHR 32>>)
 679                                        (ELSE .CHR)>>
 680                             <SPNAME <2 .MVECTOR>>>>)>
 681         <WIDTH-MUNG .OC 100000000>
 682         <COND (,GLUE-MODE <SETG GLUE-LIST <LREVERSE ,GLUE-LIST>>)>
 683         <CRLF .OC>
 684         <COND (<NOT ,BOOT-MODE>
 685                <PRINC "<SETG " .OC>
 686                <COND (<NOT ,GLUE-MODE> <PRINC <ASCII 26> .OC>)>
 687                <PRINC .LOWERSTR .OC>
 688                <COND (<NOT ,BOOT-MODE>
 689                       <COND (,INT-MODE <PRINC "!-IMSUBR!- " .OC>)
 690                             (ELSE <PRINC "-IMSUBR " .OC>)>)>
 691                <PRINC !\ >)>
 692         <PRINC "#IMSUBR [|" .OC>
 693         <COND (<AND ,GLUE-MODE <NOT ,MAX-SPACE>>
 694                <SETG CODE
 695                      <MAPF ,LIST
 696                            <FUNCTION (L "AUX" C)
 697                                 #DECL ((L) <LIST ATOM LIST FIX <LIST ANY>>
 698                                        (C) LIST)
 699                                 <SET C <REST <4 .L>>>
 700                                 <PUT .L 4 ()>
 701                                 <MAPRET !.C>>
 702                            ,GLUE-LIST>>
 703                <SETG CODE (T !,CODE)>)>
 704         <COND (<NOT ,BOOT-MODE>
 705                <PRINTBYTE <CHTYPE <LSH <SET NUM
 706                                             <+ <COND (,GLUE-MODE ,GLUE-PC)
 707                                                      (T ,CODE-LENGTH)>
 708                                                <LENGTH ,CONSTANT-VECTOR>>>
 709                                        -16> FIX>
 710                           7>
 711                <PRINTBYTE <CHTYPE <LSH .NUM -8> FIX> 7>
 712                <PRINTBYTE .NUM 7>)>
 713         <COND (<NOT ,MAX-SPACE> <WRITE-CODE .OC .LOWERSTR <REST ,CODE> .OB>)
 714               (ELSE
 715                <CHANNEL-OP .OC WRITE-BUFFER ,OUTPUT-BUFFER
 716                            <- ,OUTPUT-LENGTH <LENGTH .OB>>>)>
 717         <COND (<NOT ,GLUE-MODE>
 718                <COND (<==? .F-OR-G GFCN>
 719                       <PRIN1 ,CODE-LENGTH .OC>)
 720                      (ELSE
 721                       <PRIN1 <- ,CODE-LENGTH> .OC>)>
 722                <CRLF .OC>
 723                <COND (<NOT ,BOOT-MODE>
 724                       <PRINC "<SETG " .OC>
 725                       <COND (<NOT ,GLUE-MODE> <PRINC <ASCII 26> .OC>)>
 726                       <PRIN1 <2 .MVECTOR> .OC>
 727                       <PRINC !\  .OC>)>
 728                <PRINC "#MSUBR [" .OC>
 729                <PRINC .LOWERSTR .OC>
 730                <COND (<NOT ,BOOT-MODE>
 731                       <COND (,INT-MODE <PRINC "!-IMSUBR!- " .OC>)
 732                             (ELSE <PRINC "-IMSUBR " .OC>)>)>
 733                <PRINC " " .OC>
 734                <PRIN1 <2 .MVECTOR> .OC>
 735                <PRINC " " .OC>
 736                <PRIN1 <3 .MVECTOR> .OC>
 737                <PRINC " 0]" .OC>
 738                <COND (<NOT ,BOOT-MODE> <PRINC ">" .OC>)>
 739                <WIDTH-MUNG .OC 80>)>
 740         <AND ,INT-MODE <NOT ,MAX-SPACE> <PRINTTYPE ATOM ,PRINT>>
 741         <COND (,MAX-SPACE .LOWERSTR)>>
 742
 743
 744 <DEFINE WRITE-CODE (OC LOWERSTR CODE OB
 745                     "OPT" (LEN 0)
 746                     "AUX" (MVECTOR ,MVECTOR) LCL (OUTCHAN .OC))
 747    #DECL ((CODE MVECTOR) LIST (LEN) FIX (OUTCHAN) <SPECIAL CHANNEL>
 748           (LCL) <OR FALSE <LIST [REST LOCAL-NAME FIX]>> (OB) STRING)
 749    <MAPF <>
 750          <FUNCTION (WRD)
 751               <COND (<SET WRD <ASS-INS .WRD>>
 752                      <SET LEN <+ .LEN 4>>
 753                      <REPEAT ((I 4)) #DECL ((I) FIX)
 754                            <PRINTBYTE <SET WRD <CHTYPE <ROT .WRD 9> FIX>>>
 755                            <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>)>>
 756          .CODE>
 757    <COND
 758     (<NOT ,MAX-SPACE>
 759      <MAPF <>
 760            <FUNCTION (CB:CONSTANT-BUCKET "AUX" (WRD <CB-VAL .CB>))
 761                 <COND (<TYPE? .WRD CONSTANT>
 762                        <REPEAT ((I 4)) #DECL ((I) FIX)
 763                            <PRINTBYTE <SET WRD <CHTYPE <ROT .WRD 9> FIX>>>
 764                            <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>
 765                        <SET LEN <+ .LEN 4>>)
 766                       (<TYPE? .WRD CONST-W-LOCAL>
 767                        <COND (<SET LCL <MEMQ <1 .WRD> ,FINAL-LOCALS>>
 768                               <SET WRD
 769                                    <CHTYPE <ORB <ANDB <2 .WRD>
 770                                                       *777777000000*>
 771                                                 <ANDB <+ <CHTYPE <2 .WRD> FIX>
 772                                                          <CHTYPE <2 .LCL> FIX>>
 773                                                       *777777*>> FIX>>)
 774                              (ELSE
 775                               <PRINC "**** WARNING unknown local: " ,OUTCHAN>
 776                               <PRIN1 <1 .WRD> ,OUTCHAN>
 777                               <PRINC " in fcn " ,OUTCHAN>
 778                               <PRIN1 .NAME ,OUTCHAN>
 779                               <CRLF ,OUTCHAN>
 780                               <SET WRD 0>)>
 781                        <REPEAT ((I 4)) #DECL ((I) FIX)
 782                            <PRINTBYTE <SET WRD <CHTYPE <ROT .WRD 9> FIX>>>
 783                            <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>
 784                        <SET LEN <+ .LEN 4>>)>>
 785            ,CONSTANT-VECTOR>
 786      <CHANNEL-OP .OC WRITE-BUFFER ,OUTPUT-BUFFER <- ,OUTPUT-LENGTH <LENGTH .OB>>>
 787      <PRINC "| ">
 788      <PRINC .LOWERSTR>
 789      <COND (<NOT ,BOOT-MODE>
 790             <COND (,INT-MODE <PRINC "!-IMSUBR!- " .OUTCHAN>)
 791                   (ELSE <PRINC "-IMSUBR " .OUTCHAN>)>)>
 792      <MAPF <>
 793            <FUNCTION (MV)
 794                    #DECL ((MV) ANY)
 795                    <PRINC !\ >
 796                    <COND (<>
 797                           ; "This used to strip off a level of quoting
 798                              for atoms, but that's already happened in
 799                              MVADD..."
 800                           ;<AND <TYPE? .MV FORM>
 801                                <G? <LENGTH .MV> 1>
 802                                <==? <1 .MV> QUOTE>
 803                                <TYPE? <2 .MV> ATOM>>
 804                           <SET MV <2 .MV>>)>
 805                    <COND (<TYPE? .MV CHARACTER>
 806                           <PRINTTYPE CHARACTER ,CHR-PRINT>
 807                           <PRIN1 .MV>
 808                           <PRINTTYPE CHARACTER ,PRINT>)
 809                          (<TYPE? .MV CONST-W-LOCAL>
 810                           <SET MV
 811                                <+ <CHTYPE <2 <MEMQ <1 .MV> ,FINAL-LOCALS>>
 812                                           FIX>
 813                                   <CHTYPE <2 .MV> FIX>>>
 814                           <PRIN1 .MV>)
 815                          (T <PRIN1 .MV>)>>
 816            <REST .MVECTOR 3>>
 817      <COND (,GLUE-MODE <WIDTH-MUNG .OUTCHAN 80>)>
 818      <PRINC !\]>
 819      <COND (<NOT ,BOOT-MODE> <PRINC !\>>)>
 820      <CRLF>
 821      <COND (,VERBOSE
 822             <PROG ((OUTCHAN <COND (,V2) (,V1 .OUTCHAN) (T ,OUTCHAN)>))
 823                   #DECL ((OUTCHAN) <SPECIAL CHANNEL>)
 824                   <PRINC " [Code: ">
 825                   <PRIN1 </ .LEN 4>>
 826                   <PRINC " / Vector: ">
 827                   <PRIN1 <* <- <LENGTH .MVECTOR> 1> 2>>
 828                   <PRINC !\]>>)>
 829      ,NULL)
 830     (ELSE .LEN)>>
 831
 832 <DEFINE ASS-INS (WRD "AUX" M (AC? <>) (ADR 0) (IDX 0) (INS 0) (IND 0) INAME LCL)
 833         #DECL ((WRD) <OR CONST-W-LOCAL CONSTANT FIX WORD INST ATOM>
 834                (INS ADR IDX IND) FIX (AC?) <OR FALSE FIX> (INAME) ATOM
 835                (M) <OR FALSE VECTOR>)
 836        <COND
 837         (<TYPE? .WRD ATOM> <>)
 838         (<TYPE? .WRD INST>
 839          <MAPF <>
 840           <FUNCTION (FROB)
 841                   <COND (<==? .FROB @> <SET IND 16>)
 842                         (<AND <TYPE? .FROB ATOM> <SET M <MEMQ .FROB ,ACS>>>
 843                          <COND (<OR .AC? <N==? .IND 0>>
 844                                 <SET ADR <+ .ADR <2 .M>>>)
 845                                (T <SET AC? <2 .M>>)>)
 846                         (<TYPE? .FROB LOCAL-NAME>
 847                          <COND (<SET LCL <MEMQ .FROB ,FINAL-LOCALS>>
 848                                 <SET ADR <+ .ADR <CHTYPE <2 .LCL> FIX>>>)
 849                                (ELSE
 850                                 <SET ADR 0>
 851                                 <PRINC "**** WARNING unknown local: " ,OUTCHAN>
 852                                 <PRIN1 .FROB ,OUTCHAN>
 853                                 <PRINC " in fcn " ,OUTCHAN>
 854                                 <PRIN1 .NAME ,OUTCHAN>
 855                                 <CRLF ,OUTCHAN>)>)
 856                         (<TYPE? .FROB ATOM>
 857                          <SET INAME .FROB>
 858                          <SET FROB <COND (<LOOKUP <SPNAME .FROB> ,OPS>)
 859                                          (<LOOKUP <SPNAME .FROB> ,JSYS-OBLIST>)
 860                                          (ELSE .FROB)>>
 861                          <COND (<AND <GASSIGNED? .FROB>
 862                                      <TYPE? ,.FROB JSYS>>
 863                                 <SET INS <CHTYPE <LSH ,.FROB -27> FIX>>
 864                                 <SET ADR <CHTYPE <ANDB ,.FROB *777777*> FIX>>)
 865                                (<GASSIGNED? .FROB>
 866                                 <SET INS ,.FROB>)
 867                                (ELSE
 868                                 <MIMOCERR BAD-OPCODE!-ERRORS .FROB>)>)
 869                         (<TYPE? .FROB LIST>
 870                          <SET FROB <1 .FROB>>
 871                          <SET IDX <2 <SET M <CHTYPE <MEMQ .FROB ,ACS>
 872                                                     VECTOR>>>>)
 873                         (<MEMQ <PRIMTYPE .FROB> '[WORD FIX]>
 874                          <SET ADR <+ .ADR <CHTYPE .FROB FIX>>>)
 875                         (<MIMOCERR BAD-THING-IN-CODE!-ERRORS .FROB>)>>
 876           .WRD>
 877          <COND (<NOT .AC?> <SET AC? 0>)>
 878          <CHTYPE <ORB <LSH .INS 27>
 879                       <LSH <+ <CHTYPE <LSH .AC? 5> FIX>
 880                               .IND .IDX> 18>
 881                       <ANDB .ADR *777777*>> FIX>)>>
 882
 883 <DEFINE DUMP-CODE (CODE TC "AUX" (CB ,CODE-BUFFER) (TCB .CB))
 884         #DECL ((CODE) LIST (TC) CHANNEL (CB TCB) <UVECTOR [REST FIX]>)
 885         <PUT .CB 1 ,CODE-LENGTH>
 886         <SET CB <REST .CB>>
 887         <MAPF <>
 888               <FUNCTION (WRD)
 889                    <COND (<SET WRD <ASS-INS .WRD>>
 890                           <PUT .CB 1 .WRD>
 891                           <COND (<EMPTY? <SET CB <REST .CB>>>
 892                                  <PRINTB .TCB .TC>
 893                                  <SET CB .TCB>)>)>>
 894               .CODE>
 895         <COND (<N==? .CB .TCB>
 896                <PRINTB .TCB .TC <- ,CB-LENGTH <LENGTH .CB>>>)>>
 897
 898 <DEFINE READ-CODE (TC "AUX" (FB ,ONE-WD)) #DECL ((FB) <UVECTOR FIX>)
 899         <READB .FB .TC>
 900         <READB <SET FB <IUVECTOR <1 .FB> 0>> .TC>
 901         .FB>
 902
 903 <DEFINE NOPE (L)
 904         #DECL ((L) LIST)
 905         <MIMOCERR CANT-OPEN-COMPILE!-ERRORS .L>>
 906
 907 <DEFINE MIMOCERR ("TUPLE" T)
 908         <PRINC "
 909 ** Error - ">
 910         <MAPF <>
 911               <FUNCTION (X)
 912                    <PRIN1 .X>
 913                    <PRINC !\ >>
 914               .T>
 915         <ERROR !.T>
 916         <RETURN <> .MACT>>
 917
 918 <DEFINE DOC ("TUPLE" NAM)
 919         <PROG ((OUTCHAN <OPEN "PRINT" <STRING <GET-NM1 <1 .NAM>> ".OC">>))
 920               #DECL ((OUTCHAN) <SPECIAL CHANNEL>)
 921               <COND (.OUTCHAN
 922                      <SETG V1 T>
 923                      <SETG V2 .OUTCHAN>
 924                      <COND (,GLUE-MODE <FILE-GLUE !.NAM>)
 925                            (ELSE <FILE-MIMOC !.NAM>)>
 926                      <CLOSE .OUTCHAN>
 927                      T)
 928                     (ELSE
 929                      <ERROR .OUTCHAN>)>>>