mim/development/mim/mimc/compdec.mud

   1
   2 <PACKAGE "COMPDEC">
   3
   4 <ENTRY CTLZ-PRINT
   5        RSUB-DEC
   6        TMPS-NEXT
   7        TMP-DEST
   8        NO-BQ
   9        EXTRA-CODE
  10        ALL-TEMPS-LIST
  11        MIM-OBL
  12        TMP-OBL
  13        DEATH
  14        HAIRY-ANALYSIS
  15        DEBUG-COMPILE
  16        CODE-START
  17        CODE-PTR
  18        FCNS
  19        TMPS
  20        IDT
  21        STYPES
  22        PLUSINF
  23        MINUSINF
  24        IPUT
  25        TEMPV
  26        DEBUGSW
  27        INSTRUCTION
  28        INTH
  29        FCN
  30        SNODES
  31        SNODES1
  32        PSTACK
  33        DUMMY-MAPF
  34        INCONSISTENCY
  35        SEGS
  36        SPEC
  37        CODVEC
  38        QUOTE-CODE
  39        ADECL-CODE
  40        CALL-CODE
  41        APPLY-CODE
  42        RETURN-CODE
  43        IPUT-CODE
  44        SEG-CODE
  45        MULTI-RETURN-CODE
  46        PREDV
  47        SYM-SLOT
  48        STK
  49        STKTMP
  50        STK-CHARS7
  51        STK-CHARS8
  52        BINDING-LENGTH
  53        PARENT
  54        TYPE-INFO
  55        PROG-VARS
  56        CURRENT-TYPE
  57        NODE1
  58        PUTR-CODE
  59        ISUBR-CODE
  60        EOF-CODE
  61        IREMAS-CODE
  62        GVAL-CODE
  63        SPARE4-CODE
  64        ADDVAR
  65        FSET-CODE
  66        OFFPTR
  67        PROG-CODE
  68        COMP-TYPES
  69        NODE-NAME
  70        AGND
  71        REQARGS
  72        DECL-SYM
  73        PUT-CODE
  74        FLVAL-CODE
  75        SETG-CODE
  76        BACK-CODE
  77        PUT-SAME-CODE
  78        RSUBR-DECLS
  79        NODEF
  80        AND-CODE
  81        MT-CODE
  82        BITS-CODE
  83        FPUTBITS-CODE
  84        COPY-LIST-CODE
  85        SPARE1-CODE
  86        ATAG
  87        ASSUM
  88        PURE-SYM
  89        NUM-SYM
  90        KID
  91        GNAME-SYM
  92        CHTYPE-CODE
  93        NODE
  94        SYMTAB
  95        GDECL-SYM
  96        MAP-CODE
  97        MARGS-CODE
  98        DATVAL
  99        NODE-SUBR
 100        LIVE-VARS
 101        SPEC-SYM
 102        AS-NXT-CODE
 103        SUBSTRUC-CODE
 104        BIT-TEST-CODE
 105        SPARE3-CODE
 106        NOT-CODE
 107        TEST-CODE
 108        MIN-MAX-CODE
 109        READ-EOF2-CODE
 110        KIDS
 111        PREDIC
 112        NODEPR
 113        NODEFM
 114        GNEXT-SYM
 115        FIX-CODE
 116        MFCN-CODE
 117        IRSUBR-CODE
 118        CASE-CODE
 119        SCL
 120        NODE-TYPE
 121        DEAD-VARS
 122        DEATH-LIST
 123        COMPOSIT-TYPE
 124        PRED
 125        COPY-CODE
 126        LENGTH?-CODE
 127        INIT-DECL-TYPE
 128        NODECOND
 129        FUNCTION-CODE
 130        AGAIN-CODE
 131        0-TST-CODE
 132        FGETBITS-CODE
 133        MAPRET-STOP-CODE
 134        LSH-CODE
 135        SYMBOL
 136        NODEB
 137        SET-CODE
 138        ROT-CODE
 139        BINDING-STRUCTURE
 140        CDST
 141        VSPCD
 142        NAME-SYM
 143        INIT-SYM
 144        EQ-CODE
 145        ALL-REST-CODE
 146        DISPATCH
 147        DST
 148        RTAG
 149        ACCUM-TYPE
 150        DATUM
 151        ARGNUM-SYM
 152        ADDR-SYM
 153        USED-AT-ALL
 154        ARGNUM
 155        FGVAL-CODE
 156        ID-CODE
 157        FORM-F-CODE
 158        INFO-CODE
 159        TEMP
 160        CLAUSES
 161        TRG
 162        VARTBL
 163        LVARTBL
 164        SUBR-CODE
 165        LNTH-CODE
 166        ASSIGNED?-CODE
 167        GET2-CODE
 168        AS-IT-IND-VAL-CODE
 169        COMMON
 170        DATTYP
 171        RET-AGAIN-ONLY
 172        SEGMENT-CODE
 173        FSETG-CODE
 174        ISTRUC-CODE
 175        MFIRST-CODE
 176        CODE-SYM
 177        BST
 178        RSUBR-CODE
 179        1?-CODE
 180        REST-CODE
 181        ABS-CODE
 182        MPSBR-CODE
 183        UNWIND-CODE
 184        PRINT-CODE
 185        OBLIST?-CODE
 186        STACKS
 187        ASS?
 188        BRANCH-CODE
 189        LVAL-CODE
 190        OR-CODE
 191        ISTRUC2-CODE
 192        READ-EOF-CODE
 193        MAPLEAVE-CODE
 194        MEMQ-CODE
 195        RESULT-TYPE
 196        SIDE-EFFECTS
 197        NEXT-SYM
 198        FORM-CODE
 199        TY?-CODE
 200        FLOAT-CODE
 201        GET-CODE
 202        SPECS-START
 203        RES-TYP
 204        BITL-CODE
 205        TOP-CODE
 206        SPARE2-CODE
 207        ACTIVATED
 208        TOTARGS
 209        VTB
 210        RQRG
 211        COND-CODE
 212        ARITH-CODE
 213        NTH-CODE
 214        MOD-CODE
 215        IND
 216        ALL
 217        NOTE
 218        WARNING
 219        PRIM-CODE
 220        CAREFUL
 221        REASONABLE
 222        DONT-CARE
 223        FLUSHED
 224        NO-RETURN
 225        NO-DATUM
 226        MESSAGE
 227        GROUP-NAME
 228        COMMON-TYPE
 229        COMMON-SYMTAB
 230        COMMON-ITEM
 231        COMMON-PRIMTYPE
 232        COMMON-DATUM
 233        COMMON-SYMT
 234        TRANSFORM
 235        TRANS
 236        N0?
 237        POPWR2
 238        DEALLOCATE
 239        SRC-FLG
 240        BIN-FLG
 241        GLOSP
 242        ANALY-OK
 243        VERBOSE
 244        COMPILER
 245        INDARGL-ACT
 246        ARGL-IAUX
 247        ARGL-AUX
 248        ARGL-TUPLE
 249        ARGL-ARGS
 250        ARGL-QIOPT
 251        ARGL-IOPT
 252        ARGL-QOPT
 253        ARGL-OPT
 254        ARGL-CALL
 255        ARGL-BIND
 256        ARGL-QUOTE
 257        ARGL-ACT
 258        ARGL-ARG
 259        TAG-COUNT
 260        TEMP-NAME-SYM
 261        ARG-NAME-SYM
 262        ARGS-NEXT
 263        SPCS-X
 264        POP-STACK
 265        TOP-STACK
 266        TEMP-NAME
 267        TEMP-REFS
 268        TEMP-FRAME
 269        TEMP-ALLOC
 270        TEMP-NO-RECYCLE
 271        TEMP-TYPE
 272        FREE-TEMPS
 273        EVERY-TEMP
 274        MIM-SPECIAL
 275        MONAD-CODE
 276        GASSIGNED?-CODE
 277        GLN
 278        USAGE-SYM
 279        =?-STRING-CODE
 280        TYPE-C-CODE
 281        ANALYSIS
 282        VALID-CODE
 283        LIST-TUPLE
 284        FCN-ATOM
 285        STACK-CODE
 286        CHANNEL-OP-CODE
 287        RET-OR-AGAIN
 288        DONT-FLUSH-ME
 289        ATOM-PART-CODE
 290        OFFSET-PART-CODE
 291        PUT-GET-DECL-CODE
 292        THE-BOOL
 293        THE-BIT
 294        SPECD
 295        MULTI-SET-CODE
 296        MAX-LENGTH>
 297
 298 <SETG MAX-LENGTH *177777*>
 299
 300 <MANIFEST MAX-LENGTH>
 301
 302 <GDECL (SNODES SNODES1) <UVECTOR [REST FIX]>>
 303
 304 <NEWTYPE STACK WORD>
 305
 306 <BLOCK (<ROOT>)>
 307
 308 <NEWTYPE I$TERMIN WORD>
 309 <NEWTYPE ADECL VECTOR>
 310 =
 311 LBIND
 312 <NEWTYPE T$UNBOUND WORD>
 313
 314 <ENDBLOCK>
 315
 316 <SETG DEATH <>>
 317
 318 <SETG BQ+1 <+ <ASCII !\`> 1>>
 319
 320 <COND (<OR <NOT <ASSIGNED? READ-TABLE>>
 321            <L? <LENGTH .READ-TABLE> ,BQ+1>>
 322        <COND (<==? <TYPEPRIM FIX> WORD>
 323               <SETG READ-TABLE <SET READ-TABLE <IVECTOR ,BQ+1 0>>>)
 324              (ELSE
 325               <SETG READ-TABLE <SET READ-TABLE <IVECTOR ,BQ+1 <>>>>)>)>
 326
 327 <SETG MIM-OBL <MOBLIST MIM-OBL>>
 328
 329 <SETG TMP-OBL <MOBLIST TMPS>>
 330
 331 <SETG MIM-OBL-L (,MIM-OBL)>
 332
 333 <DEFINE BQ-RD (X "OPT" Y "AUX" (O .OBLIST) (OBLIST ,MIM-OBL-L))
 334         #DECL ((OBLIST) <SPECIAL ANY>)
 335         <COND (<NOT <TYPE? <SET X <READ>> ATOM>>
 336                <PROG ((OBLIST .O))
 337                      #DECL ((OBLIST) <SPECIAL ANY>)
 338                      <ERROR BAD-BACK-Q-USAGE!-ERRORS>>)
 339               (ELSE .X)>>
 340
 341 <COND (<AND <==? <TYPEPRIM FIX> WORD> <N==? <NTH .READ-TABLE ,BQ+1> 0>>
 342        <PUT .READ-TABLE ,BQ+1 ,BQ-RD>)
 343       (<AND <==? <TYPEPRIM FIX> FIX> <NOT <NTH .READ-TABLE ,BQ+1>>>
 344        <PUT .READ-TABLE ,BQ+1 [!\` <ASCII !\`> T ,BQ-RD <>]>)>
 345
 346 <SETG POP-STACK `STACK>
 347
 348 <SETG TOP-STACK `STACK>
 349
 350 <NEWTYPE FOOATOM ATOM>
 351
 352 <NEWTYPE FCN-ATOM ATOM>
 353
 354 <SETG OLD-ATOM <PRINTTYPE ATOM>>
 355
 356 <PRINTTYPE ATOM ,PRINT>
 357
 358 <PRINTTYPE FCN-ATOM>
 359
 360 <PRINTTYPE FOOATOM ATOM>
 361
 362 <DEFINE ATOM-PRINT ACT (X) #DECL ((ACT) <SPECIAL ANY>)
 363         <COND (<==? <OBLIST? .X> ,MIM-OBL>
 364                <COND (<NOT <AND <ASSIGNED? NO-BQ> .NO-BQ>>
 365                       <PRINC "`">)>
 366                <PRINC <SPNAME .X>>)
 367               (<==? <OBLIST? .X> ,TMP-OBL> <PRINC <SPNAME .X>>)
 368               (ELSE
 369                <SET ACT <CHTYPE .ACT FRAME>>
 370                <PROG ()
 371                      <COND (<MEMQ <FUNCT .ACT> '[PRINT PPRINT PRIN1 TOPLEV
 372                                                  PRINT-MANY
 373                                                  FLATSIZE UNPARSE]>
 374                             <PRIN1 <CHTYPE .X FOOATOM>>)
 375                            (<==? <FUNCT .ACT> PRINC>
 376                             <PRINC <CHTYPE .X FOOATOM>>)
 377                            (ELSE
 378                             <SET ACT <FRAME .ACT>>
 379                             <AGAIN>)>>)>>
 380
 381 <DEFINE FCN-ATOM-PRINT ACT (X) #DECL ((ACT) <SPECIAL ANY>)
 382         <COND (<AND <GASSIGNED? CTLZ-PRINT> ,CTLZ-PRINT>
 383                <PRINC <ASCII 26>>)>
 384         <SET ACT <CHTYPE .ACT FRAME>>
 385         <PROG ()
 386               <COND (<MEMQ <FUNCT .ACT> '[PRINT PPRINT PRIN1 TOPLEVEL
 387                                           FLATSIZE UNPARSE]>
 388                      <PRIN1 <CHTYPE .X FOOATOM>>)
 389                     (<==? <FUNCT .ACT> PRINC>
 390                      <PRINC <CHTYPE .X FOOATOM>>)
 391                     (ELSE
 392                      <SET ACT <FRAME .ACT>>
 393                      <AGAIN>)>>>
 394
 395 <COND (<==? ,OLD-ATOM ATOM>
 396        <PRINTTYPE ATOM ,ATOM-PRINT>
 397        <PRINTTYPE FCN-ATOM ,FCN-ATOM-PRINT>)>
 398
 399 <PRINTTYPE STACK <FUNCTION (X) <PRINC "#STACK "> <PRIN1 <CHTYPE .X FIX>>>>
 400
 401 <SETG PLUSINF <CHTYPE <MIN> FIX>>
 402
 403 <SETG MINUSINF <CHTYPE <MAX> FIX>>
 404
 405 "Type specification for NODE."
 406
 407 <NEWTYPE NODE
 408          VECTOR
 409          '<<PRIMTYPE VECTOR>
 410                   FIX                                                ;NODE-TYPE
 411                   ANY                                                   ;PARENT
 412                   ANY                                              ;RESULT-TYPE
 413                   ANY                                       ;(NODE-NAME PREDIC)
 414                   <LIST [REST NODE]>                            ;(KIDS CLAUSES)
 415                   <OR FALSE ATOM>                                         ;SEGS
 416                   [OPTIONAL
 417                    LIST                                  ;(TYPE-INFO LIVE-VARS)
 418                    ANY                                            ;SIDE-EFFECTS
 419                    ANY                                 ;(RSUBR-DECLS NODE-SUBR)
 420                    LIST                                      ;BINDING-STRUCTURE
 421                    SYMTAB                                               ;SYMTAB
 422                    <OR FALSE ATOM>                                   ;ACTIVATED
 423                    ANY                                                  ;SPCS-X
 424                    ANY                                        ;(DST ACCUM-TYPE)
 425                    ANY                                        ;(CDST DEAD-VARS)
 426                    ANY                                            ;(ATAG VSPCD)
 427                    ANY                                   ;(RTAG INIT-DECL-TYPE)
 428                    LIST                                                  ;ASSUM
 429                    <OR FALSE LIST>                                        ;AGND
 430                    FIX                                                 ;TOTARGS
 431                    FIX                                             ;REQARGS]>>
 432
 433 "Offsets into pass 1 structure entities and functions to create same."
 434
 435 <SETG NODE-TYPE <OFFSET 1 NODE>>
 436
 437 ;"Code specifying the node type."
 438
 439 <SETG PARENT <OFFSET 2 NODE>>
 440
 441 ;"Pointer to parent node."
 442
 443 <SETG RESULT-TYPE <OFFSET 3 NODE>>
 444
 445 ;"Type expression for result returned by code
 446                                    generated by this node."
 447
 448 <SETG NODE-NAME <OFFSET 4 NODE>>
 449
 450 ;"Usually name of SUBR associated with  this node."
 451
 452 <SETG KIDS <OFFSET 5 NODE>>
 453
 454 ;"List of sub-nodes for this node."
 455
 456 <SETG SEGS <OFFSET 6 NODE>>
 457
 458 ;"Predicate:  any segments among kids?"
 459
 460 <SETG TYPE-INFO <OFFSET 7 NODE>>
 461
 462 ;"Points to transient type info for this node."
 463
 464 <SETG SIDE-EFFECTS <OFFSET 8 NODE>>
 465
 466 ;"General info about side effects (format not yet firm.)"
 467
 468 <SETG RSUBR-DECLS <OFFSET 9 NODE>>
 469
 470 ;"Function only: final rsubr decls."
 471
 472 <SETG BINDING-STRUCTURE <OFFSET 10 NODE>>
 473
 474 ;"Partially compiled arg list."
 475
 476 <SETG SYMTAB <OFFSET 11 NODE>>
 477
 478 ;"Pointer to local symbol table."
 479
 480 <SETG ACTIVATED <OFFSET 12 NODE>>
 481
 482 ;"Predicate: any named activation?"
 483
 484 <SETG SPCS-X <OFFSET 13 NODE>>
 485
 486 ;"Predicate:  any specials bound?"
 487
 488 <SETG DST <OFFSET 14 NODE>>
 489
 490 ;"Destination spec for value of node."
 491
 492 <SETG CDST <OFFSET 15 NODE>>
 493
 494 ;"Current destination used."
 495
 496 <SETG ATAG <OFFSET 16 NODE>>
 497
 498 ;"Label for local againing."
 499
 500 <SETG RTAG <OFFSET 17 NODE>>
 501
 502 ;"Label for local Returning."
 503
 504 <SETG ASSUM <OFFSET 18 NODE>>
 505
 506 ;"Node type assumptions."
 507
 508 <SETG AGND <OFFSET 19 NODE>>
 509
 510 ;"Predicate:  Again possible?"
 511
 512 <SETG TOTARGS <OFFSET 20 NODE>>
 513
 514 ;"Total number of args (including optional)."
 515
 516 <SETG REQARGS <OFFSET 21 NODE>>
 517
 518 ;"Required arguemnts."
 519
 520 <SETG CLAUSES <OFFSET <1 ,KIDS> NODE>>
 521
 522 ;"For COND clauses."
 523
 524 <SETG NODE-SUBR <OFFSET <1 ,RSUBR-DECLS> NODE>>
 525
 526 ;"For many nodes, the SUBR (not its name)."
 527
 528 <SETG PREDIC <OFFSET <1 ,NODE-NAME> NODE>>
 529
 530 ;"For cond clause nodes, the predicate."
 531
 532 <SETG ACCUM-TYPE <OFFSET <1 ,DST> NODE>>
 533
 534 ;"Accumulated type from all returns etc."
 535
 536 <SETG DEAD-VARS <OFFSET <1 ,CDST> NODE>>
 537
 538 <SETG LIVE-VARS <OFFSET <1 ,TYPE-INFO> NODE>>
 539
 540 <SETG VSPCD <OFFSET <1 ,ATAG> NODE>>
 541
 542 <SETG INIT-DECL-TYPE <OFFSET <1 ,RTAG> NODE>>
 543
 544 "       Definitions associated with compiler symbol tables."
 545
 546 "Offsets for variable description blocks"
 547
 548 <NEWTYPE TEMP VECTOR '!<<PRIMTYPE VECTOR> ATOM FIX ANY <OR ATOM FALSE> ANY
 549                                           ANY>>
 550
 551 <NEWTYPE SYMTAB
 552          VECTOR
 553          '<<PRIMTYPE VECTOR> <PRIMTYPE VECTOR>
 554                   ATOM
 555                   <OR FALSE ATOM>
 556                   FIX
 557                   <OR ATOM FIX>
 558                   <OR FALSE ATOM>
 559                   <OR ATOM SEGMENT FORM>
 560                   ANY
 561                   ANY
 562                   ANY
 563                   <OR FALSE NODE>
 564                   <OR FALSE 'T>
 565                   FIX
 566                   <OR FALSE 'T>
 567                   <OR FALSE 'T>
 568                   LIST
 569                   ANY
 570                   ANY
 571                   ANY>>
 572
 573 <SETG NEXT-SYM <OFFSET 1 SYMTAB>>
 574
 575 ;"Pointer to next symbol table entry."
 576
 577 <SETG NAME-SYM <OFFSET 2 SYMTAB>>
 578
 579 ;"Name of variable."
 580
 581 <SETG SPEC-SYM <OFFSET 3 SYMTAB>>
 582
 583 ;"Predicate:  special?"
 584
 585 <SETG CODE-SYM <OFFSET 4 SYMTAB>>
 586
 587 ;"Code specifying whether AUX, OPTIONAL etc."
 588
 589 <SETG ARGNUM-SYM <OFFSET 5 SYMTAB>>
 590
 591 ;"If an argument, which one."
 592
 593 <SETG PURE-SYM <OFFSET 6 SYMTAB>>
 594
 595 ;"Predicate:  unchanged in function?"
 596
 597 <SETG DECL-SYM <OFFSET 7 SYMTAB>>
 598
 599 ;"Decl for this variable."
 600
 601 <SETG ADDR-SYM <OFFSET 8 SYMTAB>>
 602
 603 ;"Where do I live?"
 604
 605 <SETG INIT-SYM <OFFSET 9 SYMTAB>>
 606
 607 ;"Predicate:  initial value? if so what."
 608
 609 <SETG TEMP-NAME-SYM <OFFSET 10 SYMTAB>>
 610
 611 ;"ID of my frame."
 612
 613 <SETG RET-AGAIN-ONLY <OFFSET 11 SYMTAB>>
 614
 615 ;"Predicate:  used only in AGAIN/RETURN?"
 616
 617 <SETG ASS? <OFFSET 12 SYMTAB>>
 618
 619 ;"Predicate:  used in ASSIGNED?"
 620
 621 <SETG USAGE-SYM <OFFSET 13 SYMTAB>>
 622
 623 ;"Number of uses of this symbol."
 624
 625 '<SETG STORED <OFFSET 14 SYMTAB>>
 626
 627 ;"Predicate:  stored in slot?"
 628
 629 <SETG USED-AT-ALL <OFFSET 15 SYMTAB>>
 630
 631 ;"Predicate:  symbolused at all."
 632
 633 <SETG DEATH-LIST <OFFSET 16 SYMTAB>>
 634
 635 ;"List of info associated with life time."
 636
 637 <SETG CURRENT-TYPE <OFFSET 17 SYMTAB>>
 638
 639 ;"Current decl determined by analysis"
 640
 641 <SETG COMPOSIT-TYPE <OFFSET 18 SYMTAB>>
 642
 643 <SETG ARG-NAME-SYM <OFFSET 19 SYMTAB>>
 644
 645 "How a variable is used in a loop."
 646
 647 ;"Type as figured out by all uses of symbol."
 648
 649 <DEFINE NODE1 (TYP PAR RES-TYP NAME KID)
 650         <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID <>] NODE>>
 651
 652 "Create a function node with all its hair."
 653
 654 <DEFINE NODEF (TYP PAR RES-TYP NAME KID RSD BST HAT VTB TRG RQRG)
 655         <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID <> () <> .RSD .BST .VTB
 656                  <> <> <> () <> .RES-TYP () <> .TRG .RQRG] NODE>>
 657
 658 "Create a PROG/REPEAT node with nearly as much hair."
 659
 660 <DEFINE NODEPR (TYP PAR RES-TYP NAME KID VL BST HAT VTB)
 661         <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID <> () <> .VL .BST .VTB
 662                  <> <> <> () <> .RES-TYP () <>]
 663                 NODE>>
 664
 665 "Create a COND node."
 666
 667 <DEFINE NODECOND (TYP PAR RES-TYP NAME CLAU)
 668         <CHTYPE [.TYP .PAR .RES-TYP .NAME .CLAU <> () <>] NODE>>
 669
 670 "Create a node for a COND clause."
 671
 672 <DEFINE NODEB (TYP PAR RES-TYP PRED CLAU)
 673         <CHTYPE [.TYP .PAR .RES-TYP .PRED .CLAU <> () <>] NODE>>
 674
 675 "Create a node for a SUBR call etc."
 676
 677 <DEFINE NODEFM (TYP PAR RES-TYP NAME KID SUB)
 678         <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID <> () <> .SUB] NODE>>
 679 \f
 680
 681 <DEFINE ADDVAR (NAM SPEC CODE ARGNUM PURE DCL ADDR INIT)
 682         <SET VARTBL
 683              <CHTYPE [.VARTBL
 684                       .NAM
 685                       .SPEC
 686                       .CODE
 687                       .ARGNUM
 688                       .PURE
 689                       .DCL
 690                       .ADDR
 691                       .INIT
 692                       .NAM
 693                       <>
 694                       <>
 695                       0
 696                       T
 697                       <>
 698                       ()
 699                       <>
 700                       ANY
 701                       FOO!-IPASS1!-PASS1!-PACKAGE]
 702                      SYMTAB>>>
 703
 704 "Some specialized decl stuff."
 705
 706 <SETG LVARTBL
 707       <PROG ((VARTBL []))
 708             #DECL ((VARTBL) <SPECIAL ANY>)
 709             <ADDVAR OBLIST T -1 0 T <OR LIST OBLIST> <> <>>
 710             <ADDVAR OUTCHAN T -1 0 T CHANNEL <> <>>
 711             <ADDVAR INCHAN T -1 0 T CHANNEL <> <>>
 712             .VARTBL>>
 713
 714 <COND (<NOT ,MIM>
 715        <PUTPROP CHANNEL DECL '<CHANNEL FIX [11 ANY] [5 FIX]>>)>
 716
 717 <COND (,MIM <PUT-DECL STRING '<<PRIMTYPE STRING> [REST CHARACTER]>>)
 718       (ELSE <PUTPROP STRING DECL '<<PRIMTYPE STRING> [REST CHARACTER]>>)>
 719
 720 "Codes for the node types in the tree built by pass1 and modified by
 721 other passes."
 722
 723 "Give symbolic codes arbitrary increasing values."
 724
 725 <PROG ((N 1))
 726       <SETG CODVEC
 727             <MAPF ,VECTOR
 728                   <FUNCTION (ATM) <SETG .ATM .N> <SET N <+ .N 1>> .ATM>
 729                   '[FUNCTION-CODE
 730                     QUOTE-CODE
 731                     SEGMENT-CODE
 732                     FORM-CODE
 733                     PROG-CODE
 734                     SUBR-CODE
 735                     COND-CODE
 736                     BRANCH-CODE
 737                     RSUBR-CODE
 738                     LVAL-CODE
 739                     SET-CODE
 740                     OR-CODE
 741                     AND-CODE
 742                     RETURN-CODE
 743                     COPY-CODE
 744                     GO-CODE
 745                     AGAIN-CODE
 746                     ARITH-CODE
 747                     0-TST-CODE
 748                     NOT-CODE
 749                     1?-CODE
 750                     TEST-CODE
 751                     EQ-CODE
 752                     TY?-CODE
 753                     LNTH-CODE
 754                     MT-CODE
 755                     NTH-CODE
 756                     REST-CODE
 757                     PUT-CODE
 758                     PUTR-CODE
 759                     FLVAL-CODE
 760                     FSET-CODE
 761                     FGVAL-CODE
 762                     FSETG-CODE
 763                     MIN-MAX-CODE
 764                     STACKFORM-CODE
 765                     CHTYPE-CODE
 766                     ABS-CODE
 767                     FIX-CODE
 768                     FLOAT-CODE
 769                     MOD-CODE
 770                     ID-CODE
 771                     ASSIGNED?-CODE
 772                     ISTRUC-CODE
 773                     ISTRUC2-CODE
 774                     BITS-CODE
 775                     BITL-CODE
 776                     FGETBITS-CODE
 777                     FPUTBITS-CODE
 778                     MAP-CODE
 779                     MFCN-CODE
 780                     ISUBR-CODE
 781                     READ-EOF-CODE
 782                     READ-EOF2-CODE
 783                     EOF-CODE
 784                     GET-CODE
 785                     GET2-CODE
 786                     IPUT-CODE
 787                     IREMAS-CODE
 788                     IRSUBR-CODE
 789                     MARGS-CODE
 790                     MPSBR-CODE
 791                     MAPLEAVE-CODE
 792                     MAPRET-STOP-CODE
 793                     UNWIND-CODE
 794                     GVAL-CODE
 795                     SETG-CODE
 796                     SEG-CODE
 797                     LENGTH?-CODE
 798                     TAG-CODE
 799                     MFIRST-CODE
 800                     PRINT-CODE
 801                     MEMQ-CODE
 802                     FORM-F-CODE
 803                     INFO-CODE
 804                     OBLIST?-CODE
 805                     AS-NXT-CODE
 806                     AS-IT-IND-VAL-CODE
 807                     ALL-REST-CODE
 808                     CASE-CODE
 809                     SUBSTRUC-CODE
 810                     BACK-CODE
 811                     TOP-CODE
 812                     COPY-LIST-CODE
 813                     PUT-SAME-CODE
 814                     ROT-CODE
 815                     LSH-CODE
 816                     BIT-TEST-CODE
 817                     ADECL-CODE
 818                     CALL-CODE
 819                     MONAD-CODE
 820                     GASSIGNED?-CODE
 821                     APPLY-CODE
 822                     MULTI-RETURN-CODE
 823                     =?-STRING-CODE
 824                     TYPE-C-CODE
 825                     VALID-CODE
 826                     STACK-CODE
 827                     CHANNEL-OP-CODE
 828                     ATOM-PART-CODE
 829                     OFFSET-PART-CODE
 830                     PUT-GET-DECL-CODE
 831                     MULTI-SET-CODE
 832                     SPARE1-CODE
 833                     SPARE2-CODE
 834                     SPARE3-CODE
 835                     SPARE4-CODE]>>
 836       <SETG COMP-TYPES .N>>
 837
 838 <USE "NPRINT">
 839
 840 "Build a dispatch table based on node types."
 841
 842 <DEFINE DISPATCH (DEFAULT "TUPLE" PAIRS
 843                   "AUX" (TT <IVECTOR ,COMP-TYPES '.DEFAULT>))
 844         #DECL ((PAIRS) <<PRIMTYPE VECTOR> [REST <LIST FIX ANY>]>
 845                (TT) VECTOR)
 846         <REPEAT ((PAIR '(1 1))) #DECL ((PAIR) <LIST FIX ANY>)
 847                 <COND (<EMPTY? .PAIRS><RETURN .TT>)>
 848                 <PUT .TT <1 <SET PAIR <1 .PAIRS>>> <2 .PAIR>>
 849                 <SET PAIRS <REST .PAIRS>>>>
 850
 851 <SETG PREDV <IUVECTOR ,COMP-TYPES 0>>
 852
 853 <GDECL (PREDV) UVECTOR>
 854
 855 <MAPF <>
 856       <FUNCTION (N) <PUT ,PREDV .N 1>>
 857       [,0-TST-CODE
 858        ,1?-CODE
 859        ,NOT-CODE
 860        ,TEST-CODE
 861        ,EQ-CODE
 862        ,TY?-CODE
 863        ,MT-CODE
 864        ,ASSIGNED?-CODE
 865        ,MEMQ-CODE
 866        ,LENGTH?-CODE
 867        ,OBLIST?-CODE
 868        ,AS-NXT-CODE
 869        ,BIT-TEST-CODE
 870        ,GASSIGNED?-CODE
 871        ,VALID-CODE
 872        ,=?-STRING-CODE]>
 873
 874
 875 <MAPF <> <FUNCTION (N) <PUT ,PREDV .N -1>> [,OR-CODE ,AND-CODE ,COND-CODE]>
 876
 877 "Predicate:  does this type have special predicate code?"
 878
 879 " Assign codes to differen types of argument in argument list"
 880
 881 <PROG ((N 1))
 882       <MAPF <>
 883             <FUNCTION (TYP) <SETG .TYP .N> <MANIFEST .TYP> <SET N <+ .N 1>>>
 884             '(ARGL-ACT
 885               ARGL-IAUX
 886               ARGL-AUX
 887               ARGL-TUPLE
 888               ARGL-ARGS
 889               ARGL-QIOPT
 890               ARGL-IOPT
 891               ARGL-QOPT
 892               ARGL-OPT
 893               ARGL-CALL
 894               ARGL-BIND
 895               ARGL-QUOTE
 896               ARGL-ARG)>>
 897
 898 <COND (,MIM
 899        <PUT-DECL REP-STATE
 900                  '<LIST [5 <LIST [REST SYMTAB DATUM <OR FALSE ATOM>
 901                                   <OR ATOM FALSE>]>]>>)
 902       (ELSE
 903        <PUTPROP REP-STATE
 904                 DECL
 905                 '<LIST [5 <LIST [REST SYMTAB DATUM <OR FALSE ATOM>
 906                                  <OR ATOM FALSE>]>]>>)>
 907
 908 <COND (,MIM <PUT-DECL SYMBOL '<OR SYMTAB TEMP COMMON>>)
 909       (ELSE <PUTPROP SYMBOL DECL '<OR SYMTAB TEMP COMMON>>)>
 910
 911 <SETG DATTYP <OFFSET 1 DATUM>>
 912
 913 <SETG DATVAL <OFFSET 2 DATUM>>
 914
 915 <NEWTYPE DATUM
 916          LIST
 917          '<<PRIMTYPE LIST> <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>
 918                            <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>>>
 919
 920 <NEWTYPE OFFPTR LIST '<<PRIMTYPE LIST> FIX DATUM ATOM>>
 921
 922 <MANIFEST DATTYP DATVAL>
 923
 924 <MAPF <> ,MANIFEST ,CODVEC>
 925
 926 <MANIFEST USAGE-SYM
 927           TOT-MODES
 928           RESTS
 929           RMODES
 930           COMP-TYPES
 931           GDECL-SYM
 932           GNAME-SYM
 933           GNEXT-SYM
 934           INIT-SYM
 935           ADDR-SYM
 936           TOTARGS
 937           REQARGS
 938           DECL-SYM
 939           PURE-SYM
 940           ARGNUM-SYM
 941           CODE-SYM
 942           SPEC-SYM
 943           NAME-SYM
 944           TEMP-NAME-SYM
 945           ARG-NAME-SYM
 946           NEXT-SYM
 947           PREDIC
 948           NODE-SUBR
 949           CLAUSES
 950           ACTIVATED
 951           SYMTAB
 952           BINDING-STRUCTURE
 953           RSUBR-DECLS
 954           SEGS
 955           KIDS
 956           NODE-NAME
 957           RESULT-TYPE
 958           PARENT
 959           NODE-TYPE
 960           SIDE-EFFECTS
 961           RET-AGAIN-ONLY
 962           ASS?
 963           DST
 964           CDST
 965           ACCUM-TYPE
 966           INIT-DECL-TYPE
 967           VSPCD
 968           AGND
 969           ASSUM
 970           RTAG
 971           ATAG
 972           SPCS-X
 973           USED-AT-ALL
 974           CURRENT-TYPE
 975           DEATH-LIST
 976           COMPOSIT-TYPE
 977           TYPE-INFO
 978           LIVE-VARS
 979           DEAD-VARS>
 980
 981 <NEWTYPE COMMON
 982          VECTOR
 983          '<<PRIMTYPE VECTOR> ATOM <OR COMMON SYMTAB> FIX ANY <PRIMTYPE LIST>>>
 984
 985 <SETG COMMON-TYPE <OFFSET 1 COMMON>>
 986
 987 "TYPE OF COMMON (ATOM)"
 988
 989 <SETG COMMON-SYMT <OFFSET 2 COMMON>>
 990
 991 "POINTER TO OR COMMON SYMTAB"
 992
 993 <SETG COMMON-ITEM <OFFSET 3 COMMON>>
 994
 995 "3RD ARGUMENT TO NTH,REST,PUT ETC."
 996
 997 <SETG COMMON-PRIMTYPE <OFFSET 4 COMMON>>
 998
 999 "PRIMTYPE OF OBJECT IN COMMON"
1000
1001 <SETG COMMON-DATUM <OFFSET 5 COMMON>>
1002
1003 "DATUM FOR THIS COMMON"
1004
1005 <MANIFEST COMMON-TYPE COMMON-SYMTAB COMMON-ITEM COMMON-PRIMTYPE COMMON-DATUM>
1006
1007 <NEWTYPE TRANS
1008          VECTOR
1009          '<<PRIMTYPE VECTOR> NODE <UVECTOR [7 FIX]> <UVECTOR [7 FIX]>>>
1010
1011 <NEWTYPE MIM-SPECIAL ATOM>
1012
1013 <SETG TEMP-NAME <OFFSET 1 TEMP>>
1014
1015 <SETG TEMP-REFS <OFFSET 2 TEMP>>
1016
1017 <SETG TEMP-FRAME <OFFSET 3 TEMP>>
1018
1019 <SETG TEMP-ALLOC <OFFSET 4 TEMP>>
1020
1021 <SETG TEMP-NO-RECYCLE <OFFSET 5 TEMP>>
1022
1023 <SETG TEMP-TYPE <OFFSET 6 TEMP>>
1024
1025 <MANIFEST TEMP-NAME TEMP-REFS TEMP-FRAME TEMP-ALLOC TEMP-NO-RECYCLE
1026           TEMP-TYPE>
1027
1028 <COND (<N==? <TYPEPRIM FIX> FIX> <FLOAD "PS:<COMPIL>POPWR2.FBIN">)>
1029
1030 <SETG BINDING-LENGTH 9>
1031
1032 <MANIFEST BINDING-LENGTH>
1033
1034 <ENDPACKAGE>