298 <SETG MAX-LENGTH *177777*>
300 <MANIFEST MAX-LENGTH>
302 <GDECL (SNODES SNODES1) <UVECTOR [REST FIX]>>
308 <NEWTYPE I$TERMIN WORD>
309 <NEWTYPE ADECL VECTOR>
312 <NEWTYPE T$UNBOUND WORD>
318 <SETG BQ+1 <+ <ASCII !\`> 1>>
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>>>)
325 <SETG READ-TABLE <SET READ-TABLE <IVECTOR ,BQ+1 <>>>>)>)>
327 <SETG MIM-OBL <MOBLIST MIM-OBL>>
329 <SETG TMP-OBL <MOBLIST TMPS>>
331 <SETG MIM-OBL-L (,MIM-OBL)>
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>>
337 #DECL ((OBLIST) <SPECIAL ANY>)
338 <ERROR BAD-BACK-Q-USAGE!-ERRORS>>)
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 <>]>)>
346 <SETG POP-STACK `STACK>
348 <SETG TOP-STACK `STACK>
350 <NEWTYPE FOOATOM ATOM>
352 <NEWTYPE FCN-ATOM ATOM>
354 <SETG OLD-ATOM <PRINTTYPE ATOM>>
356 <PRINTTYPE ATOM ,PRINT>
360 <PRINTTYPE FOOATOM ATOM>
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>>
367 (<==? <OBLIST? .X> ,TMP-OBL> <PRINC <SPNAME .X>>)
369 <SET ACT <CHTYPE .ACT FRAME>>
371 <COND (<MEMQ <FUNCT .ACT> '[PRINT PPRINT PRIN1 TOPLEV
374 <PRIN1 <CHTYPE .X FOOATOM>>)
375 (<==? <FUNCT .ACT> PRINC>
376 <PRINC <CHTYPE .X FOOATOM>>)
378 <SET ACT <FRAME .ACT>>
381 <DEFINE FCN-ATOM-PRINT ACT (X) #DECL ((ACT) <SPECIAL ANY>)
382 <COND (<AND <GASSIGNED? CTLZ-PRINT> ,CTLZ-PRINT>
384 <SET ACT <CHTYPE .ACT FRAME>>
386 <COND (<MEMQ <FUNCT .ACT> '[PRINT PPRINT PRIN1 TOPLEVEL
388 <PRIN1 <CHTYPE .X FOOATOM>>)
389 (<==? <FUNCT .ACT> PRINC>
390 <PRINC <CHTYPE .X FOOATOM>>)
392 <SET ACT <FRAME .ACT>>
395 <COND (<==? ,OLD-ATOM ATOM>
396 <PRINTTYPE ATOM ,ATOM-PRINT>
397 <PRINTTYPE FCN-ATOM ,FCN-ATOM-PRINT>)>
399 <PRINTTYPE STACK <FUNCTION (X) <PRINC "#STACK "> <PRIN1 <CHTYPE .X FIX>>>>
401 <SETG PLUSINF <CHTYPE <MIN> FIX>>
403 <SETG MINUSINF <CHTYPE <MAX> FIX>>
405 "Type specification for NODE."
413 ANY ;(NODE-NAME PREDIC)
414 <LIST [REST NODE]> ;(KIDS CLAUSES)
415 <OR FALSE ATOM> ;SEGS
417 LIST ;(TYPE-INFO LIVE-VARS)
419 ANY ;(RSUBR-DECLS NODE-SUBR)
420 LIST ;BINDING-STRUCTURE
422 <OR FALSE ATOM> ;ACTIVATED
424 ANY ;(DST ACCUM-TYPE)
425 ANY ;(CDST DEAD-VARS)
427 ANY ;(RTAG INIT-DECL-TYPE)
429 <OR FALSE LIST> ;AGND
433 "Offsets into pass 1 structure entities and functions to create same."
435 <SETG NODE-TYPE <OFFSET 1 NODE>>
437 ;"Code specifying the node type."
439 <SETG PARENT <OFFSET 2 NODE>>
441 ;"Pointer to parent node."
443 <SETG RESULT-TYPE <OFFSET 3 NODE>>
445 ;"Type expression for result returned by code
446 generated by this node."
448 <SETG NODE-NAME <OFFSET 4 NODE>>
450 ;"Usually name of SUBR associated with this node."
452 <SETG KIDS <OFFSET 5 NODE>>
454 ;"List of sub-nodes for this node."
456 <SETG SEGS <OFFSET 6 NODE>>
458 ;"Predicate: any segments among kids?"
460 <SETG TYPE-INFO <OFFSET 7 NODE>>
462 ;"Points to transient type info for this node."
464 <SETG SIDE-EFFECTS <OFFSET 8 NODE>>
466 ;"General info about side effects (format not yet firm.)"
468 <SETG RSUBR-DECLS <OFFSET 9 NODE>>
470 ;"Function only: final rsubr decls."
472 <SETG BINDING-STRUCTURE <OFFSET 10 NODE>>
474 ;"Partially compiled arg list."
476 <SETG SYMTAB <OFFSET 11 NODE>>
478 ;"Pointer to local symbol table."
480 <SETG ACTIVATED <OFFSET 12 NODE>>
482 ;"Predicate: any named activation?"
484 <SETG SPCS-X <OFFSET 13 NODE>>
486 ;"Predicate: any specials bound?"
488 <SETG DST <OFFSET 14 NODE>>
490 ;"Destination spec for value of node."
492 <SETG CDST <OFFSET 15 NODE>>
494 ;"Current destination used."
496 <SETG ATAG <OFFSET 16 NODE>>
498 ;"Label for local againing."
500 <SETG RTAG <OFFSET 17 NODE>>
502 ;"Label for local Returning."
504 <SETG ASSUM <OFFSET 18 NODE>>
506 ;"Node type assumptions."
508 <SETG AGND <OFFSET 19 NODE>>
510 ;"Predicate: Again possible?"
512 <SETG TOTARGS <OFFSET 20 NODE>>
514 ;"Total number of args (including optional)."
516 <SETG REQARGS <OFFSET 21 NODE>>
518 ;"Required arguemnts."
520 <SETG CLAUSES <OFFSET <1 ,KIDS> NODE>>
524 <SETG NODE-SUBR <OFFSET <1 ,RSUBR-DECLS> NODE>>
526 ;"For many nodes, the SUBR (not its name)."
528 <SETG PREDIC <OFFSET <1 ,NODE-NAME> NODE>>
530 ;"For cond clause nodes, the predicate."
532 <SETG ACCUM-TYPE <OFFSET <1 ,DST> NODE>>
534 ;"Accumulated type from all returns etc."
536 <SETG DEAD-VARS <OFFSET <1 ,CDST> NODE>>
538 <SETG LIVE-VARS <OFFSET <1 ,TYPE-INFO> NODE>>
540 <SETG VSPCD <OFFSET <1 ,ATAG> NODE>>
542 <SETG INIT-DECL-TYPE <OFFSET <1 ,RTAG> NODE>>
544 " Definitions associated with compiler symbol tables."
546 "Offsets for variable description blocks"
548 <NEWTYPE TEMP VECTOR '!<<PRIMTYPE VECTOR> ATOM FIX ANY <OR ATOM FALSE> ANY
553 '<<PRIMTYPE VECTOR> <PRIMTYPE VECTOR>
559 <OR ATOM SEGMENT FORM>
573 <SETG NEXT-SYM <OFFSET 1 SYMTAB>>
575 ;"Pointer to next symbol table entry."
577 <SETG NAME-SYM <OFFSET 2 SYMTAB>>
581 <SETG SPEC-SYM <OFFSET 3 SYMTAB>>
583 ;"Predicate: special?"
585 <SETG CODE-SYM <OFFSET 4 SYMTAB>>
587 ;"Code specifying whether AUX, OPTIONAL etc."
589 <SETG ARGNUM-SYM <OFFSET 5 SYMTAB>>
591 ;"If an argument, which one."
593 <SETG PURE-SYM <OFFSET 6 SYMTAB>>
595 ;"Predicate: unchanged in function?"
597 <SETG DECL-SYM <OFFSET 7 SYMTAB>>
599 ;"Decl for this variable."
601 <SETG ADDR-SYM <OFFSET 8 SYMTAB>>
605 <SETG INIT-SYM <OFFSET 9 SYMTAB>>
607 ;"Predicate: initial value? if so what."
609 <SETG TEMP-NAME-SYM <OFFSET 10 SYMTAB>>
613 <SETG RET-AGAIN-ONLY <OFFSET 11 SYMTAB>>
615 ;"Predicate: used only in AGAIN/RETURN?"
617 <SETG ASS? <OFFSET 12 SYMTAB>>
619 ;"Predicate: used in ASSIGNED?"
621 <SETG USAGE-SYM <OFFSET 13 SYMTAB>>
623 ;"Number of uses of this symbol."
625 '<SETG STORED <OFFSET 14 SYMTAB>>
627 ;"Predicate: stored in slot?"
629 <SETG USED-AT-ALL <OFFSET 15 SYMTAB>>
631 ;"Predicate: symbolused at all."
633 <SETG DEATH-LIST <OFFSET 16 SYMTAB>>
635 ;"List of info associated with life time."
637 <SETG CURRENT-TYPE <OFFSET 17 SYMTAB>>
639 ;"Current decl determined by analysis"
641 <SETG COMPOSIT-TYPE <OFFSET 18 SYMTAB>>
643 <SETG ARG-NAME-SYM <OFFSET 19 SYMTAB>>
645 "How a variable is used in a loop."
647 ;"Type as figured out by all uses of symbol."
649 <DEFINE NODE1 (TYP PAR RES-TYP NAME KID)
650 <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID <>] NODE>>
652 "Create a function node with all its hair."
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>>
658 "Create a PROG/REPEAT node with nearly as much hair."
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 () <>]
665 "Create a COND node."
667 <DEFINE NODECOND (TYP PAR RES-TYP NAME CLAU)
668 <CHTYPE [.TYP .PAR .RES-TYP .NAME .CLAU <> () <>] NODE>>
670 "Create a node for a COND clause."
672 <DEFINE NODEB (TYP PAR RES-TYP PRED CLAU)
673 <CHTYPE [.TYP .PAR .RES-TYP .PRED .CLAU <> () <>] NODE>>
675 "Create a node for a SUBR call etc."
677 <DEFINE NODEFM (TYP PAR RES-TYP NAME KID SUB)
678 <CHTYPE [.TYP .PAR .RES-TYP .NAME .KID <> () <> .SUB] NODE>>
681 <DEFINE ADDVAR (NAM SPEC CODE ARGNUM PURE DCL ADDR INIT)
701 FOO!-IPASS1!-PASS1!-PACKAGE]
704 "Some specialized decl stuff."
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 <> <>>
715 <PUTPROP CHANNEL DECL '<CHANNEL FIX [11 ANY] [5 FIX]>>)>
717 <COND (,MIM <PUT-DECL STRING '<<PRIMTYPE STRING> [REST CHARACTER]>>)
718 (ELSE <PUTPROP STRING DECL '<<PRIMTYPE STRING> [REST CHARACTER]>>)>
720 "Codes for the node types in the tree built by pass1 and modified by
723 "Give symbolic codes arbitrary increasing values."
728 <FUNCTION (ATM) <SETG .ATM .N> <SET N <+ .N 1>> .ATM>
836 <SETG COMP-TYPES .N>>
840 "Build a dispatch table based on node types."
842 <DEFINE DISPATCH (DEFAULT "TUPLE" PAIRS
843 "AUX" (TT <IVECTOR ,COMP-TYPES '.DEFAULT>))
844 #DECL ((PAIRS) <<PRIMTYPE VECTOR> [REST <LIST FIX ANY>]>
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>>>>
851 <SETG PREDV <IUVECTOR ,COMP-TYPES 0>>
853 <GDECL (PREDV) UVECTOR>
856 <FUNCTION (N) <PUT ,PREDV .N 1>>
875 <MAPF <> <FUNCTION (N) <PUT ,PREDV .N -1>> [,OR-CODE ,AND-CODE ,COND-CODE]>
877 "Predicate: does this type have special predicate code?"
879 " Assign codes to differen types of argument in argument list"
883 <FUNCTION (TYP) <SETG .TYP .N> <MANIFEST .TYP> <SET N <+ .N 1>>>
900 '<LIST [5 <LIST [REST SYMTAB DATUM <OR FALSE ATOM>
901 <OR ATOM FALSE>]>]>>)
905 '<LIST [5 <LIST [REST SYMTAB DATUM <OR FALSE ATOM>
906 <OR ATOM FALSE>]>]>>)>
908 <COND (,MIM <PUT-DECL SYMBOL '<OR SYMTAB TEMP COMMON>>)
909 (ELSE <PUTPROP SYMBOL DECL '<OR SYMTAB TEMP COMMON>>)>
911 <SETG DATTYP <OFFSET 1 DATUM>>
913 <SETG DATVAL <OFFSET 2 DATUM>>
917 '<<PRIMTYPE LIST> <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>
918 <OR ATOM <PRIMTYPE LIST> <PRIMTYPE VECTOR>>>>
920 <NEWTYPE OFFPTR LIST '<<PRIMTYPE LIST> FIX DATUM ATOM>>
922 <MANIFEST DATTYP DATVAL>
924 <MAPF <> ,MANIFEST ,CODVEC>
983 '<<PRIMTYPE VECTOR> ATOM <OR COMMON SYMTAB> FIX ANY <PRIMTYPE LIST>>>
985 <SETG COMMON-TYPE <OFFSET 1 COMMON>>
987 "TYPE OF COMMON (ATOM)"
989 <SETG COMMON-SYMT <OFFSET 2 COMMON>>
991 "POINTER TO OR COMMON SYMTAB"
993 <SETG COMMON-ITEM <OFFSET 3 COMMON>>
995 "3RD ARGUMENT TO NTH,REST,PUT ETC."
997 <SETG COMMON-PRIMTYPE <OFFSET 4 COMMON>>
999 "PRIMTYPE OF OBJECT IN COMMON"
1001 <SETG COMMON-DATUM <OFFSET 5 COMMON>>
1003 "DATUM FOR THIS COMMON"
1005 <MANIFEST COMMON-TYPE COMMON-SYMTAB COMMON-ITEM COMMON-PRIMTYPE COMMON-DATUM>
1009 '<<PRIMTYPE VECTOR> NODE <UVECTOR [7 FIX]> <UVECTOR [7 FIX]>>>
1011 <NEWTYPE MIM-SPECIAL ATOM>
1013 <SETG TEMP-NAME <OFFSET 1 TEMP>>
1015 <SETG TEMP-REFS <OFFSET 2 TEMP>>
1017 <SETG TEMP-FRAME <OFFSET 3 TEMP>>
1019 <SETG TEMP-ALLOC <OFFSET 4 TEMP>>
1021 <SETG TEMP-NO-RECYCLE <OFFSET 5 TEMP>>
1023 <SETG TEMP-TYPE <OFFSET 6 TEMP>>
1025 <MANIFEST TEMP-NAME TEMP-REFS TEMP-FRAME TEMP-ALLOC TEMP-NO-RECYCLE
1028 <COND (<N==? <TYPEPRIM FIX> FIX> <FLOAD "PS:<COMPIL>POPWR2.FBIN">)>
1030 <SETG BINDING-LENGTH 9>
1032 <MANIFEST BINDING-LENGTH>