*DECK     DECL
          IDENT  DECL 
 DECL     SECT   (DECLARATIVE PHASE STATEMENTS.),1
  
          SST    A,B,D
          NOREF  A,B,D
  
 B=DECL   RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  CCT,DIR8,EQU3,EQS8,PCD,DIRX,DIR,LVL8 
  
*         IN FTN
          EXT    CO.SNAP
  
*         IN TABLES 
          EXT    ARGCOMA,ARGMODE,DECARM,REFVAR,STAGE,TA=NAM,TA.NAM
          EXT    TP.DIM,TP.EQU,TP=EQU,TS.BLK,TS=BLK,TS.EQU,TS=EQU,TS.SYM
          EXT    TS=SYM,TT=COMM,TT.COMM,TT=PAR,TS=CON,TS=CONB,VARDIM
  
*         IN ERRORS 
          EXT    CLASS,E.ANS,E.CM,E.CMA,E.CM1,E.CM2,E.CM3,E.CM4,E.CM5 
          EXT    E.CM6,E.DM,E.DM1,E.DM2,E.DM2A,E.DM3,E.DM4,E.DM5,E.DM5A 
          EXT    E.DM6,E.DM7,E.DM9,E.DM10,E.DM11,E.DM12,E.DM13,E.DM14 
          EXT    E.EQ 
          EXT    E.EQ1,E.EQ2,E.EQ3,E.EQ4,E.EQ5,E.EQ6,E.EQ11,E.EQ12,E.EX1
          EXT    E.EX2,E.EX3,E.EX4,E.MR2,E.TE5,E.TY,E.VD,E.XC1,E.ZA 
          EXT    E.EQ13,E.EQ14,E.EQ15,E.EQ16
          EXT    L.CL,FILL.,FILL.2,FILL.3 
  
*         IN HEADER 
          EXT    PSFA 
  
*         IN ALLOC
          EXT    ERT,ADW,ESY,NCM,SSY,SCD
  
*         IN MAIN 
          EXT    CPM=ASF,PCDX,PSP,WBL 
  
*         IN LEX
          EXT    DEC,STY,TRV
  
*         IN TYPE 
          EXT    TYPA 
  
*         IN PAR
          EXT    PAR
  
*         IN CONRED 
          EXT    LCT
  
*         IN GEN
          EXT    DIMI 
  
*         IN INIT 
          EXT    EQUA 
  
 CCT      SPACE  4,8
**        APT -  ASSIGN POINTER TAGS
* 
*         ENTRY- END OF DECLARATIVES HAS BEEN ENCOUNTERED 
* 
*         EXIT-  POINTER WORD TAGS GENERATED AND STORED IN BLOCK TABLE
*                ENTRIES FOR ECS/LCM COMMON BLOCKS.  POINTER WORDS
*                CONSTRUCTED AND STORED IN TP.APL.
  
  
 APT      SUBR   0
          SA1    TS.BLK 
          SA2    TS=BLK 
          AX2    1
          SB2    X2-1        B2 = NO. ENTRIES TO PROCESS
          =B3    2
          SA1    X1+1 
          MX0    -L.BLVL
  
 APT2     SA1    A1+B3       FETCH BLOCK TABLE ENTRY
          ZR     B2,APTX     IF NO MORE ENTRIES, EXIT.. 
          SB2    B2-B1
          LX1    -P.BLVL     RIGHT-JUSTIFY BLOCK LEVEL
          BX2    -X0*X1      X2 = BLOCK LEVEL 
          SX3    X2-3 
          ZR     X3,APT4     IF LEVEL 3 
  
 .76      IFEQ   .CPU,76
  
          SX3    X2-2 
          ZR     X3,APT4     IF LEVEL 2 
  
 .76      ENDIF 
  
          EQ     APT2        LOOP 
  
**        GENERATE AND SET POINTER TAG
  
 APT4     SA3    =XTG.PRO 
          =X6    X3+1        UPDATE PROGRAM TAG 
          SA6    A3 
          LX1    P.BLVL      RESTORE X1 
          LX6    P.CTAG 
          BX7    X1+X6       SET TAG INTO BLOCK TABLE ENTRY 
          SA7    A1 
  
**        CONSTRUCT POINTER WORD -- GET TAG OF FIRST NAME IN BLOCK AND
*         PLACE INTO AP-LIST WORD FORMAT WITH BIT *ALCM* ON.
*         TT.COMM HAS BEEN KEPT SO WE CAN FIND FIRST NAMES. 
  
          SA4    TS.BLK      X4 = FWA BLOCK TABLE 
          SB4    X4+B1
          SX4    A1-B4       X4 = BLOCK NUMBER
          LX4    P.BLOCK     ALIGN BLOCK NUMBER 
          MX7    L.BLOCK
          LX7    L.BLOCK+P.BLOCK   ALIGN BLOCK NUMBER MASK
          SA2    TT.COMM     X2 = FWA COMMON TAG TABLE
          SA3    TT=COMM
          SB4    X3          B4 = LENGTH OF COMMON TAG TABLE
          SA2    X2-1 
          =B5    0
  
 APT6     =A2    A2+1        FETCH TT.COMM ENTRY
          EQ     B5,B4,E.ZA  IF DID NOT FIND ANY NAME FOR BLOCK 
          =B5    B5+1 
          BX5    X7*X2       X5 = BLOCK NUMBER
          IX5    X5-X4
          NZ     X5,APT6     IF NOT CORRECT BLOCK, LOOP 
  
*         FIRST NAME IN BLOCK FOUND 
  
          MX7    L.TAG
          BX2    X7*X2       X2 = TAG ORDINAL OF FIRST NAME IN BLOCK
          SX7    C.VAR
          LX7    P.TAG
          IX2    X2+X7       X2 = TAG OF FIRST NAME IN BLOCK
          MX7    1
          LX7    P.ALCM+1 
          BX5    X6          POINTER TAG
          BX6    X2+X7       TURN ON *ALCM* BIT 
  
*         SAVE SOME REGISTERS 
  
          SX7    A1 
          SA7    APTA1       SAVE A1
          SX7    B2 
          SA7    APTB2       SAVE B2
          ADDWD  =XTP.APL 
          SX2    A6 
          IX2    X2-X1       X2 = ORDINAL OF TP.APL ENTRY JUST ADDED
          BX5    X5+X2       TAG + ORDINAL
          MX7    1
          BX6    X7+X5       ENTRY FOR *TA.PRO* 
          RJ     =XDPT       DEFINE PROGRAM TAG 
          SA1    APTB2
          SB2    X1          RESTORE B2 
          SA1    APTA1
          SA1    X1          RESTORE A1 
          =B3    2           RESTORE B3 
          MX0    -L.BLVL     RESTORE X0 
          EQ     APT2        LOOP 
  
 APTA1    BSS    1
 APTB2    BSS    1
  
**        CCT -  CHECK CONFLICTING TYPES. 
* 
*         POST AN ERROR IF ELEMENT IS GIVEN CONFLICTING TYPE. 
* 
*         ENTRY  (X6) = SYMBOL TABLE ENTRY TO BE CHECKED. 
*                (X2) = BIT POSITION OF NEW CLASS (P.XXX DEFINITION)
*                       (CAN ONLY BE ONE BIT AND NEVER BE EITHER -- 
*                            A.  NOT-VAR
*                       OR   B.  VAR
*                (X3) = MASK OF FORBIDDEN CLASSES.
* 
*                FILL.= SET TO ELEMENT CURRENTLY BEING CHECKED. 
* 
*         EXIT   IF NO ERROR X3 = ADDRESS OF TT.NAM ENTRY 
*                            X2 = ORDINAL OF TT.NAM ENTRY 
*                              ONLY A3 DESTROYED
*                IF CONFLICT:  X6 = 0 
*                              ONLY B4 PRESERVED
  
  
 CCT2     MX2    -L.PWF 
          LX6    -P.PWF 
          SA3    TS.SYM 
          BX2    -X2*X6      ISOLATE TAG ORDINAL
          IX3    X3+X2
          LX6    P.PWF       RESTORE X6 
  
 CCT      SUBR   0
          BX3    X3*X6
          ZR     X3,CCT2     IF NO CONFLICT 
          BX0    X3 
          CLAS=  X1,(VAR,FP,RP) 
          SB2    CLASS-P.CLASS2+47
          BX1    X1*X6
          SB2    B2+L.CL
          ZR     X1,CCT10    IF CURRENT ENTRY NOT VAR, FP OR RP 
          SB2    CLASS-P.CLASS+47 
 CCT10    NX3    B7,X3
          SB7    -B7
          SA1    B7+B2       *DPC* FOR CURRENT ENTRY
          BX6    X1 
          SB2    B2-47
          SA6    FILL.2 
          SA3    X2+B2       *DPC* FOR CAN NOT BE 
          BX6    X3 
          SA6    FILL.3 
          FATAL  E.VD 
          BX6    0           INDICATE ERROR 
          EQ     CCTX        EXIT.. 
 CMN      SPACE  4
**        CLU  - CHECK "LEVEL" USAGE
*         CHECKS THAT EACH LEVEL 2 OR LEVEL 3 NAME IS ASSIGNED TO 
*         COMMON OR IS A FORMAL PARAMETER.  CHECKS CONSISTENCY AND
*         COMPLETENESS OF LEVEL INFO FOR EACH COMMON BLOCK. 
  
  
 CLU      SUBR   0
          SA1    TA.NAM 
          SA2    TS=SYM 
          AX2    1
          SB5    X1          (B5) = FWA(TA.NAM) 
          SA3    TS.SYM 
          SB6    X2          (B6) = NO. OF TS.SYM WORDS TO EXAMINE
          =B3    2
          SA3    X3-1        (A3) = FWA(TS.SYM) - 1 
  
 CLU1     SA3    A3+B3       FETCH TAG  WORD
          SX0    M.LEV
          ZR     B6,CLU3     IF DONE, GO TO NEXT PHASE
          SB6    B6-B1
          BX2    X0*X3
          ZR     X3,CLU1     IF NULL ENTRY
          ZR     X2,CLU1     IF NOT LEVEL NAME
  
*         HERE IF ENTRY WITH LEVEL ON.  NOW CHECK IF LEVEL 2 OR 3.
  
          MX5    -L.LEVN
          BX4    X3 
          AX4    P.LEVN      RIGHT-JUSTIFY LEVEL NUMBER 
          BX4    -X5*X4      ISOLATE LEVEL NUMBER 
          SX4    X4-2 
          MI     X4,CLU1     IF LEVEL 1, FORGET IT
  
*         HERE IF LEVEL 2 OR 3.  CHECK IF *FP* OR *COMM* BIT SET. 
  
          SX5    M.FP+M.COMM
          BX4    X5*X3
          NZ     X4,CLU1     IF EITHER BIT SET, O.K.
  
*         NAME MAY BE IN COMMON EVEN IF *COMM* BIT OFF.  FULL CHECK 
*         IS  MADE ON BLOCK NO. IN TA.NAM ENTRY.
  
          MX5    L.PWF
          LX3    L.TGB
          BX4    X5*X3       ISOLATE ORDINAL
          LX4    L.PWF-1     RIGHT-JUSTIFY AND  HALVE 
          SB2    X4 
          SA1    B5+B2       FETCH ADDRESS TABLE ENTRY
          MX5    -L.BLOCK 
          AX1    P.BLOCK
          BX4    -X5*X1      ISOLATE BLOCK NUMBER 
          NZ     X4,CLU1     IF IN COMMON 
  
*         HERE IF ILLEGAL 
  
          SA4    A3-B1       FETCH SYMBOL 
          MX5    7*CHAR 
          BX6    X5*X4
          SA6    FILL.
          FATAL  =XE.LV6
          EQ     CLU1        CONTINUE CHECKING
  
*         SCAN TS.BLK TABLE, CHECKING FOR CONFLICT AND/OR DEFAULT 
  
 CLU3     SA3    TS.BLK 
          SA2    TS=BLK 
          SA3    X3+B1
          AX2    1
          =B3    2
          SB6    X2-1        (B6) = NO. OF TS.BLK WORDS TO EXAMINE
          SA4    =XBLNKCOM
          SB5    X4          BLANK COMMON BLOCK NUMBER
  
 CLU4     SA3    A3+B3       FETCH TS.BLK ENTRY 
          ZR     B6,CLUX     IF DONE, EXIT..
          SB6    B6-B1
          SBIT   X3,CNFL
          PL     X3,CLU6     IF NO CONFLICT 
  
*         LEVEL CONFLICT FOR THIS BLOCK 
  
          NE     B6,B5,CLU5  IF NOT BLANK COMMON
          SA4    BCOM 
          BX6    X4 
          EQ     CLU55
  
 CLU5     SA4    A3-B1       FETCH NAME 
          MX0    7*CHAR 
          BX6    X0*X4
 CLU55    SA6    FILL.
          FATAL  =XE.LV7
 CLU6     SBIT   X3,DFLT/CNFL 
          PL     X3,CLU4     IF NO NAMES DEFAULTED
  
*         NOT ALL NAMES IN BLOCK DECLARED LEVEL 
  
          NE     B6,B5,CLU7  IF NOT BLANK COMMON
          SA4    BCOM 
          BX6    X4 
          EQ     CLU75
  
 CLU7     SA4    A3-B1
          MX0    7*CHAR 
          BX6    X0*X4
 CLU75    SA6    FILL.
          NOTE   =XE.LV8
          EQ     CLU4 
  
 BCOM     DATA   0L// 
          SPACE 4,8 
**        CMN -  PROCESS "COMMON" STATEMENT.
*         CONSTRUCTS TS.COMM ENTRIES:  VFD 18/TAG,6/BLK.NR,18/,18/RELADD
*         (N.B.  *RELADD* IS LEFT ZERO FOR *MCA* TO FILL IN LATER)
*         EXIT   PROPER ENTRIES HAVE BEEN MADE IN 
*                TS.NAM, TT.NAM, TT.COMM, TS.BLK
*         CALLS  ADDWD, DIR, SCM, TRV.
*         USES   *TYPA* TEMP HOLDING OF CURN BLK NUMBER.
*         EXIT   TO MASTER LOOP.
  
          HEREIF COMMON 
  
          =X6    CR.DEC 
          SA6    REFVAR      SET REFERENCE TYPE 
  
          SA1    =XBLNKCOM
          SB7    X1          BLANK COMMON BLOCK NUMBER
          SA1    B4 
          SB2    X1-O.SLASH 
          ZR     X1,E.CM4    IF *EOS*, ERR..
          NZ     B2,CMN4H    IF NO SLASH
          SB4    B4+B1
          EQ     CMN3 
  
*         PROCESS VARIABLE LIST.
  
  
 CMN1     SA2    B4          FETCH NEXT ELEMENT 
          SA1    B4+B1
          BX6    X2 
          ZR     X2,E.CM6    IF PREMATURE *EOS* 
          SB7    X1-O.VAR 
          NZ     B7,CMN15    IF NOT LONG NAME 
          RJ     =XTLV       TRUNCATE NAME
          =A1    B4+1 
 CMN15    SX1    X1-O.( 
          SA6    FILL.       SAVE NAME FOR POSSIBLE ERROR MESSAGE 
          NZ     X1,CMN2     IF NO LPAREN 
          RJ     DIR
          SA5    TYPA        RETRIEVE BLOCK INDICATOR 
          ZR     X6,CMN2B    IF ERROR IN DIMS 
          EQ     CMN2A
  
 CMN2     RJ     TRV         TRANSLATE VARIABLE 
          NZ     X0,CMN2B    IF ERROR DETECTED
 CMN2A    SX2    P.COMM 
          CLAS=  X3,(FP,EXT,ENT,ASF,NLST,COMM)
          RJ     CCT         CHECK CONFLICTING CLASSES
          ZR     X6,CMN2B    IF USAGE CONFLICT
  
          SX4    M.COMM+M.DEF+M.VAR 
          LX2    P.TAG
          BX6    X4+X6
          SA6    X3          STORE MODIFIED ENTRY BACK INTO TT.NAM
          BX6    X2+X5       MERGE WITH BLOCK NUMBER
          ADDWD  TT.COMM     ADVANCE TABLE O
 CMN2B    SA1    B4+B1
          SB4    A1+B1       B4 = B4+2
          SX2    X1-O.COMMA 
          ZR     X2,CMN1     IF COMMA 
          ZR     X1,PSP      IF END OF STATEMENT
          SB2    X1-O.SLASH 
          NZ     B2,E.CM3    IF NO SLASH, ERR.. 
 CMN3     SA1    B4 
          ZR     X1,E.CM1    IF PREMATURE EOS 
          SB4    B4+B1
          SX6    X1-O.SLASH 
          NZ     X6,CMN5     IF NO SLASH
          SA3    =XBLNKCOM
          SB7    X3          BLANK COMMON BLOCK NUMBER
          EQ     CMN4H
  
*         PROCESS /BLOCK/ 
  
 CMN4     MX0    CHAR 
          LX0    -LG.VAR*CHAR+CHAR
          BX2    X6*X0
          ZR     X2,CMN4F    IF BLOCK NAME NOT SEVEN CHARACTERS 
          AX2    18 
          SB2    X2-1R+ 
          PL     B2,CMN4F    IF NOT BLANK COMMON
          SA6    FILL.
          SA2    A1          SAVE *A* 
          ANSI   =XE.ANS2 
          SA1    A2          RESTORE *A1* 
 CMN4F    SCAN   TS.BLK,SCD 
          PL     B7,CMN4H    IF ALREADY IN TABLE
 CMN4G    SA2    TS=BLK 
          BX5    X6 
          SX3    X2-MAX.BLK*2+1 
          PL     X3,E.CM2    IF TOO MANY BLOCKS 
          ALLOC  A1,2 
          SB7    X2-2        ORDINAL
          BX7    X5 
          MX6    0
          SA7    X1+B7
          SA6    A7+B1
          SA5    =7L
          IX5    X5-X7
          NZ     X5,CMN4I    IF NOT BLANK COMMON
          SX6    B7 
          SA6    =XBLNKCOM   BLANK COMMON BLOCK NUMBER INDICATOR
          EQ     CMN4I
 CMN4H    NZ     B7,CMN4I    IF BLANK COMMON ALREADY PRESENT
          SA1    TS.BLK 
          SA2    =7L
          BX6    X2 
          EQ     CMN4G
 CMN4I    SX6    B7 
          LX6    P.BLOCK
          BX5    X6 
          SA6    TYPA        SAVE BLOCK INDICATOR 
          EQ     CMN1 
  
 CMN5     SA3    B4 
          SB7    X1-O.CONS
          ZR     B7,CMN5B    IF BLOCK NAME IS NUMBER
          SB7    X1-O.VAR 
          NZ     B7,E.CM5    ILLEGAL BLOCK NAME 
          SB7    X3-O.VAR 
          NZ     B7,CMN5C    IF NOT LONG NAME 
          =B4    B4-1 
          RJ     =XTLV       TRUNCATE NAME
          =B4    B4+1 
          =A3    B4 
          EQ     CMN5C
          SPACE  2
 CMN5B    BX2    X1          SAVE (X1)
          ANSI   E.CMA       BLOCK NUMBER NON-ANSI
          LX1    X2          RESTORE (X1) 
 CMN5C    SX2    X1 
          BX6    X1-X2
          SB7    X3-O.SLASH 
          NZ     B7,E.CM     IF NO SLASH
          =B4    B4+1 
          EQ     CMN4 
          SPACE  2
 DIM      SPACE  4,8
**        DIM -  PROCESS "DIMENSION" DECLARATION. 
*         EXIT   TO MASTER LOOP.
*         CALLS  DIR      (FOR EVERY ARRAY IN STATEMENT.) 
  
  
          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,PSP      IF *EOS*, RETURN TO MASTER LOOP
          SA2    X1+=XCHARMAP 
          MX0    L.CDPC 
          NZ     X2,DIM2     IF NOT VAR OR CONS 
          LX2    X1 
 DIM2     BX6    X0*X2
          SA6    FILL.
          EQ     E.TY 
 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) = SYMBOL TAG ENTRY. 
*                            (= ZERO IF ERROR.) 
*                DIMENSIONING INFORMATION ENTERED INTO TP.DIM AND 
*                            POINTER ENTERED INTO *P.PNT*.
*         CALLS  DIS, TRV.
*         USES   ALL REGISTERS. 
*                *APLIST* FOR TEMP HOLDING OF DIM DESCRIPTORS.
  
  
**        HERE WHEN A SYNTAX ERROR IS FOUND -- SEARCHES FOR NEXT *)* IN 
*                ATTEMPT TO RECOVER SO THAT REST OF STATEMENT MAY BE
*                PROCESSED. 
  
 DIR7     SB4      B4+B1
 DIR8     SA1      B4 
          ZR     X1,E.DM10   IF *EOS* -- ERROR
          SX1    X1-O.) 
          NZ     X1,DIR7     ADVANCE TO NEXT RIGHT PAREN
          BX5    0           INDICATE ERROR 
  
*         EXIT - SHRINK CONSTANT TABLE BACK TO WHAT IT WAS BEFORE THIS
*         STATEMENT.
  
 DIRX     SA2    TS=CONB
          SHRINK TS=CON,X2
          BX6    X5 
  
 DIR      SUBR   Z           ENTRY/EXIT...
          SA4    B4 
          ZR     X4,E.EX3    IF *EOS* 
          BX6    X4 
          RJ     TRV         TRANSLATE VARIABLE 
          NZ     X0,DIR8     IF ERROR DETECTED
          =X3    M.ARY
          BX2    X3*X6
          ZR     X2,DIR2     IF NOT ALREADY AN ARRAY
          WARN   E.DM9       PREVIOUS DIMENSION HOLDS 
 DIR2     CLAS=  X3,(NVAR,ENT,EXT)
          SX2    P.ARY
          RJ     CCT         CHECK CONFLICTING CLASSES
          ZR     X6,DIR8     IF ERROR DETECTED. 
          SA5    X3          TAG
          LX7    X2 
          SX3    M.ARY+M.VAR
          BX5    X6+X3       SET ARRAY BIT
          LX6    X5 
          SA7    DIRT        SAVE TAG ORDINAL 
          SA6    A5 
  
**        PROCESS DIMENSION ARGUMENTS 
  
          SA1    B4+B1       FETCH SEPARATOR
          ZR     X1,E.DM5A   IF *EOS* 
          SX2    X1-O.COMMA 
          SX6    X1-O.(+O.COMMA 
          SB3    X1-O.( 
          ZR     X2,E.DM5A   IF COMMA 
          NZ     B3,E.DM     IF NOT LEFT PAREN
          SB3    DIMI        SAVE POSITION FOR 1ST DIMENSION
          SB5    DIMI+MAX.DIM 
          SA6    A1          FAKE UP A COMMA FOR *DIS*
          BX5    0
          EQ     DIS
  
  
**        HERE IS RETURN FROM *DIS*.
  
 DIR3     SB6    DIMI 
          BX6    0
          SX0    B3-B6
          EQ     B3,B6,E.DM5       IF NO DIMENSIONS 
          LX0    P.NDIM 
          SA6    B3          CLEAR EXTRA CELL IN CASE ODD NR OF DIMS
          SA3    DIRT 
          SA1    TS.SYM 
          IX2    X1+X3
          BX6    X5 
          SA5    X2          RE-FETCH TAG TABLE ENTRY 
          ZR     X6,DIR4     IF NO VARIABLE DIMENSIONS
  
  
**        HANDLE VARIABLE DIMENSIONS HERE.
  
          =X3    1
          BX2    X5 
          LX3    P.VDIM 
          =X6    1
          SA6    VARDIM      INDICATE VARIABLE DIMENSIONS APPEARED
          IFBIT  X2,FP,DIR31 IF FORMAL PARAMETER
          SA3    DIRT 
          SA1    TS.SYM 
          IX2    X1+X3
          =A2    X2-1        ARRAY NAME 
          MX0    L.SYM
          BX6    X0*X2
          SA6    FILL.
          EQ     E.DM3
  
 DIR31    BX0    X3+X0
          =X7    1           OFFSET OF 1 FOR VAR DIM ARRAY
          EQ     DIR6        CONTINUE.. TO ENTER TABLE
  
  
**        CONSTANT DIMENSIONS -- COMPUTE DIMOS AND LENGTH.
* 
*         DIMOS  =  SIGMA [1@J@N, PI (0@K@J-1, DIM(K)) ]
  
 DIR4     SA1    B6 
          =X3    1
          SB5    B6+B1
          =X4    1
  
 DIR42    IX3    X3*X1       X3 = PI (DIM(K), 0@K@J-1)
          GE     B5,B3,DIR46       [ 1 @ J \ N ]
          SA1    B5 
          SB5    B5+B1
          IX4    X4+X3       X4 = SIGMA( (X3) , J)
          EQ     DIR42
  
 DIR46    SX1    1S17-1 
          IX1    X1-X3
          MI     X1,=XE.DM8  IF LENGTH > 2**17-1
          LX3    P.DIMLG
          BX7    X4+X3
  
  
**        PACK DIM INFO INTO FINAL FORM.
*                (X0) = NDIM + VDIM FLAGS.
*                (X7) = (LEN/OFFSET WORD) 
*                (B6) = FWA DESCRIPTORS.
*                (B3) = LWA+1 DESCRIPTORS.
  
 DIR6     MX1    -L.PNT 
          BX6    X5 
          LX6    -P.PNT 
          BX1    -X1*X6 
          NZ     X1,DIRX     IF PRIOR DIMENSION ENTERED 
  
          SA2    B6 
          BX6    X7+X0
          IX1    X1-X1
          SA6    B6          STORE HEADER WORD
  
 DIR65    LX2    P.DIM
          SB5    A2+B1
          BX6    X1+X2
          SA1    A2+B1
          SA2    B5+B1
          SA6    A6+B1
          LT     B5,B3,DIR65
  
 DIR67    SB3    A6+B1       LWA+1 OF THIS ENTRY
          SB2    B6          FWA   OF THIS ENTRY
          SCAN   TP.DIM,NCM 
          SA1    TS.SYM      IN CASE TABLES MOVED 
          SA2    DIRT 
          IX3    X1+X2
          LX6    P.PNT
          BX6    X5+X6
          SA6    X3          INSERT DIM TABLE POINTER 
          LX5    X6 
          EQ     DIRX        EXIT.. 
  
 DIRT     BSS    1           TEMP HOLDING OF TAG ORDINAL
 DIS      SPACE  4,15 
**        DIS -  ASSEMBLE DIMENSION SUBSCRIPT.
*         CO-ROUTINE WITH *DIR*.  ASSEMBLES DIMENSIONALITY DESCRIPTORS
*                INTO A SAVE BUFFER.
*         ENTRY  (B4)+1 _ SUBSCRIPT ENTRY.
*                (B3) _ FWA OF SAVE AREA. 
*                (B5) _ LWA SAVE BUFFER.
*                (X5) = 0.
*         EXIT   TO *DIR3* -- 
*                (B3) _ LWA+1 OF STORED DESCRIPTORS.
*                (B4) _ RPAREN OR *EOS* THAT CAUSED *DIS* TO QUIT.
*                (X5) = 0 -- NO VAR-DIMS. 
*                     = M.CDIM -- IF VARDIMS HAPPENED.
*         MOST ERRORS EXIT TO *DIR8*. 
*         USES   ALL EXCEPT A0,A5  B5,B6
*         CALLS  DEC, TRV, WARN.
  
  
**        HERE WHEN DESCRIPTOR IS VARIABLE NAME.
  
 DIS6     RJ     TRV         TRANSLATE VARIABLE 
          MX0    1
          LX0    P.FPS+1
          SX4    M.VAR
          SA2    TS.SYM 
          BX6    X6+X0       SET FLAG FOR DEFERRED TYPE CHECK 
          BX6    X6+X4       VARIABLE DIMENSION MUST BE VARIABLE
          SA6    X2+B7
          SBIT   X6,FP
          =X4    1
          SX2    B7 
          LX4    P.TDIM 
          PL     X6,DIS5     IF NOT A DUMMY-ARG, ERR..
          MX5    1           INDICATE VARIABLE DIMS OCCURRED
          LX5    P.CDIM+1 
          IX6    X4+X2       SET VAR-DIM BIT AND CLEAR TAG TYPE 
          MX3    0           SKIP TYPE CHECK
  
  
**        ADD DESCRIPTOR TO SAVE BUFFER --
*                (X1) = TYPE. 
*                (X6) = DESCRIPTOR -- 36/0, 1/VAR, 23/(TAG OR NUMBER) 
  
 DIS8     SA6    B3          SAVE DESCRIPTOR WORD 
          LT     B3,B5,DIS9  IF NO OVERFLOW OF SAVE AREA
          SB3    B3-B1
          FATAL  E.DM6
 DIS9     =X6    0
          SB3    B3+B1
          NZ     X3,E.DM1    IF NOT TYPE INTEGER, ERR.. 
  
  
**        INITIAL ENTRY IS HERE.
*                (B4)+1 _ COMMA OR RPAREN.
  
 DIS      SA1    B4+B1       FETCH NEXT SEPARATOR 
          SB4    B4+B1
          SX2    X1-O.) 
          ZR     X1,E.MR2    IF *EOS*, ERR..
          SB2    X1-O.COMMA 
          ZR     X2,DIR3     IF RPAREN, EXIT..
          ZR     B2,DIS2     IF COMMA 
          SA2    X1+=XCHARMAP 
          NZ     X2,DIS1     IF NOT VAR OR CONS 
          LX2    X1 
 DIS1     MX0    L.CDPC 
          BX6    X0*X2
          SA6    FILL.
          FATAL  E.EX2
          EQ     DIR8        EXIT.. TO ATTEMPT RECOVERY 
  
 DIS2     SA2    B4+B1
          SX6    X2 
          ZR     X2,E.DM     IF *EOS* - ERROR 
          SB2    X2-O.VAR 
          BX6    X2-X6
          SB4    B4+B1
          SA6    FILL.2      SAVE VAR NAM FOR POSSIBLE ERROR MESSAGE
          SB7    X2-O.CONS
          ZR     B2,DIS6     IF ALPHA 
          =X0    B7+O.CONS-O.HOLL 
          SB2    X2-O.) 
          ZR     X0,DIS2A    IF HOLLERITH CONSTANT
          ZR     B2,E.DM2A   IF *)* 
          EQ     DIS3        PROCESS WHATEVER...
  
**        DIMENSION CONSTANT IS HOLLERITH, OUTPUT ANSI ERROR AND
*         CONTINUE TO PROCESS AS A LEGAL DIMENSIONALITY.
  
 DIS2A    ANSI   E.DM12 
  
**        HERE WHEN DESCRIPTOR IS A NUMBER. 
  
 DIS3     BSS    0
          RJ     EAX         EVALUATE ABSOLUTE EXPRESSION 
          ZR     B7,DIS8     IF ERROR IN CONSTANT 
          SX3    X1-M.INT 
          BX2    X6 
          NZ     X1,DIS4     IF NOT UNIVERSAL TYPE
          MX3    0
 DIS4     AX2    17 
          ZR     X6,E.DM2    IF NO CONSTANT - ERROR 
          BX6    X5+X6       MERGE *PREVIOUS VAR-DIM* BIT 
          ZR     X2,DIS8     IF NUMBER IS @ 2**17-1 
          NZ     X3,E.DM1    IF NOT TYPE INTEGER
          EQ     E.DM7
  
**        ERROR IN DIM INDICATOR. 
*                OUTPUT ERROR MESSAGE AND THEN PRETEND IT WAS AN
*         O.K. DIMENSION OF ONE.
  
 DIS5     FATAL  E.DM4
          MX3    0
          =X6    1
          EQ     DIS8        CONTINUE.. 
  
 A        DECMIC P.TDIM 
 A        DECMIC 1S"A"-C.VAR
 DISA     LIT    "A"
 EQS      SPACE  4,8
          SPACE  4,20 
* 
*        UNPACK AND PACK MACROS PARIALLY SIMULATE THE PACK AND UNPACK 
*        OPERATION CODES. EXCEPTIONS:  NO SIGN EXTENSION WHEN 
*        USING THE UNPACK MACRO. THE ENTIRE  EXPONENT FIELD IS USED 
*        TO STORE VALUES. 
* 
*        UNPK    XN,BN,WXR,MR 
*        PACK    XN,BN,WXR,MR 
* 
*        XN - THE DESTINATION REGISTER AND MUST CONTAIN THE PACKED
*             FIELD OR THE COEFICIENT FIELD 
*        BN - THE EXPONENT FIELD , SELECTING B0 RESULTS IN THE
*             ELIMINATION OF ALL INSTUCTIONS ASSOCIATED WITH THE
*             BN AND WXR REGISTERS. 
*       WXR - SCRATCH REGISTER , IF BO IS SELECTED FOR THE B REGISTER 
*             THIS REGISTER CAN BE SET TO VALUE SELECTED FOR
*             MR REGISTER.
*        MR - MASK REGISTER 
* 
* 
 UNPK     MACRO  XN,BN,WXR,MR 
          M_MR   12 
          IFNE   BN,B0,1
          B_WXR  MR*XN
          B_XN   -MR*XN 
          IFNE   BN,B0,2
          L_WXR  12 
          S_BN   WXR
          ENDM
 PACK     MACRO  XN,BN,WXR,MR 
          IFNE   BN,B0,4
          M_MR   48 
          S_WXR  BN 
          B_WXR  -MR*WXR
          L_WXR  48 
          M_MR   12 
          B_XN   -MR*XN 
          IFNE   BN,B0,1
          B_XN   WXR+XN 
          ENDM
* 
* 
**        EQS -  PROCESS "EQUIVALENCE" DECLARATION. 
* 
*         PERFORMS SYNTAX CHECKING OF THE STATEMENT, AND TRANSLATES THE 
*                EQUIVALENCES INTO TS.EQU TO AWAIT THE CLOSE OF 
*                DECLARATIVES.
* 
*         EXIT   TO MASTER LOOP.
  
  
          HEREIF EQUIVALENCE
  
          =X6    CR.DEC 
          SA6    REFVAR      SET REFERENCE TYPE 
          SB4    B4-B1
  
**        BEGIN NEW EQUIVALENCE GROUP.
*                (B4) _ LPAREN IN FRONT OF GROUP. 
  
 EQS2     SA1    B4+B1
          SB4    B4+B1       ADVANCE B4 TO 1ST SYMBOL 
          ZR     X1,=XE.MR3  IF *EOS* - ERROR 
          SB7    X1-O.( 
          =B6    1
          NZ     B7,E.EQ1    IF NO *(* - ERROR
  
  
**        NOW PROCESS A NAME. 
*                (B4) _ SYMBOL
  
 EQS3     SA1    B4+B1
          SB4    B4+B1
          BX6    X1 
          SA6    FILL.       SAVE NAME FOR (POSSIBLE) ERROR MESSAGE 
          RJ     TRV         TRANSLATE VARIABLE 
          CLAS=  X3,(FP,ENT,ASF,EXT,NLST) 
          SX2    P.EQUIV
          RJ     CCT         CHECK FOR CONFLICTING CLASS
          ZR     X6,EQS8     IF CONFLICT
          BX6    X2 
          PACK   X6,B6,X2,X3   MERGE GROUP-FLAG W/ TAG ORDINAL
          ADDWD  TS.EQU      1ST WORD TO TABLE
          SA4    B4+B1
          SB4    B4+B1       ADVANCE B4 
          SB6    B6+B1       INDICATE NO ROOT 
          =B3    0           CLEAR SUBSCRIPT COUNT
          =B7    X4-O.LP
          ZR     B7,EQS5     IF *(* 
          SA2    =XTRVA      *ST* ENTRY 
          IFBIT  X2,-ARY,EQS4 IF NOT ARRAY
          ANSI   =XE.TE4
 EQS4     BX2    0
          BX6    X2 
          PACK   X6,B0,X3,X3
          ADDWD  TS.EQU      FAKE SUBSCRIPT OF ZERO 
          EQ     EQS6 
  
  
**        PROCESS SUBSCRIPT.  (IF ANY)
  
 EQS5     SA1    B4+B1
          SB4    B4+B1       ADVANCE B4 
          SB7    X1-O.CONS
          NZ     B7,E.EQ5    IF NO NUMBER 
          RJ     DEC         CONVERT DECIMAL NUMBER 
          ZR     X6,E.EQ5    IF ZERO SUBSCRIPT - ERROR
          ZR     X1,EQS5B    IF MODELESS, OK..
          SB7    X1-M.INT 
          NZ     B7,E.EQ5    IF NOT INTEGER MODE - ERROR
 EQS5B    BX4    X6 
          AX4    17 
          NZ     X4,E.EQ2    IF SUBSCRIPT TOO BIG -- ERR
          =B3    B3+1        COUNT UP SUBSCRIPTS
          PACK   X6,B0,X3,X3
          ADDWD  TS.EQU      ADD SUBSC TO TABLE 
          SA1    B4+B1
          SB4    B4+B1       ADVANCE B4 
          SX3    B3-MAX.DIM-1 
          SX2    X1-O.COMMA 
          SB7    X1-O.) 
          PL     X3,E.EQ4    IF TOO MANY SUBSCRIPTS 
          ZR     X2,EQS5     IF COMMA, MORE SUBSCRIPTS
          NZ     B7,E.EQ3    IF NO RPAREN, ERROR
  
          SA4    B4+B1
          SB4    B4+B1
  
  
**        END OF EQUIVALENCE ITEM.
*                (X4) = NEXT *SB* ENTRY.
*                (B4) _ COMMA, AFTER THE SYMBOL, OR 
*                       RPAREN, TERMINATING THE GROUP.
  
 EQS6     SB7    X4-O.COMMA 
          SX3    X4-O.) 
          ZR     B7,EQS3     IF COMMA, GET MORE NAMES 
          NZ     X3,E.EQ     IF NO *)* - ERROR
  
  
**        CLOSE OUT AN EQUIVALENCE GROUP. 
*                CHECK FOR TRIVAL GROUP.
*                SYNTAX CHECK FOR COMMA OR *EOS*. 
  
          =B7    2
          =A4    B4+1 
          GT     B6,B7,EQS7D IF MORE THAN ONE MEMBER IN GROUP 
          WARN   E.EQ6       TRIVIAL GROUP - WARNING
 EQS7D    SB4    B4+B1       ADVANCE B4 
          SB7    X4-O.COMMA 
          ZR     B7,EQS2     IF COMMA 
          NZ     X4,E.XC1    IF NO *EOS* -- ERROR 
          EQ     PSP         EXIT.. 
  
  
**        RETURN TO HERE WHEN AN ERROR IS FOUND.
*                SEARCH FOR AN LPAREN IN ATTEMPT TO RECOVER FROM THE
*                ERROR, AND RESUME SYNTAX CHECKING. 
  
 EQS8     SA1    B4+B1
          SB4    B4+B1
          ZR     X1,PSP      IF *EOS* 
          LX1    CHAR 
          SX1    X1-O.( 
          NZ     X1,EQS8     IF NO LPAREN 
          SB4    B4-B1
          EQ     EQS2        TRY FOR MORE 
  
 EQSA     CON    1.0P0-2
 EQU      SPACE  4,8
**        EQU -  PROCESS EQUIVALENCES.
* 
*         ENTRY  (TS.EQU) CONTAINS TRANSLATED EQUIVALENCE STATEMENTS. 
*                END OF DECLARATIVES HAS BEEN ENCOUNTERED.
*                ADDRESS TABLE HAS BEEN CREATED, AND COMMON VARIABLES 
*                            DEFINED. 
*         EXIT   EQUIVALENCE ADDRESSES ASSIGNED.
*                (EQUA) = LOCAL EQUIVALENCE LENGTH
  
  
 EQU      SUBR   0
          SA2    TS=EQU 
          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  (TS.EQU) 
 EQUS0    BSS    0
 SNAP=D   ENDIF 
  
  
**        PHASE (0) OF EQUIVALENCE DIGESTION. 
*         A.     COPY (TA.NAM) ENTRY. 
*         B.     SAVE ARRAY LENGTH (FROM TP.DIM). 
*         C.     REDUCE SUBSCRIPTS TO A SINGLE OFFSET (IN WORDS). 
*         D.     COLLAPSE TABLE TO 2-WORD ENTRIES.
  
          MX6    -1 
          ADDWD  TS.EQU      MARK END OF TABLE
          SA5    TP.DIM 
          SA4    TA.NAM 
          SA3    TS.SYM 
          MX0    -L.DIMLG 
          SB4    X1          (B4) = FWA EQUIV SOURCE TABLE
          SB3    X5          (B3) = FWA DIMENSION PARAMETERS
          SB6    X4          (B6) = FWA ADDRESS/BLOCK TABLE 
          SA5    X1          (A5) _ CURRENT FETCH (FROM TS.EQU) 
          SB2    X3          (B2) = FWA SYMBOL/TAG TABLE
          =A7    A5-1        DUMMY STORE
          EQ     EQU22       BEGIN LOOP.. 
  
 EQU20    UX2    X6 
          BX7    X7+X2
          =A7    A0+1 
  
 EQU22    MI     X5,EQU28    IF TABLE EXHAUSTED 
          MX1    2
          BX5    -X1*X5 
          SA1    X5+B2       FETCH TAG ENTRY
          SX6    M.ARY       SET EQUDIM TO NON ZERO IF VARIABLE HAS BEEN
          BX6    X6*X1       DIMENSIONED
          SA6    EQUDIM 
          =A2    A1-1        PUT CURRENT VARIABLE NAME IN FILL. 
          BX6    X2 
          SA6    FILL.       STORE VARIABLE NAME
          LX1    -P.PNT 
          MX3    -L.PNT 
          BX2    -X3*X1      ISOLATE TP.DIM ORDINAL 
          SA2    X2+B3       FETCH DIM LENGTH WORD
          SBIT   X1,LONG/PNT-1
          BX7    X0*X2       ISOLATE ARRAY SIZE 
          AX1    -1 
          BX6    X1*X7
          IX7    X7+X6       DOUBLE SIZE IF *LONG*
          SA3    A2+B1
          AX2    P.NDIM      = NUMBER OF DIMENSIONS 
          BX6    X5 
          UNPK   X6,B7,X5,X0
          AX7    P.DIMLG-P.EQHI 
          PACK   X7,B7,X5,X0  MERGE ROOT-FLAG W/ LENGTH (IN EGHI FIELD) 
          MX0    -L.DIMLG 
  
  
**        COMPUTE EFFECTIVE SUBSCRIPT --
*         ENTRY  (X6) = TAG ORDINAL 
*                (X2) = NUMBER OF DIMS                 (I)
*                (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))-1 
*         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**((P.LONG))
  
          SB5    X2          B5 # N     (NUMBER OF DIMS)
          AX6    1
          SA2    X6+B6       FETCH (TA.NAM) 
          BX6    X2 
          =A6    A7+1        1ST WORD OF XFORMED TABLE (TA.NAM) 
          SA0    A6 
          SA2    =1.P0       X2 # PI   = 1
          BX1    X1*X2
          AX3    P.DIM
          BX6    0           SIGMA = 0
          FX2    X1+X2
  
 EQU25    =A5    A5+1 
          MX4    12           UX1  B7,X5
          BX1    X4*X5
          LX1    12 
          SB7    X1 
          BX1    -X4*X5 
          PX5    X5,B7
          NZ     B7,EQU29    IF NO MORE SUBSCRIPTS
          BX4    X6 
          BX6    X1 
          SA6    EQUDIM+1 
          BX6    X4 
          ZR     X1,EQU26    IF NOT SUBSCRIPTED 
          =X1    1           SUBTRACT BIAS OF ONE 
          IX5    X5-X1
          SA1    EQUDIM 
          NZ     X1,EQU26    IF DIMENSIONED 
          SX5    A0          SAVE A0
          FATAL  E.EQ13      SUBSCRIPT ON NON DIMENSIONED VARIABLE
          SA0    X5 
          BX6    X6-X6
          EQ     EQU27       SKIP REST OF SUBSCRIPTS
  
 EQU26    BSS    0
          DX1    X5*X2       R1 = (S(I)-1)*PI 
          BX4    -X0*X3      ISOLATE DIM   = D(I) 
          =B5    B5-1        I = I-1
          PX4 
          FX6    X6+X1       SIGMA = SIGMA+R1 
          DX2    X2*X4       PI = PI*D(I) 
          AX3    P.DIM
          MI     B5,EQU27    IF NO MORE DIMS
          NZ     X3,EQU25 
          =A3    A3+1        FETCH NEXT DIM PAIR
          EQ     EQU25
  
 EQU27    =A5    A5+1        PASS OVER EXCESS SUBS
          BX1    X5 
          UNPK   X1,B7,X2,X4
          ZR     B7,EQU27    IF LAST SUB NOT YET FOUND
 EQU.XS   REG 
          SX2    A0          SAVE A0
          WARN   E.EQ14      EXCESS SUBSCRIPTS IGNORED
          SA0    X2 
          MX0    -L.DIMLG    RESTORE X0 FROM WARN MACRO 
          EQ     EQU20
  
 EQU29    ZR     B5,EQU20    IF NO MORE DIMENSIONS
          SA1    EQUDIM+1 
          ZR     X1,EQU20    IF NO SUBSCRIPT ON EQUIVALENCE 
          SX2    A0          SAVE A0
          WARN   E.EQ15      MISSING SUBSCRIPTS SET TO ONE
          SA0    X2 
          MX0    -L.DIMLG    RESTORE X0 FROM WARN MACRO 
          EQ     EQU20
  
 EQUDIM   BSS    2
  
  
**        PHASE 2 -- PASS 1 OF GALLER / FISHER EQUIVALENCE ALGORITHM. 
*         A.     MARK NEW END-OF-TABLE, AND RE-SET LENGTH.
*         B.     BEGIN. 
  
 EQU28    MX7    -1 
          =A7    A7+1        MARK END OF TABLE
          SB7    A7-B4
          SHRINK TS=EQU,B7+1 RESULTANT LENGTH OF TABLE
          SA0    B4          (A0) = FWA EQUIVALENCE STATEMENTS
          =B2    2
          =B5                (B5) = 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,EQUS3    IF DECLARATIVE SNAP NOT SELECTED 
 EQU.3    DUMPT  (TS.EQU) 
 EQUS3    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. 
  
 EQU3     =A5    B4+A0
          SA4    TS.SYM 
          SB3    X4          FWA OF SYMBOL TABLE
          LX5    -P.TAG 
          MX0    L.SYM
          SB3    X5+B3
          SA4    B3-B1
          BX6    X0*X4
          SA6    FILL.       PLACE IN FILL. 
          LX5    P.TAG
          MX0    -L.EQUB
          MI     X5,EQU5     IF END OF EQUIV. INPUT 
          =A4    A5+1 
          SB3    -B2
          UNPK   X4,B6,X3,X2   (B6) = ROOT FLAG OF CURRENT
          SB4    B4+B2
  
 EQU32    SB3    B3+B2
          SA3    B3+A0
          GE     B3,B5,EQU38 IF END OF G/F TABLE
          BX2    X3-X5
          AX2    P.TAG
          NZ     X2,EQU32    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.
  
 EQU36    =A2    A3+1 
          UNPK   X2,B7,X5,X6   EXTRACT ROOT FLAG
          EQ     B7,B3,EQU4  IF THIS IS A ROOT
          LX3    -L.RELADD
          SB3    B7 
          AX3    -L.RELADD   EXTEND SIGN
          IX4    X3+X4
          SA3    B7+A0
          EQ     EQU36
  
**        CURRENT TAG NOT YET IN G/F TABLE.  CREATE AN ENTRY FOR IT.
  
 EQU38    BX3    X0*X4       LENGTH 
          SB5    B5+B2       INCREMENT LENGTH OF G/F TABLE. 
          LX6    X5 
          BX7    X3 
          PACK   X7,B3,X2,X5   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.
  
 EQU4     NE     B6,B1,EQU42 IF NOT A NEW GROUP 
          BX6    X4 
          PACK   X6,B3,X4,X5
          SA6    EQUA 
          EQ     EQU3 
  
**        WHEN IT DOES NOT BEGIN A GROUP, LINK IT INTO THE G/F TABLE. 
*                (B3) # T    G/F TABLE ORDINAL
*                (X4) # D    SUBSCRIPT
  
 EQU42    SA2    EQUA 
          BX3    X2 
          UNPK   X3,B6,X5,X2   B6 = TO
          SX3    X3 
,                            X3 = D0
          IX5    X3-X4       X5 = DIST = D0 - Y 
          GT     B3,B6,EQU44 IF CURRENT OCCURS LATER THAN THIS ROOT 
          EQ     B3,B6,EQU81 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 
          BX6    X4 
          PACK   X6,B7,X3,X4   DO = Y 
          SA6    A2 
  
**        BEFORE ADDING TO THE TREE, CHECK FOR CONSISTENCY. 
*         NOTE   R(T) = ( BLOCK(T), RELADD(T) ) 
  
 EQU44    SA3    B3+A0
          MX4    L.TAG
          BX1    -X4*X3      R(T) 
          SA2    B6+A0       B6 = (T0)
          BX6    -X4*X2      X6= R(T0)
          NZ     X1,EQU46    IF ELEMENT HAS AN ADDRESS
          NZ     X6,EQU86    IF ITS ROOT HAD AN ADDRESS 
          EQ     EQU48
  
**        CURRENT ELEMENT HAS AN ADDRESS -- CHECK ITS ROOT. 
  
 EQU46    NZ     X6,EQU84    IF ITS ROOT HAD AN ADDRESS 
  
**        ROOT HAS NO ADDRESS.
*                SET R(T0) = R(T) - DIST
  
          MX0    -L.RELADD
          BX6    X0*X1       X6 = BLOCK (T) 
          LX1    -L.RELADD
          AX1    -L.RELADD   EXTEND SIGN
          IX7    X1-X5       = R(T) - DIST
          MI     X7,EQU87    IF RA(T) - DIST <0 
          SA1    A2+1        T0 
          LX1    -L.RELADD
          AX1    -L.RELADD
          IX1    X7-X1       X1 = D-LOTO
          MI     X1,EQU88    IF RA(T0) < 0
  
 EQU47    BX1    -X0*X7      CLEAR SIGN EXTENSION 
          IX7    X2+X6
          BX6    X7+X1
          SA6    A2          RESET R(T0) = R(T) + DIST
  
  
**        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) 
*                (X4) = MX4 L.TAG 
*                (X5) = DIST
*                (A2) _ T0
*                (A3) _ T 
  
 EQU48    BX1    X4*X3       ISOLATE TAG
          =A3    A3+1        = T  (S, HI, LO) 
          MX4    -L.EQLO
          =A2    A2+1        = T0 (S, HI, LO) 
          BX0    -X4*X5 
          SB7    60-L.EQLO
          BX7    X3 
          PACK   X7,B6,X4,X6   LINK(T) = TO 
          IX6    X0+X1         R(T) = DIST
          =A6    A3-1        RESET T (TAG, BLOCK, R)
  
          LX3    -L.EQLO     POSITION SIGN BITS OF (EQLO) FIELDS
          LX2    -L.EQLO
          SA7    A3          RESET T (LINK, HI, LO) 
          AX0    X3,B7
          IX1    X0-X5       = LO(T) - DIST 
          AX7    X2,B7
          MX6    X7+X1       X6 = MAX ( LO(T0), LO(T)-DIST )
  
          LX3    -L.EQHI     POSITION SIGN BITS OF (EQHI) FIELDS
          IFNE   TEST,,1     (X6) SHOULD NEVER BE NEGATIVE
          MI     X6,EQU99S
          LX2    -L.EQHI
          AX3    B7 
          IX0    X3+X5       = HI(T) + DIST 
          AX7    X2,B7
          BX1    X6 
          PACK   X1,B6,X3,X5
          MX3    X7+X0       X3 = MAX ( HI(T0), HI(T)+DIST )
          IFNE   TEST,,1     (X3) SHOULD NEVER BE NEGATIVE
          MI     X3,EQU99S
          LX3    P.EQHI 
  
          BX7    X1+X3
          SA7    A2          RESET  (T) (S, HI, LO) 
          EQ     EQU3 
  
 EQU5     BSS    0
          SHRINK TS=EQU,B5
  
 SNAP=D   IFNE   TEST        DUMP EQUIV. TABLE
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQUS5    IF DECLARATIVE SNAP NOT SELECTED 
 EQU.5    DUMPT  (TS.EQU) 
 EQUS5    BSS    0
 SNAP=D   ENDIF 
  
  
**        PHASE 3 -- GALLER / FISHER ADDRESS ASSIGNMENT.
*                WE NOW DO G/F ADDRESS ASSIGNMENT, RELATIVE TO
*         A (MYTHICAL) BLOCK.  THE *END* PROCESSOR WILL RELOCATE OUR
*         ADDRESSES TO THE ACTUAL LOCAL-VARIABLE BLOCK.  VARIABLES IN 
*         COMMON, OF COURSE, ARE COMPLETELY ASSIGNED HERE.  COMMON BLOCK
*         LENGTHS MAY HAVE TO BE EXTENDED.
*         VARIABLES WHICH ARE IN COMMON NOW, BECAUSE OF EQUIVALENCING,
*         MUST BE SO MARKED IN THE SYMBOL TABLE.
  
*         ENTRY  (B5) = LENGTH OF (TS=EQU)
*                (B2) = 2 
*                (A0) = FWA (TS.EQU)
  
          SA1    TA.NAM 
          SA2    TS.SYM 
          BX5    0           X5 = LOCAL EQUIV-BLOCK LENGTH
          =B4    0
          MX0    L.TAG
          SB6    X1          B6 = FWA (TA.NAM)
          =B7    X2          B7 = FWA (TS.SYM)
          EQ     EQU54       BEGIN..
  
  
*         LOOP FOLDS TO HERE -- 
*         ENTRY  (X6) = NEW (TA.NAM) ENTRY
*                (X2) = TAG ORDINAL, BITS (59-42).
  
 EQU52    AX2    P.TAG+1     = 1/2 * (TAG ORDINAL)
          SB4    B4+B2       I=I+2
          SB5    B5-B2
          SA6    X2+B6       SET NEW ADDRESS
  
 EQU54    ZR     B5,EQU68    IF END OF TABLE
          SA2    B4+A0
          =A4    A2+1 
          BX3    X4 
          UNPK   X3,B3,X7,X1   B3 = LINK(I) 
          BX1    -X0*X2      = R(I) 
          NE     B3,B4,EQU60  IF NO ROOT
          BX7    0
          SA7    A4          ERASE LINK WORD
          ZR     X1,EQU58    IF LOCAL (NOT IN COMMON) CLASS 
  
**        ROOT OF A NON-LOCAL (COMMON) CLASS. 
*         SET    TA.NAM(ADDRESS) = R(I) 
*                TS.BLK(BLOCK LENGTH) = MAX ( (BLOCK LENGTH), R(I)+HI(I)
*                TS.SYM(CLASS) = + M.DEF + M.COMM 
  
*                            IF ( (REL(I)-LO(I)) .LT. 0) THEN N.F.G.
          SA1    TS.BLK 
          LX4    -P.EQHI
          BX3    X2 
          =B3    X1+1 
          LX3    -P.BLOCK 
          SA3    X3+B3       FETCH (TS.BLK) ENTRY 
          BX6    X2          ADDR = R(I)
          MX7    -L.RELADD
          IX1    X2+X4
          BX4    -X7*X1      ISOLATE R(I) + HI(I) 
          BX1    X3 
          BX3    -X7*X3      ISOLATE BLOCK LENGTH 
          MX7    -L.LVLFLD
          LX7    P.LVLFLD 
          BX1    -X7*X1      ISOLATE LEVEL DOPE 
          MX7    -L.BLEN
          BX3    -X7*X3      ISOLATE BLOCK LENGTH 
          MX7    X3+X4       = MAX ( (BLK LEN), (R+HI) )
          BX7    X7+X1       PUT LEVEL DOPE BACK
          SA7    A3 
          SX7    M.DEF+M.COMM+M.EQUIV+M.VAR 
          EQ     EQU66       CONTINUE.. TO SET (TS.SYM) 
  
**        ROOT OF A LOCAL (NON-COMMON) CLASS. 
*         INCREMENT LOCAL-EQUIVALENCE-SIZE -- 
*                (X5) = (X5) + HI(I) + LO(I)
*         SET ADDRESS --
*                BLOCK = 1S17 
*                RELADD = LO(I) + (X5)
  
 A        DECMIC P.BLOCK+17 
 EQU58    MX7    -L.EQLO
          BX2    X0*X2       ISOLATE TAG ORDINAL
          SA1    =1S"A"      FAKE BLOCK NUMBER OF 1S17
          BX6    -X7*X4      ISOLATE LO(I)
          AX4    P.EQHI 
          BX3    -X7*X4      ISOLATE HI(I)
          IX5    X6+X5
          BX1    X5+X1       = 18/ 0,    18/ 1S17,  24/ ((X5)+LO(I))
          IX5    X5+X3
          BX6    X2+X1       = 18/ TAG,  18/ 1S17,  24/ ((X5)+LO(I))
          SA6    A2 
          SX7    M.DEF+M.EQUIV+M.VAR
          EQ     EQU66
  
**        NON-ROOT MEMBERS -- 
*         SET    TA.NAM(ADDRESS) = R(I) = R(ROOT) + R(I)
*                TS.SYM(CLASS) = + M.DEF + M.EQUIV
  
 EQU60    BSS    0
          BX3    X2 
          SA4    B3+A0
          BX6    X4 
          LX3    -L.RELADD
          BX1    -X0*X4      ISOLATE (R(ROOT))
          AX3    -L.RELADD
          BX7    X0*X2
          SBIT   X6,BLOCK/COMM-17  FAKE BLOCK NUMBER TO P.COMM
          IX1    X3+X1       = R(ROOT) + R(I) 
          SX4    M.COMM 
          BX3    -X6*X4 
          IX6    X7+X1
          SX7    X3+M.DEF+M.EQUIV+M.VAR 
          SA6    A2          RESET R(I) 
  
 EQU66    BSS    0           SET (M.COMM + M.DEF) 
                             (X7) = CLASS BITS
          LX2    -P.TAG 
          SA1    X2+B7       FETCH TAG TABLE ENTRY
          LX2    P.TAG       RESTORE (X2) 
          BX7    X1+X7
          SA7    A1 
          EQ     EQU52       LOOP.. 
  
 EQU68    BSS    0           FINIS
          BX6    X5 
          SA6    EQUA        SAVE (LOCAL-EQUIVALENCE-LENGTH) FOR *END*
 SNAP=D   IFNE   TEST        DUMP EQUIV. TABLE
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQUS7    IF DECLARATIVE SNAP NOT SELECTED 
 EQU.7    DUMPT  (TS.EQU) 
 EQUS7    BSS    0
 SNAP=D   ENDIF 
  
  
**        WHILE WE STILL HAVE THE EQUIVALENCE CLASSES REPRESENTED AS A
*         FOREST, WE SORT OUT THE  INTERACTION OF EQUIVALENCE AND LEVEL.
  
          RJ     ELV         SPREAD LEVEL SPECS THROUGH EQUIV. CLASSES
  
  
 SNAP=B   IFNE   TEST 
          SA3    CO.SNAP
          LX3    1RB
          PL     X3,EQU7S    IF BLOCK TABLE SNAP NOT SELECTED 
          DUMPT  (TS.BLK) 
 EQU7S    BSS    0
 SNAP=B   ENDIF 
  
**        PHASE 4 - TELL THE REST OF THE COMPILER ABOUT EQUIVALENCING.
*                REFORMAT (TP.EQU) INTO SOMETHING INTELLIGIBLE. 
*                SEE TABLE DESCRIPTION OF (TP.EQU) FOR DETAILS. 
*         MAINLY, WE HAVE TO THROW AWAY ALL THE ROOT CELLS, AND COLLAPSE
*         THE TABLE TO ONE-WORD ENTRIES.
  
*         ENTRY  (A0) = FWA (TS.EQU)
*                (B2) = 2 
  
          SA1    TP=EQU 
          MX0    -L.BLOCK 
          SB5    X1 
          SB4    B5-B2
          =B6    0           (B6) WILL BE NEW LENGTH
          LX0    P.BLOCK
          SA2    EQUB 
          SB5    A0+B5       (B5) = CURRENT LWA+1 OF TABLE
  
 EQU7     SA4    B4+A0       FETCH LAST TABLE ENTRY 
          ZR     B4,EQU78    IF TABLE EXHAUSTED 
          =A3    A4+1 
          SB4    B4-B2
          BX7    X3 
          UNPK   X7,B7,X5,X6
          ZR     X3,EQU7     IF ROOT, SKIP IT 
  
 EQU74    SA1    A0+B7       FETCH ROOT 
          =A3    A1+1 
          BX7     X3
          UNPK   X7,B7,X5,X6
          BX5    X0*X4       TRASH BLOCK NUMBER 
          NZ     X3,EQU74    IF NOT YET A REAL ROOT 
  
          IX5    X5+X7
          =B6    B6+1        COUNT NEW LENGTH 
          LX1    -P.TAG 
          BX4    -X0*X1      ISOLATE ROOT TAG-ORDINAL 
          IX6    X5+X4
          SA6    B5-B6
          EQ     EQU7        LOOP.. 
  
 EQU78    SX6    B6 
          SX7    B5-B6       NEW ORIGIN = OLD (LWA+1) - (NEW LENGTH)
          SHRINK TP=EQU,X6
          SA7    TP.EQU 
  
 SNAP=D   IFNE   TEST        DUMP EQUIV. TABLE
          SA1    CO.SNAP
          LX1    1RD
          PL     X1,EQUS8    IF DECLARATIVE SNAP NOT SELECTED 
          PLINE  (=C=  (FINAL EQUIV TABLE.)=),3,2 
 EQU.8    DUMPT  (TS.EQU) 
 EQUS8    BSS    0
 SNAP=D   ENDIF 
  
          EQ     EQUX        EXIT.. 
  
  
**        CHECK / PROCESS REDUNDANCY / CONTRADICTION ERRORS.
  
 EQU81    NZ     X5,EQU82    IF CONTRADICTION 
          WARN   E.EQ11      REDUNDANT SPECIFICATIONS 
          EQ     EQU3 
  
 EQU82    FATAL  E.EQ12      CONFLICTING SPECS. 
          EQ     EQU3 
  
 EQU84    IX1    X1-X6
          IX1    X1-X5
          NZ     X1,EQU85    IF CONTRADICTION 
          WARN   E.EQ11      REDUNDANT SPECIFICATION
          EQ     EQU48
  
 EQU85    FATAL  E.EQ12      CONFLICTING SPECS. 
          EQ     EQU48
  
**        CHECK/ PROCESS ILLLGAL COMMON BLOCK EXTENSION ERROR 
  
*         TEST ILLEGAL EXTENSION BY MEMBER
  
 EQU86    LX6    -L.RELADD
          AX6    -L.RELADD   SIGN EXTEND RA(T0) 
          IX7    X6+X5       RA(T0) + DIST
          PL     X7,EQU48    IF RA(T0) + DIST > 0 
          BX5    -X6         DIST= -RA(T0)
          FATAL  E.EQ16      ILLEGAL EXTENSION OF COMMON BLOCK ORIGIN 
          EQ     EQU48
  
*         ILLEGAL EXTENSION BY ROOT 
  
 EQU87    BX5    X1          DIST = RA(T) 
  
*         PLACE IN FILL. NAME OF ROOT 
  
          SA1    TS.SYM 
          SB7    X1 
          LX2    -P.TAG 
          SB7    X2+B7
          SA1    B7-B1
          BX7    X1 
          SA7    FILL.       PLACE IN FILL. FOR ROOT
 EQU88    FATAL  E.EQ16      ILLEGAL EXTENSION OF COMMON BLOCK ORIGIN 
          LX2    P.TAG
          BX7    0           RA(T0)= RA(T) - DIST = 0 
          MX0    -L.RELADD
          EQ     EQU47
  
 TEST     IFNE   TEST 
 EQU99S   RJ     =XSVR
          PLINE  (=C= NEGATIVE OFFSET IN EQUIVALENCE.=),4,2 
          RJ     =XDAR
          EQ     E.ZA 
 TEST     ENDIF 
  
 EQUB     VFD    L.EQU2/C.SYM,L.EQU1/C.SYM,*P/0 
 EAX      SPACE  4,20 
**        ELV -  COORDINATE EQUIVALENCE AND LEVEL INFORMATION 
*                IF ANY MEMBER OF AN EQUIVALENCE GROUP APPEARED IN A
*         LEVEL STATEMENT, ALL OTHER GROUP MEMBERS INHERIT THE LEVEL
*         NUMBER.  IF, ADDITIONALLY, ONE  OF THE MEMBERS APPEARED IN  A 
*         COMMON STATEMENT, THE COMMON BLOCK INHERITS THE LEVEL NUMBER. 
* 
*         ENTRY  (TS.EQU) CONTAINS EQUIVALENCE GROUPS (END OF PHASE 3)
*                (A0) = FWA (TS.EQU)
*                (B2) = 2 
*                (B7) = FWA (TS.SYM)
*         EXIT   (TS.SYM) CONTAINS SAME LEVEL INFO FOR ALL MEMBERS OF AN
*                            EQUIV. GROUP 
*                (TS.BLK)  CONTAINS LEVEL INFO IN THE ENTRY FOR THE 
*                            BLOCK, IF ANY, CONTAINING THE EQUIV. GROUP 
  
  
 ELV      SUBR   0
  
**        PHASE A -- CHECK LEVEL SPECIFICATIONS WITHIN EACH  EQUIVALENCE
*                CLASS, MAKE SURE THE ROOT OF THE CLASS IS GIVEN LEVEL
*                SPECIFICATION BELONGING TO NONROOT(S). 
  
 SNAP=B   IFNE   TEST 
          SA3    CO.SNAP
          LX3    1RB
          PL     X3,ELV1S    IF BLOCK TABLE SNAP NOT SELECTED 
          DUMPT  (TS.BLK) 
 ELV1S    BSS    0
 SNAP=B   ENDIF 
  
          SA2    TS=EQU 
          SB5    X2          (B5) = LENGTH OF (TS.EQU)
          =B4    0
  
 ELV1     ZR     B5,ELV5     IF END OF  TABLE,  GO ON TO PHASE B
          SA1    A0+B4
          =A4    A1+1 
          ZR     X4,ELV4     IF ROOT, SKIP IT 
          LX1    -P.TAG 
          SA3    X1+B7       FETCH TAG WORD 
          SBIT   X3,LEV 
          PL     X3,ELV4     IF NO  LEVEL 
          BX5    X4 
          UNPK   X5,B3,X2,X0   (B3) = LINK
          SA2    A0+B3       ROOT 
          LX2    -P.TAG 
          SA2    X2+B7       FETCH TAG WORD FOR  ROOT 
          SBIT   X2,LEV 
          MX0    -L.LEVN
          LX3    P.LEV+1-P.LEVN    RIGHT-JUSTIFY LEVEL NUMBER 
          BX3    -X0*X3      ISOLATE LEVEL FOR NONROOT
          PL     X2,ELV3     IF NO LEVEL FOR ROOT 
          LX2    P.LEV+1-P.LEVN 
          BX2    -X0*X2      ISOLATE LEVEL FOR ROOT 
          IX0    X2-X3
          ZR     X0,ELV4     IF LEVEL SAME FOR ROOT AND NONROOT 
  
*         CONFLICT EXISTS REGARDING LEVEL INFO FOR THIS EQUIV. GROUP
  
          LX1    -P.BLOCK+P.TAG 
          SB3    X1          (B3) = BLOCK NUMBER
          PL     B3,ELV2     IF COMMON BLOCK
  
*         EQUIV. GROUP IS NOT IN COMMON -- OUTPUT DIAGNOSTIC
  
          =A5    A3-1        FETCH SYMBOL FOR NONROOT 
          MX0    L.SYM
          BX6    X0*X5
          SA6    FILL.
          SX2    B7          SAVE B7
          FATAL  =XE.LV10 
          SB7    X2          RESTORE B7 
          EQ     ELV4 
  
*         EQUIV. GROUP IS IN COMMON -- SET CONFLICT BIT IN TS.BLK ENTRY 
  
 ELV2     MX0    1
          SA1    TS.BLK 
          LX0    P.CNFL+1 
          SB6    X1+B1       (B6) = FWA BLOCK TABLE 
          SA2    B6+B3       FETCH TS.BLK ENTRY 
          BX6    X0+X2       SET CNFL BIT 
          SA6    A2 
          EQ     ELV4 
  
*         NO LEVEL INFO FOR ROOT -- SET LEVEL INFO TO AGREE WITH NONROOT
  
 ELV3     LX2    P.LEV+1     RESTORE X2 (ROOT TAG-WORD) 
          SX0    M.LEV
          LX3    P.LEVN      LEVEL VALUE INTO POSITION
          BX2    X2+X0       SET LEV BIT
          BX6    X2+X3       SET LEVEL NUMBER 
          SA6    A2          STORE TAG WORD 
  
*         IF THIS EQUIV. CLASS IN COMMON, SET DEFAULT BIT IN TS.BLK WORD
  
          LX1    -P.BLOCK+P.TAG 
          SB3    X1          (B3) = BLOCK NUMBER
          MI     B3,ELV4     IF NOT COMMON
          SA1    TS.BLK 
          MX0    1
          LX0    P.DFLT+1 
          SB6    X1+B1       (B6) = FWA BLOCK TABLE 
          SA2    B6+B3       FETCH TS.BLK ENTRY 
          BX6    X0+X2       SET DEFAULT BIT
          SA6    A2 
  
 ELV4     SB4    B4+B2
          SB5    B5-B2
          EQ     ELV1 
  
  
**        PHASE B -- CHECK LEVEL SPECIFICATIONS WITHIN EACH EQUIVALENCE 
*                CLASS, MAKE SURE ALL NONROOTS OF EACH CLASS HAVE THE 
*                LEVEL SPECIFICATION BELONGING TO ROOT. 
  
  
 ELV5     SA2    TS=EQU 
          SB5    X2          (B5) = LENGTH OF (TS.EQU)
          =B4    0
  
 SNAP=B   IFNE   TEST 
          SA3    CO.SNAP
          LX3    1RB
          PL     X3,ELV5S    IF BLOCK TABLE SNAP NOT SELECTED 
          DUMPT  (TS.BLK) 
 ELV5S    BSS    0
 SNAP=B   ENDIF 
  
 ELV55    ZR     B5,ELVX     IF END OF TABLE, EXIT..
  
          SA1    A0+B4
          =A4    A1+1 
          LX1    -P.TAG 
          SA3    X1+B7       FETCH TAG WORD 
          SBIT   X3,LEV 
          ZR     X4,ELV6     IF ROOT
          MI     X3,ELV9     IF LEVEL, SKIP IT
          EQ     ELV8 
  
*         ROOT OF CLASS 
  
 ELV6     PL     X3,ELV9     IF NO LEVEL FOR ROOT, SKIP IT
          LX1    -P.BLOCK+P.TAG 
          SB3    X1          (B3) = BLOCK NUMBER
          PL     B3,ELV7     IF COMMON BLOCK
  
*         CHECK LEVEL NUMBER TO SEE IF LEGAL OUTSIDE OF COMMON
  
          LX3    P.LEV+1-P.LEVN    RIGHT-JUSTIFY LEVEL NUMBER 
          MX0    -L.LEVN
          BX3    -X0*X3      ISOLATE LEVEL NUMBER 
          SX3    X3-1 
          ZR     X3,ELV9     IF LEVEL 1,O.K.
          =A5    A3-1        FETCH SYMBOL FOR NONROOT 
          MX0    L.SYM
          BX6    X0*X5
          SA6    FILL.
          SX2    B7          SAVE B7
          FATAL  =XE.LV9     EQUIV. GROUP NOT COMMON BUT LEVEL ABOVE 1
          SB7    X2          RESTORE B7 
          EQ     ELV9 
  
*         CHECK LEVEL OF EQUIV. GROUP AGAINST LEVEL, IF ANY, ALREADY
*         ASSIGNED TO COMMON BLOCK CONTAINING THE GROUP 
  
 ELV7     SA1    TS.BLK 
          MX0    -L.BLVL
          SB6    X1+B1       (B6) = FWA BLOCK TABLE 
          SA2    B6+B3       FETCH TS.BLK ENTRY 
          LX2    -P.BLVL
          BX1    -X0*X2      ISOLATE BLOCK LEVEL NUMBER 
          LX3    P.LEV+1-P.LEVN    RIGHT-JUSTIFY LEVEL NUMBER OF TAG
          MX0    -L.LEVN
          BX3    -X0*X3      ISOLATE LEVEL OF ROOT
          NZ     X1,ELV75    IF BLOCK HAS LEVEL 
  
*         BLOCK HAS NO LEVEL -- SET BLOCK LEVEL SAME AS ROOT AND SET
*         DEFAULT BIT 
  
          BX2    X2+X3       SET BLOCK LEVEL
          MX0    1
          LX0    P.DFLT+1 
          LX2    P.BLVL      RESTORE X2 
          BX6    X0+X2       SET DEFAULT BIT
          SA6    A2 
          EQ     ELV9 
  
*         BLOCK HAS LEVEL -- COMPARE WITH ROOT LEVEL
  
 ELV75    IX0    X1-X3
          ZR     X0,ELV9     IF SAME LEVELS 
          MX0    1
          LX0    P.CNFL+1 
          LX2    P.BLVL      RESTORE X2 
          BX6    X0+X2       SET CONFLICT BIT 
          SA6    A2 
          EQ     ELV9 
  
*         NONROOT -- AS IT HAS NO LEVEL, IT INHERITS ANY BELONGING
*                TO THE ROOT
  
 ELV8     BX5    X4 
          UNPK   X5,B3,X2,X0   (B3) = LINK
          SA2    A0+B3       ROOT 
          LX2    -P.TAG 
          SA2    X2+B7       FETCH TAG WORD FOR ROOT
          SBIT   X2,LEV 
          PL     X2,ELV9     IF NO LEVEL FOR ROOT 
          MX0    -L.LEVN
          LX2    P.LEV+1-P.LEVN    RIGHT-JUSTIFY LEVEL NUMBER 
          BX2    -X0*X2      ISOLATE LEVEL NUMBER 
          LX3    P.LEV+1     RESTORE X3 (NONROOT TAG WORD)
          SX0    M.LEV
          LX2    P.LEVN      LEVEL VALUE INTO POSITION
          BX3    X3+X0       SET LEV BIT
          BX6    X2+X3       SET LEVEL NUMBER 
          SA6    A3          STORE TAG WORD 
  
*         IF EQUIV. GROUP IS IN COMMON, SET DEFAULT BIT FOR BLOCK 
  
          LX1    -P.BLOCK+P.TAG 
          SB3    X1          (B3) = BLOCK NUMBER
          MI     B3,ELV9     IF NOT COMMON
          SA1    TS.BLK 
          MX0    1
          LX0    P.DFLT+1 
          SB6    X1+B1       (B6) = FWA BLOCK TABLE 
          SA2    B6+B3       FETCH TS.BLK ENTRY 
          BX6    X0+X2       SET DEFAULT BIT
          SA6    A2 
  
 ELV9     SB4    B4+B2
          SB5    B5-B2
          EQ     ELV55
          SPACE 4,8 
**        EAX -  EVALUATE ABSOLUTE EXPRESSION 
* 
*         ENTRY  (B4)_ FWA OF CONSTANT
* 
*         EXIT   (B4) _ END OF CONSTANT 
*         IF B7 > 0,CONSTANT DEFINED
*                (X1) = MODE
*                (X6) = VALUE OF DIMENSION (BINARY) 
*         IF B7 = 0, ERROR IN TRANSLATION OF CONSTANT.
*                (X6) = NOT DEFINED.
* 
*         USES   A1-A5  X0  B2,B7 
*                PRESERVES  X4,X5  B3,B5,B6 
  
  
 EAX20    SA4    EAXA        RELOAD REGISTERS BEFORE EXIT 
          =A5    A4+1 
          =A3    A5+1 
          =A2    A3+1 
          SB3    X3 
          =A3    A2+1 
          SB5    X2 
          SB6    X3 
  
  
 EAX      SUBR   0           ENTRY/EXIT...
          BX6    X4 
          LX7    X5 
          SA6    EAXA        EAXA+0 = (X4)
          =A7    A6+1            +1 = (X5)
          SX6    B3 
          SX7    B5 
          =A6    A7+1            +2 = (B3)
          =A7    A6+1            +3 = (B5)
          SA1    TT=PAR 
          SX6    B6 
          LX7    X1 
          =A6    A7+1            +4 = (B6)
          SA2    FILL.
          =A7    A6+1            +5 = (TT=PAR)
          BX6    X2 
          SA3    DECARM 
          =A6    A7+1            +6 = (FILL.= ARRAY NAME.)
          =X7    0
          BX6    X3 
          SA7    ARGCOMA
          =X7    O.SLP
          SA6    ARGMODE
          =A7    B4-1        PUT SPECIAL BEGINNING PAREN TO SET ARGMODE 
          SA2    FILL.
          =B4    B4-1        MOVE *SB* POINTER TO BEGINNING LEFT PAREN
          RJ     PAR         PARSE/REDUCE STATEMENT 
          SA1    EAXA+6 
          SA3    EAXA+5 
          BX6    X1 
          SA2    TT=PAR 
          SA6    FILL.       RESTORE FILL.
          IX0    X2-X3
          ZR     X0,EAX10    IF NO ERROR, EXPRESSION REDUCED
          SHRINK TT=PAR,X3   RESET PARSE FILE LENGTH
          FATAL  E.DM11 
          =B7    0           INDICATE ERROR IN DIMENSION CONSTANT 
          EQ     EAX20
  
**        CONSTANT FOR DIMENSION PROCESSED, SET UP EXIT CONDITIONS. 
  
 EAX10    =A1    B6-1 
          =B4    B4-1        MODE TO LAST PART OF CONSTANT
          RJ     LCT         LOAD BINARY OF CONSTANT INTO X6
          PL     X6,EAX15    IF POSITIVE NUMBER 
          =B7    X0-M.INT 
          NZ     B7,EAX15    IF NOT INTEGER 
          BX3    X0          SAVE MODE
          FATAL  E.DM13      NEGATIVE DIMENSION NOT ALLOWED 
          =X6    1           DUMMY OF *1* FOR DIMENSION 
          BX0    X3          RESTORE MODE 
 EAX15    BX1    X0          MODE 
          =B7    1           INDICATE NO ERROR IN SYNTAX
          EQ     EAX20
  
 EAXA     BSS    7
 EXT      SPACE  4,8
**        EXT -  PROCESS "EXTERNAL" DECLARATION.
*         EXIT   TO MASTER LOOP.
  
  
          HEREIF EXTERNAL 
  
          CLAS=  X6,(EST,NVAR,EXT)
          SA6    EXTA        INDICATE *EXTERNAL* STATEMENT
 EXT1     SA1    B4 
          ZR     X1,E.EX3    IF NO NEXT ITEM - ERROR
          MX0    L.CDPC 
          SB2    X1-O.VAR 
          BX6    X0*X1       ELEMENT ONLY.
          SB4    B4+B1
          SA6    FILL.       IN CASE OF ERROR.
          ZR     B2,EXT5     IF VARIABLE. 
          SA2    X1+=XCHARMAP 
          NZ     X2,EXT2     IF NOT VAR OR CONS 
          LX2    X1 
 EXT2     MX0    L.CDPC 
          BX6    X0*X2
          SA6    FILL.
          EQ     E.TE5       SYNTAX ERROR 
  
 EXT5     SA1    B4 
          SB7    X1-O.VAR 
          NZ     B7,EXT6     IF NOT LONG NAME 
          =B4    B4-1 
          RJ     =XTLV       TRUNCATE NAME
          =B4    B4+1 
 EXT6     SCAN   TS.SYM,SSY 
          MI     B7,EXT10    IF *NIT* 
          BX1    X2 
          IFBIT  X1,-EXT,EXT7 
          WARN   E.EX1
          EQ     EXT15       CONTINUE.
  
 EXT7     IFBIT  X1,-ENT/EXT,EXT9 
          WARN   E.EX4
          EQ     EXT15       CONTINUE 
  
 EXT9     =X3    M.VAR
          SX2    P.EXT
          BX5    X6          SAVE (X6)  = TAG 
          RJ     CCT         CHECK FOR CONFLICTING TYPE 
          BX1    X6 
          LX6    X5          RESTORE (X6) = TAG 
          ZR     X1,EXT15    IF CONFLICT
          SA3    EXTA 
          BX6    X3+X6
          SA6    A2          REPLACE ENTRY
          EQ     EXT15       CONTINUE.
  
 EXT10    RJ     STY         NATURAL TYPE 
          SA2    EXTA 
          BX7    X2+X1
          ADSYM  TS.SYM 
  
 EXT15    ADDREF X6,CR.SUB
          SA1    B4 
          SB4    B4+B1
          SX2    X1-O.COMMA 
          ZR     X2,EXT1     IF NO *EOS*
  
          ZR     X1,PSP      IF COMPLETE. 
          SA2    X1+=XCHARMAP 
          NZ     X2,EXT16    IF NOT VAR OR CONS 
          LX2    X1 
 EXT16    MX0    L.CDPC 
          BX6    X0*X2
          SA6    FILL.
          FATAL  E.EX2
          SB4    B4-B1
  
**        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.
          JP     PSP         NEXT 
  
 EXTA     EQU    TYPA        HOLDS BITS TO MERGE INTO TAG-TABLE 
          TITLE  FSC
          SPACE  4,8
**        FSC - FORMAL PARAMETER AS SUBSCRIPT CHECKS
*         CHECK ALL F.P.S IN SYMBOL TABLE FOR THOSE USED AS SUBSCRIPTS
*         IN ARRAYS.  THESE SHOULD BE OF TYPE INTEGER.
  
 FSC      SUBR   0
          SA4    VARDIM 
          SA2    TS.SYM 
          ZR     X4,FSC      NO FP USED AS SUBSCRIPT, EXIT
          SA3    TS=SYM 
          MX7    -L.MODE
          SB6    X3-1 
          MX5    1
 FSC1     MI     B6,FSCX     IF LIST IS EXHAUSTED, EXIT 
          SA3    X2+B6
          SB6    B6-2 
          BX4    -X7*X3      EXTRACT MODE 
          IFBIT  X3,-FP,FSC1 IF NOT FP
          IFBIT  X3,-FPS/FP,FSC1  IF NOT USED AS SUBSCRIPT
          BX6    X3 
          MX1    7*CHAR 
          LX6    P.FPS+1
          SX0    X4-M.INT 
          SA6    A3 
          ZR     X0,FSC1     IF TYPE INTEGER, OK
          =A4    A3-1 
          BX6    X1*X4
          SA6    FILL.
          FATAL  E.DM14 
          EQ     FSC1 
 MCA      SPACE  4,8
**        LVL -  PROCESS "LEVEL" STATEMENT
*         EXIT   TO MASTER LOOP 
*         CALLS  CCT,TRV
  
  
          HEREIF LEVEL
  
          ANSI   E.ANS
          SA1    B4          FETCH LEVEL NUMBER 
          SB2    X1-O.CONS
          ZR     X1,=XE.LV1  IF PREMATURE E.O.S.
          NZ     B2,=XE.LV1  IF NOT NUMBER
          MX0    L.SYM
          BX5    X0*X1
          LX5    CHAR 
          SX6    1R1
          SX7    1
          IX4    X5-X6
          ZR     X4,LVL2     IF LEVEL 1 
          SX6    1R2
          SX7    2
          IX4    X5-X6
          ZR     X4,LVL2     IF LEVEL 2 
          SX6    1R3
          SX7    3
          IX4    X5-X6
          NZ     X4,=XE.LV1  IF NOT LEVEL 1,2 OR 3
 LVL2     SA7    LVLA        SAVE LEVEL NUMBER
  
*         PROCESS COMMA FOLLOWING LEVEL NUMBER
  
          =A1    B4+1 
          =B4    A1+1        B4 = B4 + 2
          SB2    X1-O.COMMA 
          ZR     X1,=XE.LV2  IF PREMATURE E.O.S.
          NZ     B2,=XE.LV2  IF NOT COMMA 
  
*         PROCESS VARIABLE/ARRAY LIST 
  
 LVL4     SA1    B4          FETCH NAME 
          SB2    X1-O.VAR 
          ZR     X1,=XE.LV3  IF PREMATURE E.O.S.
          NZ     B2,=XE.LV3  IF NOT NAME
          MX0    L.SYM
          BX6    X0*X1
          SA6    FILL.       SAVE NAME FOR POSSIBLE ERROR MESSAGE 
          RJ     TRV         TRANSLATE VARIABLE 
          =X3    M.LEV
          BX2    X3*X6
          ZR     X2,LVL6     IF NOT ALREADY LEVEL 
          EQ     =XE.LV4     MULTIPLE LEVEL DEFINITION IGNORED
 LVL6     CLAS=  X3,(RP,EXT,ENT,ASF,NLST) 
          SX2    P.LEV
          RJ     CCT         CHECK CONFLICTING CLASSES
          ZR     X6,LVL8     IF ERROR DETECTED
          SX4    M.LEV+M.VAR
          BX6    X6+X4
          SA4    LVLA        RETRIEVE LEVEL NUMBER
          LX4    P.LEVN 
          BX6    X6+X4       SET LEVEL NUMBER INTO TAG-WORD 
          SA6    X3          UPDATE TAG 
 LVL8     =A1    B4+1 
          =B4    A1+1        B4 = B4 + 2
          SB2    X1-O.COMMA 
          ZR     X1,PSP      IF END OF STATEMENT
          ZR     B2,LVL4     IF COMMA,CONTINUE PROCESSING LIST
          EQ     =XE.LV5     BAD SYNTAX 
  
 LVLA     BSS    1
          SPACE  4,8
**        MCA -  MAKE RELATIVE COMMON ASSIGNMENTS 
*         ENTRY- END OF DECLARATIVES HAS BEEN ENCOUNTERED 
*                (X1) = FWA (TA.NAM) -- ADDRESS TABLE.
*         EXIT-  VARIABLES IN COMMON HAVE BEEN ASSIGNED BLOCK RELATIVE
*         ADDRESSES (IN TT.COMM), AND THE LENGTH OF ALL COMMON BLOCKS 
*         HAS BEEN COMPUTED AND ENTERED IN TS.BLK.
  
  
  
 MCA      SUBR   0
          SA4    TT=COMM
          SA2    TS.SYM 
          MX0    -L.DIMLG 
          SB7    X1          B7 = FWA ADDRESS TABLE 
          SA1    TT.COMM
          ZR     X4,MCAX     IF NOTHING IN COMMON, EXIT.. 
          BX6    0
          IX4    X1+X4
          SA3    TS.BLK 
          SA5    TP.DIM 
          SB5    P.DIMLG
          SA6    X4          MARK END OF TABLE
          SB6    X2          B6 = FWA TAG TABLE 
          SB3    X3+B1       B3 = FWA BLOCK TABLE 
          SA1    X1          PRE-FETCH 1ST ENTRY
          SB2    X5          B2 = FWA DIMENSION TABLE 
          BX5    X1 
          SB4    60-P.PNT 
          LX1    -P.BLOCK 
          EQ     MCA5A       TEST FOR ZERO BLOCK ORDINAL
  
  
 MCA1     SA3    X1+B3       FETCH TS.BLK ENTRY 
          LX1    P.BLOCK-P.PWF-1
          IX4    X1+X1       X4 = TAG ORDINAL 
          SA2    X4+B6       FETCH TAG TABLE ENTRY
          MX7    -L.BLEN
          BX6    -X7*X3      ISOLATE BLOCK LENGTH 
          BX6    X6+X5       MERGE ADDRESS + TAG
          LX4    X2,B4
          MX5    -L.PNT 
          BX4    -X5*X4      ISOLATE TP.DIM ORDINAL 
          SA5    X4+B2       FETCH ARRAY PARAMETERS 
          SA6    X1+B7       STORE BLOCK-RELATIVE ADDRESS 
  
**        COORDINATE COMMON AND LEVEL INFORMATION.
*                THE TS.BLK ENTRY AND THE TAG TABLE ENTRY ARE EXAMINED
*         FOR LEVEL INFORMATION.  IF THESE LEVEL INDICATORS ARE NOT SET 
*         OR ARE EQUAL, THERE IS NOTHING TO DO.  IF ONLY ONE OF THEM IS 
*         SET, WE SET THE OTHER EQUAL TO IT.  IF THEY ARE NOT EQUAL, THE
*         *CNFL* BIT IS TURNED ON IN THE TS.BLK ENTRY FOR LATER 
*         DIAGNOSTIC PROCESSING.
  
          MX7    -L.BLVL
          LX3    -P.BLVL     RIGHT-JUSTIFY BLOCK LEVEL
          BX7    -X7*X3      X7 = BLOCK LEVEL 
          LX3    P.BLVL      RESTORE X3 
          SBIT   X2,LEV 
          PL     X2,MCA3     IF NO LEVEL INDICATOR
          LX2    P.LEV+1-P.LEVN    RIGHT JUSTIFY LEVEL NUMBER 
          MX6    -L.LEVN
          BX6    -X6*X2      X6 = LEVEL NUMBER
          LX2    P.LEVN      RESTORE X2 
          IX4    X7-X6
          ZR     X4,MCA5     IF LEVELS AGREE
          ZR     X7,MCA2     IF NO  BLOCK LEVEL 
  
*         LEVEL CONFLICT
  
          MX4    1
          LX4    P.CNFL+1 
          BX3    X4+X3       SET CONFLICT BIT 
          EQ     MCA5 
  
 MCA2     LX6    P.BLVL 
          BX3    X6+X3       SET BLOCK LEVEL
          EQ     MCA5 
  
 MCA3     ZR     X7,MCA4     IF NO LEVEL
          SX4    M.LEV
          LX2    P.LEV+1     RESTORE X2 
          BX2    X2+X4       SET LEV BIT
          LX7    P.LEVN 
          BX6    X2+X7       SET LEVEL NUMBER 
          SA6    A2          UPDATE TAG WORD
  
*         TURN ON DEFAULT BIT TO INDICATE AN INFORMATIVE DIAGNOSTIC 
*         IS REQUIRED FOR THIS BLOCK. 
  
          MX4    1
          LX4    P.DFLT+1 
          BX3    X4+X3       SET DEFAULT BIT
          EQ     MCA5 
  
 MCA4     LX2    P.LEV+1     RESTORE X2 
 MCA5     IFBIT  X2,LONG
          SA1    A1+B1
          AX4    X5,B5
          BX5    -X0*X4      ISOLATE ARRAY LENGTH 
          AX2    -0 
          IX3    X3+X5
          BX2    X2*X5
          LX5    X1 
          IX6    X2+X3       ADD LENGTH AGAIN IF *LONG* 
          LX1    -P.BLOCK 
          SA6    A3 
 MCA5A    ZR     X1,MCA5B    IF TABLE EXHAUSTED 
          SX3    X1 
          NZ     X3,MCA1     IF BLOCK ORDINAL NON-ZERO
          =A1    A1+1 
          LX1    -P.BLOCK 
          BX5    X1 
          EQ     MCA5A
  
 MCA5B    BSS    0
  
**        LEVEL INFORMATION IS NOW COMPLETE IN THE BLOCK TABLE, AND ANY 
*         CONFLICTS HAVE BEEN RECORDED.  ANOTHER PASS THROUGH (TT.COMM) 
*         IS REQUIRED, HOWEVER, TO MAKE SURE ALL NAMES IN EACH BLOCK
*         HAVE THE LEVEL NUMBER AND TO RECORD ANY DEFAULTS NOT HANDLED
*         IN THE FIRST PASS THROUGH (TT.COMM).
  
 SNAP=B   IFNE   TEST 
          SA3    CO.SNAP
          LX3    1RB
          PL     X3,MCA6S    IF BLOCK TABLE SNAP NOT SELECTED 
          DUMPT  (TS.BLK) 
 MCA6S    BSS    0
 SNAP=B   ENDIF 
  
          SA1    TT.COMM
          SA1    X1 
          LX1    -P.BLOCK 
  
 MCA6     SA3    X1+B3       FETCH TS.BLK ENTRY 
          LX1    P.BLOCK-P.PWF-1
          IX4    X1+X1       X4 = TAG ORDINAL 
          SA2    X4+B6       FETCH TAG TABLE ENTRY
          MX7    -L.BLVL
          LX3    -P.BLVL     RIGHT-JUSTIFY BLOCK LEVEL
          BX7    -X7*X3      X7 = BLOCK LEVEL 
          LX3    P.BLVL      RESTORE X3 
          SBIT   X2,LEV 
          MI     X2,MCA7     IF LEVEL INDICATOR 
          ZR     X7,MCA7     IF NO BLOCK LEVEL
          SX4    M.LEV
          LX2    P.LEV+1     RESTORE X2 
          BX2    X2+X4       SET LEV BIT
          LX7    P.LEVN 
          BX6    X2+X7       SET LEVEL NUMBER 
          SA6    A2          UPDATE TAG WORD
          MX4    1
          LX4    P.DFLT+1 
          BX6    X4+X3       SET DEFAULT BIT
          SA6    A3          UPDATE BLOCK TABLE ENTRY 
          EQ     MCA75
  
 MCA7     LX2    P.LEV+1     RESTORE X2 
 MCA75    SA1    A1+B1
          LX1    -P.BLOCK 
          NZ     X1,MCA6     IF TABLE NOT EXHAUSTED 
  
 SNAP=B   IFNE   TEST 
          SA3    CO.SNAP
          LX3    1RB
          PL     X3,MCA7S    IF BLOCK TABLE SNAP NOT SELECTED 
          DUMPT  (TS.BLK) 
 MCA7S    BSS    0
 SNAP=B   ENDIF 
  
          EQ     MCAX        EXIT.. 
 PCD      SPACE  4
**        PCD  - PROCESS DECLARATIVES 
*         ENTRY  FIRST EXECUTABLE STATEMENT HAS BEEN ENCOUNTERED
*         EXIT   (STAGE) ADVANCED TO *CPM=ASF*. 
*                (X5) RESTORED FROM ("SB.KEY"). 
*                (B4) PRESERVED.
*                (A0) RESTORED TO (F.SB)
  
  
 PCD      BSS    0           ENTRY... 
          =X6    CPM=ASF
          SX7    B4 
          SA6    STAGE
          SA7    PSFA        SAVE (B4)
  
  
**        ALLOCATE AND PRESET BASIC ADDRESS TABLE.
  
 #FID     IFNE   .FID,0 
          SA2    =XTP=DIM    X2 = LENGTH OF TP.DIM
          ALLOC  =XTP.CIDM,X2 
          SA2    =XTP.DIM    X2 = ORIGIN OF TP.DIM
          SA1    TP=DIM      X1 = LENGTH OF TP.DIM
          SA3    =XTP.CIDM   X3 = ORIGIN OF TP.CIDM 
          MVE    X1,X2,X3    COUNT,FROM,TO
 #FID     ENDIF 
          SA2    TS=SYM 
          AX0    X2,B1       ADDRESS TABLE LENGTH = 1/2 SYM TAB LEN 
          SHRINK TA=NAM 
          ALLOC  TA.NAM,X0   ALLOCATE BASIC ADDRESS TABLE 
          =X3    2
          SA6    B7          INITIALIZE STORE 
          IX4    X2+X2
          LX3    P.TAG
          SX6    X4-1        LAST TAG = 2 * TABLE LEN - 1 
          NO
          LX6    P.TAG
 PCD2     =A6    A6-1 
          IX6    X6-X3       DECREMENT TAG
          PL     X6,PCD2
  
          RJ     MCA         ASSIGN RELATIVE COMMON ADDRESSES 
  
          RJ     EQU         PROCESS EQUIVALENCES 
  
          RJ     FSC         FORMAL PARAMETER AS SUBSCRIPT CHECKS 
          RJ     CLU         CHECK LEVEL NAME REQUIREMENTS
  
          RJ     APT         ASSIGN ECS/LCM POINTER TAGS
  
          SHRINK TT=COMM,0   TRASH TEMPORARY COMMON TABLE 
          SA2    =XT.SB 
          SA1    PSFA 
          SA0    X2          RESTORE (A0) 
          SA5    "SB.KEY"    RESTORE (X5) 
          SB4    X1          RESTORE (B4) 
          EQ     PCDX        EXIT.. 
          LIST   D
          END 
