<mdl.comp>/compde.mud.32

   1
   2 <PACKAGE "COMPDEC">
   3
   4 <ENTRY FCNS
   5        DEATH
   6        TMPS
   7        IDT
   8        STYPES
   9        PLUSINF
  10        MINUSINF
  11        IPUT
  12        TEMPV
  13        DEBUGSW
  14        INSTRUCTION
  15        INTH
  16        FCN
  17        IRSUBR
  18        STACK
  19        SNODES
  20        PSTACK
  21        ANY-AC
  22        DUMMY-MAPF
  23        INCONSISTENCY
  24        SEGS
  25        SPEC
  26        CODVEC
  27        QUOTE-CODE
  28        RETURN-CODE
  29        IPUT-CODE
  30        SEG-CODE
  31        PREDV
  32        ACAGE
  33        NUMACS
  34        SYM-SLOT
  35        SAVED-STK
  36        PARENT
  37        TYPE-INFO
  38        PROG-VARS
  39        CURRENT-TYPE
  40        NODE1
  41        PUTR-CODE
  42        ISUBR-CODE
  43        EOF-CODE
  44        IREMAS-CODE
  45        GVAL-CODE
  46        SPARE4-CODE
  47        ACRESIDUE
  48        AC-F
  49        LOOPVARS-LENGTH
  50        ADDVAR
  51        FSET-CODE
  52        OFFPTR
  53        CSYMT-SLOT
  54        CPOTLV-SLOT
  55        PROG-CODE
  56        COMP-TYPES
  57        INACS-SLOT
  58        SAVED-STACK-STATE
  59        NODE-NAME
  60        AGND
  61        REQARGS
  62        LOOP-VARS
  63        DECL-SYM
  64        PUT-CODE
  65        FLVAL-CODE
  66        SETG-CODE
  67        BACK-CODE
  68        PUT-SAME-CODE
  69        AC-E
  70        SS-POTENT-SLOT
  71        NUM-SYM-SLOT
  72        RSUBR-DECLS
  73        NODEF
  74        AND-CODE
  75        MT-CODE
  76        BITS-CODE
  77        PUTBITS-CODE
  78        COPY-LIST-CODE
  79        SPARE1-CODE
  80        ACLINK
  81        LINKED
  82        SS-SYM-SLOT
  83        ATAG
  84        ASSUM
  85        RETURN-STATES
  86        PURE-SYM
  87        NUM-SYM
  88        KID
  89        GNAME-SYM
  90        CHTYPE-CODE
  91        SAVED-NUM-SYM-SLOT
  92        NODE
  93        SYMTAB
  94        INACS
  95        USAGE-SYM
  96        GDECL-SYM
  97        MAP-CODE
  98        MARGS-CODE
  99        DATVAL
 100        ALLACS
 101        AC-D
 102        SAVED-AC-STATE
 103        NODE-SUBR
 104        LIVE-VARS
 105        SPEC-SYM
 106        AS-NXT-CODE
 107        SUBSTRUC-CODE
 108        BIT-TEST-CODE
 109        SPARE3-CODE
 110        TMPAC
 111        NO-RESIDUE
 112        NOT-PREF
 113        P-N-STO-RES
 114        P-N-NO-STO-RES
 115        FRMNO
 116        NOT-CODE
 117        TEST-CODE
 118        MIN-MAX-CODE
 119        READ-EOF2-CODE
 120        TAG-CODE
 121        LENGTH-CONTROL-STATE
 122        SAVED-NTSLOTS
 123        KIDS
 124        PREDIC
 125        MAKE:TAG
 126        NODEPR
 127        NODEFM
 128        GNEXT-SYM
 129        FIX-CODE
 130        MFCN-CODE
 131        IRSUBR-CODE
 132        CASE-CODE
 133        SCL
 134        ACSYM
 135        ACNUM
 136        AC-C
 137        P-N-CLEAN
 138        CINACS-SLOT
 139        NODE-TYPE
 140        USLOTS
 141        DEAD-VARS
 142        DEATH-LIST
 143        COMPOSIT-TYPE
 144        PROG-AC
 145        PRED
 146        COPY-CODE
 147        LENGTH?-CODE
 148        AC
 149        LINACS-SLOT
 150        TMPLS
 151        INIT-DECL-TYPE
 152        NODECOND
 153        FUNCTION-CODE
 154        AGAIN-CODE
 155        0-TST-CODE
 156        GETBITS-CODE
 157        MAPRET-STOP-CODE
 158        LSH-CODE
 159        SYMBOL
 160        SAVED-STATE
 161        ACO
 162        LENGTH-PROG-VARS
 163        CSTORED-SLOT
 164        NODEB
 165        SET-CODE
 166        ROT-CODE
 167        AC-B
 168        REGS
 169        PROG-SLOT
 170        SAVED-BSTB
 171        BINDING-STRUCTURE
 172        CDST
 173        VSPCD
 174        NAME-SYM
 175        INIT-SYM
 176        EQ-CODE
 177        ALL-REST-CODE
 178        DISPATCH
 179        TMPNO
 180        AC1SYM
 181        REACS
 182        LSYM-SLOT
 183        DST
 184        RTAG
 185        ACCUM-TYPE
 186        DATUM
 187        ARGNUM-SYM
 188        ADDR-SYM
 189        STORED
 190        USED-AT-ALL
 191        POTLV
 192        NAME
 193        ARGNUM
 194        FGVAL-CODE
 195        ID-CODE
 196        FORM-F-CODE
 197        INFO-CODE
 198        TEMP
 199        STORED-RESIDUE
 200        SAVED-POTLV-SLOT
 201        SAVED-CODE:PTR
 202        CLAUSES
 203        TRG
 204        VARTBL
 205        LVARTBL
 206        SUBR-CODE
 207        LNTH-CODE
 208        STACKFORM-CODE
 209        ASSIGNED?-CODE
 210        GET2-CODE
 211        AS-IT-IND-VAL-CODE
 212        COMMON
 213        DATTYP
 214        AC-A
 215        ACS
 216        RET-AGAIN-ONLY
 217        SEGMENT-CODE
 218        FSETG-CODE
 219        ISTRUC-CODE
 220        MFIRST-CODE
 221        ACPREF
 222        SS-STORED-SLOT
 223        STORED-SLOT
 224        STK-B
 225        AGAIN-STATES
 226        CODE-SYM
 227        BST
 228        RSUBR-CODE
 229        1?-CODE
 230        REST-CODE
 231        ABS-CODE
 232        MPSBR-CODE
 233        UNWIND-CODE
 234        PRINT-CODE
 235        OBLIST?-CODE
 236        ADDRSYM
 237        AC-H
 238        LAST-AC-1
 239        NOT-STORED-RESIDUE
 240        P-N-LINKED
 241        SAVED-RET-FLAG
 242        SAVED-FRMS
 243        STACKS
 244        ASS?
 245        BRANCH-CODE
 246        LVAL-CODE
 247        OR-CODE
 248        ISTRUC2-CODE
 249        READ-EOF-CODE
 250        MAPLEAVE-CODE
 251        MEMQ-CODE
 252        REP-STATE
 253        SS-DAT-SLOT
 254        SAVED-PROG-AC-SLOT
 255        LENGTH-CSTATE
 256        RESULT-TYPE
 257        SIDE-EFFECTS
 258        SSLOTS
 259        PRE-ALLOC
 260        NEXT-SYM
 261        FORM-CODE
 262        TY?-CODE
 263        FLOAT-CODE
 264        GET-CODE
 265        SPECS-START
 266        BTP-B
 267        SPCS-X
 268        RES-TYP
 269        GO-CODE
 270        BITL-CODE
 271        TOP-CODE
 272        SPARE2-CODE
 273        AC-G
 274        LAST-AC
 275        ATIME
 276        ACTIVATED
 277        TOTARGS
 278        VTB
 279        RQRG
 280        COND-CODE
 281        ARITH-CODE
 282        NTH-CODE
 283        MOD-CODE
 284        ACPROT
 285        IND
 286        ALL
 287        NOTE
 288        WARNING
 289        PRIM-CODE
 290        DONT-CARE
 291        FLUSHED
 292        NO-RETURN
 293        NO-DATUM
 294        MESSAGE
 295        GROUP-NAME
 296        FUZZ
 297        COMMON-TYPE
 298        COMMON-SYMTAB
 299        COMMON-ITEM
 300        COMMON-PRIMTYPE
 301        COMMON-DATUM
 302        COMMON-SYMT
 303        TRANSFORM
 304        TRANS
 305        N0?
 306        POPWR2
 307        DEALLOCATE
 308        TOKEN
 309        ERRS
 310        WARNS
 311        NOTES
 312        DEBUG-COMPILE
 313        REASONABLE
 314        CAREFUL
 315        PRECOMPILED
 316        HAIRY-ANALYSIS
 317        SRC-FLG
 318        BIN-FLG
 319        GLOSP
 320        ANALY-OK
 321        VERBOSE
 322        COMPILER
 323        IND
 324        ADDRESS:C
 325        FUNNY-STACK>
 326
 327
 328 <SETG PLUSINF <CHTYPE <MIN> FIX>>
 329
 330 <SETG MINUSINF <CHTYPE <MAX> FIX>>
 331
 332 "Type specification for NODE."
 333
 334 <NEWTYPE NODE
 335          VECTOR
 336          '<VECTOR FIX
 337                   ANY
 338                   ANY
 339                   ANY
 340                   <LIST [REST NODE]>
 341                   FIX
 342                   <OR FALSE ATOM>
 343                   [REST
 344                    LIST
 345                    ANY
 346                    ANY
 347                    LIST
 348                    FIX
 349                    SYMTAB
 350                    FIX
 351                    FIX
 352                    <OR FALSE ATOM>
 353                    ATOM
 354                    ANY
 355                    LIST
 356                    LIST
 357                    ANY
 358                    ANY
 359                    ANY
 360                    ANY
 361                    ANY
 362                    ANY
 363                    ANY
 364                    <PRIMTYPE LIST>
 365                    FIX
 366                    FIX
 367                    LIST
 368                    LIST
 369                    LIST
 370                    LIST
 371                    LIST]>>
 372
 373 "Offsets into pass 1 structure entities and functions to create same."
 374
 375 <SETG NODE-TYPE <OFFSET 1 NODE>>
 376
 377 ;"Code specifying the node type."
 378
 379 <SETG PARENT <OFFSET 2 NODE>>
 380
 381 ;"Pointer to parent node."
 382
 383 <SETG RESULT-TYPE <OFFSET 3 NODE>>
 384
 385 ;"Type expression for result returned by code
 386                                    generated by this node."
 387
 388 <SETG NODE-NAME <OFFSET 4 NODE>>
 389
 390 ;"Usually name of SUBR associated with  this node."
 391
 392 <SETG KIDS <OFFSET 5 NODE>>
 393
 394 ;"List of sub-nodes for this node."
 395
 396 <SETG STACKS <OFFSET 6 NODE>>
 397
 398 ;"Amount of stack needed by this node."
 399
 400 <SETG SEGS <OFFSET 7 NODE>>
 401
 402 ;"Predicate:  any segments among kids?"
 403
 404 <SETG TYPE-INFO <OFFSET 8 NODE>>
 405
 406 ;"Points to transient type info for this node."
 407
 408 <SETG SIDE-EFFECTS <OFFSET 9 NODE>>
 409
 410 ;"General info about side effects (format not yet firm.)"
 411
 412 <SETG RSUBR-DECLS <OFFSET 10 NODE>>
 413
 414 ;"Function only: final rsubr decls."
 415
 416 <SETG BINDING-STRUCTURE <OFFSET 11 NODE>>
 417
 418 ;"Partially compiled arg list."
 419
 420 <SETG SPECS-START <OFFSET 12 NODE>>
 421
 422 ;"Offset to 1st special."
 423
 424 <SETG SYMTAB <OFFSET 13 NODE>>
 425
 426 ;"Pointer to local symbol table."
 427
 428 <SETG SSLOTS <OFFSET 14 NODE>>
 429
 430 ;"Number of specials."
 431
 432 <SETG USLOTS <OFFSET 15 NODE>>
 433
 434 ;"Number of unspecials."
 435
 436 <SETG ACTIVATED <OFFSET 16 NODE>>
 437
 438 ;"Predicate: any named activation?"
 439
 440 <SETG TMPLS <OFFSET 17 NODE>>
 441
 442 ;"Offset to unamed temps."
 443
 444 <SETG PRE-ALLOC <OFFSET 18 NODE>>
 445
 446 ;"Variable slots allocated in advance."
 447
 448 <SETG STK-B <OFFSET 19 NODE>>
 449
 450 ;"Base of stack at entry."
 451
 452 <SETG BTP-B <OFFSET 20 NODE>>
 453
 454 ;"Base of stack after bindings."
 455
 456 <SETG SPCS-X <OFFSET 21 NODE>>
 457
 458 ;"Predicate:  any specials bound?"
 459
 460 <SETG DST <OFFSET 22 NODE>>
 461
 462 ;"Destination spec for value of node."
 463
 464 <SETG CDST <OFFSET 23 NODE>>
 465
 466 ;"Current destination used."
 467
 468 <SETG ATAG <OFFSET 24 NODE>>
 469
 470 ;"Label for local againing."
 471
 472 <SETG RTAG <OFFSET 25 NODE>>
 473
 474 ;"Label for local Returning."
 475
 476 <SETG ASSUM <OFFSET 26 NODE>>
 477
 478 ;"Node type assumptions."
 479
 480 <SETG AGND <OFFSET 27 NODE>>
 481
 482 ;"Predicate:  Again possible?"
 483
 484 <SETG ACS <OFFSET 28 NODE>>
 485
 486 ;"Predicate:  AC call possible? (if not false
 487                                    ac structure)"
 488
 489 <SETG TOTARGS <OFFSET 29 NODE>>
 490
 491 ;"Total number of args (including optional)."
 492
 493 <SETG REQARGS <OFFSET 30 NODE>>
 494
 495 ;"Required arguemnts."
 496
 497 <SETG LOOP-VARS <OFFSET 31 NODE>>
 498
 499 "Variables kept in acs thru loop."
 500
 501 <SETG AGAIN-STATES <OFFSET 32 NODE>>
 502
 503 "States at agains"
 504
 505 <SETG RETURN-STATES <OFFSET 33 NODE>>
 506
 507 "States at repeats."
 508
 509 <SETG PROG-VARS <OFFSET 34 NODE>>
 510
 511 "Vars handled in this prog/repeat."
 512
 513 ;"Information used for merging states with prog-nodes"
 514
 515 <SETG CLAUSES <OFFSET <INDEX ,KIDS> NODE>>
 516
 517 ;"For COND clauses."
 518
 519 <SETG NODE-SUBR <OFFSET <INDEX ,RSUBR-DECLS> NODE>>
 520
 521 ;"For many nodes, the SUBR (not its name)."
 522
 523 <SETG PREDIC <OFFSET <INDEX ,NODE-NAME> NODE>>
 524
 525 ;"For cond clause nodes, the predicate."
 526
 527 <SETG ACCUM-TYPE <OFFSET <INDEX ,DST> NODE>>
 528
 529 ;"Accumulated type from all returns etc."
 530
 531 <SETG DEAD-VARS <OFFSET <INDEX ,CDST> NODE>>
 532
 533 <SETG LIVE-VARS <OFFSET <INDEX ,TYPE-INFO> NODE>>
 534
 535 <SETG VSPCD <OFFSET <INDEX ,ATAG> NODE>>
 536
 537 <SETG INIT-DECL-TYPE <OFFSET <INDEX ,RTAG> NODE>>
 538
 539 "       Definitions associated with compiler symbol tables."
 540
 541 "Offsets for variable description blocks"
 542
 543 <NEWTYPE SYMTAB
 544          VECTOR
 545          '<VECTOR <PRIMTYPE VECTOR>
 546                   ATOM
 547                   <OR FALSE ATOM>
 548                   FIX
 549                   <OR ATOM FIX>
 550                   <OR FALSE ATOM>
 551                   LIST
 552                   ANY
 553                   ANY
 554                   FIX
 555                   <OR FALSE NODE>
 556                   <OR FALSE 'T>
 557                   <OR FALSE DATUM LIST>
 558                   <OR FALSE 'T>
 559                   <OR FALSE 'T>
 560                   LIST
 561                   ANY
 562                   ANY
 563                   <OR FALSE FIX>>>
 564
 565 <SETG NEXT-SYM <OFFSET 1 SYMTAB>>
 566
 567 ;"Pointer to next symbol table entry."
 568
 569 <SETG NAME-SYM <OFFSET 2 SYMTAB>>
 570
 571 ;"Name of variable."
 572
 573 <SETG SPEC-SYM <OFFSET 3 SYMTAB>>
 574
 575 ;"Predicate:  special?"
 576
 577 <SETG CODE-SYM <OFFSET 4 SYMTAB>>
 578
 579 ;"Code specifying whether AUX, OPTIONAL etc."
 580
 581 <SETG ARGNUM-SYM <OFFSET 5 SYMTAB>>
 582
 583 ;"If an argument, which one."
 584
 585 <SETG PURE-SYM <OFFSET 6 SYMTAB>>
 586
 587 ;"Predicate:  unchanged in function?"
 588
 589 <SETG DECL-SYM <OFFSET 7 SYMTAB>>
 590
 591 ;"Decl for this variable."
 592
 593 <SETG ADDR-SYM <OFFSET 8 SYMTAB>>
 594
 595 ;"Where do I live?"
 596
 597 <SETG INIT-SYM <OFFSET 9 SYMTAB>>
 598
 599 ;"Predicate:  initial value? if so what."
 600
 601 <SETG FRMNO <OFFSET 10 SYMTAB>>
 602
 603 ;"ID of my frame."
 604
 605 <SETG RET-AGAIN-ONLY <OFFSET 11 SYMTAB>>
 606
 607 ;"Predicate:  used only in AGAIN/RETURN?"
 608
 609 <SETG ASS? <OFFSET 12 SYMTAB>>
 610
 611 ;"Predicate:  used in ASSIGNED?"
 612
 613 <SETG INACS <OFFSET 13 SYMTAB>>
 614
 615 ;"Predicate:  currently in some AC?"
 616
 617 <SETG STORED <OFFSET 14 SYMTAB>>
 618
 619 ;"Predicate:  stored in slot?"
 620
 621 <SETG USED-AT-ALL <OFFSET 15 SYMTAB>>
 622
 623 ;"Predicate:  symbolused at all."
 624
 625 <SETG DEATH-LIST <OFFSET 16 SYMTAB>>
 626
 627 ;"List of info associated with life time."
 628
 629 <SETG CURRENT-TYPE <OFFSET 17 SYMTAB>>
 630
 631 ;"Current decl determined by analysis"
 632
 633 <SETG COMPOSIT-TYPE <OFFSET 18 SYMTAB>>
 634
 635 <SETG USAGE-SYM <OFFSET 19 SYMTAB>>
 636
 637 "How a variable is used in a loop."
 638
 639 <SETG PROG-AC <OFFSET <INDEX ,CURRENT-TYPE> SYMTAB>>
 640
 641 <SETG NUM-SYM <OFFSET <INDEX ,COMPOSIT-TYPE> SYMTAB>>
 642
 643 <SETG POTLV <OFFSET <INDEX ,USED-AT-ALL> SYMTAB>>
 644
 645
 646 "Slot used to store information for variables in loops."
 647
 648 ;"Type as figured out by all uses of symbol."
 649
 650 <DEFINE NODE1 (TYP PAR RES-TYP NAME KID)
 651         <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <>] NODE>>
 652
 653 "Create a function node with all its hair."
 654
 655 <DEFINE NODEF (TYP PAR RES-TYP NAME KID RSD BST HAT VTB ACS? TRG RQRG)
 656         <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <> () <> .RSD .BST 0 .VTB 0
 657                  0 <> <MAKE:TAG "FRM"> <> () () <> <> <> <> .RES-TYP <> <>
 658                  .ACS? .TRG .RQRG] NODE>>
 659
 660 "Create a PROG/REPEAT node with nearly as much hair."
 661
 662 <DEFINE NODEPR (TYP PAR RES-TYP NAME KID VL BST HAT VTB)
 663         <CHTYPE [.TYP
 664                  .PAR
 665                  .RES-TYP
 666                  .NAME
 667                  .KID
 668                  0
 669                  <>
 670                  ()
 671                  <>
 672                  .VL
 673                  .BST
 674                  0
 675                  .VTB
 676                  0
 677                  0
 678                  <>
 679                  <MAKE:TAG "FRM">
 680                  <>
 681                  ()
 682                  ()
 683                  <>
 684                  <>
 685                  <>
 686                  <>
 687                  .RES-TYP
 688                  <>
 689                  <>
 690                  <>
 691                  0
 692                  0
 693                  ()
 694                  ()
 695                  ()
 696                  ()]
 697                 NODE>>
 698
 699 "Create a COND node."
 700
 701 <DEFINE NODECOND (TYP PAR RES-TYP NAME CLAU)
 702         <CHTYPE [.TYP .PAR .RES-TYP .NAME .CLAU 0 <> () <>] NODE>>
 703
 704 "Create a node for a COND clause."
 705
 706 <DEFINE NODEB (TYP PAR RES-TYP PRED CLAU)
 707         <CHTYPE [.TYP .PAR .RES-TYP .PRED .CLAU 0 <> () <>] NODE>>
 708
 709 "Create a node for a SUBR call etc."
 710
 711 <DEFINE NODEFM (TYP PAR RES-TYP NAME KID SUB)
 712         <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID 0 <> () <> .SUB] NODE>>
 713 \f
 714
 715 <DEFINE ADDVAR (NAM SPEC CODE ARGNUM PURE DCL ADDR INIT)
 716         <SET VARTBL <CHTYPE [.VARTBL .NAM .SPEC .CODE .ARGNUM .PURE .DCL .ADDR .INIT 0 <>
 717                              <> <> T <> () <> ANY 0] SYMTAB>>>
 718
 719
 720 "Some specialized decl stuff."
 721
 722 <SETG LVARTBL
 723       <PROG ((VARTBL []))
 724             #DECL ((VARTBL) <SPECIAL ANY>)
 725             <ADDVAR OBLIST T -1 0 T '(<OR LIST OBLIST>) <> <>>
 726             <ADDVAR OUTCHAN T -1 0 T '(CHANNEL) <> <>>
 727             <ADDVAR INCHAN T -1 0 T '(CHANNEL) <> <>>
 728             .VARTBL>>
 729
 730 <PUT CHANNEL DECL '<CHANNEL FIX [11 ANY] [5 FIX]>>
 731
 732 <PUT STRING DECL '<STRING [REST CHARACTER]>>
 733
 734 <PUT OBLIST DECL '<UVECTOR [REST <LIST [REST <OR ATOM LINK>]>]>>
 735
 736 "Codes for the node types in the tree built by pass1 and modified by
 737 other passes."
 738
 739 "Give symbolic codes arbitrary increasing values."
 740
 741 <PROG ((N 1))
 742       <SETG CODVEC
 743             <MAPF ,UVECTOR
 744                   <FUNCTION (ATM) <SETG .ATM .N> <SET N <+ .N 1>> .ATM>
 745                   ![FUNCTION-CODE
 746                     QUOTE-CODE
 747                     SEGMENT-CODE
 748                     FORM-CODE
 749                     PROG-CODE
 750                     SUBR-CODE
 751                     COND-CODE
 752                     BRANCH-CODE
 753                     RSUBR-CODE
 754                     LVAL-CODE
 755                     SET-CODE
 756                     OR-CODE
 757                     AND-CODE
 758                     RETURN-CODE
 759                     COPY-CODE
 760                     GO-CODE
 761                     AGAIN-CODE
 762                     ARITH-CODE
 763                     0-TST-CODE
 764                     NOT-CODE
 765                     1?-CODE
 766                     TEST-CODE
 767                     EQ-CODE
 768                     TY?-CODE
 769                     LNTH-CODE
 770                     MT-CODE
 771                     NTH-CODE
 772                     REST-CODE
 773                     PUT-CODE
 774                     PUTR-CODE
 775                     FLVAL-CODE
 776                     FSET-CODE
 777                     FGVAL-CODE
 778                     FSETG-CODE
 779                     MIN-MAX-CODE
 780                     STACKFORM-CODE
 781                     CHTYPE-CODE
 782                     ABS-CODE
 783                     FIX-CODE
 784                     FLOAT-CODE
 785                     MOD-CODE
 786                     ID-CODE
 787                     ASSIGNED?-CODE
 788                     ISTRUC-CODE
 789                     ISTRUC2-CODE
 790                     BITS-CODE
 791                     BITL-CODE
 792                     GETBITS-CODE
 793                     PUTBITS-CODE
 794                     MAP-CODE
 795                     MFCN-CODE
 796                     ISUBR-CODE
 797                     READ-EOF-CODE
 798                     READ-EOF2-CODE
 799                     EOF-CODE
 800                     GET-CODE
 801                     GET2-CODE
 802                     IPUT-CODE
 803                     IREMAS-CODE
 804                     IRSUBR-CODE
 805                     MARGS-CODE
 806                     MPSBR-CODE
 807                     MAPLEAVE-CODE
 808                     MAPRET-STOP-CODE
 809                     UNWIND-CODE
 810                     GVAL-CODE
 811                     SETG-CODE
 812                     SEG-CODE
 813                     LENGTH?-CODE
 814                     TAG-CODE
 815                     MFIRST-CODE
 816                     PRINT-CODE
 817                     MEMQ-CODE
 818                     FORM-F-CODE
 819                     INFO-CODE
 820                     OBLIST?-CODE
 821                     AS-NXT-CODE
 822                     AS-IT-IND-VAL-CODE
 823                     ALL-REST-CODE
 824                     CASE-CODE
 825                     SUBSTRUC-CODE
 826                     BACK-CODE
 827                     TOP-CODE
 828                     COPY-LIST-CODE
 829                     PUT-SAME-CODE
 830                     ROT-CODE
 831                     LSH-CODE
 832                     BIT-TEST-CODE
 833                     SPARE1-CODE
 834                     SPARE2-CODE
 835                     SPARE3-CODE
 836                     SPARE4-CODE!]>>
 837       <SETG COMP-TYPES .N>>
 838
 839
 840 <USE "NPRINT">
 841
 842 "Build a dispatch table based on node types."
 843
 844 <DEFINE DISPATCH (DEFAULT "TUPLE" PAIRS
 845                   "AUX" (TT <IVECTOR ,COMP-TYPES '.DEFAULT>))
 846         #DECL ((PAIRS) <TUPLE [REST <LIST FIX ANY>]>
 847                (TT) VECTOR)
 848         <REPEAT ((PAIR '(1 1))) #DECL ((PAIR) <LIST FIX ANY>)
 849                 <COND (<EMPTY? .PAIRS><RETURN .TT>)>
 850                 <PUT .TT <1 <SET PAIR <1 .PAIRS>>> <2 .PAIR>>
 851                 <SET PAIRS <REST .PAIRS>>>>
 852
 853 <SETG PREDV <IUVECTOR ,COMP-TYPES 0>>
 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         ,OR-CODE
 865         ,AND-CODE
 866         ,ASSIGNED?-CODE
 867         ,ISUBR-CODE
 868         ,NTH-CODE
 869         ,MEMQ-CODE
 870         ,LENGTH?-CODE
 871         ,OBLIST?-CODE
 872         ,AS-NXT-CODE
 873         ,COND-CODE
 874         ,BIT-TEST-CODE!]>
 875
 876 "Predicate:  does this type have special predicate code?"
 877
 878 <PUT REP-STATE
 879      DECL
 880      '<LIST [5 <LIST [REST SYMTAB DATUM <OR FALSE ATOM> <OR ATOM FALSE>]>]>>
 881
 882 <PUT SYMBOL DECL '<OR SYMTAB TEMP COMMON>>
 883
 884 <NEWTYPE TEMP VECTOR '<VECTOR SCL <OR FALSE DATUM>>>
 885
 886 <NEWTYPE SAVED-STATE
 887          LIST
 888          '<LIST [REST
 889                  <LIST AC
 890                        <OR FALSE <LIST [REST SYMBOL]>>
 891                        [REST <LIST SYMBOL [3 ANY]>]>]>>
 892
 893 <SETG TMPNO <OFFSET 1 TEMP>>
 894
 895 <SETG TMPAC <OFFSET 2 TEMP>>
 896
 897 <SETG DATTYP <OFFSET 1 DATUM>>
 898
 899 <SETG DATVAL <OFFSET 2 DATUM>>
 900
 901 <SETG ADDRSYM <OFFSET 1 AC>>
 902
 903 <SETG ACSYM <OFFSET 2 AC>>
 904
 905 <SETG ACLINK <OFFSET 3 AC>>
 906
 907 <SETG ACAGE <OFFSET 4 AC>>
 908
 909 <SETG ACNUM <OFFSET 5 AC>>
 910
 911 <SETG ACPROT <OFFSET 6 AC>>
 912
 913 <SETG AC1SYM <OFFSET 7 AC>>
 914
 915 <SETG ACRESIDUE <OFFSET 8 AC>>
 916
 917 <SETG ACPREF <OFFSET 9 AC>>
 918
 919 <NEWTYPE AC
 920          VECTOR
 921          '<<PRIMTYPE VECTOR> <PRIMTYPE WORD>
 922                              <PRIMTYPE WORD>
 923                              <OR <LIST [REST DATUM]> FALSE>
 924                              FIX
 925                              FIX
 926                              <OR FALSE ATOM>
 927                              <PRIMTYPE WORD>
 928                              <OR FALSE LIST>
 929                              <OR FALSE ATOM>>>
 930
 931 <NEWTYPE DATUM
 932          LIST
 933          '<<PRIMTYPE LIST> <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>
 934                            <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>>>
 935
 936 <NEWTYPE OFFPTR LIST '<<PRIMTYPE LIST> FIX DATUM ATOM>>
 937
 938 <NEWTYPE TEMPV LIST>
 939
 940 <NEWTYPE IRSUBR LIST>
 941
 942 "A TOKEN GIVES INFORMATION TO CUP"
 943
 944 <NEWTYPE TOKEN VECTOR '<<PRIMTYPE VECTOR> FIX>>
 945
 946 <NEWTYPE ADDRESS:PAIR LIST>
 947
 948 <NEWTYPE ADDRESS:C LIST>
 949
 950 <SETG ALLACS
 951       <MAPF ,UVECTOR
 952             <FUNCTION (N1 N2 N N+1 NAME "AUX"  THISAC)
 953                     <SETG .NAME <SET THISAC <CHTYPE [.N1 .N2 <> 0 .N <> .N+1 <> <>] AC>>>
 954                     <EVAL <FORM GDECL (.NAME) AC>> .THISAC>
 955             ![`A `B `C `D `E `F `TVP `SP!]
 956             ![`A* `B* `C* `D* `E* `F* `TVP* `SP*!]
 957             ![1 2 3 4 5 6 7 8!]
 958             ![`B* `C* `D* `E* `F* `TVP* `SP* `AB*!]
 959             ![AC-A AC-B AC-C AC-D AC-E AC-F AC-G AC-H!]>>
 960
 961 <SETG NUMACS <LENGTH ,ALLACS>>
 962
 963 <SETG LAST-AC ,AC-H>
 964
 965 <SETG LAST-AC-1 ,AC-G>
 966
 967 <DEFINE REACS ()
 968         <MAPF <>
 969               <FUNCTION (AC)
 970                       #DECL ((AC) AC)
 971                       <PUT .AC ,ACLINK <>>
 972                       <PUT .AC ,ACPROT <>>
 973                       <PUT .AC ,ACAGE 0>
 974                       <PUT .AC ,ACRESIDUE <>>
 975                       <PUT .AC ,ACPREF <>>>
 976               ,ALLACS>
 977         <SETG REGS 8>
 978         <SETG ATIME 0>>
 979
 980 <GDECL (ALLACS) !<UVECTOR [8 AC]> (ATIME REGS) FIX (LAST-AC LAST-AC-1 AC0) AC>
 981
 982 <MANIFEST SS-SYM-SLOT SS-DAT-SLOT SS-STORED-SLOT SS-POTENT-SLOT>
 983
 984 <MANIFEST TMPFRM TMPNO THOME TUSERS DATTYP DATVAL  ADDRSYM ACSYM ACLINK ACAGE
 985           ACNUM ACPROT AC1SYM ACRESIDUE ACPREF ACINUSE TMPAC COMMON-DATUM
 986           NUMACS POTLV>
 987
 988 <MAPF <> ,MANIFEST ,CODVEC>
 989
 990 <MANIFEST TOT-MODES RESTS RMODES COMP-TYPES
 991 GDECL-SYM GNAME-SYM GNEXT-SYM FRMNO INIT-SYM ADDR-SYM TOTARGS REQARGS
 992 DECL-SYM PURE-SYM ARGNUM-SYM CODE-SYM SPEC-SYM NAME-SYM NEXT-SYM PREDIC
 993 NODE-SUBR CLAUSES ACS TMPLS ACTIVATED USLOTS SSLOTS SYMTAB SPECS-START
 994 BINDING-STRUCTURE RSUBR-DECLS SEGS STACKS KIDS NODE-NAME RESULT-TYPE PARENT
 995 NODE-TYPE SIDE-EFFECTS RET-AGAIN-ONLY ASS? INACS STORED DST CDST ACCUM-TYPE
 996 INIT-DECL-TYPE VSPCD AGND ASSUM RTAG ATAG SPCS-X BTP-B STK-B PRE-ALLOC
 997 USED-AT-ALL CURRENT-TYPE DEATH-LIST COMPOSIT-TYPE AGAIN-STATES RETURN-STATES
 998 PROG-VARS LOOP-VARS PROG-AC NUM-SYM  TYPE-INFO USAGE-SYM LIVE-VARS
 999 DEAD-VARS>
1000
1001 <REACS>
1002
1003 <SETG LINKED 1>
1004
1005 <SETG NO-RESIDUE 10000000>
1006
1007 <SETG STORED-RESIDUE 1000000>
1008
1009 <SETG NOT-STORED-RESIDUE 100000>
1010
1011 <SETG NOT-PREF 10000>
1012
1013 <SETG P-N-CLEAN 1000>
1014
1015 <SETG P-N-STO-RES 100>
1016
1017 <SETG P-N-NO-STO-RES 10>
1018
1019 <SETG P-N-LINKED 1>
1020
1021 <MANIFEST LINKED
1022           NO-RESIDUE
1023           STORED-RESIDUE
1024           NOT-STORED-RESIDUE
1025           NOT-PREF
1026           P-N-LINKED
1027           P-N-CLEAN
1028           P-N-STO-RES
1029           P-N-NO-STO-RES>
1030
1031 <SETG ACO <CHTYPE [`O* `O* <> 0 0 <> `A* <> <>] AC>>
1032
1033 <SETG SS-SYM-SLOT 1>
1034
1035 "POINTER TO SYMBOL"
1036
1037 <SETG SS-DAT-SLOT 2>
1038
1039 "DATUM OF THE SYMBOL"
1040
1041 <SETG SS-STORED-SLOT 3>
1042
1043 "IS THE SYMBOL STORED"
1044
1045 <SETG SS-POTENT-SLOT 4>
1046
1047 "IS THE SYMBOL POTENTIAL"
1048
1049 <MANIFEST SS-SYM-SLOT SS-DAT-SLOT SS-STORED-SLOT SS-POTENT-SLOT>
1050
1051 "MANIFESTS FOR PROG-AC"
1052
1053 <SETG PROG-SLOT 1>
1054
1055 <SETG NUM-SYM-SLOT 2>
1056
1057 <SETG STORED-SLOT 3>
1058
1059 <SETG INACS-SLOT 4>
1060
1061 "MANIFESTED VARIABLES FOR SLOT STORE IN PROG-VARS"
1062
1063 <SETG SYM-SLOT 1>
1064
1065 <SETG SAVED-NUM-SYM-SLOT 2>
1066
1067 <SETG SAVED-PROG-AC-SLOT 3>
1068
1069 <SETG SAVED-POTLV-SLOT 4>
1070
1071 <SETG LENGTH-PROG-VARS 4>
1072
1073 "MANIFESTS FOR AGAIN AND RETURN STATES"
1074
1075 <SETG SAVED-AC-STATE 1>
1076
1077 <SETG SAVED-CODE:PTR 2>
1078
1079 <SETG SAVED-STACK-STATE 3>
1080
1081 <SETG SAVED-RET-FLAG 4>
1082
1083 <SETG LENGTH-CONTROL-STATE 4>
1084
1085 "OFFSETS FOR STACK:INFO"
1086
1087 <SETG SAVED-FRMS 1>
1088
1089 <SETG SAVED-BSTB 2>
1090
1091 <SETG SAVED-NTSLOTS 3>
1092
1093 <SETG SAVED-STK 4>
1094
1095 "SLOTS FOR SAVED-AC-SLOT"
1096
1097 <SETG CSYMT-SLOT 1>
1098
1099 <SETG CINACS-SLOT 2>
1100
1101 <SETG CSTORED-SLOT 3>
1102
1103 <SETG CPOTLV-SLOT 4>
1104
1105 <SETG LENGTH-CSTATE 4>
1106
1107 "SLOTS FOR LOOP-VARS"
1108
1109 <SETG LSYM-SLOT 1>
1110
1111 <SETG LINACS-SLOT 2>
1112
1113 <SETG LOOPVARS-LENGTH 2>
1114
1115 <MANIFEST NUM-SYM-SLOT
1116           LSYM-SLOT
1117           LOOPVARS-LENGTH
1118           LINACS-SLOT
1119           SAVED-FRMS
1120           CSYMT-SLOT
1121           CINACS-SLOT
1122           CSTORED-SLOT
1123           CPOTLV-SLOT
1124           LENGTH-CSTATE
1125           SAVED-BSTB
1126           SAVED-NTSLOTS
1127           SAVED-STK
1128           STORED-SLOT
1129           INACS-SLOT
1130           PROG-SLOT
1131           SYM-SLOT
1132           SAVED-NUM-SYM-SLOT
1133           SAVED-POTLV-SLOT
1134           SAVED-PROG-AC-SLOT
1135           LENGTH-PROG-VARS
1136           LENGTH-CONTROL-STATE
1137           SAVED-AC-STATE
1138           SAVED-CODE:PTR
1139           SAVED-STACK-STATE
1140           SAVED-RET-FLAG>
1141
1142 <NEWTYPE COMMON
1143          VECTOR
1144          '<<PRIMTYPE VECTOR> ATOM <OR COMMON SYMTAB> FIX ANY <PRIMTYPE LIST>>>
1145
1146 <SETG COMMON-TYPE <OFFSET 1 COMMON>>
1147
1148 "TYPE OF COMMON (ATOM)"
1149
1150 <SETG COMMON-SYMT <OFFSET 2 COMMON>>
1151
1152 "POINTER TO OR COMMON SYMTAB"
1153
1154 <SETG COMMON-ITEM <OFFSET 3 COMMON>>
1155
1156 "3RD ARGUMENT TO NTH,REST,PUT ETC."
1157
1158 <SETG COMMON-PRIMTYPE <OFFSET 4 COMMON>>
1159
1160 "PRIMTYPE OF OBJECT IN COMMON"
1161
1162 <SETG COMMON-DATUM <OFFSET 5 COMMON>>
1163
1164 "DATUM FOR THIS COMMON"
1165
1166 <MANIFEST COMMON-TYPE COMMON-SYMTAB COMMON-ITEM COMMON-PRIMTYPE COMMON-DATUM>
1167
1168 <NEWTYPE TRANS
1169          VECTOR
1170          '<<PRIMTYPE VECTOR> NODE <UVECTOR [7 FIX]> <UVECTOR [7 FIX]>>>
1171
1172 <DEFINE MESSAGE (SEVERITY STR "TUPLE" TEXT)
1173         <AND <GASSIGNED? DEBUGSW> <ERROR .SEVERITY .STR>>
1174         <MAPF <>
1175               <FUNCTION (SEV ATM)
1176                       #DECL ((ATM SEV) ATOM)
1177                       <COND (<==? .SEV .SEVERITY>
1178                              <AND <ASSIGNED? .ATM> <SET .ATM T>>
1179                              <MAPLEAVE>)>>
1180               '(ERROR NOTE WARNING INCONSISTANCY INCONSISTENCY)
1181               '(ERRS NOTES WARNS INCONS INCONS)>
1182         <PRINC "*** ">
1183         <PRINC .SEVERITY>    ;"Typically NOTE, WARNING, ERROR, or INCONSISTANCY"
1184         <PRINC "        ">
1185         <PRINC .STR>
1186         <REPEAT ()
1187                 <COND (<EMPTY? .TEXT> <RETURN 0>)
1188                       (<==? <TYPE <1 .TEXT>> ATOM> <PRINC <1 .TEXT>>)
1189                       (<TYPE? <1 .TEXT> NODE>
1190                        <COND (<GASSIGNED? NODE-COMPLAIN>
1191                               <TERPRI>
1192                               <NODE-COMPLAIN <1 .TEXT>>
1193                               <TERPRI>)>)
1194                       (ELSE <PRIN1 <1 .TEXT>>)>
1195                 <PRINC " ">                                             ;"Space"
1196                 <SET TEXT <REST .TEXT>>>
1197         <TERPRI>
1198         <COND (<==? .SEVERITY ERROR> <RETURN " COMPILATION ABORTED " .COMPILER>)
1199               (<OR <==? .SEVERITY INCONSISTANCY> <==? .SEVERITY INCONSISTENCY>>
1200                <RETURN " INFORM  BKD; OR CLR; " .COMPILER>)>
1201         T>
1202
1203 <SETG INSTRUCTION ,FORM>
1204
1205 <ENDPACKAGE>