*DECK     PS1CTL
          IDENT  PS1CTL 
          TITLE              PS1CTL$ - PASS 1 , PHASE 2 CONTROLLER
*CALL     SSTCALL 
          SPACE  4
*** 
*         PS1CTL$ IS THE INTERFACE ROUTINE BETWEEN SCANNER AND THE
*         STATEMENT PROCESSORS FOR ALL NON SPECIFICATION STATEMENTS 
* 
  
  
 B=PS1CT  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
          ENTRY  PH2CTL,PH2RETN,LDPS2 
  
          EXT    RSELECT,OPTLVL,N.FERR,O.CBT,O.DIM
          EXT    DOLAB,DOLABCN,ERPRO,ERPROI,FORMAT,DFLAG
          EXT    OPSTAK,FSTEX 
          EXT    O.ARLST,L.ARLST,S.ARLST
          EXT    QFLAG,R=FLAG 
  
*         ERROR MESSAGES ISSUED BY PS1CTL$
  
 E.CUL    EQU    18                CONFLICTING USE OF A LABEL 
 E.BDA    EQU    41                STATEMENT ILLEGAL IN BLOCK DATA
 E.HCNF   EQU    55           HEADER CARD NOT FIRST STATEMENT 
 E.DECS   EQU    109               OUT OF SEQUENCE DECLARATIVE STMT 
 E.URS    EQU    178               NO PATH TO THIS STATEMENT
*CALL,DBGCOM
          EJECT 
*** 
*         JMP - FORM JUMP VECTOR FOR STATEMENT PROCESSING 
* 
*         PROG IS THE NAME OF THE STATEMENT PROCESSOR 
*         LSFLAG IS TO BE SET FOR RETURN, GOTO OR ARITHMETIC IF STMTS 
* 
 JMP      MACRO  PROG,LSFLAG,FSTX 
          IFC    EQ,//LSFLAG/ 
          SA6    B6                LS FLAG = 0
          ELSE
          SA7    B6                LS FLAG = 1
          ENDIF 
          RJ     =X_PROG
          EQ     PH2RETN
          ENDM
  
  
*         EQU"S FOR RA CELLS USED BY THE COMPILER 
  
 SYM1     EQU    12B               FWA OF THE SYMBOL TABLE
 SYMEND   EQU    13B               LWA OF THE SYMBOL TABLE
 DIM1     EQU    17B               30/LENGTH,30/FWA OF DIM TABLE
 LTYPE    EQU    21B               TYPE OF LOGICAL IF 
 CLABEL   EQU    23B               LABEL OF CURRENT STMT
 TYPE     EQU    24B               STATEMENT TYPE CODE ( 0 - 37 ) 
 SELIST   EQU    32B               FWA OF E LIST
 LELIST   EQU    34B               E LIST POINTER FOR LOGICAL IF
 DUKE     EQU    37B               BINARY LINE COUNT
 ATYPE    EQU    51B               ARITHMETICS FOR TYPES 3 AND 8 QQQQQQQ
 PROGRAM  EQU    56B               E LIST OF SUBPROGRAM NAME
 NRLN     EQU    64B               NEXT AVAILABLE NUMBER FOR RI 
  
 LSFLG    ENTRY.                   .NE. 0 IF LAST STMT WAS UNCONDITIONAL
*                                  JUMP ( ARITH IF , RETURN OR GOTO ) 
  
          USE    /DOLVL/
 DOFLAG   ENTRY.                   LEVEL OF NESTING 
          USE    /STSORD/ 
 STSORD   BSSZ   1                 NUMBER OF STMT TEMPORARIES GENERATED 
          USE    *                 FOR A SINGLE STATEMENT 
  
          USE    /MACBUF/ 
 MACBUF   BSS    16                TEMPORARY STORAGE FOR VARIOUS ROUTINE
          USE    0
  
  
  
*         R-LIST MACRO SKELETON FOR *RJ FTNERR.* (ISSUED IN DEBUG ONLY).
  
 RJ60     =      122B 
 FERRMAC  RMHDR  RJ60,2      MACRO WORD 1 
          BSSZ   2           WORDS 2 AND 3
          EJECT 
          TITLE              MAIN LOOP
**        PH2CTL - ENTRY POINT TO PHASE 2 FROM *DPCLOSE*
  
 PH2CTL   SX7    2
          SA7    NRLN        NRLN = 2 
          EQ     D.PS4
          SPACE  2
*** 
*         IPH2 - INITIALIZE PHASE 2 FOR EXECUTABLE STMT PROCESSING
* 
 IPH2     ENTRY.
          SA1    DUKE 
          SA3    =XSPPFLAG
          ZR     X3,IPH2.0         IF SPP OPTION NOT SELECTED 
          SA2    =XIFTLU.P+1
          BX6    X2 
          SA6    A2-1 
 IPH2.0   LX7    X1 
          SA7    FSTEX             FSTEX = LINE NUM OF FIRST EXEC STMT
          SA1    LWAWORK
          SA2    FWAWORK
          IX3    X1-X2             WORKING STORAGE AVAILABLE
          SX4    X3-400B           ENSURE AT LEAST 400B WORDS LEFT
          NG     X4,CTBLOVL        ERROR IF NOT 
          SX5    ARLSZ             ARLIST BUFFER SIZE DEFAULT 
          IX3    X5-X4
          NG     X3,IPH2.2         USE MINIMUM OF THE TWO SIZES 
          SX5    X4 
 IPH2.2   ALLOC  ARLST,X5          ALLOCATE ARLIST BUFFER SPACE 
          SA2    S.ARLST           AMOUNT OF STORAGE ALLOCATED
          SA3    O.ARLST           ARLIST BUFFER BASE 
          BX6    X2 
          SB3    X3                FWA OF ARLIST BUFFER 
          SA1    OPSTAK+1          BEGINNING OF ADDSUB INFORMATION
          SA6    L.ARLST           AMOUNT OF ALLOCATION USED
          SB5    1
          MX0    60-18
          SB6    60 
 LOOP     UX7    B7,X1             GET SHIFT COUNT AND ADDRESS
          SB4    B6-B7             COMPUTE SHIFT COUNT
          SA4    X7                TARGET WORD FOR ADDRESS SUBSTITUTION 
          LX1    B4,X4             POSITION INSTRUCTION 
          LX7    B7,X0             POSITION MASK
          SB2    X1                ADDRESS BIAS 
          BX1    X7*X4             CLEAR BIAS 
          SX3    B2+B3             ADD ARLIST BUFFER ADDRESS TO BIAS
          LX5    B7,X3             POSITION RESULT
          BX6    X1+X5             INSERT ADDRESS INTO INSTRUCTION
          SA1    A1+B5             NEXT ADDSUB INFORMATION WORD 
          SA6    A4                RESTORE
          NZ     X1,LOOP
          SA2    DFLAG
          ZR     X2,IPH2           IF D OPTION NOT SELECTED 
          RJ     =XPOINTRS         SET UP POINTERS FOR BUGPRO 
          CALLF  BUGPRO,B5         INIT FOR DEBUG PROCESSING
          SX3    DEBUG-1
          SA2    D.SSMTB
          IX6    X2+X3
          SA6    SYM1              UPDATE SYM1
          SA2    D.ESMTB
          IX6    X2+X3
          SA6    SYMEND            UPDATE SYMEND
          SA2    D.ELAST
          IX6    X2+X3
          SA6    LWAWORK           UPDATE LWAWORK 
          SA2    D.ELIST
          IX6    X2+X3
          SA6    SELIST            UPDATE SELIST
          SA2    NOACT
          NZ     X2,IPH2.1         NO PACKET INFORMATION
          MX6    0
          SA6    D.ON 
          CALLF  BUGACT,B5         ACTIVATE OPTIONS 
 IPH2.1   CALL   CVDB        ISSUE *COMPUTE VARDIM BOUNDS* R-MACRO
          EQ     IPH2 
          SPACE  3
*** 
*         PH2RETN - RETURN POINT FROM STMT PROCESSOR S
* 
 PH2RETN  SA1    CLABEL 
          SB5    1
          ZR     X1,PH2EL    IF NO LABEL
          RJ     DOLAB             OUTPUT DOEND MACROS FOR LOOPS THAT 
*                                  TERMINATE ON THIS STMT 
  
 PH2EL    SA5    RSELECT
          ZR     X5,PH2DB          R = 0
          ADDREF B0                TERMINATE THE LINE OF REFERENCES 
  
 PH2DB    SA3    DFLAG
          ZR     X3,PH2SCAN        IF NOT DEBUG MODE
          CALL   DOP         DEBUG OPTIONS PROCESSOR
          SB5    1
          EQ     D.PS4       CONTINUE MAIN *PS1CTL* LOOP
          EJECT 
*** 
*         PH2SCAN - START OF STATEMENT PROCESSING LOOP
* 
 PH2SCAN  CALL   SCANNER     TYPE AND CONVERT STMT TO E-LIST
  
 D.PS4    SA2    TYPE 
          SX6    X2-12
          MI     X6,D.PS4A   IF NOT EXECUTABLE
  
          SA3    NRLN 
          SA4    =XN.EXST 
          SX6    X3-74000B
          SX7    X4+B5       N.EXST = N.EXST + 1
          SA7    A4 
          MI     X6,D.PSAA   IF NRLN < 74000B 
  
          WRM    EOSM        *EOS* TO RLIST TO STOP SEQ ACCUMULATION
          SX6    2
          SA6    NRLN        NRLN = 2 
  
 D.PSAA   SA4    DUKE 
          SA3    NRLN 
          LX4    R1.INP 
          SB3    OC.BOS 
          IX5    X3+X4
          PX6    B3,X5
          SA6    MACBUF 
          SB1    B5 
          WRITEW =XF.RLST,A6,1
          SB5    B1 
  
 D.PS4A   SA2    TYPE 
          SA1    CLABEL 
          SA3    PROGRAM
          SB7    X2           SET TYPE IN B7
          NZ     X3,PS2SC6         IF NOT BLOCK DATA
          SA2    BDTYPE 
          LX2    X2,B7
          PL     X2,D.BDA          IF TYPE NOT ALLOWED IN BLK DATA
          SB6    B7-2 
          LT     B6,D.PS5          IF A HEADER CARD 
          SB6    B6-10+2
          LT     B6,D.DEC          IF A DECLAR. OUT OF SEQUENCE 
          EQ     PS2SC.S
  
 PS2SC6   SB6    12 
          GE     B7,B6,PS2SC3      IF NOT DECLARATIVE 
          SB4    9
          GT     B7,B4,PS2SC.S     IF NOT A SPECIFICATION STMT
          EQ     B7,B4,PS2SC.F     IF A FORMAT STMT 
          SPACE 
          GT     B7,B5,D.DEC  IF NOT A HEADER CARD
  
 D.PS5    POSTER SEV=FE,NR=E.HCNF *HDR OUT OF SEQ*
          SA1    C$STMT 
          ZR     X1,PH2SCAN  IF NEXT STMT IS NOT C$DEBUG STMT 
          CALL   SCANNER     BURST NEXT STMT INTO A SBUFF 
          CALL   DBGINTX     PROCESS DEBUG STMT 
          EQ     PH2SCAN     REJOIN NORMAL FLOW OF PROGRAM
  
 D.DEC    POSTER SEV=FE,NR=E.DECS *DECL OUT OF SEQ* 
          SA1    C$STMT 
          ZR     X1,PH2SCAN  IF NEXT STMT IS NOT C$DEBUG STMT 
          CALL   SCANNER     BURST NEXT STMT INTO A SBUFF 
          CALL   DBGINTX     PROCESS DEBUG STMT 
          EQ     PH2SCAN     REJOIN NORMAL FLOW OF PROGRAM
  
 D.BDA    POSTER SEV=FE,NR=E.BDA,RETURN=PH2SCAN  *ILL STMT IN BLK DATA* 
  
 PS2SC.F  CALL   FORMAT      PROCESS FORMAT STATEMENT 
          EQ     PH2EL
  
*         CHECK FOR UNREACHABLE STMTS 
  
 PS2SC3   SA2    LSFLG
          ZR     X2,PS2SC4         IF LAST STMT WAS NOT AN UNCONDITIONAL
*                                  JUMP 
          NZ     X1,PS2SC4         IF THIS STMT HAS A LABEL 
          SA3    JMPBIT            BIT VECTOR 
          LX4    B7,X3
          MI     X4,PS2SC4   IF THIS STMT TERMINATES THE BLOCK
          MX5    0
          CALL   WLABM       OUTPUT A LABEL MAC WITH IH = 0 FOR PASS 2
  
          POSTER SEV=INF,NR=E.URS,RETURN=PS2SC.S  *UNREACHABLE STMT*
  
 PS2SC4   ZR     X1,PS2SC.S        IF NO LABEL
          RJ     DOLABCN           PROCESS LABEL DEFINITION 
  
*         CHECK AND RESET MISCELLANEOUS FLAGS 
  
 PS2SC.S  SA3    STSORD            NUMBER OF ST. S USED FOR LAST STMT 
          SA4    =XN.ST 
          MX6    0
          SA6    A3                RESET STSORD 
          IX5    X4-X3             STMAX-STSORD 
+         PL     X5,*+1 
          SX7    X3 
          SA7    A4          N.ST = MAX( N.ST , STSORD )
  
          SA1    TYPE 
          SB7    X1 
 DBG1     SA2    FSTEX
          NZ     X2,PS2SC.S1       IF EXECUTABLES APPEARED
  
          SA3    BT.EXEC           BIT TABLE
          LX4    B7,X3
          NG     X4,PS2SC.S1       IF STMT IS NOT EXECUTABLE
  
          RJ     IPH2              INITIALIZE FOR PHASE 2 
  
          SA1    TYPE 
          SB7    X1 
  
 PS2SC.S1 SB3    B7+B7             2*STMT TYPE
          MX6    0                 X6 = 0 
          SX7    B5                X7 = 1 
          SB6    LSFLG
          JP     VTABL-2*10+B3     JUMP TO APPROPIATE STMT PROCESSOR
 EOSM     VFD    12/2000B+OC.EOS,48/0 
          SPACE  3
*         BIT 59-I ON IF STMT WITH TYPE I TERMINATES SUBPROGRAM 
  
 JMPBIT   VFD    13/0              0 - 12 
          VFD    1/-0              13 
          VFD    22/0              14 - 35
          VFD    2/-0              36 - 37
          VFD    32/0              38 - 59
  
*         BIT 59-I SET IF STMT WITH TYPE CODE = I IS NOT EXECUTABLE 
  
 BT.EXEC  VFD    14/-0        0 - 13
          VFD    4/0         14 - 17
          VFD    1/-0        18 
          VFD    17/0        19 - 35
          VFD    34/-0       36 - 59
*         STATEMENT TYPE MASK FOR BLOCK DATA
 BDTYPE   VFD    2/3,2/0           HEADER CARD TYPES
          VFD    5/33B             ALLOWABLE DECLARATIVES 
          VFD    5/11B,23/0,1/1    ALLOWABLE EXECUTABLES(DATA, END) 
          VFD    22/0              ALL OTHERS ILLEGAL 
          SPACE  3
*** 
*         JUMP TABLE FOR THE STATEMENT PROCESSORS 
* 
 VTABL    RJ     =XDATA            10 - DATA STMT 
          EQ     PH2EL
  
          RJ     =XNAMELST         11 - NAMELIST/GN/... 
          EQ     PH2EL
  
          JMP    ARITH,,NX         12- ASF OR V = E 
  
          RJ     END               13 - END CARD
          EQ     LDPS2             LOAD PASS 2
  
          JMP    ASSIGN            14 - ASSIGN N TO I 
  
          JMP    GOTO,1            15 - GO TO I , ETC 
  
          JMP    IFE,1             16 - IF(E) N1,N2,N3
  
          JMP    IFL               17 - IF(E) S 
  
          MX6    0                 18 - BAD STATEMENT 
          SA6    LSFLG
          EQ     PH2RETN
  
          JMP    CALL              19 - CALL NAME...
  
          JMP    RETURN,1          20 - RETURN
  
          JMP    CONT              21 - CONTINUE
  
          JMP    STOPP,1           22 - STOP  OR  STOP NNN
  
          JMP    PAUSEP            23 - PAUSE 
  
          JMP    DOPROC            24 - DO N I = N1,N2,N3 
  
          JMP    READ              25 - READ
  
          JMP    WRITE             26 - WRITE N,LIST  ETC 
  
          JMP    BUFIN             27 - BUFFER IN (U,K) (A,B) 
  
          JMP    BUFOUT            28 - BUFFER OUT (U,K) (A,B)
  
          JMP    ENC               29 - ENCODE (N,F,A) K
  
          JMP    DEC               30 - DECODE (N,F,A) K
  
          JMP    REW               31 -REWIND U 
  
          JMP    BKSP              32 - BACK SPACE U
  
  
          JMP    ENDFILE           33 - END FILE U
  
          JMP    PRINT             34 - PRINT F,LIST
  
          JMP    PUNCH             35 - PUNCH F,LIST
  
          CALL ENTRY
          EQ     PH2RETN
  
          RJ     =XEND             37 - EOF ( END CARD ASSUMED )
          EQ     LDPS2
          TITLE              TERMINATE PASS 1 , LOAD PASS 2 
*** 
*         LDPS2 - LOAD PASS 2 
* 
 LDPS2    SA1    DFLAG
          ZR     X1,LDPS21         IF DEBUG NOT SELECTED
  
*         SCAN AREA LIST TABLE FOR ERRORS 
  
          SA1    D.SFDIT           FWA OF AREA LIST 
          SA2    D.EFDIT           LWA+1
          SB2    X1 
          SB3    X2 
          EQ     B2,B3,LDPS21      IF NO ERRORS 
  
          MX6    0
          SA6    D.NOERR           SET NO. OF ERRORS TO ZERO
  
          CALLF  BUGSOUT,B5   GO CHECK FOR ERRORS 
  
 LDPS21   SB1    1
          WRITER =XF.RLST 
          REWIND =XF.RLST 
  
*         IF REFERENCE MAP OPTION SELECTED (R .NE. 0), TERMINATE THE
*         REFERENCES BLOCK (WRITTEN BY -ADDREF-) ON THE *REFMAP* FILE 
*         AND COPY THE COMMON AND EQUIVALENCE TABLES TO THE FILE. 
*         THE REFERENCES BLOCK TERMINATOR IS ONE OR MORE ZERO WORDS.
*         SINCE THE REFERENCES BUFFER *RBUF* IS CLEARED TO ZEROS AFTER
*         EACH WRITE TO *REFMAP*, AND SINCE -ADDREF- WRITES *RBUF* TO 
*         *REFMAP* IMMEDIATELY WHEN FULL, THE BLOCK TERMINATOR IS 
*         GUARANTEED AUTOMATICALLY BY DOING A FINAL WRITE OF *RBUF* TO
*         *REFMAP*. 
  
          SA1    RSELECT
          ZR     X1,LDPS2A         IF NO LONG MAP 
  
          ADDREF B0                TERMINATE THE CURRENT LINE 
          WRITEW =XF.RMAP,RBUF,RBUFL     TERMINATE REFERENCES 
          SA1    O.DIM
          SB6    =XO.CBT           (B6) = FWA COMMON BLOCK TABLE
          MX7    0
          SB2    X1+B1
          SA7    X1                ZERO LWA+1 OF EQV INFO 
          SB7    B2-B6
          WRITEW =XF.RMAP,B6,B7 
          WRITER =XF.RMAP 
          REWIND =XF.RMAP 
  
**        LOAD PASS 2 
  
 LDPS2A   SA1    =XN.ERROR
          NZ     X1,LDPS2C   IF ERRORS ( ANY TYPE ) 
          SA2    QFLAG
          ZR     X2,LDPS2B   IF ^ Q MODE
          SA3    R=FLAG 
          ZR     X3,=XFTNEND IF R = 0  ( NO REFMAP )
  
 #OVL     IFNE   .OVL,0 
 LDPS2AA  LOVER  OVL25       LOAD AND EXECUTE REFMAP
 #OVL     ENDIF 
  
 LDPS2B   BSS    0
  
 #OVL     IFNE   .OVL,0 
          SA1    PROGRAM
          ZR     X1,LDPS2AA  IF BLOCKDATA, SKIP (2,2) OVERLAY...
 #OVL     ENDIF 
  
          LOVER  OVL22       LOAD AND EXECUTE PASS 2
  
 LDPS2C   SA3    =XIMFLG     FC TYPE ERRORS 
          ZR     X3,LDPS2D   IF NO FC TYPE ERROR
          MX6    0
          SA1    =XR=FLAG 
          SX3    X1-3 
          NZ     X3,LDPS2D   IF NOT R=3 
          SA6    =XL.COM     CHECKED BY REFMAP FOR FC TYPE ERRORS 
          SA6    =XL.EQV
 LDPS2D   SA1    =XN.FERR 
          SA2    =XNOLIST 
          BX6    X1+X2
          ZR     X6,LDPS2B   IF NO FE ERRS .AND. IN NOLIST MODE 
  
          LOVER  OVL23       LOAD ERROR MESSAGE OVERLAY 
          TTL    P S 1 C T L  -  SUBROUTINES
          TITLE              ADDREF - PASS 1 REF MAP ACCUMULATION 
*** 
*         ADDREF - ADD REFERENCE TO THE REFERENCE TABLE 
* 
*         ON ENTRY: 
*                B1 = ORDINAL OF THE SYMBOL TO BE ADDED 
*                X2 = REFERENCE/DEFINITION BITS 
* 
*         NOTE: CALL ADDREF(0,0) TERMINATES A LINE
* 
*         ADDREF IS CALLED BY THE STATEMENT PROCESSORS WHEN THE R 
*         OPTION IS SELECTED TO ADD A REFERENCE FOR A SYMBOL ( IN 
*         SYMTAB ONLY ).  THE REFERENCES ARE COLLECTED INTO LINES AND 
*         THE LINES ARE DUMPED TO THE REFMAP TABLE FOR PROCESSING AT
*         THE END OF PASS2 WHEN ALL LOCAL SYMBOLS HAVE BEEN ASSIGNED
*         ADDRESS"S.
* 
*         EACH LINE CONSISTS OF A NUMBER OF 15 BIT PARCELS TERMINATED 
*         BY 1 OR MORE ZERO PARCELS TO FILL OUT THE LAST WORD.
*         THE FIRST PARCEL HOLDS THE LINE NUMBER ( IN BINARY ), 
* 
*         SUCEEDING PARCELS HAVE THE FORMAT:  
*         1/0,2/REF,DEF CODE,12/SYMTAB ORDINAL
* 
*         THE LOW ORDER PARCEL OF THE LAST WORD CONTAINS THE NUMBER OF
*         PARCELS IN THE LAST WORD IN THE FORMAT: 3/CPC,12/0
* 
*         REFERENCE LINES ARE ACCUMULATED IN *RBUF* UNTIL IT IS FULL. 
*         THEN, A TERMINATOR IS PLACED IN THE 4TH PARCEL OF THE LAST
*         REFERENCE LINE (AS IF THE SOURCE LINE HAD ENDED) AND THE
*         BUFFER IS FLUSHED TO -REFMAP-.  -ADDREF- CONDITIONS ARE RESET 
*         TO INITIAL.  ANY REMAINING REFERENCES IN THE CURRENT SOURCE 
*         LINE ARE PROCESSED AS IF A NEW LINE HAD BEGUN.  THIS AVOIDS 
*         SOME UNPLEASANT PROCESSING RESTART PROBLEMS IN PASS 2.
  
  
 ADDREF   ENTRY. **          ** ENTRY/EXIT ** 
          LX2    1+12        POSITION REF/DEF BITS
          SX1    X2+B1       (X1) = 45/0, 2/REF/DEF, 1/0, 12/ORDINAL
          SA4    RBUFN       (X4) = NR WORDS IN *RBUF*
          SA3    RBUFP       (X3) = CURRENT SHIFT COUNT 
          SA5    RBUF+X4     (X5) = PARTIAL *RBUF* ENTRY
          SB1    1
          ZR     X1,ADD5     IF TERMINAL CALL 
          PL     X3,ADD2     IF INTERMEDIATE CALL 
  
*         PROCESS INITIAL CALL (NEW SOURCE LINE OR *RBUF* EMPTY). 
  
          SA2    DUKE        SOURCE LISTING LINE NUMBER (BINARY)
          SX3    30          INITIAL SHIFT COUNT
          LX2    45 
          BX5    X2          BEGIN NEW ENTRY
  
*         PROCESS INTERMEDIATE CALL.
  
 ADD2     SB2    X3 
          SX6    X3-15       SHIFT COUNT - 15 
          LX1    B2 
          BX7    X5+X1       MERGE NEW REFERENCE
          SB2    X6 
          SA6    A3          UPDATE SHIFT COUNT 
          SA7    A5          NEW REFERENCE TO *RBUF*
          GT     B2,B0,ADDREF      IF NEW REF NOT IN PARCEL 3 OR 4, EXIT
  
*         PROCESS PARCEL 3/4 ENTRIES. 
  
          SX6    X4+B1       BUF WD COUNT + 1 
          PL     B2,ADD3     IF NEW REF IN PARCEL 3 
  
*         NEW REF IN PARCEL 4 - UPDATE WORD COUNT AND RESET SHIFT COUNT.
  
          SX7    45 
          SA6    A4          UPDATE WORD COUNT
          SA7    A3          RESET SHIFT COUNT
          EQ     ADDREF 
  
*         NEW REF IN PARCEL 3 - CHECK FOR FULL BUFFER.
  
 ADD3     AX6    6           BUF WD COUNT / (RBUFL=100B)
          NO
          ZR     X6,ADDREF   IF BUFFER NOT FULL, EXIT 
  
*         BUFFER IS FULL.  TERMINATE CURRENT REF/DEF ENTRY STRING.
  
          SX6    3S12        ACTIVE PARCEL COUNT = 3
          BX7    X7+X6
          SA7    A5 
  
*         DUMP BUFFER TO *REFMAP*, AND SET ENTRY CONDITIONS *INITIAL*.
  
 ADD4     WRITEW =XF.RMAP,RBUF,RBUFL
          SETZERO   RBUF,RBUFL+1   CLEAR *RBUF* AND WORD COUNT
          MX6    -1 
          SB5    B1 
          SA6    RBUFP       SET SHIFT COUNT TO *INITIAL* 
          EQ     ADDREF      EXIT 
  
*         PROCESS TERMINAL CALL.
  
 ADD5     MI     X3,ADDREF   IF NO ENTRIES FOR CURRENT LINE 
          MX7    -1 
          SX6    X4+B1       BUF WD COUNT + 1 
          SX1    3
          SA7    A3          SET SHIFT COUNT TO *INITIAL* 
          IX3    X3+X1       SC+3 
          AX3    4           (SC+3)/16
          IX1    X1-X3       3-(SC+3)/16 = ACTIVE REFS IN CURR ENTRY WRD
          SA6    A4          UPDATE BUF WD COUNT
          LX1    12 
          BX7    X5+X1       MERGE PARCEL COUNT IN ENTRY
          AX6    6           BUF WD COUNT / (RBUFL=100B)
          SA7    A5          TERMINATED ENTRY TO *RBUF* 
          ZR     X6,ADDREF   IF BUFFER NOT FULL, EXIT 
          EQ     ADD4 
  
  
 RBUFL    =      100B        LENGTH OF *RBUF* 
 RBUF     BSSZ   RBUFL       REFERENCES BUFFER
 RBUFN    DATA   0           NUMBER OF WORDS IN *RBUF*
 RBUFP    DATA   -1          SHIFT COUNT FOR NEXT REF/DEF PARCEL ENTRY
          TITLE              PASS 1 TABLE MANAGER 
          EXT    PHASE,NAF,LTN,LOWCORE,FWAWORK,LWAWORK,T.FPBL,N.FP
          EXT    ORIGINS,SIZES,ROOMS,TINFO,NAFVEC 
          EXT    MOVE,FATALER 
  
 E.CTO    EQU    36                TABLE OVERFLOW 
  
 SLL      MACRO  XR                SET LOOP LIMITS FOR TABLE MANAGER
          IF     -REG,XR,1
          SA5    NAF
          SB2    X5                N.FT 
          AX5    30 
          SB3    B2+X5             N.LT + 1 
          ENDM
  
*** 
*         ALLOC - ADJUST TABLE ALLOCATION FOR TABLE N 
*         MAY MOVE TABLES UP OR DOWN IN CORE AND STRIP EXCESS 
*         ALLOCATIONS TO BUY SPACE. 
* 
*         ON ENTRY: 
*                A0 = TABLE NUMBER
*                X5 < 0 THEN L.TBL = S.TBL = -X5
*                X5 \ 0 THEN THE ALLOCATION WILL BE ADJUSTED SO THAT
*                S.TBL \ X5 + L.TBL  ON EXIT, IF THE SPACE IS AVAILABLE 
* 
*         ON EXIT:  
*                A0 = TABLE NUMBER
*                X7 " 0 IF SPACE ALLOCATED , ELSE 0 
* 
 ATA0     BX6    -X5
          SA6    SIZES+A0 
          SA6    ROOMS+A0 
 ALLOC    ENTRY.
 ATA      EQU    ALLOC
  
          NG     X5,ATA0           IF NEGATIVE
          SA3    SIZES+A0 
          SA4    ROOMS+A0 
          IX6    X4-X3             UNUSED SPACE 
          IX5    X5-X6             REMOVE FROM REQUEST
          NG     X5,ATA            IF NOTHING TO DO 
          SA1    FWAWORK
          SA2    LWAWORK
          SB6    X5 
          FX7    X2-X1             SA = SPACE AVAILABLE ( IN WORKING STO
          SX6    X4+B6             INCREMENT ROOMS
          IX0    X5-X7
          SA6    A4 
          PL     X0,ATA2           IF SN \ SA 
  
*         SPACE IN WORKING STORAGE, MOVE TABLES ABOVE THIS ONE UP 
  
 ATA1     SA3    LTN
          SB2    A0 
          IX6    X5+X1             UPDATE FWAWORK 
          SB3    X3 
          SA6    A1 
          EQ     B2,B3,ATA         IF THIS IS THE LAST TABLE
          RJ     MTU
          MX7    1
          EQ     ATA
  
*         COMPUTE EXCESS SPACE AVAILABLE
*         = FWAWORK - LOWCORE - SIGMA( ROOMS(I) ) + SIGMA( EXC(I) ) 
*         EXC(I) = 0 IF SIZES(I)+40B \ ROOMS(I) , ELSE = TO DIFF
  
 ATA2     SA3    LOWCORE
          SLL    NAF
          IX5    X1-X3             F-LC 
          SB4    ROOMS
          SB1    SIZES
          SA2    B4+A0             ROOMS(N) 
          SA1    B1+A0             SIZES(N) 
          BX6    X2 
          SA6    A1                SIZE(N) = ROOMS(N) 
  
 ATA3     SA4    B4+B2             ROOMS(I) 
          SA3    B1+B2             SIZES(I) 
          IX5    X5-X4
          SB2    B2+B5             I = I+1
          SX6    X3+40B            SIZES(I)+40B 
          IX2    X6-X4
          PL     X2,ATA4           IF NOT ENOUGH OF AN EXCESS 
          IX5    X5-X2
          SA6    A4                ADJUST R(I)
 ATA4     LT     B2,B3,ATA3 
          BX6    X1                RESTORE SIZES(N) 
          SA6    A1 
  
          IX0    X7+X5
          NG     X0,ATAX           IF NOT ENOUGH SPACE AVAILABLE
  
*         SHRINK TABLES BELOW THIS ONE
  
          SB4    X5                - IF WE HAVE TO INCREMENT FWAWORK
  
          SA1    LOWCORE     FWA TABLE AREA 
          SLL    NAF
          BX6    X1 
          SB6    B3          SAVE NR OF (LAST TABLE + 1)
          SB3    A0 
          RJ     MTD         MOVE TABLES DOWN (0, TBLN, LOWCORE)
          SA1    FWAWORK     WSA ORIGIN 
          SX5    -B4         WSA LENGTH INCREMENT/DECREMENT 
          IX7    X1+X5
          MI     B4,ATA1     IF WSA MUST BE SHRUNK
          SA7    A1          EXPAND WSA 
          SB2    A0+B5
          EQ     B2,B6,ATA   IF NO TABLES TO MOVE UP
* 
*         PACK UP TABLES ABOVE THIS ONE.
* 
          SB3    B6-B5       NR OF LAST TABLE 
          BX6    X1 
          SB4    B3          SAVE LAST TABLE NR 
          RJ     MTU         MOVE TABLES UP (TBLN+1, NRTBLS,OLD FWAWORK)
          SA1    ORIGINS+A0 
          SA2    ROOMS+A0 
          SB3    B4 
          IX6    X1+X2
          RJ     MTD         MOVE TABLES DOWN (TBLN+1, NRTBLS,
*                               ORIGINS(N) + ROOMS(N).
          MX7    1
          EQ     ATA
  
*         ERROR EXIT - INSUFFICIENT STORAGE 
  
 ATAX     SA1    TINFO+A0 
          MX7    0
          LX1    1
          NG     X1,ATA            IF RETURN TO CALLER TABLE
  
          ENTRY  CTBLOVL           ENTRY FOR COMPILER TABLE OVERFLOW
 CTBLOVL  SA2    PHASE
          SA3    ERVEC+X2          PHASE NAME 
          MX4    0
          SB6    E.CTO             COMPILER TABLE OBERFLOW
          AX2    1
          NZ     X2,FATALER        IF NOT PROCESSING DECLARATIVES 
          SX6    0
          SA6    =XL.COM
          SA6    =XL.EQV
          EQ     FATALER
  
 ERVEC    DATA   8R PHASE 1 
          DATA   8R AUX TAB 
          DATA   8R PHASE 2 
          TITLE              MTU, MTD - MOVE TABLES UP OR DOWN
*** 
*         MTU - MOVE TABLES UP IN CORE
* 
*         ON ENTRY: 
*                X6 = HIGH LIMIT OF MOVE
*                B2,B3 = LOOP LIMITS
* 
 MTU
 MTU1     SA4    ROOMS+B3 
          SA2    ORIGINS+B3 
          SA1    SIZES+B3 
          IX7    X6-X4
          SB3    B3-B5             DECREMENT INDEX
          SA7    A2                NEW ORIGIN 
          BX0    X7 
          IX5    X7-X2             NEW ORGIN - OLD ORIGIN 
          BX3    X7 
          ZR     X1,MTU2           IF LENGTH = 0
          ZR     X5,MTU2           SKIP GO NOWHERE MOVE 
          MOVE   X1,X2,X3 
 MTU2     BX6    X0 
          GT     B3,B2,MTU1 
          EQ     MTU
          SPACE  3
*** 
*         MTD - MOVE TABLES DOWN IN CORE
* 
*         ON ENTRY: 
*                X6 = LOW CORE LIMIT
*                B2,B3 = LOOP LIMITS
* 
 MTD
 MTD1     SA4    ROOMS+B2 
          SA2    ORIGINS+B2 
          SA1    SIZES+B2 
          BX3    X6 
          IX0    X4+X6             ADVANCE LOW
          SA6    A2 
          IX5    X3-X2             NEW ORIGIN - OLD ORIGIN
          ZR     X1,MTD2           SKIP EMPTY TABLE 
          ZR     X5,MTD2           AVIOD NULL MOVE
          MOVE   X1,X2,X3 
 MTD2     SB2    B2+B5
          BX6    X0 
          LE     B2,B3,MTD1 
          EQ     MTD
          TITLE              ROUTINES FOR TABLE ALLOCATION
*** 
*         ADDWD - ADD A WORD TO THE END OF A MANAGED TABLE
* 
*         ON ENTRY: 
*                A0 = TABLE NUMBER
*                X1 = WORD TO BE ADDED    ( AND B5 = 1 )
* 
*         ON EXIT:  
*                X6 = WORD THAT WAS ADDED 
*                X7 = NEW TABLE LENGTH ( " 0 ) OR 0 IF NO SPACE AVAIL 
* 
  
 ADDWD1   IX0    X3+X4
          SX7    X4+B5             SIZES(I) = SIZES(I)+1
          SA6    X0 
          SA7    A4                UPDATE LENGTH
 ADDWD    ENTRY.
          SA4    SIZES+A0 
          SA5    ROOMS+A0 
          BX6    X1 
          IX2    X4-X5             S - R
          SA3    ORIGINS+A0 
          NG     X2,ADDWD1         IF SIZES(I) < ROOMS(I) 
  
*         ALLOCATE MORE SPACE 
  
          SA5    TINFO+A0          INCREMENT FOR THIS TABLE 
          SA6    ADDWDT            SAVE WORD
          SX5    X5 
          RJ     ATA               ADJUST ALLOCATION
  
          SA1    ADDWDT 
          SA3    ORIGINS+A0 
          SA4    SIZES+A0 
          BX6    X1 
          NZ     X7,ADDWD1         IF WE GOT THE SPACE
          EQ     ADDWD
  
 ADDWDT   BSS    1
          EJECT 
*** 
*         ALLAE - ALLOCATE ALMOST EVERYTHING FOR TABLE N
* 
*         ON ENTRY: 
*                A0 = TABLE NUMBER
* 
 ALLAE    ENTRY.
          SA1    LOWCORE
          SA2    FWAWORK
          SA3    LWAWORK
          SLL    NAF
          IX0    X2-X1             AREA OCCUPIED BY THE TABLES
          IX3    X3-X2             SA IN WORKING STORAGE
          SB7    X3                B7 = L-F 
          SB4    ROOMS
          SB1    SIZES
          SA2    B4+A0
          SA1    B1+A0
          BX7    X2 
          SA7    A1 
          SX6    40B
  
 ALLAE1   SA4    B4+B2             ROOMS(I) 
          SA3    B1+B2             SIZES(I) 
          IX0    X0-X4
          FX5    X3+X6             S(I)+40B 
          IX4    X5-X4
          IX2    X5-X4
          IX0    X0-X2
 ALLAE2   SB2    B2+B5
          LT     B2,B3,ALLAE1 
  
          BX6    X1 
          SA6    A1                RESTORE SIZES(N) 
  
          SX5    B7-B5             (LWAWORK-FWAWORK) - 1
          SX7    X0-400B
          NG     X7,ALLAE3         IF WE CANT BUY AT LEAST 400B WORDS 
*                                  DONT FORCE A REPACKING 
          IX5    X5+X0
 ALLAE3   RJ     ATA               ADJUST ALLOCATION
          EQ     ALLAE
          TITLE              INITBL - INITIALIZE TABLES 
*** 
*         INITBL - INITIALIZE TABLES FOR A PHASE
*         SETS LOWCORE,PHASE NUMBER AND INITIALIZES TABLE VECTORS 
* 
*         ON ENTRY: 
*                X6 = NEW LOW CORE LIMIT
* 
  
 INITBL   ENTRY.
          SA1    LOWCORE
          SA2    PHASE
          SA6    A1                SET NEW LOWCORE LIMIT
          ZR     X1,INIT0          IF START OF PHASE 1
          SX7    X2+B5
          SA7    A2                PHASE = PHASE+1
          ZR     X2,INIT1          IF START OF DPCLOSE
          RJ     PTD               PHASE 2 - PACK TABLES TO LOW CORE
          SA6    LOWCORE           SET FWA OF ACTIVE TABLES *** 
          EQ     INIT1
  
 INIT0    SA6    FWAWORK
          SA4    N.FP 
          BX7    X4 
          LX7    18 
          SA7    T.FPBL 
  
*         INITIALIZE THE NEW TABLES 
  
 INIT1    SA4    PHASE
          SA5    NAFVEC+X4
          BX7    X5 
          SA7    NAF               NAF = NAFVEC(PHASE)
          SLL    X5                SET LOOP LIMITS
          SA4    FWAWORK
          BX6    X4 
          SX7    B3-B5
          SA7    LTN               SAVE NUMBER OF LAST ACTIVE TABLE 
  
 INTB1    SA1    ORIGINS+B2 
          SA2    TINFO+B2 
          SB2    B2+B5
          NZ     X1,INTB1          IF INITIALIZED 
          SA6    A1                SET FWA
          AX2    18 
          SX7    X2                INITIAL ALLOC
          SA7    ROOMS-1+B2 
          IX6    X6+X7             UPDATE FWAWORK 
          MX7    0
          SA7    SIZES-1+B2        SIZES(I) = 0 
          LT     B2,B3,INTB1
  
          SA6    FWAWORK           UPDATE FWAWORK 
          EQ     INITBL 
          TITLE              PTU, PTD - PACK TABLES TO HIGH OR LOW CORE 
*** 
*         PTU - PACK TABLES UP TO HIGH CORE 
* 
*         ON ENTRY: 
*                X1 = NUMBERS OF TABLES TO BE SAVED 
*                IN FORMAT: 60-6*N/0,6/TBLN+1,...,6/TBL1+1
* 
 PTU      ENTRY.
          SA2    SYMEND 
          BX0    X1 
          SB6    X2                B6 = LWAWORK 
  
 PTU1     MX7    60-6 
          BX6    -X7*X0            TABLE NUMBER + 1 
          AX0    6
          SX5    B6 
          SA1    SIZES-1+X6 
          SA2    ORIGINS-1+X6 
          IX6    X5-X1             NEW ORIGIN 
          SA6    A2 
          BX3    X6 
          SB6    X6 
          ZR     X1,PTU2           SKIP EMPTY TABLE 
          MOVE   X1,X2,X3 
 PTU2     NZ     X0,PTU1           IF MORE TO GO
          SX6    B6-B5
          SA6    LWAWORK
          EQ     PTU
  
*** 
*         PTD - PACK TABLES TO LOW CORE 
* 
*         ON ENTRY:   
*                X6 = LOW CORE LIMIT
* 
 PTD
          SLL    NAF
          SB6    X6                B6 = LOW 
 PTD1     SA1    SIZES+B2 
          SA2    ORIGINS+B2 
          SX6    B6 
          BX7    X1 
          SA6    A2                NEW FWA
          SB6    B6+X1             UPDATE LOW 
          SA7    ROOMS+B2          ROOMS(I) = SIZES(I)
          ZR     X1,PTD2           IF NOTHING TO MOVE 
          IX0    X2-X6
          BX3    X6 
          ZR     X0,PTD2           IF OLD ORG = NEW ORG 
          MOVE   X1,X2,X3 
 PTD2     SB2    B2+B5
          LT     B2,B3,PTD1 
          SX6    B6 
          SA6    FWAWORK           UPDATE FWAWORK 
          EQ     PTD
  
 WRM      SPACE  4,14 
**        WRM - WRITE R-MACRO CALL TO *RLIST* FILE. 
* 
*         INSERTS CURRENT VALUE OF *NRLN* IN HEADER WORD. 
* 
*         ENTRY  (B7) = FWA OF R-MACRO CALL 
* 
*         EXIT   R-MACRO WRITTEN TO RLIST FILE. 
* 
*         USES   X - 0, 3, 4, 5, 6
* 
*         CALLS  WRITEW 
  
 WRM      ENTRY. ** 
          SA4    B7 
          MX0    -R1.RIL
          SA3    NRLN 
          BX5    X0*X4
          AX4    R1.INP 
          IX6    X3+X5       ADD CURRENT VALUE OF NRLN TO HEADER WORD 
          SA6    B7 
          SB1    1
          WRITEW =XF.RLST,A4,X4+B1
          SB5    1
          EQ     WRM
          END 
