*DECK     DECL
          IDENT  DECL 
 DECL     SECT   (DECLARATIVE PHASE STATEMENTS.)
 DECL     SPACE  4
*         IN ALLOC
          EXT    ADW,ADWT,ALC 
  
*         IN CONRED 
          EXT    GPS,NCS
  
*         IN DATA 
          EXT    CSC,CMV
  
*         IN FEC
          EXT    ARGCOMA,ARGMODE,CCT,CT1,ERT,ESY,FEC=STF,FEC.RTN,INN,NCM
          EXT    PARAMC,PARMODE,REFVAR,SCSA,SCS,SCT,SLT,SSY,STAGE,STY 
          EXT    TLV,TRV,WANFP
  
*         IN FERRS
          EXT    E.ANS,E.ANS2,E.AT16,E.CM,E.CM1,E.CM2,E.CM3,E.CM5,E.CM6 
          EXT    E.CM9,E.CM10,E.CM11,E.CM12,E.DM00,E.DM02,E.DM05,E.DM06 
          EXT    E.DM07,E.DM08,E.DM09,E.DM10,E.DM12,E.DM13,E.DM15,E.DM16
          EXT    E.DM19,E.DM20,E.EQ,E.EQ1,E.EQ2,E.EQ3,E.EQ4,E.EQ6,E.EQ7 
          EXT    E.EQ8,E.EQ10,E.EQ11,E.EQ12,E.EQ13,E.EQ14,E.EQ15,E.EQ16 
          EXT    E.EQ17,E.EX1,E.EX2,E.EX3,E.EX4,E.IN,E.IN1,E.IN2,E.IN3
          EXT    E.IN4,E.LV1,E.LV2,E.LV3,E.LV4,E.LV5,E.LV7,E.LV8,E.LV9
          EXT    E.MR2,E.MR3,E.PX2,E.PX3,E.PX4,E.PX5,E.PX8,E.SA,E.SA1 
          EXT    E.SA2,E.SA3,E.SA4,E.SA5,E.SA6,E.ST,E.ST1,E.TY,E.VA09 
          EXT    FILL.,FILL.2 
  
*         IN FSNAP
          EXT    DMT= 
  
*         IN FTN
          EXT    CO.AL,CO.DBPM,CO.LCM,CO.SNAP,CO.TMLC 
  
*         IN LEX
          EXT    TB=TYPE
  
*         IN PAR
          EXT    EMT,LBARM,PAR,PAREXIT,UBARM,VD.EQ,VD.GP,VD.MI,VD.PL
          EXT    ERROP,PIX,PKX,VD.MU
  
*         IN PEM
          EXT    ANSI=,PDM
  
*         IN PUC
          EXT    BLNKCOM,CHARDCL,CONONE,E=TOTAL,LEVEL,LEVEL2,MOD,N.CPL
          EXT    N.EPL,N.TABLE,N.VD,SAVE,S=CON,S=ENTRY,S=VALUE,S=VD 
          EXT    T=BLKS,T=COMM,T=ENTP,T=ECT,T=EOT,T=EQUS,T=FPI,T=LCA
          EXT    T=PAR,T=SYM,T=VDI,T=VDIM,T.BLKS,T.COMM,T.CON,T.DIM 
          EXT    T.ECT,T.ENTP,T.EOT,T.EQUS,T.FPI,T.LCA,T.PAR,T.SYM,T.TB 
          EXT    T.VDI,T.VDIM,USAVE,WOF,WO.LOM,WO.LCM 
  
*         IN QSKEL/FSKEL
          EXT    F.INTF 
  
*         IN UTILITY
          EXT    MVE= 
  
 DIMI     BSS    2*MAX.DIM+1
          TITLE  DECLARATIVE SCANNING AND SUPPORTING ROUTINES 
 CMN      SPACE 4,8 
 CMN      SPACE 4,8 
**        CMN -  PROCESS "COMMON" STATEMENT.
* 
*         CONSTRUCTS T.COMM ENTRIES:  FORMAT AS CT. . 
*         FWA(T.COMM) CONTAINS 0 AND IS NEVER USED. 
*         (N.B.  RA[CT.] IS LEFT ZERO FOR *MCA* TO FILL IN LATER) 
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         SEE ANSI 8.3
  
  
          HEREIF COMMON 
  
          =X7    CR.DEC 
          SA7    REFVAR      SET REFERENCE TYPE 
          SA1    BLNKCOM
          MX6    CA.BNAML 
          SB7    X1          BLANK COMMON BLOCK NUMBER
          SA1    B4 
          SB4    B4+B1
          SA6    SCSA        SET MASK FOR SCAN ROUTINE *SCS*
          SA2    =7L
          SB3    X1-O.VAR 
          BX6    X2          NAME FOR BLANK COMMON
          NZ     B3,CMN150   IF NOT VAR 
          SB4    B4-B1
          EQ     CMN60
  
*         PROCESS BLOCK NAME. 
  
 CMN30    SA1    B4 
          ZR     X1,E.CM1    IF PREMATURE EOS 
          SB4    B4+B1
          SA3    B4 
          SB7    X1-O.VAR 
          NZ     B7,E.CM5    ILLEGAL BLOCK NAME 
          SB7    X3-O.VAR 
          NZ     B7,CMN50    IF NOT LONG NAME 
          =B4    B4-1 
          CALL   TLV         TRUNCATE NAME
          =B4    B4+1 
          =A3    B4 
 CMN50    SX2    X1 
          BX6    X1-X2
          SB7    X3-O.SLASH 
          NZ     B7,E.CM     IF NO SLASH
          =B4    B4+1 
          MX0    CHAR 
          LX0    -MAX.VAR*CHAR+CHAR 
          BX2    X0*X6
          ZR     X2,CMN60    IF BLOCK NAME NOT SEVEN CHARACTERS 
          AX2    18 
          SB2    X2-1R+ 
          PL     B2,CMN60    IF NOT BLANK COMMON
          SA6    FILL.
          ANSI   E.ANS2 
 CMN60    SCAN   T.BLKS,SCS 
          MI     B7,CMN80    IF NOT ALREADY IN TABLE
          =A3    A2-CA.W+CB.W  CBI = CB ENTRY OF T.BLKS 
          BX7    X3 
          SA4    T=COMM 
          LX4    CB.FMIP     FMIND = LEN(T.COMM)
          HX3    CB.FMI 
          AX3    -CB.FMIL    FMI = FMI[CBI] 
          BX7    X7+X4
          NZ     X3,CMN90    IF FMI .NE. 0
          SA7    A3          FMI[CBI] = FMIND 
          EQ     CMN90
  
 CMN80    SA2    T=BLKS 
          BX5    X6          NAME 
          SX3    X2-MAX.BLK*Z=BLKS+1
          PL     X3,E.CM2    IF TOO MANY BLOCKS 
          ALLOC  T.BLKS,Z=BLKS
          SA4    T=COMM 
          LX4    CB.FMIP     FMIND = LEN(T.COMM)
          =B7    X2-Z=BLKS   CBIND = INDEX OF LAST ENTRY
          BX7    X5 
          BX6    X4 
          SA7    X1+B7       (BNAM,LMI)[T.BLKS(CBIND)] =(NAME,0) [CA.]
          SA6    A7+B1       FMI [T.BLKS(CBIND)+1] = FMIND
          SA2    =7L
          IX5    X2-X5
          NZ     X5,CMN90    IF NOT BLANK COMMON
          SX6    B7 
          SA6    BLNKCOM     BLANK COMMON BLOCK NUMBER INDICATOR
  
 CMN90    SX6    B7 
          SA2    B4 
          BX5    X6 
          SA6    CMNA        SAVE BLOCK INDICATOR 
  
*         PROCESS VARIABLE LIST.
*         (A2,X2) = VARIABLE
*         (B4) _ VARIABLE 
  
 CMN100   SA1    A2+B1       FETCH NEXT ELEMENT 
          SB7    X1-O.VAR 
          BX6    X2 
          NZ     B7,CMN110   IF NOT LONG NAME 
          CALL   TLV         TRUNCATE NAME
          =A1    B4+1 
 CMN110   SX1    X1-O.( 
          SA6    FILL.       SAVE NAME FOR POSSIBLE ERROR MESSAGE 
          NZ     X1,CMN120   IF NO LPAREN 
          RJ     DIR
          SA5    CMNA        RETRIEVE BLOCK INDICATOR 
          SA3    DIRS 
          ZR     X6,CMN140   IF ERROR IN DIMS 
          BX0    X3 
          CALL   CT1         CONSTRUCT PASS 1 TAG FORM
          EQ     CMN130 
  
 CMN120   SB2    0           ENTRY (VALUE.) NOT ALLOWED 
          CALL   TRV         TRANSLATE VARIABLE 
          MI     X0,CMN140   IF TRV DETECTED ERROR
 CMN130   =X1    WB.COMP
          CLAS=  X3,WB,(FP,DEXT,EXT,ENT,NLST,COM,PARM)
          RJ     CCT         CHECK CONFLICTING CLASSES
          MI     X0,CMN140   IF USAGE CONFLICT
          CLAS=  X4,WB,(COM,DEF,VAR,MAT)
          =A3    A2-WB.W+WC.W 
          HX3    WC.CTYP
          BX7    X4+X2       MERGE NEW PROPERTY BITS
          LX0    CT.TAGP
          MI     X3,CMN140   IF WC.CTYP .EQ. 1
          SA7    A2          UPDATE SYMTAB (WB) 
          BX6    X0          CREATE (T.COMM) ENTRY
          ADDWD  T.COMM      ADVANCE TABLE ORGIN
          SA4    T.BLKS 
          SX7    X2-1        COMIND = (T=COMM) - 1
          MX0    -CA.LMIL 
          IX4    X4+X5       RBAD = RBI + FWA(T.BLKS) 
          =A4    X4+CA.W     CAI = T.BLKS(RBAD)+CA.W
          LX4    -CA.LMIP 
          BX6    -X0*X4      LMI = LMI[CAI] 
          BX4    X0*X4
          IX6    X1+X6
          LX7    CT.LNKP
          SA1    X6          CTI = T.COMM(LMI)
          BX6    X7+X1
          LX7    CA.LMIP-CT.LNKP
          BX7    X7+X4
          LX7    CA.LMIP
          SA6    A1          LNK[CTI] = COMIND
          SA7    A4          LMI[CAI] = COMIND
 CMN140   SA1    B4+B1
          SB4    A1+B1       B4 = B4+2
          SA2    B4          LOOK AHEAD 
          =B2    X2-O.VAR 
          =X3    X1-O.COMMA 
          ERRNZ  O.EOS
          ZR     X1,FEC.RTN  IF *EOS* 
          NZ     X3,CMN150   IF NOT COMMA 
  
*         COMMA, MUST FOLLOWED BY A VARIABLE, SLASH OR BLANK COMMON.
  
          EQ     B2,CMN100   IF VARIABLE
          ZR     X2,E.CM6          IF PREMATURE *EOS* 
          SA1    A2          IGNORE THIS COMMA
          SB4    B4+B1
 CMN150   SB2    X1-O.SLASH 
          SX3    X1-O.CAT 
          ZR     B2,CMN30    IF SLASH 
          NZ     X3,E.CM3    IF NOT //
          SA2    =7L
          BX6    X2 
          EQ     CMN60
  
 CMNA     BSS    1           HOLDS BLOCK NUMBER 
          TITLE  *DIMENSION* AND ARRAY DECLARATIONS.
          SPACE  2
 DIM      SPACE  4,8
**        DIM -  PROCESS "DIMENSION" DECLARATION. 
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         SEE ANSI 8.1
  
  
          HEREIF DIMENSION
  
          =X6    CR.DEC 
          SA6    REFVAR      SET REFERENCE TYPE 
  
 DIM1     RJ     DIR         PROCESS DIMENSIONED VARIABLE 
          SA1    B4+B1
          SB4    A1+B1       (B4) = (B4) + 2
          SX2    X1-O.COMMA 
          ZR     X2,DIM1     IF *,* 
          ZR     X1,FEC.RTN  IF *EOS* 
          ERRNZ  O.EOS
          =B4    B4-1 
          FATAL  E.TY 
          =B4    B4+1 
          EQ     FEC.RTN
 DIR      SPACE  4,15 
**        DIR -  PROCESS DIMENSIONED VARIABLE.
* 
*         ENTRY  (B4) _ VARIABLE NAME IN *SB*.  LPAREN EXPECTED AS NEXT 
*                            CHARACTER. 
* 
*         EXIT   (B4) _ TERMINAL *)*, OR *EOS*-1. 
*                (X6) = *WB* ENTRY (ZERO IF ERROR)
*                (DIRS) = ORDINAL OF SYMTAB ENTRY.
*                DIMENSIONING INFORMATION ENTERED INTO T.DIM AND
*                POINTER ENTERED INTO *WB.PNTP* 
* 
*         CALLS  DIS, TRV.
* 
*         USES   ALL REGISTERS. 
  
  
**        HERE WHEN A SYNTAX ERROR IS FOUND -- SEARCHES FOR NEXT *)* IN 
*                ATTEMPT TO RECOVER SO THAT REST OF STATEMENT MAY BE
*                PROCESSED. 
  
 DIR6     FATAL  B7          OUTPUT DIAGNOSTIC
          JP     B2          SKIP PROPERLY
  
 DIR7     =B4    B4+1 
  
 DIR8     BSS    0
          SA1    B4 
          ZR     X1,E.DM10   IF *EOS* -- ERROR
          SX1    X1-O.) 
          NZ     X1,DIR7     ADVANCE TO NEXT RIGHT PAREN
  
 DIR9     BX6    0
  
 DIR      SUBR   =           ...ENTRY/EXIT... 
          SA4    B4 
          ZR     X4,E.DM16   IF *EOS* 
          BX6    X4 
          SB2    0           ENTRY (VALUE.) NOT ALLOWED 
          CALL   TRV         TRANSLATE VARIABLE 
          MI     X0,DIR8     IF TRV DETECTED ERROR
          CLAS=  X3,WB,(NVAR,NLST,DEXT,ENT,PARM,EXT)
          =X1    WB.ARYP
          CALL   CCT         CHECK FOR CONFLICTING CLASS
          MI     X0,DIR8     IF CLASS CONFLICT
          BX7    X0 
          SBIT   X2,WB.ARYP 
          SA7    DIRS 
          SX7    B7 
          SA7    DIRT        SAVE WB INDEX OF SYMTAB ENTRY
          BX7    0
          PL     X2,DIR1     IF NOT ALREADY AN ARRAY
          BX7    X2 
          LX7    WB.ARYP+1   RESTORE *WB* ENTRY 
          FATAL  E.DM09      PREVIOUS DIMENSIONALITY HOLDS
  
 DIR1     SA7    DIRI        SET PREVIOUSLY DIMENSIONED FLAG
          LX2    1+WB.ARYP   RESTORE (X2) 
          CLAS=  X3,WB,(ARY,VAR)
          BX6    X2+X3
          SA6    A2          UPDATE SYMBOL TABLE (WB) 
  
**        PROCESS DIMENSION ARGUMENTS 
  
          SA1    B4+B1       FETCH SEPARATOR
          SB2    DIR9 
          SB7    E.DM05 
          ZR     X1,DIR6     IF *EOS* 
          SX2    X1-O.COMMA 
          SX6    X1-O.(+O.COMMA 
          SB3    X1-O.( 
          ZR     X2,DIR6     IF COMMA 
          SB2    DIR8 
          SB7    E.DM00 
          NZ     B3,DIR6     IF NOT LEFT PAREN
          SA2    DIR.HEAD 
          SA6    A1          FAKE UP A COMMA FOR *DIS*
          LX7    X2 
          SA7    DIMI        INITIALIZE HEADER WORD 
          SB5    A7          READY TO INCREMENT FOR DIMENSIONS
          RJ     DIS
          SB2    DIR8 
          NZ     B7,DIR6     IF ERROR 
          SA3    DIMI 
          SA2    CO.DBPM
          MX4    0
          SBIT   X3,DH.ASP
          PL     X3,DIR3     IF NOT ASSUMED SIZE ARRAY
          CLAS=  X4,WB,(VDS) MARK FORMAL PARAMETER REQUIRED 
          LX3    DH.ASL+DH.ASP
          ZR     X2,DIR5     IF PMD NOT ON
          CLAS=  X6,DH,(MAT)
          BX6    X3+X6       PMD REQUIRES MATERIALIZE 
          SA6    A3 
          EQ     DIR5 
  
 DIR3     SBIT   X3,DH.VDP/DH.ASP 
          PL     X3,DIR5     IF NOT ADJUSTABLY DIMENSIONED
          LX3    DH.VDL+DH.VDP
          ZR     X2,DIR4     IF PMD NOT ON
          CLAS=  X6,DH,(MAT)
          BX6    X3+X6       PMD REQUIRES MATERIALIZE 
          SA6    A3 
  
 DIR4     RJ     OVP         OUTPUT VARIABLE PRODUCT OF SPANS 
          CLAS=  X4,WB,(VDS) MARK FORMAL PARAMETER REQUIRED 
  
 DIR5     SA1    DIRI 
          SX6    0           ERROR INDICATION 
          NZ     X1,EXIT.    IF PREVIOUSLY DIMENSIONED
          SB2    DIMI        FWA OF DIMENSION DESCRIPTORS 
          SB3    B5+1        LWA+1
          =B7    0
          RJ     EDD         ENTER DIMENSION DESCRIPTOR INTO T.DIM
          SA1    T.SYM       IN CASE TABLES MOVED 
          SA2    DIRT 
          IX3    X1+X2
          SA5    X3          REFETCH *WB* ENTRY 
          LX6    WB.PNTP
          BX6    X5+X6
          SA6    X3          INSERT DIM TABLE POINTER 
          SBIT   X5,WB.FPP
          MI     X5,EXIT.    IF FORMAL PARAMETER
          BX6    X6+X4       MARK FORMAL PARAMETER REQUIRED, AS NEEDED
          SA6    A6 
          EQ     EXIT.
  
 DIRS     BSS    1           RETURN ORDINAL OF SYMTAB ENTRY 
 DIRT     BSSENT 1           TEMP HOLDING OF SYMTAB *WB* INDEX
 DIRI     BSS    1           PREVIOUSLY DIMENSIONED FLAG
 DIR.HEAD VFD    DH.ATTRL/0,DH.PSL/1,DH.RAL/0,DH.DIML/0 
 DIS      SPACE  4,8
**        DIS -  ASSEMBLE DIMENSION SUBSCRIPT.
* 
*         ASSEMBLES DIMENSION DESCRIPTORS INTO A SAVE BUFFER. 
* 
*         ENTRY  (B4)+1 _ SUBSCRIPT ENTRY.
*                (B5) = FIRST D2. SAVE LOCATION TO INCREMENT
* 
*         EXIT   (B4) _ *)* OR *EOS* WHICH CAUSED *DIS* TO QUIT 
* 
*                IF NO ERROR... 
*                (B7) = 0 
*                (B5) = LWA OF STORED DIMENSION DESCRIPTORS 
* 
*                IF ERROR...
*                (B7) = DIAGNOSTIC ADDRESS
*                (B5) = UNDEFINED 
* 
*         USES   ALL BUT A0 
* 
*         CALLS  CDB, NCS, OVS, OVT 
  
  
 DIS      SUBR               ...ENTRY/EXIT... 
 DIS1     SA1    DIMI        FETCH HEADER 
          SB2    1R0
          MX6    -DH.DIML 
          LX1    -DH.DIMP 
          BX6    -X6*X1      EXTRACT DIMENSION COUNT
          =X6    X6+1        INCREMENT FOR THE UPCOMING DIMENSION 
          SX6    X6+B2       CONVERT TO DPC 
          ERRPL  MAX.DIM-10  CODE WORKS FOR ONLY ONE DIGIT
          LX6    9*CHAR      HIGH ORDER 
          SA6    FILL.2      SAVE FOR POSSIBLE ERROR
          =B7    0
          SA1    B4+B1       FETCH SEPARATOR
          SB4    B4+B1
          SX2    X1-O.) 
          ZR     X1,E.MR2    IF *EOS*, ERR..
          SB3    X1-O.COMMA 
          ZR     X2,EXIT.    IF *RP*, EXIT
          ZR     B3,DIS3     IF COMMA 
          SB7    E.DM15 
          EQ     EXIT.
  
 DIS3     SA2    B4+1 
          =B4    B4+1 
          SX6    X2 
          SB7    E.DM00 
          ZR     X2,EXIT.    IF *EOS* 
          SB5    B5+Z=DD     INCREMENT DIMENSION SAVE POINTER 
          =X1    1
          LX1    D2.LBP      DEFAULT LOWER BOUND
          SB3    X2-O.STAR
          ZR     B3,DIS30    IF ASSUMED SIZE ARRAY
          SB3    X2-O.) 
          ZR     B3,EXIT.    IF O.) ERROR 
          SA3    LBARM
          RJ     CDB         COMPILE DIMENSION BOUND
          NZ     B7,EXIT.    IF ERROR, EXIT...
          =A1    B4+1        FETCH SEPARATOR
          SB3    X1-O.COLON 
          =X1    1
          LX1    D2.LBP      DEFAULT LOWER BOUND
          NZ     B3,DIS5     IF NOT COLON, NO LOWER BOUND 
  
*         SAVE EXPLICIT LOWER BOUND, PROCESS UPPER BOUND
*                (X5) = EXPLICIT LOWER BOUND (DI. FORMAT) 
  
          LX5    D2.LBP      CURRENT BOUND WAS LOWER BOUND
          BX6    X5 
          SA6    DIS.LB      SAVE LOWER BOUND 
          SA3    UBARM
          =B4    B4+2        POINT TO UB
          SA2    B4 
          LX1    X6 
          SB3    X2-O.STAR
          ZR     B3,DIS30    IF ASSUMED SIZE ARRAY
          RJ     CDB         COMPILE DIMENSION BOUND
          NZ     B7,EXIT.    IF ERROR, EXIT...
          SA1    DIS.LB 
  
*         PROCESS DIMENSION BOUND PAIR
*                (X1) = LOWER BOUND (D2. FORMAT)
*                (X5) = UPPER BOUND (D2. FORMAT)
  
 DIS5     BX6    X1+X5       LB + UB = D2.
          SA1    DIMI        FETCH HEADER ENTRY 
          =X7    1
          LX7    DH.DIMP
          IX7    X1+X7       INCREMENT NUMBER OF DIMENSIONS 
          MX0    -DH.DIML 
          SX2    MAX.DIM
          BX0    -X0*X7      ISOLATE DIMENSIONALITY 
          IX2    X2-X0
          SB7    E.DM06 
          MI     X2,EXIT.    IF DIMENSIONALITY EXCEEDED 
          SA7    A1          HEADER ENTRY 
          SA6    B5          *D2* ENTRY 
  
*         DETERMINE DIMENSION SPAN
  
          BX1    X6 
          LX2    X6 
          HX2    D2.UB
          MI     X6,DIS20    IF LOWER BOUND VARIABLE
          LX1    -DM.INFL-DM.INFP+D2.LBL
          AX1    -DM.INFL    (X1) = LOWER BOUND (CONSTANT)
          MI     X2,DIS10    IF UPPER BOUND VARIABLE
          LX2    -DM.INFL-DM.INFP+D2.UBL
          AX2    -DM.INFL    (X2) = UPPER BOUND (CONSTANT)
          IX7    X2-X1
          SB7    E.DM02 
          MI     X7,EXIT.    IF LB .GT. UB
          =X6    1
          IX7    X7+X6
          LX7    D1.SPANP 
          SA7    A6-D2.W+D1.W 
          EQ     DIS40
  
*         UPPER BOUND VARIABLE, LOWER BOUND CONSTANT
  
 DIS10    =X0    1
          IX0    X0-X1
          NZ     X0,DIS15    IF LB " 1
          MX0    -D1.SPANL
          LX2    D1.SPANL 
          BX7    -X0*X2      SPAN = UB
          ERRNZ  D1.SPANL-D2.UBL+D1.SPANP-D2.UBP
          =A7    A6-D2.W+D1.W 
          EQ     DIS1 
  
*         UPPER BOUND VARIABLE, LOWER BOUND CONSTANT " 1
*         MUST MANUFACTURE VD. ENTRY FOR SPAN 
*                (X0) = 1 - LOWER BOUND 
*                (X2) = UPPER BOUND (SHIFTED HIGH ORDER)
  
 DIS15    SA3    T.VDI
          LX2    -DM.INFL-DM.INFP+D2.UBL
          AX2    -DM.INFL    (X2) = UPPER BOUND (VD. INDEX) 
          IX2    X3+X2
          SA4    X2          FETCH VD. INFORMATION
          HX4    VD.IND 
          AX4    -VD.INDL    EXTRACT STORE OPERAND INDEX
          SA3    T.VDIM 
          IX4    X3+X4
          SA4    X4          FETCH VD. STORE OPERAND
          =X7    M.INT
          LX6    X0          CONSTANT 
          CALL   NCS         ENTER THE CONSTANT 
          BX5    X6 
          SB3    VD.PL
          RJ     OVT         OUTPUT VARDIM TURPLE 
          RJ     OVS         OUTPUT VARDIM STORE
          SA7    B5-D2.W+D1.W 
          EQ     DIS1 
  
*         LOWER BOUND VARIABLE
*         MUST MANUFACTURE VD. ENTRY FOR SPAN 
*                (X1) = LOWER BOUND (HIGH ORDER)
*                (X2) = UPPER BOUND (SHIFTED HIGH ORDER)
  
 DIS20    SA3    T.VDI
          LX1    -DM.INFL-DM.INFP+D2.LBL
          AX1    -DM.INFL    EXTRACT VD. INDEX
          IX1    X3+X1
          SA5    X1          FETCH VD. INFORMATION
          HX5    VD.IND 
          AX5    -VD.INDL    EXTRACT STORE OPERAND INDEX
          SA3    T.VDIM 
          IX5    X3+X5
          SA5    X5          FETCH VD. STORE OPERAND
          MI     X2,DIS25    IF UPPER BOUND VARIABLE
          LX2    -DM.INFL-DM.INFP+D2.UBL
          =X0    1
          AX2    -DM.INFL    EXTRACT (SIGN EXTEND) CONSTANT 
          IX6    X2+X0
          =X7    M.INT
          CALL   NCS         ENTER THE CONSTANT 
          LX4    X6 
          SB3    VD.MI
          RJ     OVT         OUTPUT VARDIM TURPLE 
          RJ     OVS         OUTPUT VARDIM STORE TURPLE 
          SA7    B5-D2.W+D1.W 
          EQ     DIS1 
  
 DIS25    SA3    T.VDI
          LX2    -DM.INFL-DM.INFP+D2.UBL
          AX2    -DM.INFL    EXTRACT VD. INDEX
          IX2    X3+X2
          SA4    X2          FETCH VD. INFORMATION
          HX4    VD.IND 
          AX4    -VD.INDL    EXTRACT STORE OPERAND INDEX
          SA3    T.VDIM 
          IX4    X3+X4
          SA4    X4          FETCH VD. STORE OPERAND
          SB3    VD.MI
          RJ     OVT         OUTPUT VD.MI TURPLE
          SA5    CONONE 
          SB3    VD.PL
          RJ     OVT         OUTPUT VD.PL TURPLE
          RJ     OVS         OUTPUT VD.EQ TURPLE
          SA7    B5-D2.W+D1.W 
          EQ     DIS1 
  
*         PROCESS ASSUMED SIZE ARRAY
*                (X1) = LOWER BOUND (D2. FORMAT)
*                (B4) _ * IN *TB* 
  
 DIS30    =A2    B4+1 
          =X7    1
          LX7    DH.DIMP
          SB3    X2-O.RP
          SB7    E.DM13 
          NZ     B3,EXIT.    IF NOT *)* FOLLOWING, ERROR
          SA2    DIMI        FETCH HEADER ENTRY 
          IX2    X2+X7       INCREMENT NUMBER OF DIMENSIONS 
          MX0    -DH.DIML 
          LX2    -DH.DIMP 
          BX0    -X0*X2      EXTRACT NUMBER OF DIMENSIONS 
          LX2    DH.DIMP
          SB7    E.DM06 
          SB3    X0-MAX.DIM-1 
          PL     B3,EXIT.    IF MAXIMUM DIMENSIONALITY EXCEEDED 
          CLAS=  X7,DH,(AS) 
          BX7    X2+X7       ADD IN ASSUMED BIT 
          MX0    -DH.PSL
          LX0    DH.PSP 
          BX7    X0*X7       PRODUCT OF SPANS = 0.
          SA7    A2          UPDATE HEADER
          SA2    =37777777B  INDICATE UPPER BOUND IS ASSUMED
          BX6    X1+X2
          SA6    B5          *D2* = LB + ASSUMED (MAXIMUM +) UB 
          LX7    X2          SPAN IS ASSUMED (MAXIMUM +)
          SA7    A6-D2.W+D1.W 
          EQ     DIS1        FINISH PROCESSING
  
*         UPDATE PRODUCT OF SPANS (CURRENT SPAN CONSTANT) 
*                (X7) = SPAN
  
 DIS40    SA1    DIMI        FETCH HEADER ENTRY 
          MX0    -DH.PSL
          LX1    -DH.PSP
          BX2    -X0*X1      ISOLATE SIZE 
          IX2    X2*X7       MULTIPLY TIMES CURRENT SPAN
          BX1    X1*X0       CLEAR OLD SIZE 
          IX7    X1+X2       INSERT NEW SIZE
          LX7    DH.PSP 
          AX2    MAX.SPAN 
          SB7    E.DM08 
          NZ     X2,EXIT.    IF SIZE .GT. 2**23-1 
          SA7    A1+         UPDATE HEADER ENTRY
          EQ     DIS1        CONTINUE PROCESSING
  
 DIS.LB   BSS    1           SAVE LOWER BOUND 
 EDD      SPACE  4
**        EDD -  ENTER DIMENSION DESCRIPTOR INTO T.DIM
* 
*         ENTRY  (B2) _ FWA CONSTANTS 
*                (B3) _ LWA+1 DESCRIPTOR TO BE ENTERED
* 
* 
*         EXIT   (B7) = ORDINAL OF FWA OF DESCRIPTOR IF 
*                       ENTERED OR ALREADY PRESENT
*                (X6) = (B7) IF ELEMENT ENTERED 
* 
* 
* 
*         CALLS ALLOC, MOVE 
* 
*         CANNOT DESTORY A4,A5 B4,B5,B6 
  
  
 EDD      SUBR   =           ...ENTRY/EXIT... 
          SX6    B3 
          SA6    EDDA 
          SX7    B5 
          SA7    EDDB5
          EQ     B2,B3,EXIT. IF NO WORDS TO ADD 
          MX0    -DH.DIML 
          SB7    B3-B2       LENGTH OF DESCRIPTOR 
          SA1    T.DIM
          SA3    A1+N.TABLE 
          SB3    X3          T.DIM LENGTH 
          LT     B3,B7,EDD16 IF TABLE TOO SMALL TO HOLD DESCRIPTOR
          SA3    X1-1        PRESET TO T.DIM-1
          SA2    B2          PRESET FWA OF DESCRIPTOR 
  
 EDD4     SA3    A3+1 
          BX5    -X0*X3 
          LX5    1
          SX5    X5+1 
          SB5    X5          NUM OF WORDS IN NEXT DESCRIPTOR IN T.DIM 
          SX7    B5          X7 USED IN CASE OF MISMATCH
          EQ     B5,B7,EDD8  IF NUMBER OF WORDS IN DESCRIPTORS EQUAL
  
**        HERE IF SIZE MISMATCH 
  
          SB3    B3-B5       T.DIM LENGTH MINUS CURRENT DESCRIPTOR
          ZR     B3,EDD16    IF NO MORE DESCRIPTORS IN T.DIM
          SX3    A3+B5
          SA3    X3-1        NEXT DESCRIPTOR-1
          EQ     EDD4        CHECK SIZE OF NEXT DESCRIPTOR
  
**        HERE TO COMPARE DESCRIPTORS OF EQUAL SIZE 
  
 EDD8     SA2    B2          RESET FWA OF DESCRIPTOR
  
 EDD10    ZR     B5,EDD14    IF CURRENT DESCRIPTOR MATCHES
          BX6    X2-X3
          SB5    B5-B1
          SA2    A2+1 
          SA3    A3+1 
          MI     X6,EDD12    IF NO MATCH
          ZR     X6,EDD10    IF CURRENT WORD MATCHES
  
**        HERE IF MISMATCH
  
 EDD12    BX7    -X7
          SB3    B3+X7
          ZR     B3,EDD16    IF NO MORE DESCRIPTORS 
          SX3    A3+B5
          SA3    X3-1        NEXT DESCRIPTOR-1
          EQ     EDD4        CHECK SIZE OF NEXT 
  
**        HERE IF DESCRIPTOR ALREADY IN T.DIM 
  
 EDD14    SX6    A3-B7
          IX6    X6-X1       ORDINAL
          SB7    X6 
          SA2    EDDB5
          SB5    X2          RESTORE B5 
          EQ     EXIT.
  
**        HERE IF DESCRIPTOR NOT IN T.DIM 
  
 EDD16    SX6    B2 
          SA6    EDDA+1      SAVE (B2) FWA
          ALLOC  A1,B7
          BX0    X1 
          SA3    EDDA 
          SA1    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+ORIGN)
          SA6    A3          SAVE ORDINAL 
          BX6    X4 
          SX1    B3-B2       (X1) = WORD COUNT
          SA6    EDDA+1      SAVE X4
          SX6    A4 
          SA6    A6+1        SAVE A4
          MOVE   X1,X2,X3 
          SA4    EDDA+2      RESTORE A4 
          SA1    A4-1 
          BX4    X1          RESTORE X4 
          SA2    EDDB5
          SB5    X2          RESTORE B5 
          SA1    EDDA 
          BX6    X1 
          SB7    X1 
          EQ     EXIT.
  
 EDDB5    CON    0           B5 SAVED HERE
 EDDA     EQU    ADWT        ADDITIONAL SAVE AREA 
 CDB      SPACE  4,8
**        CDB -  COMPILE DIMENSION BOUND
* 
*         FOR *PHASE 1A*, THIS ROUTINE EVALUATES CONSTANT EXPRESSIONS 
*         AND VARIABLE DIMENSIONS WHICH USE A FORMAL PARAMETER OR COMMON
*         ELEMENT ONLY.  THIS ROUTINE MUST BE EXTENDED TO COMPILE ALL 
*         ALL DIMENSION EXPRESSIONS.
* 
*         ENTRY  (B4) _ FWA OF DIMENSION BOUND
*                (X3) = ARGMODE SETTING 
* 
*         EXIT   (B4) _ END OF DIMENSION DESCRIPTOR 
* 
*                IF NO ERROR... 
*                (B7) = 0 
*                (X5) = DIMENSION DESCRIPTOR (DM. FORMAT) 
* 
*                IF ERROR...
*                (B7) = DIAGNOSTIC ADDRESS
*                (X5) = UNDEFINED 
* 
*         USES   A1,A2,A3,A4,A5,A6,A7  B2,B7  X0,X1,X2,X3,X4,X5,X6,X7 
* 
*         PRESERVES B5  (FILL.)  (FILL.2)  (T=PAR)  (E=TOTAL) 
* 
*         CALLS  PAR
  
  
 CDB      SUBR               ...ENTRY/EXIT... 
          SA1    T=PAR
          SA2    FILL.
          LX7    X1 
          BX6    X2 
          SA1    E=TOTAL
          SA7    CDBA        CDBA+0 = (T=PAR) 
          =A2    A2+1        FILL.2 
          =A6    A7+1            +1 = (FILL.) 
          LX7    X2 
          =A7    A6+1            +2 = (FILL.2)
          SX6    B5 
          BX7    X1 
          =A6    A7+1            +3 = (B5)
          BX6    X3 
          =A7    A6+1            +4 = (E=TOTAL) 
          MX7    0
          SA7    ARGCOMA
          =X7    O.SLP
          SA6    ARGMODE
          =A7    B4-1        PUT SPECIAL BEGINNING PAREN TO SET ARGMODE 
          =B4    B4-1        MOVE *TB* POINTER TO BEGINNING LEFT PAREN
          =X6    PM=DIM 
          SA6    PARMODE     SET FOR NON STANDARD PARSE 
          CALL   PAR         PARSE/REDUCE EXPRESSION
          SX6    0
          SA6    PARMODE     CLEAR
          SA1    CDBA+1 
          =A2    A1+1 
          LX7    X2 
          BX6    X1 
          SA6    FILL.       RESTORE FILL.
          =A7    A6+1        RESTORE FILL.2 
          LX2    X5 
          SBIT   X2,TP.SHRTP
          PL     X2,CDB20    IF NOT SHORT CONSTANT
          MX0    -DM.INFL 
          HX5    TP.BIAS
          AX5    -TP.BIASL   SIGN EXTEND
          BX5    -X0*X5      ISOLATE CONSTANT BOUND 
          EQ     CDB40       CONTINUE PROCESSING... 
  
 CDB20    MX0    -TP.ORDL 
          SA2    S=VD 
          LX5    -TP.ORDP 
          BX3    -X0*X5      ISOLATE ORDINAL
          IX2    X3-X2
          MX0    -TP.BIASL
          LX5    TP.ORDP-TP.BIASP 
          BX5    -X0*X5      BIAS (CON. OR VD.) 
          ZR     X2,CDB30    IF VARIABLE DIMENSION BOUND
          SA2    T.CON
          SB2    X5 
          SA2    X2+B2       FETCH THE CONSTANT 
          MX0    -DM.INFL 
          BX5    -X0*X2      ISOLATE CONSTANT BOUND 
          AX2    MAX.SPAN 
          ZR     X2,CDB40    IF BOUND .LE. 2**23-1
          SB7    E.DM07 
          EQ     EXIT.
  
 CDB30    SA2    DIMI        FETCH HEADER ENTRY 
          CLAS=  X6,DH,(VD) 
          BX6    X2+X6       ADD IN VARIABLE DIMENSION BIT
          SA6    A2 
          CLAS=  X4,DM,(TD) 
          BX5    X4+X5       DI.TD + DI.INF = DIMENSION BOUND 
  
 CDB40    SA1    CDBA+3 
          SB5    X1          RESTORE (B5) 
          =B7    0           INDICATE NO ERROR
          =B4    B4-1        RESET *TB* TO END OF DIMENSION DESCRIPTOR
          EQ     EXIT.
  
 CDBA     BSS    5           CDB SAVE AREA
 CDBB     EQUENT CDBA+1      FILL. CELLS NEEDED IN PAR
 C=DBD    SPACE  4,8
**        C=DBD/A=DBD - PROCESS CLOSING *,* OR *)* FOR DIMENSION
*                       BOUND EXPRESSION. 
* 
*         ENTRY  (X5) = RESULTS OF EXPRESSION (TP. FORMAT)
* 
*         EXIT   (X5) = RESULTS OF EXPRESSION OR VARDIM TURPLE
* 
*         USES   A1,A2,A5,A6  B2,B3,B7  X0,X1,X2,X3,X5,X6 
* 
*         CALLS  EMT, MVE=, OVS 
  
  
 C=DBD    BSSENT 0           ENTRY... 
          SB4    B4+1 
 A=DBD    BSSENT 0           ENTRY... 
          LX2    X5 
          SBIT   X2,TP.INTRP
          PL     X2,DBD10    IF NOT EXPRESSION
          SA1    CDBA        FETCH FORMER T=PAR 
          SA2    E=TOTAL
          SA3    A1+4        FETCH PREVIOUS STATEMENT ERROR COUNT 
          IX2    X2-X3
          ZR     X2,DBD1     IF NO ERRORS THIS DIMENSION BOUND
          SHRINK T=PAR,X1    RESET PARSE FILE LENGTH
          MX4    0
          BX5    0
          EMIT   ERROP,*
          SA5    CONONE      DEFAULT BOUND WHEN ERROR 
          EQ     PAREXIT
  
*         HERE IF LEGAL DIMENSION BOUND EXPRESSION
*                (X1) = OLD PARSE FILE LENGTH 
  
 DBD1     SA2    T=PAR
          SA3    T=VDIM 
          IX0    X2-X1       LENGTH OF DIMENSION BOUND EXPRESSION 
          IX3    X3-X1       OFFSET FOR INTERMEDIATE CONVERSION 
          SA2    T.PAR
          LX6    X0 
          IX2    X1+X2       STARTING POINT FOR CONVERSION
          SB2    X0          LOOP COUNTER 
          SA1    X2          INITIALIZE LOOP
          SA6    OVSA        SAVE EXPRESSION LENGTH FOR OVS 
  
 DBD2     =A2    A1+OR.1OP
          =A4    A2-OR.1OP+OR.2OP 
          SBIT   X2,TP.INTRP
          SBIT   X4,TP.INTRP
          PL     X2,DBD3     IF NOT INTERMEDIATE
          LX2    TP.INTRL+TP.INTRP-TP.ORDP
          IX2    X3+X2       ADJUST WITH OFFSET 
          LX2    TP.ORDP
          BX6    X2 
          SA6    A2          RESET
 DBD3     PL     X4,DBD4     IF NOT INTERMEDIATE
          LX4    TP.INTRL+TP.INTRP-TP.ORDP
          IX4    X3+X4       ADJUST WITH OFFSET 
          LX4    TP.ORDP
          BX6    X4 
          SA6    A4          RESET
 DBD4     SA1    A1+Z=TURP
          SB2    B2-Z=TURP
          NZ     B2,DBD2     IF NOT FINISHED
  
*         THE PARSE FILE NOW CONTAINS DIMENSION BOUND TURPLES, ADJUSTED 
*         FOR INCLUSION IN THE VARDIM TABLE.
*                (X0) = LENGTH OF DIMENSION BOUND TURPLES 
  
          HX5    TP.ORD 
          LX5    TP.ORDL
          IX5    X5+X3       ADJUST THE FINAL INTERMEDIATE WITH OFFSET
          LX5    TP.ORDP
          LX4    X0 
          ALLOC  T.VDIM,X0   GET NEEDED SPACE 
          SA1    CDBA 
          SHRINK T=PAR,X1    RESET PARSE FILE LENGTH
          SA2    T.PAR
          IX2    X2+X1       ORIGIN OF DIMENSION BOUND TURPLES
          SX3    B7 
          IX3    X3-X4       DESTINATION OF TURPLES 
          MOVE   X4,X2,X3 
          BX4    X5 
          RJ     OVS         OUTPUT VARIABLE STORE TURPLE 
          EQ     PAREXIT
  
 DBD10    SBIT   X2,TP.SHRTP/TP.INTRP 
          MI     X2,PAREXIT  IF SHORT CONSTANT
          LX2    X5 
          HX2    TP.ORD 
          SA1    S=CON
          AX2    -TP.ORDL    ISOLATE ORDINAL
          IX3    X1-X2
          ZR     X3,PAREXIT  IF CONSTANT
  
*         HERE IF VARIABLE. 
  
          BX4    X5 
          RJ     OVS         OUTPUT VARIABLE STORE TURPLE 
          EQ     PAREXIT
 OVP      SPACE  4,8
**        OVP -  OUTPUT VARDIM PRODUCT OF SPANS 
* 
*         ENTRY  (DIMI) = T.DIM ENTRY CURRENTLY PROCESSING
* 
*         EXIT   (DIMI) = DH.PS CONTAINS VD. INDEX FOR PRODUCT OF SPANS 
*                (T.VDIM) - UPDATED WITH MULTIPLY TURPLES (AS NEEDED) 
*                (T.VDI)  - UPDATED WITH NEW VD. INFORMATION (AS NEEDED)
* 
*         USES   A1,A2,A3,A4,A5,A6,A7  B6  X0,X1,X2,X3,X4,X5,X6,X7
* 
*         CALLS  EMT, NCS, OVS
  
  
 OVP      SUBR               ...ENTRY/EXIT... 
          SA1    DIMI        FETCH HEADER 
          LX1    -DH.DIMP 
          MX0    -DH.DIML 
          BX5    -X0*X1      EXTRACT NUMBER OF DIMENSIONS 
          LX1    DH.DIMP
          HX1    DH.PS
          AX1    -DH.PSL     EXTRACT PRODUCT OF CONSTANT SPANS
          =B6    0
          =X0    1
          IX0    X1-X0
          ZR     X0,OVP1     IF NO CONSTANT SPAN
          LX6    X1 
          =X7    M.INT
          CALL   NCS
          SA6    B6+OVPA
          =B6    B6+1 
  
*         FETCH LOOP ON SPANS TO DETERMINE NUMBER OF MULTIPLIES 
*                (X5) = NUMBER OF DIMENSIONS
*                (B6) = COUNTER OF OPERANDS 
  
 OVP1     =A1    A1+1        PREFETCH SPAN (INITIAL)
          SA3    T.VDI
          SA4    T.VDIM 
  
 OVP2     BX7    X1          SAVE POSSIBLE VARIABLE SPAN
          HX1    D1.SPAN
          PL     X1,OVP3     IF NOT VARIABLE SPAN 
          LX1    -DM.INFL-DM.INFP+D1.SPANL
          AX1    -DM.INFL    EXTRACT VD. INDEX
          IX1    X3+X1
          SA2    X1          FETCH VD. INFORMATION
          HX2    VD.IND 
          AX2    -VD.INDL    EXTRACT STORE OPERAND INDEX
          IX2    X4+X2
          SA2    X2          FETCH VD. STORE OPERAND
          LX6    X2 
          SA6    B6+OVPA
          =B6    B6+1 
          SA7    OVPB        SAVE D1. ENTRY 
  
 OVP3     =X5    X5-1 
          ZR     X5,OVP4
          SA1    A1+Z=DD     FETCH NEXT SPAN
          EQ     OVP2 
  
*         LOOP FOR THE MULTIPLIES 
*                (B6) = COUNT OF OPERANDS 
  
 OVP4     =B6    B6-1 
          SA4    B6+OVPA     FETCH OPERAND
          LX7    X4 
          HX7    TP.BIAS
          AX7    -TP.BIASL   EXTRACT THE VD. INDEX
          ERRNZ  DM.INFP
          NZ     B6,OVP5     IF MULTIPLY TURPLES NEEDED 
          SA1    OVPB        FETCH D1. ENTRY
          LX7    X1          USE FOR DH. COMPLETION 
          EQ     OVP11
  
 OVP5     ZR     B6,OVP10    IF FINISHED
          =B6    B6-1 
          SA5    B6+OVPA     FETCH OPERAND
          EMIT   VD.MU,*,T.VDIM 
          SA1    OVSA 
          SX6    Z=TURP 
          IX6    X1+X6
          SA6    A1          INCREMENT TURPLE COUNT 
          SA2    T=VDIM 
          SX2    X2-Z=TURP
          CLAS=  X4,TP,(INTR),INT 
          LX2    TP.ORDP
          BX4    X2+X4       ORD + INTR + MODE
          EQ     OVP5        CONTINUE 
  
*         ALL MULTIPLIES OUTPUT, MAKE VD. FOR THE PRODUCT OF SPANS
*                (X4) = STORE OPERAND FOR PRODUCT OF SPANS VD.
  
 OVP10    RJ     OVS
 OVP11    SA1    DIMI        FETCH HEADER 
          MX0    DH.PSL 
          LX7    DH.PSP 
          CLAS=  X6,DH,(VP) 
          LX0    DH.PSL+DH.PSP
          BX7    X0*X7       EXTRACT VD. INDEX
          BX1    -X0*X1      CLEAR CONSTANT PRODUCT 
          BX7    X1+X7       VD. INDEX IS NOW PRODUCT OF SPANS
          BX7    X6+X7       INDICATE THIS
          SA7    A1 
          EQ     EXIT.
  
 OVPA     BSS    MAX.DIM
 OVPB     BSS    1
 OVS      SPACE  4,8
**        OVS -  OUTPUT VARIABLE DIMENSION STORE (VD.EQ) TURPLE 
* 
*         ENTRY  (X4) = OR.1OP (VALUE OF VD.) 
* 
*         EXIT   (X5) = VARDIM (TP. FORMAT) 
*                (X7) = DIMENSION DESCRIPTOR (DM. FORMAT) 
* 
*         USES   A1,2,3,4,5,6,7  B2,3,6,7  X0,1,2,3,4,5,6,7 
* 
*         CALLS  ADW, EMT 
  
  
 OVS      SUBR               ...ENTRY/EXIT... 
          SA5    S=VD 
          SA1    OVSA        TURPLE COUNT 
          SA2    N.VD 
          =X7    M.INT
          LX5    TP.ORDP     VD. ORDINAL
          LX2    TP.BIASP    USE CURRENT VDIM COUNTER 
          BX5    X5+X2       ORDINAL + BIAS 
          BX5    X5+X7       ORDINAL + BIAS + MODE
          SX7    X1+Z=TURP   INCREMENT FOR THE STORE TURPLE 
          SA7    A1 
          LX7    X5 
          SA7    OVSB        SAVE VD. OPERAND 
          EMIT   VD.EQ,*,T.VDIM 
  
*         THIS PORTION OF OVS ATTEMPTS TO SQUEEZE OUT THE TURPLES JUST
*         ADDED TO T.VDIM.  IF AN EXACT MATCH IS FOUND (ALLOWING FOR
*         ADJUSTED INTERMEDIATE OPERANDS) THAT VD. WILL BE USED AND THE 
*         TURPLES ADDED TO T.VDIM WILL BE TRASHED.  IF NOT, THE ENTRY 
*         STANDS AND A T.VDI ENTRY WILL BE MADE, N.VD UPDATED, ETC.  THE
*         SQUEEZE LOOP DEPENDS UPON NO TABLE MOVEMENT.  MODIFIERS BE
*         WARNED. 
  
          SA1    OVSA        LENGTH OF VD. EXPRESSION 
          SA2    T=VDIM 
          IX7    X2-X1       OFFSET FOR INTERMEDIATES 
          SX0    Z=TURP 
          IX1    X1/X0,B7    CONVERT SIZE TO NUMBER OF TURPLES
          SA2    T=VDI
          SB2    X1          NUMBER OF TURPLES, CURRENT VD. EXPRESSION
          SB3    X2          NUMBER OF T.VDI ENTRIES
  
*         THE FOLLOWING DUAL LOOP WILL TEST T.VDI ENTRIES FOR LENGTH
*         COMPATIBILITY.  IF AN EXISTING VD. EXPRESSION MATCHES THE 
*         CURRENT EXPRESSION IN LENGTH, AN INTERMEDIATE OFFSET IS 
*         CALCULATED, AND THE TWO EXPRESSIONS WILL BE COMPARED, TURPLE
*         BY TURPLE FOR A MATCH.  IF A MATCH IS FOUND, THE CURRENT
*         EXPRESSION TURPLES ARE ELIMINATED AND THAT VD. OPERAND IS 
*         USED.  IF NO MATCH, LOOP IS CONTINUED UNTIL T.VDI IS EXHAUSTED
*         AT WHICH POINT THE CURRENT ENTRY STANDS AS UNIQUE.
*                (X7) = INDEX OF CURRENT VD. EXPRESSION START 
*                (B2) = NUMBER OF TURPLES IN CURRENT VD. EXPRESSION 
*                (B3) = COUNT OF T.VDI ENTRIES (AS YET UNCHECKED) 
  
 OVS1     ZR     B3,OVS15    IF NO MORE ENTRIES 
          SA1    T.VDI
          =B3    B3-1 
          SA2    X1+B3       FETCH T.VDI ENTRY
          LX2    -VD.LENP 
          SB6    X2          EXTRACT NUMBER OF TURPLES
          ERRNZ  18-VD.LENL 
          SB6    B6-B2
          NZ     B6,OVS1     IF LENGTH NOT EQUAL, NO MATCH POSSIBLE 
  
*         A LENGTH MATCH IS FOUND.  PERFORM WORD BY WORD COMPARE FOR
*         MATCHING VD. ENTRY. 
  
          LX2    VD.LENP-VD.PNTP
          SB6    X2          EXTRACT ORDINAL OF START OF VD. EXPRESSION 
          ERRNZ  18-VD.PNTL 
          SX0    B6+B6
          SX0    X0+B6       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=TURP 
          SA1    T.VDIM 
          IX2    X1+X7       STARTING POINT, CURRENT VD. EXPRESSION 
          IX1    X1+X0       STARTING POINT, TO BE TESTED VD. EXPRESSION
          IX0    X7-X0       INTERMEDIATE OFFSET
          =B6    1           LOOP COUNTER 
          SA1    X1          PRE-FETCH TO BE TESTED VD. 
          SA2    X2          PRE-FETCH CURRENT VD.
          =A4    A2-OR.OPR+OR.1OP 
          SBIT   X4,TP.INTRP
          PL     X4,OVS3     IF NOT INTERMEDIATE
          SX0    0           IF FIRST TURPLE IS INTERMEDIATE, NO OFFSET 
  
 OVS3     EQ     B6,B2,OVS9  IF LAST (STORE) TURPLE 
          =A3    A1-OR.OPR+OR.1OP 
          =A4    A2-OR.OPR+OR.1OP 
          IX1    X1-X2
          NZ     X1,OVS1     IF OPERATORS DONT MATCH
          LX5    X4 
          SBIT   X5,TP.INTRP
          PL     X5,OVS5     IF NOT INTERMEDIATE
          LX4    -TP.ORDP 
          IX4    X4-X0       ADJUST BY OFFSET 
          LX4    TP.ORDP
 OVS5     IX3    X3-X4
          NZ     X3,OVS1     IF 1OPS DONT MATCH 
          =A3    A3-OR.1OP+OR.2OP 
          =A4    A4-OR.1OP+OR.2OP 
          LX5    X4 
          SBIT   X5,TP.INTRP
          PL     X5,OVS7     IF NOT INTERMEDIATE
          LX4    -TP.ORDP 
          IX4    X4-X0       ADJUST BY OFFSET 
          LX4    TP.ORDP
 OVS7     IX3    X3-X4
          NZ     X3,OVS1     IF 2OPS DONT MATCH 
          =A1    A1+Z=TURP
          =A2    A2+Z=TURP
          =B6    B6+1 
          EQ     OVS3        CONTINUE LOOP
  
*         ONLY CHECK OPERATOR AND FIRST OPERAND OF STORE TURPLE 
  
 OVS9     =A3    A1-OR.OPR+OR.1OP 
          =A4    A2-OR.OPR+OR.1OP 
          IX1    X1-X2
          NZ     X1,OVS1     IF OPERATORS DONT MATCH
          LX5    X4 
          SBIT   X5,TP.INTRP
          PL     X5,OVS11    IF NOT INTERMEDIATE
          LX4    -TP.ORDP 
          IX4    X4-X0       ADJUST BY OFFSET 
          LX4    TP.ORDP
 OVS11    IX3    X3-X4
          NZ     X3,OVS1     IF 1OPS DONT MATCH 
  
*         WE HAVE A MATCH, EXCEPT FOR VD. (WHICH CANT).  USE THE
*         TESTED VD. EXPRESSION 
  
          SA5    A3-OR.1OP+OR.2OP 
          SHRINK T=VDIM,X7   TRASH CURRENT VD. EXPRESSION 
          EQ     OVS20
  
 OVS15    SA5    OVSB 
          SA2    N.VD 
          =X7    X2+1        INCREMENT VD. COUNTER
          SA7    A2 
          SA1    OVSA        NUMBER OF TURPLES * Z=TURP 
          SA2    T=VDIM 
          SX0    Z=TURP 
          =X6    X2-OR.2OP+OR.1OP-1 
          IX2    X2-X1       STARTING POSITION
          LX6    VD.INDP
          IX1    X1/X0,B7    CONVERT LENGTH TO NUMBER OF TURPLES
          SX0    Z=TURP 
          IX2    X2/X0,B7    CONVERT STARTING POSITION TO ORDINAL 
          LX1    VD.LENP
          LX2    VD.PNTP
          BX6    X6+X1       IND + LEN
          BX6    X6+X2       IND + PNT + LEN
          ADDWD  T.VDI
 OVS20    LX7    X5 
          CLAS=  X6,DM,(TD) 
          HX7    TP.BIAS
          AX7    -TP.BIASL   EXTRACT VD. INDEX
          LX7    DM.INFP
          BX7    X6+X7       DIMENSION DESCRIPTOR 
          SX6    0
          SA6    OVSA        CLEAR TURPLE COUNT 
          EQ     EXIT.
  
 OVSA     CON    0           TURPLE COUNT FOR VD. (* Z=TURP)
 OVSB     BSS    1           SAVE VD. OPERAND DURING SQUEEZE
 OVT      SPACE  4,8
**        OVT -  OUTPUT VARIABLE DIMENSION TURPLE (VD.PL OR VD.MI)
* 
*         ENTRY  (X4) = OR.1OP
*                (X5) = OR.2OP
*                (B3) = TURPLE TO OUTPUT
* 
*         EXIT   (X4) = INTERMEDIATE (TP. FORMAT) 
* 
*         USES   A1,A2,A7  B3  X1,X2,X4,X7
* 
*         CALLS  EMT
  
  
 OVT      SUBR               ...ENTRY/EXIT... 
          EMIT   B3,*,T.VDIM
          SA2    T=VDIM 
          SA1    OVSA 
          SX7    Z=TURP 
          IX2    X2-X7       FORM THE INTERMEDIATE INDEX
          IX7    X1+X7       INCREMENT TURPLE COUNT 
          SA7    A1 
          LX2    TP.ORDP
          CLAS=  X4,TP,(INTR),INT 
          BX4    X2+X4       ORD + INTR + MODE
          EQ     EXIT.
          TITLE  DECLARATIVE SCANNING AND SUPPORTING ROUTINES 
 EQS      SPACE  4,8
**        EQS -  PROCESS "EQUIVALENCE" DECLARATION. 
* 
*         PERFORMS SYNTAX CHECKING OF THE STATEMENT, AND TRANSLATES THE 
*         EQUIVALENCES INTO T.EQUS TO AWAIT THE CLOSE OF DECLARATIVES.
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         SEE ANSI 8.2
  
  
          HEREIF EQUIVALENCE
  
          =X6    CR.DEC 
          SA6    REFVAR      SET REFERENCE TYPE 
          SB4    B4-B1
  
**        BEGIN NEW EQUIVALENCE GROUP.
*                (B4) _ LPAREN IN FRONT OF GROUP. 
  
 EQS10    SA1    B4+B1
          SB4    B4+B1       ADVANCE B4 TO 1ST SYMBOL 
          ZR     X1,E.MR3    IF *EOS* - ERROR 
          SB7    X1-O.( 
          SX6    B1 
          SA6    EQSR        (EQSR) = GROUP COUNT = 1 
          NZ     B7,E.EQ1    IF NO *(* - ERROR
  
  
**        NOW PROCESS A NAME. 
*                (B4) _ SYMBOL
  
 EQS20    SA1    B4+B1
          SB4    B4+B1
          BX6    X1 
          =B2    0           ENTRY (VALUE.) NOT ALLOWED 
          SA6    FILL.       SAVE NAME FOR (POSSIBLE) ERROR MESSAGE 
          CALL   TRV         TRANSLATE VARIABLE 
          MI     X0,EQS80    IF TRV DETECTED ERROR
          =A3    A2-WB.W+WA.W 
          CLAS=  X6,WA,NFP
          BX6    X3+X6
          SA6    A3          NFP[WA] = 1
          CLAS=  X3,WB,(NVAR,LAB,FP,NLST,DEXT,ENT,PARM,EXT) 
          =X1    WB.EQVP
          CALL   CCT         CHECK FOR CONFLICTING CLASS
          MI     X0,EQS80    IF CLASS CONFLICT
          SA4    EQSR 
          LX6    X4 
          BX7    X2 
          SX1    B7 
          LX6    EQ.LINKP 
          SA7    EQSB        SAVE SYMTAB PROPERTIES (WB)
          BX6    X6+X1       MERGE GROUP FLAG WITH SYMTAB WB INDEX
          SX7    X4+B1
          SA7    A4          (EQSR) = (EQSR) + 1
          ADDWD  T.EQUS      1ST WORD TO TABLE
          SX6    X2-1        HDIND = (T=EQUS) - 1 
          SA6    EQSH        (EQSH) = INDEX OF 1ST WORD 
          SA4    B4+B1
          SB4    B4+B1       ADVANCE B4 
          SB6    X4-O.LP
          MX6    0
          SA6    EQSS        (EQSS) = SUBSCRIPT COUNT = 0 
          SA2    EQSB 
          HX4    TB.COL 
          HX2    WB.ARY 
          NZ     B6,EQS25    IF NOT LEFT PAREN
          PL     X4,EQS40    IF NO COLON IMBEDED
          ADDWD  T.EQUS      FAKE SUBSCRIPT OF ZERO 
          EQ     EQS60       BEFORE GO OFF TO SUB-STRING PROCESSING 
  
 EQS25    ADDWD  T.EQUS      FAKE SUBSCRIPT OF ZERO 
          EQ     EQS65
  
  
**        PROCESS SUBSCRIPT.
  
 EQS40    SA1    EQSH        1ST WORD INDEX 
          SA2    T.EQUS 
          SB7    X1 
          SA1    X2+B7       FETCH ITEM 1ST WORD
          CLAS=  X2,EQ,(ISUB) 
          BX6    X1+X2       MERGE IN SUBSCRIPTED INDICATOR 
          SA6    A1          UPDATE 
          SB4    B4+1        ADVANCE *TB* POINTER 
          CALL   PIX         PARSE THE SUBSCRIPT
          SA5    EQSS        SUBSCRIPT COUNT = (EQSS) 
          SX4    X5-MAX.DIM-1 
          SX7    X5+B1
          SA7    A5          (EQSS) = (EQSS) + 1
          MX0    -EQ.SUBSL
          LX6    -EQ.SUBSP
          BX6    -X0*X6      TRUNCATE TO EQ.SUBS (IF NEGATIVE)
          LX6    EQ.SUBSP 
          ADDWD  T.EQUS      ADD SUBSC TO TABLE 
          SA1    B4 
          SX2    X1-O.COMMA 
          SB7    X1-O.) 
          PL     X4,E.EQ4    IF TOO MANY SUBSCRIPTS 
          ZR     X2,EQS40    IF COMMA, MORE SUBSCRIPTS
          NZ     B7,E.EQ3    IF NO RPAREN, ERROR
          SA4    B4+B1
          SB4    B4+B1
  
*         PROCESS (POSSIBLE) SUBSTRING. 
  
 EQS60    SB3    X4-O.LP
          NE     B3,EQS65    IF NOT LEFT PAREN
          SA1    EQSH 
          SA2    T.EQUS 
          IX3    X1+X2
          SA1    X3          SYMIND = SYMI[T.EQUS( (EQSH) ) 
          RJ     PKS         PARSE CONSTANT SUBSTRING 
          SA1    EQSH 
          SA2    T.EQUS 
          IX1    X1+X2
          LX5    EQ.STFP
          SA1    X1          EQI = T.EQUS(EQIND)
          BX6    X1+X5
          SA6    A1          STF[EQI] = SUBSTRING-FIRST 
          SA4    B4 
  
**        END OF EQUIVALENCE ITEM.
*                (X4) = NEXT *SB* ENTRY.
*                (B4) _ COMMA, AFTER THE SYMBOL, OR 
*                       RPAREN, TERMINATING THE GROUP.
  
 EQS65    SB7    X4-O.COMMA 
          SX3    X4-O.) 
          ZR     B7,EQS20    IF COMMA, GET MORE NAMES 
          NZ     X3,E.EQ     IF NO RIGHT PAREN ... ERROR
  
  
**        CLOSE OUT AN EQUIVALENCE GROUP. 
*                CHECK FOR TRIVAL GROUP.
*                SYNTAX CHECK FOR COMMA OR *EOS*. 
  
          SA2    EQSR 
          SB6    X2 
          =B7    2
          =A4    B4+1 
          GT     B6,B7,EQS70 IF MORE THAN ONE MEMBER IN GROUP 
          WARN   E.EQ6       TRIVIAL GROUP - WARNING
  
 EQS70    SB4    B4+B1       ADVANCE B4 
          SB7    X4-O.COMMA 
          ZR     B7,EQS10    IF COMMA 
          NZ     X4,E.EQ2    IF NOT *EOS* 
          ERRNZ  O.EOS
          EQ     FEC.RTN     EXIT TO FRONT END CONTROLLER...
  
  
**        RETURN TO HERE WHEN AN ERROR IS FOUND.
*                SEARCH FOR AN LPAREN IN ATTEMPT TO RECOVER FROM THE
*                ERROR, AND RESUME SYNTAX CHECKING. 
  
 EQS80    BSSENT 0           ...RETURN FROM ERROR PROCESSOR 
          SA1    B4+B1
          SB4    B4+B1
          ZR     X1,FEC.RTN  IF *EOS* 
          ERRNZ  O.EOS
          LX1    CHAR 
          SX1    X1-O.( 
          NZ     X1,EQS80    IF NO LPAREN 
          SB4    B4-B1
          EQ     EQS10       TRY FOR MORE 
  
 EQSB     EQU    DIRT        CELL TO SAVE SYMTAB WORD WB
 EQSH     EQU    DIRS        CELL TO SAVE T.EQUS INDEX OF FIRST WORD
 EQSS     EQU    DIRI        CELL TO SAVE SUBSCRIPT COUNT 
 EQSR     BSS    1           CELL TO SAVE GROUP MEMBER COUNT
 EXT      SPACE  4,10 
**        EXT -  PROCESS "EXTERNAL" DECLARATION.
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         SEE ANSI 8.7
  
  
          HEREIF EXTERNAL 
  
          CLAS=  X2,WB,(DEXT,EXT,NVAR)
          BX6    X2 
          SA6    EXTA        INDICATE *EXTERNAL* STATEMENT
 EXT1     SA1    B4 
          ZR     X1,E.EX3    IF NO NEXT ITEM - ERROR
          MX0    CH.DPCL
          SB2    X1-O.VAR 
          BX6    X0*X1       ELEMENT ONLY.
          SA6    FILL.       IN CASE OF ERROR.
          NZ     B2,E.VA09   IF NOT VARIABLE
          =A1    B4+1 
          =B4    B4+1 
          SB7    X1-O.VAR 
          NZ     B7,EXT6     IF NOT LONG NAME 
          =B4    B4-1 
          CALL   TLV         TRUNCATE NAME
          =B4    B4+1 
 EXT6     CALL   SSY         SCAN SYMBOL TABLE
          MI     B7,EXT10    IF *NIT* 
          BX1    X2 
          SBIT   X1,WB.DEXTP
          PL     X1,EXT7     IF NOT DEFINED EXTERNAL
          WARN   E.EX1
          EQ     EXT15       CONTINUE.
  
 EXT7     SBIT   X1,WB.ENTP/WB.DEXTP
          PL     X1,EXT8     IF NOT EXTERNAL
          WARN   E.EX4
          EQ     EXT15       CONTINUE 
  
 EXT8     SBIT   X1,WB.ALP/WB.ENTP
          PL     X1,EXT9     IF AUTOMATIC LEVEL OFF 
          CLAS=  X1,WB,(AL,LEV) 
          BX2    -X1*X2      CLEAR AL AND LEV FOR EXTERNAL SYMBOL 
  
 EXT9     CLAS=  X3,WB,(LAB,VAR,INTF,GENF,ENT,PARM) 
          SX1    WB.DEXTP 
          CALL   CCT         CHECK FOR CONFLICTING CLASS
          MI     X0,EXT15    IF CLASS CONFLICT
          SA3    EXTA 
          BX7    X3+X2       MERGE *EXTERNAL* PROPERTY BITS 
          SA7    A2 
          EQ     EXT15       CONTINUE.
  
 EXT10    CALL   STY         SET NATURAL TYPE 
          SA3    EXTA 
          BX7    X3+X1
          ADSYM  T.SYM
  
 EXT15    =X6    X0          CONSTRUCT XREF ORD 
          LX6    XR.TAGP
          ADDREF X6,CR.SUB
          SA1    B4 
          SB4    B4+B1
          SX2    X1-O.COMMA 
          ZR     X2,EXT1     IF NO *EOS*
          ZR     X1,FEC.RTN  IF COMPLETE
          =B4    B4-1 
          FATAL  E.EX2
  
**        HERE IF SYNTAX ERROR ENCOUNTERED
*         ADVANCE TILL NEXT SEPARATOR FOUND AND CONTINUE. 
  
 EXT20    SA1    B4 
          SX2    X1-O.COMMA 
          ZR     X2,EXT1     IF COMMA AFTER ERROR 
          SB4    B4+B1
          NZ     X1,EXT20    CONTINUE.
          EQ     FEC.RTN     EXIT TO FRONT END CONTROLLER 
  
 EXTA     EQU    DIMI        HOLDS PROPERTY BITS FOR SYMTAB (WB)
 INT      SPACE  4,8
**        INT -  PROCESS "INTRINSIC" DECLARATION
* 
*         EXIT   TO FRONT END CONTROLLER
* 
*         SEE ANSI 8.8
  
  
          HEREIF INTRINSIC
  
 INT1     SA1    B4          FETCH INTRINSIC
          SB2    X1-O.VAR 
          NZ     B2,E.IN     IF NOT INTRINSIC 
          SX2    X1 
          IX1    X1-X2       NAME ONLY
          BX6    X1 
          SA6    FILL.
          CALL   SLT         SCAN LIBRARY TABLE 
          SB5    B2          SAVE F.INTF INDEX
          PL     B2,INT2     IF IN INTRINSIC TABLE
          FATAL  E.IN1
          EQ     INT10
  
*                (X3) = *WB* SYMTAB ENTRY 
*                (X7) = *WC* SYMTAB ENTRY 
  
 INT2     LX5    X7          SAVE *WC*
          CLAS=  X7,WB,(INTF) 
          BX7    X3+X7       SAVE *WB* (CORRECT REGISTER FOR ESY) 
          CALL   SSY         SCAN SYMBOL TABLE
          PL     B7,INT5     IF ALREADY IN SYMBOL TABLE 
          BX2    X5 
          ADSYM  A1          ENTER INTO SYMBOL TABLE
          EQ     INT10
  
*                (X5) = *WC* SYMTAB ENTRY 
*                (X7) = *WB* SYMTAB ENTRY 
  
 INT5     SX1    WB.INTFP 
          CLAS=  X3,WB,(VAR,EXT,ENT,FP) 
          CALL   CCT         CHECK CONFLICTS
          MI     X0,INT10    IF CONFLICT
          LX0    X2 
          SBIT   X0,WB.INTFP
          PL     X0,INT6     IF NOT ALREADY INTRINSIC 
          WARN   E.IN2
          EQ     INT10
  
*                (B5) = F.INTF INDEX OF INTRINSIC 
  
 INT6     SBIT   X0,WB.TYPP/WB.INTFP
          PL     X0,INT7     IF NOT TYPED 
          MX0    -WB.MODEL
          BX3    -X0*X2      ISOLATE TYPED MODE 
          ERRNZ  WB.MODEP 
          SA1    B5+F.INTF   FETCH INTRINSIC TABLE ENTRY
          BX1    -X0*X1      ISOLATE INTRINSIC MODE 
          ERRNZ  IT.MODEP 
          ERRNZ  IT.MODEL-WB.MODEL
          IX3    X1-X3
          ZR     X3,INT7     IF CONFIRMING MODE 
          BX2    X0*X2       CLEAR NON CONFIRMING MODE
          IX2    X2+X1       REPLACE WITH INTRINSIC MODE
          WARN   E.IN3
  
 INT7     BX6    X5          *WC* 
          BX7    X2+X7       MERGE IN INTRINSIC BITS
          SA7    A2          UPDATE *WB*
          =A6    A7-WB.W+WC.W 
  
 INT10    =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.COMMA 
          ZR     X1,FEC.RTN  IF *EOS* 
          ERRNZ  O.EOS
          NZ     B2,E.IN4    IF NOT *COMMA* 
          =B4    B4+1 
          EQ     INT1        CONTINUE.. 
 LVL      SPACE  4,10 
**        LVL -  PROCESS "LEVEL" STATEMENT
* 
*         EXIT   TO FRONT END CONTROLLER. 
  
  
          HEREIF LEVEL
  
          ANSI   E.ANS
          SA4    B4          LEVEL NUMBER 
          MX6    CA.BNAML 
          SA6    LEVEL       FLAG LEVEL STATEMENT 
          SA6    SCSA        MASK FOR SCS 
          SB2    X4-O.CONS
          SB3    X4-O.VAR 
          ZR     X4,E.LV1    IF PREMATURE E.O.S.
          ERRNZ  O.EOS
          ZR     B2,LVL05    IF NUMBER
          NZ     B3,E.LV1    IF NOT VARIABLE
  
*         CHECK FOR POSSIBLE SYMBOLIC CONSTANT. 
  
          CALL   CSC         CHECK SYMBOLIC CONSTANT
          MI     B7,E.LV1    IF VAR NOT SYMBOLIC CONSTANT 
          SX5    X6+1R0 
          LX0    XR.TAGP
          SB5    X1          SAVE MODE ACROSS ERT CALL
          BX4    X6          SAVE BINARY ACROSS ERT 
          SX1    CR.DEC 
          ADDREF X0,X1       FOR PARAMETER
          LX6    X4          RESTORE BINARY 
          ZR     B5,LVL10    IF MODE BOOLEAN
          ERRNZ  M.BOOL 
          SB5    B5-M.INT 
          ZR     B5,LVL10    IF MODE INTEGER
          EQ     E.LV1
  
 LVL05    MX0    TB.TOCL
          HX4    TB.TOC 
          BX5    X0*X4       ISOLATE TOKEN VALUE FOR THE NUMBER 
          SX6    1R0
          LX5    CHAR 
          IX6    X5-X6       BINARY OF LEVEL NUMBER 
  
 LVL10    SX2    1R3
          IX1    X2-X5       .MI. IFF (3 .LT. LEV)
          BX2    X1+X6
          MI     X2,E.LV1    IF (LEV .LT. 0) OR (LEV .GT. 3)
          BX7    X6 
          NZ     X6,LVL15    IF (LEV .NE. 0)
          SX7    X6+2 
  
 LVL15    SX2    X7+.DAL-3
          ERRPL  .DAL-2 
          MI     X2,LVL20    IF (LEVNO+.DAL) .LT. 3 THEN NOT LARGE CORE 
  
 #MI      IFEQ   .MI,ON 
          NZ     X2,LVL19    IF LEVEL 3 
          SA2    CO.TMLC
          ZR     X2,LVL20    IF NO LCM
  
 LVL19    BSS    0
 #MI      ENDIF 
  
          SA7    LEVEL2      INDICATE THAT LARGE CORE VARIABLES APPEARED
  
 LVL20    SA6    LVLA        REMEMBER (LVLA) = LEVNO
  
*         PROCESS COMMA FOLLOWING LEVEL NUMBER. 
  
          =A1    B4+1 
          =B4    A1+1 
          SB2    X1-O.COMMA 
          ZR     X1,E.LV3    IF PREMATURE E.O.S.
          ZR     B2,LVL25    IF COMMA 
          WARN   E.LV2       MISSING COMMA
          =B4    B4-1 
  
*         PROCESS VARIABLE/ARRAY LIST 
  
 LVL25    SA1    B4          FETCH NAME 
          SB2    X1-O.VAR 
          SB3    X1-O.SLASH 
          SB7    X1-O.CAT 
          ZR     B2,LVL30    IF NAME
          ZR     B3,LVL35    IF SLASH 
          ZR     B7,LVL32    IF BLANK COMMON
          EQ     E.LV3       ERROR... 
  
*         PROCESS VARIABLE NAME.
  
 LVL30    BSS    0
          MX0    WA.SYML
          BX6    X0*X1
          SA6    FILL.       SAVE NAME FOR POSSIBLE ERROR MESSAGE 
          SB2    0           ENTRY (VALUE.) NOT ALLOWED 
          CALL   TRV         TRANSLATE VARIABLE 
          MI     X0,LVL90    IF TRV DETECTED ERROR
          CLAS=  X3,WB,(LAB,NVAR,PARM,DEXT,ENT,NLST,EXT)
          SBIT   X2,WB.ALP
          PL     X2,LVL31    IF AUTOMATIC LEVEL OFF 
          CLAS=  X1,WB,(AL,LEV,LCM) 
          SBIT   X1,WB.ALP
          BX2    -X1*X2      CLEAR AL, LEV, LCM BITS
  
 LVL31    SBIT   X2,WB.LEVP/WB.ALP
          MI     X2,E.LV4    IF ALREADY *LEVELED* 
          LX2    1+WB.LEVP   RESTORE (X2) 
          =X1    WB.LEVP
          CALL   CCT         CHECK FOR CONFLICTING CLASS
          MI     X0,LVL90    IF CLASS CONFLICT
          SA4    LVLA 
          LX4    WB.LEVNP 
          CLAS=  X3,WB,(LEV,VAR)
          BX4    X4+X3
          BX6    X2+X4       MERGE LEVEL NUMBER AND PROPERTY BITS 
          SA6    A2          (LEV,LEVN,VAR)[WBI] = (1,LEVNO,1)[WB.] 
          EQ     LVL90
  
*         PROCESS BLOCK NAME. 
  
 LVL32    SA1    =2H//       BLANK COMMON NAME FOR ERROR MESSAGE
          SA4    =7L         BLANK COMMON NAME IN BLOCK TABLE 
          SX7    O.SLASH
          BX6    X1 
          SA7    B4          REPLACE // WITH SLASH
          SB4    B4-B1       AND DECREMENT TB POINTER 
          EQ     LVL50
  
 LVL35    BSS    0
          SA1    B4+B1
          SB4    B4+B1
          SB2    X1-O.VAR 
          NZ     B2,E.LV3    IF NOT ALPAHBETIC
          SA2    B4+B1
          SB2    X2-O.VAR 
          NZ     B2,LVL40    IF NOT LONG NAME 
          CALL   TLV
  
 LVL40    SX2    X1 
          IX6    X1-X2
          BX4    X6 
  
 LVL50    SA6    FILL.       SAVE BLOCK NAME FOR ERROR MESSAGE
          SA5    LVLA 
          LX5    CA.BLVLP 
          BX6    X4 
          ZR     X5,E.LV8    IF LEVEL 0 DECLARATION 
          SCAN   T.BLKS,SCS 
          MI     B7,LVL70    IF BLOCK NOT ALREADY DECLARED
  
*         CHECK FOR REDUNDANT BLOCK LEVEL DECLARATION.
*         (X5) = LEVEL NUMBER 
  
          MX0    -CA.BLVLL
          LX2    -CA.BLVLP
          BX0    -X0*X2      BLKLEV = BLVL[CAI] 
          LX2    CA.BLVLP 
          NZ     X0,E.LV7    IF BLKLEVL .NE. 0
          BX7    X5+X2
          SA7    A2          BLVL[CAI] = BLKLEV 
          EQ     LVL80
  
*         COMMON BLOCK NOT BEING DECLARED YET, CREATE AN
*         ENTRY FOR THIS BLOCK. 
  
 LVL70    ALLOC  T.BLKS,Z=BLKS
          SX3    X2-MAX.BLK*Z=BLKS+1
          SA1    =7L
          BX7    0
          BX6    X4+X5
          =A6    B7-Z=BLKS+CA.W    (BNAM,BLVL)[CAI] = (NAME,BLKLEV)[CA.]
          =A7    A6-CA.W+CB.W 
          IX4    X4-X1
          PL     X3,E.CM2    IF TOO MANY BLOCKS 
          NZ     X4,LVL80    IF NOT BLANK COMMON
          SX7    X2-Z=BLKS   BLOCK ORD = LEN(T=BLKS) - Z=BLKS 
          SA7    BLNKCOM
  
 LVL80    BSSENT 0           ...RETURN FROM ERROR PROCESSOR 
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.SLASH 
          NZ     B2,E.CM3    IF SLASH MISSING 
  
*         CHECK NEXT SEPARATOR, LOOP FOR MORE ITEMS.
  
 LVL90    BSSENT 0           ...RETURN FROM ERROR PROCESSOR 
          =A1    B4+1 
          =B4    A1+1        B4 = B4 + 2
          SB2    X1-O.COMMA 
          ZR     X1,FEC.RTN  IF *EOS* 
          ERRNZ  O.EOS
          ZR     B2,LVL25    IF COMMA,CONTINUE PROCESSING LIST
          EQ     E.LV5       BAD SYNTAX 
  
 LVLA     EQU    DIMI        HOLDS LEVEL NUMBER 
 PARAM    SPACE  4,10 
**        PROCESS "PARAMETER" STATEMENT.
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         SEE ANSI 8.6
  
  
          HEREIF PARAMETER
  
          SA1    B4 
          SB2    X1-O.LP
          ZR     B2,PRM10    IF LEFT PAREN
          FATAL  E.PX2       INITIAL LEFT PAREN MISSING 
 PRM10    SB4    B4+B1
  
*         LOOP TO PROCESS INDIVIDUAL PARAMETER DECLARATIONS.
*         CURRENT TOKEN MUST BE O.VAR FOLLOWED BY O.= 
  
 PRM20    SA1    B4 
          SA2    B4+B1
          SB2    X1-O.VAR 
          NZ     B2,E.PX3    IF NO VARIABLE 
          SB3    X2-O.VAR 
          NZ     B3,PRM21    IF NOT LONG NAME 
          CALL   TLV         TRUNCATE THE LONG NAME 
          SA2    B4+1 
  
 PRM21    SB3    X2-O.= 
          MX0    TB.TOCL
          HX1    TB.TOC 
          BX6    X0*X1
          SB4    B4+1 
          NZ     B3,E.PX4    IF NO EQUAL SIGN 
          SA6    PRMA        (PRMA) = VARIABLE NAME 
  
*         CALL PARSER TO EVALUATE THE EXPRESSION.  THE NAME IS NOT YET
*         IN THE SYMTAB, SO PAR WILL GIVE A DIAGNOSTIC IF IT IS USED ON 
*         THE RIGHT HAND SIDE.
  
          SX6    PM=PARM     *PKX* STORES THIS INTO *PARMODE* 
          SB4    B4+B1
          CALL   PKX         PARSE KONSTANT EXPRESSION
  
          SX2    X6+B1       CO1 = CONORD + 1 
          SX5    B6          CONLEN = LENGTH OF CONSTANT
          LT     B2,PRM28    IF MATERIAL CONSTANT 
          EQ     B2,PRM29    IF RESULT IS NOT A CONSTANT
          SCAN   T.CON,SCT
          SX2    B7+B1       CO1 = CONORD + 1 
          PL     B7,PRM28    IF THIS VALUE ALREADY PRESENT
          ADDWD  A1 
  
 PRM28    SX6    X2-1        CONORD = CO1 - 1 
          LX5    DI.DLENP 
          SX1    B5          (DI.MODE) = CONMODE
          LX6    DI.PNTP
          BX7    X6+X5
          LX1    DI.MODEP 
          BX7    X1+X7
          SA7    PRMB        (PRMB) = (MODE,PNT,LEN) [DI.]
  
*         NOW ENTER THE PARAMETER NAME IN THE SYMBOL TABLE. 
  
 PRM29    SA1    PRMA 
          BX6    X1 
          SA6    FILL.       FOR POSSIBLE DIAGNOSTIC
          CALL   SSY         SCAN SYMBOL TABLE
          CLAS=  X7,WB,(PARM,DEF,NVAR)
          MI     B7,PRM30    IF SYMBOL NOT IN TABLE 
  
*         SYMBOL ALREADY IN TABLE.
  
          BX6    X0 
          SA6    PRMC        SAVE THE SYMORD
          CLAS=  X3,WB,(FP,VAR,NVAR,LAB,PARM) 
          SX1    WB.PARMP 
          CALL   CCT         CHECK CONFLICTING TYPE 
          MI     X0,PRM70    IF CONFLICT
          BX6    X7+X2       UPDATE SYMTAB ATTRIBUTES 
          SA6    A2          (PARM,DEF,VAR) [WBI] = (1,1,1) [WB.] 
          EQ     PRM40
  
*         SYMBOL NOT IN TABLE, CONSTRUCT AN ENTRY FOR IT. 
  
 PRM30    CALL   STY         SET NATURAL TYPE 
          BX5    X1          REMEMBER (X5) = MODE 
          BX4    X2          REMEMBER (X4) = CLEN 
          LX1    WB.MODEP 
          BX7    X1+X7       ADD IN NATURAL MODE
          AX4    WC.CLENP 
          ADSYM  T.SYM       ADD TO SYMBOL TABLE
          BX7    X0 
          SA7    PRMC        SAVE THE SYMORD
  
 PRM40    SA1    PARAMC 
          =X6    X1+1 
          SA6    A1          INCREMENT PARAMETER COUNT
          =A3    A2-WB.W+WC.W 
          HX3    WC.CTYP
          MX7    -WB.MODEL
          AX2    WB.MODEP 
          BX2    -X7*X2      MODEI = MODE[WBI]
          =X4    2           WDCNT = 2
          SB3    X2-M.CHAR
          MI     X3,PRM50    IF WC.CTYP .EQ. 1
          SB2    X2-M.DBL 
          LX3    WC.CTYPP+1-WC.CLENP
          ZR     B2,PRM60    IF DOUBLE
          EQ     B2,B1,PRM60 IF COMPLEX 
          ERRNZ  M.CPLX-1-M.DBL 
          =X4    1           WDCNT = 1
          NZ     B3,PRM60    IF NOT CHARACTER 
          MX1    -WC.CLENL
          BX4    -X1*X3      WDCNT = CLEN[WCI]
          EQ     PRM60
  
 PRM50    CLAS=  X4,WC,(CTYP,CLEN)
          LX3    1+WC.CTYPP 
          BX7    -X4*X3      CLEAR (CTYP,CLEN) FILEDS 
          SA1    PRMB 
          AX1    DI.DLENP 
          SX4    X1          CONLEN = DLEN[PRMB]
          ERRNZ  18-DI.DLENL
          LX4    WC.CLENP 
          BX7    X7+X4
          SA7    A3          (CTYP,CLEN) [WCI] = (0,CONLEN)[WC.]
          LX4    -WC.CLENP
  
*         NOW THAT EXPRESSION AND NAME ARE BOTH AVAILABLE, CONVERT TYPE 
*         ACCORDING TO ASSIGNMENT RULES, AND ENTER CONSTANT VALUE.
*         (X2) = DESIRED VARIABLE TYPE
*         (X4) = DESIRED VARIABLE LENGTH
  
 PRM60    BSS    0
          SA5    PRMB        CONSTANT DESCRIPTOR = (PRMB) 
          CALL   CMV
          AX5    DI.PNTP
          SX5    X5          PNT = PNT[DI.] 
          ERRNZ  18-DI.PNTL 
          SA1    PRMC        ORDI = (PRMC)
          SA2    T.SYM
          =B2    X1+WC.W
          LX3    X1,B1
          SB2    X3+B2       STIND = 3 * ORDI 
          ERRNZ  3-Z=SYM
          SA1    X2+B2       WCI = T.SYM(STIND) + WC.W
          MX4    -WC.RAL
          LX1    -WC.RAP
          BX7    X4*X1
          BX7    X7+X5
          LX7    WC.RAP 
          SA7    A1          RA[WCI] = PNT
  
 PRM70    SA1    PRMC        CONSTRUCT XREF ENTRY 
          LX1    XR.TAGP
          ADDREF X1,CR.STR
  
*         FINISHED INDIVIDUAL PARAMETER.  CHECK FOR MORE DEFINITINONS,
*         OR STATEMENT TERMINATION. 
  
 PRM80    SA4    B4 
          SB4    B4+B1
          SB3    X4-O.COMMA 
          SB2    X4-O.RP
          ZR     B3,PRM20    IF COMMA 
          NZ     B2,E.PX5    IF NOT *)* 
          SA1    B4+
          NZ     X1,E.PX8    IF NOT *EOS* 
          ERRNZ  O.EOS
          EQ     FEC.RTN
  
 PRMERR   BSSENT 0
          SB4    B4+B1
          SA1    B4 
          =B2    X1-O.COMMA 
          =B3    X1-O.RP
          ZR     X1,FEC.RTN  IF *EOS* 
          ERRNZ  O.EOS
          ZR     B3,FEC.RTN  IF TERMINATING *)* 
          ZR     B2,PRM20    IF COMMA, CONTINUE 
          EQ     PRMERR      LOOP 
  
 PRMA     EQU    DIMI        SAVE SYMBOL NAME 
 PRMB     EQU    PRMA+1      SAVE CONSTANT DESCRIPTOR WORD
 PRMC     EQU    PRMB+1      SAVE SYMORD
 SAV      SPACE  4,8
**        SAV -  PROCESS "SAVE" STATEMENT 
* 
*         EXIT   TO FRONT END CONTROLLER
* 
*         SEE ANSI 8.9
  
  
          HEREIF SAVE 
  
          SA1    B4 
          MX6    CA.BNAML 
          SA6    SCSA        MASK FOR SCS 
          NZ     X1,SAV1     IF NOT *EOS* (NOT UNIVERSAL SAVE)
          CLAS=  X6,WB,(SAVE) 
          SA6    USAVE       SET UNIVERSAL SAVE 
          EQ     FEC.RTN     EXIT TO FRONT END CONTROLLER...
  
 SAV1     CLAS=  X6,WB,(SAVE) 
          SA6    SAVE        SET SAVE PRESENT 
 SAV2     SB2    X1-O.VAR 
          SB3    X1-O.SLASH 
          ZR     B2,SAV5     IF VARIABLE
          ZR     B3,SAV10    IF COMMON BLOCK
          EQ     E.SA1       ELSE ERROR 
  
 SAV5     BSS    0
          CALL   TRV         TRANSLATE THE VARIABLE 
          MI     X0,SAV20    IF CONFLICT, BYPASS
          LX0    X2 
          SBIT   X0,WB.FPP
          PL     X0,SAV6     IF NOT FORMAL PARAMETER
          FATAL  E.SA5
          EQ     SAV20
  
 SAV6     CLAS=  X1,WB,(SAVE) 
          BX0    X1*X2
          ZR     X0,SAV7     IF NOT REDUNDANT DECLARATION 
          WARN   E.SA2
 SAV7     BX7    X1+X2       MERGE IN SAVE BIT
          SA7    A2          AND UPDATE SYMTAB
          EQ     SAV20
  
 SAV10    BSS    0
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.VAR 
          NZ     B2,E.SA1    IF NOT ALPHABETIC
          SA2    B4+1 
          SB2    X2-O.VAR 
          NZ     B2,SAV13    IF NOT LONG NAME 
          CALL   TLV         TRUNCATE 
 SAV13    SX2    X1 
          IX6    X1-X2
          SA6    FILL.       SAVE FOR POSSIBLE DIAGNOSTIC 
          SCAN   T.BLKS,SCS 
          MI     B7,SAV16    IF COMMON BLOCK NOT IN T.BLKS
          CLAS=  X1,CB,(SAVE) 
          =A2    A2-CA.W+CB.W 
          BX3    X1*X2
          ZR     X3,SAV15    IF NOT REDUNDANT SAVE
          WARN   E.SA2
          EQ     SAV18
  
 SAV15    BX6    X1+X2       MERGE IN SAVE BIT
          SA6    A2          UPDATE T.BLKS
          EQ     SAV18
  
 SAV16    BX5    X6          SAVE BLOCK NAME
          ALLOC  T.BLKS,Z=BLKS
          SX3    X2-MAX.BLK*Z=BLKS+1
          PL     X3,E.CM2    IF TOO MANY BLOCKS 
          LX6    X5          RESTORE BLOCK NAME 
          CLAS=  X7,CB,(SAVE) 
          =A7    B7-Z=BLKS+CB.W 
          =A6    A7-CB.W+CA.W 
  
 SAV18    =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.SLASH 
          NZ     B2,E.SA3    IF NOT SLASH 
  
 SAV20    BSS    0
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.COMMA 
          ZR     X1,FEC.RTN  IF *EOS* 
          ERRNZ  O.EOS
          NZ     B2,E.SA4    IF NOT *COMMA* 
          =A1    B4+1 
          =B4    B4+1 
          EQ     SAV2        CONTINUE PROCESSING
  
 SAVERR   BSSENT 0
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.COMMA 
          ZR     X1,FEC.RTN  IF *EOS* 
          ERRNZ  O.EOS
          NZ     B2,SAVERR   IF NOT *COMMA* 
          =A1    B4+1 
          =B4    B4+1 
          EQ     SAV2        CONTINUE PROCESSING
          TITLE  CLOSE OF DECLARATIVE ROUTINES. 
 TABLES   SPACE  4,4
**        CLOSE OF EQUIVALENCE PROCESSING  DATA STRUCTURES. 
  
  
*         G/F TABLE - GALLER / FISHER EQUIVALENCE TABLE.
  
  
          DESCRIBE G1.,,,0
 SYMI     DEFINE 18          INDEX OF SYMTAB WORD WB
 CHAR     DEFINE 1           INDICATE CHARACTER ENTITY
 SAVE     DEFINE 1           INDICATE SAVE
          DEFINE 6
 ADR      DEFINE WC.RBL+WC.RAL
          REDEF  ADR
 RB       DEFINE WC.RBL      RELOCATION BASE
 RA       DEFINE WC.RAL      RELATIVE ADDRESS 
  
          DESCRIBE G2.,,,1
 LINK     DEFINE EQ.LINKL    INDEX IN EQUIV TABLE 
          ERRNZ  EQ.LINKP-G2.LINKP
 HI       DEFINE 24          SPACE NEEDED ABOVE ROOT
 LO       DEFINE 24          SPACE NEEDED BELOW ROOT
  
          DESCRIBE F2.,60 
 LINK     DEFINE G2.LINKL 
 EOI      DEFINE 12          INDEX TO T.EOT 
 BSYM     DEFINE 12          INDEX OF SYMTAB WORD WB OF BASE MEMBER 
 FWA      DEFINE 24          FWA OF CLASS 
  
*         T.EOT - EQUIVALENCE OVERLAP TABLE.
  
          DESCRIBE OA.,,,0
          DEFINE
 RB       DEFINE WC.RBL      RELOCATION BASE OF CLASS 
          DEFINE
 FWA      DEFINE 24          FWA OF CLASS 
 LWA      DEFINE 24          LWA OF CLASS 
  
          DESCRIBE OB.,,,1
          DEFINE 42          0
 GFI      DEFINE 18          INDEX OF CLASS ROOT IN T.EQUS
  
  
 Z=EQS    EQU    2           WORDS PER EQUIV TABLE ENTRY
 Z=EOT    EQU    2           WORDS PER EOT TABLE ENTRY
 PCD      EJECT 
**        PCD  - PROCESS END OF DECLARATIVES. 
*         CONTROL ROUTINE FOR END OF DECLARATIVE PROCESSING.
*         ENTRY  FIRST EXECUTABLE STATEMENT HAS BEEN ENCOUNTERED
*         EXIT   (STAGE) ADVANCED TO *FEC=STF*
*                (X5) RESTORED FROM ("SB.KEY"). 
*                (B4) PRESERVED.
*                (A0) RESTORED TO (F.SB)
  
  
 PCD      SUBR   =           ...ENTRY/EXIT... 
          SX6    FEC=STF
          SX7    B4 
          SA6    STAGE
          SA7    PCDA        SAVE (B4)
  
          RJ     MFR         MARK FUNCTION AS REFERENCED
  
          RJ     MCA         MAKE /COMMON/ ADDRESS ASSIGNMENTS
  
          RJ     EQU         PROCESS EQUIVALENCES 
  
          RJ     CCL         CORDINATE COMMON LEVEL INFORMATION 
  
          RJ     CCC         CHECK CHARACTER COMMON BLOCKS
  
          RJ     CCS         CONVERT CHARACTER SYMBOLS
  
          RJ     DCS         DIAGNOSE COMMON-SAVE VARIABLES 
  
          RJ     PSC         PROPAGATE SAVE BIT THROUGH COMMON
  
          RJ     PCF         PROCESS CHARACTER/FORMAL PARAMETER INTERACT
  
          RJ     VDP         PROCESS VARABLE DIMENSIONS 
  
          RJ     APT         ASSIGN ECS/LCM POINTER TAGS
  
          RJ     ASL         ASSIGN STORAGE LEVELS
  
          RJ     SAS         SCAN ARRAY SIZES 
  
          SHRINK T=COMM,0    COMM TABLE NO LONGER NEEDED
 SNAP=D   IFNE   TEST 
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,PCD7     IF DECL SNAP NOT SELECTED
 SNP=D    DUMPT  (SYM,BLKS,DIM) 
 PCD7     BSS 
 SNAP=D   ENDIF 
          SA2    T.TB 
          SA1    PCDA 
          SA0    X2          RESTORE (A0) 
          SA5    TB=TYPE     RESTORE (X5) 
          SB4    X1          RESTORE (B4) 
          EQ     EXIT.       EXIT...
  
 PCDA     CON    0           SAVE AREA
 APT      SPACE  4,10 
**        APT -  ASSIGN POINTER TAGS
* 
*         ENTRY  (T.BLKS) = (CB.LEVN) COMPLETELY DETERMINED.
*                (.DAL) = 0 IF LEVEL 2 IS CM/SCM, 
*                       = 1 IF LEVEL 2 IS ECS/LCM.
* 
*         FOR EACH COMMON BLOCK, *APT* DECIDES FROM ITS LEVEL AND THE 
*         OBJECT MACHINE TYPE, WHAT STORAGE TYPE IS FOR THE BLOCK.
*         FOR COMMON BLOCKS WHICH ARE ECS/LCM RESIDENT, THE (CB.LCM) BIT
*         IS SET, AND A POINTER WORD TAG IS SET IN (CB.TAG).
*         POINTER WORDS ARE CONSTRUCTED AND STORED IN (T.APL).
* 
*         EACH COMMON BLOCK LENGTH IS CHECKED AGAINST THE MAXIMUM 
*         LENGTH ALLOWED, ERROR MESSAGE ISSUED ACCORDINGLY. 
*            FOR (LCM=G), MAXIMUM ECS/LCM BLOCK LENGTH IS (MAX.SPLC), 
*         AND FOR ALL OTHER CASES, BLOCK LENGTHS SHOULD NOT EXCEED
*         (MAX.SPCM). 
  
  
 APT      SUBR               ...ENTRY/EXIT... 
          SA4    WO.LCM 
          SB4    X4          (B4) = LCM INDICATOR 
          MX6    0
          ADDWD  T.LCA
          SA1    T.BLKS 
          SA2    T=BLKS 
          AX2    1           X2 = (TABLE LENGTH) DIV (Z=BLKS) 
          ERRNZ  2-Z=BLKS 
          SB2    X2-1        B2 = NO. ENTRIES TO PROCESS
*                            (1ST ENTRY IS NOT A COMMON BLOCK)
          =B3    Z=BLKS 
          =A1    X1+CB.W
  
 APT10    SA1    A1+B3       CBI = CB ENTRY 
          =A4    A1-CB.W+CA.W      CAI = CA ENTRY 
          ZR     B2,EXIT.    IF NO MORE ENTRIES, EXIT.. 
          MX7    -CB.BLENL
          MX6    CA.BNAML 
          LX1    -CB.BLENP
          BX5    -X7*X1      BLENI = BLEN[CBI]
          LX1    CB.BLENP 
          BX6    X6*X4       BLOCK NAME = BNAM[CAI] 
          SA6    FILL.
          SB2    B2-B1
          MX0    -CA.BLVLL
          LX4    -CA.BLVLP
          BX2    -X0*X4      EXTRACT (X2) = LEVEL OF THIS BLOCK 
          SX7    X2+.DAL-3
          ERRPL  .DAL-2 
          CLAS=  X3,CB,(LCM)
          BX6    X1+X3
          SX0    B4          LCM INDICATOR
          MI     X7,APT20    IF (LEV+.DAL .LT. 3), THEN NOT LARGE CORE
          IFEQ   .MI,1,6
          NZ     X7,APT19    IF LEVEL 3 
          SA3    =XCO.TMLC
          MX7    1
          ZR     X3,APT20    IF NO LCM
          MX7    0
  
 APT19    BSS    0
          SA6    A1+         LCM(CBI] = 1 
  
 APT20    SA3    APTB        MAXLEN = (MAX.SPCM)
          SB7    E.CM9
          AX7    59 
          SA2    CO.LCM 
          BX2    -X7*X2 
          BX4    -X7*X0 
          PL     X2,APT30           IF NOT LCM=G AND LCM
          SA3    APTA        MAXLEN = (MAX.SPLC)
          SB7    E.CM10 
  
 APT30    IX7    X5-X3
          MI     X7,APT40    IF BLENI .LT. MAXLEN 
          FATAL  B7 
  
 APT40    ZR     X4,APT10    IF (LCM=D OR NOT LCM BLOCK)
  
**        GENERATE AND SET POINTER TAG
  
          SA3    T=LCA
          SX7    K=LC 
          LX7    P=PFX
          IX7    X3+X7
          LX7    CB.TAGP
          BX6    X6+X7       SET TAG INTO BLOCK TABLE ENTRY 
          SA6    A1 
  
**        CONSTRUCT POINTER WORD -- GET TAG OF FIRST NAME IN BLOCK AND
*         PLACE INTO AP-LIST WORD FORMAT WITH BIT *ALCM* ON.
*         T.COMM HAS BEEN KEPT SO WE CAN FIND FIRST NAMES.
  
          SA2    T.COMM 
          HX1    CB.FMI 
          AX1    -CB.FMIL    FMIND = FMI[CBI] 
          MX4    -CB.FMIL 
          ERRNZ  12-CB.FMIL 
          BX1    -X4*X1 
          IX4    X2+X1
          SA2    X4          CMI = T.COMM(FMIND)
  
*         FIRST NAME IN BLOCK FOUND 
  
          MX7    -CT.TAGL 
          LX2    -CT.TAGP 
          BX6    -X7*X2      TAGI = TAG[CMI]
          LX6    IA.TAGP     POSITION TAG FOR APLIST TABLE
          SA4    T.BLKS 
          SB3    X4 
          SX4    A1-B3       RELATIVIZE BLOCK POINTER 
          ADDWD  T.LCA
          SA1    T.BLKS 
          SB3    X1 
          SA1    X4+B3       ABSOLUTIZE BLOCK POINTER 
          =B3    Z=BLKS 
          MX0    -CA.BLVLL     RESTORE X0 
          EQ     APT10       LOOP 
  
 APTA     CON    MAX.SPLC+1 
 APTB     CON    MAX.SPCM+1 
 ASL      SPACE  4,10 
**        ASL - ASSIGN STORAGE LEVELS.
* 
*         ENTRY  (T.SYM/WB) = (LAB, VAR, FP, COM, LEVN) SET CORRECTLY.
* 
*         FOR EACH *VAR* SYMBOL, *ASL* DECIDES FROM ITS LEVEL AND THE 
*         OBJECT MACHINE TYPE, WHAT STORAGE TYPE IS FOR THE VARIABLE. 
*         FOR VARIABLES WHICH ARE ECS/LCM RESIDENT, THE (WB.LCM) BIT
*         IS SET. 
  
  
 ASL      SUBR               ...ENTRY/EXIT... 
          SA1    LEVEL2 
          SA2    T=SYM
          SA3    T.SYM
          =B3    Z=SYM
          ZR     X1,EXIT.    IF NO LCM/ECS IN PROGRAM 
          SB6    X2          (B6) = LENGTH OF SYMTAB
          MX0    -WB.LEVNL
          =A3    X3-Z=SYM+WB.W
          CLAS=  X5,WB,LEV
          CLAS=  X7,WB,(LCM)
  
 ASL2     SA3    A3+B3       FETCH SYMTAB ATTRIBUTE WORD
          ZR     B6,EXIT.    IF TABLE EXHAUSTED 
          BX4    X5*X3
 .TEST    IFEQ   TEST,ON,1
          MI     B6,"BLOWUP" IF SYMTAB LEN NOT MULTIPLE OF Z=SYM
          SB6    B6-B3
          LX3    59-WB.LABP 
          MI     X3,ASL2     IF LAB, IGNORE 
          MX6    1
          LX6    WB.ALP-WB.LABP 
          BX3    -X6*X3      CLEAR WB.ALP SINCE THE BIT IS RE-USED BY 
          BX6    X3          STATEMENT FUNCS AND ASSIGN GOTO PROCESSING 
          LX6    WB.LABP+1
          SA6    A3          UPDATE MEMORY COPY OF WORD B 
          LX3    WB.LABP-WB.VARP
          PL     X3,ASL2     IF NOT VAR, IGNORE 
          ZR     X4,ASL2     IF NOT DECLARED IN LEVEL 
          LX3    WB.VARP+1-WB.LEVNP 
          BX2    -X0*X3      EXTRACT (X2) = LEVEL NUMBER
          NZ     X2,ASL10    IF LEVEL NUMBER .NE. 0 
          =X2    2
 ASL10    =X4    X2+.DAL-3
          ERRPL  .DAL-2 
          MI     X4,ASL2     IF (LEV + .DAL) .LT. 3, THEN NOT LARGE CORE
          IFEQ   .MI,1,4
          NZ     X4,ASL15    IF LEVEL 3 
          SA4    =XCO.TMLC
          ZR     X4,ASL2     IF NO LCM
 ASL15    BSS    0
  
          LX3    WB.LEVNP 
          BX6    X7+X3       SET (LCM) BIT
          SA6    A3 
          EQ     ASL2        LOOP.. 
 CCC      SPACE  4,10 
**        CCC - CHECK CHARACTER COMMON BLOCK. 
*         DETECT CHARACTER DECLARATION CONFLICT IN COMMON BLOCK AND 
*         CONVERT CHARACTER BLOCK LENGTH TO NO. OF WORDS. 
* 
*         ENTRY  COMMON BLOCK LENGTH HAVE BEEN CALCULATED, EQUIVALENCE
*                PROCESSING (IF ANY) HAVE BEEN DONE.
*         EXIT   ALL COMMON BLOCK LENGTHS NOW ARE IN NO. OF WORDS.
  
  
 CCC      SUBR               ...ENTRY/EXIT... 
          SA1    CHARDCL
          SA2    T.BLKS 
          PL     X1,EXIT.    IF NO CHARACTER DECLARATIONS 
          SA3    T=BLKS 
          SA4    BLNKCOM
          SB5    X4          (B5) = BLKIND FOR BLANK COMMON 
          =B3    Z=BLKS 
          =B2    X2+CA.W
          SB4    X3          LEN = (T=BLKS) 
          MX0    -CB.BLENL
          MX4    CA.BNAML 
          SB6    -Z=BLKS     INITIALIZE FOR LOOP
  
*         PROCESS NEXT COMMON BLOCK.
  
 CCC10    SB6    B6+B3       BLKIND = BLKIND + Z=BLKS 
          GE     B6,B4,EXIT. IF END OF T.BLKS 
          SA1    B2+B6       CAI = T.BLKS(BKLIND) 
          BX7    X1 
          HX1    CA.CHAR
          PL     X1,CCC30    IF NOT CHAR BLOCK
          =A2    A1-CA.W+CB.W      CBI = CB ENTRY OF T.BLKS 
          LX2    -CB.BLENP
          BX6    X0*X2       CLEAR BLEN FIELD 
          BX3    -X0*X2      BLENI = BLEN[CBI]
          WX5    X3,X2       BLENI = BLENI / 10 
          BX5    -X0*X5 
  
 .TEST    IFEQ   TEST,ON
          SX3    X2-10
          PL     X3,"BLOWUP" IF REMAINING CHARS .GE. 10 
 .TEST    ENDIF 
  
          =X3    1
          ZR     X2,CCC20    IF NO REMAINDER
          IX5    X5+X3       BLENI = BLENI + 1
          LX2    CB.RNCP-CB.BLENP 
          BX6    X6+X2
  
 CCC20    IX6    X6+X5
          LX6    CB.BLENP 
          SA6    A2          (RNC,BLEN)[CBI] = (RNC,BLENI) [CB.]
  
*         ISSUE MESSAGE FOR CHARACTER CONFLICT IN THIS BLOCK IF 
*         NAC[CAI] = 1. 
  
 CCC30    LX1    CA.CHARP-CA.NACP 
          PL     X1,CCC10    IF NO CONFLICT 
          BX7    X4*X7
          NE     B6,B5,CCC40 IF NOT BLANK COMMON
          SX7    2R// 
          LX7    8*CHAR 
  
 CCC40    SA7    FILL.       STORE BLOCK NAME 
          FATAL  E.CM11 
          EQ     CCC10
 CCL      SPACE  4,10 
**        CCL - CORDINATE COMMON LEVEL INFORMATION. 
* 
*         FOR EACH COMMON BLOCK, PROPAGATE LEVEL INFORMATION
*         TO ALL THE COMMON MEMBERS, DIAGNOSING ANY PREVIOUS
*         INDIVIDUAL LEVEL DECLARATIONS.
  
  
 CCL      SUBR               ...ENTRY/EXIT... 
          SA4    LEVEL
          SA3    T.BLKS 
          SA2    T.COMM 
          ZR     X4,EXIT.    IF NO LEVEL DECLARATIONS 
          SA4    T.SYM
          SB3    X2 
          =B6    X4+WB.W
          SA1    T=BLKS 
          =B5    X3+CA.W
          MX0    -CT.LNKL 
          ERRNZ  12-CT.LNKL 
          SB2    X1          BLKIND = (T=BLKS)
          =B4    Z=BLKS 
  
 CCL10    SB2    B2-B4       BLKIND = BLKIND - Z=BLKS 
          SA4    B5+B2       CAI = T.BLKS(BLKIND) 
          LE     B2,B0,EXIT. IF END OF TABLE
          =A3    A4-CA.W+CB.W      CBI = CB ENTRY OF T.BLKS 
          MX7    -CA.BLVLL
          LX4    -CA.BLVLP
          HX3    CB.FMI 
          AX3    -CB.FMIL    CMIND = FMI[CBI] 
          BX7    -X7*X4      BLEV = BLVL[CAI] 
          LX7    WB.LEVNP 
          BX3    -X0*X3 
  
*         NEXT COMMON MEMBER OF THIS BLOCK. 
*         (A4,X4) = CAI 
*         (X3) = CMIND
*         (X7) = BLEV, SHIFTED TO WB.LEVNP
  
 CCL20    ZR     X3,CCL10    IF CMIND .EQ.0 
          SA1    X3+B3       CMI = T.COMM(CMIND)
          LX1    -CT.TAGP 
          SB7    X1          TAGI = TAG[CMI]
          ERRNZ  18-CT.TAGL 
          SX2    B7+B7
          LX1    CT.TAGP-CT.LNKP
          BX3    -X0*X1      CMIND = LNK[CMI] 
          SX6    X2+B7       STINDB = 3 * TAGI
          ERRNZ  3-Z=SYM
          SA2    X6+B6       WBI = T.SYM(STINDB)
          =A1    A2-WB.W+WA.W 
          CLAS=  X5,WB,(LEV,LEVN) 
          MX6    WA.SYML
          BX5    -X5*X2 
          HX2    WB.EQV 
          BX6    X6*X1
          SA6    FILL.       STORE NAME IN MESSAGE
          MI     X2,CCL20    IF EQUIVALENCED
          LX2    WB.EQVP-WB.LEVP
          PL     X2,CCL30    IF NOT ALREADY LEVELED 
          FATAL  E.LV9       EXPLICT LEVEL DECLARATION BY COM MEMBER
 CCL30    ZR     X7,CCL20    IF BLOCK NOT LEVELED 
          CLAS=  X1,WB,(LEV)
          BX1    X1+X7
          BX6    X5+X1
          SA6    A2          (LEV,LEVN) [WBI] = (1,BLEV) [WB.]
          EQ     CCL20
 CCS      SPACE  4,10 
**        CCS - CONVERT CHARACTER SYMBOL. 
*         FOR EACH CHARACTER SYMBOL, CONVERT ITS RA[WCI] FROM CHARACTER 
*         OFFSET TO WORD OFFSET AND BCP (BEGINNING CHARACTER POSITION). 
  
  
 CCS      SUBR               ...ENTRY/EXIT... 
          SA1    CHARDCL
          SA2    T=SYM
          PL     X1,EXIT.    IF NO CHARACTER DECLARATIONS 
          SA3    T.SYM
          SB6    X2 
          SB2    -M.CHAR
          =B3    Z=SYM
          =A3    X3+WB.W
          MX0    -WB.MODEL
          MX7    -WC.RAL
          CLAS=  X2,WB,(LAB,FP,PARM,NVAR,EXT,NLST,ENT)
 CCS10    SA3    A3+B3       WBI = T.SYM(SYMIND)
          SB6    B6-B3
          ZR     B6,EXIT.    IF END OF T.SYM
          BX1    X2*X3
          LX3    -WB.MODEP
          BX3    -X0*X3      MODEI = MODE[WBI]
          SX6    X3+B2
          NZ     X6,CCS10    IF NOT MODE CHARACTER
          NZ     X1,CCS10    IF WRONG CLASS 
          =A4    A3-WB.W+WC.W      WCI = WC ENTRY OF T.SYM
          LX4    -WC.RAP
          BX6    X7*X4       CLEAR RA FIELD 
          BX4    -X7*X4      RAI = RA[WCI]
          WX5    X4,X3       RAI = RAI / 10 
          LX3    WC.BCPP
          BX6    X6+X5
          LX6    WC.RAP 
          BX6    X6+X3
          SA6    A4          (BCP,RA) [WCI] = (BCP,RAI) [WC.] 
          EQ     CCS10
 DCS      SPACE  4,10 
**        DCS - DIAGNOSE COMMON-SAVE VARIABLES. 
* 
*         FIRST, DIAGNOSE REDUNDANT SAVE STATEMENTS WHEN UNIVERSAL
*         SAVE IS ON. 
* 
*         BEFORE PROPAGATION OF SAVE BIT THROUGH SAVE DECLARED
*         COMMON BLOCK, SYMBOL TABLE IS SCANNED FOR COMMON ELEMENTS 
*         WHICH ARE ALREADY DECLARED THROUGH SAVE EXPLICITLY, AND 
*         FATAL ERRORS ARE ISSUED.
* 
*         USES   ALL
  
  
 DCS      SUBR               ...ENTRY/EXIT... 
          SA1    SAVE 
          SA3    USAVE
          BX6    X1*X3
          BX1    X1+X3
          ZR     X1,EXIT.    IF NO SAVE STATEMENTS OCCURED
          ZR     X6,DCS10    IF NOT BOTH SAVE FLAGS ON
          WARN   E.SA        REDUNDANT SAVE DECLARATIONS
  
 DCS10    SA2    T=SYM
          SA4    T.SYM
          MX0    WA.SYML
          SB6    X2 
          =B3    Z=SYM
          =A5    X4+WB.W
          CLAS=  X2,WB,(LAB,CGS)
          CLAS=  X3,WB,(COM,SAVE) 
 DCS20    SA5    A5+B3       WBI = WB ENTRY OF T.SYM
          SB6    B6-B3
          ZR     B6,EXIT.    IF END OF T.SYM
          BX6    X2*X5
          BX4    X3*X5
          =A1    A5-WB.W+WA.W 
          BX7    X1*X0
          BX5    X4-X3
          NZ     X6,DCS20    IF LABEL OR CGS
          NZ     X5,DCS20    IF NOT (COMMON AND SAVE) 
          SA7    FILL.
          FATAL  E.SA6
          EQ     DCS20
  
*CALL,COMFDST 
 ELV      SPACE  4,8
          TITLE  *EQUIVALENCE* DIGESTION. 
 EQU      SPACE  4,8
**        EQU -  PROCESS EQUIVALENCES.
* 
*         ENTRY  END OF DECLARATIVES HAS BEEN ENCOUNTERED.  COMMON
*                ADDRESSES (IF PRESENT) ARE RESOLVED.  T.EQUS CONTAINS
*                TRANSLATED EQUIVALENCE STATEMENTS (IF PRESENT).
* 
*         EXIT   EQUIVALENCE ADDRESSES ASSIGNED.
*                (EQUA) = LOCAL EQUIVALENCE LENGTH
  
  
 EQU      SUBR               ...ENTRY/EXIT... 
          SA2    T=EQUS 
          ZR     X2,EQUX     IF NO EQUIV STATEMENTS 
  
 SNAP=D   IFNE   TEST        DUMP EQUIV. TABLE
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQUS0    IF DECLARATIVE SNAP NOT SELECTED 
          PLINE  (=C=  (TRANSLATED EQUIV STATEMENTS.)=),4,2 
 EQU.0    DUMPT  EQUS 
 EQU.1    DUMPT  COMM 
 EQUS0    BSS    0
 SNAP=D   ENDIF 
 EQU      SPACE  4,10 
**        PHASE 0 OF EQUIVALENCE DIGESTION. 
*         A.   DETECT SUBSTRINGED VARIABLE WITH MODE NOT CHARACTER. 
*         B.   DETECT SUBSTRING FIRST GREATER THAN DECLARED 
*              LENGTH OF ASSOCIATED VARIABLE. 
  
          MX6    1
          ADDWD  T.EQUS      MARK END OF TABLE
          =A5    X1-1        INITIALIZE FETCH REG 
          MX0    -EQ.STFL 
          MX7    -EQ.SYMIL
          SA4    T.SYM
          SB3    X4-1 
          MX4    -WA.SYML 
  
EQU5      =A5    A5+1 
          MI     X5,EQU15    IF TABLE EXHAUSTED 
          MX2    -EQ.LINKL
          LX5    -EQ.LINKP
          BX2    -X2*X5      EXTRACT LINK 
          ZR     X2,EQU5     IF NOT HEADER WORD 
          LX5    -EQ.STFP+EQ.LINKP
          BX2    -X0*X5      ISOLATE SUBSTRING FIRST
          ZR     X2,EQU5     IF NOT SUBSTRINGED 
          =X3    X2-1 
          BX6    X0*X5       ERASE OLD FIRST
          BX6    X6+X3       REPLACE WITH DECREMENTED VERSION 
          LX6    EQ.STFP
          SA6    A5 
          LX5    EQ.STFP-EQ.SYMIP 
          BX3    -X7*X5      ISOLATE SYMTAB *WB* INDEX
          SA3    B3+X3       *WA* 
          LX3    -WA.SYMP 
          BX6    -X4*X3      ISOLATE NAME 
          LX6    -WA.SYML    LEFT JUSTIFY 
          SA6    FILL.       SET CELL FOR DIAGNOSTICS 
          =A3    A3-WA.W+WB.W      *WB* 
          LX3    -WB.MODEP
          MX5    -WB.MODEL
          BX5    -X5*X3      ISOLATE MODE 
          SX5    X5-M.CHAR
          ZR     X5,EQU10    IF NO ERROR
          FATAL  E.ST1       MODE NOT CHARACTER 
          EQ     EQU5 
  
 EQU10    =A3    A3-WB.W+WC.W      *WC* 
          MX5    -WC.CLIFL
          LX3    -WC.CLIFP
          BX3    -X5*X3      ISOLATE LENGTH INFO
          LX3    WC.CTYPP-WC.CLENP
          MI     X3,EQU5     IF VARIABLE LENGTH 
          IX3    X3-X2       MI IF FIRST GT LENGTH
          PL     X3,EQU5     IF NO ERROR
          FATAL  E.AT16      INVALID SUBSTRING
          EQ     EQU5 
 PHASE1   SPACE  3,8
**        PHASE 1 OF EQUIVALENCE DIGESTION. 
*         A.     COPY BLOCK AND RELADD (RB + RA) FROM T.SYM.
*         B.     SAVE ARRAY LENGTH (FROM T.DIM).
*         C.     REDUCE SUBSCRIPTS TO A SINGLE OFFSET (IN WORDS). 
*         D.     COLLAPSE TABLE TO 2-WORD ENTRIES.
*         EXIT   (G1.) WORD SET UP. 
*                (G2.HI) = LENGTH OF ARRAY. 
*                (G2.LO) = SUBSCRIPT. 
  
 EQU15    SA5    T.DIM
          SB4    X1          (B4) = FWA EQUIV SOURCE TABLE
          SB3    X5          (B3) = FWA DIMENSION PARAMETERS
          SA5    X1          (A5) _ CURRENT FETCH (FROM T.EQUS) 
          =A7    A5-1        DUMMY STORE
          ERRMI  FUDGE-1     CODE REQUIRES AT LEAST 1 SLOP WORD 
          EQ     EQU30       BEGIN LOOP.. 
  
*         FORM PHASE 1 EQV TABLE WORD 2, FORMATTED AS G2. . 
*         (A5) _ EQI = NEXT EQUIV SOURCE ENTRY
*         (A0) _ G1I ENTRY
*         (B6) = CLENI
*         (X0) = SIGMA = LOI
*         (X7) = (LINK,HII) [G2.] 
  
 EQU20    SA5    A5          (X5) = EQI ENTRY 
          SX6    B6          (X6) = CLENI 
          IX6    X0*X6       LOI = LOI * CLENI
          LX6    G2.LOP 
          IX7    X7+X6
          SA7    A0+B1       (LINK,HI,LO)[G2I] = (LINKI,HII,LOI+STFI) 
  
*         (B3) = FWA(T.DIM) 
*         (B4) = FWA(T.EQUS)
*         (A5) _ FETCH ADDRESS FOR EQI ENTRY
*         (A7) _ G1I ENTRY
  
 EQU30    MI     X5,EQU99    IF TABLE EXHAUSTED 
          BX6    X5 
          HX6    EQ.ISUB
          SA6    EQUS        SAVE SUBSCRIPTION INDICATOR
          SA3    T.SYM
          SB7    X3 
          SA1    X5+B7       WBI = T.SYM( SYMI[EQI])
          =A2    A1-WB.W+WA.W      WAI = WA ENTRY 
          MX3    WA.SYML
          BX6    X3*X2
          SA6    FILL.
          CLAS=  X3,WB,(ARY)
          BX6    X3*X1
          SA6    EQUDIM 
          MX3    EQ.LINKL 
          BX2    X3*X5       EXTRACT LINK 
          BX5    -X3*X5      EXTRACT SYMBOL INFORMATION 
          LX2    EQ.LINKL 
          SB2    X2          (B2) = LINKI 
          MX3    -WB.MODEL
          BX6    X1 
          HX6    WB.LEV 
          LX1    -WB.MODEP
          BX3    -X3*X1 
          SB5    X3          (B5) = MODEI = MODE[WBI] 
          SB7    E.EQ10      CLASS CONFLICT -- F.P. IN EQV GROUP
          MI     X6,EQU45    IF LEVELED 
          LX1    WB.MODEP-WB.SAVEP
          SX7    X3-M.CHAR
          SA4    GCI         GROUP CHAR INDICATER = (GCI) 
          CLAS=  X6,G1,(CHAR)      CHARI = 1
          ZR     X7,EQU35    IF MODE CHARACTER
          MX6    0           CHARI = 0
  
 EQU35    NE     B2,B1,EQU40 IF NOT FIRST ELEMENT IN GROUP
          LX4    X6          SET GROUP CHARACTER INDICATER
          SA6    A4          (GCI) = CHARI
  
 EQU40    IX7    X6-X4
          MX6    -WC.RAL
          SB7    E.EQ17      CHARACTER DECLARATION CONFLICT 
          ZR     X7,EQU50    IF NO CONFLICT 
  
*         THIS ELEMENT IS LEVELED OR IS CAUSING CHARACTER DECLARATION 
*         CONFLICT IN EQV GROUP, DROP IT FROM THE GROUP.
  
 EQU45    =A5    A5+1 
          MI     X5,EQU47    IF TABLE ENDS BEFORE END OF CLASS
          MX1    EQ.LINKL 
          BX1    -X1*X5      EXTRACT LINK 
          LX1    EQ.LINKL 
          SB2    X1 
          NE     B2,B1,EQU45 IF NOT END OF THIS CLASS 
  
 EQU47    FATAL  B7          CHARACTER DECLARATION CONFLICT 
          EQ     EQU30
  
*         FORM PHASE 1 EQUIVALENCE TABLE WORD 1 (G1.).
  
 EQU50    CLAS=  X3,EQ,(ISUB) 
          BX5    -X3*X5      CLEAR SUBSCRIPTION INDICATOR 
          CLAS=  X3,EQ,(STF)
          BX0    X3*X5       STFI = STF[EQI]
          BX5    X5-X0
          AX0    EQ.STFP
          =X2    1
          BX2    X2*X1       SAVEI = SAVE[WBI]
          LX2    G1.SAVEP 
          BX2    X4+X2
          LX5    G1.SYMIP-EQ.SYMIP
          BX5    X5+X2
          MX7    -WC.CLENL
          CLAS=  X2,WC,(RB) 
          =A3    A1-WB.W+WC.W      WCI = WC ENTRY 
          BX2    X2*X3       RBI = RB[WCI]
          LX3    -WC.RAP
          BX6    -X6*X3      RAI = RA[WCI]
          LX3    WC.RAP-WC.CLENP
          LX2    G1.RBP-WC.RBP
          BX2    X2+X5
          BX3    -X7*X3      CLENI = CLEN[WCI]
          SB6    X3          REMEMBER (B6) = CLENI
          ERRNZ  18-WC.CLENL
          LX6    G1.RAP 
          BX6    X6+X2
          SA6    A7+B1       [G1I] = (SYMI,CHAR,RBI,RAI) [G1.]
          SA0    A7+B1
          CLAS=  X2,G1,(CHAR) 
          BX2    X4-X2
          LX2    -G1.CHARP   (X2) .EQ. 0 IF CHAR, .EQ. 1 IF NON-CHAR
          SB6    X2+B6       CLENI = CLENI + (X2) 
  
*         GET HI[G2.] FROM  T.DIM ENTRY OF ELEMENT. 
*         (B5) = MODEI
*         (X0) = STFI 
*         (B2) = LINKI
  
          LX1    WB.SAVEP-WB.PNTP 
          MX3    -WB.PNTL 
          BX2    -X3*X1      DIMIND = PNT[WBI]
          MX6    -DH.PSL
          SA2    X2+B3       D1I = T.DIM(DIMIND)
          LX2    -DH.PSP
          BX7    -X6*X2      SIZI = SIZ[D1I]
          LX2    DH.PSP-DH.DIMP 
          MX1    -0          INDICATES TWO WORD ELEMENT 
          SB5    B5-M.DBL 
          EQ     B5,B0,EQU60 IF MODE DOUBLE 
          EQ     B5,B1,EQU60 IF MODE COMPLEX
          =X1    0           INDICATES ONE WORD ELEMENT 
          SX3    B6 
          IX7    X3*X7       SIZI = SIZI * CLENI
  
 EQU60    =A3    A2+1 
          MX6    -DH.DIML 
          BX2    -X6*X2 
          SB5    X2          (B5) = NO. OF DIMENSIONS 
          BX6    X1*X7
          IX7    X7+X6       DOUBLE SIZE IF *LONG*
          LX7    G2.HIP 
          LX0    G2.LOP 
          BX7    X7+X0       ADD IN SUB STRING OFF SET
          SX2    B2 
          LX2    G2.LINKP 
          BX7    X2+X7       (LINKI,SIZI,STFI)[G2.] 
  
  
**        COMPUTE EFFECTIVE SUBSCRIPT --
* 
*         ENTRY  (B5) = NUMBER OF DIMENSIONS.    (N)
*                (X1) = 0 IF SINGLE,  -0 IF LONG. 
*                (A3,X3) = FIRST DIM WORD        (S(I)) 
* 
*         METHOD -- 
*         I=1                LOOP INDEX 
*         PI=1               PARTIAL PRODUCT
*         SIGMA=0            ACCUMULATOR
* ALPHA   R1 = (S(I)) - LB(I)      SUBTRACT LOWER BOUND 
*         SIGMA = SIGMA+R1*PI      ADD CONTRIBUTION FOR THIS SUB
*         PI = PI*D(I)
*         I=I+1 
*         IF I@N, _ALPHA     IF MORE SUBS TO DO 
*         BIAS = SIGMA*2**((WB.LONGP))
  
          =X2    1           X2 # PI = 1
          BX1    X1*X2
          BX0    0           SIGMA = 0
          IX2    X1+X2
  
 EQU70    =A5    A5+1 
          MX4    EQ.LINKL 
          BX4    X4*X5
          HX5    EQ.SUBS
          NZ     X4,EQU90    IF NO MORE SUBSCRIPTS
          AX5    -EQ.SUBSL   SIGN EXTEND SUBSCRIPT
          BX6    X5 
          SA6    EQUDIM+1 
          =A1    A6-1        NO. OF DIMENSIONS
          SB7    E.EQ13 
          SA4    EQUS 
          PL     X4,EQU75    IF NOT SUBSCRIPTED 
          ZR     X1,EQU80    IF NOT DIMENSIONED 
          HX3    D1.SPAN
          AX3    -D1.SPANL   D(I) = SPAN[D1I] 
          =A1    A3+D2.W     FETCH *D2* ENTRY 
          HX1    D2.LB
          LX1    D2.LBL-DM.INFL-DM.INFP 
          AX1    -DM.INFL    LB(I) = LB(D2I) [SIGN EXTENDED]
          IX5    X5-X1       R1 = S(I) - LB(I)
*                            */UB(I) = D(I) + LB(I) - 1 
          IX4    X5-X3       */S(I) - UB(I) = R1 - D(I) + 1 
          SB7    E.EQ7
          MI     X5,EQU80    IF R1 .LT. 0      */SUBS TOO SMALL 
          SB7    E.EQ8
          PL     X4,EQU80    IF SX .GE. 0      */SUS TOO BIG
  
 EQU75    IX1    X5*X2       R1(I) = R1(I) * PI 
          =B5    B5-1        I = I-1
          IX0    X0+X1       SIGMA=SIGMA+R1 
          IX2    X2*X3       PI = PI*D(I) 
          MI     B5,EQU70    IF NO MORE DIMS
          SA3    A3+Z=DD     FETCH NEXT DIMENSION DESCRIPTOR
          EQ     EQU70
  
*         ERROR - SKIP OVER REST OF SUBSCRIPTS. 
  
 EQU80    FATAL  B7          OUTPUT THE MESSAGE 
          MX0    0           SIGMA = 0
  
 EQU85    =A5    A5+1        NEXT SUBSCRIPT WORD
          MX1    EQ.LINKL 
          BX1    X1*X5       EXTRACT LINK 
          ZR     X1,EQU85    IF LAST SUBSCRIPT NOT YET FOUND
          WARN   E.EQ14      EXCESS SUBSCRIPTS IGNORED
          EQ     EQU20
  
 EQU90    ZR     B5,EQU20    IF NO MORE DIMENSIONS
          SA1    EQUDIM+1 
          ZR     X1,EQU20    IF NO SUBSCRIPT ON EQUIVALENCE 
          FATAL  E.EQ15      MISSING SUBSCRIPTS SET TO LOWER BOUND
          EQ     EQU20
 PHASE2   SPACE  3,8
**        PHASE 2 -- PASS 1 OF GALLER / FISHER EQUIVALENCE ALGORITHM. 
*         A.     MARK NEW END-OF-TABLE, AND RE-SET LENGTH.
*         B.     BEGIN. 
  
 EQU99    MX7    -1 
          =A7    A7+1        MARK END OF TABLE
          SB7    A7-B4
          ZR     B7,EQUX     IF TABLE EMPTY 
          SHRINK T=EQUS,B7+1 RESULTANT LENGTH OF TABLE
          SA0    B4          (A0) = FWA EQUIVALENCE STATEMENTS
          =B2    Z=EQS
          =B5                GFLEN = 0 (LENGTH OF G/F INFO IN TABLE)
          =B4                (B4) = POINTER TO EQUIV SOURCE INFO
  
 SNAP=D   IFNE   TEST        DUMP EQUIV. TABLE
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQU99S   IF DECLARATIVE SNAP NOT SELECTED 
 EQU.99   DUMPT  EQUS 
 EQU99S   BSS    0
 SNAP=D   ENDIF 
  
  
**        HERE WE BEGIN TO ADD AN ITEM INTO THE G/F TABLE, WHICH IS 
*                GROWING INTO THE SAME SPACE NOW OCCUPIED BY THE EQUIV
*                STATEMENT TABLE. 
  
 EQU100   =A5    B4+A0
          MX0    -G2.LOL
          MI     X5,EQU195   IF END OF EQUIV. INPUT 
          SA4    T.SYM
          SB3    X4          FWA OF SYMBOL TABLE
          LX5    -G1.SYMIP
          SB3    X5+B3
          =A4    B3-WB.W+WA.W 
          MX6    WA.SYML
          BX6    X6*X4       SYMBOL ONLY
          LX5    G1.SYMIP    RESTORE (X5) 
          SA6    FILL.       STORE NAME INTO MESSAGE
          =A4    A5-G1.W+G2.W 
          SB3    -B2
          MX6    G2.LINKL 
          BX2    X6*X4       EXTRACT LINK 
          BX4    -X6*X4      G2.HI+G2.LO
          LX2    G2.LINKL 
          SB6    X2          (B6) = ROOT FLAG OF CURRENT
          SB4    B4+B2
  
 EQU110   SB3    B3+B2
          SA3    B3+A0
          GE     B3,B5,EQU130      IF END OF G/F TABLE
          BX2    X3-X5
          AX2    G1.SYMIP 
          NZ     X2,EQU110   IF NO MATCH IN G/F 
          BX4    -X0*X4      ISOLATE SUBSCRIPT
  
**        CURRENT TAG IS FOUND TO BE ALREADY IN THE G/F TABLE.
*                CHAIN BACK UNTIL ITS ROOT IS FOUND, ADJUSTING SUBCRIPT 
*                AS WE GO.
  
 EQU120   =A2    A3+1 
          MX0    G2.LINKL 
          BX0    X0*X2       EXTRACT LINK 
          LX0    EQ.LINKL 
          SB7    X0          ROOT FLAG
          EQ     B7,B3,EQU140      IF THIS IS A ROOT
          HX3    G1.RA
          SB3    B7 
          AX3    -G1.RAL     EXTEND SIGN OF ADDRESS 
          IX4    X3+X4       ACCUMULATE (X4) = TOTAL DISTANCE TO ROOT 
          SA3    B7+A0
          EQ     EQU120 
  
**        CURRENT TAG NOT YET IN G/F TABLE.  CREATE AN ENTRY FOR IT.
  
 EQU130   BX3    X0*X4       LENGTH 
          SB5    B5+B2       GFLEN = GFLEN + Z=EQS
          LX6    X5 
          SX7    B3 
          LX7    G2.LINKP 
          BX7    X7+X3       HI = LEN, LO = 0, LINK = SELF. 
          SA6    B3+A0
          =A7    A6+1 
          BX4    -X0*X4      ISOLATE SUBSCRIPT
  
**        CURRENT TAG IS NOW IN THE G/F TABLE, AND WE KNOW ITS DISTANCE 
*                FROM ITS ROOT.   IF IT IS THE FIRST MEMBER OF A GROUP, 
*                REMEMBER IT AND RETURN TO PROCESS THE NEXT ONE.
*                (B3) = G/F TABLE ORDINAL (T).
*                (B6) = ROOT FLAG.
*                (X4) = SUBSCRIPT.
  
 EQU140   MX6    -G2.LOL
          BX4    -X6*X4      EXTRACT SUBSRIPT ONLY
          NE     B6,B1,EQU150 IF NOT A NEW GROUP
          SX6    B3 
          LX6    G2.LINKP 
          BX6    X6+X4
          SA6    EQUA 
          EQ     EQU100 
  
**        WHEN IT DOES NOT BEGIN A GROUP, LINK IT INTO THE G/F TABLE. 
*                (B3) # T    G/F TABLE ORDINAL
*                (X4) # D    SUBSCRIPT
  
 EQU150   SA2    EQUA 
          MX6    G2.LINKL 
          BX3    -X6*X2      EXTRACT D0 
          BX2    X6*X2
          LX2    G2.LINKL 
          SB6    X2          EXTRACT T0 
          IX5    X3-X4       X5 = DIST = D0 - Y 
          HX5    G1.RA
          AX5    -G1.RAL     SIGN EXTEND
          GT     B3,B6,EQU160 IF CURRENT OCCURS LATER THAN THIS ROOT
          EQ     B3,B6,EQU.10 IF CURRENT ALREADY LINKED TO THIS ROOT
  
**        IF CURRENT OCCURS BEFORE ITS ROOT, SWITCH THEM SO TABLE 
*                ALWAYS LINKS UPWARD. 
  
          SB7    B3          W = T
          SB3    B6          T = T0 
          BX5    -X5         DIST = -DIST 
          SB6    B7          T0 = W 
          SX6    B7 
          LX6    G2.LINKP 
          BX6    X6+X4       D0 = Y 
          SA6    A2 
  
**        BEFORE ADDING TO THE TREE, CHECK FOR CONSISTENCY. 
*         NOTE   R(T) = ( BLOCK(T), RELADD(T) ) 
  
 EQU160   SA3    B3+A0       G1T = T.EQUS(T)
          SA2    B6+A0       G1T0 = T.EQUS(T0)
          CLAS=  X4,G1,(RB) 
          LX7    X2 
          HX7    G1.RA
          AX7    -G1.RAL     RAT0 = RA[G1T0], SIGN EXTENTED 
          BX1    X4*X3       RBT = RB[G1T]
          BX6    X4*X2       RBT0 = RB[G1T] 
          BX4    X3 
          HX4    G1.RA
          AX4    -G1.RAL     RAT = RA[G1T], SIGN EXTENTED 
          NZ     X1,EQU170   IF RBT .NE. 0
          NZ     X6,EQU.50   IF RBT0 .NE. 0 
          EQ     EQU190 
  
**        CURRENT ELEMENT HAS AN ADDRESS -- CHECK ITS ROOT. 
  
 EQU170   NZ     X6,EQU.30   IF RBT0 .NE. 0 
  
**        ROOT HAS NO ADDRESS.
*                SET R(T0) = R(T) - DIST
  
          IX7    X4-X5       D = RAT - DIST 
          MI     X7,EQU.60   IF RAT .LT. DIST 
          BX6    X1          PRESERVE X1
          =A1    A2+1 
          HX1    G2.LO
          AX1    -G2.LOL     X1 = LOT0
          IX1    X7-X1       X1 = D - LOT0
          MI     X1,EQU.70   ILLEGAL EXTENSION OF BLOCK ORIGIN
          BX1    X6          RESTORE X1 
  
 EQU180   LX7    G1.RAP 
          BX7    X1+X7
          CLAS=  X1,G1,(RB,RA)
          BX2    -X1*X2      (RB,RA)[G1T0] = 0
          BX6    X2+X7
          SA6    A2          (RB,RA)[G1T0] = (RBT,D)[G1.] 
  
  
**        ADD ELEMENT TO PROPER TREE. 
*         SET    R(T) = DIST
*                S(T) = T0
*                HI(T0) = MAX (HI(T0), HI(T)+DIST)
*                LO(T0) = MAX (LO(T0), LO(T)-DIST)
  
*         ENTRY  (B3) = T 
*                (B6) = T0
*                (X3) = CURRENT (T) 
*                (X5) = DIST
*                (A2) _ T0
*                (A3) _ T 
  
 EQU190   SA2    A2          G1R = G1 ENTRY OF T0 
          MX0    -G1.ADRL 
          CLAS=  X4,G1,(SAVE) 
          BX6    X0*X3       CLEAR (RB,RA) FIELD
          ERRNZ  0-G1.ADRP
          BX4    X4*X3
          BX7    X2+X4
          SA7    A2          SAVE[G1R] = SAVE[G1R] .OR. SAVE[G1I] 
          MX0    -G1.RAL
          BX0    -X0*X5      ISOLATE (X0) = DISTANCE
          =A2    A2-G1.W+G2.W      G2R = G2 ENTRY OF T0 
          =A3    A3-G1.W+G2.W      G2I = G2 ENTRY OF T
          LX0    G1.RAP 
          BX6    X6+X0
          =A6    A3-G2.W+G1.W      (RB,RA)[G1I] = (0,DIST) [G1.]
          MX0    G2.LINKL 
          BX2    -X0*X2      EXTRACT (HI+LO)[G2R] 
          BX3    -X0*X3      EXTRACT (HI+LO)[G2I] 
          SX7    B6 
          LX7    G2.LINKP 
          BX7    X7+X3       LINK(T) = T0 
          SA7    A3          LNK[G2I] = T0
          HX3    G2.LO
          HX2    G2.LO
          =B7    59-G2.LOL-G2.LOP+1 
          AX0    X3,B7
          IX1    X0-X5       = LO(T) - DIST 
          AX7    X2,B7
          MX6    X7+X1       X6 = MAX ( LO(T0), LO(T)-DIST )
  
 A        SET    G2.LOL+G2.LOP-G2.HIL-G2.HIP
          LX3    A           (G2.HI) FIELDS TO TOP
  
 .TEST    IFEQ   TEST,ON,1
          MI     X6,"BLOWUP"       IF NEGATIVE OFFSET 
  
          LX2    A
          AX3    B7 
          IX0    X3+X5       = HI(T) + DIST 
          LX6    G2.LOP 
          AX7    X2,B7
          MX1    G2.LINKL 
          BX6    -X1*X6 
          SX1    B6 
          LX1    G2.LINKP 
          BX1    X1+X6       RESTORE LINK 
          MX3    X7+X0       X3 = MAX ( HI(T0), HI(T)+DIST )
  
 .TEST    IFEQ   TEST,ON,1
          MI     X3,"BLOWUP"       IF NEGATIVE OFFSET 
  
          LX3    G2.HIP 
          BX7    X1+X3
          SA7    A2          RESET (T0) (S, HI, LO) 
          EQ     EQU100 
 EQU.N    SPACE  4,10 
**        PHASE 2 ERROR PROCESSING. 
*         CHECK / PROCESS EQUIVALENCE REDUNDANCY / CONTRADICTION ERRORS.
  
  
 EQU.10   NZ     X5,EQU.20   IF CONTRADICTION 
          WARN   E.EQ11      REDUNDANT SPECIFICATIONS 
          EQ     EQU100 
  
 EQU.20   FATAL  E.EQ12      CONFLICTING SPECS. 
          EQ     EQU100 
  
 EQU.30   IX4    X4-X7
          IX6    X1-X6       = RBT - RBT0 
          IX1    X4-X5       = RAT - RAT0 - DIST
          NZ     X6,EQU.40   IF RBT .NE. RBT0 
          NZ     X1,EQU.40   IF CONTRADICTION 
          WARN   E.EQ11      REDUNDANT SPECIFICATION
          EQ     EQU190 
  
 EQU.40   FATAL  E.EQ12      CONFLICTING SPECS. 
          EQ     EQU190 
  
*         CHECK/PROCESS ILLEGAL COMMON BLOCK EXTENSION ERROR. 
* 
*         TEST ILLEGAL EXTENSION BY MEMBER. 
  
 EQU.50   IX0    X7+X5       D = RAT0 + DIST
          PL     X0,EQU190   IF D .GT. 0
          BX5    -X7         DIST = -RAT0 
          FATAL  E.EQ16      ILLEGAL EXTENSION OF COMMON BLOCK ORIGIN 
          EQ     EQU190 
  
*         ILLEGAL EXTENSION BY ROOT.
  
 EQU.60   BX5    X4          DIST = RAT 
  
*         PLACE IN (FILL.) NAME OF ROOT.
  
          SA1    T.SYM
          MX7    WA.SYML
          =B7    X1-WB.W+WA.W 
          LX2    -G1.SYMIP
          =A1    X2+B7
          ERRNZ  18-G1.SYMIL
          BX7    X7*X1       SYMBOL ONLY
          LX2    G1.SYMIP    RESTORE (X2) 
          SA7    FILL.       SET NAME OF ROOT INTO MESSAGE
  
 EQU.70   FATAL  E.EQ16      ILLEGAL EXTENSION OF COMMON BLOCK ORIGIN 
          BX7    0           RAT0 = RAT - DIST = 0
          MX1    0           RBT = RB[G1T] = 0
          EQ     EQU180 
 PHASE3   SPACE  3,8
**        PHASE 3 -- COMMON-EQUIVALENCE OVERLAP SEARCH. 
* 
*         CONSTRUCT T.EOT TABLE.
*         FOR EACH EQUIVALENCE GROUP IN COMMON, EXTEND ITS RANGE TO 
*         INCLUDE MEMBERS OF COMMON BLOCK WHICH IT OVERLAPS.
*         ADD ADDITIONAL ENTRIES TO G-F TABLE FOR THESE MEMBERS AND 
*         UPDATE FWA AND LWA OF CLASS.
*         ENTRY  (B5) = EQLEN 
*                (B2) = Z=EQS 
*                (X1) = FWA(T.EOT)
  
*         SHRINK LENGTH OF T.EQUS TO GFLEN. 
*         ALLOCATE TABLE SPACE FOR T.EOT AND T.ECT. . 
  
 EQU195   BSS    0
          SHRINK T=EQUS,B5
          ALLOC  T.ECT,B5    ALLOCATE SPACE FOR T.ECT 
          ALLOC  T.EOT,B5    ALLOCATE SPACE FOR T.EOT 
  
 SNAP=D   IFNE   TEST        DUMP EQUIV. TABLE
          SA2    CO.SNAP
          LX2    1RD
          PL     X2,EQU195S  IF DECLARATIVE SNAP NOT SELECTED 
 EQU.195  DUMPT  EQUS 
 EQU195S  BSS    0
 SNAP=D   ENDIF 
  
          SA3    T.EQUS 
          =B6    X1+OA.W
          =B7    0           EOIND = 0
          SB4    -B2         GFIND = -Z=EQS 
          =A0    X3+G1.W
          MX0    -G2.LOL
  
**        CONSTRUCT EQUIVALENCE OVERLAP TABLE (T.EOT).
*         FOR EACH ROOT OF AN EQUIVALENCED GROUP, FORMAT T.EOT
*         ENTRIES AS OA., OB. . 
  
 EQU200   ZR     B5,EQU210   IF END OF T.EQUS 
          SB4    B4+B2       GFIND = GFIND + Z=EQS
          SA1    A0+B4       G1I = T.EQUS(GFIND)
          =A2    A1-G1.W+G2.W      G2I
          MX5    -G1.RBL
          MX4    G2.LINKL 
          BX3    X4*X2
          BX7    -X4*X2 
          LX3    G2.LINKL 
          SB3    X3          (B3) = LINKI = LINK[G2I] 
          SB5    B5-B2       GFLEN = GFLEN - Z=EQS
          NE     B3,B4,EQU200      IF LNKI .NE. GFIND (IF NOT ROOT) 
          BX3    X1 
          LX2    -G2.LOP
          HX3    G1.RA
          LX7    -G2.HIP
          BX4    -X0*X2      LOI = LO[G2I]
          LX1    -G1.RBP
          AX3    -G1.RAL     RAI = RA[G1I], SIGN EXTENTED 
          BX6    -X5*X1      RBI = RB[G1I]
          BX2    -X0*X7      HII = HI[G1I]
          ERRNZ  G2.LOL-G2.HIL
          IX4    X3-X4       FWAI = RAI - LOI (COULD BE NEGATIVE) 
          IX2    X3+X2       LWAI =RAI + HII
          BX4    -X0*X4 
          ERRNZ  G2.LOL-OA.FWAL 
          LX6    OA.RBP 
          LX4    OA.FWAP
          BX6    X6+X4
          LX2    OA.LWAP
          SX7    B4 
          IX6    X6+X2
          SA6    B6+B7       T.EOT(EOIND) = (RBI,FWAI,LWAI) [OA.] 
          SA7    A6-OA.W+OB.W      T.EOT(EOIND+OB.W) = GFIND[OB.] 
          SB7    B7+B2       EOIND = EOIND + Z=EOT
          ERRNZ  Z=EOT-Z=EQS
          EQ     EQU200 
  
*         SORT T.EOT IN ASCENDING ORDER OF (RB,FWA,LWA).
  
 EQU210   SX6    B7+Z=EOT 
          MX5    1
          BX7    -X5         STORE A POSITIVE LARGE NUMBER INTO 
          SA7    B6+B7       TERMINATOR WORD
          SHRINK T=EOT,X6    SHRINK (T=EOT) TO EOIND+1
  
 SNAP=D   IFNE   TEST 
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQU210S 
 EQU.210  DUMPT  EOT
 EQU210S  BSS    0
 SNAP=D   ENDIF 
  
          SA1    T.EOT
          RJ     DSRT        SORT T.EOT 
          SA2    T.EOT
          SA3    T=EOT
          =B2    -Z=EOT      EOIND = -Z=EOT 
          SB4    X3+B2       LWIND = LEN(T.EOT) - Z=EOT 
          BX7    X5 
          =B3    X2+OA.W
          SA7    B3+B4       T.EOT(LWIND) = 1S59
  
  
**        BEGIN COMMON EQUIVALENCE OVERLAP SEARCH.
*         FOR EACH EQUIVALENCE GROUP IN COMMON, SEARCH ITS ENTIRE 
*         COMMON BLOCK FOR MEMBERS OVERLAPPING WITH SPAN OF EQUIVALENCE 
*         CLASS, ADD THESE TO THE CLASS.
*         (B2) = EOIND
*         (B3) = FWA(T.EOT) + OA.W
  
  
 EQU220   SB2    B2+Z=EOT    EOIND = EOIND + Z=EOT
          SA3    B3+B2       OAI = T.EOT(EOIND) 
          MX0    -OA.RBL
          MI     X3,EQU300   IF END OF T.EOT
          LX3    -OA.RBP
          BX7    -X0*X3      RBI = RB[OAI]
          SA2    T.BLKS 
          ZR     X7,EQU220   IF RBI .NE. 0
          IX6    X2+X7
          SA2    T.COMM 
          =A4    X6+CB.W     CBI = T.BLKS(RBI)
          MX5    -CB.BLENL
          LX4    -CB.BLENP
          BX5    -X5*X4      BLENI = BLEN[CBI]
          LX4    CB.BLENP-CB.FMIP 
          SB4    X2 
          MX0    -CB.FMIL 
          BX0    -X0*X4 
          SB5    X0          COMIND = FMI[CBI]
  
*         NEXT ELEMENT IN THIS COMMON BLOCK.
*         (B2) = EOIND
*         (B3) = FWA(T.EOT) + OA.W
*         (B4) = FWA(T.COMM)
*         (B5) = COMIND 
*         (X5) = BLENI
  
 EQU230   ZR     B5,EQU220   IF END OF THIS BLOCK 
          SA3    B3+B2       OAI
          SA4    B4+B5       CMI = T.COMM(COMIND) 
          MX7    -CT.LNKL 
          CLAS=  X1,OA,(FWA,LWA)
          LX4    -CT.LNKP 
          BX6    -X7*X4 
          SB5    X6          COMIND = LNK[CMI]
          BX7    -X1*X3      CLEAR FWA, LWA FIELDS
          LX3    -OA.FWAP 
          MX0    -OA.FWAL 
          LX4    CT.LNKP-CT.RAP 
          BX2    -X0*X3      FWAC = FWA[OAI]
          BX4    -X0*X4      FWAM = RA[CMI] 
          ERRNZ  OA.FWAL-CT.RAL 
          LX3    OA.FWAP-OA.LWAP
          BX3    -X0*X3      LWAC = LWA[OAI]
          ERRNZ  OA.FWAL-OA.LWAL
          IX6    X3-X4
          BX1    X5          LWAM = BLENI 
          ZR     B5,EQU235   IF LAST ELEMENT OF BLOCK 
          SA1    B4+B5       CMN = T.BLKS(COMIND) 
          HX1    CT.RA
          AX1    -CT.RAL     LWAM = RA[CMN] 
  
 EQU235   MI     X6,EQU230   IF LWAC .LT. FWAM
          ZR     X6,EQU230   IF LWAC .EQ. FWAM
          IX0    X1-X2
          MI     X0,EQU230   IF LWAM .LT. FWAC
          ZR     X0,EQU230   IF LWAM .EQ. FWAC
  
*         OVERLAP EXISTS, UPDATE (FWA,LWA) OF CLASS.
  
          MX6    X4-X2       FWAC = MIN (FWAM, FWAC)
          LX6    OA.FWAP
          IX7    X6+X7
          MX0    X1+X3       LWAC = MAX (LWAM, LWAC)
          LX0    OA.LWAP
          IX7    X7+X0
          SA7    A3          (FWA,LWA) [OAI] = (FWAC,LWAC) [OA.]
  
*         CHECK IF THIS COMMON ELEMENT IS IN THE G-F TABLE. 
*         (A4) = CMI
  
          SA4    A4          CMI
          SA1    T.EQUS 
          SA2    T=EQUS 
          =B7    X1+G1.W
          MX7    -G1.SYMIL
          BX6    X4 
          LX6    -CT.TAGP 
          BX6    -X7*X6      TAGI = TAG[CMI]
          ERRNZ  CT.TAGL-G1.SYMIL 
          LX0    X6,B1
          IX6    X6+X0       SYMM = 3 * TAGI
          LX7    G1.SYMIP 
          =X6    X6+WB.W
          SB6    X2-Z=EQS    LENGF = LEN(T.EQUS) - Z=EQS
          LX6    G1.SYMIP 
  
 EQU240   SA1    B7+B6       G1I = T.EQUS(LENGF)
          SB6    B6-Z=EQS    LENGF = LENGF - Z=EQS
          BX3    -X7*X1      SYMI = SYM[G1I]
          IX2    X6-X3
          ZR     X2,EQU230   IF MATCH 
          GE     B6,B0,EQU240      IF TABLE NOT EXHAUSTED 
  
*         MATCH NOT FOUND, CREATE AN ENTRY FOR IT.
*         (A3) = OAI
*         (A4,X4) = CMI 
  
          MX0    -G1.RAL
          SA2    A3-OA.W+OB.W 
          HX4    CT.RA
          SB6    X2          GFIR = GFI(OBI)
          ERRNZ  18-OB.GFIL 
          AX4    -CT.RAL     RAI = RA[CMI]
          SA2    B7+B6       G1R = T.EQUS(GFIR) 
          HX2    G1.RA
          AX2    -G1.RAL     RAR = RA[G1R], SIGN EXTENTED 
          IX4    X4-X2       RAM = RAM - RAR
          BX0    -X0*X4 
          LX0    G1.RAP 
          IX4    X6+X0
          ALLOC  T.EQUS,Z=EQS 
          LX6    X4 
          SX7    B6 
          LX7    G2.LINKP 
          =A7    B7-1        GF2 = (GFIR)[G2.]
          SA6    A7-B1       GF1 = (SYMM,RAM) [G1.] 
  
*         RESTORE SOME TABLE ORGINS.
  
          SA2    T.EOT
          SA1    T.COMM 
          SB4    X1 
          =B3    X2+OA.W
          EQ     EQU230 
  
 PHASE4   SPACE  3,8
**        PHASE 4 -- EQUIVALENCE CLASS OVERLAP SEARCH.
* 
*         MERGE OVERLAPPING EQUIVALENCE CLASSES WITHIN COMMON BLOCKS. 
* 
*         ENTRY  T.EOT FORMATED [OA.,OB.], SORTED BY [RB.,RA.]
*                (B3) = FWA(T.EOT) + OA.W 
  
  
 EQU300   BSS    0
  
 SNAP=D   IFNE   TEST 
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQU300S  IF SNAP NOT REQUESTED
 EQU.300  DUMPT  EQUS 
 EQU300S  BSS    0
 SNAP=D   ENDIF 
  
          SA1    T.EOT
          SA2    T.EQUS 
          =X7    1
          =B5    -Z=EOT      EOIND = -Z=EOT 
          =B2    X2+G1.W
          SA7    N.EQ        INITIALIZE (N.EQ) = 1
          =B4    Z=EOT
          =A1    X1-Z=EOT+OA.W     OANA = FWA(T.EOT) - Z=EOT
  
  
**        OVERLAP SEARCH BEGINS.
*         (A1) _ OANA 
*         (B4) = Z=EOT
  
  
 EQU310   SA1    A1+B4       OANA = OANA + Z=EOT, OAN = (OANA)
          MI     X1,EQU340   IF END OF T.EOT
          MX6    OA.RBL 
          LX6    OA.RBL+OA.RBP
          BX7    X6*X1       RBN = RB[OAN]
          ZR     X7,EQU310   IF RBN .EQ. 0
          =B6    Z=EOT
  
 EQU320   SA2    A1+B6       OAN1 = OAN + OFFSET
          =B6    B6+Z=EOT 
          MI     X2,EQU310   IF END OF TABLE
          MX6    OA.RBL 
          LX6    OA.RBL+OA.RBP
          BX6    X6*X2       RBN1 = RB[OAN1]
          IX5    X7-X6
          NZ     X5,EQU320   IF RBN .NE. RBN1 
  
*         SAME RB, CHECK FOR OVERLAP. 
  
          MX0    -OA.LWAL 
          ERRNZ  OA.LWAL-OA.FWAL
          LX2    -OA.LWAP 
          LX1    -OA.LWAP 
          BX5    -X0*X2      LWAN1 = LWA[OAN1]
          BX6    -X0*X1      LWAN = LWA[OAN]
          LX2    OA.LWAP-OA.FWAP
          BX2    -X0*X2      FWAN1 = FWA[OAN1]
          =X3    1
          IX2    X2+X3       TRUE FWA 
          IX2    X6-X2
          MI     X2,EQU320   IF LWAN .LT. FWAN1  (NO OVERLAP) 
  
*         THERE IS OVERLAP, JOIN TWO CLASSES. 
  
          =A3    A2-OA.W+OB.W      OBN1 
          =A4    A1-OA.W+OB.W      OBN
          LX1    OA.LWAP-OA.FWAP
          MX2    X5+X6       LWASR = MAX (LWAN, LWAN1)
          SX3    X3          GNSR = GFI[OBN1] 
          SX4    X4          GSR = GFI[OBN] 
          ERRNZ  18-OB.GFIL 
          IX6    X4-X3
          MI     X6,EQU330   IF GSR .LT. GNSR 
          BX6    X3          TEMP = GNSR
          LX3    X4          GNSR = GSR 
          BX4    X6          GSR = TEMP 
  
 EQU330   SB7    X4 
          BX6    0
          SA6    A1          (OANA) = 0 
          LX1    OA.FWAP-OA.LWAP
          BX6    X0*X1       ALL BUT LWA
          IX6    X6+X2
          LX6    OA.LWAP
          SA6    A2          LWA[OAN1] = (LWASR)[OA.] 
          BX6    X4 
          SA6    A2-OA.W+OB.W  GFI[OBN1] = GSR[OB.] 
  
*         UPDATE G-F ENTRY OF NON SURVIVING ROOT.  ADJUST ITS RA
*         AND MAKE IT POINT TO THE SURVIVING ROOT.
  
          SA4    B2+X4       GF1SR = T.EQUS(GSR)
          SA3    B2+X3       GF1NSR = T.EQUS(GNSR)
          BX2    X0*X3
          HX4    G1.RA       SIGN EXTEND
          HX3    G1.RA
          AX4    -G1.RAL     RASR = RA[GF1SR] 
          AX3    -G1.RAL     RANSR = RA[GF1NSR] 
          IX5    X3-X4
          BX3    -X0*X5      RANSR = RANSR - RASR 
          ERRNZ  OA.LWAL-G1.RAL 
          =A5    A3-G1.W+G2.W      G2NSR
          MX6    G2.LINKL 
          BX5    -X6*X5 
          SX6    B7 
          LX6    G2.LINKP 
          BX6    X6+X5
          SA6    A5          LINK[G2NSR] = GSR[G2.] 
          IX6    X2+X3
          SA6    A3          RA[GF1NSR] = RANSR[G1.]
          EQ     EQU310 
  
**        OVERLAP SEARCH COMPLETE.
*         PREPARE FOR PHASE 5.
*         (B5) = EOIND
*         (B3) = FWA(T.EOT) + OA.W
  
 EQU340   =B6    0           ECIND = 0
  
 EQU350   SB5    B5+Z=EOT    EOIND = EOIND + Z=EOT
          SA2    B3+B5       OAI = T.EOT(EOIND) 
          BX3    X2 
          MI     X2,EQU400   IF END OF T.EOT
          ZR     X2,EQU350   IF NULL ENTRY
  
*         CREATE A BASE SYMBOL *EQ.N* FOR EACH EQUIVALENCE CLASS N
*         WITH DIMENSION OF 1 AND LENGTH OF SPAN OF CLASS.
  
          =A1    A2-OA.W+OB.W      OBI = OB ENTRY OF T.EOT
          SA4    T.EQUS 
          IX1    X4+X1
          =A4    X1+G1.W     G1I = G1 ENTRY OF T.EQUS 
          HX4    G1.CHAR
          HX3    OA.LWA 
          HX2    OA.FWA 
          AX2    -OA.FWAL    FWAC = FWA[OAI], SIGN EXTENTED 
          AX3    -OA.LWAL    LWAC = LWA[OAI], SIGN EXTENTED 
  
          IFEQ   TEST,ON,1
          MI     X3,"BLOWUP" LWA OF CLASS SHOULD NEVER BE NEGATIVE
  
          IX5    X3-X2       SPANC = LWAC - FWAC
          PL     X4,EQU355   IF NON-CHAR
          CW     X1,X5       SPANC = SPANC / 10 
          LX5    X1 
  
 EQU355   SA1    N.EQ 
          SX7    3REQ.
          RJ     INN         INVENT A BASE SYMBOL 
          SB4    X0          SAVE (B4) = SYMORD OF BASE MEMBER
          SX3    B1 
          SX7    B1 
          BX4    X5 
          LX5    DH.PSP 
          LX4    D2.UBP 
          LX7    DH.DIMP
          IX7    X7+X5
          SA7    DIMI        (SIZ,DIM)[DH.] = (SPANC,1) 
          LX3    D2.LBP 
          LX5    D1.SPANP-DH.PSP
          BX6    X5 
          SA6    A7+B1       (LOC,SPAN)[D1.] = (0,SPANC)
          IX7    X4+X3
          SA7    A6+B1       (LB,UB)[D2.] = (1,SPANC) 
          SB2    DIMI 
          SB3    B2+3 
          =B7    0
          SCAN   T.DIM,NCM   (B7) = DIMIND OF BASE MEMBER 
  
*         PUT (EOT INDEX, SYMORD OF BASE MEMBER, FWA OF CLASS) INTO 
*         GF2 ENTRY OF EACH CLASS ROOT, SO THEY CAN BE PROPAGATED 
*         TO EACH MEMBER OF THE CLASS IN PHASE 5. 
*         (B5) = EOIND
  
          SA1    T.EOT
          SA3    T.EQUS 
          =B3    X1+OA.W
          SB2    X3+G2.W
          SA4    B3+B5       OAI = T.EOT(EOIND) 
          =A3    A4-OA.W+OB.W      OBI
          LX4    -OA.FWAP 
          MX0    -OA.FWAL 
          SA3    B2+X3       G2R = T.EQUS(GFI[OBI]) 
          ERRNZ  18-OB.GFIL 
          MX2    F2.LINKL 
          BX2    X2*X3
          LX2    F2.LINKL 
          SB2    X2 
          SX1    B5 
          SX2    B4          BSYM = SYMORD OF BASE MEMBER 
          BX3    -X0*X4      FWAC = FWA[OAI]
          LX2    F2.BSYMP 
          LX1    F2.EOIP
          LX3    F2.FWAP
          BX2    X2+X1
          BX6    X2+X3
          MX0    F2.LINKL 
          BX6    -X0*X6      CLEAR LINK 
          SX0    B2 
          LX0    F2.LINKP 
          BX6    X0+X6       NEW LINK 
          MX0    -OA.RBL
          SA6    A3          (EOI,BSYM,FWA)[G2R]= (EOIND,BSYM,FWAC)[F2.]
          LX4    OA.FWAP-OA.RBP 
          BX0    -X0*X4      RBC = RB[OAI]
  
*         CREATE AN T.ECT ENTRY FOR THE BASE MEMBER, FORMAT AS: 
*         TE. . 
  
          SA4    T.ECT
          SX2    B4+B4
          SB4    X2+B4
          ERRNZ  3-Z=SYM
          SX6    B4+WA.W     WAINDB = 3 * BSYM + WA.W 
          LX1    TE.EOIP-F2.EOIP
          SB4    X6-WA.W+WB.W 
          LX6    TE.SYMIP 
          BX6    X6+X1
          SA6    X4+B6       T.ECT(ECIND) = (EOIND,0,WAINDB) [TE.]
          SB6    B6+B1       ECIND = ECIND + 1
  
*         UPDATE (WB,WC) ENTRY OF T.SYM FOR THE INVENTED BASE MEMBER. 
*         (A5) = G1R
*         (B4) = WBINDB 
*         (X3) = FWAC 
*         (X0) = RBC
  
          LX0    WC.RBP 
          LX3    WC.RAP-F2.FWAP 
          ERRNZ  WC.RAL-F2.FWAL 
          BX7    X0          RAI[WCI] = 0 
          SA1    T.SYM
          SA2    X1+B4       WBI = T.SYM(WBINDB)
          SX6    B7          DIMIND OF BASE 
          CLAS=  X4,WB,(VAR,BMEM,ARY) 
          LX6    WB.PNTP
          BX4    X4+X2
          BX6    X4+X6
          =X1    0
          ZR     X0,EQU370   IF RBC .EQ. 0
          BX7    X7+X3
          CLAS=  X1,WB,(COM,MAT)
  
 EQU370   BX6    X6+X1       SET (COM,MAT)[WBI] IFF COMMON
          CLAS=  X1,G1,(SAVE) 
          =A5    A3-G2.W+G1.W      G1R = G1 ENTRY OF ROOT 
          BX1    X5*X1       SAVEI = SAVE[G1R]
          LX1    WB.SAVEP-G1.SAVEP
          BX6    X6+X1
          =X2    10 
          LX2    WC.CLENP 
          MX1    1
          HX5    G1.CHAR
          BX1    X1*X5
          =X3    M.CHAR 
          AX1    59          FORM MASK FOR MODE CHARACTER 
          BX3    X1*X3       (X3) = M.CHAR IF CHAR[G1I] = 1 
          BX5    X2*X1       (X5) = 10 IF CHAR[G1I] = 1 
          LX3    WB.MODEP 
          BX7    X7+X5
          =A7    A2-WB.W+WC.W      (RB,RA) [WCI] = (RBC,RAI) [WC.]
          BX6    X6+X3       ADD IN MODE
          SA6    A2          (VAR,BMEM,ARY,COM,SAVE,PNT) [WBI] = [WB.]
          ZR     X0,EQU350   IF RBC .EQ. 0 (LOCAL CLASS)
  
*         COMMON BLOCK LENGTH IS EXTENDED IF BLOCK LENGTH .LT.
*         LWA OF CLASS. 
*         ALSO COPY BLOCK LEVEL INFORMATION TO LVLN[WBI] OF BASE MEMBER,
*         AND SET LVL[WBI] = 1 IF BLOCK IS LEVELED. 
  
          SA1    B3+B5       OAI = T.EOT(EOIND) 
          SA4    T.BLKS 
          HX1    OA.LWA 
          AX1    -OA.LWAL    LWAC = LWA[OAI]
          =B2    X4+CB.W
          CLAS=  X5,CA,(BLVL) 
          LX0    -WC.RBP
          SA3    X0+B2       CBI = T.BLKS(RBC)
          =A4    A3-CB.W+CA.W      CAI = CA ENTRY OF T.BLKS 
          MX7    -CB.BLENL
          BX2    X5*X4       BLKLEV = BLVL[CAI] 
          LX3    -CB.BLENP
          LX2    WB.LEVNP-CA.BLVLP
          BX4    -X7*X3      BLEN = BLEN[CBI] 
          BX7    X7*X3
          MX5    X4+X1
          IX7    X5+X7
          LX7    CB.BLENP 
          SA7    A3          BLEN[CBI] = MAX (BLEN,LWAC)
          ZR     X2,EQU350   IF BLOCK NOT LEVELED 
          CLAS=  X1,WB,(LEV)
          BX1    X1+X2
          BX6    X6+X1
          SA6    A2          (LEV,LEVN)[WBI] = (1,BLKLEV) [WB.] 
          EQ     EQU350 
 PHASE5   SPACE  3,8
**        PHASE 5 -- GALLER / FISHER ADDRESS ASSIGNMENT.
*                WE NOW DO G/F ADDRESS ASSIGNMENT, RELATIVE TO
*         THE CLASS BASE.  THE *END* PROCESSOR WILL RELOCATE OUR
*         ADDRESSES TO THE ACTUAL LOCAL-VARIABLE BLOCK.  VARIABLES IN 
*         COMMON ARE ASSIGNED ADDRESSES RELATIVE TO THEIR RESPECTIVE
*         BLOCKS. 
*         VARIABLES WHICH ARE IN COMMON NOW, BECAUSE OF EQUIVALENCING 
*         MUST BE SO MARKED IN THE SYMBOL TABLE.
*         A TEMPORARY EQUIVALENCE CLASS TABLE (TE.) IS FORMED FOR 
*         EACH MEMBER OF THE CLASS.  IF LO=R IS SELECTED, 
*         THIS WILL BE USED TO FORMAT THE EQUIVALENCE CLASS MAP.
* 
*         ENTRY: (B6) = ECIND 
  
  
 EQU400   BSS    0
 SNAP=D   IFNE   TEST 
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQU400S 
 EQU.400  DUMPT  EQUS 
          DUMPT  EOT
 EQU400S  BSS    0
 SNAP=D   ENDIF 
  
          SA3    T=EQUS      X3 = NUMBER OF EQUIVALENCED VARIABLES
          SA2    T=ECT
          SA1    N.EQ 
          AX3    1
          =X1    X1-1        X1 = NUMBER OF EQUIVALENCE CLASSES 
          IX1    X1+X3       X1 = DESIRED LENGTH OF T.ECT 
          IX0    X1-X2       X0 = INCREMENT TO LENGTH 
          ALLOC  T.ECT,X0 
          SA1    T.EQUS 
          SA2    T.SYM
          SA3    T=EQUS 
          =A0    X1+G1.W
          SB7    X2 
          =B4    -Z=EQS      GFIND = -Z=EQS 
          SHRINK T=EOT,0     DISCARD T.EOT
          SB5    X3          GFLEN = LEN(T.EQUS)
  
 EQU410   SB4    B4+Z=EQS    GFIND = GFIND + Z=EQS
          SA1    A0+B4       G1I = T.EQUS(GFIND)
          SB5    B5-Z=EQS    GFLEN = GFLEN - Z=EQS
          MI     B5,EQU450   IF END OF T.EQUS 
          MX3    -G1.SYMIL
          =A5    A1-G1.W+G2.W      G2I
          MX0    G2.LINKL 
          BX6    X0*X5
          BX5    -X0*X5 
          MX0    G1.RBL 
          LX6    G2.LINKL 
          SB2    X6 
          LX0    G1.RBL+G1.RBP
          BX6    X1 
          BX4    X0*X1       RBC = RB[G1I]
          HX6    G1.RA
          AX6    -G1.RAL     RAI = RA[G1I]
          LX1    -G1.SYMIP
          BX7    -X3*X1      SYMI = SYM[G1I]
          SB3    X7 
          EQ     B2,B4,EQU420      IF ROOT
  
*         NON-ROOT MEMBERS. 
*         PROPAGATE (EOI,BSYM,FWA)[F2.] FROM ROOT TO MEMBER.
*         COMPUTE RA OF MEMBER AS:  
*                RAI = RAI + RA[G1ROOT] 
  
          SA3    A0+B2       G1R = T.EQUS(GFIR) 
          BX4    X0*X3       RBC = RB[G1R]
          LX1    G1.SYMIP 
          MX0    -G1.RAL
          BX7    X0*X1       CLEAR RA FIELD 
          BX7    X7+X4       ADD IN RB OF CLASS 
          HX3    G1.RA
          AX3    -G1.RAL     RAR = RA[G1R], SIGN EXTENTED 
          IX6    X6+X3       RAI = RAI + RAR
          BX3    -X0*X6      GET RID OF SIGN EXTENSION
          LX3    G1.RAP 
          BX7    X7+X3
          SA7    A1          (RB,RA)[G1I] = (RBR,RAI) [G1.] 
          =A3    A3-G1.W+G2.W      G2R = G2 ENTRY OF ROOT 
          MX7    G2.LINKL 
          BX3    -X7*X3      CLEAR LINK 
          SX7    B2 
          LX7    G2.LINKP 
          BX7    X7+X3
          SA7    A5          (EOI,BSYM,FWA)[G2I] = [G2R]
          SA5    A3 
  
*         FORM TE. ENTRY. 
*         (X4) = RB OF CLASS
*         (X6) = RAI
*         (X5) = G2R
*         (B3) = SYMI 
  
 EQU420   BX7    X5 
          LX5    -F2.EOIP 
          MX0    -F2.EOIL 
          HX7    F2.FWA 
          AX7    -F2.FWAL    FWAC = FWA[G2R]
          BX1    -X0*X5      EOI = EOI[G2R] 
          IX6    X6-X7       BIASI = RAI - FWAC 
          LX1    TE.EOIP
          SX3    B3-WB.W+WA.W 
          LX3    TE.SYMIP 
          BX1    X1+X3
          LX5    F2.EOIP-F2.BSYMP 
  
          IFEQ   TEST,ON,1
          MI     X6,"BLOWUP" BIAS SHOULD NOT BE .LT. 0
  
          LX6    TE.BIASP 
          CLAS=  X3,TE,(NB) 
          BX7    X6+X3
          BX7    X7+X1
          LX4    -G1.RBP
          SA3    T.ECT
          SA7    X3+B6       [T.ECT(ECIND)] = (EOI,NB,BIASI,SYMI)[TE.]
          SB6    B6+B1       ECIND = ECIND + 1
  
*         UPDATE SYMTAB WB,WC.
*         SET (EQU,DEF,VAR,COM,SAVE)[WBI] BITS, 
*                (BMEM)[WB.] = BSYM(G2R), 
*                (RB,RA)[WC.] = (RBC,BIASI) [WC.] 
  
          MX3    0           COMI = 0 
          ZR     X4,EQU430   IF RBR .EQ. 0
          SA1    T.BLKS 
          =B2    X1+CA.W
          CLAS=  X3,WB,(COM) COMI = COM[WB.] = 1
          CLAS=  X2,CA,(BLVL) 
          SA1    X4+B2       CAI = T.BLKS(RBI) + CA.W 
          BX7    X2*X1       BLKLEV = BLVL[CAI] 
          LX4    WC.RBP 
          ZR     X7,EQU430   IF BLOCK NOT LEVELED 
          LX7    WB.LEVNP-CA.BLVLP
          BX3    X3+X7
          CLAS=  X2,WB,(LEV)
          BX3    X3+X2       COMI = (COM,LEV,LEVN) [WB.]
  
 EQU430   LX6    WC.RAP-TE.BIASP
          ERRNZ  WC.RAL-TE.BIASL
          BX7    X6+X4
          MX0    -F2.BSYML
          BX5    -X0*X5      BSYM = BSYM[G2R] 
          LX5    WB.BASEP 
          BX5    X5+X3
          SA3    B7+B3       WBI = T.SYM(SYMI)
          =A4    A3-WB.W+WC.W      WCI
          BX3    X3+X5
          CLAS=  X6,WB,(EQV,DEF,VAR)
          BX6    X6+X3
          SA6    A3          (EQV,DEF,VAR,BASE,COMI)[WBI] = [WB.] 
          CLAS=  X1,WC,(RB,RA)
          BX4    -X1*X4 
          BX7    X4+X7
          SA7    A4          (RB,RA)[WCI] = (RBR,RAI) [WC.] 
          EQ     EQU410 
  
 EQU450   BSS    0
          SHRINK T=ECT,B6    SHRINK T.ECT TO ACTUAL SIZE
 SNAP=D   IFNE   TEST        DUMP EQUIV. TABLE
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQU450S  IF DECLARATIVE SNAP NOT SELECTED 
 EQU.450  DUMPT  EQUS 
          DUMPT  ECT
 EQU450S  BSS    0
 SNAP=D   ENDIF 
  
          SA1    WO.LOM 
          MX6    0
          SHRINK T=EQUS,X6   DISCARD T.EQUS 
          MI     X1,EXIT.    IF COMMON-EQUIVALENCE MAP SELECTED 
          SHRINK T=ECT,X6 
          EQ     EXIT.
  
 N.EQ     EQU    EQSR        NUMBER OF EQUIVALENCE CLASSES
 EQUA     CON    0           12/T0, 48/D0,[PHASE 1 OF EQU]
 EQUS     BSS    1           SUBSCRIPTED ITEM INDICATOR 
 GCI      EQU    EQUA        GROUP CHARACTER INDEX IN PHASE 1 OF *EQU*
 EQUC     BFLIT  WC,(RB,RA) 
 EQUDIM   EQU    DIMI 
          TITLE  CLOSE OF DECLARATIVE ROUTINES. 
 ACV      SPACE  4,10 
**        ACV -  ASSUMED LENGTH CHARACTER VARDIM PROCESSING 
* 
*         CHECKS A FORMAL PARAMETER FOR ASSUMED LENGTH CHARACTER.  IF SO
*         VARDIM TURPLES WILL BE OUTPUT AND THE VD. INDEX PLACED IN THE 
*         WC.CLEN FIELD FOR THE FORMAL PARAMETER. 
* 
*         ENTRY  (X1) = FORMAL PARAMETER ORDINAL
* 
*         USES   A1,A2,A5,A6  X0,X1,X2,X3,X4,X5,X6  B2,B3,B5
  
  
 ACV      SUBR   =           ...ENTRY/EXIT... 
          SA5    T.SYM
          LX1    -FP.PNTP 
          SX1    X1 
          ERRNZ  FP.PNTL-18 
          BX0    X1 
          SB5    X1 
          LX1    1
          SX1    X1+B5       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B5    X1-WA.W+WB.W 
          SA1    X5+B5       FETCH *WB* 
          MX3    -WB.MODEL
          BX2    -X3*X1      ISOLATE MODE 
          SB2    X2-M.CHAR
          NZ     B2,EXIT.    IF NOT TYPE CHARACTER
          =A2    A1-WB.W+WC.W 
          SBIT   X2,WC.CTYPP
          PL     X2,ACV1     IF NOT ASSUMED LENGTH
          CALL   CT1         GET TP. FORMAT 
          CLAS=  X4,TP,(ADDR) 
          BX4    X4+X6       MERGE IN ADDRESS BIT 
          MX5    0           2OP IS NULL
          SB3    VD.GP
          RJ     OVT         OUTPUT THE GPL TURPLE
          RJ     OVS         OUTPUT VARDIM STORE TURPLE 
          SA1    T.SYM
          HX5    TP.BIAS
          AX5    -TP.BIASL   EXTRACT VD. INDEX
          =X1    X1-WB.W+WC.W 
          SA2    X1+B5       FETCH *WC* ENTRY 
          LX5    WC.CLENP 
          BX6    X2+X5       MERGE IN VD. INDEX 
          SA6    A2 
          EQ     EXIT.
  
 ACV1     SA1    S=VALUE
          SX1    X1+M.CHAR
          IX1    X0-X1
          =X6    1
          ZR     X1,EXIT.    IF VALUE.
          SA6    N.EPL       SET FIXED CHARACTER LENGTH FP PRESENT FLAG 
          EQ     EXIT.
 MCA      SPACE  4,8
**        MCA -  MAKE RELATIVE COMMON ASSIGNMENTS 
* 
*         ENTRY- END OF DECLARATIVES HAS BEEN ENCOUNTERED 
* 
*         EXIT-  VARIABLES IN COMMON HAVE BEEN ASSIGNED BLOCK RELATIVE
*         ADDRESSES (IN T.COMM), AND THE LENGTH OF ALL COMMON BLOCKS
*         HAS BEEN COMPUTED AND ENTERED IN T.BLKS.
*                THE BLOCK IS MARKED CHARACTER  (CHAR[CA.] = 1) 
*         IF FIRST MEMBER OF THE BLOCK IS MODE CHARACTER.  MEMBERS WITH 
*         CONFLICTING MODES WITH THE BLOCK WILL BE ELIMINATED.
*                FOR A CHARACTER COMMON BLOCK, BLOCK LENGTH AND BLOCK 
*         RELATIVE ADDRESSES ARE EXPRESSED IN TERMS OF CHARACTERS.
*         AT END OF EQUIVALENCE PROCESSING, THESE WILL BE CONVERTED INTO
*         NO. OF WORDS AND CHARACTERS.
*         IF AUTOMATIC LEVEL OF COMMON AND ARGS IS SELECTED, ALL COMMON 
*         BLOCKS WILL HAVE *LEVEL* 2 INSERTED IN THE LVL FIELD. 
  
  
 MCA      SUBR               ...ENTRY/EXIT... 
          ERRNZ  FUDGE-1
          SA2    T=BLKS 
          SA3    T.BLKS 
          SA4    T.COMM 
          BX6    0
          IX2    X2+X3
          SA5    T.SYM
          SA1    T.DIM
          SA0    X4          (A0) = FWA(T.COMM) 
          SA6    X2          LWA+1 (T.BLKS) = 0 
          =B6    X5+WB.W     (B6) = FWA(T.SYM) + WB.W 
          =A3    X3+CB.W     CBA = FWA(T.BLKS)+CB.W 
          SB4    B0          RBI = 0
          SB2    X1          (B2) = FWA(T.DIM)
  
*         FETCH NEXT ENTRY FROM COMMON BLOCK TABLE AND FIND 
*         ITS FIRST MEMBER. 
*         FROM MODE[WBI] OF FIRST MEMBER, DETERMINE IF THIS IS
*         A CHARACTER COMON BLOCK.
  
 MCA10    SA3    A3+Z=BLKS   CBA = CBA+Z=BLKS, CBI =T.BLKS(CBA) 
          =A4    A3-CB.W+CA.W      CAI = CA ENTRY 
          ZR     X4,MCA99    IF END OF T.BLKS 
  
*         IF AUTOMATIC LEVEL IS ON, SET A LEVEL OF 2 INTO ALL COMMON
*         BLOCKS NOT EXPLICITLY ASSIGNED A LEVEL. 
  
          SA1    CO.AL
          PL     X1,MCA11    IF AUTOMATIC LEVEL IS OFF
          MX6    -CA.BLVLL
          LX6    CA.BLVLP 
          BX0    -X6*X4 
          NZ     X0,MCA11    IF EXPLICITLY LEVELED
          =X6    2
          LX6    CA.BLVLP 
          BX4    X6+X4       SET LEVEL 2
          BX6    X4 
          SA6    A4          UPDATE CAI 
          SA6    LEVEL2      MARK LEVEL 2 STORAGE IN USE
          SA6    LEVEL
  
 MCA11    MX0    -CA.LMIL 
          LX4    -CA.LMIP 
          BX6    -X0*X4      LASTMEM = LMI[CBA] 
          NZ     X6,MCA13    IF AT LEAST ONE MEMBER ENTERED 
          SA6    A3          CBI = 0     SET FMI[CBA] = 0 
          BX3    X6 
  
 MCA13    SB4    B4+Z=BLKS
          MX0    -WB.MODEL
          MX6    -CB.FMIL 
          LX3    -CB.FMIP 
          BX6    -X6*X3      COMIND = FMI[CBI]
          SB5    X6 
          SB3    B5          BPNTER = COMIND
  
*         DIAGNOSE EMPTY COMMON BLOCK DECLARED THROUGH SAVE.
  
          NZ     X6,MCA15    IF COMIND .NE. 0 
          MX0    CA.BNAML 
          BX6    X0*X4       EXTRACT BLOCK NAME 
          SA6    FILL.
          FATAL  E.CM12 
          EQ     MCA10
  
  
 MCA15    SA1    A0+B5       CMF = T.COMM(COMIND) 
          LX1    -CT.TAGP 
          SB7    X1 
          ERRNZ  18-CT.TAGL 
          SX2    B7+B7
          SX7    X2+B7       STIND = 3 * TAG[CMF] 
          ERRNZ  3-Z=SYM
          SA2    X7+B6       WBF = T.SYM(STIND) 
          LX2    -WB.MODEP
          BX2    -X0*X2      MODEI = MODE[WBF]
          SX7    X2-M.CHAR
          CLAS=  X2,CA,(CHAR) 
          NZ     X7,MCA20    IF NOT MODE CHARACTER
          BX6    X4+X2
          SA6    A4          CHAR[CAI] = 1
  
*         FETCH FROM T.COMM NEXT COMMON MEMBER OF THIS BLOCK AND
*         SET ITS  RB[WC.] = RBI, RA[WC.] = BLEN[CBI].
* 
*         A3 = CBI
*         (B3) = BPNTER, PNTER TO THE PREVIOUS COMMON ELEMENT 
*         (B4) = RBI
*         (A0) = FWA(T.COMM)
*         (B5) = COMIND 
*         (B6) = FWA(T.SYM) + WB.W
  
 MCA20    ZR     B5,MCA10    IF COMIND .EQ.0  (END OF THIS BLOCK) 
          SA1    A0+B5       CMI = T.COMM(COMIND) 
          =A4    A3-CB.W+CA.W      CAI = CA ENTRY 
          MX0    1
          HX4    CA.CHAR
          BX4    X4*X0       (X4) = CHAR INDICATOR
          BX2    X1 
          LX1    -CT.TAGP 
          MX0    -CT.LNKL 
          SB7    X1          TAGI = TAG[CMI]
          ERRNZ  18-CT.TAGL 
          LX2    -CT.LNKP 
          BX2    -X0*X2      COMIND = LNK[CMI]
          SX3    B7+B7
          SX3    X3+B7       STINDB = 3 * TAGI
          ERRNZ  3-Z=SYM
          SX0    B3          SAVE BPNTER
          SB3    B5          BPNTER = COMIND
          MX7    -WB.MODEL
          SB5    X2          COMIND = LNK[CMI]
          SA2    X3+B6       WBI = T.SYM(STINDB)
          LX2    -WB.MODEP
          BX3    -X7*X2      MODEI = MODE[WBI]
          SB7    X3          CMI = MODEI
          SX6    B7-M.CHAR
          LX2    WB.MODEP 
          BX3    0           INDICATE NON-CHAR
          NZ     X6,MCA25    IF ELEMENT NOT MODE CHAR 
          MX3    1           INDICATE CHARACTER 
          =B7    477777B     CMI = -300000B (CHARACTER MODE INDICATOR)
  
 MCA25    IX6    X3-X4       COMPARE WITH BLOCK CHAR INDICATOR
          MX3    -CT.LNKL 
          ZR     X6,MCA40    IF NO CONFLICT 
  
*         THIS ELEMENT CAUSES CHARACTER MODE CONFLICT IN THIS BLOCK.
*         DELETE IT FROM THE BLOCK, AND SET ITS COM[WBI] = 0. 
*         INDICATE ERROR BY SETTING NAC[CAI] = 1. 
  
          CLAS=  X7,WB,(COM)
          BX6    -X7*X2      CLEAR COM[WBI] FIELD 
          SB3    X0          BPTER = SAVED BPTER
          SA5    A0+B3       CMB = T.COMM(BPTER)
          SA6    A2          COM[WBI] = 0 
          SX7    B5 
          LX5    -CT.LNKP 
          BX6    X3*X5       CLEAR LNK[CT.] FIELD 
          =A4    A3-CB.W+CA.W      CAI = CA ENTRY 
          BX6    X6+X7       ADD IN NEW LINK
          LX6    CT.LNKP
          CLAS=  X0,CA,(NAC)
          BX7    X0+X4
          SA6    A5          LNK[CMB] = CMIND 
          SA7    A4          NAC[CAI] = 1 
          EQ     MCA20
  
*         UPDATE BLOCK LENGTH, STORE BLOCK RELATIVE ADDRESS.
  
 MCA40    SA3    A3          CBI = CB ENTRY OF T.BLKS 
          =A5    A2-WB.W+WC.W      WCI = WC ENTRY OF T.SYM
          LX3    -CB.BLENP
          SX4    B4 
          LX4    WC.RBP 
          MX0    -CB.BLENL
          BX6    -X0*X3      BLENI = BLEN[CBI]
          LX1    CT.TAGP-CT.RAP 
          BX7    X1+X6
          LX7    CT.RAP 
          LX6    WC.RAP 
          IX6    X4+X6
          SA7    A1          RA[CMI] = BLENI[CT.] 
          MX4    -WB.PNTL 
          BX6    X6+X5
          SA6    A5          (RB,RA) [WCI] = (RBI,BLENI) [WC.]
          BX1    X2 
          LX2    -WB.PNTP 
          BX0    -X4*X2      DTIND = PNT[WBI] 
  
*         FETCH ARRAY LENGTH FROM T.DIM ENTRY AND UPDATE
*                BLEN[CBI] = BELN[CBI] + ARRAY LENGTH.
*         FOR CHARACTER ITEM, ARRAY LENGTH = ARRAY LENGTH * CLEN[WCI] 
*         (X5) = DTA, DIMENSION TABLE ENTRY OF THIS COMMON ELEMENT
*         (B7) = CMI
*         A3,(X3) = CBI 
  
 MCA70    SA5    X0+B2       DTI = T.DIM(DTIND) 
          LX5    -DH.PSP
          MX7    -DH.PSL
          BX4    -X7*X5      CMLEN = SIZ[DIT] 
          MX2    -0          FOR TWO WORD ELEMENTS
          SX1    B7-M.DBL 
          ZR     X1,MCA90    IF MODE DOUBLE 
          SX1    X1+M.DBL-M.CPLX
          ZR     X1,MCA90    IF MODE COMPLEX
          SX2    0           FOR ONE WORD ELEMENTS
          GE     B7,B0,MCA90 IF CMI .GE. 0 (IF NOT MODE CHARACTER)
          SA5    A2-WB.W+WC.W      WCI = WC ENTRY 
          HX5    WC.CLEN
          AX5    -WC.CLENL
          IX4    X4*X5       CMLEN = CMLEN * CLEN[WCI]
  
 .TEST    IFEQ   TEST,ON
          ZR     X5,"BLOWUP" IF CLEN .EQ. 0 
          LX4    -CB.BLENL
          AX4    -CB.BLENL
          MI     X4,"BLOWUP" CHARACTER BLOCK LENGTH TOO LONG
 .TEST    ENDIF 
  
 MCA90    BX2    X2*X4
          IX4    X2+X4       CMLEN = 2 * CMLEN IF DOUBLE
          MX1    -CB.BLENL
          BX7    X1*X3
          BX3    -X1*X3      BLEN = BLEN[CBI] 
          IX4    X3+X4       BLEN = BLEN + CMLEN
          BX6    -X1*X4      TRUNCATE TO CB.BLENL 
          BX6    X7+X6
          LX6    CB.BLENP 
          SA6    A3          BLEN[CBI] = BLEN[CBI] + CMLEN
          EQ     MCA20
 MCA99    BSS    0
 SNAP=B   IFNE   TEST 
          SA3    CO.SNAP
          LX3    1RB
          PL     X3,MCA99S   IF BLOCK TABLE SNAP NOT SELECTED 
 MCA.99   DUMPT  BLKS 
 MCA99S   BSS    0
 SNAP=B   ENDIF 
  
          EQ     EXIT.
 MFR      SPACE  3,10 
**        MFR -  MARK FUNCTION AS REFERENCED
* 
*         IF COMPILING A FUNCTION, THIS ROUTINE WILL SET WB.MDF 
*         ON THE VALUE. SYMBOL CORRESPONDING TO THE MODE OF 
*         THE FUNCTION. 
* 
*         USES   X - 0,1,2,6  A - 1,2,6  B - 2
  
 MFR      SUBR               ...ENTRY/EXIT... 
          SA1    MOD
          HX1    MO.FUN 
          PL     X1,EXIT.    IF NOT COMPILING A FUNCTION
          SA2    S=VALUE
          LX1    MO.FUNP+1-MO.MODEP 
          MX0    -MO.MODEL
          BX1    -X0*X1      ISOLATE FUNCTION MODE
          IX1    X1+X2       X1 = SYMORD OF PROPER VALUE. SYMBOL
          SB2    X1 
          LX1    1
          SX1    X1+B2       CONVERT TO INDEX 
          SA2    T.SYM
          SB2    X1+WB.W
          SA2    X2+B2       *WB* OF PROPER VALUE. SYMBOL 
          LDBIT  X1,WB.MDFP 
          BX6    X1+X2
          SA6    A2          SET 1REF *DEFINITION REQUIRED* FLAG
          EQ     EXIT.
 PCF      SPACE  4,10 
**        PCF -  PROCESS CHARACTER/FORMAL PARAMETER INTERACTION 
* 
*         IF THE MAIN ENTRY (FUNCTION ONLY) IS TYPE CHARACTER, THE
*         CORRESPONDING VALUE. IS MADE THE FIRST FORMAL PARAMETER.  ANY 
*         FORMAL PARAMETER WITH ASSUMED CHARACTER LENGTH WILL HAVE A
*         VARDIM TURPLE ASSOCIATED WITH IT. 
* 
*         CALLS  ACV, ADW, ALC, MVE=
  
  
 PCF      SUBR               ...ENTRY/EXIT... 
          SA1    CHARDCL
          ZR     X1,EXIT.    IF NO CHARACTER DECLARATIONS 
          SA1    S=ENTRY
          SA2    T.SYM
          SB2    X1 
          LX1    1
          SX1    X1+B2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B2    X1-WA.W+WB.W 
          SA1    X2+B2       FETCH MAIN ENTRY *WB*
          MX0    -WB.MODEL
          LX1    -WB.MODEP
          BX0    -X0*X1      EXTRACT MODE 
          SB2    X0-M.CHAR
          NZ     B2,PCF6     IF MAIN ENTRY NOT TYPE CHARACTER 
          =A3    A1-WB.W+WC.W 
          MX0    -WC.CLIFL
          LX3    -WC.CLIFP
          BX3    -X0*X3      ISOLATE CLIF OF MAIN ENTRY 
          SA5    S=VALUE
          SA4    T.SYM
          SX5    X5+M.CHAR
          SB2    X5 
          LX1    X5,B1
          SX1    X1+B2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B2    X1-WA.W+WB.W 
          SA2    B2+X4       FETCH VALUE. *WB*
          CLAS=  X6,WB,(FP) 
          BX6    X2+X6       VALUE. BECOMES A FORMAL PARAMETER
          SA1    MOD
          LX3    MO.CLIFP 
          BX7    X1+X3
          SA7    A1          PROPAGATE CLIF TO MOD
          SA1    A2-WB.W+WC.W      *WC* OF VALUH. 
          LX3    WC.CLIFP-MO.CLIFP
          BX7    X1+X3
          SA7    A1          PROPAGATE CLIF TO VALUH. 
          CLAS=  X3,WB,(EQV,BASE) 
          BX6    -X3*X6 
          SA6    A2 
          ALLOC  T.FPI,1     NEED A NEW ENTRY FOR VALUE.
          BX3    X1 
          SX1    X2-1        COUNT (LESS NEW CELL)
          BX2    X3          SOURCE 
          =X3    X2+1        DESTINATION
          SB4    X1          SAVE COUNT 
          MOVE   X1,X2,X3    MAKE ROOM FOR NEW FPNO 1 
          SA1    T.FPI
          BX6    X5 
          SA6    X1          VALUE. BECOMES FPNO 1
          =X7    1
          LX7    WB.FPNOP 
          SA4    T.SYM
  
 PCF1     SA2    X1+B4
          SB2    X2 
          LX2    1
          SX2    B2+X2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B2    X2-WA.W+WB.W 
          SA3    X4+B2       FETCH FORMAL PARAMETER *WB*
          IX6    X7+X3       INCREMENT FORMAL PARAMETER NUMBER
          SA6    A3 
          =B4    B4-1 
          PL     B4,PCF1     IF NOT FINISHED
  
*         IF ASSUMED SIZE, MUST INSERT ENTRY FOR VALUH. INTO T.ENTP AND 
*         ADJUST EXISTING ENTRIES.
  
          SA1    MOD
          SBIT   X1,MO.CTYPP
          PL     X1,PCF6     IF NOT ASSUMED SIZE
          SA1    T.ENTP 
          SA2    T=ENTP 
          NZ     X2,PCF2     IF NOT NULL PARAMETER LIST 
          =X6    1
          LX6    EH.FPCP     COUNT IS ONE 
          =X0    1
          LX0    EH.BIASP    CPL. BIAS WILL BE 1
          BX6    X6+X1       FORM EH. 
          ADDWD  T.ENTP 
          SA1    S=VALUE
          SX6    X1+M.CHAR   VALUE.H
          LX6    EF.ORDP
          ADDWD  T.ENTP      EF. WORD 
          =X6    2
          SA6    N.CPL
          EQ     PCF6 
  
 PCF2     =B4    X2-1        COUNT EF. WORDS ONLY 
          =B7    X1+1        POINT TO FIRST EF. WORD
          SA1    X1          FETCH HEADER (EH. WORD)
          SX6    1
          LX1    -EH.FPCP 
          MX0    -EH.FPCL 
          IX6    X6+X1       INCREMENT FP COUNT 
          BX0    -X0*X6      EXTRACT COUNT
          LX6    EH.FPCP
          SA6    A1          UPDATE 
          =X0    X0+1        INCREMENT FOR THE MANDATORY NULL ELEMENT 
          MX1    -2 
          BX1    -X1*X0      FOR MOD4 ARITHMETIC
          AX0    2
          SB6    X0 
          ZR     X1,PCF3     IF PARCELLED EXACTLY 
          =B6    B6+1 
  
 PCF3     EQ     B6,B4,PCF4  IF NO ALLOCATION NEEDED
          MX6    0
          ADDWD  T.ENTP      ADD NEW WORD 
          =B7    X1+1        POINT TO FIRST EF. WORD
          =B4    X2-1        COUNT EF. WORDS ONLY 
  
 PCF4     SA1    N.CPL
          =X6    X1+1        INCREMENT
          SA6    A1 
          SA1    S=VALUE
          SX1    X1+M.CHAR   FIRST 'CARRY OVER' IS VALUH. 
  
 PCF5     SA2    B7          FETCH EF. WORD 
          LX1    EF.ORDP     POSITION CARRY OVER
          MX0    -EF.ORDL 
          BX0    -X0*X2 
          AX2    EF.ORDL     DROP ONE ENTRY 
          BX6    X1+X2       ADD IN CARRY OVER
          SA6    A2 
          =B7    B7+1        INCREMENT POINTER
          =B4    B4-1        DECREMENT COUNT
          BX1    X0          CARRY OVER FOR NEXT EF. WORD 
          NZ     B4,PCF5     IF MORE ADJUSTMENT 
  
*         TEST FOR ASSUMED LENGTH CHARACTER 
  
 PCF6     SA2    T=FPI
          SA3    T.FPI
          ZR     X2,EXIT.    IF NO FORMAL PARAMETERS
          SB4    X2-1        LAST T.PFI ELEMENT 
  
 PCF10    SA1    X3+B4       FORMAL PARAMETER INFORMATION (ORDINAL) 
          RJ     ACV         PROCESS FOR ASSUMED LENGTH CHARACTER 
          SA1    MOD
          MX0    -MO.CLIFL
          LX1    -MO.CLIFP
          BX1    -X0*X1      ISOLATE CLIF 
          SA2    S=VALUE     SYMORD OF VALUE. 
          SA4    T.SYM
          =X2    X2+M.CHAR   SYMORD OF VALUH. 
          SB2    X2 
          LX2    1
          SB2    X2+B2       CONVERT TO INDEX 
          SB2    B2-WA.W+WC.W 
          SA2    X4+B2       *WC* OF VALUH. 
          LX1    WC.CLIFP 
          BX6    X2+X1
          SA6    A2          RESET WC.CLIF OF VALUH.
          SA3    T.FPI
          SB4    B4-1 
          PL     B4,PCF10    IF NOT FINISHED
          EQ     EXIT.
 PKS      SPACE  4,10 
**        PKS -  PARSE CONSTANT SUBSTRING.
* 
*         ENTRY  (B4) _ SUBSTRING LEFT PAREN
*                (X1) = WB INDEX OF VARIABLE
*                (FILL.) = VARIABLE NAME FOR DIAGNOSTICS
* 
*         EXIT   (B4) _ TOKEN AFTER SUBSTRING RIGHT PAREN.
*                (X5) = SUBSTRING FIRST 
*                (X6) = SUBSTRING LAST
*                FIRST AND LAST ARE GUARANTEED TO BE LEGITIMATE.
* 
*         USES   ALL. 
* 
*         CALLS  FATAL,PIX. 
  
 PKS      SUBR               ...ENTRY/EXIT... 
          SA4    B4 
          MX6    -TB.IOCPL
          LX4    -TB.IOCPP
          BX6    -X6*X4      PNTRP = IOCP(TOKEN)
          LX4    TB.IOCPP-1-TB.COLP 
          SA6    PKSA+1      (PKSA+1) = PNTRP 
          PL     X4,PKS80    IF THERE IS NO COLON 
          =A4    B4+1 
          =B4    B4+1 
          SB2    X4-O.COLON 
          =X6    1           FIRST = 1
          ZR     B2,PKS30    IF SUBSTRING FIRST OMITTED 
          CALL   PIX         PARSE INTEGER CONSTANT EXPRESSION
  
 PKS30    SA6    PKSA        (PKSA) = FIRST 
          SA2    B4 
          =B4    B4+1 
          SB7    X2-O.COLON 
          NZ     B7,PKS80    IF NEXT NOT COLON
          SA4    B4 
          SB2    X4-O.RP
          =X6    1
          LX6    18          X6 = POSITIVE LARGE NUMBER 
          ZR     B2,PKS40    IF SUBSTRING LAST OMITTED
          CALL   PIX         PARSE INTEGER CONSTANT EXPRESSION
  
 PKS40    SA2    B4 
          SB7    X2-O.RP
          NZ     B7,PKS80    IF NO RIGHT PAREN
          =B4    B4+1        ADVANCE CURSOR PAST SUBSTRING RP 
          SA5    PKSA        X5 = FIRST 
          =X0    1
          IX3    X5-X0
          IX4    X6-X0
          BX3    X3+X4       MI IFF FIRST OR LAST NOT POSITIVE
          IX0    X6-X5       MI IFF FIRST GT LAST 
          BX0    X0+X3
          PL     X0,EXIT.    IF NO ERROR
          FATAL  E.AT16 
          =X5    1
          =X6    1
          EQ     EXIT.
  
*         SYNTAX ERROR OCCURED IN THIS SUBSTRING EXPRESSION,
*         DIAGNOSE, SET DEFAULT AND EXIT. 
  
 PKS80    FATAL  E.ST        SYNTAX ERROR 
          =A1    PKSA+1 
          =B4    X1+1        ADVANCE PAST CLOSING RIGHT PAREN 
          =X5    1
          =X6    1
          EQ     EXIT.
  
 PKSA     BSS    2           SAVE SUBSTRING RESULT AND CLOSING RP 
 PSC      SPACE  4,10 
**        PSC - PROPAGATE SAVE BIT THROUGH COMMON.
* 
*         ENTRY - COMMON,EQUIVALENCE PROCESSING COMPLETED.
*                EXPLICIT SAVE DECLARATION OF COMMON ELEMENT HAVE BEEN
*                DIAGNOSED. 
* 
*         EXIT - ALL COMMON ELEMENTS BELONGING TO A SAVE DECLARED 
*                COMMON BLOCK HAVE SAVE[WB.] = 1. 
  
  
 PSC      SUBR               ...ENTRY/EXIT... 
          SA1    SAVE 
          SA3    USAVE
          SA2    T=SYM
          ZR     X1,EXIT.    IF NO EXPLICIT SAVE DECLARATION
          NZ     X3,EXIT.    IF UNIVERSAL SAVE
          SA4    T.SYM
          SA1    T.BLKS 
          SB6    X2 
          SB4    X1+CB.W
          =B3    Z=SYM
          =A5    X4+WB.W
          CLAS=  X2,WB,(COM)
          MX0    -WC.RBL
          CLAS=  X4,CB,(SAVE) 
 PSC10    SA5    A5+B3       WBI = WB ENTRY OF T.SYM
          SB6    B6-B3
          ZR     B6,EXIT.    IF END OF T.SYM
          BX6    X2*X5       COMI = COM[WBI]
          =A1    A5+WC.W-WB.W 
          SBIT   X5,WB.LABP 
          MI     X5,PSC10    IF LABEL 
          ZR     X6,PSC10    IF NOT COMMON
          LX1    -WC.RBP
          BX1    -X0*X1      RBI = RB[WCI]
          SA3    X1+B4       CBI = T.BLKS(RBI) + CB.W 
          BX3    X4*X3       SAVEI = SAVE[CBI]
          LX5    1+WB.LABP
          LX3    WB.SAVEP-CB.SAVEP
          BX6    X5+X3
          SA6    A5          SAVE[WBI] = SAVE[CBI]
          EQ     PSC10
 SAS      SPACE  4,10 
**        SAS -  SCAN ARRAY SIZES.
* 
*         RESPONSIBLE FOR ISSUING FATAL ERROR FOR EVERY 
*         ARRAY WHOSE SIZE EXCEEDS THE MAXIMUM ALLOWED. 
* 
*         CALLS  GPS,PDM. 
* 
*         USES   X - ALL  A - 1,2,3,4,5,7  B - 2,3,5,6,7. 
  
 SAS      SUBR               ...ENTRY/EXIT... 
          SA2    T=SYM
          SA4    T.SYM
          =B3    Z=SYM
          SB5    X2          B5 = LENGTH OF SYMTAB
          =A4    X4-Z=SYM+WB.W
          =B6    -1          INITIAL SYMTAB ORDINAL 
          SA5    CO.LCM 
          MX6    WA.SYML
  
 SAS10    SA4    A4+B3
          ZR     B5,EXIT.    IF TABLE EXHAUSTED 
          HX4    WB.ARY 
          IFEQ   TEST,ON,1
          MI     B5,"BLOWUP" IF SYMTAB LENGTH NOT MULTIPLE OF Z=SYM 
          SB5    B5-B3
          =B6    B6+1 
          PL     X4,SAS10    IF NOT AN ARRAY
          CALL   GPS         GET PRODUCT OF SPANS 
          LX4    WB.ARYP-WB.LCMP
          BX0    X4*X5
          SB2    E.DM19 
          SX7    MAX.SPCM 
          PL     X0,SAS20    IF X7,B2 ARE CORRECT 
          SB2    E.DM20 
          SA1    SASA 
          BX7    X1 
  
 SAS20    IX0    X7-X2
          PL     X0,SAS10    IF SIZE OK 
          SA1    A4-WB.W+WA.W      *WA* 
          HX1    WA.SYM 
          BX7    X6*X1       ISOLATE ARRAY NAME 
          SA7    FILL.
          FATAL  B2 
          EQ     SAS10       CONTINUE 
  
 SASA     CON    MAX.SPLC 
 VDP      SPACE  4,8
**        VDP -  VARIABLE DIMENSION PROCESSING
* 
*         CHECK ALL VARIABLES IN SYMBOL TABLE FOR THOSE USED AS 
*         SUBSCRIPTS IN ARRAYS.  IF THESE ARE FORMAL PARAMETERS OR IN 
*         COMMON, SET OFF THE WB.VDS BIT.  TEST FOR TYPE INTEGER. 
* 
*         CLEAR THE VD.IND FIELD FOR ALL ENTRIES IN T.VDI.
  
 VDP      SUBR               ...ENTRY/EXIT... 
          SA4    N.VD 
          SA2    T.SYM
          ZR     X4,EXIT.    IF NO VARIABLE SUBSCRIPTS
          SA3    T=SYM
          MX7    -WB.MODEL
          =B6    X3-Z=SYM+WB.W
          CLAS=  X5,WB,(VDS)
 VDP1     MI     B6,VDP3     IF LIST IS EXHAUSTED 
          SA3    X2+B6
          =B6    B6-Z=SYM 
          LX3    -WB.MODEP
          BX4    -X7*X3      EXTRACT MODE 
          LX3    WB.MODEP 
          BX6    X3-X5       CLEAR WB.VDS FOR POSSIBLE REMOVAL
          CLAS=  X1,WB,(COM,FP) 
          SX4    X4-M.INT 
          BX0    X1*X3
          CLAS=  X1,WB,(ARY,LAB)
          BX1    X1*X3
          NZ     X1,VDP1     IF ARRAY OR STATEMENT LABEL
          SBIT   X3,WB.VDSP 
          PL     X3,VDP1     IF NOT USED AS VARIABLE SUBSCRIPT OR ARRAY 
          ZR     X0,VDP2     IF NOT FORMAL PARAMETER OR IN COMMON 
          SA6    A3          REMOVE WB.VDS FOR THIS ENTRY 
          SBIT   X0,WB.FPP
          PL     X0,VDP2     IF NOT FORMAL PARAMETER
          SA1    T.FPI
          HX6    WB.FPNO
          AX6    -WB.FPNOL   EXTRACT FORMAL PARAMETER NUMBER
          SB2    X6-1 
          SA1    X1+B2       FETCH T.FPI ENTRY
          CLAS=  X6,FP,(VDS)
          BX6    X6+X1
          SA6    A1          UPDATE WITH FP.VDS 
 VDP2     ZR     X4,VDP1     IF TYPE INTEGER, OK
          MX1    WA.SYML
          =A4    A3-WB.W+WA.W 
          BX6    X1*X4
          SA6    FILL.
          FATAL  E.DM12 
          EQ     VDP1 
  
*         PROCESS T.VDI 
  
 VDP3     SA1    T=VDI
          SA2    T.VDI
          =B2    X1-1 
          MX0    VD.INDL
          LX0    VD.INDL+VD.INDP
 VDP4     SA1    X2+B2       FETCH T.VDI ENTRY
          BX6    -X0*X1      CLEAR VD.IND 
          SA6    A1 
          =B2    B2-1 
          MI     B2,EXIT.    IF DONE
          EQ     VDP4        CONTINUE LOOP
          SPACE  4,8
          LIST   D
          END 
