*DECK     LSTPRO
          IDENT  LSTPRO 
 LSTPRO   TITLE  LSTPRO -    BATCH CONTROL AND SYMBOL TABLE SEARCH
*CALL     SSTCALL 
          SPACE  3
 B=LSTPR  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
  
 O.SYMTAB EQU    12B               FWA OF THE SYMBOL TABLE
 L.SYMTAB EQU    13B               LWA+1 OF THE SYMBOL TABLE
 DUKE     =      RA.SSW+37B        CURRENT STATEMENT LINE NR (BINARY) 
          SPACE  3
          ENTRY  LABEL
          ENTRY  SYMBOL 
          EXT    CP.PD,LCP.PS,PDFLAG
          EXT    RS.PD
          EXT    FV.LGO,F.COMPS,F.IN,F.LGO,F.OPT
          EXT    F.OUT,F.RLST,F.RMAP
          EXT    L.TITL,O.TITL,TL.DATE,TL.PAGE,TL.TIME
          EXT    DFLAG,MLOP=R,UFLAG 
 RCBUFS   TITLE  RLIST/LGO AND COMPS FILE BUFFERS OR HOLDING BUFFERS
*CALL     IOBUFL
  
 #RM      IFEQ   CP#RM,0
  
 O.RLST   BSS    LC.RLST
 O.CMPS   BSS    LC.CMPS
  
 #RM      ELSE
  
 O.CMPS   BSS    0
 O.RLST   BSS    LH.RLST
  
 #RM      ENDIF 
  
 O.LGO    EQU    O.RLST 
 SYMBOL   TITLE  SYMBOL TABLE SEARCH ROUTINES 
*** 
*         SYMBOL AND LABEL ARE THE SEARCH-AND-ENTER ROUTINES FOR THE
*         SYMBOL TABLE. ENTRY IS MADE WITH THE SYMBOL (LABEL) FOR WHICH 
*         THE TABLE IS TO BE SEARCHED IN X1.  THIS SYMBOL SHOULD BE 
*         LEFT JUSTIFIED WITH BLANK FILL IN BITS 00-47. 
*                                         B7+1 AT ENTRY CONTAINS THE
*         ADDRESS TO WHICH CONTROL SHOULD BE RETURNED IN THE EVENT
*         THAT THE SYMBOL IS IN TABLE. B7 CONTAINS THE ADDRESS TO WHICH 
*         CONTROL SHOULD BE RETURNED IN THE EVENT THAT THE SYMBOL IS
*         NOT IN THE TABLE. IN THE LATTER CASE A NEW ENTRY WILL BE MADE 
*         FOR THE SYMBOL AND THE APPROPRIATE CHANGES AND ADDITIONS MADE 
*         TO THE LINKING INFORMATION. 
* 
*         ON EXIT:  
*                A0 = FWA OF THE SYMBOL TABLE 
*                A1,X1 = ADDRESS AND CONTENTS OF WORD 1 OF THE ENTRY
*                A2,X2 = ADDRESS AND CONTENTS OF WORD 2 OF THE ENTRY
*                B1 = ORDINAL OF THE ENTRY
*                B2 = 2*B1  AND  B5 = 1 
* 
*         IN ADDITION IF THIS IS THE FIRST OCCURANCE OF A NAME, THEN: 
*                X7 = 0 AND X6 = NATURAL TYPE S P.TYP 
* 
*         IN DEBUG MODE, REPEATED OCCURANCES OF A NAME WITH TYPE
*         "T.DBG" ,  ( NAME FIRST MENTIONED IN A "DEBUG" STMT" )
*                X2 = .NOT.MASK(48).A.WORDB  ( P- FIELD ONLY )
*                X6 = SAVED NATURAL TYPE
*                X7 = THE DEBUG FIELD BITS IN WORD B ( " 0 )
*                AND CONTROL IS RETURNED TO THE FIRST OCCURRANCE EXIT 
  
  
          TITLE              SYMBOL - SEARCH SYMBOL TABLE 
 SYMBOL   LX1    12                LEFT JUSTIFY SYMBOL (BIT 59) 
          BX4    X1                BEGIN HASHING IN X4
          SA3    SYMORD            .BEGIN LOAD OF CURRENT NEXT ORD
          LX4    21                .HASH
          SB1    7                 .  TWO 
          BX4    X1-X4             .    21-BIT
          LX6    B1,X4             .      BYTES 
          SA2    O.SYMTAB          FWA OF SYMTAB
          BX4    X6-X4             .HASH
          LX7    B1,X6             .  THREE 
          SB1    X3                NEXT ORDINAL 
          BX4    X7-X4             .    7-BIT BYTES 
          MX0    53                .      BYTES 
          LX4    7                 .
          SB5    1
          SA0    X2                START OF SYMBOL TABLE TO A0
          BX4    -X0*X4            .X4 NOW HAS HEAD-OF-LIST POINTER 
          MX5    42                .42-BIT MASK IN X5 
          SB2    B1+B1             2*NEXT ORDINAL 
          SA2    X4+SLIST          .GET ORDINAL FOR HEAD OF LIST
 SLCOMM   SB3    A0-B2             CURRENT NEXT ADDRESS IN B3 
          BX0    X1*X5             .MASK OFF SYMBOL IN X0 
          MX3    48                .48-BIT MASK IN X3 
          SB4    X2                .HEAD OF LIST ORDINAL IN B4
          NE     B4,PRETOP         .IF LIST NON-EMPTY,SEARCH
          SX7    B1                HEAD OF LIST 
 LSTSW1   BX6    X0                .P- BOTH EQUAL TO ZERO           LSTS
          SB6    B1-4096           TEST MAXIMUM TABLE SIZE
          SA6    B3                STORE WORD A 
          SA7    A2                STORE LIST HEAD OR NEXT LINK 
          ZR     B6,STFULL         IF SYMBOL TABLE FULL 
          MX7    0
          SX6    A6-2              DECREASE SYMEND BY 2 
          SA7    A6-B5             STORE WORD B 
          SA1    A0-B2             SETUP A1,X1 WITH WORD A
          SA6    L.SYMTAB          UPDATE SYMEND
          SX6    B1+B5             INCREASE SYMORD BY 1 
          SA2    A1-B5             SETUP A2,X2 WITH WORD B
          SA6    SYMORD 
          NG     X1,RETRN1         IF A LABEL 
          RJ     NTYPE             GET THE NATURAL TYPE 
 RETRN1   JP     B7 
  
* 
*         MAIN SEARCH LOOP TO SCAN DOWN A SYMBOL CHAIN
* 
  
 PRETOP   SB2    B4+B4             2*HEAD OF LIST ORDINAL 
          SA2    A0-B2             LOAD THE FIRST SYMBOL
 TOP      BX4    X5*X2             EXTRACT THE SYMBOL 
          IX6    X4-X0
          ZR     X6,FOUND          IF SYMBOLS ARE THE SAME
          BX7    -X3*X2            ISOLATE P+ 
          SB4    X7                ORDINAL OF NEXT LINK 
          ZR     X7,ENTER          IF END OF CHAIN
          SB2    B4+B4             2*ORDINAL
          SA2    A0-B2             LOAD THE NEXT MEMBER OF CHAIN
          EQ     TOP
  
*         SETUP TO LINK A NEW SYMBOL ONTO THE CAHIN 
  
 ENTER    SX4    B1                NEXT ORDINAL 
          BX7    X2+X4             INSERT NEW LINK
          SB2    B1+B1             2*ORDINAL
          EQ     LSTSW1            GO PERFORM REST OF PROCESSING
          TITLE              LABEL - LABEL SEARCH ROUTINE 
*** 
*         LABEL - SEARCH AND ENTER ROUTINE FOR SYMBOLIC LABELS
* 
 LABEL    LX1    12                LEFT JUSTIFY LABEL 
          BX4    X1                BEGIN HASHING IN X4
          SA3    SYMORD            .BEGIN LOAD OF CURRENT NEXT ORD. 
          LX4    15                HASH BITS 24-53
          SB1    5
          BX4    X4-X1             INTO TWO 15-BIT
          LX6    B1,X4             CHUNKS 
          SA2    O.SYMTAB 
          BX4    X6-X4             HASH THREE 
          LX7    B1,X6             5-BIT
          SB1    X3                NEXT ORDINAL 
          BX4    X4-X7             BYTES. 
          SA0    X2                START OF SYMBOL TABLE TO A0
          SB5    1
          SB2    B1+B1             2*ORDINAL
          MX0    55                MASK IN X0 
          LX4    11 
          BX6    -X0*X4            HASHED 5-BIT SYMBOL (POINTER) IN X6
          MX5    36                .36-BIT MASK IN X5 
          SA2    LLIST+X6          LOAD HEAD OF LIST
          EQ     SLCOMM            .GO TO COMMON SEARCH ROUTINE 
  
*** 
*         ERROR EXIT
* 
 STFULL   SB6    -54               (ERROR NO. 54 = SYMBOL TABLE OVERFLOW
 LFER     ENTRY.                   JUMP TO FATALER IN ERPRO PLACED HERE 
          SPACE  3
*         FOUND EXIT
  
 FOUND    SA1    A2                SETUP WORD A A1,X1 
          SB1    B4                ORDINAL
          SA2    A1-B5             WORD B 
 LSTSW3   JP     B7+1 
  
*         X4 = TYPE FIELD - T.UDV IF IN DEBUG MODE
  
+         ZR     X4,*+1            IF AN UNUSED DEBUG VARIABLE
          JP     B7+1 
  
          MX5    L.DBGI 
          LX5    L.DBGI+P.DBGI
          BX7    X5*X2             X7 = DEBUG FIELD BITS
          MX3    48 
          LX6    X2 
          BX2    X2-X2             CLEAR WORD B 
          LX6    P.TYP-P.SNT
          BX6    X0*X6             X6 = SAVED NATURAL TYPE
          JP     B7                RETURN TO FIRST TIME EXIT
          TITLE              NTYPE - GET NATURAL TYPE OF A VARIABLE 
*** 
*         NTYPE - DETERMINE NATURAL TYPE OF A VARIABLE
* 
*         ON ENTRY: 
*                X1 = NAME LEFT JUSTIFIED 
* 
*         ON EXIT28 
*                X0 = TYPE , RIGHT ADJUSTED 
*                X6 = TYPE S P.TYP
* 
*         USES   A3,X3,B3 
* 
  
 NTYPEX   SB3    P.TYP
          LX6    B3,X0             TYPE TO X6 
  
 NTYPE    ENTRY.
          SB3    54 
          AX0    B3,X1             POSITION TO FIRST CHARACTER
          SA3    IMPTYP 
          SB3    X0 
          MX0    0                 SET TYPE TO LOGICAL
  
 NTYPEL   LX3    B3,X3             SHIFT BIT TABLE BY CHARACTER 
          NG     X3,NTYPEX         IF A HIT 
          SX0    X0+B5             BUMP TYPE
          LX3    26                CHECK LOWER TYPE 
          NG     X3,NTYPEX
          SA3    A3+B5             NEXT WORD
          SX0    X0+B5
          EQ     NTYPEL 
          SPACE  3
*** 
*         IMPTYP - IMPLICIT TYPE BIT TABLE
* 
  
          ENTRY  IMPTYP 
 IMPTYP   VFD    27/0              LOGICAL
          VFD    8/0,6/77B,19/0    INTEGER
          VFD    9/377B,6/0,12/7777B
          VFD    33/0              DOUBLE 
          VFD    27/0              COMPLEX
          VFD    33/0 
  
*** 
*         SAVE NATURAL REAL BITS
*         IF NEEDED, NATURAL INTEGER BITS WILL BE COMPUTED IN LINE
  
          ENTRY  NRB
 NRB      VFD    9/377B,6/0,12/7777B,30/0 
 RSSW     EJECT 
**        RSSW - PLUG SWITCHES IN *SYMBOL* FOR *LISTIO* AND *FAX*.
* 
*         SET SWITCHS SO THAT SYMBOL AND LABEL DO NOT ADD AN ENTRY
*         TO SYMTAB IF THE NAME IS NOT FOUND. 
* 
*         THIS CODE IS NECESSARY SINCE THE NAMES OF THE BASIC EXTERNAL
*         FUNCTIONS ARE INITIALLY ENTERED IN "SYMTAB" WITHOUT 
*         A TRAILING DOLLAR SIGN OR PERIOD. 
*         IF "LSTPRO" RETURNS TO THE NOT FOUND EXIT, THEN FAX WILL
*         SEARCH THE TABLE OF EXTERNAL NAMES THAT IT HAS CONSTRUCTED
* 
*         KSSW - RESTORE SYMBOL CODE TO ORIGINAL PASS 1 STATE 
* 
 RSSW     ENTRY.
          SX6    027B 
          NO
          LX6    51                FORM / JP B7 / INSTRUCTION 
          PLUG   AT=LSTSW1,FROM=X6
          EQ     RSSW 
  
 KSSW     ENTRY.
          PLUG   AT=LSTSW1,FROM=KLS1N,FREG=3,SREG=7 
          EQ     KSSW 
  
  
  
 KLS1N    BX6    X0 
          SB6    B1-4096
          SA6    B3 
  
 KLS.D    MX0    L.TYP             PLUG FOR DEBUG MODE
          BX3    X0*X2
          IX4    X0-X3
          NO
          SPACE  3
          TITLE  BATCH COMPILATION CONTROL
 LSTPRO$  EJECT 
*         IF (BREAK=20) WAS SELECTED, ENTRY TO OVERLAY(2,0) WILL BE TO
*         *FTN20-1* TO CALL THE COMPILE-TIME INTERACTIVE DEBUG PACKAGE. 
  
 FTN20    BREAK 
  
          ENTRY  FTN20
 FTN20    BSS    0           ** LOADER ENTRY POINT ** 
          SB1    1
  
  
**        POST REPRIEVE REQUEST.
* 
 .T       IFNE   TEST,0 
          SA1    RA.SSW 
          LX1    59-11
          MI     X1,LST2     IF SENSE SWITCH 6 ON, SKIP *RPV* REQUEST 
 .T       ENDIF 
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
 .T       IFEQ   TEST,0 
          SYSTEM RPV,RCL,XJP,23BS6
 .T       ELSE
          SYSTEM RPV,RCL,XJP,37BS6
 .T       ENDIF 
 #OS      ELSE
          REPRIEVE  XJP      POST REPRIEVE REQUEST
 #OS      ENDIF 
  
  
**        OPEN FILES. 
* 
 LST2     CALL   OPF         OPEN FILES 
          SA1    =XCOMRET 
          PL     X1,LST2A    IF FIRST TIME THROUGH
          SA2    CP.CARD
          ZR     X2,FTNEND   IF COMPASS DETECTED EOR
  
 LST2A    BSS    0
  
 #RM      IFNE   CP#RM,7
          SA1    =XPMDFLAG
          ZR     X1,USKIP1
          OPEN   ZZZZZSY,WRITENR,R
          SA5    =XFL 
          BX6    X5 
          SA6    ZZZZZSY+4   LIMIT = FL 
          SX6    2
          SA6    ZZZZZSY+1   FIRST = 2
 USKIP1   BSS    0
 #RM      ENDIF 
  
  
 LST3     BSS    0           ** BATCH COMPILATION RESTART ENTRY POINT **
  
  
  
**        INITIALIZE INTERNAL OPT LEVEL CELL TO CONTROL CARD VALUE. 
* 
          SA1    =XCO.OLVL
          BX6    X1 
          AX7    B1,X1
          SA6    OPTLVL      OPTLVL = CO.OLVL 
          SA7    OPT2        OPT2 = OPTLVL / 2
          SA1    =XCP.AFLS
          BX6    X1 
          SA6    =XPR.MXFL   PR.MXFL = CP.AFLS
  
  
**        LOAD AND EXECUTE PASS 1.
*         SELECT (2,1) OVERLAY IF DEBUG OFF, OR (2,4) IF ON.
* 
          SA1    DFLAG       (X1) = DEBUG OPTION CONTROL WORD 
          ZR     X1,LST4     IF DEBUG (D) OPTION OFF
          PLUG   AT=LSTSW3,FROM=KLS.D 
          LOVER  OVL24       LOAD AND EXECUTE (2,4) OVERLAY 
 LST4     LOVER  OVL21       LOAD AND EXECUTE (2,1) OVERLAY 
 OPF      EJECT 
**        OPF - OPEN FILES. 
* 
*         OPENS CMPS, IN, OUT AND RLST FILES.  IF CONTROL CARD OPTIONS
*         ARE ON, OPENS LGO AND RMAP FILES. 
*         THE OPT/DEBUG FILE IS OPENED BY THE (2,2)/(2,4) OVERLAY.
*         BUFFERS ARE ALLOCATED TO BLANK COMMON BEGINNING AT HIGH CORE
*         AND WORKING DOWN. 
*         (RECORD MANAGER ONLY) - FILE POSITIONING PARAMETERS ARE TAKEN 
*         FROM THE FITS.  THOSE PARAMETERS AGREE WITH THE POSITIONING 
*         REQUESTS ON THE -OPEN- CALLS BELOW. 
* 
* 
*         ENTRY  FIT, FET AND PSEUDO-FET PARAMETERS CORRECTLY SET.
*                (B1) = 1 
* 
*         EXIT   (B1) = 1 
*                FILES ARE OPEN.
* 
*         USES   A - 1, 2, 6
*                X - 1, 2, 6
*                B - 2, 3, 4
* 
*         CALLS  OPEN, CLOSE, SETFIL, READ
  
  
 OPF      ENTRY. *           ** ENTRY/EXIT ** 
  
 .T       IFNE   TEST,0 
          OPEN   F.TEST,ALTER,RCL  INTERNAL DEBUG FILE *SYMTAB* 
 .T       ENDIF 
  
*         IF RETURNING FROM *COMPASS* (CP.CARD = .NZ.), -IN-, -OUT- 
*         AND -LGO- ARE  ALREADY OPEN.  BUFFERS ARE ALLOCATED FOR 
*         -IN- AND -OUT- ONLY.
  
          ECHO   1,Z=(RLST,CMPS,LGO)
          SETFIL FILE==XF.Z,MODE=INIT,FWA==XO.Z 
          SA1    COMRET 
          NZ     X1,OPF7     IF RETURNING FROM COMPASS
          SA1    =XCP.NFLS
          SB2    X1-4 
 OPF3     SA2    MLOP=R 
          PL     X2,OPF4     IF SHORT REF MAP OPTION (R-OPTION .LT. 2)
          SETFIL FILE=F.RMAP,MODE=INIT,LWA1=B2
  
*         SET SYMBOL TABLE LWA+1 (TERMED AN INVERTED FWA, SINCE THE 
*         SYMBOL TABLE GROWS DOWNWARD) TO LAST BUFFER FWA.
  
 OPF4     SX6    B2-2 
          SA1    =XDFLAG
          IFEQ   TEST,0,1          ALLOW SLOP FOR SYMDMP IN TEST MODE 
          ZR     X1,OPF4A    IF NOT DEBUG MODE
          SX6    X6-100      ALLOCATE DEBUG FIXED AREA LIST 
  
 OPF4A    SA6    O.SYMTAB    INITIALIZE INVERTED FWA FOR SYMBOL TABLE 
          SA6    =XGL.SYM    SAVE FOR RESTORE IN LSTPRO 
  
*         OPEN INPUT, OUTPUT AND LGO FILES. 
  
 #RM      IFEQ   CP#RM,0
          OPEN   F.OUT,NR,RCL 
          SA1    =XCO.REW 
          ZR     X1,OPF4C 
          REWIND F.IN 
 OPF4C    READ   F.IN        FILL INPUT BUFFER
 #RM      ELSE
          SA1    =XCO.REW 
          ZR     X1,OPF4C 
          OPEN   F.IN,ALTER,RCL 
          REWIND F.IN 
          EQ     OPF4D
  
 OPF4C    BSS    0
          OPEN   F.IN,READNR,RCL
 OPF4D    BSS    0
          STORE  X2,MRL=100D
          OPEN   F.OUT,WRITENR,RCL
          OPEN   F.OPT,ALTER,RCL
 #RM      ENDIF 
  
*         INITIALIZE PAGE SIZE AND PRINT DENSITY. 
  
          SA2    CP.PD
          SA1    LCP.PS 
          BX6    -X1
          SA6    A1 
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
          RECALL F.OUT
          SA3    F.OUT+I.DT 
 #OS1     IFEQ   .OS,1       IF OPERATING SYSTEM IS NOS 
          AX3    48          GET DEVICE TYPE FIELD
          SB2    X3-2RTT
 #OS1     ELSE
          AX3    54 
          SB2    X3+16B 
 #OS1     ENDIF 
          NZ     B2,OPF4D.5  IF NOT A TERMINAL FILE 
          MX7    0
          SA7    A2 
          EQ     OPF4B
  
 OPF4D.5  BSS    0
 #OS      ENDIF 
  
 OPF4B    SA1    FV.LGO 
          ZR     X1,OPF5     IF BINARY OUTPUT OPTION OFF (B=0)
          SA1    =XCO.REW 
          ZR     X1,OPF4E    IF REW OPTION NOT SELECTED 
          OPEN F.LGO,WRITE,RCL
          EQ     OPF5 
  
 OPF4E    OPEN F.LGO,WRITENR,RCL
 OPF5     CLOSE  F.OPT,UNLOAD      INSURE NO FILE FROM PRIOR JOB STEP 
  
*         OPEN REMAINING FILES. 
  
 OPF6     OPEN   F.CMPS,ALTER,RCL 
          OPEN   F.RLST,ALTER,RCL 
          SA1    MLOP=R 
          PL     X1,OPF      IF SHORT REF MAP, EXIT 
          OPEN   F.RMAP,ALTER,RCL 
          EQ     OPF         EXIT 
  
*         HERE IF RETURNING FROM COMPASS.  RE-INITIALIZE FETS OR
*         PSEUDO-FETS FOR -RMAP-. 
  
 OPF7     SA1    MLOP=R 
          PL     X1,OPF8     IF SHORT REF MAP 
          SETFIL FILE=F.RMAP,MODE=RESET 
 OPF8     EQ     OPF6        GO OPEN FILES
 FTNEND   EJECT 
***       FTNABT - ABORT COMPILATION IMMEDIATELY DUE TO A SYSTEM OR 
*         HARDWARE ERROR. 
* 
*         ENTRY  (X1) = ADDRESS OF ERROR MESSAGE TO BE DAYFILED 
  
          ENTRY  FTNABT 
 FTNABT   MESSAGE  X1,,R     SEND DAYFILE MESSAGE 
          SX6    B1 
          MX7    0
          SA6    =XCP.ERCT   CP.ERCT = 1
          SA7    =XCP.CARD   CP.CARD = 0   */ SIGNAL END OF INPUT 
          SA7    =XCAFLAG    DO NOT CALL COMPASS
          LX6    29 
          SA6    =XCO.ABT    FORCE ABORT
*         EQ     FTNEND 
          SPACE  2
***       FTNEND - TERMINATE COMPILATION. 
* 
*         CONTROL IS TRANSFERRED HERE WHEN EACH COMPILATION ENDS. 
  
          ENTRY  FTNEND 
 FTNEND   SB1    1
          RJ     MPP         MAINTAIN PAGE PARITY 
*         UPON RETURN FROM MPP, (X5) = CURRENT PAGE NO. 
  
  
  
**        CHECK IF MORE TO COMPILE. 
* 
          SA1    =XCP.CARD
          NZ     X1,RST      IF MORE SOURCE LINES TO COMPILE
  
  
  
**        TERMINATE AND CLOSE FILES.
* 
          SA1    =XCP.LSTF
          ZR     X1,END1     IF L = 0, DONOT OUTPUT PD
          SA1    CP.PD
          ZR     X1,END1     IF TTY FILE
  
          SA2    RS.PD       RESTORE *PD* 
          BX6    X2-X1
          ZR     X6,END1     IF USING DEFAULT *PD*
  
          BX6    X2          ENTER JOB DEFAULT
          SA6    =XGT1
          WRITEC F.OUT,GT1,1 RESET DENSITY
 END1     BSS    0
#RM       IFEQ   CP#RM,0
          SA1    F.OUT
          SB2    X1 
          EQ     B1,B2,END1A IF FILE NOT ACTED UPON 
          SB3    34 
          LE     B2,B3,END1B IF NOT AN OPEN OR CLOSE
 END1A    SA1    A1+2        GET IN POINTER 
          SA2    A1+B1       GET OUT POINTER
          SB2    X1 
          SB3    X2 
          EQ     B2,B3,END2 IF BUFFER EMPTY 
#RM       ELSE
          FETCH  F.OUT,LOP,X5 
          SB3    X5 
          LE     B3,B1,END2 IF FILE NOT WRITTEN ON
#RM       ENDIF 
 END1B    WRITER F.OUT       FLUSH OUTPUT BUFFER
 END2     SA2    =XFV.LGO    FILE VECTOR
          ZR     X2,END3     IF BINARY OUTPUT SUPPRESSED (B=0)
          SA1    =XCAFLAG 
          SA2    =XUFLAG
          BX6    X1+X2
          NZ     X6,END3     IF C- OR E-OPTION SELECTED 
          WRITEF F.LGO
          BKSP   F.LGO       BACKSPACE OVER END-OF-FILE 
 END3     BSS    0
  
 #RM      IFEQ   CP#RM,0
  
*         EVICT SCRATCH FILES.
  
          SA5    F.OPT+I.FIRST
          SA4    =XSCRTBL-1  INITIALIZE A4
          SX7    200B 
          SA7    A5          CLEAR FET SO NO ERROR FROM CIO 
          SA7    A7+B1       IN CASE FET POINTERS ARE OUTSIDE 
          SA7    A7+B1       PRESENT FL 
          LX7    1
          SA7    A7+B1
          SX0    377774B
  
 .T       IFEQ   TEST,0 
  
 END4     SA4    A4+B1       (X4) = FET ADDRESS FOR NEXT FILE TO EVICT
          MI     X4,END5     IF ALL FILES EVICTED 
          SA3    X4 
          BX6    X0*X3       EXTRACT CIO CODE FIELD 
          ZR     X6,END4     IF FILE UNUSED 
          CLOSE  X4,UNLOAD
          EQ     END4        LOOP FOR NEXT FILE 
  
 .T       ELSE
  
          SA1    F.OPT
          BX6    X0*X1       EXTRACT CIO CODE FIELD 
          ZR     X6,END5     IF FILE UNUSED 
          CLOSE  A1,UNLOAD
  
 .T       ENDIF 
  
 #RM      ENDIF 
  
*         TERMINATE AND REWIND -CMPS- IF *COMPASS* ASSEMBLY (C) OPTION
*         OR UPDATE/EDIT (E) OPTION IS SELECTED.
  
 END5     SA1    =XUFLAG
          SA2    =XCAFLAG 
          BX6    X1+X2
          ZR     X6,END6     IF NEITHER OPTION SELECTED 
          WRITER F.CMPS 
          REWIND F.CMPS 
 END6     BSS    0
  
 #RM      IFGE   CP#RM,6
  
          SX6    =XFVLEN-1   (X6) = FILE VECTOR TABLE OFFSET
 END7     SA2    RA.ARG+X6   (X2) = FIT ADDRESS FROM FILE VECTOR TABLE
          SA6    GT1         TEMP SAVE OFFSET 
          ZR     X2,END8     IF FILE DESELECTED BY CONTROL CARD OPTION
          RJ     FA=CLO 
 END8     SA1    GT1
          SX6    X1-1        (X6) = OFFSET FOR NEXT FILE
          PL     X6,END7     IF MORE FILES TO CLOSE 
  
 .T       IFNE   TEST,0 
          CLOSEM FI.TEST     INTERNAL DEBUGGING FILE *SYMTAB* 
 .T       ENDIF 
  
 #RM      ENDIF 
  
  
  
**        TURN -SPY- OFF (TEST COMPILER ON 6000-SERIES ONLY). 
* 
 .T       IFNE   TEST,0 
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
          CALL   OFFSPY 
 #OS      ENDIF 
 .T       ENDIF 
  
  
  
**        WAIT FOR ALL FILE ACTIONS TO COMPLETE.
* 
 #RM      IFEQ   CP#RM,0
          SB2    RA.ARG 
          SB3    RA.ARG+=XFVLEN 
 END9     SA5    B2          (X5) = FILE VECTOR TABLE ENTRY 
          SB2    B2+B1
          ZR     X5,END10    IF FILE DESELECTED BY CONTROL CARD OPTION
          SX2    X5          (X2) = ADDRESS OF FET FOR FILE 
          RECALL X2 
 END10    LT     B2,B3,END9  IF MORE FILES TO CHECK 
 #RM      ENDIF 
  
  
  
**        IF *COMPASS* ASSEMBLY (C) OPTION OFF, TERMINATE *FTN*.
* 
          SA1    =XCAFLAG 
          ZR     X1,=XENDFTN IF C-OPTION OFF
  
  
  
**        PREPARE FOR *COMPASS* CALL. 
* 
*         (RECORD MGR OFF)   REWIND -COMPS- FILE AND MOVE ITS NAME TO 
*                            THE INPUT FILE FET.
*         (RECORD MGR ON)    MOVE -COMPS- FILE NAME TO INPUT FILE FIT.
* 
          SX6    0
          SA6    =XCP.CARD   SIGNAL EMPTY INPUT WSA 
          SA6    =XCAFLAG    CLEAR -CALL COMPASS- FLAG
  
 #RM      IFEQ   CP#RM,0
  
          SA1    F.CMPS 
          BX6    X1 
          SA6    F.IN        MOVE FILE NAME 
  
 #RM      ELSE
  
          SA1    F.CMPS      (X1) = COMPS FILE FIT ADDR 
          SA2    F.IN        (X2) = INPUT FILE FIT ADDR 
          FETCH  X1,LFN,X3
          STORE  X2,LFN=X3
  
          IFEQ   CP#RM,7,1
          SETFIT X2          COMPS FDT INFO TO INPUT FIT
  
 #RM      ENDIF 
  
          EQ     =XLDCOM     EXIT TO LOAD *COMPASS* (1,0) OVERLAY 
 RST      EJECT 
***       INITIALIZE COMPILER FOR PASS 1 RESTART. 
  
**        INITIALIZE TABLES.
* 
 RST      MX6    6
          SA1    NRB          NATURAL REAL BITS 
          LX6    24+1         NATURAL INTEGER BITS
          BX7    X1 
          SA6    IMPTYP       RESET NATURAL TYPE TABLE
          SA7    A6+B1
          BX6    X6-X6
          SA6    A7+B1
          SETZERO  ORIGINS,NTBLS   CLEAR TABLE MANAGER ORIGINS VECTORS
          SETZERO  O.BATCH,L.BATCH CLEAR BATCH CONTROL CELLS
  
  
  
**        INITIALIZE MISCELLANEOUS CELLS. 
* 
          SX7    2R 
          SX6    B1 
          LX7    59-11
          SA6    N.AP        N.AP = 1      */ NEXT AVAIL APLIST NUMBER
          SA7    O.STITL     BLANK OUT SUBTITLE LINE
          SA6    N.GL        N.GL = 1      */ NEXT AVAIL GL NUMBER
          SA6    O.CEP       O.CEP = 1
          SA6    SYMORD 
          SA6    L.STITL     L.STITL = 1   */ SUBTITLE LENGTH 
  
*         RESTORE O.SYMTAB BECAUSE OF POSSIBLE STORAGE MOVES IN DEBUG 
*         MODE DURING LAST COMPILATION.  (DEBUG ALLOCATES FIXED TABLES
*         ABOVE SYMTAB).
  
          SA1    GL.SYM 
          BX6    X1 
          SA6    O.SYMTAB 
  
  
  
**        RESET *SYMBOL* TABLE SEARCH SWITCHES TO PASS 1 CONDITIONS.
* 
          CALL   KSSW 
  
  
  
**        REWIND INTERNAL SCRATCH FILES.  RESTORE PASS 1 INITIAL
*         CONDITIONS AND STORAGE ALLOCATIONS IN FETS, FITS, PSEUDO-FETS.
* 
 .T       IFNE   TEST,0 
          REWIND F.TEST 
 .T       ENDIF 
  
          SA1    =XUFLAG     UPDATE/EDIT (E) OPTION FLAG
          SA2    =XCAFLAG    COMPASS-TO-ASSEMBLE (C) OPTION FLAG
          BX6    X1+X2
          NO
          NZ     X6,RST2     IF EITHER OPTION ON (MUST SAVE -CMPS- FILE)
          REWIND F.CMPS,RCL 
          SETFIL FILE=F.CMPS,MODE=RESET 
 RST2     SA1    MLOP=R      REFERENCE MAP OPTION FLAG
          PL     X1,RST3     IF NO LONG REF MAP (R=0 OR =1) 
          REWIND F.RMAP,RCL 
          SETFIL FILE=F.RMAP,MODE=RESET 
 RST3     REWIND F.RLST,RCL 
          SETFIL FILE=F.RLST,MODE=RESET 
          SA2    =XFV.LGO 
          ZR     X2,LST3     IF BINARY OUTPUT SUPPRESSED (B=0), EXIT
  
 #RM      IFEQ   CP#RM,0
          SA1    X2          (X1) = FET WORD 1
          LX1    59-0 
          MI     X1,RST4     IF FILE NOT BUSY 
          RECALL X2          WAIT FOR FILE QUIET
 RST4     BSS    0
 #RM      ENDIF 
  
          SETFIL FILE=F.LGO,MODE=RESET
          EQ     LST3        EXIT TO RESTART BATCH COMPILATION
          SPACE  4
          LIST   F,X
 CDD      SPACE  4
*CALL COMCCDD 
          SPACE  4
          ENTRY  CDD
 COD      SPACE  4
*CALL COMCCOD 
          SPACE  4
          ENTRY  COD
 DXB      SPACE  4
*CALL COMCDXB 
          SPACE  4
          ENTRY  DXB
 MVE=     SPACE  4
*CALL COMCMVE 
          SPACE  4
          ENTRY  MVE= 
*CALL COMCSFN 
 SFN      SPACE  4,8
          ENTRY  SFN
          SPACE  4
 #RM      IFEQ   CP#RM,0
 CIO=     SPACE  4
*CALL COMCCIO 
          SPACE  4
          ENTRY  CIO= 
 RDC=     SPACE  4
*CALL COMCRDC 
          SPACE  4
          ENTRY  RDC= 
 RDW=     SPACE  4
*CALL COMCRDW 
          SPACE  4
          ENTRY  RDW= 
 WTC=     SPACE  4
*CALL COMCWTC 
          SPACE  4
          ENTRY  WTC= 
 WTW=     SPACE  4
*CALL COMCWTW 
          SPACE  4
          ENTRY  WTW= 
          SPACE  4
 #RM      ENDIF 
 FA=LOL   TITLE  FA=LOL - LIST ONE LINE 
**        FA=LOL - LIST ONE LINE. 
* 
* 
*         ENTRY  (B1) = 1 
*                (B6) = LINE BUFFER ADDRESS.
*                (B7) = LINE LENGTH (WORDS).
* 
*         EXIT   (B1) = 1 
* 
*         USES   X - 1, 2, 6, 7 
*                A - 1, 2, 6, 7 
*                B - 6
* 
*         CALLS  NUPAGE, WRITEC 
  
  
 #RM      IFEQ   CP#RM,0
  
 LOL2     WRITEC F.OUT,B6 
  
 FA=LOL   ENTRY. **          ** ENTRY/EXIT ** 
          SA1    N.LINES     COMPLEMENT OF UNFILLED LINE COUNT
          SX6    X1+B1       DECR COUNT 
          SA6    A1 
          MI     X6,LOL2     IF PAGE NOT FULL 
          SX7    B6+
          SA7    LOLA        TEMP SAVE LINE ADDRESS 
          NUPAGE             EJECT AND TITLE PAGE 
          SA2    LOLA 
          SB6    X2 
          EQ     LOL2 
  
 #RM      ELSE
  
 LOL2     WRITEC F.OUT,B6,B7
  
 FA=LOL   ENTRY. **          ** ENTRY/EXIT ** 
  
          SA1    N.LINES     COMPLEMENT OF UNFILLED LINE COUNT
          SX6    X1+B1       DECREMENT LINE COUNT 
          SA6    A1 
          MI     X6,LOL2     IF PAGE NOT FULL 
          SX7    B7 
          SX6    B6 
          LX7    18D
          BX6    X7+X6
          SA6    LOLA        TEMP SAVE LINE LENGTH AND FWA
          NUPAGE             EJECT AND TITLE PAGE 
          SA2    LOLA 
          SB6    X2 
          AX2    18D
          SB7    X2 
          EQ     LOL2 
  
 #RM      ENDIF 
  
  
  
 LOLA     BSS    1           LINE LENGTH AND FWA TEMP SAVED HERE
 FA=NPG   TITLE  FA=NPG - EJECT AND TITLE NEW PAGE
**        FA=NPG - EJECT AND TITLE NEW PAGE.
* 
*                IF *BL* OPTION ON, UNCONDITIONALLY EJECTS, TITLES AND
*         SUBTITLES NEW PAGE. 
*                IF *BL* OPTION OFF, AND 8 OR MORE LINES REMAIN ON
*         CURRENT PAGE, SPACES 4 AND LISTS SUBTITLE ONLY.  IF LESS THAN 
*         8 LINES REMAIN, EJECTS, TITLES AND SUBTITLES NEW PAGE.
*         BEHAVES LIKE COMPASS *SPACE 4,4* DIRECTIVE. 
* 
* 
*         ENTRY  (B1) = 1 
* 
*         EXIT   PAGE SPACED OR EJECTED, AND TITLED.
*                (N.LINES) ADJUSTED (IF SPACE 4) OR RESET (IF EJECT). 
*                (CP.PAGE) INCREMENTED IF PAGE EJECTED. 
*                (B1) = 1 
* 
*         USES   X - 1, 2, 6, 7 
*                A - 1, 2, 6, 7 
*                B - NONE.
* 
*         CALLS  CDD, WRITEC
  
  
 FA=NPG   ENTRY. **          ** ENTRY/EXIT ** 
          SA1    O.STITL     SET DOUBLE SPACE CODE IN SUBTITLE
          SX2    1R0
          MX6    6
          LX2    54 
          BX1    -X6*X1 
          IX6    X2+X1
          SA6    O.STITL     FWA OF SUBTITLE LINE 
          SA1    =XCP.BLF 
          NZ     X1,NPG2     IF BURSTABLE LISTING 
          SA1    N.LINES     CHECK SPACE LEFT ON CURRENT PAGE 
          SX6    X1+8-1 
          PL     X6,NPG2     IF LESS THAN 8 LINES LEFT
  
*         SPACE 4 AND SUBTITLE CURRENT PAGE.
  
          SX6    X1+4+1 
          SA6    A1          UPDATE *LINES REMAINING* COUNT 
          WRITEC F.OUT,(=1C-),1    TRIPLE SPACE 
          EQ     NPG3 
  
*         EJECT, TITLE AND SUBTITLE NEW PAGE. 
  
 NPG2     SA1    =XCP.PAGE   LAST PAGE NUMBER (BINARY INTEGER)
          MX6    -1 
          IX7    X1-X6       PAGE NUMBER + 1
          SX1    X7          REMOVE PROPAGATION BIT, IF PRESENT 
          SA7    A1 
          CALL   CDD         RETURNS (X6) = PAGE NUMBER (DISPLAY CODE)
          MX7    24 
          BX6    -X7*X6 
          SB3    X6-1A1      FOR TEST OF FIRST PAGE 
          LX6    24 
          SA6    TL.PAGE     UPDATE PAGE NUMBER IN TITLE LINE 
          NZ     B3,NPG21    IF NOT FIRST PAGE
          SA4    =XCP.LSTF
          ZR     X4,NPG21    IF L = 0 
          SA4    =XCP.PAGE
          LX4    1
          MI     X4,NPG21    IF PD ALREADY WRITTEN OUT TO OUTPUT
          LX4    59 
          SX5    B5 
          LX5    58 
          BX6    X4+X5
          SA6    =XCP.PAGE
          SA4    CP.PD
          ZR     X4,NPG21    IF TTY OUTPUT FILE 
          WRITEC F.OUT,CP.PD,1
 NPG21    SA1     LCP.PS
          BX6    X1 
          SA6    N.LINES     RESET FULL PAGE LINE COUNT 
  
*         LIST TITLE AND SUBTITLE LINES.
  
          WRITEC F.OUT,O.TITL,L.TITL     / MAIN TITLE / 
 NPG3     SA1    L.STITL
          WRITEC F.OUT,O.STITL,X1        / SUBTITLE / 
  
          EQ     FA=NPG      EXIT 
  
  
  
 L.STITL  ENTRY. 1           SUBTITLE LINE LENGTH (WORDS) 
          SPACE  4
 #RM      IFGE   CP#RM,6
*CALL     FA=CLO
 CLO      SPACE  4
          ENTRY  FA=CLO 
*CALL     FA=EOF
 EOF      SPACE  4
          ENTRY  FA=EOF 
*CALL  FA=EOR 
 EOR      SPACE  4
          ENTRY  FA=EOR 
*CALL     FA=FLSH 
*CALL     FA=OPE
 OPE      SPACE  4
          ENTRY  FA=OPE 
*CALL     FA=RDC
 RDC      SPACE  4
          ENTRY  FA=RDC 
*CALL     FA=RDW
 RDW      SPACE  4
          ENTRY  FA=RDW 
*CALL     FA=RWX
 RWX      SPACE  4
          ENTRY  FA=RWX 
*CALL     FA=WTC
 WTC      SPACE  4
          ENTRY  FA=WTC 
*CALL     FA=WTW
 WTW      SPACE  4
          ENTRY  FA=WTW 
          SPACE  4
 #RM      ENDIF 
*CALL FA=SET
          SPACE  4
          ENTRY  FA=SET 
 MPP      SPACE  4,8
**        MPP - MAINTAIN PAGE PARITY. 
* 
*         ENTRY  (B1) = 1 
* 
*         EXIT   PAGE EJECTED IF NECESSARY TO MAINTAIN EVEN PARITY. 
*                (B1) = 1 
* 
*         USES   X - 1, 2, 3, 6, 7
*                A - 1, 2, 3, 6 
*                B - NONE.
* 
*         CALLS  WRITEC 
  
  
 MPP      ENTRY. **          ** ENTRY/EXIT ** 
          SA5    =XCP.PAGE
          SA1    =XCP.PAGE
          SA2    =XCP.LSTF
          SA3    =XCP.BLF 
          BX6    X2*X1
          BX7    X3*X6       (X7) = 1 IF EJECT NEEDED, = 0 IF NOT 
          IX6    X1+X7
          PL     X6,MPP2     IF PAGE PROPAGATION SELECTED (P OPTION)
          LX5    1
          PL     X5,MPP1     IF CP.PAGE IS NOT SET
          MX6    2
          EQ     MPP2 
 MPP1     MX6    1
 MPP2     SA6    A1          UPDATE OR RESET PAGE NUMBER
          ZR     X7,MPP      IF (EVEN PAGE COUNT) OR (SHORT/NO LIST)
          WRITEC F.OUT,(=1C1),1    EJECT PAGE TO MAINTAIN EVEN PARITY 
          EQ     MPP         EXIT 
 OUTUSE   TITLE  OUTPUT * USE BLKNAM * TO -COMPS- 
**        OUTUSE - OUTPUT * USE BLKNAM * TO -COMPS-.
* 
*         ENTRY  (X6) = ADDRESS OF NEW BLOCK NAME (IN TABLE BELOW)
*                (C.BLOCK) = ADDRESS OF CURRENT BLOCK NAME
* 
*         EXIT   *USE* WRITTEN, IF DIFFERENT FROM CURRENT BLOCK.
*                (B1) = 1 
*                (B5) = 1 
*                (C.BLOCK) = ADDRESS OF NEW BLOCK NAME
* 
*         USES   X - 1, 2, 3, 6, 7
*                A - 1, 2, 3, 6, 7
*                B - 1, 5 
* 
*         CALLS  WRITEC 
  
  
 OUTUSE   ENTRY. **          ** ENTRY/EXIT ** 
          SA1    C.BLOCK     (X1) = ADDRESS OF CURRENT BLOCK NAME 
          SB1    1
          SA2    A1+B1       (X2) = *  USE XXXX*
          IX7    X6-X1
          SA3    X6          (X3) = NEW BLOCK NAME
          MX1    6*6
          ZR     X7,OUTUSE   IF NEW NAME = CURRENT NAME, EXIT 
  
*         ASSEMBLE * USE NEWBLOK * AND WRITE TO -COMPS-.
  
          BX2    X1*X2       REMOVE OLD NAME FROM *USE* 
          SA6    A1          NEW NAME ADDRESS TO (C.BLOCK)
          BX7    X1*X3
          BX1    -X1*X3 
          SA7    A2+B1
          IX6    X2+X1
          SA6    A2 
          WRITEC =XF.CMPS,A2,2     *  USE BLKNAM* TO -COMPS-
          SB5    1
          EQ     OUTUSE      EXIT 
  
  
  
 C.BLOCK  ENTRY. 0           ADDRESS OF CURRENT BLOCK NAME
          DATA   12C  USE BLKNAM   (POSITIONALLY DEPENDENT, SEE CODE) 
  
  
  
**        BLOCK - FORM BLOCK NAME TABLE ENTRY.
* 
 BLOCK    MACRO  BLKNAM 
 BNAM     MICRO  1,6, BLKNAM
          ENTRY  U"BNAM"
 FIRST4   MICRO  1,4, BLKNAM
 REST     MICRO  5,, BLKNAM 
 U"BNAM"  VFD    36/0L"REST",24/4L"FIRST4"
 BLOCK    ENDM
  
  
  
**        BLOCK NAME TABLE. 
* 
          BLOCK  START. 
          BLOCK  VARDIM.
          BLOCK  ENTRY. 
          BLOCK  CODE.
          BLOCK  DATA.
          BLOCK  DATA.. 
          BLOCK  HOL. 
 RPV      TITLE  REPRIEVE PROCESSOR 
**        RPV - REPRIEVE PROCESSOR. 
* 
*         IF COMPILATION IS ABORTED DUE TO COMPILER ERROR, *RPV* GAINS
*         CONTROL TO FLUSH THE OUTPUT BUFFER AND POST DAYFILE MESSAGES
*         THAT IDENTIFY THE PROGRAM UNIT BEING COMPILED AND WHERE THE 
*         ERROR OCCURRED.  IF THE COMPILER HAS BEEN ASSEMBLED IN TEST 
*         MODE, ALL FILES IN AN OUTPUT MODE ARE FLUSHED.  FINALLY, THE
*         ORIGINAL ERROR CONDITION IS RESTORED TO PERMIT NORMAL *EXIT*
*         CONDITION PROCESSING. 
* 
*         ENTRY  NO REQUIREMENTS. 
* 
*         EXIT   MESSAGES POSTED AND BUFFERS FLUSHED.  REINSTATES THE 
*                ERROR CONDITION AND RETURNS CONTROL TO THE OPERATING 
*                SYSTEM.
* 
*         USES   X - ALL
*                A - 1, 2, 3, 5, 6, 7 
*                B - 1, 2 
* 
*         CALLS  CDD, SYSTEM (RPV), WRITER
  
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
 XJP      VFD    12/0,18/LWARPV,30/0
 #OS      ELSE
 .T       IFEQ   TEST,0 
 XJP      VFD    12/0,18/LWARPV,6/0,24/05470000B
 .T       ELSE
 XJP      VFD    12/0,18/LWARPV,6/0,24/77770014B
 .T       ENDIF 
 #OS      ENDIF 
  
  
          BSSZ   16          EXCHANGE PACKAGE AND RA+1
  
          SB1    1           **  REPRIEVE ENTRY POINT **
  
 .T       IFEQ   TEST,0 
  
          MESSAGE   =XCOMPMSG,,RCL *COMPILING NNNNNNN*
  
 .T       ELSE
  
*         SAVE CONTENTS OF ENTRY POINTS THAT *RPV* WILL USE.
  
          SA1    CDD
          SA2    COD
          BX6    X1 
          LX7    X2 
          SA6    RPVE 
          SA7    A6+B1
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
          SA1    =XSYS= 
          SA2    =XWNB= 
          SA3    =XMSG= 
          BX6    X1 
          LX7    X2 
          SA6    A7+B1
          SA7    A6+B1
          BX6    X3 
          SA6    A7+B1
 #RM      IFEQ   CP#RM,0
          SA1    CIO= 
          BX6    X1 
          SA6    A6+B1
 #RM      ENDIF 
 #OS      ENDIF 
  
 .T       ENDIF 
  
          SA5    XJP
          MX0    -17
          LX5    24 
          BX1    -X0*X5      EXTRACT P REGISTER 
          SB2    X1 
          GT     B2,B1,RPV2  IF P-REGISTER NOT CLEARED
          SA5    RA.SSW 
          LX5    59-47+18 
          BX1    -X0*X5      EXTRACT P FROM RA+0
 RPV2     BSS    0
  
 .T       IFNE   TEST,0 
 #OS      IFEQ   .OS,2       IF SCOPE 2 
          BX7    X1 
          SA7    ERRP=
 #OS      ENDIF 
 .T       ENDIF 
  
          SB7    RPV3        (B7) = RETURN ADDRESS
          EQ     FRA=        FIND RELATIVE ADDRESS
  
 RPV3     SA6    RPVC+1      ADDRESS AND ROUTINE NAME TO MSG TEXT 
          SA7    A6+B1
  
*         INDICATE LAST OVERLAY LOADED. 
  
          SA1    RA.ORG      (X1) = LOADER CALL PARAM LIST WORD 1 
          MX0    -6 
          LX1    6
          BX6    -X0*X1      PRIMARY LEVEL
          LX1    6
          BX7    -X0*X1      SECONDARY LEVEL
          LX6    12 
          SB2    X7          (B2) = SECONDARY OVERLAY LEVEL NUMBER
          BX7    X6+X7
          SA2    RPVD+2      * - (0,0)  * 
          LX7    18 
          IX6    X2+X7
          SA6    A2 
  
*         INDICATE LAST SOURCE STATEMENT PROCESSED.  ISSUED ONLY IF 
*         (2,1), (2,2) OR (2,4) OVERLAY WAS LAST LOADED, SINCE VALID
*         LINE NUMBER INFORMATION IS NOT AVAILABLE AT OTHER TIMES.
  
          SX1    15B         SHIFT TEST MASK FOR 1, 2 AND 4 
          LX1    58-3 
          LX1    B2 
          PL     X1,RPV7     IF 2NDARY OVERLAY LEVEL NOT 1, 2 OR 4
          SB3    B1+B1
          SA1    DUKE 
          NE     B2,B3,RPV6  IF NOT IN OVERLAY (1,2)
          IFNE   TEST,0,1 
          EQ     DMPTBL=
  
 RPV5     SA1    LINENR 
          SX1    X1 
 RPV6     MX0    -12
          CALL   CDD
          BX6    X0*X4       CREATE 12-BIT ZERO BYTE MSG TERMINATOR 
          SA6    RPVB+3      LINE NR TO MESSAGE TEXT
  
*         ISSUE THE DAYFILE MESSAGES. 
  
          MESSAGE   RPVB,,RCL      * LAST STATEMENT BEGAN AT LINE NNNN* 
 RPV7     MESSAGE   RPVC,,RCL      * ERROR AT XXXXXX IN YYYYYYY*
          MESSAGE   RPVD,,RCL      * LAST OVERLAY LOADED - (P,S)* 
  
*         FLUSH FILE I/O BUFFERS (DIRECT CIO I/O ONLY). 
  
 #RM      IFEQ   CP#RM,0
          SA1    F.OUT
          SX6    B1 
          BX7    X1+X6
          SA7    A1          INSURE CIO COMPLETE BIT IS ON
          WRITER A1,,RCL
 .T       IFNE   TEST,0 
          SX6    3           FLUSH COUNT - 1  (LGO, CMPS, RLST, RMAP) 
 RPV8     SA2    =XFV.LGO+X6 (X2) = NEXT FILE FET ADDRESS 
          SA6    RPVF        TEMP SAVE VECTOR OFFSET
          ZR     X2,RPV9     IF FILE DESELECTED BY CONTROL CARD OPTION
          SA1    X2          (X1) = FET WORD 1
          MX0    -6 
          SX6    B1 
          BX7    X1+X6
          SA3    RPVA        (X3) = SHIFT TEST MASK FOR CIO CODE
          AX1    2
          BX0    -X0*X1      EXTRACT CIO CODE 
          SB2    X0 
          LX3    B2 
          PL     X3,RPV9     IF LAST CIO OP NOT OPEN OR WRITE 
          SA7    A1          INSURE CIO COMPLETE BIT IS ON
          WRITER A1,,RCL     FLUSH BUFFER 
 RPV9     SA1    RPVF 
          SX6    X1-1        (X6) = NEXT FILE OFFSET IN VECTOR TABLE
          PL     X6,RPV8     IF MORE FILES TO FLUSH 
 .T       ENDIF 
 #RM      ENDIF 
  
*         RESTORE SAVED ENTRY POINT CONTENTS. 
  
 .T       IFNE   TEST,0 
          SA1    RPVE 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    CDD
          SA7    COD
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
          SA1    A2+2        (WILL RESTORE SYS= LATER)
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    =XWNB= 
          SA7    =XMSG= 
 #RM      IFEQ   CP#RM,0
          SA1    A2+B1
          BX6    X1 
          SA6    CIO= 
 #RM      ENDIF 
 #OS      ENDIF 
 .T       ENDIF 
  
*         REINSTATE THE ERROR CONDITON. 
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
          SX1    B1 
          LX1    35-0 
          SYSTEM RPV,,X1
 .T       IFNE   TEST,0 
          SA1    RPVE+2      (X1) = SAVED (SYS=)
          BX6    X1 
          SA6    =XSYS=      RESTORE PREVIOUS CONTENTS
 .T       ENDIF 
 +        EQ     *           WAIT FOR OP SYS TO PICK UP ERROR 
 #OS      ELSE
  
 .T       IFNE   TEST,0 
          SA1    =XXJP
          CALL   DXP=        DUMP EXCHANGE PACKAGE
 .T       ENDIF 
          ABORT              *** TEMPORARY UNTIL SCOPE 2.0 REPRIEVE 
*                            *** RESET METHOD IS AVAILABLE. 
 #OS      ENDIF 
  
  
 .T       IFNE   TEST,0 
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
 RPVA     BSS    0
          ECHO   2,CIOCODE=(4B,14B,104B,120B,144B,160B) 
          POS    60-CIOCODE_S-2 
          VFD    1/1
          POS    0
          BSS    0
 #OS      ENDIF 
 .T       ENDIF 
          EJECT 
 FRA      SPACE  4,8
**        FRA - FIND RELATIVE ADDRESS.
* 
*                GIVEN AN ABSOLUTE ADDRESS, *FRA* FINDS THE ROUTINE 
*         NAME AND RELATIVE ADDRESS BY SEARCHING THE TABLES INSTALLED 
*         ORIGINALLY FOR *RPV* PROCESSING.
* 
*                *FRA* DOES NOT USE A RETURN JUMP CALLING SEQUENCE
*         BECAUSE IT IS LOCATED IN CODE SPACE CHECKSUMMED BY *RPV*. 
* 
* 
*         ENTRY  (X1) = ADDRESS RELATIVE TO RA+0
*                (B7) = EXIT ADDRESS
* 
*         EXIT   TO (B7), WITH ...
*                (X4) = ADDRESS RELATIVE TO ROUTINE ORIGIN, H FORMAT
*                (X6) = RELATIVE ADDRESS, DPC, *NNNNNN IN * 
*                (X7) = ROUTINE NAME, DPC, L FORMAT 
* 
*         USES   X - 0, 1, 2, 3, 6, 7 
*                A - 2
*                B - 2, 3 
* 
*         CALLS  COD
  
  
          QUAL   FRA
  
 FRA=     SB3    =XLWA2.0+1+LDR.NN
          SB2    X1          (B2) = ADDRESS RELATIVE TO RA+0
          SA2    B3 
          GE     B2,B3,FRA2  IF ADDRESS IN (2,N) OVERLAY
          SA2    =XFWA2.0 
  
*         SEARCH ADDRESS TABLE. 
  
 FRA2     BX6    X2 
          SA2    A2+1        NEXT TABLE ENTRY 
          SB3    X2 
          ZR     X2,FRA3     IF END OF TABLE
          GE     B2,B3,FRA2  IF ABS ADDR BEYOND CURRENT ENTRY 
  
*         EXTRACT ROUTINE NAME AND FORMAT RELATIVE ADDRESS. 
  
 FRA3     MX7    42 
          SX3    X6          EXTRACT FWA
          BX0    X7*X6       EXTRACT ROUTINE NAME 
          IX1    X1-X3       (X1) = ADDRESS RELATIVE TO ROUTINE ORIGIN
          RJ     COD         CONVERT TO OCTAL DISPLAY CODE
          LX6    24D
          SX3    2R  &2RIN
          LX3    6
          BX6    X6-X3       (X6) = RELATIVE ADDRESS, *NNNNNN IN *
          LX7    X0          (X7) = ROUTINE NAME, L FORMAT
          JP     B7          EXIT ... 
          SPACE  4
          QUAL   *
  
 FRA=     =      /FRA/FRA=
          ENTRY  FRA= 
 RPV      SPACE  4,8
          BSS    0
 LWARPV   =      *-1         *** END OF CHECKSUMMED REPRIEVE CODE *** 
 RPV      SPACE  4,8
 RPVB     DIS    ,* LAST STATEMENT BEGAN AT LINE ........*
 RPVC     DIS    ,* ERROR AT 000000 IN XXXXXXX* 
 RPVD     DIS    ,* LAST OVERLAY LOADED - (0,0)*
  
 .T       IFNE   TEST,0 
  
 RPVE     BSSZ   2           TO SAVE (CDD) AND (COD)
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
          BSSZ   3           TO SAVE (SYS=), (WNB=) AND (MSG=)
 #RM      IFEQ   CP#RM,0
          BSSZ   1           TO SAVE (CIO=) 
 RPVF     BSSZ   1           COUNT-1 OF FILES TO FLUSH
 #RM      ENDIF 
 #OS      ELSE
 ERRP=    ENTRY. 0           SAVE ERROR ADDRESS 
 #OS      ENDIF 
  
 .T       ENDIF 
 SETCORE  TITLE  SET BLOCK OF MEMORY TO A GIVEN VALUE 
**        SETCORE - SET BLOCK OF MEMORY TO A GIVEN VALUE. 
* 
* 
*         ENTRY  (X1) = BLOCK LENGTH
*                (X6) = VALUE TO SET
*                (A6) = BLOCK FWA (WORD 1 ALREADY STORED) 
* 
*         EXIT   (X6) = UNCHANGED 
*                (X7) = (X6)
*                (A6) = BLOCK LWA 
*                (B1) = 1 
* 
*         USES   X - 1, 2, 7
*                A - 6, 7 
*                B - 1
* 
*         CALLS  NONE 
  
  
 SETC2    SA7    A6+1 
          IX1    X1-X2
          SA6    A7+B1
          PL     X1,SETC2    IF ALL OF BLOCK NOT SET
  
 SETCORE  ENTRY. **          ** ENTRY/EXIT ** 
  
 .T       IFNE   TEST,0 
          SB1    X1 
          LE     B1,B0,*+1S17      IF LENGTH ERROR, ABORT JOB 
 .T       ENDIF 
  
          SX2    1
          NO
          BX7    -X1*X2      EXTRACT COMPLEMENT OF LSB
          SB1    X7          (B1) = 1 IF LENGTH EVEN, = 0 IF ODD
          SX1    X1-3        DECREMENT LENGTH 
          SA6    A6+B1       SET 2ND WORD IF LENGTH WAS EVEN
          LX2    1           (X2) = 2 
          SB1    1
          BX7    X6 
          PL     X1,SETC2    IF ALL OF BLOCK NOT SET
          EQ     SETCORE     EXIT 
          TITLE  STORAGE DECLARATIONS 
*         *COMPILING ...* MESSAGE FOR B-DISPLAY / PROGRAM UNIT NAME 
* 
 COMPMSG  ENTRY. 10HCOMPILING 
 PROGNAM  ENTRY. 0           PROGRAM UNIT NAME, 42/7H_NNN....,18/0
  
*         WORKING COPY OF LISTING CONTROL FLAGS 
  
 LSTWRKG  BSS    0
          ENTRY  LSTWRKG
 ANSI     ENTRY.
 IEFLG    ENTRY.
 LOP=M    ENTRY.
 LOP=O    ENTRY.
 LOP=R    ENTRY.
 LOP=W    EQENT  IEFLG
 LOP=X    EQENT  ANSI 
 OLIST    EQENT  LOP=O
 RSELECT  EQENT  LOP=R
 R=FLAG   ENTRY.
  
*         SUBTITLE LINE 
  
 O.STITL  ENTRY. 2L 
          DIS    6, 
*         SPACE FOR THE ERROR TABLE 
* 
          USE    /TABLES/ 
 SIZE     EQU    ERRMAX*2+2        SIZE OF THE ERROR TABLE
          BSS    SIZE              THE ERROR TABLE
          IFLT   SIZE,130,1 
          BSS    130-SIZE          THIS AREA IS ALSO USED BY JAMMER 
*                                  AND THE REFMAP AND THE THE ASSEMBLER 
          USE    *
  
 N.AP     ENTRY. 1           PASS 1 - NEXT AVAIL AP NUMBER
 N.GL     ENTRY. 1           PASS 1 - NEXT GL NUMBER
*                            PASS 2 - NUMBER OF AP/GL"S 
  
*         HASH TABLES FOR SYMBOL AND LABEL
  
 SYMORD   ENTRY.  1                LAST ORDINAL + 1 
 O.BATCH  =      *                 ** BEGIN BATCH CONTROL AREA ** 
 SLIST    BSSZ   128
 LLIST    BSSZ   32 
  
 N.LINES  ENTRY. 0                 NR UNFILLED LINES ON PAGE (BINARY) 
  
 N.COM    ENTRY.                   NUMBER OF COMMON BLOCKS
  
 ORGTAB   ENTRY.                   42/7LNAME,18/LENGTH
          BSSZ   M.NCB
  
*         THE FOLLOWING CELLS HOLD THE LENGTH OF LOCAL RELOCATION BASES 
  
          ENTRY  O.LBLK 
 O.LBLK   EQU    *                 FWA OF LOCAL BLOCK TABLE 
 START.   ENTRY.                   START. 
 VARDIM.  ENTRY.                   VARDIM.
 EPOINT.  ENTRY.                   ENTRY. 
 CODE.    ENTRY.                   CODE.
 DATA.    ENTRY.                   DATA.
 DATA..   ENTRY.                   DATA.. 
 HOL.     ENTRY.                   HOL. 
 N.LRB    EQU    *-O.LBLK          NUMBER OF LOCAL BLOCKS 
 SDATA.   ENTRY. 0
  
*         N.XX - NUMBER OF LOCATIONS TO ASSIGN TO XX. 
  
 N.ST     ENTRY. 0           STATEMENT TEMPORARIES ( FUNCTION CALLS ) 
 N.OT     ENTRY. 0           OPTIMIZING TEMPORARIES ( CODE GENERATOR )
 N.DO     ENTRY. 0           DO TEMPORARIES ( INDEX FUNCTIONS ) 
 N.VD     ENTRY. 0           VARDIM TEMPS ( VARIABLE DIMENSION CALC ) 
 N.IT     ENTRY. 0           INTERMEDIATE TEMPS ( INVARIANT EXPRESSIONS ) 
  
 LINENR   ENTRY. 0           INITIAL LINE NUMBER OF STMT/SEQUENCE 
*                                  BEING PROCESSED ( PASS 1/2 ).
 N.EXST   ENTRY. 0           N. EXECUTABLE STMTS / N. *BOS"S* 
 N.FILES  ENTRY.                   NUMBER OF FILES FOR A MAIN PROGRAM 
 N.EQUF   ENTRY.             NR OF EQUIVALENCED FILES 
 IOAPLN   ENTRY.                   HOLDS I/O APLIST NUMBER
 XFRNAME  ENTRY.                   XFER NAME OR 0 
 FUNTYPE  ENTRY. 0                 0 OR NUM OF WORDS IN FUNCTION RESULT 
 N.FP     ENTRY.                   NUMBER OF FORMAL PARAMETERS
 RETURNS  ENTRY. 0           "0 IF RETURNS S ON CALL PARAMETER LISTS
 FSTEX    ENTRY.                   LINE NUMBER OF FIRST EXECUTABLE STMT 
 VARDIM   ENTRY.                   .NE. 0 IF F.P. S WITH VARIABLE DIMS
 LEVEL    ENTRY.                   .NE. 0 IF LEVEL STATEMENTS APPEARED
 LEVEL2   ENTRY. 0           .NZ. IF LCM-RESIDENT SYMBOLS DECLARED
 N.TLAB   ENTRY.                   NUMBER OF LABELS BEING TRACED ( D OPT
  
*         LOOP INFORMATION TABLE USED BY "REFMAP" 
  
 O.LOOP   ENTRY.                   FWA OF LOOP TABLE ( PASS 2 ) 
 L.LOOP   ENTRY.                   LENGTH ( SET IN PASS 1 BY DOPROC ) 
  
*         FLAGS ASSOCIATED WITH ERROR PROCESSING
  
 N.ERROR  ENTRY.                   NUMBER OF ERRORS 
 N.FERR   ENTRY.                   NUMBER OF FATAL ERRORS 
 E.UDEFL  ENTRY.                   NON ZERO IF MISSING LABELS 
 P2NOGO   ENTRY. 0                 DEBUG-MODE OBJECT CODE CONTROL FLAG
*                                    1S59 = SUPPRESS, 0 = GENERATE CODE.
*         (DURING PASS 1, SET IF ANY FATAL-TO-DEBUG-EXECUTION ERRORS
*         OCCUR.  AT END OF PASS 1, *NOGOFLG* VALUE IS MERGED INTO
*         *P2NOGO*, WHICH THEN BECOMES THE PASS 2 MASTER CONTROL FLAG.) 
  
*         "SYMTAB" ORDINALS OF THE SPECIAL SYMBOLS
  
          ENTRY  O.TSS,L.TSS
 O.TSS    EQU    *                 FWA OF TABLE OF SPECIAL SYMBOLS
 TEMPA0.  ENTRY.
 VALUE.   ENTRY.
 TRACE.   ENTRY.
 ENTRY.   ENTRY.
 EXIT.    ENTRY.
 CON.     ENTRY.
 LABEL.   ENTRY.
 FTNNOP.  ENTRY.
 NOPS.    ENTRY.
 FP.      ENTRY.
 ST.      ENTRY.
 OT.      ENTRY.
 IT.      ENTRY.
 VD.      ENTRY.
 L.TSS    EQU    *                 LWA+1 OF TABLE 
  
*         LOCATIONS USED BY THE TABLE MANAGER 
  
 PHASE    ENTRY.                   0 - PHASE 1, 1 - DPCLOSE, 2 - PHASE 2
 NAF      ENTRY.                   30/N.ACTIVE TBLS,30/N.FIRST ACTIVE TB
 LTN      ENTRY.                   60/NUMBER OF LAST ACTIVE TABLE 
  
 LOWCORE  ENTRY.                   FWA OF ACTIVE TABLES 
*                                  LOWCORE .GE. O.COM 
 FWAWORK  ENTRY.                   FWA OF WORKING STORAGE , 
*                                  LWA+1 OF THE TABLES
 LWAWORK  ENTRY.                   LWA+1 OF WORKING STORAGE 
  
*         POINTERS TO THE PSEUDO SYMBOL TABLES FOR POSSIBLE FOWARD
*         REFERENCES IN COMPASS PRODUCED BY THE COMPILER
  
 O.GLT    ENTRY.             FWA OF GL DEFINATION TABLE 
 O.API    ENTRY.             FWA OF APLIST INDEX/DEFINATION TABLE 
 O.IOT    ENTRY.             FWA OF IOLIST DEFINATION TABLE 
  
 L.BATCH  =      *-O.BATCH         ** END BATCH CONTROL AREA ** 
  
 GOTOER.  ENTRY.                   DUMMY ENTRY POINT FOR COMPUTED GO TO 
          EQ     GOTOER.+400000B   ERRORS 
  
 O.CEP    ENTRY. 1                 SYMTAB ORDINAL OF CURRENT ENTRY POINT
  
  
  
**        INTERNAL OPTIMIZATION LEVEL VALUE (BINARY).  INITIALIZED TO 
*         CONTROL CARD OPTION VALUE EACH TIME PASS 1 IS LOADED.  MAY BE 
*         CHANGED (PROBABLY LOWERED) DURING PASS 1 OR 2, DEPENDING ON 
*         COMPLEXITY OF SOURCE PROGRAM. 
  
 OPTLVL   ENTRY. 0
 OPT2     ENTRY. 0           OPTLVL/2 ( "0 IF OPT .GE. 2  ) 
 STLTAB   SPACE  4,8
**        STLTAB - DEFINE STATIC LOAD DECK NAME TABLE.
* 
*         WHEN THE *STATIC* OPTION IS SELECTED, FCL DECK NAMES ARE
*         SELECTED BY *LISTIO/IOCM*, FORMATTED AS *LDSET USE=STLXXX.* 
*         DIRECTIVES AND WRITTEN TO *COMPS* BY *ENDPRO/OSL*, AND
*         ASSEMBLED TO *LGO* BY *FAX/PID3*.  *PH1CTL/CTL1* CLEARS THE 
*         DECK NAME SELECTION BITS AT THE BEGINNING OF EACH COMPILATION.
* 
* 
*         STLOAD    DECKNAM,PERMSEL 
* 
*         ARGS   *DECKNAM* = FCL DECK NAME. 
*                *PERMSEL* = 1 IF DECK NAME PERMANENTLY SELECTED. 
*                            MAY BE OMITTED OTHERWISE.
  
  
          PURGMAC STLTAB
  
 STLTAB   MACRO  DNAM,SEL 
          VFD    1/SEL,17/0,42/0L_DNAM
 STLTAB   ENDM
  
  
          ENTRY  STLTAB 
 STLTAB   BSS    0
          LOC    0
*CALL,STLOAD
          DATA   0           TERMINATE TABLE
          LOC    *O 
          TITLE              TABLE MACRO
*** 
*         TABLE MACRO - FORM QUANITIES FOR A TABLE TO BE MANAGED
*                       BY THE TABLE MANAGER. 
* 
*         ARGUMENTS:  
*         TNAME - TABLE NAME, MUST BE @ 5 CHARACTERS SINCE THE QUANITIES
*                O.TNAM , L.TNAM AND Z.TNAM ARE ENTRY POINTS
*                NOTE THAT LOCF(L.TNAM) " LOCF(O.TNAME)+1 
* 
*         TYPE
*                FIT - FIXED INCREMENT TABLE
*                AOR - ALLOCATE SPACE ON REQUEST
* 
*         AOV    ACTION ON OVERFLOW 
*                IER - ISSUE FC ERROR MESSAGE AND QUIT  OR
*                RTC - RETURN TO CALLER WITH FLAG SET 
* 
*         IAL    INITIAL ALLOCATION 
* 
*         INC    INCREMENT FOR FIXED INCREMENT TABLES 
* 
 AOR      EQU    0
 FIT      EQU    1                 FIXED INCREMENT TABLE
  
 IER      EQU    0                 ISSUE ERROR MESSAGE
 RTC      EQU    1                 RETURN TO CALLER 
  
          MACRO  TABLE,TNAM,TYPE,AOV,IAC,INC
          LOCAL  INCR 
 Z.TNAM   EQU    NTBLS.            TABLE NUMBER 
          ENTRY  Z.TNAM 
 NTBLS.   SET    NTBLS.+1 
          USE    ORIGINS
 O.TNAM   ENTRY.
          USE    SIZES
 L.TNAM   ENTRY.
          USE    ROOMS
 S.TNAM   ENTRY.
          USE    TINFO
 INCR     EQU    INC 40B           DEFAULTS TO 40B
+         VFD    1/TYPE,1/AOV,22/0,18/IAC,18/INCR 
          ENDM
          SPACE  3
*         "STBL" MACRO TO FORM A SHARED TABLE 
  
          MACRO  STBL,TBL1,TBL2 
          ENTRY  Z.TBL1,O.TBL1,L.TBL1,S.TBL1
 Z.TBL1   EQU    Z.TBL2 
 O.TBL1   EQU    O.TBL2 
 L.TBL1   EQU    L.TBL2 
 S.TBL1   EQU    S.TBL2 
          ENDM
  
 NTBLS.   SET    0
 LNTBS.   SET    0
          TITLE              TABLES FOR PASS 1
 CTIP     MACRO  INCR              COUNT NUMBER OF TABLES IN A PHASE
          LOCAL  F,N
 N        EQU    NTBLS.-LNTBS.
 F        EQU    LNTBS.            FIRST ACTIVE ONE 
          IFC    NE,/INCR//,1 
 LNTBS.   SET    NTBLS.            INCREMENT NUMBER OF FIRST ACTIVE TBL 
          USE    PHVECT 
+         VFD    30/N,30/F
          USE    *
          ENDM
  
*         ESTABLISH BLOCK ORDERING
  
          ENTRY  ORIGINS,SIZES,ROOMS,TINFO,NAFVEC 
          USE    ORIGINS
 ORIGINS  BSS    0                 ORIGINS(I) = FWA OF TABLE I
          USE    SIZES
 SIZES    BSS    0                 SIZES(I) = LENGTH OF TABLE I 
          USE    ROOMS
 ROOMS    BSS    0                 ROOMS(I) = SPACE ALLOCATED TO TABLE I
          USE    TINFO
 TINFO    BSS    0                 TINFO(I) = MISC INFO ABOUT TABLE I 
          USE    PHVECT 
 NAFVEC   BSS    0                 FWA OF NAF TBL 
          SPACE  2
*         TABLE DECLARATIONS
  
 COM      TABLE  FIT,IER,300B,40B 
 EQV      TABLE  FIT,IER,40B,40B
 DIM      TABLE  FIT,IER,100B,40B 
 DCON     TABLE  FIT,IER,0,20B     TEMPORARY DEBUG CONSTANT TABLE 
          CTIP
  
 LAT      TABLE  AOR,IER
 SCA      TABLE  AOR,IER
 ECT      STBL   SCA               TEMPORARY EQUIVALENCE CLASS TABLE
 EOT      TABLE  AOR,IER     EQUIVALENCE OVERLAP TABLE
          CTIP   INCR              END OF PHASE 1 TABLES
  
 FPBL     TABLE                    F.P. BLOCK LENGTH TBL ( NAMELIST ) 
 ASF      TABLE  AOR,IER           ASF DEFINITIONS
 ARLST    TABLE  AOR,IER           ARLIST BUFFER
  
 CON      TABLE  FIT,IER,50B,20B   BINARY LITERALS
 DATA     TABLE  FIT,IER,20B,20B   USEAGE DEFINED VARS IN DATA STMTS
 DIL      TABLE  FIT,IER,20B,20B   DATA ITEM LIST TABLE 
 DIT      TABLE  FIT,IER,20B,40B   DATA ITEM TABLE
 ENTR     TABLE  FIT,IER,1,10B     ENTRY POINTS 
 NML      TABLE FIT,IER,10B,10B    NAMELIST ITEM TABLE
 DOLST    TABLE  FIT,RTC,100B,20B  DO LIST
 IOLST    TABLE  FIT,IER,20B,10B   INPUT ORDINAL LIST TABLE 
 LTAB     TABLE  AOR,IER           GOTOPROC - LABEL TABLE 
  
 SCR      TABLE  AOR,IER           SCRATCH AREA FOR ASFREF , ETC
 EXT      STBL   ASF               FORMED AT THE END OF PASS 1
 UDV      STBL   FPBL              USEAGE DEFINED VARS - ENDPROC
          CTIP
  
 NTBLS    EQU    NTBLS.            NUMBER OF TABLES 
          USE    0
  
          ENTRY  T.FPBL 
 T.FPBL   EQU    TINFO+Z.FPBL 
          SPACE  3
 SAVTBL   MICRO  1,,
 STBIT    SET    60 
  
 SAVTBL   MACRO  TBL
 SAVTBL   MICRO  1,,$"SAVTBL",6/Z.TBL+1$
 STBIT    SET    STBIT-6
          IFLT   STBIT,0,1
          ERR    10 TABLES IS MAX THAT MAY BE SAVED 
          ENDM
  
*** 
*         LIST OF TABLES TO BE SAVED FOR PASS 2 
*         TABLES FIRST IN THE BELOW LIST WILL BE MOVED TO HIGH CORE LAST
  
          SAVTBL UDV
          SAVTBL EXT
          SAVTBL ENTR 
  
          ENTRY  SAVTBL 
 SAVTBL   VFD    STBIT/0"SAVTBL"
          SPACE  4
***       PUTTAB - DUMP A TABLE TO DISK 
* 
          ENTRY  PUTTAB 
          SPACE  2
**        ENTRY CONDITIONS
*                X2 = FWA OF TABLE
*                X3 = LENGTH OF TABLE 
*                X5 = 57/,1/ERFLAG,2/OPTLEVEL  (ONLY IF SYMBOL TABLE) 
*                X6 = TABLE TYPE
* 
*                TABLES ARE OUTPUT AS 1 RECORD. 
*                A TWO-WORD HEADER PRECEDES EACH TABLE
*                EMPTY TABLES ARE NOT DUMPED AT ALL 
*         HEADER TABLE FORMAT 
* 
*         WORD 1  42/7H_NAME,18/0 
* 
*         WORD 2
*         6/     TABLE TYPE (SEE MANTRAPS IPARAMS)
*         30/    UNUSED 
*         1/     1 IF ER OPTION ON  (ONLY IN SYMBOL ENTRY)
*         2/     COMPILATION OPT LEVEL (ONLY IN SYMBOL ENTRY) 
*         3/     PROGTYPE (0:PROGRAM,1:SUBROUTINE,2:FUNCTION) 
*         18/    TABLE LENGTH (EXCLUDING HEADER)
* 
 PUTTAB   BSS    1           ENTRY/EXIT 
          SPACE  2
*         SET UP 2 HEADER WORDS IN FRONT OF TABLE 
          SA1    =XPMDFLAG
          SA4    56B         PROGRAM TYPE 
          ZR     X3,PUTTAB   IGNORE EMPTY TABLES
          ZR     X1,PUTTAB   IF MANTRAP DISABLED, RETURN
          SA1    PROGNAM
          ZR     X4,PUTTAB   IGNORE BLOCKDATA 
          UX4    X4,B2       PROGRAM TYPE TO B2 
          LX5    3
          SX0    X5+B2       3/OPT,3/PROGTYPE 
          LX0    18 
          SPACE  1
          SA4    X2-2        FWA-2
          SA5    X2-1        FWA-1
          LX6    54 
          BX6    X6+X3
          BX6    X0+X6
          LX7    X1 
          SA6    A5          CORRUPT FWA-1
          SA7    A4          CORRUPT FWA-2
 #RM      IFEQ   CP#RM,7
          OPENM  ZZZZZSY,OUTPUT,E 
          SX3    X3+2         LENGTH = ORIG LENGTH + HEADER 
          SX7    A4           STARTING ADDRESS
          PUTW   ZZZZZSY,X7,X3
          CLOSEM ZZZZZSY,R
 #RM      ELSE
          IX6    X3+X2       LWA
          SX7    A4          SET OUT=FWA-2
          SA6    ZZZZZSY+2   IN=LWA 
          SA7    ZZZZZSY+3   OUT=FWA-2
          SPACE  1
          WRITER ZZZZZSY,R   WRITE OUT TABLE
          SPACE  2
*         RELOAD FWA-2,FWA-1
 #RM      ENDIF 
          BX6    X4 
          LX7    X5 
          SA6    A4 
          SA7    A5 
          EQ     PUTTAB 
          SPACE  4
 #RM      IFEQ   CP#RM,0
 ZZZZZSY  FILEB  *,0         DUMMY FIRST,DUMMY IN,DUMMY OUT,DUMMY LIMIT 
 #RM      ELSE
 ZZZZZSY  FILE   FO=SQ,RT=U,OF=R,CF=R,EO=T,MRL=131071 
 #RM      ENDIF 
          TITLE              ADDRESS FIELD DEFINITIONS
*** 
*         WORDB - DEFINE TYPE AND/OR ADDRESS DEFINITION FIELDS FOR WORD 
*         B OF SYMTAB ENTRY FOR SOME SPECIAL SYMBOLS
* 
          MACRO  WORDB,LOC,A,B,C,D
          LOCAL  NRL,NRB
          ENTRY  LOC
 TY=      SET    0
 RL=      SET    0
 RB=      SET    0
          SPLIT= A
          SPLIT= B
          SPLIT= C
 NRL      EQU    P.TYP-P.RL 
 NRB      EQU    P.RL-P.RB
 LOC      VFD    L.TYP/TY=,NRL/RL=,NRB/RB=,P.RB/D 
          ENDM
  
 SPLIT=   MACRO  A
          IFC    NE,/A//,3
 N        MICRO  1,3,/A/
 R        MICRO  4,,/A/ 
 "N"      SET    "R"
          ENDM
  
 START.   MICRO  1,,/0/ 
 ENTRY.   MICRO  1,,/2/ 
 CODE.    MICRO  1,,/3/ 
 DATA.    MICRO  1,,/4/ 
 HOL.     MICRO  1,,/6/ 
  
*                                  POST - LABELS AND ENTRY POINTS 
 WB.LAB   WORDB  RL=1,RB="CODE."   FAX - GL , AP AND VD LABELS
  
*                                  HEADER CARD PROCESSOR
 WB.ESS   WORDB  TY=T.CGS,RL=1,RB="START."
 WB.LFN   WORDB  TY=T.LFN,RL=1,RB="START."
  
*                                  ENTRY STMT PROCESSOR 
 WB.FTN   WORDB  TY=T.CGS,RL=1,RB="ENTRY."
 WB.NOP   WORDB  TY=T.CGS,RL=1,RB="DATA." 
*                                  CON. - SET IN DPCLOSE
 WB.CON   WORDB  TY=T.CGS,RL=1,RB="DATA.",V.LDO 
*                                  NAMELIST 
 WB.NML   WORDB  TY=T.NML,RL=1,RB="DATA." 
*                                  FORMAT LABELS
 WB.FMT   WORDB  RL=1,RB="DATA."
  
*                                  HOL. - SET IN CONVERT
 WB.HOL   WORDB  TY=T.CGS,RL=1,RB="HOL.",V.LDO
  
*                                  ENDPROC
 WB.ECGS  WORDB  TY=T.CGS,RL=1,RB="CODE." 
 WB.PROG  WORDB  RL=1,RB="CODE."
 WB.FP    WORDB  RL=1,RB=7
          TITLE              TABDMP - DUMP A TABLE TO DISK ( DEBUG RTN )
 .T       IFEQ   TEST,0 
  
 SYMDMP   ENTRY. ** 
          EQ     SYMDMP      EXIT WITHOUT ACTION
  
 TABDMP   ENTRY. ** 
          EQ     TABDMP      EXIT WITHOUT ACTION
  
 .T       ELSE
  
 #RM      IFEQ   CP#RM,0
  
*** 
*         TABDMP - DUMP CORE TO THE FILE "SYMTAB" 
* 
*         ON ENTRY: 
*                X1,X2 = PREFIX WORDS , BCD AND INDEX 
*                X3,X4 = FWA,LWA+1 OF TABLE TO BE DUMPED
* 
 TABDMP   ENTRY.
          SX7    X3-2              FWA-2
          SB1    1
          SA7    F.TEST+I.FIRST    (FIRST) = PREFIX WORD ADDRESS
          BX6    X4 
          SA6    A7+B1             (IN)    = LWA+1
          SA7    A6+B1             (OUT)   = (FIRST)
          SX6    77B
          SA6    A7+B1             (LIMIT) = LWA+100B 
          SA4    X3-2 
          SA5    A4+B1
          BX6    X4 
          LX7    X5 
          SA6    SAVE 
          SA7    A6+B1
          BX6    X1 
          LX7    X2 
          SA6    A4 
          SA7    A5 
          WRITER F.TEST,RCL 
          SA1    SAVE 
          SA2    A1+B1
          SA3    F.TEST+I.FIRST 
          BX6    X1 
          LX7    X2 
          SA6    X3 
          SA7    X3+B1
          EQ     TABDMP 
  
 SAVE     BSSZ   2                 TO SAVE 2 WORDS
 F.TEST   VFD    42/0LSYMTAB,18/3 
          CON    *           DUMMY -FIRST-
          CON    *-1         DUMMY -IN- 
          CON    *-2         DUMMY -OUT-
          CON    *           DUMMY -LIMIT-
          DATA   0           DUMMY FET WORD 5 
          TITLE              SYMDMP - SYMTAB DUMP ROUTINE 
*** 
*         SYMDMP - DUMP THE SYMBOL TABLE TO THE FILE "SYMTAB" 
* 
 SYMDMP   ENTRY.
          SA2    L.SYMTAB 
          SA3    O.SYMTAB 
          SB1    1
          SX7    X3-1 
          SX6    X2+B1             FIRST
          SX2    F.TEST 
          SA6    X2+B1
          SA7    A6+B1             IN 
          SA6    A7+B1             OUT = FIRST
          SX7    X3+100B
          SA7    A6+B1             LIMIT
          WRITER X2,RCL 
          EQ     SYMDMP 
  
 #RM      ELSE
  
 TABDMP   ENTRY. ** 
          EQ     TABDMP 
  
*         SYMDMP - DUMP THE SYMBOL TABLE USING RECORD MANAGER.
  
 SYMDMP   ENTRY. ** 
          SA2    L.SYMTAB 
          SA3    O.SYMTAB 
          IX4    X3-X2
          SX5    X2+1 
          SX4    X4-2 
          PUTW   FI.TEST,X5,X4
          EQ     SYMDMP      EXIT 
  
*         DECLARE *SYMTAB* FIT AND ADDRESS POINTER. 
  
 FI.TEST  FILE   LFN=SYMTAB,FO=SQ,OF=R,CF=R,PD=IO,EO=T,RT=W,MRL=131071
 F.TEST   CON    FI.TEST
  
 #RM      ENDIF 
  
 .T       ENDIF 
  
          IFNE   TEST,0,2 
 DMPTBL=  ENTRY. **          PLUGGED FROM *CLOSE2* TO *  RJ  PTC= * 
+         EQ     RPV5 
          SPACE  3
          END    FTN20
