mim/development/mim/20c/msglue.mud

   1
   2 <PACKAGE "MSGLUE">
   3
   4 <ENTRY FILE-GLUE>
   5
   6 <USE "NEWSTRUC">
   7
   8 <NEWSTRUC GLUE-INFO VECTOR
   9           IMSUBR-NAME ATOM
  10           MSUBR-NAME ATOM
  11           GLUED-CALL-OK? <OR ATOM FALSE>
  12           MSUBR-DECL LIST
  13           START-LOC FIX
  14           REFS LIST
  15           FINAL-LOC <OR FALSE FIX>
  16           CONST-START FIX
  17           MIN-MAX-ARGS FIX
  18           MSUBR-OBLIST LIST>
  19
  20 <NEWSTRUC CONST-REF VECTOR C-VALUE FIX C-REFS <LIST [REST FIX]>>
  21
  22 <EVAL-WHEN ("SUBSYSTEM" "MIMC")
  23            <FLOAD "PS:<MIM.20C>MSGLUE-PM.MUD">>
  24
  25 <COND (<N==? <PRIMTYPE 1> FIX>
  26        <DEFINE FLSH (A B) #DECL ((A B) FIX) <CHTYPE <LSH .A .B> FIX>>
  27        <DEFINE FORB ("TUPLE" X) <CHTYPE <ORB !.X> FIX>>
  28        <PUTPROP CODE DECL '<<PRIMTYPE UVECTOR> [REST FIX]>>)
  29       (ELSE
  30        <SETG FLSH ,LSH>
  31        <SETG FORB ,ORB>
  32        <PUT-DECL CODE '<<PRIMTYPE UVECTOR> [REST FIX]>>)>
  33
  34 <MSETG GLUE-FRM-INS 1>
  35
  36 <MSETG GLUE-LOAD-MS-INS 2>
  37
  38 <MSETG GLUE-LOAD-ARG 3>
  39
  40 <MSETG GLUE-CALL-INS 0>
  41
  42 <MSETG INDX-BP <BITS 4 18>>
  43
  44 <MSETG AC-BP <BITS 4 23>>
  45
  46 <MSETG INS-BP <BITS 9 27>>
  47
  48 <MSETG ADDR-BP <BITS 18>>
  49
  50 <MSETG FRAME-LOC *220*>
  51
  52 <MSETG CALL-LOC *221*>
  53
  54 <MSETG GVAL-LOC *160*>
  55
  56 <MSETG GASS-LOC *157*>
  57
  58 <MSETG ACALL-LOC 206>
  59
  60 <MSETG SFRAME-LOC 207>
  61
  62 <MSETG O2 9>
  63
  64 <MSETG O1 8>
  65
  66 <MSETG T 7>
  67
  68 <MSETG TP 14>
  69
  70 <MSETG F 13>
  71
  72 <MSETG R 10>
  73
  74 <MSETG M 11>
  75
  76 <MSETG P 15>
  77
  78 <MSETG P-AC <FLSH ,P 23>>
  79
  80 <MSETG T-AC <FLSH ,T 23>>
  81
  82 <MSETG PC-AC ,T-AC>
  83
  84 <MSETG F-INDX <FLSH ,F 18>>
  85
  86 <MSETG F-AC <FLSH ,F 23>>
  87
  88 <MSETG TP-INDX <FLSH ,TP 18>>
  89
  90 <MSETG TP-AC <FLSH ,TP 23>>
  91
  92 <MSETG R-INDX <FLSH ,R 18>>
  93
  94 <MSETG IND <FLSH 1 22>>
  95
  96 <MSETG JSP <FLSH *265* 27>>
  97
  98 <MSETG SKIPL <FLSH *331* 27>>
  99
 100 <MSETG HRROI <FLSH *561* 27>>
 101
 102 <MSETG PUSH <FLSH *261* 27>>
 103
 104 <MSETG XMOVEI <FLSH *415* 27>>
 105
 106 <MSETG MOVEI *201*>
 107
 108 <MSETG SUB-INS <FLSH *274* 27>>
 109
 110 <MSETG JRST <FLSH *254* 27>>
 111
 112 <MSETG SETZ <FLSH *400* 27>>
 113
 114 <MSETG PUSHJ <FLSH *260* 27>>
 115
 116 <MSETG PUSHJ-GVAL <FORB ,PUSHJ ,P-AC ,IND ,GVAL-LOC>>
 117
 118 <MSETG PUSHJ-GASS <FORB ,PUSHJ ,P-AC ,IND ,GASS-LOC>>
 119
 120 <MSETG JSP-GVAL <FORB ,JSP ,PC-AC ,IND ,GVAL-LOC>>
 121
 122 <MSETG JSP-GASS <FORB ,JSP ,PC-AC ,IND ,GASS-LOC>>
 123
 124 <MSETG JSP-ACALL <FORB ,JSP ,PC-AC ,IND ,ACALL-LOC>>
 125
 126 <SETG FUNNY-CALLS <UVECTOR ,PUSHJ-GVAL ,PUSHJ-GASS ,JSP-GVAL ,JSP-GASS ,JSP-ACALL>>
 127
 128 <GDECL (FUNNY-CALLS) <UVECTOR [REST FIX]>>
 129
 130 <MSETG JSP-FRAME <FORB ,JSP ,PC-AC ,IND ,FRAME-LOC>>
 131
 132 <MSETG JSP-CALL <FORB ,JSP ,PC-AC ,IND ,CALL-LOC>>
 133
 134 <MSETG JSP-SFRAME <FORB ,JSP ,PC-AC ,IND ,SFRAME-LOC>>
 135
 136 <MSETG SKIPL-T-1-PARENF <FORB ,SKIPL ,T-AC *777777* ,F-INDX>>
 137
 138 <MSETG HRROI-T <FORB ,HRROI ,T-AC ,F-INDX>>
 139
 140 <MSETG PUSH-TP-T <FORB ,PUSH ,TP-AC ,T>>
 141
 142 <MSETG PUSH-TP-F <FORB ,PUSH ,TP-AC ,F>>
 143
 144 <MSETG PUSH-TP-PARENR <FORB ,PUSH ,TP-AC ,R-INDX>>
 145
 146 <MSETG XMOVEI-F-1-TP <FORB ,XMOVEI ,F-AC *777777* ,TP-INDX>>
 147
 148 <MSETG SUB-F-O2 <FORB ,SUB-INS ,F-AC ,O2>>
 149
 150 <MSETG XMOVEI-TP <FORB ,XMOVEI ,F-AC ,TP-INDX>>
 151
 152 <MSETG JRST-R <FORB ,JRST ,R-INDX>>
 153
 154 <MSETG SETZ-R <FORB ,SETZ ,R-INDX>>
 155
 156 <NEWTYPE GLUED-ATOM ATOM>
 157
 158 <GDECL (ALL-PACKAGES ALL-P OBJ-LIST OBJ-PTR CODE-LIST CODE-PTR) LIST>
 159
 160 <GDECL (CONST-PTR CONST-LIST) <LIST [REST CONST-REF]>>
 161
 162 <DEFINE FILE-GLUE ("TUPLE" FILES "AUX" C TMP-TXT TMP-CODE (OUTCHAN .OUTCHAN)
 163                    (EXPFLOAD <AND <ASSIGNED? EXPFLOAD> .EXPFLOAD>) (EST-LNT 0)
 164                    (FNM1 <GET-NM1 <1 .FILES>>) CP ITM OBP OC (NM2 "MSUBR")
 165                    (TEMP-FILE? <AND <GASSIGNED? TEMP-FILE?> ,TEMP-FILE?>)
 166                    (END <>))
 167         #DECL ((FILES) <<PRIMTYPE VECTOR> [REST STRING]> (OUTCHAN) <SPECIAL ANY>
 168                (OBP CP) <LIST ANY> (OC C TMP-TXT TMP-CODE) <OR FALSE CHANNEL>
 169                (EST-LNT) FIX (NM2) <SPECIAL STRING>)
 170         <COND (<AND <SET C <OPEN "READ" <1 .FILES>>>
 171                     <OR <NOT .TEMP-FILE?>
 172                         <AND <SET TMP-TXT
 173                                   <OPEN "PRINT"
 174                                         <STRING .FNM1
 175                                                 ".GLUE-TXT">>>
 176                              <SET TMP-CODE
 177                                   <OPEN "PRINT"
 178                                         <STRING .FNM1 ".GLUE-CODE">>>>>>
 179                <COND (<NOT .TEMP-FILE?>
 180                       <SET TMP-TXT <SET TMP-CODE <>>>
 181                       <SETG OBJ-LIST <SETG OBJ-PTR (T)>>)>
 182                <SETG CODE-LIST <SET CP <SETG CODE-PTR (T)>>>
 183                <SETG CONST-LIST <SETG CONST-PTR (<CHTYPE [0 ()] CONST-REF>)>>
 184                <SETG INCHANS (.C)>
 185                <SET FILES <REST .FILES>>
 186                <SETG ALL-P <SETG ALL-PACKAGES (T)>
 187                <REPEAT (RES IMS) #DECL ((IMS) IMSUBR)
 188                  <REPEAT ()
 189                    <COND (<SET ITM <FINISH-FILE .C .TMP-TXT .EXPFLOAD>>)
 190                          (T
 191                           <RETURN>)>
 192                    <SET C <1 ,INCHANS>>
 193                    <COND (.TEMP-FILE? <PRIN1 .ITM .TMP-CODE>)
 194                          (ELSE <SET OBP ,OBJ-PTR>)>
 195                    <SET EST-LNT <+ <LENGTH <1 <SET IMS .ITM>>> .EST-LNT>>
 196                    <COND (<NOT <TYPE? <SET ITM <READ .C EOF>> FIX>>
 197                           <ERROR NOT-GLUEABLE!-ERRORS>)>
 198                    <SET RES <READ .C '<ERROR EOF-BAD-MSUBR-FILE!-ERRORS>>>
 199                    <COND (<NOT <TYPE? <SET RES <EVAL .RES>> MSUBR>>
 200                           <ERROR MSUBR-DOES-NOT-FOLLOW-IMSUBR!-ERRORS
 201                                  .RES>)>
 202                    <COND (.TEMP-FILE? <PRIN1 .RES .TMP-CODE>)>
 203                    <PUTREST .CP <SET CP (<CHTYPE [<2 <CHTYPE .IMS VECTOR>>
 204                                                   <2 <CHTYPE .RES VECTOR>>
 205                                                   <G=? <CHTYPE .ITM FIX> 0>
 206                                                   <3 <CHTYPE .RES VECTOR>>
 207                                                   <4 <CHTYPE .RES VECTOR>>
 208                                                   ()
 209                                                   <>
 210                                                   <ABS <CHTYPE .ITM FIX>>
 211                                                   <ARG-SPEC <3 <CHTYPE .RES
 212                                                                        VECTOR>>>
 213                                                   <LIST !.OBLIST>]
 214                                                  GLUE-INFO>)>>
 215                    <COND (.TEMP-FILE? <GUNASSIGN <2 <CHTYPE .IMS VECTOR>>>)>
 216                    <PUTPROP <2 <CHTYPE .RES VECTOR>> INFO <1 .CP>>>
 217                  <COND (<EMPTY? .FILES>
 218                         <RETURN>)>
 219                  <CLOSE .C>
 220                  <COND (<SET C <OPEN "READ" <1 .FILES>>>
 221                         <SET FILES <REST .FILES>>
 222                         <SETG INCHANS (.C)>)
 223                        (<ERROR .C FILE-MIMOC>)>>
 224                <CLOSE .C>
 225                <COND (.TEMP-FILE?
 226                       <CHANNEL-OP .TMP-TXT ACCESS 0>
 227                       <CHANNEL-OP .TMP-CODE ACCESS 0>)>
 228                <SET OBP <REST ,OBJ-LIST>>
 229                <SET CP <REST ,CODE-LIST>>
 230                <PROG ((ST <STRING .FNM1 ".GSUBR">))
 231                      <COND (<OR <NOT <TYPE? .ST STRING>>
 232                                 <NOT <SET OC <OPEN "PRINT" .ST>>>>
 233                             <SET ST <ERROR CANT-OPEN-OUTPUT!-ERRORS
 234                                            .ST
 235                                            ERRET-CORRECT-NAME!-ERRORS>>
 236                             <AGAIN>)>>
 237                <COND (<G? <LENGTH ,ALL-PACKAGES> 3>
 238                       <REPEAT ((ALL-P:LIST <REST ,ALL-PACKAGES>) NP
 239                                (OBLIST:<SPECIAL ANY> .OBLIST) ITM:<FORM ATOM>)
 240                               <COND (<EMPTY? .ALL-P> <RETURN>)>
 241                               <COND (<==? <1 .ITM> PACKAGE>
 242                                      <PRIN1 .ITM .OC>
 243                                      <SET NP <LOOKUP <2 .ITM> #OBLIST PACKAGE>>)
 244                                     (<ASSIGNED? NP>
 245                                      <SET OBLIST (<CHTYPE .NP OBLIST> <ROOT>)>
 246                                      <PRIN1 .ITM .OC>)>
 247                               <CRLF .OC>
 248                               <SET ALL-P <REST .ALL-P>>>)>
 249                <REPEAT (INM ITM (FIRST T) (OBLIST .OBLIST))
 250                        #DECL ((OBLIST) <SPECIAL ANY>)
 251                        <COND (.TEMP-FILE? <SET ITM <READ .TMP-TXT '<RETURN>>>)
 252                              (<NOT <EMPTY? .OBP>>
 253                               <SET ITM <1 .OBP>>
 254                               <SET OBLIST <GETPROP .OBP BLOCK '.OBLIST>>
 255                               <SET OBP <REST .OBP>>)
 256                              (ELSE <RETURN>)>
 257                        <COND (<TYPE? .ITM GLUED-ATOM>
 258                               <COND (.FIRST
 259                                      <GLUE-IT .CP .TMP-CODE .OC
 260                                               <SET INM <CHTYPE .ITM ATOM>>
 261                                               .EST-LNT>
 262                                      <SET FIRST <>>)>
 263                               <WRITE-MSUBR <1 .CP> .OC .INM>
 264                               <SET CP <REST .CP>>)
 265                              (ELSE <PRIN1 .ITM .OC> <CRLF .OC>)>>
 266                <CLOSE .OC>
 267                T)
 268               (<ASSIGNED? TMP-CODE>
 269                <FLUSH .TMP-TXT>
 270                <CLOSE .C>
 271                .TMP-CODE)
 272               (<ASSIGNED? TMP-TXT>
 273                <CLOSE .C>
 274                .TMP-TXT)
 275               (ELSE .C)>>
 276
 277 <DEFINE FINISH-FILE (INCHAN OUTCHAN EXPFLOAD "AUX" (IND '(1)) OBP)
 278   #DECL ((INCHAN) CHANNEL (OUTCHAN) <OR CHANNEL FALSE> (EXPFLOAD) <OR ATOM FALSE>
 279          (OBP) <LIST ANY>)
 280   <COND (<NOT .OUTCHAN> <SET OBP ,OBJ-PTR>)>
 281   <REPEAT (RES ITM NCH (OOBL <LIST !.OBLIST>))
 282     <COND (<==? <SET ITM <READ .INCHAN '.IND>> .IND>
 283            <COND (<EMPTY? <SETG INCHANS <REST ,INCHANS>>>
 284                   <COND (<NOT .OUTCHAN> <SETG OBJ-PTR .OBP>)>
 285                   <RETURN <>>)>
 286            <SET INCHAN <1 ,INCHANS>>
 287            <AGAIN>)>
 288     <UNASSIGN NCH>
 289     <COND (<AND <TYPE? .ITM FORM>
 290                 <G? <LENGTH .ITM> 1>
 291                 <OR <==? <1 .ITM> PACKAGE> <==? <1 .ITM> ENTRY>>>
 292            <PUTREST ,ALL-P <SETG ALL-P (.ITM)>>)
 293           (<AND .EXPFLOAD
 294                 <TYPE? .ITM FORM>
 295                 <NOT <EMPTY? .ITM>>
 296                 <PROG OUT ()
 297                       <COND (<==? <1 .ITM> FLOAD>
 298                              <SET NCH <OPEN "READ" !<REST .ITM>>>)
 299                             (<==? <1 .ITM> L-FLOAD>
 300                              <SET NCH <L-OPEN <2 .ITM>>>)
 301                             (ELSE <RETURN <>>)>
 302                       <COND (<NOT .NCH>
 303                              <PROG (NM)
 304                                    <COND (<SET NM
 305                                                <ERROR
 306                                                 .NCH
 307                                                 ERRET-NAME-OR-FALSE!-ERROS>>
 308                                           <COND (<NOT <SET NCH <OPEN "READ" .NM>>>
 309                                                  <AGAIN>)>)
 310                                          (ELSE
 311                                           <RETURN <> .OUT>)>>)>
 312                       1>>
 313            <SET INCHAN .NCH>
 314            <SETG INCHANS (.NCH !,INCHANS)>)
 315           (ELSE
 316            <SET RES <>>
 317            <COND (<NOT <ASSIGNED? NCH>> <SET RES <EVAL .ITM>>)>
 318            <COND (<AND .RES <TYPE? .RES IMSUBR>>
 319                   <COND (.OUTCHAN
 320                          <PRIN1 <CHTYPE <2 .RES> GLUED-ATOM> .OUTCHAN>)
 321                         (ELSE
 322                          <PUTREST .OBP
 323                                   <SET OBP (<CHTYPE <2 .RES> GLUED-ATOM>)>>)>
 324                   <COND (<NOT .OUTCHAN> <SETG OBJ-PTR .OBP>)>
 325                   <RETURN .RES>)
 326                  (.OUTCHAN <PRIN1 .ITM .OUTCHAN>)
 327                  (ELSE
 328                   <PUTREST .OBP <SET OBP (.ITM)>>
 329                   <COND (<N=? .OOBL .OBLIST>
 330                          <PUTPROP .OBP BLOCK <SET OOBL <LIST !.OBLIST>>>)>)>)>>>
 331
 332 <SETG OUTPUT-LENGTH 1024>
 333
 334 <GDECL (OUTPUT-LENGTH) FIX>
 335
 336 <SETG OUTPUT-BUFFER <ISTRING ,OUTPUT-LENGTH>>
 337
 338 <DEFINE GLUE-IT (CP CHAN? OC NAM LNT
 339                  "AUX" (IMS (T)) (IMP .IMS) (NUM 0)
 340                        (NEW-CODE <IUVECTOR <+ </ .LNT 2> .LNT>>)
 341                        (OB ,OUTPUT-BUFFER) CNUM (CHRS 0))
 342         #DECL ((IMSP IMP) LIST (CP) <LIST [REST GLUE-INFO]> (CHRS OL LNT NUM) FIX
 343                (OB) STRING)
 344         <MAPF <>
 345               <FUNCTION (G-O) #DECL ((G-O) GLUE-INFO)
 346                    <FINAL-LOC .G-O .NUM>
 347                    <MAPF <>
 348                          <FUNCTION (LOC) #DECL ((LOC) FIX)
 349                               <PUT .NEW-CODE
 350                                    .LOC
 351                                    <ORB <NTH .NEW-CODE .LOC> .NUM>>>
 352                          <REFS .G-O>>
 353                    <REFS .G-O ()>
 354                    <SET NUM <DO-ONE-GLUE <COND (.CHAN? <READ .CHAN?>)
 355                                                (ELSE ,<IMSUBR-NAME .G-O>)>
 356                                          .IMS
 357                                          .IMP
 358                                          .NUM
 359                                          <CONST-START .G-O>
 360                                          .NEW-CODE>>
 361                    <SET IMP <REST .IMS <- <LENGTH .IMS> 1>>>>
 362               .CP>
 363         <SET CNUM .NUM>
 364         <MAPF <>
 365               <FUNCTION (C) #DECL ((C) CONST-REF)
 366                    <MAPF <>
 367                          <FUNCTION (LOC) #DECL ((LOC) FIX)
 368                               <PUT .NEW-CODE .LOC <ORB <NTH .NEW-CODE .LOC>
 369                                                        .CNUM>>>
 370                          <C-REFS .C>>
 371                    <SET CNUM <+ .CNUM 1>>
 372                    <C-REFS .C ()>>
 373               <REST ,CONST-LIST>>
 374         <PRINC "<SETG " .OC>
 375         <PRIN1 .NAM .OC>
 376         <PRINC " #IMSUBR [|" .OC>
 377         <PRINTBYTE <LSH .CNUM -16>>
 378         <PRINTBYTE <LSH .CNUM -8>>
 379         <PRINTBYTE .CNUM>
 380         <MAPF <>
 381               <FUNCTION (WRD)
 382                    #DECL ((WRD) FIX)
 383                    <REPEAT ((I 4)) #DECL ((I) FIX)
 384                            <PRINTBYTE <SET WRD <ROT .WRD 9>>>
 385                            <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>
 386                    <COND (<L=? <SET NUM <- .NUM 1>> 0> <MAPLEAVE>)>>
 387               .NEW-CODE>
 388         <MAPF <>
 389               <FUNCTION (C "AUX" (WRD <C-VALUE .C>))
 390                    #DECL ((C) CONST-REF (WRD) FIX)
 391                    <REPEAT ((I 4)) #DECL ((I) FIX)
 392                            <PRINTBYTE <SET WRD <ROT .WRD 9>>>
 393                            <COND (<==? <SET I <- .I 1>> 0> <RETURN>)>>>
 394               <REST ,CONST-LIST>>
 395         <CHANNEL-OP .OC WRITE-BUFFER ,OUTPUT-BUFFER
 396                     <- ,OUTPUT-LENGTH <LENGTH .OB>>>
 397         <PRINC "| " .OC>
 398         <PRIN1 .NAM .OC>
 399         <MAPF <>
 400               <FUNCTION (OBJ)
 401                    <PRINC !\ .OC>
 402                    <PRIN1 .OBJ .OC>>
 403               <REST .IMS>>
 404         <PRINC "]>" .OC>
 405         <CRLF .OC>>
 406
 407 <DEFINE WRITE-MSUBR (G-I OC INM) #DECL ((G-I) GLUE-INFO)
 408         <PRINC "<SETG " .OC>
 409         <PRIN1 <MSUBR-NAME .G-I> .OC>
 410         <PUTPROP <MSUBR-NAME .G-I> INFO>
 411         <PRINC " #MSUBR [" .OC>
 412         <PRIN1 .INM .OC>
 413         <PRINC !\ .OC>
 414         <PRIN1 <MSUBR-NAME .G-I> .OC>
 415         <PRINC !\  .OC>
 416         <PRIN1 <MSUBR-DECL .G-I> .OC>
 417         <PRINC !\  .OC>
 418         <PRIN1 <FINAL-LOC .G-I> .OC>
 419         <PRINC "]>" .OC>
 420         <CRLF .OC>>
 421
 422 <DEFINE DO-ONE-GLUE (IMS MV MVP CURR CONST-S CV
 423                      "AUX" (COD <1 .IMS>) (REL-PC 0) (FRM-STACK ())
 424                            (GLUE-CALL-NO 0) (PC-DIFF 0)
 425                            (FRAME-CHANGES (T)) (FCP .FRAME-CHANGES)
 426                            (CV-LN <LENGTH .CV>) FUDGE (OUT-CNT <+ .CURR 1>))
 427         #DECL ((IMS) IMSUBR (MV MVP FRM-STACK FCP FRAME-CHANGES) LIST
 428                (CALLS) <VECTOR [REST ATOM]>
 429                (CV-LN REL-PC OUT-CNT GLUE-CALL-NO CURR CONST-S) FIX
 430                (COD) CODE (DB) <LIST [REST GLUE-INFO]> (CV) <UVECTOR [REST FIX]>)
 431         <MAPR <>
 432               <FUNCTION (IP "AUX" TMP (INS <1 .IP>) MOB (NARG <>) LD-NARG
 433                                   LD-AT AC MI MA (INDX <GETBITS .INS ,INDX-BP>))
 434                    #DECL ((MI MA AC INS INDX LD-AT LD-NARG) FIX
 435                           (NARG) <OR FALSE FIX>)
 436                    <COND (<==? .INS ,JSP-FRAME>
 437                           <SET FRM-STACK (<+ .REL-PC 1> !.FRM-STACK)>)
 438                          (<==? .INS ,JSP-SFRAME>
 439                           <SET FRM-STACK (-1 !.FRM-STACK)>)
 440                          (<==? .INS ,JSP-CALL>
 441                           <COND (<EMPTY? .FRM-STACK>
 442                                  <ERROR BAD-CODE-UNMATCHED-FRAME-CALL!-ERRORS>)
 443                                 (<==? <1 .FRM-STACK> -1>
 444                                  <SET FRM-STACK <REST .FRM-STACK>>)
 445                                 (ELSE
 446                                  <REPEAT ((N <- <LENGTH .COD> <LENGTH .IP>>) I AC)
 447                                   #DECL ((AC I N) FIX)
 448                                   <COND (<==? <SET AC
 449                                                    <GETBITS <SET I <NTH .COD .N>>
 450                                                             ,AC-BP>>
 451                                               ,O1>
 452                                          <SET MOB
 453                                               <NTH .IMS
 454                                                    <+ </ <ANDB .I *777777*>
 455                                                          2> 1>>>
 456                                          <SET LD-AT .N>
 457                                          <RETURN>)
 458                                         (<AND <==? .AC ,O2>
 459                                               <==? <GETBITS .I ,INS-BP> ,MOVEI>>
 460                                          <SET LD-NARG .N>
 461                                          <SET NARG <ANDB .I *777777*>>)
 462                                         (<==? .AC ,O2> <SET LD-NARG .N>)>
 463                                   <COND (<L=? <SET N <- .N 1>> 0>
 464                                          <ERROR
 465                                           BAD-CODE-NO-LOAD-OF-MSUBR!-ERRORS>)>>
 466                                  <COND (<AND <GASSIGNED? .MOB>
 467                                              <TYPE? <SET MOB
 468                                                          <GETPROP .MOB INFO>>
 469                                                     GLUE-INFO>
 470                                              <GLUED-CALL-OK? .MOB>
 471                                              <NOT <COND
 472                                                    (<AND
 473                                                      .NARG
 474                                                      <OR <G?
 475                                                           .NARG
 476                                                           <SET MA
 477                                                                <LSH <MIN-MAX-ARGS
 478                                                                      .MOB>
 479                                                                     -18>>>
 480                                                          <L?
 481                                                           .NARG
 482                                                           <SET MI
 483                                                                <ANDB <MIN-MAX-ARGS
 484                                                                       .MOB>
 485                                                                      *777777*>>>>>
 486                                                     <PRINC
 487                                                      <STRING
 488                                                       "Wrong number args to "
 489                                                       <SPNAME <MSUBR-NAME .MOB>>
 490                                                       " from "
 491                                                       <2 .IMS>
 492                                                       " supplied= "
 493                                                       <UNPARSE .NARG>
 494                                                       " max= "
 495                                                       <UNPARSE .MA>
 496                                                       " min= "
 497                                                       <UNPARSE .MI>
 498                                                       " not glued!"> ,OUTCHAN>
 499                                                     <CRLF ,OUTCHAN>
 500                                                     T)>>>
 501                                         <PUT .IP 1
 502                                              <+ .GLUE-CALL-NO ,GLUE-CALL-INS>>
 503                                         <PUT .COD .LD-AT
 504                                              <+ .GLUE-CALL-NO ,GLUE-LOAD-MS-INS>>
 505                                         <PUT .COD <CHTYPE <1 .FRM-STACK> FIX>
 506                                              <+ .GLUE-CALL-NO ,GLUE-FRM-INS>>
 507                                         <SET FCP
 508                                              <REST <PUTREST .FCP
 509                                                             (.MOB
 510                                                              <NTH .COD .LD-NARG>
 511                                                              <1 .FRM-STACK>)>
 512                                                    3>>
 513                                         <COND (<AND .NARG <==? .MI .MA>>
 514                                                <PUT .COD .LD-NARG
 515                                                     <+ .GLUE-CALL-NO
 516                                                        ,GLUE-LOAD-ARG>>)>
 517                                         <SET GLUE-CALL-NO <+ .GLUE-CALL-NO 4>>)>
 518                                  <SET FRM-STACK <REST .FRM-STACK>>)>)
 519                          (<MEMQ .INS ,FUNNY-CALLS>
 520                           <SET FRM-STACK <REST .FRM-STACK>>)>
 521                    <COND (<G=? <SET REL-PC <+ .REL-PC 1>> .CONST-S>
 522                           <MAPLEAVE>)>>
 523               .COD>
 524         <SET REL-PC 0>
 525         <SET FCP <REST .FRAME-CHANGES>>
 526         <MAPR <>
 527               <FUNCTION (IP "AUX" TMP (INS <1 .IP>) MOB
 528                                   CCOD (INDX <GETBITS .INS ,INDX-BP>))
 529                    #DECL ((CCOD INS INDX) FIX)
 530                    <COND (<L=? <ABS .INS> *777777*>
 531                           <COND (<==? <SET CCOD <ANDB .INS 3>> ,GLUE-FRM-INS>
 532                                  <UPDATE-JUMPS <+ .REL-PC .PC-DIFF> .COD 4>
 533                                  <SET PC-DIFF <+ .PC-DIFF 4>>)
 534                                 (<==? .CCOD ,GLUE-LOAD-MS-INS> <SET FUDGE <>>)
 535                                 (<==? .CCOD ,GLUE-LOAD-ARG> <SET FUDGE T>)
 536                                 (<OR .FUDGE
 537                                      <N==? <GETBITS <SET INS <2 .FCP>> ,INS-BP>
 538                                            ,MOVEI>>
 539                                  <UPDATE-JUMPS <+ .REL-PC .PC-DIFF> .COD
 540                                                <COND (.FUDGE -1) (ELSE 2)>>
 541                                  <SET PC-DIFF <+ .PC-DIFF
 542                                                  <COND (.FUDGE -1) (ELSE 2)>>>)>
 543                           <COND (<==? .CCOD ,GLUE-CALL-INS>
 544                                  <SET FCP <REST .FCP 3>>)>)
 545                          (<==? .INDX ,M>
 546                           <SET MOB <NTH .IMS <+ </ <ANDB .INS *777777*> 2> 1>>>
 547                           <COND (<SET TMP <MEMBER .MOB <REST .MV>>>)
 548                                 (ELSE
 549                                  <PUTREST .MVP <SET TMP (.MOB)>>
 550                                  <SET MVP .TMP>)>
 551                           <SET INS <PUTBITS .INS ,ADDR-BP
 552                                             <+ <* <- <LENGTH .MV>
 553                                                      <LENGTH .TMP> -1> 2>
 554                                                <MOD <GETBITS .INS
 555                                                              ,ADDR-BP> 2>>>>
 556                           <PUT .IP 1 .INS>)>
 557                    <COND (<G=? <SET REL-PC <+ .REL-PC 1>> .CONST-S>
 558                           <MAPLEAVE>)>>
 559               .COD>
 560         <SET REL-PC 0>
 561         <SET FCP <REST .FRAME-CHANGES>>
 562         <MAPR <>
 563               <FUNCTION (IP "AUX" (INS <1 .IP>) TMP MOB CCOD G-I FL
 564                                   (INDX <GETBITS .INS ,INDX-BP>))
 565                    #DECL ((CCOD INS INDX) FIX (G-I) GLUE-INFO (FL) <OR FALSE FIX>)
 566                    <COND (<L? <- .CV-LN .OUT-CNT> 5>
 567                           <ERROR OUTPUT-CODE-VECTOR-OVERFLOW!-ERRORS>)>
 568                    <COND (<G? <SET REL-PC <+ .REL-PC 1>> .CONST-S>
 569                           <PUT .CV .OUT-CNT .INS>)
 570                          (<L=? <ABS .INS> *777777*>
 571                           <COND (<==? <SET CCOD <ANDB .INS 3>> ,GLUE-FRM-INS>
 572                                  <PUT .CV .OUT-CNT ,SKIPL-T-1-PARENF>
 573                                  <PUT .CV <SET OUT-CNT <+ .OUT-CNT 1>> ,HRROI-T>
 574                                  <PUT .CV <SET OUT-CNT <+ .OUT-CNT 1>> ,PUSH-TP-T>
 575                                  <PUT .CV <SET OUT-CNT <+ .OUT-CNT 1>>
 576                                       ,PUSH-TP-PARENR>
 577                                  <PUT .IP 1 .OUT-CNT>
 578                                  <PUT .CV <SET OUT-CNT <+ .OUT-CNT 1>> ,PUSH-TP-F>)
 579                                 (<==? .CCOD ,GLUE-CALL-INS>
 580                                  <COND (<N==? <GETBITS <SET INS <2 .FCP>> ,INS-BP>
 581                                               ,MOVEI>
 582                                         <PUT .CV .OUT-CNT ,XMOVEI-F-1-TP>
 583                                         <PUT .CV <SET OUT-CNT <+ .OUT-CNT 1>>
 584                                              ,SUB-F-O2>
 585                                         <PUT .CV <SET OUT-CNT <+ .OUT-CNT 1>>
 586                                              ,SUB-F-O2>)
 587                                        (ELSE
 588                                         <PUT .CV .OUT-CNT
 589                                              <ORB ,XMOVEI-TP
 590                                                   <ANDB <- <+ <* <ANDB .INS
 591                                                                        *777777*> 2>
 592                                                               1>>
 593                                                         *777777*>>>)>
 594                                  <SET OUT-CNT <+ .OUT-CNT 1>>
 595                                  <COND (<SET FL <FINAL-LOC <SET G-I <1 .FCP>>>>
 596                                         <PUT .CV .OUT-CNT <ORB ,JRST-R .FL>>)
 597                                        (ELSE
 598                                         <PUT .CV .OUT-CNT ,JRST-R>
 599                                         <REFS .G-I (.OUT-CNT !<REFS .G-I>)>)>
 600                                  <ADD-CONST <ORB ,SETZ-R .OUT-CNT>
 601                                             <NTH .COD <3 .FCP>>>
 602                                  <SET FCP <REST .FCP 3>>)
 603                                 (ELSE <SET OUT-CNT <- .OUT-CNT 1>>)>)
 604                          (<==? .INDX ,R>
 605                           <PUT .CV
 606                                .OUT-CNT
 607                                <ORB <ANDB .INS *777777000000*>
 608                                     <ANDB <+ .INS .CURR> *777777*>>>)
 609                          (ELSE <PUT .CV .OUT-CNT .INS>)>
 610                    <SET OUT-CNT <+ .OUT-CNT 1>>>
 611               .COD>
 612         <- .OUT-CNT 1>>
 613
 614 <DEFINE ADD-CONST (X WHERE) #DECL ((X) FIX)
 615         <COND (<MAPF <>
 616                      <FUNCTION (C-R) #DECL ((C-R) CONST-REF)
 617                           <COND (<==? <C-VALUE .C-R> .X>
 618                                  <C-REFS .C-R (.WHERE !<C-REFS .C-R>)>
 619                                  <MAPEAVE T>)>>
 620                      <REST ,CONST-LIST>>)
 621               (ELSE
 622                <PUTREST ,CONST-PTR
 623                         <SETG CONST-PTR (<CHTYPE [.X (.WHERE)] CONST-REF>)>>)>>
 624
 625
 626 <DEFINE UPDATE-JUMPS (WHERE COD HOW-MUCH)
 627         #DECL ((COD) CODE (WHERE HOW-MUCH) FIX)
 628         <MAPR <>
 629               <FUNCTION (IP "AUX" AD (INS <1 .IP>)
 630                          (INDX <GETBITS .INS ,INDX-BP>))
 631                    #DECL ((AD INS INDX) FIX)
 632                    <COND (<AND <==? .INDX ,R>
 633                                <G? <SET AD <ANDB .INS *777777*>> .WHERE>
 634                                <L? .AD *400000*>>
 635                           <PUT .IP
 636                                1
 637                                <ORB <ANDB .INS *777777000000*>
 638                                     <ANDB <+ .AD .HOW-MUCH> *777777*>>>)>>
 639               .COD>>
 640
 641 <DEFINE ARG-SPEC (DCL "AUX" (MIN 0) (MAX 0) (OPT <>))
 642         #DECL ((DCL) LIST (MIN MAX) FIX)
 643         <COND (<OR <EMPTY? .DCL> <N=? <1 .DCL> "VALUE">>
 644                <LSH -1 18>)
 645               (ELSE
 646                <MAPF <>
 647                      <FUNCTION (EL)
 648                           <COND (<TYPE? .EL ATOM FORM SEGMENT>
 649                                  <SET MAX <+ .MAX 1>>
 650                                  <COND (<NOT .OPT>
 651                                         <SET MIN <+ .MIN 1>>)>)
 652                                 (<MEMBER .EL '["OPT" "OPTIONAL" "ARGS"]>
 653                                  <SET OPT T>)
 654                                 (<=? .EL "QUOTE">)
 655                                 (<=? .EL "TUPLE">
 656                                  <SET MAX *777777*>
 657                                  <MAPLEAVE>)
 658                                 (ELSE <ERROR BAD-DECL!-ERRORS>)>>
 659                      <REST .DCL 2>>
 660                <ORB <LSH .MAX 18> .MIN>)>>
 661
 662 <DEFINE GET-NM1 (STR "AUX" (SEEN-OP <>)) #DECL ((STR) STRING)
 663         <MAPF ,STRING <FUNCTION (CH) <COND (<==? .CH !\<> <SET SEEN-OP T>)
 664                                            (<==? .CH !\>> <SET SEEN-OP <>>)
 665                                            (<AND <NOT .SEEN-OP>
 666                                                  <==? .CH !\.>> <MAPSTOP>)
 667                                            (ELSE .CH)>> .STR>>
 668
 669 <ENDPACKAGE>