*DECK     FEC                FRONT END CONTROLLER 
          IDENT  FEC
 FEC      SECT   (FRONT END CONTROLLER AND SUPPORT.)
 FEC      SPACE  4
*         IN ALLOC
          EXT    ADWT,ALC.REG,ALC.00,ALC
  
*         IN DECL 
          EXT    PCD
  
*         IN FERRS
          EXT    CLASS,E.ANS1,E.ANS2,E.AS6,E.CM8,E.C$15,E.DM03,E.DM04 
          EXT    E.DO09,E.FM,E.IF17,E.LV6,E.MA,E.MB,E.MD,E.MDO,E.MH,E.MI
          EXT    E.MS,E.NP,E.SEQ,E.SU04,E.SU06,E.TY7,E.VA00,E.VA02
          EXT    E.VA09,E.VA10,FILL.,FILL.2,MOD.DPC,E.STO 
  
*         IN FSNAP
          EXT    FI=BRLI,SN.PAR 
  
*         IN FTN
          EXT    CO.ANSI,CO.C$,CO.LOS,CO.SEQ,CO.SNAP,CP.FLIN,F.REF,L.C$ 
          EXT    L.TITL,TL.PTYP 
          EXT    ERFO 
  
*         IN GEN/BRIDGE 
          EXT    BN=CON,BN=FMT,BN=IOAP,BN=NLST
  
*         IN HEADER 
          EXT    PSF
  
*         IN IDP
          EXT    IDP=SVX,IDP=,REG=
  
*         IN KEY
          EXT    INIF,KW=CONT 
  
*         IN LABEL
          EXT    GSL,PDA
  
*         IN LEX
          EXT    LDB,LEX,LEXFLG,LEXMODE,SB=LINC,SB=LORD,TB=LABL,TB=LABR 
          EXT    TB=NUML,TB=TYPE,TB=1ST 
  
*         IN LISTLNK
          EXT    ALC=CNT,MOVES,PARSLEN
  
*         IN PAR
          EXT    CURST,EMT,OPBSS,PARNOW 
  
*         IN PEM
          EXT    ANSI=,PDM
  
*         IN PUC
          EXT    BASES,BLNKCOM,CHARDCL,ERRORS,ERRTYP,ERR=K
          EXT    E=TOTAL,FAILSFT,F.LBT,F.SORD,HDRBL,IO.TEM,LEVEL,LEVEL0 
          EXT    LEVEL2,LINES,LJS,LOSTREF,L=TABLE,L.TABS,MOD,NARGS,N.FP 
          EXT    NOLIST,N.AP,N.ARP,N.CPL,N.CT,N.CTMAX,N.DOB,N.EPL,N.ERRT
          EXT    N.GL,N.MAXIL,N.ST,N.STMAX,N.TABLE,N.VD,O.STITL,O.TABS
          EXT    PASS,RATES,REFIO,SAVE,SCR,SIZES,S=BU,S=CL,S=CON
          EXT    S=CT,S=ENTRY,S=FAR,S=FAS,S=FID,S=FMC,S=FVS,S=IT,S=LA 
          EXT    S=LC,S=LENP,S=LMC,S=MMC,S=OT,S=RD,S=SA1,S=ST,S=TA0 
          EXT    S=TRACE,S=VD,S=VALUE,T=BLKS,T=BLST,T=CON,T=C$IF,T=PAR
          EXT    T=PAR,T=REF,T=SCR,T=STMT,T=STF,T=SYM,T=TB,T=VDIM,T.BLKS
          EXT    T.BLST,T.COMM,T.DIM,T.END,T.FPI,T.PAR,T.REF,T.SYM
          EXT    T.VDIM,USAVE,WO.C$,WO.LOR,WO.LOS,WO.QC,Z.LBT,Z.SORD
          EXT    S=SA0,ENDFTN,CAF 
          EXT    NSQZLH,N.BUF,N$LC,S=BUF
  
*         IN QCGC 
          EXT    DUC.,DUC.BTH,DUC.1ST,DUC.2ND,QCP 
  
*         IN QCGLINK
          EXT    FEL.RTN,PIS
  
*         IN QSKEL/FSKEL
          EXT    F.INTF,V=BVD,V=EVD,V=FIN,V=NOOP,Z.INTF 
  
*         IN TYPE 
          EXT    TYPD 
  
*         IN UTILITY
          EXT    CDD,DXB,MVE=,SBM=,WTW= 
 FETABS   TITLE  FRONT END TABLE/SYMBOL DEFINITIONS.
 CELLS    EJECT 
**        DEFINITIONS OF CELLS USED BY THE FRONT END. 
  
  
 PSTACK   BSS    Z=PSTACK    TOP STACK FRAME FOR LEFT PARENTHESIS 
 ARGCOMA  EQUENT AC.W+PSTACK       SEE TEXT FOR FORMAT
 ARGMODE  EQUENT AM.W+PSTACK       SEE PAR  FOR USAGE 
 ARGMIS   EQUENT AS.W+PSTACK
  
 ASSTAG   BSSENT 1           *ASSIGN* STATEMENT LABEL 
  
 CALLTAG  EQUENT ASSTAG      *CALL* STATEMENT LABEL 
  
 CSLTAG   CONENT 0           CURRENT STATEMENT LABEL SYMTAB ORDINAL 
  
 DATFLG   BSSENT 1           DATA-STATEMENT FLAG.  ROYAL KLUDGE.
                             AFFECTS MISCELLANEOUS ACTIVITIES INVOLVED
                             IN ISSUING (T.DATS). 
  
 DTI      CONENT 0           DO-TERMINATION INDICATOR 
                             CONTAINS TAG OF THIS STATEMENTS LABEL, IF
                             IT IS A DO-TERMINATOR. 
                             = 0  IF THIS STATEMENT IS NOT A DO-TERMINAL
  
          USE    /RGFILE/ 
 OSTACK   BSSENT N.OPSTK     OPERATOR STACK  (BEFORE ESTACK)
  
 ESTACK   BSSENT N.ELSTK     ELEMENT STACK   (AFTER OSTACK) 
          USE    0
  
 FLOW     BSSENT 1           = 0  IF CONTROL FLOWS INTO THIS STATEMENT. 
                             " 0  IF THIS IS IN-ACCESSIBLE CODE.
                             SET FROM (NOPATH) OF PREVIOUS STATEMENT. 
  
 FORSKEL  EQUENT OSTACK      SKELETON AREA FOR PACKING FORMAT 
  
 HANGER   CONENT 0           HANGING COMPILATION INDICATOR. 
                             = 0  PREVIOUS STATEMENT COMPLETELY 
                                   PROCESSED ALREADY. 
                             " 0  ADDRESS OF ROUTINE WHO WILL BE ENTERED
                                   WHEN THE NEXT CODE-GENERATING STATE- 
                                   MENT IS ENCOUNTERED AND IT IS KNOWN
                                   WHAT THE STATEMENT LABEL IS. 
  
 IFLEVEL  CONENT 0           CURRENT BLOCK IF LEVEL 
  
 INSTF    CONENT 0           INDICATES FROM WHERE PARSER INPUT IS COMING
                             = 0 -- FROM *TB* (NORMAL)
                             " 0 -- FROM *STF* (STMT FUNCT EXPANSION) 
  
 LDEAD    CONENT 0           INITIAL LENGTH OF PARSED FILE UPON ENTRY TO
                             *PAR*.  USED WHEN *FLOW* = 0 TO RESET
                             LENGTH OF PARSED FILE UPON EXIT -- THUS
                             ELIMINATING PARSED CODE FOR DEAD REGIONS OF
                             SOURCE CODE. 
  
 L.CARD   CONENT 0           NR OF WORDS IN SOURCE LINE IMAGE AT
*                              (CP.CARD) ET SEQ  (INCLUDES FULL ZERO
*                              WORD EOL MARK) 
  
 NOPATH   CONENT 0           IF " 0 INDICATES STATEMENT MUST HAVE A 
                             STATEMENT LABEL FIELD.  IF SET AND NO LABEL
*                            *GSN* WILL OUTPUT *NO PATH* WARNING MESSAGE
  
 NTRCNT   CONENT 0           COUNT OF *ENTRY* STATEMENTS WHICH APPEARED 
                             IN THIS SUBPROGRAM.  USED TO DETERMINE WHAT
                             SUBPROGRAM EXIT CODE TO COMPILE. 
  
 PARMODE  CONENT 0           PARSE MODE = 0, NORMAL PROCESSING
                                        " 0, SPECIAL PROCESSING 
  
 PARAMC   BSSENT 1           COUNT OF PARAMETERS (SYMBOLIC CONSTANTS) 
  
 REFLIN   CONENT 0           REFERENCE LINE NUMBER
  
 REFNUM   BSZENT 2           STATEMENT LABEL REFERENCE. 
                             TYPE OF CROSS REFERENCE SYMBOL PROCESSING. 
                             SHOULD BE PRESET FOR ALL PROCESSORS THAT 
                             CALL *ISN* TO TRANSLATE A STATEMENT LABEL
                             REFERENCE. 
 REFVAR   EQUENT REFNUM+1    SYMBOL REFERENCE.
                             TYPE OF CROSS REFERENCE SYMBOL PROCESSING. 
                             SHOULD BE PRESET FOR ALL PROCESSORS THAT 
                             CALL *TRE* TO TRANSLATE A STATEMENT LABEL
                             REFERENCE. 
                             (*TRE* = *TRV*,*TNK* AND *TSF*)
  
 ROUTNAM  CONENT 0           NAME OF ROUTINE TO BE CALLED. USED BY
                             I/O STATEMENT PROCESSORS.
  
 RTNCNT   CONENT 0           COUNT OF NUMBER OF *RETURN* STATEMENTS IN
                             SUBPROGRAM.  COMPLEMENTED IF *END* IS
                             IMMEDIATELY PRECEDED BY *RETURN*.  USED BY 
                             *RTU* TO DETERMINE WHAT CODE NEED BE 
                             GENERATED. 
  
 STAGE    CONENT 0           CURRENT SOURCE PROGRAM STAGE.  VALUES ARE
                             *FEC=XXX*.  SEE DISCUSSION IN *FEC*. 
  
 TRLINE   CONENT 0           LINE NO. (OCTAL) FOR TRACEBACK ON RJT. 
  
 T=CONB   BSSENT 1           SAVE CON LEN AT BOS
 WANFP    BSSENT 1           OR'ED INTO *WA* BY *SSY* AND *ESY* 
 CELLS    SPACE  4,10 
**        SCRATCH AREA. 
  
 SCR2     BSSENT MAX.DIM+1   GENERAL SCRATCH AREA 2 
 TAB      SPACE  4
**        CELLS SET UP BY *TAB* FOR CLASSIFYING A STATEMENT.
  
 ZLEQUAL  CONENT 0           IF = 0 NO ZERO LEVEL *=* FOUND.
 ZLCOMMA  CONENT 0           IF = 0 NO ZERO LEVEL *,* FOUND.
 ZLPAREN  CONENT 0           1ST ZERO LEVEL *)* FOUND.
 ZLE      CONENT 0           LOCAL *ZLEQUAL* POINTER USED DURING PARSE. 
 ZLCOLON  CONENT 0           .NZ. IF A COLON AT PAREN LEVEL 1 OCCURRED, 
                             ELSE .ZR.  SEE *CST* (CLASSIFY STMT) 
                             IN DECK *LEX*. 
 SYMTAB   SPACE  4,10 
**        SYMBOL TABLE INITIALIZATION DATA. 
* 
*         WHEN A NEW PROGRAM-UNIT IS STARTED, FEC/PUP PRESTORES THE 
*         FOLLOWING ENTRIES IN THE SYMBOL TABLE.
  
  
          MACRO  SYMT,NAM,CELL,ATTR,BLOCK,FUNK
          LOCAL  ORD
 ORD      EQU    */Z=SYM
 .B       BFMIC  WB,(ATTR)
          DATA   L-NAM-,".B"
          IFC    NE,/BLOCK//,2
          VFD    WC.RLL/ML.PROG,WC.RBL/=XBN=BLOCK,*P/0
          SKIP   4
          IFC    NE,/FUNK//,2 
          VFD    WC.FUNTL/MF.FUNK,*P/0
          SKIP   1
          CON    0
*                            SAVE CODE TO STORE ORDINAL 
          IFC    NE,/CELL//,4 
 SORD     RMT 
          =X6    ORD
          SA6    =XS=CELL 
 SORD     RMT 
          ENDM
  
  
 F.SYMIL  BSSENT 0           BASE OF INITIAL SYMBOL TABLE IMAGE 
          LOC    0
          BSSZ   Z=SYM             ORDINAL 0 = ALWAYS CLEAR 
 *O+4S15  SYMT   BU,(CGS,NVAR)
 BUF.     SYMT   BUF,(CGS,VAR,DEF)
 CL.      SYMT   CL,(CGS,VAR,DEF,ARY),IOAP
 CON.     SYMT   CON,(CGS,VAR,DEF,ARY),CON
 CT.      SYMT   CT,(CGS,VAR,DEF) 
 LA.      SYMT   LA,(CGS,VAR,DEF,ARY),FMT 
 LENP.    SYMT   LENP,(CGS,LAB,DEF) 
 SAVEA1.  SYMT   SA1,(CGS,VAR,DEF)
 SAVEA0.  SYMT  SA0,(CGS,VAR,DEF) 
 ST.      SYMT   ST,(CGS,VAR,DEF,ARY) 
 TEMPA0.  SYMT   TA0,(CGS,VAR,DEF)
 TRACE.   SYMT   TRACE,(CGS,VAR,DEF)
 VD.      SYMT   VD,(CGS,VAR,DEF,ARY) 
 IT.      SYMT   IT,(CGS,VAR,DEF,ARY) 
 OT.      SYMT   OT,(CGS,VAR,DEF,ARY) 
 LC.      SYMT   LC,(CGS,VAR,DEF,ARY) 
 RD.      SYMT   RD,(CGS,VAR,DEF,ARY,MAT),NLST
  
 DBUG.LN  SYMT   FID,(CGS,NVAR,DEF,SUB,EXT),,LIB
 FMC.     SYMT   FMC,(CGS,NVAR,DEF,SUB,EXT),,BEF
 UMC.     SYMT   FMC+1,(CGS,NVAR,DEF,SUB,EXT),,BEF
 MMC.     SYMT   MMC,(CGS,NVAR,DEF,SUB,EXT),,BEF
 LMC.     SYMT   LMC,(CGS,NVAR,DEF,SUB,EXT),,BEF
  
 Z.SYMVP  BSSENT 0           FIRST VALUE. SYMBOL
 VALUE.   SYMT   VALUE,(CGS,VAR,BMEM) 
 VALUL.   SYMT   ,(VAR,EQV,CGS) 
 VALUI.   SYMT   ,(VAR,EQV,CGS) 
 VALUR.   SYMT   ,(VAR,EQV,CGS) 
 VALUD.   SYMT   ,(VAR,EQV,CGS) 
 VALUC.   SYMT   ,(VAR,EQV,CGS) 
 VALUH.   SYMT   ,(VAR,EQV,CGS) 
  
 Z.SYMDB  BSSENT 0           FIRST ENTRY WHICH DEPENDS ON (CO.DBSL) 
 FASC.    SYMT   FAS,(CGS,NVAR,DEF,SUB,EXT),,LIB
 FARC.    SYMT   FAR,(CGS,NVAR,DEF,SUB,EXT),,LIB
 FVSC.    SYMT   FVS,(CGS,NVAR,DEF,SUB,EXT),,LIB
  
 Z.SYMIL  BSSENT 1           LENGTH OF INITIAL SYMTAB LOAD
          LOC    *O 
 SYMTAB   SPACE  4,10 
*         HASH VECTOR FOR T.SYM.
          USE    /HASH/ 
 HASHTBL  BSSENT Z.HASH 
          USE    *
 CHARMAP  EJECT  4,30 
**        CHARMAP - CHARACTER MAPPING FOR OUTPUT OF ORIGINAL SYMBOL.
* 
*         MAPPING FOR CHARACTERS/OPERATORS USED THRU-OUT THE COMPILER.
* 
*         ANY ONE WISHING TO CHANGE THESE EQUS SHOULD LOOK AT 
*         GENERAL LEXICAL ROUTINES LIKE --
*         A.  TAB - NORMALIZE STATEMENT.
*         B.  ASN - ASSEMBLE NUMBER.
*         C.  ASV - ASSEMBLE VARIABLE.(NOTE SPECIAL MASK FOR KLUDGED 64 
*                   CHARACTER SET). 
* 
*         ALSO NOTE ROUTINES LIKE --
* 
*         A.  PAR - PARSE STATEMENT.
*         B.  TRE,TRV,TNK,TSF - TRANSLATE ELEMENT.
*         C.  LST, IOL, ETC. -- I/O LISTS.
* 
*         MOST OF MAPPING CRITERIA IS FOR CONVENIENCE OF JUMP TABLES AND
*         PROCESSING OF THE GIVEN OPERATOR WITH THESE ROUTINES. 
  
  
 CHMAP    MACRO  DPC,OPERS
 .3       IFC    EQ, DPC
          CON    0
 .3       ELSE
 A        MICRO  1,,\_DPC_\ 
 B        MICCNT A
 B        DECMIC B
          VFD    CH.DPCL/"B"L_DPC,CH.OPCL/DUC.OPERS 
 .3       ENDIF 
 CHMAP    ENDM
  
  
 CH=      MACRO 
          BSS    0
 CH=      ENDM
  
 CHARMAP  EJECT 
**        CHARMAP - CHARACTER MAPPING FOR PRINTING/ DISPLAYING. 
  
* 
*         *FORTRAN* DEFINED OPERATORS.
  
 CHARMAP  EQUENT *-O.DEF
          LOC    O.DEF
  
 O.EOS    CHMAP  -EOS-       END OF STATEMENT 
 O.HOLL   CHMAP  STRING      HOLLERITH CONSTANTS
 O.QHOLL  CHMAP  STRING      "" DELIMITED HOLLERITHS
 O.RLCON  CHMAP  STRING      R"" OR L"" HOLLERITHS
 O.CHAR   CHMAP  STRING      TYPE CHARACTER CONSTANTS 
 O.CONS   CHMAP              ALL NUMERIC STRINGS
 O.OCT    CHMAP 
 O.HEX    CHMAP 
 PERIOD   CHMAP  .           DECIMAL POINT
 O.VAR    CHMAP              ALL ALPHANUMERIC STRINGS 
 O.TRUE   CHMAP  .TRUE.      LOGICAL CONSTANTS
 O.FALSE  CHMAP  .FALSE.
  
 O.SEP    CH=                ---- BEGINNING OF SEPARATORS 
 O.PL     CHMAP  +,BTH
 O.MIN    CHMAP  -,BTH
 O.STAR   CHMAP  *,BTH
 O.SLASH  CHMAP  /,BTH
 O.UMIN   CHMAP  -,1ST
 O.EXP    CHMAP  **,BTH 
 O.LT     CHMAP  .LT.,BTH 
 O.GE     CHMAP  .GE.,BTH 
 O.EQ     CHMAP  .EQ.,BTH 
 O.NE     CHMAP  .NE.,BTH 
 O.LE     CHMAP  .LE.,BTH    REVERSED TO O.GE 
 O.GT     CHMAP  .GT.,BTH    REVERSED TO O.LT 
 O.NOT    CHMAP  .NOT.,1ST
 O.AND    CHMAP  .AND.,BTH
 O.XOR    CHMAP  .XOR.,BTH
 O.NEQV   CHMAP  .NEQV.,BTH 
 O.EQV    CHMAP  .EQV.,BTH
 O.OR     CHMAP  .OR.,BTH 
 O.CAT    CHMAP  //,BTH 
*                            ---- FOLLOWING DELIMIT EXPRESSIONS 
 O.LP     CHMAP  ()(
 O.RP     CHMAP  )
 O.=      CHMAP  (=),BTH
  
 O.SDEF   CH=                START OF SPECIAL OPERATORS 
 O.COMMA  CHMAP  (,),1ST
 O.COLON  CHMAP  (: ),BTH 
 O.SLP    CHMAP  ()(
 O.STFA   CHMAP  STF-ARG     STATEMENT FUNCTION ARGUMENT
 O.ILL    CHMAP 
  
*         FOLLOWING CHARACTERS SERVE MISCELLEANOUS PURPOSES 
  
 O.DOBI   CHMAP  IODOB       I/O DO BEGIN 
 O.DOCI   CHMAP  IODOC       I/O DO CONCLUSION
 O.DCBI   CHMAP  IODCB       I/O DO COLLAPSE BEGIN
 O.DCCI   CHMAP  IODCC       I/O DO COLLAPSE CONCLUSION 
 O.SPACE  CHMAP  SPACE
 O.NONE   CHMAP  -NONE- 
 O.1ST    CHMAP  -1ST-,1ST
 O.2ND    CHMAP  -2ND-,2ND
 O.BOTH   CHMAP  -BOTH-,BTH 
 O.ARY    CHMAP  ARY-LOD,2ND       SUBSCRIPTED ARRAY LOAD 
 O.MODC   CHMAP  MODE-CV,1ST       MODE CONVERSION
 O.MXP    CHMAP  ..MXP..     BOUNDARY MARKER (INTERNAL TO PARSER) 
 O.SQOT   CHMAP  (')         SINGLE QUOTE (INTERNAL TO LEX) 
 O.DQOT   CHMAP  (")         DOUBLE QUOTE (INTERNAL TO LEX) 
 O.ERR    CHMAP  ERROR       SOURCE PROGRAM FATAL ERROR 
  
          LOC    *O 
  
  
 Z.CHMAP  EQUENT *-CHARMAP
  
          PURGMAC CH= 
          PURGMAC CHMAP 
          TITLE  FRONT END CONTROLLER.
 FEC=     SPACE  4,15 
**        FEC= - STAGE VECTORS ARE ROWS IN A TRANSITION TABLE WHICH 
*                DESCRIBES THE ACTION NECESSARY (AS A JUMP ADDRESS) UPON
*                ENCOUNTERING A STATEMENT WITH (SFEC) = ROW WHEN
*                (STAGE) = COLUMN.
*         THE FIRST 7 ENTRIES ARE ORDER DEPENDENT (ONE FOR EACH VALUE OF
*                *STAGE*).  FURTHER ENTRIES ARE ADDED FOR STATEMENTS NOT
*                ACCURATELY DESCRIBED BY ANY PREVIOUS ROW.
* 
*         SEE ANSI 3.5, AND FIGURE 1. 
  
  
          MACRO  FEC=,NAM,FST,IMP,DEC,STF,EXU 
 FEC=NAM  VFD    4/0,8/FEC.BY,8/FEC.BY,8/FEC.EXU,8/FEC.STF,8/FEC.DEC,___
,8/FEC.IMP,8/FEC.FST
          ENTRY  FEC=NAM
 FEC=     ENDM
  
 FEC=     BSS    0
          LOC    0
****             (1ST IMP DEC STF EXU)
 1ST      FEC=    OK_,EMH,EMH,EMH,EMH 
 IMP      FEC=    IMP,OK_,EMI,EMI,EMI 
 DEC      FEC=    IMP,DEC,OK_,EMD,EMD 
 STF      FEC=    IMP,DEC,STF,OK_,EMA 
 EXU      FEC=    IMP,DEC,STF,EXU,OK_ 
 END      FEC=    IMP,DEC,STF,EXU,OK_ 
 BY       FEC=    BY_,BY_,BY_,BY_,BY_ 
  
 DAT      FEC=    IMP,DEC,STF,OK_,OK_ 
 FMT      FEC=    IMP,FMT,FMT,FMT,FMT 
 ENT      FEC=    IMP,OK_,OK_,OK_,OK_ 
 TYP      FEC=    OK_,DEC,OK_,EMD,EMD 
 PRM      FEC=    IMP,OK_,OK_,EMD,EMD 
 OK       FEC=    OK_,OK_,OK_,OK_,OK_ 
****
          LOC    *O 
 FEC      EJECT 
**        FEC - FRONT END CONTROLLER. 
* 
*         CALLED BY OVERLAY INITIALIZER.
* 
*         EXITS TO FRONT END LOADER.
* 
*         PROGRAM UNIT PRESETS (PUP) SHOULD HAVE LOGICALLY BEEN 
*         CALLED BY THE PROGRAM UNIT CONTROLLER (PUC), BUT, 
*         CERTAIN HIGHER LEVEL OVERLAY INITIALIZATION HAD TO BE 
*         DONE FIRST SO DO IT NOW.
*         THEN, FOR THE SAME REASON, CALL QUICK CODEGENERATOR 
*         PRESETS (QCP). THIS IS A NOOP IN CCG MODE. FRAP.
  
  
 FEC      BSSENT 0           ...ENTRY 
          CALL   PUP         PROGRAM UNIT PRESETS 
          CALL   QCP         QUICK CODE PRESETS 
          RJ     FEP         FRONT END PRESETS
 FEC.RTN  SPACE  4,10 
**        FEC.RTN - RETURN FROM STATEMENT PROCESSING. 
* 
*         MOST STATEMENT PROCESSORS RETURN TO THE FRONT END CONTROLLER. 
  
  
 FEC.RTN  BSSENT 0
          RJ     RSC         RESET STATEMENT CELLS
  
*         CHECK FOR *BRLI* REQUEST. 
  
 .T       IFEQ   TEST,ON
          SA1    LINES       (X1) = LINE NR WITHIN THIS PGM UNIT
          SA2    FI=BRLI     (X2) = *BRLI* LINE NR, IF REQUESTED
          IX3    X1-X2
          BX6    X6-X6
          ZR     X2,FEC1     IF NO *BRLI* REQUESTED 
          MI     X3,FEC1     IF NOT AT OR PAST SELECTED LINE NR 
          SA6    A2+         CLEAR *BRLI* LINE NR 
  
 BRLI     BREAK 
 FEC1     BSS    0
 .T       ENDIF 
  
*         CHECK TO SEE IF WE NEED TO LIST ANY LINES IN *T.STMT* 
*         THAT WERE SAVED IN *BEFORE HEADER* MODE.
*         SEE *LEXFLG/HDR* IN DECK *LEX* FOR MORE INFORMATION.
  
          SA1    STAGE
          SA2    LEXFLG 
          SX6    X1-FEC=1ST 
          LX2    59-LF.HDRP 
          ZR     X6,FEC1A    IF WE ARE IN *HEADER* STAGE
          PL     X2,FEC1A    IF NOT IN *HEADER DELAY* MODE
          CALL   LDB         LIST DEFERRED BUFFER 
  
*         CALL THE LEXICAL SCANNER TO ENTOKEN THE NEXT SOURCE STATEMENT.
  
 FEC1A    CALL   LEX         LEXICAL SCANNER
  
*         SET UP REFERENCE LINE NUMBER OF INITIAL LINE OF STMT
*         FOR REF MAP GENERATION  (SEE *ERT*).
  
          SA5    TB=NUML     (X5) = LINE NR OF INITIAL LINE OF STMT,
*                                   -L- FORMAT
          SB7    B1+         SET TO *DECIMAL CONVERSION*
          CALL   DXB         CONVERT DECIMAL DPC TO BINARY
  
          IFEQ   TEST,ON,1
          NZ     X4,"BLOWUP" IF ERROR IN CONVERSION 
  
          SA1    REFLIN 
          LX6    XR.LINEP-0 
          IX1    X1-X6
          MI     X1,FEC1B    IF SEQUENCE/LINE NUMBER IS ASCENDING 
          FATAL  E.SEQ       ** SEQUENCE NUMBER OUT OF ORDER
          SX6    0           RESTART THE SEQUENCE NUMBERS 
  
 FEC1B    SA6    REFLIN 
          SA1    STAGE
          SX1    X1-FEC=BY
          ZR     X1,FEC.+FEC.BY  IF IN BYPASS MODE
          SA5    TB=TYPE
          NZ     X5,FEC2     IF NOT UNTYPED 
          SA1    T=CONB 
          BX6    X1 
          SHRINK T=CON,X6    RESTORE T=CON
          EQ     E.FM        UNRECOGNIZED STATEMENT DIAG. 
 FEC.RTN  SPACE  4,10 
***       NOW FOR MISCELLANEOUS CHECKS ON THE PROPERTIES OF THE STMT. 
* 
*         SEE *KEYW* MACRO (IN DECK *LEX*) AND *KW.* STRUCTURE
*         DEFINITIONS (IN *FTN5TXT*) FOR DEFINITIONS AND A DESCRIPTION
*         OF ATTRIBUTES.
  
  
**        DIAGNOSE ILLEGAL STATEMENTS IN *BLOCKDATA* SUBPROGRAMS. 
  
 FEC2     SA1    MOD
          SX4    MO.BLKM
          BX4    X4*X1       FORM MASK (=1 IF BLOCKDATA)
          SBIT   X4,MO.BLKP/KW.BKDP 
          BX4    -X5*X4      ISOLATE *LEGAL IN BKD* BIT (IF IN BKD) 
          ZR     X4,FEC3     IF NO BLOCK DATA PROBLEM 
          FATAL  E.MB 
 FEC.     SPACE  4,10 
**        FEC. - STATEMENT TRANSITION TABLE EXECUTIVE.
* 
*         INSURE THAT THIS STATEMENT IS IN ITS PROPER PLACE.
  
  
 FEC3     SA5    TB=TYPE
          BX3    X5 
          MX0    -KW.FECL 
          SA4    STAGE
          LX3    -KW.FECP 
          BX2    -X0*X3      ISOLATE STATEMENT STAGE NUMBER 
          SA1    X2+FEC=     FETCH STAGE VECTOR 
          LX4    3           = ACTUAL (STAGE) * 8 
          SB7    X4 
          MX0    -8 
          AX1    B7 
          BX2    -X0*X1      ISOLATE COLUMN 
          SB2    X2 
          JP     B2+FEC.
  
 FEC.     BSS    0           BASE OF STAGE ACTIONS TABLE. 
          LOC    0
  
 FEC.IMP  CALL   PSF         SET STAGE = IMP
          EQ     FEC3 
  
 FEC.DEC  =X6    FEC=DEC     SET STAGE = DEC
          SA6    A4 
          EQ     FEC3 
  
 FEC.STF  CALL   PCD         SET STAGE = STF
          RJ     OIL         OUTPUT IL FOR PRE-EXECUTABLES
          EQ     FEC3 
  
 FEC.EXU  =X6    FEC=EXU     SET STAGE = EXU
          SA6    A4 
          SA1    =XTV=EXU 
          BX7    X1 
          SA7    =XTV=CUR    SET CURRENT PHASE TO EXU (FOR ALLOC) 
          MX6    1
          LX6    1+WA.NFPP
          SA6    WANFP       SET CANNOT BE *FP* FLAG
          EQ     FEC3 
  
  
 FEC.EMA  EQ     E.MA        MISPLACED STATEMENT FUNCTION 
 FEC.EMD  EQ     E.MD        MISPLACED DECLARATIVE STATEMENT
 FEC.EMH  EQ     E.MH        MISPLACED HEADER STATEMENT 
 FEC.EMI  EQ     E.MI        MISPLACED IMPLICIT STATEMENT 
  
 FEC.BY   SA1    TB=TYPE
          SBIT   X1,KW.PWSP 
          PL     X1,FEC.RTN  IF NOT PROCESS ALWAYS STATEMENT
  
 FEC.FMT  BSS    0
 FEC.OK   BSS    0           PROPERLY POSITIONED. 
          LOC    *O 
          SA1    TB=LABR
          ZR     X1,FEC3A    IF NO LABEL
          SA3    TB=LABL
          BX6    X1 
          BX7    X3 
          SA7    FILL.
          CALL   GSL         GET STATEMENT LABEL
  
**               IF THIS IS A CODE-GENERATING STATEMENT, INVOKE *CUS* TO
*         FINISH UP ANY INCOMPLETE STUFF FROM PREVIOUS STATEMENT, 
*         AND PROCESS THE LABEL.
  
 FEC3A    SA5    TB=TYPE
          SBIT   X5,KW.GENP 
          PL     X5,FEC4     IF STATEMENT DOES NOT GENERATE TURPLES 
          RJ     CUS         CHECK UPCOMING STATEMENT 
  
 FEC4     SA5    TB=TYPE
          SA1    DTI
          SBIT   X5,KW.DONP 
          ZR     X1,FEC5     IF NO DO TERMINATION 
          PL     X5,FEC5     IF NOT DO TERMINAL 
          FATAL  E.MDO       *ILLEGAL DO TERMINAL*
 FEC5     BSS    0
  
  
**               LOGICAL (1-BRANCH) IF PROCESSOR RETURNS TO HERE AFTER
*         DETERMINING STATEMENT TYPE AND LEGALITY.
  
 FEC.RIF  BSSENT 0           ...RETURN FROM 1-BRANCH IF.
          SA1    TB=1ST 
          =B4    X1 
  
  
**        JUMP - TO COMPILE THE STATEMENT.
  
          SA5    TB=TYPE
          LX5    0-KW.JMPP
          SB6    X5 
          JP     B6          COMPILE STATEMENT, RETURN TO FEC THROUGH 
                             ENTRIES OF THE FORM *FEC.RXX*
 FEC.RTF  SPACE  4,10 
**        FEC.RTF - RETURN TO TERMINATE FRONT END PROCESSING. 
  
  
 FEC.RTF  BSSENT 0           ...RETURN TO TERMINATE FRONT END 
          SA1    WO.LOS      SOURCE LISTING FLAG (WORKING)
          ZR     X1,FEC7     IF NOT IN *LIST* MODE
          CALL   LDB         LIST DEFERRED BUFFER 
  
 FEC7     RJ     OIL         FLUSH I.L. 
          RJ     CLU         CHECK LEVEL USAGE
          CALL   FVD         FLUSH VARIABLE DIMENSIONS
          BX4    0
          MX5    0
          EMIT   V=FIN       OUTPUT FINIS TURPLE
          CALL   OIL         OUTPUT REMAINING IL
          SHRINK T=STF,0
          SHRINK T=TB,X6
          SHRINK T=SCR,X6 
          RJ     CAC         CHECK ASSUMED LENGTH CHARACTER 
          RJ     CUF         CHECK UNDEFINED FUNCTION 
          RJ     CUL         CHECK UNDEFINED LABELS 
          RJ     SSU         SET SAVE BIT FOR UNIVERSAL SAVE
          RJ     RLS         RELOCATE LOCAL SAVED VARIABLES 
          RJ     CVD         CHECK VARIABLE DIMENSION IRREGULARITIES
          CALL   MAL         MARK ASSIGN GOTO/ED LOOPS WITH ENTRIES 
          SHRINK T=STMT,0 
          SA6    SB=LINC
          SA6    SB=LORD
          SA1    CO.ANSI
          ZR     X1,FEL.RTN  IF ANSI NOT REQUESTED
          RJ     CBN         CHECK COMMON BLOCK NAME MISUSE 
          SA1    CO.SEQ 
          ZR     X1,FEL.RTN  IF NOT SEQ MODE
          ANSI   E.ANS1      **SEQ MODE NON ANSI
          EQ     FEL.RTN     EXIT TO FRONT END LOADER...
          TITLE  SUBROUTINES. 
 ASK      SPACE  4,30 
**        ASK -  ADJUST STATEMENT KEYWORD.
* 
*         REMOVES A KEYWORD FROM THE TOKEN BUFFER, *T.TB*,
*         AND ADJUSTS THE REMAINING CHARACTERS. 
* 
*                ** IMPORTANT MESSAGE **
* 
*         THIS ROUTINE EXISTS ONLY SO THAT *ASL* CAN CALL IT
*         TO STRIP OFF THE LABEL FOR THE *DO* AND *ASSIGN* STMTS. 
*         THE NEW SCANNER (LEX) DOES NOT REQUIRE *ASK* AND IT EXISTS
*         ONLY BECAUSE I (PXC) DID NOT WANT TO DEAL WITH THIS 
*         SPECIAL *ASL/ASK* INTERFACE AT THE CURRENT TIME.  THAT IS,
*         I INTEND ON CLEANING THIS UP, AND REMOVING *ASK* ALL TOGETHER.
* 
*         **NOTE - MRR**  ASK IS CALLED BY ASSIGN AND TYPE DECLARATIONS 
*         TO ADJUST IMBEDDED KEYWORDS (*TO* AND *FUNCTION*). THUS ASK,
*         OR SOME SUBSTITUTE WILL BE NEEDED.
*         *************** 
* 
*         V E R Y   I M P O R T A N T   M E S S A G E 
* 
*         IF U CALL THIS ROUTINE, U ***MUST*** MANUFACTURE A DUMMY
*         *JUMPTO.* WORD.  ***DONT*** USE THIS ROUTINE. 
* 
*         *************** 
* 
*                           * * * 
* 
*         ENTRY  (X5) = (JUMPTO. TABLE ENTRY) 
*                (B4) _ KEYWORD IN *TB* 
* 
*         EXIT   (B4) _ *TB* ENTRY PAST KEYWORD 
*                (B3) = JUMP ADDRESS FOR THE STATEMENT PROCESSOR
*                (X3) = 0 IFF KEYWORD WAS CORRECTLY SPELLED.
* 
*         USES   X - ALL
*                A - 2,4,6
*                B - ALL BUT B5 
* 
*         CALLS  NONE 
  
  
*         HERE WE THROW AWAY INTEGERAL WORDS (MULTIPLES OF 7 CHARS).
  
 ASK8     SB2    B7-B1       BIT COUNT = BITCOUNT MINUS 7CHARS
          SB4    B4+B1
          BX6    X7*X2
          IX3    X3-X6       COMPARE KEYWORD (1ST 7 CHAR) 
          NZ     B7,ASK2     IF MORE THAN 7 CHARACTERS IN KEY 
  
 ASK      SUBR   =           ENTRY/EXIT...
          MX0    4*CHAR 
          SB3    X5 
          SA4    B3-B1       HIJKLMNEFG  WHERE A-N ARE CHARS IN KEYWORD 
          BX3    X0*X5       ABCD------ 
          LX5    -18         *** KLUDGE *** 
          SX1    X4          -------EFG 
          MX2    -9          *** KLUDGE *** 
          IX6    X4-X1       HIJKLMN--- 
          BX7    -X2*X5      ISOLATE BIT COUNT
          SB2    X7-4*CHAR
          MI     B2,ASK1     IF 4 CHARACTER KEYWORD (OR LESS) 
          MX0    7*CHAR 
          SA2    B4 
          BX2    X0*X2
          BX2    X2-X3
          ZR     X2,E.FM     IF NOT ACTUALLY KEYWORD
 ASK1     SB2    X7 
          LX1    3*CHAR      ----EFG--- 
          BX4    X1+X3       ABCDEFG--- 
          SA6    FILL.2      SAVE KEYWORD FOR POSSIBLE ERROR MSG
          IX3    X4+X6
          MX7    7*CHAR 
          BX6    X4 
          SA6    A6-B1
  
 ASK2     SA2    B4 
          SB7    B2-7*CHAR+1
          SB6    X2-O.VAR 
          SX1    X2-O.CONS
          ZR     B6,ASK3     IF ALPHA STRING
          ZR     X1,ASK3     IF DIGIT STRING
          EQ     EXIT.
  
 ASK3     PL     B7,ASK8     IF SEVEN OR MORE CHARACTERS
          MX4    1
          SB6    B4 
          AX0    X4,B2       MASK FOR UPPER PART
          BX1    X0*X2
          IX3    X3-X1       COMPARE KEYWORD
          SB7    B2+18+1
          SB2    B2+B1
          BX7    X7-X0       MASK FOR MIDDLE PART 
          BX1    X7*X2
          LX6    X1,B2
          BX1    X6 
          LX6    6
          =X4    O.VAR
          SX6    X6-1R0 
          MI     X6,ASK4     IF LETTER
          =X4    O.CONS 
  
*         NOW AN OFFSET CHARACTER MOVE UNTIL WE RUN INTO A SEPARATOR. 
  
 ASK4     SA2    B6+B1
          SX6    X2-O.VAR 
          ZR     X6,ASK5     IF ALPHA STRING
          SX6    X2-O.CONS
          ZR     X6,ASK5     IF DIGIT STRING
          EQ     ASK6 
  
 ASK5     BX6    X0*X2
          LX6    B7          MOVE NEXT UPPER TO RESULT MIDDLE 
          IX6    X6+X1
          SB6    B6+B1
          BX6    X6+X4       RESTORE O.VAR (OR O.CONS)
          SA6    B6-B1
          BX6    X7*X2
          LX1    X6,B2       MOVE CURRENT MIDDLE TO RESULT UPPER
          EQ     ASK4 
  
*         HAVE FOUND A STOPPER, IS A MOVE NEEDED QQQ. 
  
 ASK6     BX6    X4+X1
          SA6    B6          STORE ANY REMAINING PARTIAL WORD 
          NZ     X1,EXIT.    IF THERE WAS ANYTHING IN THE PARTIAL WORD
  
          =B4    B4+1        *TB* MUST BE ADJUSTED
 ASK7     SA2    B6-B1
          SB6    B6-B1       COUNT DOWN THE AUXILLARY COUNTER 
          BX6    X2 
          SA6    A2+B1
          GE     B6,B4,ASK7        IF NOT YET TO FRONT OF STRING
          EQ     EXIT.
 ASL      SPACE  4,15 
**        ASL -  ADJUST STATEMENT LABEL.
* 
*         SPECIAL KLUDGE FOR *DO* AND *ASSIGN* STATEMENTS.  DETERMINES
*         LENGTH OF STATEMENT LABEL IN *TB*, AND CALLS *ASK* TO REMOVE
*         IT FROM THE STRING.  THUS, THESE POOR STATEMENTS CAN GET AT 
*         THE NEXT ELEMENT OF THE STATEMENT IN THE USUAL FASHION. 
* 
*         ENTRY  (B4) _ LABEL IN *TB* 
* 
*         EXIT   (B4) _ TOKEN (LOGICAL) FOLLOWING STATEMENT LABEL 
*                (X1) = 0L_LABEL + O.CON. 
*                *TB* ADJUSTED, AS DEFINED BY *ASK* 
* 
*         USES   ALL BUT A0.
*                (SCR). 
*         CALLS  ASK. 
  
  
 ASL      SUBR   =           ENTRY/EXIT...
          SB5    -O.CONS
          SA2    =05050505050505BS18
          SA3    =40404040404040BS18
          SB6    B0          INITIALIZE *SB* POINTER
          SA1    B4          (X1) = START OF LABEL
 ASL1     IX4    X1+X2       SET SIGN BITS OF DIGITS
          BX7    -X3+X4      ISOLATE NON-DIGITS 
          NZ     X7,ASL2     IF NOT 7-DIGITS
          =B6    B6+B1       UPDATE *SB* POINTER
          SA1    B4+B6       PICK UP NEXT *SB* ENTRY
          SX5    X1+B5
          ZR     X5,ASL1     IF STILL A CONSTANT
          =B2    -1 
          EQ     ASL3 
  
 ASL2     LX7    -12
          NX2,B2 X7          LOCATE FIRST NON-DIGIT 
          =B2    B2-1 
          MX0    1
          AX4    X0,B2       MASK LENGTH = DIGIT LENGTH 
          ZR     B6,ASL4     IF LABEL ONLY 1 WORD LONG
 ASL3     MX4    7*CHAR 
          SA1    B4          RESET (X1) = START OF LABEL
          SB4    B4+B6       SET B4 TO LAST WORD OF LABEL 
 ASL4     BX6    X4*X1
          MI     B2,ASL5     IF LABEL MULTIPLE OF 7 CHARACTERS
          SX3    B2 
          MX4    -9          *** KLUDGE *** 
          SX5    1+=0 
          BX3    -X4*X3 
          LX3    18          *** KLUDGE *** 
          SA6    SCR
          IX5    X5+X3       MANUFACTURE DUMMY *SATTR* WORD FOR *ASK* 
          RJ     ASK         ADJUST OFF THE LABEL 
          SA1    SCR
          EQ     EXIT.
  
 ASL5     SA1    B4 
          SX5    X1+B5
          NZ     X5,ASL6     IF NOT CONSTANT
          SX4    O.VAR-O.CONS 
          IX7    X1+X4
          SA7    B4 
 ASL6     BX1    X6 
          EQ     EXIT.
 CAC      SPACE  4,10 
**        CAC -  CHECK ASSUMED LENGTH CHARACTER DECLARATIONS
* 
*         OUTPUTS DIAGNOSTIC FOR ILLEGAL ASSUMED LENGTH CHARACTER.
  
  
 CAC      SUBR   0           ...ENTRY/EXIT... 
          SA1    CHARDCL
          ZR     X1,EXIT.    IF NO TYPE CHARACTER DECLARATIONS
          SA3    T.SYM
          SA2    T=SYM
          SB3    Z=SYM
          SA4    X3-Z=SYM+WB.W     INITIALIZE FETCH REGISTER
          SB4    X2 
          MX0    -WB.MODEL
          SA1    S=VALUE
          SB5    X1 
          LX1    1
          SX1    X1+B5       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B5    X1-WA.W+WB.W 
          SB5    B5+X3       ADD IN T.SYM ADDR
  
 CAC1     SA4    A4+B3
          ZR     B4,EXIT.    IF TABLE EXHAUSTED 
          SB4    B4-B3
          LX4    -WB.MODEP
          BX3    -X0*X4      EXTRACT MODE 
          LX4    WB.MODEP 
          SB2    X3-M.CHAR
          NZ     B2,CAC1     IF NOT TYPE CHARACTER
          =A1    A4-WB.W+WC.W 
          HX1    WC.CTYP
          PL     X1,CAC1     IF NOT ASSUMED LENGTH
          HX4    WB.FP
          MI     X4,CAC1     IF FORMAL PARAMETER
          SBIT   X4,WB.ENTP/WB.FPP
          MI     X4,CAC1     IF ENTRY POINT 
          SB7    A4-B5
          NZ     B7,CAC5     IF NOT 1ST VALUE. SYMBOL 
          SA4    A4+Z=SYM*M.CHAR   SKIP OVER REST OF VALUE. SYMBOLS 
          EQ     CAC1 
  
 CAC5     =A1    A4-WB.W+WA.W 
          MX3    WA.SYML
          BX6    X3*X1       NAME ONLY
          SA6    FILL.
          FATAL  E.TY7
          EQ     CAC1 
 CBN      SPACE  4,10 
**        CBN -  CHECK COMMON BLOCK NAMES 
* 
*         CHECK FOR NON-ANSI USAGE OF COMMON BLOCK NAMES IN PROGRAM UNIT
* 
*         CALLS  SSY
  
  
 CBN      SUBR               ...ENTRY/EXIT... 
          SA1    T=BLKS 
          SB3    X1-Z=BLKS
          SA5    T.BLKS 
  
 CBN1     SA1    X5+B3
          ZR     B3,EXIT.    IF FINISHED
          SB3    B3-Z=BLKS
          MX0    CA.BNAML 
          BX6    X0*X1
          ERRNZ  CA.BNAML-WA.SYML 
          SA6    FILL.
          RJ     SSY         SCAN SYMBOL TABLE
          MI     B7,CBN1     IF SYMBOL NOT USED (EXCEPT AS COMMON BLOCK)
          CLAS=  X3,WB,(INTF,DEXT,GENF,EXT,ENT,FUN,SUB,PARM)
          BX3    X3*X2
          ZR     X3,CBN1     IF NO INVALID USAGE
          NX3,B7
          SBIT   X2,WB.FUNP 
          PL     X2,CBN2     IF NOT FUNCTION
          =A2    A2-WB.W+WC.W 
          MX0    -WC.FUNTL
          LX2    -WC.FUNTP
          BX2    -X0*X2      EXTRACT FUNCTION TYPE
          SX2    X2-MF.STF
          ZR     X2,CBN1     IF STATEMENT FUNCTION, NO CONFLICT 
  
 CBN2     SB2    CLASS+47 
          SA3    B2-B7       FETCH ERRLIT OF INVALID USAGE
          BX6    X3 
          SA6    FILL.2 
          ANSI   E.CM8
          EQ     CBN1 
 CLU      SPACE  4,10 
**        CLU  - CHECK "LEVEL" USAGE. 
*         CHECKS THAT EACH LEVELED NON- COMMON NAME IS A FORMAL 
*         PARAMETER.
*         SETS LEV0[FPI] FOR LEVEL 0 FORMAL PARAMS. 
*         CALLS  NONE 
  
  
 CLU      SUBR   0
          SA1    LEVEL
          SA2    T=SYM
          ZR     X1,EXIT.    IF NO LEVEL STATEMENTS 
          SA3    T.SYM
          SA4    T.FPI
          SB6    X2          (B6) = NO. OF T.SYM WORDS TO EXAMINE 
          SB7    X4-1 
          =B3    Z=SYM
          =A3    X3-Z=SYM+WB.W
          CLAS=  X5,WB,(LEVN) 
          CLAS=  X4,WB,(LEV,LEVN) 
          CLAS=  X1,WB,(FP,COM) 
          EQ     CLU10
  
 CLU5     LX3    WB.LABP-WB.LCMP
          MX6    1
          PL     X3,CLU10    IF NOT LCM 
          LX3    1+WB.LCMP
          BX0    X5*X3
          LX6    1+FP.LEV0P 
          NZ     X0,CLU10    IF LEVEL NE 0
          MX0    -WB.FPNOL
          LX3    -WB.FPNOP
          BX0    -X0*X3 
          SA2    B7+X0
          BX6    X6+X2
          SA6    A2          SET LEV0[FPI ENTRY]
          SA6    LEVEL0      LEVEL0 NZ FOR PASS 2 
  
 CLU10    SA3    A3+B3       WBI = WB ENTRY OF T.SYM
          =A2    A3-WB.W+WA.W      WAI = WA ENTRY OF T.SYM
          MX6    WA.SYML
          BX6    X6*X2
          ZR     B6,EXIT.    IF DONE
          BX0    X1*X3
          BX7    -X4*X3 
          SB6    B6-B3
          HX3    WB.LEV 
          SA6    FILL.       STORE NAME IN MESSAGE
          PL     X3,CLU10    IF NOT LEVELED 
          LX3    WB.LEVP-WB.LABP
          MI     X3,CLU10    IF LABEL LEVEL BITS NOT DEFINED
          HX0    WB.COM 
          MI     X0,CLU10    IF COMMON
          NZ     X0,CLU5     IF F.P.
          FATAL  E.LV6       LEVEL DECLARATION ON NON F.P. ITEM 
          SA7    A3          (LEV,LEVN) [WBI] = 0 
          EQ     CLU10
 CSB      SPACE  4,10 
**        CSB -  CHECK SEQUENCE BREAK.
* 
*                DECIDES WHETHER A SEQUENCE BREAK (END OF BASIC BLOCK)
*         IS NECESSARY. IF SO, CALLS *OIL* TO OUTPUT THE IL.
*         IF A LABEL IS TO BE DEFINED, THE IL WILL BE FLUSHED.
* 
*         IF THE CURRENT ACCUMULATED IL SEGMENT IS LARGE, IT WILL 
*         BE FLUSHED.  THEREFORE CSB MUST NOT BE CALLED IF THE IL 
*         IS NOT IN A FLUSHABLE STATE.
* 
*         EVEN IF THE SEGMENT IS NOT FLUSHED, IT MAY BE TOO LONG
*         FOR SQUEEZE TO BE PROFITABLE.  IF SO, (CURST) IS RESET
*         TO LIMIT THE REGION EXAMINED BY PAR/SQZ.
* 
*         ENTRY  (X2) = LABEL TO BE COMPILED (TP. FORMAT).
*                     .ZR. IF NO LABEL DEFINITION.
*         USES   ALL BUT A0.
  
  
 PAR.TH   EQU    50*Z=TURP
  
 CSB      SUBR   =           ENTRY/EXIT...
          NZ     X2,CSB4     IF LABEL TO BE DEFINED 
          SA1    T=PAR
          SA3    N.MAXIL
          IX0    X1-X3
          PL     X0,CSB6     IF SEGMENT LENGTH EXCEEDS THRESHOLD
          SX6    X1-PAR.TH
          SA3    CURST
          IX0    X3-X6
          PL     X0,EXIT.    IF SQUEEZE LENGTH WITHIN LIMIT 
          SA6    A3          INDICATE NO SQUEEZING PAST HERE
          EQ     EXIT.
  
*         EMIT TURPLE TO DEFINE THE LABEL, AND FLUSH THIS 
*         IL SEGMENT. 
  
 CSB4     BX4    X2          (P1) = LABEL 
          MX5    0           (P2) = NIL 
          EMIT   OPBSS,*
 CSB6     CALL   OIL         OUTPUT INTERMEDIATE LANGUAGE SEGMENT 
          EQ     EXIT.       EXIT...
 CUF      SPACE  4,10 
**        CUF - CHECK UNDEFINED FUNCTION. 
* 
*         USES   X - 1,2,3,6,7  A - 1,2,3,6  B - 2,3
  
 CUF      SUBR   0           ENTRY/EXIT...
          SA2    MOD
          SA1    S=VALUE
          HX2    MO.FUN 
          PL     X2,EXIT.    IF NOT COMPILING A FUNCTION
          SB2    X1 
          LX1    1
          SB2    X1+B2       CONVERT TO INDEX 
          SA1    T.SYM
          SX1    X1+B2
          =A1    X1+WB.W     A1 = ADDRESS OF *WB* 
          BX2    X1 
          SBIT   X2,WB.MDFP 
          PL     X2,CUF10    IF NO BOOLEAN ENTRY POINTS 
          SA2    A1+M.INT*Z=SYM    X2 = *WB* VALUI. 
          SA3    A1+M.REAL*Z=SYM   X3 = *WB* VALUR. 
          LDBIT  X0,WB.DEFP 
          BX7    X0*X1       ISOLATE DEF BIT OF VALUE.
          BX6    X0*X2       ISOLATE DEF BIT OF VALUI.
          BX7    X6+X7
          BX6    X0*X3       ISOLATE DEF BIT OF VALUR.
          BX7    X6+X7       X7 = LOGICAL SUM OF DEF BITS 
          LDBIT  X0,WB.MDFP 
          BX7    X7+X0       SET *MUST DEFINE* BIT
          BX6    X1+X7
          SA6    A1          UPDATE VALUE. *WB* 
          BX6    X2+X7
          SA6    A2          UPDATE VALUI. *WB* 
          BX6    X3+X7
          SA6    A3          UPDATE VALUR. *WB* 
  
 CUF10    =B2    0
          SB3    Z=SYM*N.TYPE      LOOP LIMIT 
          LDBIT  X3,WB.DEFP 
          LDBIT  X4,WB.MDFP 
  
 CUF20    SA2    A1+B2
          BX6    X3*X2       ISOLATE DEF BIT
          LX6    WB.MDFP-WB.DEFP
          BX7    X4*X2       ISOLATE 1REF BIT 
          BX7    X7-X6
          ZR     X7,CUF30    IF NO ERROR
          SX1    B2 
          SX2    Z=SYM
          IX1    X1/X2       X1 = OFFSET INTO MOD.DPC TABLE 
          SA2    X1+MOD.DPC 
          BX6    X2 
          SA6    FILL.
          FATAL  E.SU06 
  
 CUF30    SB2    B2+Z=SYM 
          GE     B2,B3,EXIT. IF DONE
          EQ     CUF20
 CUL      SPACE  4,10 
**        CUL - CHECK UNDEFINED LABELS. 
* 
*         CALLS  CDD, LJS, PDM
  
  
 CUL      SUBR               ENTRY/EXIT...
          SA3    T.SYM
          SA2    T=SYM
          SB3    Z=SYM
          SA4    X3-Z=SYM+WB.W  INITIALIZE FETCH REGISTER 
          SB4    X2 
  
 CUL2     SA4    A4+B3       FETCH SYMBOL 
          ZR     B4,CUL6     IF TABLE EXHAUSTED 
          SB4    B4-B3       DECREMENT TABLE LENGTH 
          CLAS=  X1,WB,(SDEF,FDEF,NDEF) 
          BX6    X1*X4
          HX4    WB.LAB 
          MI     X4,CUL4     IF THIS ENTRY IS A STATEMENT LABEL 
          LX4    WB.LABP+1
          CLAS=  X1,WB,(AGN,AGO2) 
          BX6    -X1*X4 
          SA6    A4          CLEAR THE BITS 
          HX4    WB.AGO2
          PL     X4,CUL2     IF VAR NOT OBJECT OF *GO TO* 
          LX4    WB.AGO2P-WB.AGNP 
          MI     X4,CUL2     IF VAR APPEARED IN *ASSIGN* STATEMENT
          =A1    A4-WB.W+WA.W      X1 = *WA*
          MX7    WA.SYML
          BX7    X7*X1       X7 = 0LSYMBOL
          ERRNZ  WA.SYMP+WA.SYML-60D
          SA7    FILL.
          FATAL  E.AS6       ** GOTO I WITHOUT ASSIGN 10 TO I 
          EQ     CUL2 
  
 CUL4     NZ     X6,CUL2     IF LABEL DEFINED 
          =A5    A4-WB.W+WA.W 
          AX5    WA.STLP     EXTRACT LABEL
          CALL   LJS         LEFT JUSTIFY STATEMENT LABEL 
          SA6    FILL.
          FATAL  E.MS        ** MISSING STATEMENT NUMBER ** 
          EQ     CUL2 
  
**        CHECK FOR UNTERMINATED DO LOOPS AND IF BLOCKS 
  
 CUL6     SA2    T=BLST 
          ZR     X2,CUL9     IF NO UNTERMINATED BLOCK STRUCTURES
  
 CUL7     SA1    T.BLST 
          SB4    X2-1 
          SA4    X1+B4       FETCH COUNT WORD 
          LX4    -LC.CNTP 
          SX0    X4          EXTRACT SEGMENT SIZE 
          ERRNZ  18-LC.CNTL 
          LX4    LC.CNTP-LC.DOP 
          SX4    X4          EXTRACT DO INDEX 
          ERRNZ  18-LC.DOL
          ZR     X4,CUL8     IF UNTERMINATED BLOCK IF 
          IX2    X2-X0
          IX4    X1+X2
          SA4    X4+DO.W
          AX4    DO.TAGP
          MX3    -DO.TAGL 
          BX4    -X3*X4 
          ZR     X4,CUL8     IF I/O DO
          SB5    X4 
          ERRNZ  18-DO.TAGP 
          SX4    B5+B5
          SB5    X4+B5       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          SA3    T.SYM
          SA5    X3+B5       FETCH DPC OF STATEMENT LABEL 
          AX5    WA.STLP     EXTRACT LABEL
          CALL   LJS         LEFT JUSTIFY STATEMENT LABEL 
          SA6    FILL.
          FATAL  E.DO09      UNTERMINATED DO LOOP 
 CUL8     SA2    T=BLST 
          IX2    X2-X0
          SHRINK A2,X2       SCRATCH PROCESSED SEGMENT
          NZ     X2,CUL7     IF MORE TO PROCESS 
          SA1    IFLEVEL
          ZR     X1,CUL9     IF NO UNTERMINATED BLOCK IFS 
          CALL   CDD         CONVERT TO DPC 
          SA6    FILL.
          FATAL  E.IF17 
  
 CUL9     SA1    T=C$IF 
          ZR     X1,EXIT.    IF NO UNTERMINATED C$ IFS
          CALL   CDD         CONVERT TO DPC 
          SA6    FILL.
          SHRINK A1,B0
          FATAL  E.C$15 
          EQ     EXIT.
 CUS      SPACE  4,10 
**        CUS -  CHECK UPCOMING STATEMENT.
* 
*                ROUTINE IS ENTERED BY THE FRONT END CONTROLLER (*FEC*) 
*         WHENEVER A STATEMENT WHICH MAY GENERATE CODE IS ENCOUNTERED.
* 
*         OUTPUT OBJECT TIME REPRIEVE TURPLE, WHEN NECESSARY
* 
*         IF (HANGER) " 0 -- JUMP TO IT TO COMPLETE ANY HANGING PARTS OF
*                PREVIOUS STATEMENT.
* 
*                NOTE THAT A "CONTINUE" WITHOUT A LABEL CAN NEVER CAUSE 
*         ANY CODE TO BE GENERATED, AND IS THEREFORE IGNORED. 
* 
*         ENTRY  (X5) = (TB=KEY) SHIFTED TO KW.GENP IN BIT 59.
*                ("SB.STN") =  COLUMNS 1-5 OF STATEMENT.
* 
*         EXIT   INTO *FEC*.
* 
*         USES   ALL BUT  A0. 
* 
*         CALLS  ALC, CSB, GSL
  
  
 CUS      SUBR   0           ...ENTRY/EXIT... 
          SA1    TB=LABR
          NZ     X1,CUS3     IF LABEL PRESENT, CHECK HANGER 
          SA2    TB=TYPE
          SB7    KW=CONT
          LX2    -KW.JMPP 
          SB7    -B7
          SB7    X2+B7
          ERRNZ  18-KW.JMPL 
          ZR     B7,EXIT.    IGNORE NULL *CONTINUE* STATEMENTS
  
  
**        IF COMPILATION OF THE PRECEDING STATEMENT WAS DEPENDENT UPON
*         THE NEXT STATEMENT (I.E., THIS ONE), IT HAS BEEN LEFT HANGING.
*         IT IS NOW TIME TO FINISH IT UP -- 
*                WE JUMP TO WHOMSOEVER HATH PUT HIS ADDRESS IN (HANGER).
*                HE DOES HIS THING AND RETURNS TO *CUS.RET*.
*         NOTE THAT ONLY STATEMENTS WHICH MAKE PARSED FILE ENTRIES MAY
*                BE *HUNG*. 
  
 CUS3     SA3    HANGER 
          ZR     X3,CUS.RET  IF NO *HANGING* COMPILATION
          =X6 
          SB7    X3 
          SA6    A3          CLEAR *HANGER* FLAG
          JP     B7          COMPILE ANY HANGING PIECES 
  
  
**        CUS.RET -  RETURN TO *CUS* FROM *HANGER* PROCESSING.
* 
*         SET (TRLINE) = CURRENT LINE NUMBER, TO BE ADDED TO THE
*         NEXT TURPLE OUT.
*                PREPARE TO EXIT -- 
*         IF THIS IS THE END OF A BASIC BLOCK (SEQUENCE BREAK), THEN WE 
*                FLUSH THE PARSED FILE BY CALLING *ARITH*.
*         IF THERE WAS A LABEL, COMPILE THE BSS TO DEFINE IT, 
*         CHECK (NOPATH) AND ISSUE APPROPRIATE WARNING, AND SET (FLOW)
*                TO INDICATE DEAD CODE. 
  
 CUS.RET  BSSENT 0           ...RETURN FROM *HANGERS*.
          SA1    TB=TYPE
          SBIT   X1,KW.NBSP 
          MI     X1,CUS4     IF NO BEGINNING-OF-STATEMENT TO ISSUE
          ALLOC  T.PAR,Z=TURP 
          SA4    REFLIN      EMIT BEGINNING-OF-STATEMENT
          SX2    V=NOOP 
          BX7    0           (1OP) = (2OP) = NIL
          LX4    -XR.LINEP+TH.LINEP 
          =A7    B7-Z=TURP+OR.2OP 
          LX2    TH.SKELP 
          SX6    O.SPACE
          BX6    X2+X6       LINE NUMBER/OPERAND VALUE
          BX6    X4+X6       AND NOOP SKELETON = BOS TURPLE HEADER
          =A7    A7-OR.2OP+OR.1OP 
          =A6    A7-OR.1OP+OR.OPR 
  
 CUS4     BSS    0
          SA2    CSLTAG 
          LX2    TP.ORDP
          RJ     CSB         CHECK FOR SEQUENCE BREAK 
          SA2    NOPATH 
          SA4    CSLTAG 
          SA3    FLOW 
          BX6    X2+X3
          ZR     X4,CUS6     IF NO LABEL PRESENT
          BX6    0           CLEAR (FLOW) IF LABEL
  
 CUS6     SA6    A3          RESET (FLOW) 
          SA6    A2          RESET (NOPATH) 
          ZR     X6,EXIT.    IF NO STATEMENT NUMBER REQUIRED
          SA3    TB=TYPE
          SBIT   X3,KW.ILP
          MI     X3,EXIT.    IF IMPLIED LABEL ON THIS STATEMENT 
          WARN   E.NP        *NO PATH TO THIS STATEMENT*
          EQ     EXIT.       EXIT...
 CVD      SPACE  4,8
**        CVD -  CHECK VARIABLE DIMENSION IRREGULARITIES
* 
*         CHECK ALL VARIABLES IN SYMBOL TABLE FOR THOSE WITH WB.VDS 
*         STILL SET.  THIS INDICATES THAT AN AJUSTABLE OR ASSUMED SIZE
*         ARRAY DIDNT APPEAR AS A FORMAL PARAMETER OR THAT A VARIABLE 
*         USED AS A VARIABLE SUBSCRIPT WAS NOT A FORMAL PARAMETER OR IN 
*         COMMON. 
  
  
 CVD      SUBR               ...ENTRY/EXIT... 
          SA2    T.SYM
          SA3    T=SYM
          =B6    X3-Z=SYM+WB.W
 CVD1     MI     B6,EXIT.    IF LIST IS EXHAUSTED 
          SA3    X2+B6
          =B6    B6-Z=SYM 
          SBIT   X3,WB.LABP 
          MI     X3,CVD1     IF STATEMENT LABEL 
          SBIT   X3,WB.VDSP/WB.LABP 
          PL     X3,CVD1     IF NOT USED AS VARIABLE SUBSCRIPT OR ARRAY 
          SBIT   X3,WB.ARYP/WB.VDSP 
          SB7    E.DM03 
          MI     X3,CVD2     IF ARRAY 
          SB7    E.DM04 
 CVD2     MX1    WA.SYML
          =A4    A3-WB.W+WA.W 
          BX6    X1*X4
          SA6    FILL.
          FATAL  B7 
          EQ     CVD1 
 FEP      SPACE  4,10 
**        FEP - FRONT END PRESETS.
* 
*         PRESET FRONT END CELLS. 
  
  
 FEP      SUBR   0           ...ENTRY/EXIT... 
          SX6    0
          SA6    TYPD        IMPLICIT STATEMENT LETTERS 
          SA6    CURST       CURRENT START FOR PARSED FILE SQUEEZE
          SA6    FLOW        DEAD CODE FLAG 
          SA6    HANGER      HANGING COMPILATION INDICATOR
          SA6    IO.TEM      I/O TEMP USE COUNT 
          SA6    NARGS       NUMBER OF ARGUMENTS
          SA6    NOPATH      STATEMENT LABEL REQUIRED FLAG
          SA6    NTRCNT      COUNT OF *ENTRY* STATEMENT 
          SA6    RTNCNT      COUNT OF *RETURN* STATEMENTS 
          SA6    BLNKCOM     BLOCK NUMBER OF BLANK COMMON 
          SA6    CHARDCL     CHARACTER DECLARATION PRESENT
          SA6    SAVE        SAVE INDICATOR 
          SA6    USAVE       UNIVERSAL SAVE INDICATOR 
          SA6    LEVEL       NO LEVEL STATEMENTS
          SA6    LEVEL0      NO LEVEL 0 STATEMENTS
          SA6    LEVEL2      NO LCM/ECS 
          SA6    N.EPL       NO ENTRIES WITH UNIQUE FP LISTS
          SA6    PARAMC      COUNT OF PARAMETERS (SYMBOLIC CONSTANTS) 
          SX6    LM.1ST 
          SA6    LEXMODE     SET TO 1ST TIME IN 
  
          =X7    FEC=1ST
          =X6    PASS=FE     INDICATE IN FRONT END PROCESSING 
          SA7    STAGE       SIGNAL THAT A *FIRST CARD* IS NEEDED.
          SA6    PASS 
          SA2    CO.SEQ 
          SA7    A7+B1
          NZ     X2,FEP1     IF SEQ MODE
  
          MX6    0
          SA6    LINES       SET TO *1ST LINE IS IN (CP.BUF)* 
          SA2    =10H        1
          BX6    X2 
          SA6    CP.FLIN     NUMBER FIRST LINE OF SOURCE
  
  
**        RE-SET NATURAL TYPE TABLE TO -- 
*                IMPLICIT REAL (A-H), INTEGER (I-N), REAL (O-Z) 
  
 FEP1     SA1    FEPA        NATURAL TYPE PRESETS 
          SA2    A1+B1
          =X6    M.BOOL 
          =X7    M.LOG
          SA6    NAT.TYP     BOOLEAN
          LX6    X1 
          =A7    A6+1        LOGICAL
          BX7    X2 
          =A6    A7+1        INTEGER
          =X6    X7+1 
          =A7    A6+1        REAL 
          =X7    X6+1 
          =A6    A7+1        DOUBLE 
          =X6    X7+1 
          =A7    A6+1        COMPLEX
          =A6    A7+1        CHARACTER
  
          SETMEM NAT.LEN,26/2 
  
          EQ     EXIT.       EXIT...
  
 FEPA     CON    "INT"+M.INT NATURAL TYPE PRESETS 
          CON    "REAL"+M.REAL
 FVD      SPACE  4,15 
**        FVD -  FLUSH VARIABLE DIMENSION CODE. 
* 
*         COMPILES CODE TO PRE-COMPUTE VARIABLE DIMENSION ADDRESS 
*         FUNCTIONS, WHEN NECESSARY.  WILL NOT COMPILE ANYTHING IF NO 
*         VARIABLE DIMENSIONS OCCURRED IN THE SUBPROGRAM. 
*         FINISHES OPERAND ENTRIES OF TURPLES WITH INFORMATION
*         WHICH MAY HAVE BEEN DECLARED AFTER THE DIMENSION BOUNDS 
*         EXPRESSIONS WERE COMPILED.
* 
*         ENTRY  T.VDIM TABLE CONTAINS *TURPLES* TO BE PROCESSED. 
*                T.PAR IS A NULL TABLE. 
* 
*         EXIT   T.VDIM LENGTH = 0. 
*                CODE DEFINED BY *TURPLES* IN *T.VDIM* SENT TO
*                INTERMEDIATE FILE. 
* 
*         USES   ALL
* 
*         CALLS  ALC, CT1, MVE= 
  
  
 FVD      SUBR   0           ENTRY/EXIT...
          SA3    T=VDIM 
          SX0    X3-Z=TURP-1
          PL     X0,FVD0     IF VARDIM CODE PRESENT 
          SHRINK A3,B0       TRASH V=BVT TURPLE 
          EQ     EXIT.
  
*         ADD IN ALL TP. ATTRIBUTES (THESE MAY HAVE BEEN DECLARED AFTER 
*         THE DIMENSION INFORMATION CONSTRUCTION).
  
 FVD0     SA5    T.VDIM 
          =B2    X3+OR.1OP
          SB3    X5 
          CLAS=  X4,TP,(BIAS,ATTR)
          CLAS=  X7,TP,(INTR,SHRT)
  
 FVD1     SB2    B2-Z=TURP
          MI     B2,FVD4     IF FINISHED
          SA3    B2+B3       FETCH 1OP
          =B4    0           INDICATE 1OP 
  
 FVD2     BX2    X7*X3
          NZ     X2,FVD3     IF TP.INTR OR TP.SHRT
          BX5    X4*X3       PRESERVE BIAS AND EXISTING ATTRIBUTES
          HX3    TP.ORD 
          AX3    -TP.ORDL    EXTRACT ORDINAL
          LX0    X3 
          RJ     CT1         GET TP. FORMAT (WITH COMPLETE INFORMATION) 
          BX6    X6+X5       RESTORE BIAS 
          SA6    A3 
  
 FVD3     NZ     B4,FVD1     IF JUST PROCESSED 2OP
          =A3    A3-OR.1OP+OR.2OP 
          =B4    1           INDICATE 2OP 
          EQ     FVD2        LOOP FOR 2OP 
  
*         FLUSH T.VDIM IL TO T.PAR
  
 FVD4     MX4    0
          BX5    0
          EMIT   V=EVD,,T.VDIM  END VARDIM INDICATOR
          SA3    T=VDIM 
          SB6    X3 
          ALLOC  T.PAR,X3    ALLOCATE SPACE FOR TURPLES 
          SX3    B7-B6       DESTINATION ADDRESS
          SA1    T=VDIM      WC 
          SA2    T.VDIM      SOURCE ADDRESS 
          MOVE   X1,X2,X3    MOVE *TURPLES* TO PARSER TABLE 
          SHRINK T=VDIM      COLLAPSE T.VDIM
          EQ     EXIT.       EXIT...
 OIL      SPACE  4,10 
**        OIL - OUTPUT IL.
* 
*         OIL PASSES THE CURRENT SAVED INTERMEDIATE LANGUAGE (IL) 
*         OFF TO A CODE GENERATOR.  THE HANDOFF IS ACCOMPLISHED BY
*         CALLING *PIS - PUBLISH IL SEGMENT*.  THERE ARE TWO VERSIONS 
*         OF PIS -- 
* 
*         IN QCG MODE, PIS ACTUALLY CRANKS UP AND ISSUES
*                THE PREBINARY. 
*         IN CCG MODE, THE IL IS WRITTEN TO A FILE (F.IL) TO
*                AWAIT LATER EXPANSION BY THE BRIDGE. 
* 
*         THE MAIN FUNCTIONS OF OIL ARE ADMINISTRATIVE. 
*         (A)  STATISTICS, SNAPS, AND TEST MODE CHECKS. 
*         (B)  DECIDE WHETHER IL IS OR CAN BE SUPPRESSED. 
*         (C)  CALL PIS.
*         (D)  RESET PARSER FOR NEXT SEGMENT. 
*         USES   ALL (REALLY).
* 
*         USES   ALL. 
*         CALLS  PIS, SN.PAR .
  
  
 OIL      SUBR   =           ...ENTRY/EXIT... 
  
 .TEST    IFEQ   TEST,ON
          SA2    CO.SNAP
          LX2    1RO
          PL     X2,OIL2     IF *SNAP=O* NOT SELECTED 
          CALL   SN.PAR      PRINT IL SEGMENT 
  
 OIL2     SA5    PARSLEN
          SA4    T=PAR
          MX6    X4+X5
          SA6    A5          RESET MAXIMUM PARSED FILE LENGTH 
 .TEST    ENDIF 
          SA2    N.CT 
          SA3    N.CTMAX
          BX6    0
          MX7    X2+X3       RESET MAX CHAR TEMPS 
          SA6    A2 
          SA7    A3 
  
          SA1    ERR=K
          NZ     X1,OIL4     IF CATASTROPHIC ERRORS IN IL SEGMENT 
          SA1    WO.QC
          SA2    T=PAR
          MI     X1,OIL4     IF CODE GENERATION SUPPRESSED
          ZR     X2,OIL4     IF PARSED FILE EMPTY 
          SA1    PASS        CURRENT PASS 
          BX7    X1 
          SA7    OILA        SAVE CURRENT PASS
          CALL   PIS         PUBLISH IL SEGMENT 
          SA1    OILA 
          BX6    X1 
          SA6    PASS        RESTORE FORMER PASS
 OIL4     BX6    0
          SA6    CURST       RESET STARTING PASS 1 BLOCK
          SHRINK T=PAR,X6    CLEAR OUT PARSED FILE
  
 .TEST    IFEQ   TEST,ON
          SA2    OILB 
          SX7    X2+B1       COUNT SEGMENTS PROCESSED 
          SA7    A2 
 .TEST    ENDIF 
          EQ     EXIT.
  
 OILA     CON    0           SAVE CURRENT PASS
 OILB     CON    0           NUMBER OF SEGMENTS PROCESSED 
 PUP      SPACE  4,10 
**        PUP - PROGRAM UNIT PRESETS. 
* 
*         PERFORMS INITIALIZATION FOR EACH PROGRAM-UNIT OF THE BATCH. 
*         PUP LOGICALLY SHOULD BE CALLED BY THE 
*         PROGRAM UNIT CONTROLLER (PUC), BUT, CERTAIN 
*         HIGHER OVERLAY INITIALIZATION MUST BE DONE FIRST
*         THEREFORE, IT IS CALLED BY FEC AND RESIDES HERE.
* 
*         EXIT   ALL APPROPRIATE CELLS, COUNTERS AND TABLES HAVE BEEN 
*                SET TO THEIR INITIAL VALUES. 
  
 PARMIN   EQU    200B        MINIMUM ALLOCATION FOR PAR 
  
 PUP      SUBR   0           ENTRY/EXIT...
  
*         IF X-REF SELECTED ACTIVATE REF. 
  
          SA2    =XCO.LOR 
          ZR     X2,PUP1     IF CO.LOR = 0 */X-REF NOT SELECTED.
          ACTTAB REF,(DECL,EXU)    ACTIVATE REF ON DECL AND EXU PHASES
  
*         TURN ON DECL PHASE. 
  
 PUP1     SA1    =XTV=DECL
          SX7    PARMIN 
          SA7    =XALC.PAR   SET MIN. ALLOC FOR PAR 
          BX7    X1 
          SA7    =XTV=CUR    TURN ON DECL PHASE 
  
**        COLLAPSE TABLES TO INITIAL LENGTHS
  
          SA4    O.TABS 
          SA2    L.TABS 
          SB2    N.TABLE*FUDGE
          SB2    B2+L=TABLE 
          SB2    -B2
          SX5    X2+B2
          LX7    X2 
          SB2    N.TABLE-1
  
  
**        INITIALLY, AMOUNT OF AVAILABLE SPACE IS --
*         A = (SIZCORE) - N*FUDGE - L=TABLES
  
          PX2    X5          (X2) = AVAILABLE 
          IX7    X7+X4       (X7) = LWA TABLES
          NX1    X2 
          SA7    T.END
  
 PUP2     SA3    B2+RATES 
          FX2    X3*X1
          SX6    X3 
          UX0,B7 X2 
          =B2    B2-1 
          =X3    X3+FUDGE    = INIT(I) + FUDGE
          LX2    X0,B7
          IX5    X2+X3
          IX7    X7-X5
          SA6    B2+SIZES+1  SET INITIAL SIZE 
          SA7    B2+BASES+1  SET INITIAL ORIGIN 
          PL     B2,PUP2     LOOP THRU TABLES 
          BX7    X4 
          SA7    A7          RESET ORIGIN OF LOWEST TABLE 
          MX6    0
          SA6    NSQZLH      SQUEEZE LONG HOLLERITH FLAG
          SA6    N.AP        COUNT OF AP-LISTS
          SA6    N.ARP       INDICATE NO ALTERNATE RETURN YET 
          SA6    N.BUF       SPACE ALLOCATED TO BUFFERS (STATIC MODE) 
          SA6    N.CPL       LENGTH OF COPY AP AREA 
          SA6    N.FP        NUMBER OF FORMAL PARAMETERS
          SA6    N$LC        NUMBER OF FP LOCAL COPY CELLS
          SA6    N.CT 
          SA6    N.CTMAX     MAX CHAR TEMP AREA 
          SA6    N.DOB       COUNT OF DO-BEGIN LABELS 
          SA6    N.ST        COUNT OF STATEMENT TEMPS 
          SA6    N.STMAX     MAX TEMPS IN ANY STATEMENT 
          SA6    N.VD        COUNT OF VARDIM EXPRESSIONS
          SA6    FAILSFT     CATASTROPHE IN TABLES
          SA6    LOSTREF     REFERENCE COUNT
          SA6    MOD         PROGRAM UNIT MODE
          SA6    IFLEVEL     BLOCK IF LEVEL 
          =X6    1
          SA6    N.GL        COUNT OF GENERATED LABELS
  
  
**        PRESET T.SYM WITH SOME SPECIAL SYMBOLS. 
*         ORDINAL ZERO OF T.SYM WILL CONTAIN ZEROS AT ALL TIMES.
*         INITIALIZE VALUES OF SYMORD CELLS.
  
          SHRINK T=SYM
          ALLOC  T.SYM,Z.SYMIL
          BX3    X1          DESTINATION = FWA (T.SYM)
          LX1    X2          WORD COUNT = LENGTH OF (T.SYM) 
          SX2    F.SYMIL     SOURCE 
          MOVE   X1,X2,X3 
  
          SX6    Z.SYMIL/Z=SYM     NUMBER OF ENTRIES (ORDINALS) PRESET
          SA6    NEXTORD     PRESET SYM. TAB. ORDINAL COUNTER 
  
          MX6    1           MARK ALL HASH VECTOR ENTRIES AS EMPTY
          SETMEM HASHTBL,Z.HASH,X6
  
          SETMEM F.SORD,Z.SORD  CLEAR SYMORD CELLS
          LIST   G
 SORD     HERE               SET KNOWN SYMORDS
          LIST   *
  
  
**        PRESET DIM TABLE WITH A FAKE ENTRY WHICH SAYS --
*                (NUMBER OF DIMS ) = 1
*                (LENGTH OF ARRAY) = 1
  
          ALLOC  T.DIM,1+Z=DD  HEADER + DIMENSION DESCRIPTOR
          BX3    X1 
          LX1    X2          WORD COUNT = LENGTH OF (T.DIM) 
          MOVE   X1,PUPA,X3 
  
  
**        PRESET VARDIM TABLE WITH A BEGIN-VAR-DIM TURPLE.
  
          MX4    0
          BX5    0
          EMIT   V=BVD,,T.VDIM
  
  
**        PRE-ENTER COMMON BLOCK TABLE WITH --
*                0.  PROGRAM RELOCATION BLOCK 
  
          SA1    T.BLKS 
          SETMEM X1,Z=BLKS
  
*         PRE-ENTER COMMON TAG TABLE WITH NULL ENTRY. 
  
          SA1    T.COMM 
          SETMEM X1,1 
  
 .T       IFEQ   TEST,ON
          SA6    =XALC=CNT
          SA6    MOVES       NUMBER OF STORAGE MOVES
 .T       ENDIF 
  
  
          SETMEM F.LBT,Z.LBT,X6    SET ALL LOCAL BLOCKS EMPTY 
  
  
**        SET UP MISCELLANEOUS CELLS. 
  
          MX7    0
          SA7    =XOVCFLG 
          MX7    1
          SA7    NOLIST      SET TO *LIST,ALL* DEFAULT
          MX7    0
          =X6    -1 
          SA7    WANFP       INITIALIZE WA.NFP CELL 
          SA6    REFLIN 
          SA2    =1H
          LX7    X2 
          SX5    B1 
          SX6    HDRBL
          LX5    30 
          BX6    X6+X5
          SA6    O.STITL
          SA7    TL.PTYP     BLANK OUT PROGRAM TYPE 
          =A7    A7+1        BLANK OUT NAME 
          SA7    A7-1+ERFO   BLANK OUT IN E-FILE HEADER 
          =A7    A7+1 
  
*         PRESET ERROR COUNT CELLS
  
          SB2    N.ERRT 
          SETMEM B2+ERRTYP,B2 
          SA6    E=TOTAL
          SA6    ERRORS 
  
*         INITIALIZE WORKING COPY OF DIRECTIVE OPTIONS, EQUAL TO THEIR
*         CONTROL STATEMENT VALUES. 
  
          MOVE   L.C$,CO.C$,WO.C$ 
          SA1    CO.LOR 
          SA2    ERT=ON 
          MI     X1,PUP60    IF REFERENCE MAP SELECTED
          SA2    ERT=OFF
  
 PUP60    BX7    X2 
          SA7    ERT         SET REFERENCE MAP SWITCH TO ON/OFF 
          SA1    CO.LOS 
          SA2    LEXFLG 
          MX3    1           SET TO *HEADER DELAY*
          MI     X1,PUP70    IF PROGRAMMER SELECTED A LISTING 
          BX3    0           SET TO *NO HEADER DELAY* 
  
 PUP70    LX3    LF.HDRP-59 
          BX6    X2+X3       MERGE *HDR* BIT FLAG 
          SA6    A2 
          EQ     EXIT.       EXIT...
  
 PUPA     VFD    DH.ATTRL/0,DH.PSL/1,DH.RAL/0,DH.DIML/1 
          VFD    30/0,D1.SPANL/1
          VFD    D2.LBL/1,D2.UBL/1
 RLS      SPACE  4,10 
**        RLS - RELOCATE LOCAL SAVE VARIABLES.
* 
*         RELOCATE EACH LOCAL SAVE VARIABLE WITH RESPECT
*         TO THE LOCAL SAVE BLOCK. (S$A$V$E)
* 
*         ENTRY  END OF PROGRAM UNIT HAS BEEN ENCOUNTERED 
* 
*         EXIT   LOCAL SAVE VARIABLES HAVE BEEN RELOCATED 
* 
*         USES   ALL
* 
*         CALLS  ALC
  
  
 RLS      SUBR   0           ENTRY/EXIT.
          SA1    SAVE 
          SA2    USAVE
          BX1    X1+X2
          ZR     X1,EXIT.    IF NO SAVE STATEMENTS APPEARED 
  
**        THE FOLLOWING CODE SOLVES THE VALUE. STORAGE ALLOCATION 
*         PROBLEM BY SEARCHING THE LIST OF VALUE. SYMBOLS IN REVERSE
*         ORDER AND ASSIGNING THE BASE MEMBER THE TYPE OF THE FIRST 
*         ONE WHICH HAS WB.DEF SET. IF NONE OF THEM ARE DEFINED, A
*         ZERO WILL BE STORED AT S=VALUE. 
  
          SA1    S=VALUE
          SB2    X1 
          LX1    1
          SB2    X1+B2       CONVERT TO INDEX 
          SA2    T.SYM
          SB2    B2+WB.W
          SB7    X2+B2       SAVE ADDRESS OF BASE MEMBER
          SB2    B2+Z=SYM*N.TYPE
          SA2    X2+B2       INITIALIZE FETCH REG 
          SX7    M.CHAR 
  
 RLS5     SA2    A2-Z=SYM 
          SBIT   X2,WB.DEFP 
          MI     X2,RLS6     IF A VALUE. IS DEFINED 
          =X7    X7-1 
          PL     X7,RLS5     IF NOT DONE
  
**        HERE IF NO VALUE. HAS BEEN DEFINED. 
  
          MX6    0
          SA6    A1 
          EQ     RLS7 
  
 RLS6     LX7    WB.MODEP    POSITION NEW MODE
          MX0    -WB.MODEL
          LX0    WB.MODEP 
          SA2    B7          *WB* OF BASE MEMBER
          BX2    X0*X2       ERASE PREVIOUS MODE
          BX6    X2+X7       FILL IN NEW MODE 
          SA6    A2          UPDATE *WB*
  
*         ALLOCATE FOR A SPECIAL LOCAL SAVE BLOCK (S$A$V$E).
  
 RLS7     ALLOC  T.BLKS,Z=BLKS
          SA1    =7LS$A$V$E 
          SX5    X2-Z=BLKS
          LX5    WC.RBP      RBS =  LEN(T.BLKS) - Z=BLKS
          BX6    X1 
          SA6    B7-Z=BLKS   BNAME[CA.] = 7LS$A$V$E 
  
*         SAVLEN = 0. 
*         FOR EACH SAVED UNIQUE LOCAL VARIABLES, RELOCATE ITS RA
*         BY SETTING: 
*                RA[WC.] = RA[WC.] + SAVLEN 
*                RB[WC.] = RBS
*                (COM,SAVE) [WB.] = (1,1) 
*         SAVLEN = SAVLEN + SIZE
  
          SA1    T.SYM
          SA2    T=SYM
          SB3    Z=SYM
          =A3    X1+WB.W
          SA1    T.DIM
          SB7    X2 
          BX7    0           SAVLEN = 0 
          SB5    X1 
  
*         PROCESS NEXT WB ENTRY OF T.SYM
*         A3 = WBI ENTRY OF T.SYM 
*         (X5) = RBS
*         (X7) = SAVLEN 
*         (B5) = FWA(T.DIM) 
*         (B7) = SYMLEN 
  
 RLS10    SA3    A3+B3       WBI = WB ENTRY OF T.SYM
          SB7    B7-B3
          ZR     B7,RLS30    IF END OF T.SYM
          CLAS=  X4,WB,(LAB,FP,EXT,NVAR,NLST,PARM,ENT,COM,EQV)
          BX6    X3*X4
          CLAS=  X0,WB,(SAVE) 
          NZ     X6,RLS10    IF NOT UNIQUE LOCAL
          SA1    USAVE
          CLAS=  X2,WB,(COM,SAVE,MAT) 
          CLAS=  X4,WB,(BMEM) 
          BX0    X3*X0       SAVEI = SAVE[WBI]
          BX1    X0+X1       (OR SAVEI WITH UNIVERSAL SAVE FLAG)
          BX6    X3+X2
          ZR     X1,RLS10    IF NOT SAVED LOCAL 
          BX4    X3*X4       BMEMI = BMEM[WBI]
          SBIT   X3,WB.CGSP 
          PL     X3,RLS15    IF NOT COMPILER GENERATED SYMBOL 
          ZR     X4,RLS10    IF NOT BASE MEMBER 
  
 RLS15    SA6    A3          (COM,SAVE)[WBI] = (1,1) [WB.]
          MX4    -WB.MODEL
          LX3    1+WB.CGSP-WB.PNTP
          MX0    -WB.PNTL 
          =A1    A3-WB.W+WC.W      WCI = WC ENTRY OF T.SYM
          BX6    -X0*X3      DTIND = PNT[WBI] 
          SA2    X6+B5       TDI = T.DIM(DTIND) 
          HX2    DH.PS
          AX2    -DH.PSL     SIZE = PS[TDI] 
          LX3    WB.PNTP-WB.MODEP 
          BX6    -X4*X3      MODEI = MODE[WBI]
          SB4    X6-M.CHAR
          MX3    -0          INDICATE TWO WORD ELEMENT
          SB2    X6-M.DBL 
          EQ     B2,B0,RLS20 IF MODE = DOUBLE 
          EQ     B2,B1,RLS20 IF MODE = COMPLEX
          ERRNZ  M.CPLX-M.DBL-1 
          SX3    0           INDICATE SIGLE WORD ELEMENT
          NZ     B4,RLS20    IF NOT MODE CHARACTER
          BX6    X1 
          HX6    WC.CLEN
          AX6    -WC.CLENL   CLENI = CLEN[WCI]
          IX6    X2*X6       SIZE = SIZE *CLENI 
          CW     X2,X6       SIZE = SIZE / 10 
 RLS20    BX1    X1+X5
          LX0    X7 
          BX3    X3*X2
          IX2    X2+X3       SIZE = 2 * SIZE ( IF DOUBLE WORD)
          LX0    WC.RAP 
          BX6    X1+X0
          IX7    X7+X2       SAVLEN = SAVLEN + SIZE 
          SA6    A1          (RB,RA) [WCI] = (RBS,SAVLEN) [WC.] 
          EQ     RLS10
  
*         UPDATE LENGTH OF S$A$V$E BLOCK. 
  
 RLS30    ZR     X7,RLS40    IF SAVLEN .EQ. 0 
          SA1    T.BLKS 
          CLAS=  X2,CB,(SAVE) 
          LX5    -WC.RBP
          LX7    CB.BLENP 
          =B4    X1+CB.W
          BX7    X7+X2
          SA7    X5+B4       (SAVE,BLEN) [T.BLKS(RBS)] = (1,SAVLEN)[CB.]
          EQ     EXIT.
  
*         LOCAL SAVE BLOCK LENGTH .EQ. 0... 
*         SHRINK BLOCK TABLE TO ORIGINAL SIZE.
  
 RLS40    SA1    T=BLKS 
          SHRINK A1,X1-Z=BLKS 
          EQ     EXIT.
 RSC      SPACE  4,10 
**        RSC -  RESET INTRA-STATEMENT CELLS. 
* 
*         EXIT   (ALC.00) = NO REGISTER IS LOCKED.
*                (T=CONB) = LENGTHS OF CON AND CHAR TABLES, AT BEGINNING
*                            OF STATEMENT.  USED TO THROW AWAY CONSTANTS
*                            APPEARING IN A DATA STATEMENT. 
*                RESET OF CELLS.
  
  
 RSC      SUBR   0
          BX6    0
          =X7    CR.REF 
          SA6    DATFLG      CLEAR DATA-KLUDGE 'FLAG' 
          SA6    DTI         CLEAR DO-TERMINATION INDICATOR 
          SA7    REFNUM        -   CURRENT VALUE FOR REFS TO STAT. NO.
          SA6    CSLTAG        -   CURRENT STATEMENT LABEL TAG
          SA6    E=TOTAL       -   CURRENT STATEMENT ERROR COUNT
          SA6    INIF          -   LOGICAL IF INDICATOR 
          SA6    PARMODE       -   PARSE MODE 
          SA6    PARNOW        -   CURRENT PARSE MODE 
          SA6    ZLE
          SA6    ZLEQUAL
          SA6    ZLCOMMA
          SA6    ZLPAREN
          SA6    ZLCOLON
          SHRINK T=SCR,X6    RESET TO ZERO
          SA7    REFVAR 
          SA2    T=CON
          SA1    ALC.00      POINTER TO NO REGISTERS TO RESTORE 
          LX7    X1 
          SHRINK T=CONB,X2   RESET TO START OF CONSTANTS FOR THIS STAT. 
          SA7    ALC.REG     RESET SO NO REGISTERS WILL BE RELOCATED
          EQ     RSCX        EXIT.. 
 SSU      SPACE  4,10 
**        SSU - SET SAVE BIT FOR UNIVERSAL SAVE.
*         FOR UNIVERSAL SAVE, SET SAVE[WB.] FOR ALL LOCAL AND 
*         COMMON VARIABLES. 
  
  
 SSU      SUBR   0           ENTRY/EXIT.
          SA1    USAVE
          SA2    T=SYM
          ZR     X1,EXIT.    IF NO UNIVERSAL SAVE 
          SA3    T.SYM
          SB6    X2 
          CLAS=  X0,WB,(SAVE) 
          SB3    Z=SYM
          =A3    X3+WB.W
          CLAS=  X2,WB,(LAB,FP,EXT,NVAR,NLST,PARM,ENT)
          CLAS=  X4,WB,(BMEM) 
          CLAS=  X5,WB,(CGS)
  
 SSU10    SA3    A3+B3       WBI = WB ENTRY OF T.SYM
          SB6    B6-B3
          ZR     B6,EXIT.    IF END OF T.SYM
          BX1    X3*X2
          BX7    X3*X4       BMEMI = BMEM[WBI]
          NZ     X1,SSU10    IF NOT LOCAL OR COMMON 
          BX6    X3*X5       CGSI = CGS[WBI]
          HX7    WB.BMEM
          HX6    WB.CGS 
          BX7    X7-X6
          NZ     X7,SSU10    IF CGS AND NOT BMEM [EQ.]
          BX6    X0+X3
          SA6    A3          SAVE[WBI] = 1
          EQ     SSU10
          TITLE  FRONT END SUPPORT ROUTINES.
 BBC      SPACE  4,10 
**        BBC -  BASE/BIAS CONVERSION.
* 
*         WILL CONVERT A TP. FORMAT OPERAND TO BASE/BIAS FORM.
* 
*         ENTRY  (X5) = TP.FORMAT OPERAND.
* 
*         EXIT   (X5) = BASE/BIAS CONVERSION. 
* 
*         USES   X - 1,2,5,6,7  A - 1,2  B - 2. 
  
  
 BBC      SUBR   =           ENTRY/EXIT...
          BX6    X5 
          HX6    TP.EQV 
          PL     X6,EXIT.    IF ALREADY IN BASE/BIAS FORM 
          MX7    -TP.ORDL 
          LX6    TP.EQVP+1-TP.ORDP
          BX6    -X7*X6      X6 = SYMTAB ORDINAL
          SA2    T.SYM
          SB2    X6 
          LX6    1
          SB2    B2+X6
          =B2    B2+WB.W     CONVERT TO *WB* INDEX
          SA1    X2+B2       *WB* 
          MX7    -WB.BASEL
          LX1    -WB.BASEP
          BX1    -X7*X1      X1 = SYMORD OF EQUIV. CLASS BASE 
          BX6    X1          SAVE IT FOR LATER
          =A1    A1+WC.W-WB.W      *WC* 
          MX7    -WC.RAL
          LX1    -WC.RAP
          BX1    -X7*X1      X1 = RA OF OPERAND 
          MX7    -TP.BIASL
          BX2    X5 
          HX2    TP.BIAS
          AX2    -TP.BIASL   EXTRACT OPERAND BIAS WITH SIGN EXTEND
          IX1    X1+X2       X1 = NEW BIAS
          BX1    -X7*X1 
          CLAS=  X2,TP,(BIAS,ORD,EQV) 
          LX6    TP.ORDP
          LX1    TP.BIASP 
          BX5    -X2*X5      CLEAR OLD BIAS AND ORD 
          BX5    X5+X6
          BX5    X5+X1       X5 = OPERAND IN BASE/BIAS FORM 
          EQ     EXIT.
 CCT      SPACE  4,10 
**        CCT -  CHECK CONFLICTING TYPES. 
* 
*         POST AN ERROR IF ELEMENT IS GIVEN CONFLICTING TYPE. 
* 
*         ENTRY  (X0) = ORDINAL OF SYMBOL.
*                (X1) = BIT NUMBER OF NEW CLASS.
*                       (CAN ONLY BE ONE BIT AND NEVER BE EITHER -- 
*                            A.  NOT-VAR
*                       OR   B.  VAR
*                (X3) = MASK OF FORBIDDEN CLASSES.
*                (A2) = ADDRESS OF SYMTAB WORD (WB).
* 
*                FILL.= SET TO ELEMENT CURRENTLY BEING CHECKED. 
* 
*         EXIT   IF NO ERROR -- 
*                ONLY (X3) DESTROYED. 
* 
*                IF CONFLICT -- 
*                (X0) = .LT. ZERO 
*                ONLY (B4, B5, B6) PRESERVED. 
  
  
 CCT      SUBR   =           ENTRY/EXIT...
          BX3    X3*X2
          ZR     X3,EXIT.    IF NO CONFLICT 
          NX3,B7             LOCATE LEADING BIT IN CONTENTION 
          SB2    CLASS+47 
          SA1    X1+CLASS    FETCH ERRLIT FOR CANNOT-BE 
          SA3    B2-B7       FETCH ERRLIT FOR CURRENT CLASS 
          BX6    X3 
          SA6    FILL.2 
          LX7    X1 
          SA7    A6+B1
          FATAL  E.VA02 
          MX0    -1          INDICATE ERROR 
          EQ     EXIT.       EXIT...
 CT1      SPACE  4,10 
**        CT1 - CONSTRUCT PASS ONE TAG FORM.
* 
*         ENTRY  (X0) = SYMTAB ORDINAL. 
* 
*         EXIT   (X0) = SYMTAB ORDINAL. 
*                (A2, X2) = SYMTAB ATTRIBUTE WORD (WB). 
*                (X6) = PASS ONE TAG FORM.
*                (B7) = SYMTAB WB INDEX.
*         USES   A1  X3.
  
  
 CT1      SUBR   =           ENTRY/EXIT...
          LX2    X0,B1
          IX3    X2+X0
          ERRNZ  3-Z=SYM
 .TEST    IFNE   TEST 
          MI     X0,"BLOWUP"       IF NEGATIVE ORDINAL
          SA1    T=SYM
          IX2    X3-X1
          PL     X2,"BLOWUP"       IF INDEX .GE. SYMTAB LENGTH
 .TEST    ENDIF 
          SA1    T.SYM
          =B7    X3+WB.W     RETURN (B7) = INDEX OF WB
          SA2    X1+B7       RETURN (A2, X2) = SYMTAB ATTRIBUTE WORD
  
*         FORM *P2 TAG* WORD. 
  
          SX6    X0 
          ERRMI  18-TP.ORDL  IF TRUNCATION PROBLEMS 
          LX6    TP.ORDP
  
*         TEST FOR STATEMENT LABEL
  
          BX3    X2 
          SBIT   X3,WB.LABP 
          MI     X3,EXIT.    IF STATEMENT LABEL 
  
*         COPY FP BIT.
  
          CLAS=  X3,WB,(FP) 
          BX1    X3*X2       EXTRACT (FP) 
          LX1    -WB.FPP+TP.FPP 
          IX6    X1+X6       MERGE (FP) INTO TAG
  
*         COPY MODE FIELD.
  
          LX2    -WB.MODEP
          MX3    -WB.MODEL
          ERRNZ  WB.MODEL-TP.MODEL
          BX1    -X3*X2 
          LX1    TP.MODEP 
          IX6    X6+X1
  
*         COPY EQUIVALENCE BIT. 
*                FOR NON-BASE MEMBERS ONLY, SET (TP.EQV). 
  
          LX2    WB.MODEP+59-WB.EQVP
          MX3    1
          BX1    X3*X2
          LX1    TP.EQVP+1
          IX6    X6+X1
  
*         COPY LCM BIT. 
  
          LX2    WB.EQVP-WB.LCMP
          BX1    X3*X2       EXTRACT (LCM) BIT
          LX1    1+TP.LCMP
          IX6    X6+X1
  
          LX2    WB.LCMP-59  RESTORE (X2) 
          EQ     EXIT.
 STY      SPACE  4,10 
**        STY  - SET NATURAL (IMPLICIT) TYPE
* 
*         ENTRY- NAME IN X6 (LEFT JUST, ZERO FILL)
* 
*         EXIT   (X1) = MODE. 
*                (X2) = CHARACTER LENGTH (0 IF TYPE NOT CHARACTER)
*                (X6) = PRESERVED.
*                (B7) = 1ST CHARACTER OF NAME.
* 
*         DESTROYS  A1. 
  
  
 STY2     AX1    X1,B7       REPOSITION 
          LX6    -6          RESTORE X6 
          SX2    X1-M.CHAR
          SX1    X1          ISOLATE MODE 
          ZR     X2,STY3     IF TYPE CHARACTER
          MX2    0
          EQ     STYX 
  
 STY3     =X2    B7-1 
          LX2    -1 
          MI     X2,STY4     IF ODD LETTER (LOWER HALF OF PAIR) 
          SA2    X2+NAT.LEN  FETCH PAIR 
          AX2    30          UPPER HALF ONLY
          LX2    WC.CLENP 
          EQ     STYX 
  
 STY4     SA2    X2+NAT.LEN  FETCH PAIR 
          SX2    X2          LOWER HALF ONLY
          LX2    WC.CLENP 
  
 STY      SUBR   =           ENTRY/EXIT...
          LX6    CHAR 
          =X2    N.TYPE-1 
          MX1    -CHAR
          BX1    -X1*X6      ISOLATE FIRST CHARACTER
          SB7    X1+
 STY1     SA1    X2+NAT.TYP 
          SX2    X2-1 
          LX1    X1,B7
          MI     X1,STY2     IF HIT 
          PL     X2,STY1     IF NO TABLE EXHAUSTION 
          TRUBL  E.ZA 
 NAT.TYPE SPACE  4,10 
**        NAT.TYPE - TABLE OF NATURAL (IMPLICIT) TYPES. 
  
  
 NAT.TYP  BSSENT 0
          LOC    0
 M.BOOL   VFD    27/000000000B,15/0,18/M.BOOL 
 M.LOG    VFD    27/000000000B,15/0,18/M.LOG
 M.INT    VFD    27/000770000B,15/0,18/M.INT
 M.REAL   VFD    27/377007777B,15/0,18/M.REAL 
 M.DBL    VFD    27/000000000B,15/0,18/M.DBL
 M.CPLX   VFD    27/000000000B,15/0,18/M.CPLX 
 M.CHAR   VFD    27/000000000B,15/0,18/M.CHAR 
          LOC    *O 
  
 NAT.LEN  BSZENT 26/2 
 TLV      SPACE  4,10 
**        TLV - TRUNCATE LONG VARIABLE. 
* 
*         WHEN A VARIABLE NAME (TYPE O.VAR) OCCUPIES MORE THAN ONE
*         TOKEN, B4 IS RESET TO POINT TO THE LAST TOKEN IN THE
*         STRING AND THE VALUE OF THIS TOKEN IS CHANGED TO THE SAME 
*         AS THE FIRST TOKEN.  THIS EVIDENTLY FOOLS PAR INTO THINKING 
*         THE NAME DOES NOT EXCEED 7 CHARACTERS.
* 
*         CALLED BY - PAR,CST,TRV,ETC,ETC 
* 
*         ENTRY  (B4) _ FIRST TOKEN IN VARIABLE.
*                IT IS KNOWN THAT THE NEXT TOKEN IS OF TYPE O.VAR.
* 
*         EXIT   (B4) _ LAST TOKEN IN VARIABLE. 
*                CONTENTS OF LAST TOKEN = CONTENTS OF FIRST TOKEN.
* 
*         USES   A2,A7   X0,X2,X7   B4,B7 
* 
*         CALLS  NONE 
  
  
 TLV      SUBR   =           ** ENTRY/EXIT ** 
          SA2    B4 
          BX7    X2          SAVE FIRST TOKEN OF NAME 
          MX0    WA.SYML
 TLV5     =B4    B4+1 
          =A2    B4+1 
          SB7    X2-O.VAR 
          ZR     B7,TLV5     IF MORE CHARACTERS IN NAME 
          SA7    B4          SET LAST TOKEN=FIRST TOKEN 
          BX7    X0*X7
          SA7    FILL.
          FATAL  E.VA10      ** NAME TOO LONG, TRUNCATED
          EQ     EXIT.
 TRV      SPACE  4,15 
**        TRV -  TRANSLATE VARIABLE.
* 
*         ENTRY  (B2) = 1 ENTRY (FUNCTION) ALLOWED AS VARIABLE (VALUE.) 
*                     = 0 DISALLOWED
*                (B4) _ VARIABLE TO BE TRANSLATED 
* 
*         EXIT   (A2, X2) = SYMTAB ATTRIBUTE WORD (WB). 
*                (X6) = PASS 2 TAG FORM.
*                (B7) = INDEX OF *WB* 
*                (X0) = ORDINAL IF NO ERROR DETECTED
*                     = -1 OTHERWISE
*         NOTE   *TRV* VALIDATES THE *ENTRY* BEFORE EXIT TO MAKE SURE 
*                NO USAGE CONFLICT EXIST. 
*         USES   A1,A2,A3,A6 X0 B2,B3,B7
*                (TRVA, TRVA+1) 
  
  
  
 TRV      SUBR   =           ENTRY/EXIT...
          SX6    B2 
          SA6    TRVB        SAVE ENTRY INDICATOR 
          SA1    B4 
          MX0    WA.SYML
          BX6    X0*X1       SYMBOL ONLY
          SB2    X1-O.VAR 
          SA6    FILL.
          NZ     B2,E.VA09   IF NOT *VARIABLE*
          SA2    B4+1 
          SB7    X2-O.VAR 
          NZ     B7,TRV5     IF NAME LESS THAN 8 CHAR 
          CALL   TLV         TRUNCATE LONG VARIABLE NAME
 TRV5     RJ     SSY
          SB3    X0          (B3) = ORDINAL 
          SX7    B3 
          SA7    TRVA 
          PL     B7,TRV10    IF FOUND IN TABLE
          RJ     STY         SET MODE 
          CLAS=  X7,WB,(VAR)
          BX7    X1+X7       ADD MODE 
          ADSYM  T.SYM       ADD SYMBOL + TAG TO TABLE. 
          SB3    X0          ORDINAL
          SX7    B3 
          SA7    TRVA 
          EQ     TRV12
  
 TRV10    BX0    X6 
          SBIT   X0,WB.LABP 
          SX1    CLASS+WB.LABP
          MI     X0,TRV11E   IF STATEMENT LABEL 
          LX0    WB.LABP-WB.NVARP 
          PL     X0,TRV12    IF NOT A *NOT VARIABLE*
          CLAS=  X2,WB,(SUB,FUN,LAB,PARM) 
          BX0    X2*X6
          NZ     X0,TRV11    IF NASTY NVAR
          CLAS=  X0,WB,(ENT)
          BX2    X0*X6
          SX1    CLASS+WB.NVARP 
          ZR     X2,TRV11E   IF NOT ENTRY POINT 
          SA1    MOD
          SBIT   X1,MO.FUNP 
          PL     X1,TRV11    IF NOT FUNCTION SUBPROGRAM 
          SA1    TRVB 
          ZR     X1,TRV11    IF MAIN ENTRY POINT ILLEGAL AS VARIABLE
          SA1    S=VALUE     X1 = SYMORD OF VALUE.
          MX0    -WB.MODEL
          LX2    -WB.MODEP
          BX0    -X0*X2      ISOLATE MODE OF ENTRY POINT
          IX7    X0+X1
          SA7    TRVA 
          SB3    X7 
          LX1    B1,X7
          SX1    X1+B3       CONVERT TO INDEX 
          =B7    X1+WB.W
          SA1    T.SYM
          SA2    X1+B7       *WB* OF PROPER VALUE. SYMBOL 
          EQ     TRV12
  
*         CLASS CONFLICT.  GET PROPER MESSAGE.
  
 TRV11    NX2,B2 X0          LOCATE LEADING BIT OF CONTENTION 
          SX0    -B2
          SX1    X0+47+CLASS
  
 TRV11E   SA3    X1          FETCH ERRLIT FOR CLASS NAME
          SB7    E.VA00      USAGE CONFLICT ERROR 
          BX6    X3 
          SA6    FILL.2      SET NAME OF CONFLICTING CLASS
          FATAL  B7 
          SX0    B3 
          RJ     CT1         CONSTRUCT OPERAND (TP.)
          MX0    -1          INDICATE ERROR 
  
**               (B3) = SYMTAB ORDINAL. 
  
 TRV12    SA1    WO.LOR 
          PL     X1,TRV20    IF NO CROSS-REFERENCE SELECTED.
          SX6    B3 
          LX6    XR.TAGP     CONSTRUCT XREF TAG 
          SA1    REFVAR      TYPE OF REFERENCE
          ADDREF X6,X1
  
**        SET-UP EXIT CONDITIONS. 
  
 TRV20    SA1    TRVA 
          BX0    X1 
          RJ     CT1         CONSTRUCT PASS 1 TAG 
          SA6    TRVA 
          EQ     EXIT.       EXIT...
  
 TRVA     CONENT 0
 TRVB     BSS    1           SAVE ENTRY POINT TEST SWITCH 
 TSX      SPACE  4,10 
**        TSX - TAG SYSTEM EXTERNAL.
* 
*         MUST BE USED TO ENTER ALL "INVISIBLE" SYSTEM EXTERNALS IN 
*         SYMBOL TABLE.  IF NAME IS ALREADY IN SYMTAB, NO CHECK FOR 
*         ATTRIBUTE CONFLICTS IS PERFORMED.  IF NAME IS ENTERED, ITS
*         ATTRIBUTES WILL BE SET TO "M.SYSXT".  THE TYPE FIELD
*         (WB.MODE) WILL BE ZERO. 
*         NO XREF ENTRY IS MADE.
*         THE "TAGSEX" MACRO SHOULD ALWAYS BE USED TO CALL TSX. 
* 
*         ENTRY  (X1) = NAME (-L- FORMAT).
* 
*         EXIT   (X0) = SYMBOL ORDINAL. 
*                (A2, X2) = SYMTAB ATTRIBUTE WORD (WB). 
*                (X6) = OPERAND FORM (TP).
*                (B7) = INDEX OF SYMTAB WORD (WB).
* 
*         USES   A1,A2,A3,A6,A7  X0-3,X6,X7  B2,B3,B7.
*         CALLS  ADSYM, CT1, SSY. 
  
  
 TSX      SUBR   =           ENTRY/EXIT...
          MX0    WA.SYML
          BX6    X0*X1
          CALL   SSY         SCAN SYMBOL TABLE
          PL     B7,TSX3     IF ALREADY IN TABLE
          CLAS=  X3,WB,("M.SYSXT")
          ERRNZ  M.BOOL 
          BX7    X3 
          MX2    0
          ADSYM  A1 
  
 TSX3     SA2    T=BLST 
          ZR     X2,TSX4     IF NOT IN BLOCK STRUCTURE
          LX6    X0          PRESERVE ORDINAL 
          CLAS=  X0,WB,(DLER) 
          CALL   PDA         PROPOGATE DO LOOP ATTRIBUTE
          LX0    X6 
  
 TSX4     RJ     CT1         CONSTRUCT (TP.) OPERAND
          EQ     EXIT.
 TSY      SPACE  4,10 
**        TSY - TAG COMPILER SYMBOL.
* 
*         ENTRY  (X3) = ATTRIBUTES FOR (WB).
*                (X4) =  42/ 0LNAME,  18/ CELL
* 
*         EXIT   (X0) = SYMORD. 
*                (A2,X2) = SYMTAB WORD (WB.). 
*                (X7) = SYMORD. 
*                (CELL) = SYMORD. 
* 
*         ABORTS IF SYMBOL ALREADY IN TABLE.
* 
*         CALLS  ADSYM, SSY.
*         USES   A1-3,A6-7   X0-3,X6-7   B2-3,B7. 
  
  
 TSY      SUBR   =           ENTRY/EXIT...
          MX0    WA.SYML
          BX6    X0*X4
          LX7    X3 
          CALL   SSY         COMPUTE SYMBOL HASH
          PL     B7,"BLOWUP" IF SYMBOL ALREADY IN TABLE 
          MX2    0           (WC.W) = 0 
          ADSYM  A1          ADD SYMBOL TO TABLE
          BX7    X0 
          SA7    X4 
          EQ     EXIT.
          TITLE  TABLE SCANNING AND ENTRY ROUTINES. 
 ERT      SPACE  4,10 
**        ERT -  ENTER REFERENCE TABLE. 
* 
*         ENTRY  (X6) = TAG.
*                (X1) = USAGE LETTER CR.XXX AS DEFINED IN TSTEXT. 
*                (B7) = EXIT ADDRESS. 
* 
*         NOTE
*                ALL CALLS TO *ERT* SHOULD USE MACRO *ADDREF* 
* 
*         USES   A1-A4,A6,A7  B2,B3,B7  X0-X3,X6,X7 
*                PRESERVES  A0,A5  X4,X5  B4,B5,B6
  
  
 ERT1     SHRINK T=REF,0     TABLE JUST OVERFLOWED
  
 ERT2     SX6    B6 
          SX7    B5 
          SA6    ERTA        (ERTA+0) = (B6)
          =A7    A6+1             +1  = (B5)
          BX6    X4 
          =A6    A7+1             +2  = (X4)
          SX0    B4          SAVE (B4)
          WRITEW F.REF,ERTB,1 
          SB4    X0          RESTORE (B4) 
          SA2    ERTA 
          SA1    ERTB+1 
          =A3    A2+1 
          =A4    A3+1        RESTORE (X4) 
          SB6    X2          RESTORE (B6) 
          SB5    X3          RESTORE (B5) 
          SB7    X1 
          JP     B7          EXIT.. 
  
*         THE ERT ENTRY IS MODIFIED BY LO=R AND C$LIST(R=), USING ERT=ON
*         OR ERT=OFF, AS APPLICABLE.
  
 ERT      BSSENT 1           ...ENTRY 
          SA2    REFLIN 
          MX0    XR.TAGL
          BX6    X0*X6       ISOLATE TAG
          IX3    X1+X2       PAGE, LINE, USE
          SA1    LOSTREF
          IX6    X3+X6
          SA6    ERTB 
          SX6    X1+B1       ACCUMULATE REF COUNT 
          SA2    REFIO
          SA6    A1 
          SX6    B7 
          SA6    ERTB+1      SAVE EXIT ADDRESS
          NZ     X2,ERT2     IF ON DISK 
  
          ALLOC  T.REF,1
          SA3    REFIO
          NZ     X3,ERT1     IF JUST OVERFLOWED 
          SA3    ERTB+1 
          =A2    A3-1 
          SB2    X3 
          BX6    X2 
          =A6    B7-1        STORE REFERENCE IN TABLE 
          JP     B2          EXIT.. 
  
 ERTA     BSS    3           SAVES (B6, B5, X4) 
 ERTB     BSS    2           SAVE AREA
  
 ERT=ON   BSSENT
          NO
          NO
          NO
          NO
 ERT=OFF  BSSENT
          JP     B7 
 ESY      SPACE  4,10 
**        ESY -  ENTER SYMBOL TABLE 
* 
*         NOTE - ESY REQUIRES A PREVIOUS CALL TO SSY TO SET *LAST*
* 
*         ENTRY  (A1) _ T.SYM 
*                (X2) = *WC* ENTRY
*                (X6) = SYMBOL
*                (X7) = *WB* ENTRY
*                (LAST) = INDEX OF CURRENT CHAIN END
*                (NEXTORD) = NEXT AVAILABLE SYMBOL TABLE ORDINAL
* 
*         EXIT   (X0) = ORDINAL OF SYMBOL TABLE ENTRY 
*                (X6) = *WB* WORD 
*                (X1) = FWA SYMTAB = (T.SYM)
*                (A2, X2) = SYMTAB (WB) 
*                (B7) = SYMTAB INDEX OF WB
*                (NEXTORD) = INCREMENTED
* 
*         USES   A1,A2,A3,A6,A7  X0  B2,B7
* 
*         CALLS  ALC
  
 MSTO     BFMIC  WA,(HASH)   MAXIMUM SYMBOL TABLE ORDINAL 
  
  
 ESY      SUBR   =           ...ENTRY/EXIT... 
          LDBIT  X3,WB.1REFP
          BX7    X3+X7       SET 1REF FLAG
          MX0    CHAR 
          MI     X6,ESY05    IF TAPEXXX SYMBOL
          LX0    -MAX.VAR*CHAR+CHAR 
          BX3    X0*X6
          ZR     X3,ESY05    IF NOT SEVEN CHARACTER SYMBOL
          AX3    18 
          SB2    X3-1R+ 
          PL     B2,ESY05    IF APPENDED SPECIAL CHARACTER
          SA6    FILL.
          ANSI   E.ANS2 
  
 ESY05    SA6    ESYA 
          =A7    A6+1 
          LX6    X2 
          SA6    A7+1 
          SA2    LAST 
          SA3    NEXTORD
          BX6    X3 
          PL     X2,ESY1     IF HASH LINK TO SYMBOL TABLE 
          BX0    -X2
          SA6    X0+HASHTBL  HASH LINK TO HASH TABLE
          EQ     ESY2 
  
 ESY1     =B2    X2+WA.W
          SA2    X1+B2       FETCH SYMBOL 
          BX6    X2+X6       ADD IN HASH CHAIN
          SA6    A2 
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
          MX6    -WA.HASHL
          LX2    -WA.HASHP
          BX6    -X6*X2      EXTRACT HASH FIELD 
          NZ     X6,"BLOWUP"       IF PREVIOUS LINK EXISTED 
 .TEST    ENDIF 
  
 ESY2     ALLOC  A1,Z=SYM 
          SA2    ESYA+1 
          =A3    A2+1 
          BX6    X3          *WC* ENTRY 
          =A6    B7-Z=SYM+WC.W
          SA3    NEXTORD
          SB2    X3-"MSTO"   CURRENT ORDINAL - MAXIMUM ORDINAL ALLOWED
          GT     B2,ESY3     IF SYMBOL TABLE OVERFLOW 
          BX0    X3          RETURN (X0) = ORDINAL OF ENTRY 
          LX6    X2 
          =A6    A6-WC.W+WB.W 
          SA2    A2-B1
          BX7    X2          STORE NAME, CLEAR HASH 
          SA2    WANFP
          BX7    X7+X2       GIVE WA.NFP BIT THE PROPER VALUE 
          =A7    A6-WB.W+WA.W 
          SA2    A6          RETURN (A2, X2) = (WB) 
          SB7    X1 
          SX7    X0+B1       ADVANCE ORDINAL
          SA7    A3 
          SB7    A6-B7       RETURN (B7) = INDEX OF WB
          EQ     EXIT.
  
 ESY3     FATAL  E.STO       ERROR - SYMBOL TABLE OVERFLOW
          CALL   CAF         CLOSE ALL FILES
          EQ     ENDFTN 
  
 ESYA     DATA   0,0,0       SAVE AREA FOR SYMBOL TABLE INFORMATION 
 INN      SPACE  4,10 
**        INN - INVENT NEW NAME.
* 
*         CONSTRUCTS A UNIQUE SYMBOL AND ADDS IT TO THE SYMBOL TABLE. 
*         THE NEW SYMTAB ENTRY HAS ONLY (WB.CGS) SET.  ALL OTHER
*         ATTRIBUTE FIELDS ARE SET TO ZERO, AND SHOULD BE FILLED IN 
*         BY THE CALLER.
* 
*         ENTRY  (A1) = ADDRESS OF COUNTER. 
*                (X1) = (COUNTER) TO BE USED AS SUFFIX. 
*                (X7) = PREFIX FOR NEW NAME,
*                       -3R- FORMAT FOR SYMBOLS,
*                       -2R- FORMAT FOR LABELS. 
* 
*         EXIT   (COUNTER) INCREMENTED. 
*                INVENTED NAME ADDED TO SYMTAB -- 
*                (A2, X2) = SYMTAB ATTRIBUTE WORD (WB). 
*                (B7) = INDEX OF (WB).
*                (X0) = SYMTAB ORDINAL. 
* 
*         USES   A1-A4,A6,A7   B2,B3   X0-X4,X6,X7
*         CALLS  CDD, ESY, SSY
  
  
 INN      SUBR   =           ENTRY/EXIT...
          SX6    X1+B1       INCRMENT COUNT OF INVENTED NAMES 
          SA7    INNA        SAVE PREFIX
          SB7    B4          SAVE (B4)
          SA6    A1 
          CALL   CDD         CONVERT DECIMAL DIGITS (SUFFIX)
          MX0    1
          SB2    B2-B1
          SA3    INNA        RETRIEVE PREFIX
          SB4    B7          RESTORE (B4) 
          AX0    B2 
          BX2    X0*X4       STRIP SPACES FROM CONVERSION 
          BX6    X2+X3       MERGE PREFIX WITH INVENTED SUFFIX
          LX6    -3*6 
          CALL   SSY         SCAN SYMBOL TABLE (TO COMPUTE HASH)
 .TEST    IFEQ   TEST,ON,1
          PL     B7,"BLOWUP"       IF ALREADY IN TABLE
          CLAS=  X7,WB,(CGS)       SET (COMPILER-GENERATED-SYMBOL)
          SX2    0
          ADSYM  A1          ADD NEW NAME TO SYMBOL TABLE 
          EQ     EXIT.
  
 INNA     BSS    1           SAVE PREFIX
 NCM      SPACE  4,30 
**        NCM -  ENTER *MULTI-WORD* ELEMENT INTO REQUESTED TABLE. 
* 
*         ENTRY  (A1) _ TABLE TO BE ENTERED.
*                (B2) _ FWA CONSTANTS.
*                (B3) _ LWA+1 ELEMENT TO BE ENTERED.
*                (B7) = IF .EQ. 0 --
*                         IF NOT IN TABLE, CALL ALLOC AND ENTER 
*                         ELEMENT 
*                       IF .NE. 0 --
*                          IF NOT IN TABLE, DO NOT CALL ALLOC AND 
*                          DO NOT ENTER ELEMENT IN TABLE
*                (X1) = ((A1))
* 
*         NOTE   LIKE MOST SCAN ROUTINES *NCM* REQUIRES A USABLE WORD 
*                PRECEDING CURRENT TABLE ABOUT TO SCAN. 
* 
*         EXIT   (B7) = ORDINAL OF FWA OF ELEMENT IN TABLE IF 
*                         ENTERED OR ALREADY PRESENT, ELSE -1 
*                (X6) = (B7) IF ELEMENT ENTERED 
*                (X0) = LENGTH OF ELEMENT IF NOT ENTERED IN TABLE 
* 
*         CALLS  ALLOC, MOVE
* 
*         CANNOT DESTROY A4,A5 B4,B5,B6 
  
  
 NCM      SUBR   =           ...ENTRY/EXIT... 
          SX6    B3 
          SX0    B3-B2
          SA6    NCMA 
          SX7    B7 
          =A7    A6+1 
          EQ     B2,B3,EXIT. IF NO WORDS TO ADD 
  
**        SCAN TABLE N TIMES TO CHECK IF ENTITY IS ALREADY IN TABLE.
  
          SA2    B2          1ST ELEMENT TO BE CHECKED. 
          SB7    X0-1        LENGTH OF THIS ENTRY 
          SA3    A1+N.TABLE  LENGTH OF TABLE. 
 NCM5     BX6    X2 
          SB3    X3 
          SA6    X1-1        DUMMY FIND 
          SA3    A6+B3
          LE     B3,B7,NCM50 IF TABLE TOO SMALL TO ALREADY HAVE IT
          SA3    A3-B7
          SB3    B3-B7
  
**        CHECK FOR 1ST ELEMENT 60 BIT MATCH. 
*         BACKWARD SCAN THRU TABLE. 
  
 NCM10    =B3    B3-1 
          BX6    X3-X2
          =A3    A3-1 
          NZ     X6,NCM10    IF NO MATCH
          MI     X6,NCM10    IF NO MATCH (-0 PROBLEM) 
          MI     B3,NCM50    IF DUMMY HIT - DEFINITELY NOT IN TABLE.
          =X6    A3+1 
          SA6    NCMA+2 
          =A2    A2+1 
          SA3    A3+2 
  
**        SCAN TABLE FOR REMAINING NTH ELEMENT TO MATCH 
  
 NCM20    ZR     B7,NCM30    IF ENTIRE LIST MATCHES 
          BX6    X2-X3
          =B7    B7-1 
          =A2    A2+1 
          =A3    A3+1 
          MI     X6,NCM22    IF NO MATCH (-0 PROBLEM) 
          ZR     X6,NCM20    IF CONTINUED MATCH 
  
**        HERE IF ONLY PARTIAL MATCH. 
*         RESET PARAMETERS AND START OVER.
  
 NCM22    SA3    NCMA+2 
          SA2    B2 
          SB7    X0-1 
          IX3    X3-X1       ORDINAL FOR RE-START.
          EQ     NCM5        TRY AGAIN .... 
  
**        HERE IF ENTITY IS ALREADY IN TABLE
*         SET-UP EXIT CONDITIONS AND EXIT.
  
 NCM30    SB3    X1 
          SX2    A3-B3
          IX6    X2-X0       ORDINAL
          SB7    X6 
          EQ     EXIT.       EXIT...
  
**        HERE IF ENTITY NOT IN TABLE 
*         ALLOCATE ROOM FOR TABLE IF REQUESTED. 
  
 NCM50    SA3    NCMA+1 
          =B7    -1          FLAG NOTHING ENTERED 
          NZ     X3,EXIT.    IF NO ALLOC DESIRED, EXIT... 
  
          SX6    B2 
          SA6    NCMA+1      SAVE (B2) FWA
          ALLOC  A1,X0       ALLOCATE ROOM IN TABLE.
          BX0    X1 
          SA3    NCMA 
          =A1    A3+1 
          IX7    X2-X3
          SB3    X3          RESTORE B3 
          SB2    X1          RESTORE B2 
          BX2    X1          (X2) = SOURCE
          SX6    X7+B2       ORDINAL = NEW LENGTH - WORD COUNT
          IX3    X6+X0       (X3) = DESTINATION (ORDINAL + ORIGIN)
          SA6    A3          SAVE ORDINAL 
          BX6    X4 
          SX1    B3-B2       (X1) = WORD COUNT
          SA6    NCMA+1      SAVE X4
          SX6    A4 
          =A6    A6+1        SAVE A4
          MOVE   X1,X2,X3 
          SA4    NCMA+2      RESTORE A4 
          =A1    A4-1 
          BX4    X1          RESTORE X4 
          SA1    NCMA 
          BX6    X1 
          SB7    X1 
          EQ     EXIT.       EXIT...
  
 NCMA     EQU    ADWT        REUSE ADWT SAVE AREA (3 WDS) 
 SCS      SPACE  4,15 
*CALL     COMFSCS            SCAN TABLE WITH SUPPLIED MASK
 SCT      SPACE  4,10 
**        SCT -  SCAN TABLE COMPARING ALL BITS. 
*         ENTRY  (A1) TABLE TO BE SEARCHED
*                (X6) ENTRY LOOKING FOR IN GIVEN TABLE
*         EXIT   IF ENTRY *NIT*    - (B7) IS NEGATIVE.
*                                    (A1),(X1) PRESERVED. 
*                                    (X6) UNTOUCHED.
*                IF ENTRY *IT*     - (B7) ORDINAL OF MATCHING ENTRY.
*         USES   A1,A2,A6  X0  B1,B2
  
  
 SCT      SUBR   =           ...ENTRY/EXIT... 
          SA2    A1+N.TABLE 
          =B2    -1 
          SA6    X1+B2       STORE CRITERION BELOW TABLE
          ERRMI  FUDGE-1     CODE REQUIRES 1 SLOP WORD
          IX0    X1+X2
          NO
          SA2    X0+B2       FETCH LAST ENTRY 
          SB2    A6 
 SCT1     BX0    X6-X2
          SA2    A2-B1       FETCH NEXT TABLE ENTRY 
          NZ     X0,SCT1     IF NO HIT, LOOP
          MI     X0,SCT1     IF *0* - *-0* *HIT*
          SB7    A2-B2       RELATIVE POSITION OF ENTRY 
          MI     B7,EXIT.    IF DUMMY HIT, EXIT...
          SB2    B2+B1       FIRST ADDRESS IN NAME TABLE
          SA1    B7+B2       NAME TABLE ENTRY 
          EQ     EXIT.       EXIT...
 SLT      SPACE  4,20 
**        SLT -  SCAN DEFINED LIBRARY TABLE.
* 
*         ENTRY  (X1) = SYMBOL TO CHECK.
*                (FILL.) = NAME OF FUNCTION.
* 
*         EXIT   (B2) .LT. 0 = NAME NOT IN INTRINSIC TABLE. 
*                     .GE. 0 = INDEX IN (F.INTF) OF NAME. 
*                (X3) = ATTRIBUTES FOR SYMTAB WB (JPF, NATR, NVAR). 
*                            (WB.JPF) = INDEX IN TABLE OF NAME, OR ZERO.
*                (X6) = PRESERVED.
*                (X7) = (WC.FUNI), WITH (WC.FUNT) AS FOLLOWS -- 
*                            (MF.USER) = NAME NOT IN TABLE. 
*                            (MF.LIB)  = NAME FOUND IN INTRINSIC TABLE. 
* 
*         NOTE THAT IF NAME IS NOT IN TABLE, THEN (WB.MODE) IS NOT SET. 
* 
*         USES   CANNOT DESTROY A2,A4,A5,A7  X4,X5,X6  B4,B5,B6 
  
  
 SLT      SUBR   =           ENTRY/EXIT...
          BX2    X1 
          MX0    IT.DPCL
          SB2    Z.INTF-1 
          SA1    B2+F.INTF         FETCH LAST ENTRY IN TABLE
          LX0    IT.DPCL+IT.DPCP
 SLT3     BX3    X0*X1       ISOLATE NAME FROM TABLE
          IX7    X3-X2
          ZR     X7,SLT4     IF HIT 
          SB2    B2-B1
          SA1    A1-B1
          PL     B2,SLT3     IF NOT END OF TABLE
  
*         NAME NOT FOUND IN TABLE.  MUST BE USER FUNCTION.
  
          =X7    MF.USER
          CLAS=  X3,WB,(NVAR,FUN,EXT) 
          LX7    WC.FUNTP 
          EQ     EXIT.
  
*         NAME FOUND IN LIBRARY TABLE.
  
 SLT4     CLAS=  X3,IT,(GENF) 
          MX0    -IT.MODEL
          BX3    X3*X1
          LX1    -IT.MODEP
          BX2    -X0*X1      (X2) = RESULT MODE OF FUNCTION 
          ERRNZ  IT.MODEL-WB.MODEL
          LX2    WB.MODEP 
          LX3    -IT.GENFP+WB.GENFP    XFER GENERIC BIT 
          BX3    X2+X3
          MX0    -IT.ARGCL
          LX1    IT.MODEP-IT.ARGCP
          BX7    -X0*X1      XFER ARG COUNT TO SYMTAB 
          ERRMI  WC.ARGCL-IT.ARGCL
          CLAS=  X2,WB,(NVAR,FUN,DEF) 
          SX0    X7-17B 
          NZ     X0,SLT5     IF NOT VARIABLE ARG COUNT
          CLAS=  X2,WB,(NVAR,FUN) 
  
 SLT5     BX3    X2+X3
          LX7    WC.ARGCP 
          =X0    MF.LIB 
          LX0    WC.FUNTP 
          LX1    IT.ARGCP-1-IT.ANSIP
          BX7    X7+X0       FORM (X7) = (WC.FUNI)
          MI     X1,SLT6     IF FUNCTION DEFINED IN ANSI
          ANSI   E.SU04 
 SLT6     SX1    B2 
          LX1    WB.JPFP     SET (WB.JPF) = INDEX IN (F.INTF) 
          BX3    X3+X1
          EQ     EXIT.
 SSY      SPACE  4,10 
**        SSY -  SCAN *SYMBOL* TABLE. (HASHED TABLE)
* 
*         ENTRY  (X6) = SYMBOL (0L FORMAT)
* 
*         EXIT   IF SYMBOL NOT FOUND IN TABLE --
*                (B7) .LT. 0
*                (X6) = PRESERVED.
*                (A1) _ T.SYM 
*                (LAST) _ END OF HASHED CHAIN 
*                       IF < 0 HASHTBL ADDR (FIRST ENTRY IN CHAIN)
*                       IF > 0 T.SYM ADDR (_ *WA* WORD) 
* 
*                IF SYMBOL ALREADY PRESENT IN TABLE --
*                (X0) = ORDINAL OF SYMBOL TABLE ENTRY 
*                (X1) = FWA SYMTAB = (T.SYM)
*                (A2, X2,X6) = SYMTAB (WB)
*                (B7) = SYMTAB INDEX OF WB
* 
*         USES   A1,A2,A3  X0  B2,B7
  
  
 SSY10    =A2    A2+WB.W     *WB* ENTRY 
          SA3    WANFP
          BX6    X3 
          =A3    A2-WB.W+WA.W      X3 = *WA*
          BX6    X6+X3       GIVE WA.NFP BIT THE PROPER VALUE 
          SA6    A3          UPDATE *WA*
          SX0    B2          RETURN (X0) = ORDINAL
          =B7    B7-WA.W+WB.W 
          LDBIT  X3,WB.1REFP
          BX2    -X3*X2      CLEAR 1REF FLAG
          BX6    X2 
          SA6    A2          UPDATE SYMTAB
  
 SSY      SUBR   =           ...ENTRY/EXIT... 
          SA1    T.SYM
          MX2    1
          BX3    -X2*X6      AVOIDS POSSIBLE NEGATIVE EXPONENT
          SA2    SYMHASH
          AX3    12          ZERO EXPONENT
          PX0    X3 
          DX3    X2*X0
          MX0    -PSYM
          AX3    47-PSYM
          BX3    -X0*X3      (X3) = HASH TABLE INDEX
          =B7    -1 
          SB2    X3 
          SA2    B2+HASHTBL 
          PL     X2,SSY5     IF CHAIN FORMED
          BX0    X6 
          SX3    B2 
          BX6    -X3
          SA6    LAST        INDICATE CHAIN NOT FORMED
          LX6    X0          RESTORE *SYMBOL* 
          EQ     SSYX        EXIT...
  
 SSY5     SB2    X2 
          IX3    X2+X2
          IX2    X2+X3       CONVERT ORDINAL TO INDEX 
          =B7    X2+WA.W
          ERRNZ  3-Z=SYM
          SA2    X1+B7       FETCH SYMTAB WORD WA 
          MX0    WA.SYML
          BX3    X0*X2
          IX3    X6-X3
          MX0    -WA.HASHL
          BX2    -X0*X2      GET HASH POINTER 
          ZR     X3,SSY10    IF MATCH 
          NZ     X2,SSY5     LOOP UNTIL EMPTY CHAIN 
          BX0    X6 
          SX6    B7 
          =B7    -1          INDICATE NOT IN TABLE. 
          SA6    LAST        END OF CHAIN 
          LX6    X0 
          EQ     SSYX        EXIT...
  
 LAST     DATA   0           INDEX OF HASH CHAIN END
 NEXTORD  CON    0           NEXT AVAILABLE SYMBOL TABLE ORDINAL
 SYMHASH  LIT    2525001001001001.BP0            T.SYM HASH CONSTANT
          SPACE  4,10 
          LIST   D
          END 
