*DECK HEADER
          IDENT  HEADER 
 HEADER   SECT   (HEADER STATEMENT PROCESSING),1
  
          SST 
  
 B=HEAD   RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  PPA4,PSF,DCM3,PSFA,PPAD,DCM,PPA,PSA
          ENTRY  PPA355 
          ENTRY  PIDX,PFDX
  
*         IN FTN
          EXT    CO.BLN,CO.EDT,LOP=O
          EXT    CO.ER
  
*         IN TABLES 
          EXT    BA.PRO,CSNTAG,ENTRY.,IDENT,IDENT1,MOD
          EXT    NARGS,ORG,STAGE,STN,TA.PRO,TG.PRO,TS.ENT,TS.SYM,TT=LF
          EXT    TT.LF,F.LF,BINIO 
          EXT    T=FILE,T.FILE
          EXT    IGS
  
*         IN ERRORS 
          EXT    E.AC,E.AC3,E.AC4,E.AC5,E.AC6,E.AC8,E.AC9,E.ANS 
          EXT    E.AP,E.AP1,E.FA,E.FR,E.MR1,E.PN1,E.PN3,E.TC1,E.TC3 
          EXT    E.TC4,E.TC5,E.TC6,E.TC7,E.TC9,E.TC10,E.XC,E.ZA,FILL. 
          EXT    FILL.2,E.TC2,E.TC11
  
*         IN PIG
          EXT    WIN,PIG
  
*         IN MAP
          EXT    SFN
  
*         IN END
          EXT    BT.IDNT,BT.XFR1
  
*         IN ALLOC
          EXT    SCTR,SSY 
  
*         IN MAIN 
          EXT    CPM=IMP,PSFX,WOF 
  
*         IN LEX
          EXT    S.Q2NTR,TSF,DEC,STY
          EXT    S.FTNRP
  
*         IN IO 
          EXT    FFN
  
*         IN REG
          EXT    CRJ
  
*         IN TYPE 
          EXT    TYP02
  
 PSF      SPACE  4,8
**        PSF -  PROCESS SPECIAL FIRST CARD.
*                WHEN NO HEADER CARD IS PRESENT, *PSF* IS CALLED TO EMIT
*         " PROGRAM START. (INPUT, OUTPUT) "
*         EXIT   TO *PSFX*, WHICH IS IN *CPM*.
*                (A0)  RESTORED FROM (F.SB) 
*                (X5) RESTORED FROM ("SB.KEY"). 
*                (B4) PRESERVED.
  
  
 PSF      WARN   E.PN3
          SX7    B4 
          SA4    PSFA 
          MI      X4,PSF1    IF PSF IS CALLED IN THE MIDDLE OF TYPE PROC
          MX4     0 
 PSF1     BX7    X7+X4
          SX6    M.PPRO 
          SA7    PSFA        SAVE (B4)
          SB4    DPN         POINT TO FAKE STRING 
          SA4    =7HPROGRAM 
          RJ     DCM         PROCESS COMPILE MODE + DISPLAY 
          RJ     PPA         PROCESS ARGUMENTS
          SA1    =XT.SB 
          BX6    0
          SA0    X1 
          SA6    STN
          SA6    CSNTAG 
          SA1    PSFA 
          SA5    "SB.KEY" 
          SB4    X1          RESTORE (B4) 
          MI     X1,TYP02    IF CALLED FROM *TYPE* PROCESSING 
          EQ     PSFX        EXIT.. 
  
 PSFA     DATA   0           LOWER 18 BITS IS A SAVE AREA FOR B4. 
*                            SIGN BIT IS SET IF PSF WAS CALLED IN THE 
*                            MIDDLE OF TYPE PROCESSING
  
  
**        DEFAULT SUBPROGRAM NAME + PARAMETERS
*         SET = *PROGRAM START.(INPUT,OUTPUT)*
  
 DPN      VFD    42/0LSTART.,18/O.VAR 
          CON    O.(
          VFD    42/0LINPUT,18/O.VAR
          CON    O.COMMA
          VFD    42/0LOUTPUT,18/O.VAR 
          CON    O.)
          DATA   0           END OF STRING INDICATOR
 DCM      SPACE  4,15 
**        DCM -  DISPLAY *COMPILING* MESSAGE. 
* 
*         CHECKS LEGALITY OF NAME AND ENTERS IT IN SYMBOL TABLE AND 
*                ENTRY POINT TABLE. 
*         DISPLAYS CONSOLE MESSAGE, PRINTS *IDENT* CARD, AND SETS NAME
*                INTO MAIN TITLE AND 77-TABLE.
* 
*         ENTRY  (B4) _ SUBPROGRAM NAME (IN *SB*).
*                (X4) = DPC PROGRAM TYPE FOR BANNER.
*                (X6) = PROGRAM-UNIT COMPILE MODE.
* 
*         EXIT   (B4) _ NEXT ELEMENT OF *SB*. 
* 
*         CALLS  ADDWD, MESAGE, PVF, SFN. 
  
  
 DCM      SUBR   0
          SA2    MOD
          BX6    X6+X2
          SA6    A2          SET COMPILE MODE 
          BX6    X4 
          SA6    =XTL.PTYP
          SX4    =XBT.IDN8
          SA6    X4+=XBT.IDNT 
          SA4    B4 
          MX0    LG.VAR*CHAR
          SX2    X4-O.VAR 
          NZ     X2,DCM1A    IF PROGRAM NAME NOT VARIABLE 
          BX2    X0*X4       CLEAR TYPE CODE
          LX2    CHAR 
          SX2    X2-1R0 
          PL     X2,DCM1A    IF NOT A LETTER
          =A2    B4+1 
          SB7    X2-O.VAR 
          NZ     B7,DCM1     IF LESS THAN 8 CHAR
          RJ     =XTLV       TRUNCATE NAME
          EQ     DCM1 
  
 DCM1A    FATAL  E.PN1       SYNTAX ERROR IN ROUTINE NAME 
          SA4    DCM3        SET *DUMMY* NAME 
 DCM1     MX0    L.SYM
          BX6    X0*X4
          LX4    X6 
          SA6    IDENT       ROUTINE NAME IN 0L FORMAT
          SA6    BT.IDNT+1
          SA6    BT.XFR1
          SCAN   TS.SYM,SSY  FIND WHERE TO PUT *SYMBOL/TAG* 
          =X7    M.ENT+M.DEF+M.NVAR 
          ADSYM  A1          ADD *SYMBOL/TAG* TO TABLE. 
          SA1    =XREFLIN 
          LX1    18-CHAR
          SX6    X0+B1
          BX6    X6+X1
          SA6    ENTRY. 
          BX6    X0+X4
          ADDWD  TS.ENT 
          SA1    ENTRY. 
          =X6    X1+C.VAR 
          LX6    P.TAG
          ADDREF X6,CR.NTR
          BX1    X4 
          RJ     SFN         SPACE FILL NAME. 
          SA1    =XCP.PW
          SA6    =XNAME      ROUTINE NAME SPACE FILLED
          ZR     X1,DCM2     IF NOT IN PW MODE
          SA2    =XTL.PTYP
          MX0    8*CHAR 
          BX1    X0*X2       (X1) = 1ST 8 CHARACTERS OF ROUTINE TYPE
          BX3    -X0*X2      (X3) = LAST 2 CHARACTERS OF ROUTINE TYPE 
          BX4    X0*X6       (X4) = 1ST 8 CHARACTERS OF ROUTINE NAME
          BX6    X3+X4
          SX3    2R 
          BX7    X3+X1
          LX7    -2*CHAR
          SA7    A2 
          LX6    -2*CHAR
 DCM2     SA6    =XTL.PNAM
          MESAGE IDENT1,CONSOLE 
          =X6    CPM=IMP
          SA6    STAGE
          SA1    =XHDELAY 
          ZR     X1,DCM4     IF NO HEADER DELAY 
          SA0    B4          SAVE (B4)
          RJ     =XLDB       LIST DEFERRED BUFFER 
          SB4    A0          RESTORE (B4) 
 DCM4     SA2    =XLOP=O     OBJECT LIST FLAG 
          MI     X2,=XPID    IF OBJECT LIST - PRINT IDENT 
*         ... 
 PIDX     SA1    B4 
          ZR     X1,DCMX     IF NAME MISSING
          =B4    B4+1 
          EQ     DCMX 
  
 DCM3     LIT    7LXXX****   DUMMY NAME WHEN NAME ERROR 
 PPA      SPACE  4,8
**        PPA -  PROCESS PROGRAM ARGUMENTS
*         ENTRY  B4 _ PAREN IN FRONT OF (POSSIBLE) ARGUMENTS
*         CALLS  PXE, SCTR, DEC, ALC, FFN, SFN, PVF, SSY, ADW, ESY
  
  
 PPA      SUBR   0
          RJ     PXE         PROCESS TRACEBACK WORD 
          SA1    B4 
          =X4 
          ZR     X1,PPA63    IF NO ARGUMENT LIST
          SB7    X1-O.( 
          NZ     B7,E.AP     IF NO *(* - ERROR
          SB4    B4+B1       POINT TO FIRST FILE NAME 
  
**        PROCESS PROGRAM ARGUMENTS LOOP
  
 PPA1     SA4    B4 
          MX0    7*CHAR 
          ZR     X4,E.MR1    IF EOS INSTEAD OF FILE NAME
          BX6    X4*X0
          SA6    FILL.2 
          MX0    6*CHAR 
          SA1    B4+B1       FETCH NEXT SEPARATOR 
          BX2    -X0*X6 
          ZR     X2,PPA12    IF NO SEVENTH CHARACTER IN FILE NAME 
          FATAL  =XE.TC11    FILE NAME EXCEEDS 6 CHAR 
 PPA12    SX5    X4-O.VAR 
          ZR     X5,PPA13 
          FATAL  =XE.TC11    FILE NAME EXCEEDS 6 CHAR.
 PPA13    BX4    X6 
          =B4    B4+1 
          SX5    X1-O.= 
          ZR     X1,E.MR1    IF *EOS* - ERROR 
          SA6    FILL.
          SA6    PPAF 
          SA0    -1          INITIALLY, NO RECORD LENGTH INDICATED
          SCAN   T.FILE,SCTR
          SX7    B7 
          SA7    PPAE 
          MI     B7,PPA15    IF *NIT* 
          WARN   E.TC1       ERR..  FILE DOUBLY DEFINED 
 PPA14    =A1    B4+1 
          SB2    X1-O.COMMA 
          ZR     X1,E.MR1    IF *EOS* - ERROR 
          =B4    B4+1 
          SB7    X1-O.) 
          ZR     B7,PPA62    IF *)*, CONTINUE FILE PROCESSING 
          NZ     B2,PPA14    IF NOT COMMA, CONTINUE 
          =B4    B4+1 
          EQ     PPA1        LOOP FOR MORE FILES
  
 PPA15    NZ     X5,PPA4     IF NO EQUAL SIGN 
  
  
**        PROCESS EQUIVALENCED FILE 
  
          SA2    B4+B1       FETCH EQUIVALENCE ELEMENT
          MX0    7*CHAR 
          SB4    A2+B1
          BX6    X0*X2
          SB2    X2-O.VAR 
          =B7    B2+O.VAR-O.CONS
          ZR     X2,E.MR1    IF *EOS* - ERROR 
          SX5    X2-O.SLASH 
          NZ     X5,PPA17    IF NOT */* 
          MX5    1           INDICATE NO BUFFER LENGTH GIVEN
          EQ     PPA2        GO PROCESS RECORD LENGTH 
  
 PPA17    SA6    FILL.2 
          ZR     B7,PPA3     IF NUMBER
          NZ     B2,E.TC7    IF NO LETTER 
          MX0    6*CHAR 
          BX5    -X0*X6 
          ZR     X5,PPA18 
          FATAL  =XE.TC11    FILE NAME EXCEEDS 6 CHAR 
 PPA18    SCAN   T.FILE,SCTR
          SB5    B7 
          MI     B7,E.TC6    IF *NIT*, ERR..
          SB2    -B7
          MX1    1
          SX0    X2+B2
          BX3    X1+X2       SET EQUIVALENCED BIT 
          IX5    X3-X0       6/ -,  18/ L.TAG,  18/ FIT,  18/ ORDINAL 
          SA0    -1 
          EQ     PPA55       CONTINUE.. 
  
**        PROCESS RECORD LENGTH DECLARATION 
  
 PPA2     SA2    B4 
          SB2    X2-O.CONS
          NZ     B2,E.TC9    IF NOT NUMBER - ERROR
          RJ     DEC         CONVERT RECORD LENGTH
          SB4    B4+B1
          SB7    X1-M.INT 
          ZR     X1,PPA25    IF UNIVERSAL TYPE
          NZ     B7,E.TC9    IF NOT TYPE INTEGER - ERROR
 PPA25    SX3    MAX.RECL 
          IX3    X3-X6
          MI     X3,E.TC10   IF RECORD LENGTH TOO LARGE - ERROR 
          MI     X6,E.TC9    IF RECORD LENGTH NEGATIVE - ERROR
          SA0    X6 
          MI     X5,PPA4     IF NO BUFFER LENGTH
          EQ     PPA5 
  
**        PROCESS BUFFER LENGTH DECLARATION 
  
 PPA3     SB4    B4-B1
          RJ     DEC         CONVERT BUFFER LENGTH
          SB4    B4+B1
          SB7    X1-M.INT 
          ZR     X1,PPA35    IF UNIVERSAL TYPE
          NZ     B7,E.TC3    IF NOT TYPE INTEGER
 PPA35    SX3    MAX.BUFL 
          IX3    X3-X6
          SX5    X6 
          MI     X3,E.TC4    IF BUFFER LENGTH TOO LARGE - ERROR 
          MI     X6,E.TC3    IF BUFFER LENGTH NEGATIVE - ERROR
          ZR     X5,PPA352   IF BUFFER LENGTH ZERO, HONOR IT
          SX5    X5+3        INCR 3 TO PREVENT S-TAPE PROBLEMS
 PPA352   SA2    B4 
          SB2    X2-O.SLASH 
          NZ     B2,PPA5     IF NOT */* 
          =B4    B4+1 
          EQ     PPA2        GO PROCESS RECORD LENGTH 
  
 PPA355   =X5    MAX.BUFL+3  BUFFER LENGTH REQUESTED EXCEEDS 360000 
*                            -- 360000 SUBSTITUTED
          EQ     PPA45       CHECK FOR TERMINAL ORIGIN JOB
  
 PPA4     =X5    L.IOBUF6    DEFAULT BUFFER LENGTH (2003B)
 PPA45    =A4    PPAF 
          SA3    =XJOT
          ZR     X3,PPA5     IF NOT TERMINAL ORIGIN JOB 
          SA3    DPN+2       DPC FOR *INPUT*
          MX0    42 
          BX3    X0*X3       STRIP OFF LOWER 18 BITS
          SX5    L.TIN       DEFAULT INPUT BUFF LENGTH FOR TERMINAL JOBS
          BX3    X4-X3
          ZR     X3,PPA5     IF FILE *INPUT*
          SA3    DPN+4       DPC FOR *OUTPUT* 
          BX3    X0*X3       STRIP OFF LOWER 18 BITS
          SX5    L.TOUT      DEFAULT OUTPUT LENGTH FOR TERMINAL JOBS
          BX3    X4-X3
          ZR     X3,PPA5     IF FILE *OUTPUT* 
          SX5    L.IOBUF6 
  
**        DEFINE NEW FILE  (ENTER INTO *LONG FILE*).
*                (X4) = 42/0LFILENAM
*                (X5) = BUFFER LENGTH 
*                (B6) \ 0 IFF ALREADY DEFINED.
  
 PPA5     SA3    TG.PRO 
          SA2    ORG
          SA1    PPAE 
          PL     X1,PPA6     IF FILE ALREADY DEFINED
          SX6    X3+B1       UPDATE PROGRAM TAG 
          SX7    X2+L.FIT6   CRM FIT LENGTH INCR
          SA3    =XOT.RM
          ZR     X3,PPA52    IF 6RM AT OBJECT TIME
          SX7    X2+L.FIT7   7RM FIT LENGTH INCR
          SX5    L.IOBUF7    (7RM ONLY) ALLOCATE NO CIO BUFFER
 PPA52    SA6    TG.PRO 
          LX6    18 
          IX1    X2+X6
          SA7    A2          UPDATE ORIGIN COUNTER
          LX1    18 
          IX5    X5+X1       =  6/ 0,  18/ L.TAG,  18/ (ORG),  18/ BUFLN
  
 PPA55    ALLOC  T.FILE,2 
          LX7    X5 
          BX6    X4 
          =A7    B7-1 
          =A6    A7-1 
  
*         SET UP ENTRY FOR WORKING STORAGE AREA 
  
          SX5    A0 
          PL     X5,PPA57    IF RECORD LENGTH SPECIFIED 
          MX5    1           =  1/1,  59/0  (DUMMY ENTRY) 
          EQ     PPA58
  
 PPA57    SA3    TG.PRO 
          SX6    X3+B1       UPDATE PROGRAM TAG 
          SA6    A3 
          LX6    36 
          IX5    X5+X6       =  6/0,  18/L.TAG,  18/0,  18/MRL
  
 PPA58    ALLOC  T.FILE,1 
          LX7    X5 
          =A7    B7-1 
  
**        CHECK FOR MORE FILE DECLARATIONS
*                EXPECT COMMA OR RIGHT PAREN. 
  
 PPA6     SA1    B4          FETCH NEXT SEPARATOR 
          SB4    B4+B1       POINT B4 TO (POSSIBLE) NEXT FILE NAME
          SB7    X1-O.COMMA 
          ZR     X1,E.MR1    IF *EOS* - ERROR 
          SB2    X1-O.) 
          ZR     B7,PPA1     IF COMMA, LOOP FOR MORE FILES
          SA2    B4 
          NZ     B2,PPA61    IF NO *)* - ERROR
          ZR     X2,PPA62    IF *EOS* 
          WARN   E.XC        WARN THAT WE IGNORED TRAILING CHARACTERS.
          EQ     PPA62
  
PPA61     SB4    B4-1 
          EQ     E.TC2
  
  
**        END OF STATEMENT SCANNING.
*                MARK THE END OF THE FILE LIST. 
*                CHECK FOR TOO MANY FILES.
*                SET UP (NARGS) AND (BT.IGS). 
  
 PPA62    SA4    T=FILE 
          SB2    X4-3*MAX.PARG
          LE     B2,PPA63    IF NOT TOO MANY FILES
          SX4    3*MAX.PARG 
          SHRINK A4,X4
          WARN   E.TC5       ** TOO MANY FILES ** 
  
*         NUMBER OF ARGS IS (X4)/3 -- THE DIVISION IS NOW DONE BY A 
*         SUBTRACTION LOOP
  
 PPA63    =B2    0           INITIALIZE QUOTIENT
          ZR     X4,PPA63B   IF NO FILES
          SX3    3
 PPA63A   IX4    X4-X3
          =B2    B2+1        INCREMENT QUOTIENT 
          NZ     X4,PPA63A   IF DIVISION NOT COMPLETE 
 PPA63B   SX6    B2 
          SA6    NARGS
          BX6    0
          ADDWD  T.FILE      MARK END OF LIST 
          SA5    X1 
          ZR     X5,PPA7     IF NO FILES
          SA6    TFI         INITIALIZE T.FILE INCREMENT FOR PRINT
*                            FILE DESCRIPTION MACRO LOOP. 
  
  
**        PRINT FILE DESCRIPTION MACROS.
  
 PPA64    SA4    A5+B1       FETCH TAG WORD 
          SA2    =XLOP=O     OBJECT LIST FLAG 
          MI     X2,=XPFD    IF OBJECT LIST - PRINT FILE DESCRIPTORS
          LX4    -18
          MX3    LG.VAR*CHAR
          SX4    X4 
          BX6    X3*X5
          RJ     FFN         ADD SPECIAL CHARACTER TO FILE NAME 
*         ... 
 PFDX     BSS    0           ** RETURN FROM PFD 
          BX5    X6 
          SCAN   TS.SYM,SSY        PREPARE TO ADD SYMBOL
          PL     B7,E.ZA     IF ALREADY IN TABLE, COMPILER ERROR. 
          =X7    M.ENT+M.DEF+M.NVAR 
          LX4    P.PNT
          BX7    X4+X7
          ADSYM  A1 
          SA3    CO.EDT 
          IX5    X5+X3       MERGE LINKAGE-SUPPRESSION BIT
          BX6    X0+X5
          ADDWD  TS.ENT 
          SA2    TFI         T.FILE INCREMENT 
          SX6    X2+3 
          SA3    T.FILE      X3 = ORIGIN
          SA6    A2          SAVE NEW INCREMENT 
          SA5    X3          FWA OF T.FILE
          SB7    X6 
          SA5    A5+B7
          NZ     X5,PPA64    IF MORE FILES
  
  
**        PRINT *FILE VECTOR*.
  
 PPA7     PIA    ORG,PPAC 
          SA3    ORG
          SA2    NARGS
          SX4    CT.FILE
  
 .RM      IFEQ   OT#RM,6
  
          NZ     X2,PPA7.5   IF MAIN PROGRAM WITH FILES 
          SA1    =XCO.STA 
          ZR     X1,PPA7.5   IF NOT STATIC MODE 
          SX2    X2+=XL.STL+1      NO FILES + STLTAB + AP-LIST POINTER
  
 PPA7.5   SX2    X2+L.LIST   Q2NTRY AP-LIST 
  
 .RM      ENDIF 
  
          SA5    TA.PRO 
          IX1    X3+X2
          SX6    X1+B1
          LX4    P.TAG
          BX7    X4+X3
          SA6    A3          ADVANCE ORIGIN COUNTER 
          SA7    X5+CT.FILE-C.PRO  DEFINE ADDRESS OF *CT.FILE*
          SA6    BA.PRO 
          SA2    LOP=O
          PL     X2,PPA8     IF NO OBJECT LISTING 
          PLINE  PPAC,4      PRINT * L.S   Q2NTRY   NNNNN * 
  
  
*         COMPILE CALLS TO *Q2NTRY.* AND *FTNRP2.*. 
  
 PPA8     SA1    CO.ER       CHECK FOR OTR
          ZR     X1,PPA9
          RJ     PIG
          RJ     SOR
 #FID     IFNE  .FID,0
          SA3    =XCO.ID     INTERACTIVE DEBUG FLAG 
          MI     X3,PPA9     IF FID ON
 #FID     ENDIF 
          SX1    =XSB=BKS3
          SX1    X1+2 
          SA3    =XREFLIN 
          LX1    P.LI12 
          LX3    P.LBIAS-CHAR 
          BX7    X1+X3
          WCODE  X7          SB0  B2+LINENO 
 PPA9     BSS    0
          SA1    ENTRY. 
          CBSS   X1+C.VAR    COMPILE ENTRY POINT
 A        OCTMIC CT.FILE,6
          SA3    =5110"A"BS30 
          WCODE  X3          COMPILE  *SA1 FILE.* 
          SA2    CO.ER
          NZ     X2,PPA10    IF *ER* SET, DO FTNRPV. ONLY 
          TAGSEX S.Q2NTR     IF ER = 0 CALL Q2NTRY. 
          CRJ    NONE        COMPILE  * RJ  =XQ2NTRY. * 
          RJ     PIG         PRINT INSTRUCTION GROUP
          EQ     PPAX 
 PPA10    TAGSEX S.FTNRP
          CRJ    NONE        COMPILE  * RJ  =XFTNRP2. * 
          RJ     PIG         PRINT INSTRUCTION GROUP
          EQ     PPAX        EXIT.. 
 TFI      BSS    1           T.FILE INCREMENT 
  
 PPAC     BSS    1           ADDRESS
 A        OCTMIC CT.FILE-C.PRO
          DATA   10H L."A"
          DIS    1,Q2NTRY    FILE VECTOR MACRO CALL 
 PPAD     DIS    1,          PRINT LIMIT (SET BY *IMO*) 
  
 PPAE     DATA   0
 PPAF     DATA   0
 PPAG     BSS    1
          DATA   10H
          DATA   10HSB0    B2-
          DIS    1,LEN. 
          DATA   0
 PPAH     DATA   10H
          DATA   10H
          DATA   10HSB0    B2+
          DIS    1,L.0      T 
          DIS    1,RACE.
          DATA   0
  
**        SOR-   SET OBJECT TIME REPRIEVE CODE
*         WHEN CONTROL CARD OPTION *ER* IS SET,  SET FIRST INSTRUCTIONS 
*         IN LONG FILE TO BE  * SB0  B2-LEN. * (LEN. = LENGTH OF
*         ROUTINE) AND * SB0  B2+POINTER * (POINTER = POINTER TO TRACE
*         WORD).  WHEN LENGTH OF ROUTINE IS DETERMINED (IN *END* ) THE
*         TRUE VALUE WILL THEN BE APPENDED TO THE INSTRUCTION BEFORE
*         THE LONG FILE IS PROCESSED (IN *END*).
* 
*         USES - X0-X4,X6,A1-A4,A6,B1,B2
  
  
 SOR      SUBR   0
          MX0    1
          AX0    16 
          SA4    =6102BS48
          LX0    48 
          IX3    X0+X4       SET TAG FIELD NONZERO _ 61027777760-0B 
          WCODE  X3          X4 IS PRESERVED. 
 A        OCTMIC CT.TRAC,6
          SA4    =6102"A"BS30 
          WCODE  X4          TAG FIELD = 0  _ 61020-0B
          SA1    ORG
          SX6    X1+B1
          SA6    A1          ADVANCE ORIGIN COUNTER 
          SA1    BINIO
          ZR     X1,SOR2     IF LONG FILE IS IN CORE
          SA1    TT.LF
          SA2    TT=LF
          WRITEW F.LF,X1,X2  PUT OTR INSTRUCTIONS ON DISK 
          SHRINK TT=LF
 SOR2     SA1    TT=LF
          BX6    X1 
          SA6    IGS         PIG WILL NOT PROCESS THE OTR INSTRUCTIONS
          SA2    LOP=O
          PL     X2,SOR1     IF NO OBJECT LISTING 
          PIA    ,PPAG
          PLINE  PPAG,4      PRINT * SB0  B2-LEN.*
          PLINE  PPAH,5      PRINT * SB0  B2+L.0   TRACE. * 
 SOR1     EQ     SOR
 PSA      SPACE  4,15 
**        PSA -  PROCESS SUBPROGRAM ARGUMENTS.
*         ENTRY  (B4) _ *(* AT BEGINNING OF (POSSIBLE) ARGUMENT LIST. 
*         USES   ALL
*         CALLS  PIG, PXE, STY, TLV.
  
  
 PSA      SUBR   0
          RJ     PXE         PROCESS TRACEBACK WORD 
          SA1    B4 
          SB6    B0          SET ARGUMENT COUNT TO ZERO 
          ZR     X1,PSA11    IF NO ARGUMENTS
          SX2    X1-O.( 
          NZ     X2,PSA13    IF NO *(*
          SA1    B4+B1
          SB4    B4+B1
          ZR     X1,E.MR1    IF EOS INSTEAD OF ARGUMENT 
  
 PSA1     MX0    LG.VAR*CHAR
          SB7    X1-O.VAR 
          BX6    X0*X1
          SA6    FILL.
          ZR     B7,PSA12    IF LETTER
          FATAL  E.AC4
          EQ     PSA17
  
 PSA11    SX6    B6 
          SA6    NARGS       STORE NUMBER OF ARGUMENTS
          SA1    MOD
          LX1    59-P.PFNC
          PL     X1,PSA32    IF NOT A FUNCTION
 PSA11A   FATAL  E.FA 
          EQ     PSA32
  
 PSA12    SCAN   TS.SYM,SSY 
          MI     B7,PSA14    IF NOT PREVIOUSLY DEFINED
          FATAL  E.AC3
          EQ     PSA15
  
 PSA13    SX6    B6 
          SA6    NARGS       STORE NUMBER OF ARGUMENTS
          SA2    MOD
          LX2    59-P.PFNC
          MI     X2,PSA11A   IF A FUNCTION
          SX3    X1-O.COMMA 
          NZ     X3,E.AC6    IF NO *,* - ERROR
          EQ     PSA22
  
 PSA14    RJ     STY         SET NATURAL TYPE 
          =X3    B6+1        = ORDINAL OF ARGUMENT
          =X2    M.FP 
          =B6    B6+1        COUNT ARGUMENTS
          LX3    P.FPNO 
          IX1    X2+X1
          BX7    X1+X3
          ADSYM  TS.SYM 
  
 PSA15    ADDREF X6,CR.CALL 
  
 PSA17    =A3    B4+1 
          SB7    X3-O.VAR 
          NZ     B7,PSA18    IF NOT LONG NAME 
          RJ     =XTLV       TRUNCATE NAME
          =A3    B4+1 
 PSA18    ZR     X3,E.MR1    IF NO *)* - ERROR
          SA1    A3+B1
          SX2    X3-O.COMMA 
          SB4    A3+B1       B4 = B4+1
          ZR     X2,PSA1     IF *,* LOOP ON NEXT ARGUMENT 
          SX2    X3-O.) 
          NZ     X2,E.AP1    IF NO *)* - ERROR
          SX6    B6 
          SA6    NARGS
          SA2    B4 
          ZR     X2,PSA3     IF *EOS* 
          SX1    X2-O.COMMA 
          ZR     X1,PSA22 
          SA1    X2+=XCHARMAP 
          MX0    L.CDPC 
          NZ     X1,PSA21A   IF NOT VAR OR CONS 
          LX1    X2 
 PSA21A   BX6    X0*X1
          SA6    FILL.
          EQ     =XE.TY      OUTPUT ERROR 
 PSA22    SA1    B4+B1
          SB4    B4+B1
          MX0    LG.VAR*CHAR
          SB7    X1-O.VAR 
          BX6    X0*X1
          NZ     B7,PSAERR   IF NOT LETTER - ERROR
          MX2    4*CHAR 
          BX2    X2*X1
          SA3    =0LRETU
          IX2    X2-X3
          NZ     X2,PSAERR   IF FIRST 4 LETTERS NOT *RETU*
          SA3    =0LRETURNS 
          IX2    X6-X3
          ZR     X2,PSA23    IF *RETURNS* 
          WARN   E.AC9
 PSA23    ANSI   E.ANS
          SA1    B4+B1
          SB4    B4+B1
          SX2    X1-O.( 
          NZ     X2,E.AP     IF NO *(* - ERROR
          =B6    B6+1        BUMP ARG COUNT FOR -0 WORD 
          =B4    B4+1 
 PSA24    SA1    B4 
          MX0    LG.VAR*CHAR
          SB7    X1-O.VAR 
          BX6    X0*X1
          SA6    FILL.
          ZR     B7,PSA25    IF LETTER
          FATAL  E.AC4
          EQ     PSA28
  
 PSA25    SCAN   TS.SYM,SSY 
          MI     B7,PSA26    IF NOT PREVIOUSLY DEFINED
          FATAL  E.AC3
          EQ     PSA27
  
 PSA26    =X3    B6+1        = ORDINAL OF ARGUMENT
          =X2    M.RP+M.NVAR
          =B6    B6+1        COUNT ARGUMENTS
          LX3    P.FPNO 
          BX7    X2+X3
          ADSYM  TS.SYM 
  
 PSA27    ADDREF X6,CR.CALL 
  
 PSA28    =A3    B4+1 
          ZR     X3,E.MR1    IF PREMATURE *EOS* 
          SB7    X3-O.VAR 
          NZ     B7,PSA28B   IF NOT LONG NAME 
          RJ     =XTLV       TRUNCATE NAME
          =A3    B4+1 
 PSA28B   =A1    A3+1 
          SX2    X3-O.COMMA 
          SB4    A3+B1
          ZR     X2,PSA24    IF *,* LOOP ON NEXT ARGUMENT 
          SX2    X3-O.) 
          NZ     X2,E.AP1    IF NO *)* - ERROR
          ZR     X1,PSA29    IF *EOS* 
          WARN   E.AC8
 PSA29    SX6    B6 
          SA6    NARGS       STORE NUMBER OF ARGUMENTS
          SA1    MOD
          LX1    59-P.PFNC
          PL     X1,PSA3     IF NOT A FUNCTION
          FATAL  E.FR 
 PSA3     SB2    B6-MAX.SARG
          LE     B2,PSA32    IF COMPILER DEFINED LIMIT NOT EXCEEDED 
          FATAL  E.AC 
 PSA32    SX1    CT.BEGIN 
          CBSS   X1 
          RJ     PIG         PRINT INSTRUCTIONS 
          SA1    CO.ER
          ZR     X1,PSA33    IF ER=0
          RJ     SOR
 PSA33    EQ     PSAX 
  
*         IF NOT RETURNS FOLLOWING *ARGUMENT LIST* *,*
  
 PSAERR   SA2    X1+=XCHARMAP 
          NZ     X2,PSAERR1  IF NOT VAR OR CONS 
          LX2    X1 
 PSAERR1  MX0    L.CDPC 
          BX6    X0*X2
          SA6    FILL.
          EQ     E.AC5
 PXE      SPACE  4,8
**        PXE -  PROCESS TRACEBACK WORD 
  
  
 PXE      SUBR   0
          SHRINK TT=LF,0
  
**        INITIALIZE THE *PROGRAM* TAG ADDRESS TABLE. 
  
          ALLOC  TA.PRO,CT.LAST-C.PRO+1 
          SX7    CT.LAST
          BX6    0
          SB2    X1 
          SA7    TG.PRO 
          MX0    -1 
 PXE2     SA6    B2 
          =B2    B2+1 
          IX6    X6-X0
          LT     B2,B7,PXE2  IF MORE PRE-DEFINED TAGS 
  
*         NOW TAKE CARE OF LISTING STUFF
  
          SA1    LOP=O
          SX6    3
          SA6    ORG         ADVANCE RUNNING ADDRESS
          SA6    BA.PRO 
          PL     X1,PXEX     IF NO OBJECT LISTING 
  
          SA1    =XTL.PNAM   PROGRAM UNIT NAME
          BX6    X1 
          SA6    PXEB+1 
          PLINE  A6-1,2      PRINT * NAME     TRACE.* 
          EQ     PXEX        EXIT.. 
  
 PXEB     CON    4A0
          DIS    1,          NAME GOES HERE 
          DIS    ,/TRACE./
 STR      SPACE  4
          LIST   D
          END 
