*DECK     HEADER - PROGRAM UNIT HEADER STATEMENTS.
          IDENT  HEADER 
 HEADER   SECT   (PROGRAM UNIT HEADER STATEMENTS.)
 HEADER   SPACE  4,10 
***       HEADER CONTAINS TRANSLATORS FOR STATEMENTS WHICH BEGIN
*         PROGRAM-UNITS, AS WELL AS ROUTINES TO DEAL WITH FORMAL
*         PARAMETER LISTS.
  
  
*         IN ALLOC
          EXT    ADW,ALC
  
*         IN DECL 
          EXT    ACV
  
*         IN CONRED 
          EXT    DEC,OCT
  
*         IN FEC
          EXT    CHARMAP,ERT,ESY,FEC=IMP,FEC=STF,FEC.RTN,SCS,SCSA 
          EXT    SCT,SSY,STAGE,STY,TLV,TSX,TSY,WANFP
  
*         IN FERRS
          EXT    E.AG00,E.AG01,E.AG02,E.AG03,E.AG04,E.AG07,E.AG08,E.AG11
          EXT    E.AG12,E.FD,E.FD0,E.FD1,E.FD2,E.FD3,E.FD4,E.FD5,E.FD6
          EXT    E.FD7,E.FD8,E.FD9,E.FD10,E.MR1,E.OV1,E.OV2,E.OV3,E.OV4 
          EXT    E.PN1,E.MDE1,E.MDE6
          EXT    E.PN3,FILL.,FILL.2,E.FD11,E.FD12 
  
*         IN FTN
          EXT    CO.AL,CO.DBER,CO.DBPM,CO.PW,CO.STAT,ERFO,MSG=,TL.PNAM
          EXT    TL.PTYP
  
*         IN LEX
          EXT    SB=CONT,TB=TYPE
  
*         IN KEY
          EXT    KW=ENTR
  
*         IN PAR
          EXT    EMT
  
*         IN PEM
          EXT    ANSI=,MDERR=,PDM 
  
*         IN PUC
          EXT    HO$MSG 
          EXT    IDENT,IDENT1,LEVEL,LEVEL2,MOD,NARGS,N.ARP,N.CPL
          EXT    N.EPL,N.FP,SCR 
          EXT    S=AEXIT,S=CP,S=CPL,S=ENTRY,S=EXIT,S=FILES,S=GPL,S=INIT 
          EXT    S=SLI,S=SPA,S=SUB,S=SUBI,S=SUB0I,S=UPW,S=VALUE 
          EXT    T=ARG,T=ENTP,T.ARG,T.LCC,T.ENT,T.ENTP,T.FPI,T.SYM
          EXT    T=VDI,T.VDI
  
*         IN QSKEL/FSKEL
          EXT    V=FILE,V=HDR,V=LCC,V=PLIM,V=SEX
  
*         IN UTILITY
          EXT    MVE=,SFN 
 BKD      SPACE  4,10 
**        BKD -  PROCESS "BLOCKDATA" STATEMENT. 
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         CALLS  DCM. 
  
  
          HEREIF BLOCKDATA
  
          RJ     COVC        CHECK FOR *OVCAP* DIRECTIVE
          SA1    B4 
          SA2    BKDA 
          NZ     X1,BKD1     IF NAME SPECIFIED
          MX7    0
          BX6    X2 
          SA6    B4          DEFAULT NAME TO *TB* 
          SA7    B4+B1
 BKD1     CLAS=  X6,MO,(BLK)
          SA4    =9ABLOCKDATA 
          RJ     DCM         DISPLAY COMPILING MESSAGE
          MX4    0
          BX5    0
          EMIT   V=SEX       INITIALIZE PASS 2
          EQ     FEC.RTN     RETURN TO FRONT END CONTROLLER 
  
 BKDA     CON    7LBLKDAT.+O.VAR
 FCT      SPACE  4,20 
**        FCT -  PROCESS "FUNCTION" STATEMENT.
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         CALLS  1.  DCM = ASSEMBLE THE PROGRAM NAME. 
*                2.  TSB = PROCESS ANY FORMAL PARAMETER LIST. 
  
  
          HEREIF FUNCTION 
  
          SA2    B4 
          SA1    MOD
          BX6    X1 
          HX6    MO.TYP 
          MI     X6,FCT2     IF FUNCTION EXPLICITLY TYPED 
          BX6    X2 
          SB7    X2-O.VAR 
          NZ     B7,FCT2     IF NOT VARIABLE,BYPASS STY 
          MX0    -CHAR
          LX2    CHAR 
          BX2    -X0*X2 
          SB7    X2-1R0 
          PL     B7,FCT2     IF FIRST CHARACTER NOT LETTER
          CALL   STY         SET IMPLICIT TYPE
 FCT2     CLAS=  X6,MO,(FUN)
          BX6    X1+X6
          SA4    =8AFUNCTION
          RJ     DCM         DISPLAY COMPILING MESSAGE
          RJ     TSB         TRANSLATE SUBPROGRAM BEGIN 
          EQ     FEC.RTN     RETURN TO FRONT END CONTROLLER 
  
 SVALUE.  VFD    42/0LVALUE.,18/O.VAR 
 PPG      SPACE  4,10 
**        PPG -  PROCESS "PROGRAM" STATEMENT. 
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         CALLS  1.  WARN (NON-ANSI STATEMENT). 
*                2.  DCM = ASSEMBLE THE PROGRAM NAME. 
*                3.  PPA = PROCESS ANY FILE DECLARATION LIST. 
  
  
          HEREIF PROGRAM
  
          CLAS=  X6,MO,(PRO)       SET SUBPROGRAM MODE
          SA4    =7APROGRAM 
          RJ     DCM         DISPLAY COMPILING MESSAGE
          RJ     PPA         PROCESS PROGRAM ARGUEMENTS 
          EQ     FEC.RTN     RETURN TO FRONT END CONTROLLER 
 LCC      SPACE  4,20 
**        LCC - HANDLE EMBEDDED LOADER CONTROL CARDS. 
* 
*         DIRECTIVES CURRENTLY KNOWN ARE -- 
*                "OVERLAY"
* 
*         EXIT   TO MBC SO THAT A FOLLOWING *IDENT* MAY BE DETECTED.
  
  
          HEREIF OVCAP
          MDERR  E.MDE6      ** OVCAPS ARE MACHINE DEPENDENT
          MX6    1
          SA6    OVCFLG      INDICATE *OVCAP* APPEARED
          SA3    =5ROVCAP 
          SB2    5*CHAR 
          SA2    B4 
          SB7    X2-O.PERIOD
          ZR     B7,LCC      IF KEYWORD FOLLOWED BY PERIOD
          SB7    X2-O.LP
          ZR     B7,LCC      IF FOLLOWED BY LEFT PAREN
          FATAL  E.OV2       ** EXPECTED LEFT PAREN OR PERIOD 
          EQ     FEC.RTN
  
 OVCFLG   CONENT 0
  
          HEREIF OVERLAY
          MDERR  E.MDE1      ** OVERLAY USE MACHINE DEPENDENT 
          SA3    =7ROVERLAY 
          SB2    3*CHAR 
          SA2    B4 
          SB7    X2-O.LP
          NZ     B7,E.OV1    ** OVERLAY MISSING LEFT PAREN
  
 LCC      MX0    -CHAR
          SA6    SCR
          BX6    X3 
  
 LCC2     SA1    X2+CHARMAP 
          NZ     X1,LCC3     IF NOT *SYMBOL*
          BX1    X0*X2       USE *TB* CHARACTERS
  
 LCC3     LX1    CHAR 
          SB0    0
          BX3    -X0*X1 
 LCC35    LX6    CHAR 
          SB2    B2-CHAR
          LX1    CHAR 
          IX6    X6+X3
          BX3    -X0*X1      ISOLATE NEXT CHARACTER 
          NZ     B2,LCC4     IF WORD NOT FULL 
          =A6    A6+1 
          SB2    10*CHAR
          BX6    0
 LCC4     NZ     X3,LCC35    IF MORE CHARACTERS 
          SA2    A2+1 
          NZ     X2,LCC2     IF NOT *EOS* 
          LX6    X6,B2       LEFT JUSTIFY 
          =A6    A6+1 
          SB2    B2-12
          BX6    0
          GE     B2,LCC6     IF ZERO BYTE 
          SA6    A6+1        INSURE END-OF-LINE 
 LCC6     SB7    SCR
          SB2    A6-B7       LENGTH OF DIRECTIVE
          ALLOC  T.LCC,B2 
          =B3    X2+1        TABLE LENGTH +1
          SX1    B2          DIRECTIVE LENGTH 
          SX2    SCR+1       START OF DIRECTIVE 
          SB3    B3-B2       POINTER INTO CON TABLE 
          SX3    B7-B2       ADDRESS IN CON TABLE 
          MOVE   X1,X2,X3    MOVE DIRECTIVE TO CON TABLE
          SX4    B3-1        POINTER TO DIRECTIVE 
          SX5    B2          DIRECTIVE LENGTH 
          LX4    TP.BIASP    1OP
          LX5    TP.BIASP    2OP
          EMIT   V=LCC       TURPLE TO IL 
          SA1    SB=CONT     NUMBER OF CONTINUATION LINES IN STATEMENT
          NZ     X1,E.OV3    IF CONTINUED (RETURN FEC.RNX)
          EQ     FEC.RTN     RETURN TO FRONT END CONTROLLER 
 PSF      SPACE  4,10 
**        PSF -  PROCESS SPECIAL FIRST CARD.
* 
*         PSF IS CALLED BY THE FRONT END CONTROLLER WHEN THE FIRST
*         STATEMENT OF A PROGRAM-UNIT IS NOT A HEADER STATEMENT.
*         IT INVENTS A PROGRAM STATEMENT -- 
*                " PROGRAM START. (INPUT, OUTPUT) " 
*         AND EFFECTIVELY INSERTS IT BEFORE THE ACTUAL FIRST
*         STATEMENT.
* 
*         EXIT   (X5) RESTORED FROM (TB=TYPE).
*                (B4) PRESERVED.
  
  
 PSF      SUBR   =           ...ENTRY/EXIT... 
          WARN   E.PN3       NO PROGRAM NAME - START. ASSUMED 
          SX7    B4 
          SX6    MO.PROM
          SA7    PSFA        SAVE (B4)
          SB4    DPN         POINT TO FAKE STRING 
          SA4    =7HPROGRAM 
          RJ     DCM         PROCESS COMPILE MODE + DISPLAY 
          RJ     PPA         PROCESS ARGUMENTS
          SA1    PSFA 
          SA5    TB=TYPE     (X5) = STATEMENT TYPE INFORMATION WORD 
          SB4    X1          RESTORE (B4) 
          EQ     EXIT.       EXIT...
  
 PSFA     BSS    1           SAVE AREA FOR B4 
  
  
**        DEFAULT SUBPROGRAM NAME + PARAMETERS
*         SET = *PROGRAM START.(INPUT,OUTPUT)*
  
 DPN      VFD    42/0LSTART.,18/O.VAR 
          CON    O.LP 
          VFD    42/0LINPUT,18/O.VAR
          CON    O.COMMA
          VFD    42/0LOUTPUT,18/O.VAR 
          CON    O.RP 
          DATA   0           END OF STRING INDICATOR
 SUB      SPACE  4,10 
**        SUB -  PROCESS "SUBROUTINE" STATEMENT.
* 
*         EXIT   TO FRONT END CONTROLLER
* 
*         CALLS  1.  DCM = ASSEMBLE THE PROGRAM NAME. 
*                2.  TSB = PROCESS ANY FORMAL PARAMETER LIST. 
  
  
          HEREIF SUBROUTINE 
  
          CLAS=  X6,MO,(SUB)       SET SUBPROGRAM MODE
          SA4    =10HSUBROUTINE 
          RJ     DCM         DISPLAY COMPILING MESSAGE
          RJ     TSB         TRANSLATE SUBPROGRAM BEGIN 
          SA4    SUBA 
          CLAS=  X3,WB,(CGS,VAR)
          CALL   TSY         TAG SYMBOL (AEXIT.)
          EQ     FEC.RTN     RETURN TO FRONT END CONTROLLER 
  
 SUBA     VFD    42/6LAEXIT.,18/S=AEXIT 
          TITLE  SUBROUTINES
 COVC     SPACE  4,10 
**        COVC - CHECK FOR *OVCAP* DIRECTIVE
* 
*         WILL ISSUE A FATAL ERROR IF AN *OVCAP* DIRECTIVE
*         APPEARED BEFORE A *PROGRAM*, *FUNCTION* OR *BLOCK DATA* 
*         HEADER STATEMENT, OR IF IT APPEARED BEFORE A *SUBROUTINE* 
*         HEADER THAT CONTAINED ARGUMENTS.
* 
*         USES   X - 1  A - 1.
  
 COVC     SUBR               ENTRY/EXIT...
          SA1    OVCFLG 
          ZR     X1,EXIT.    IF NO *OVCAP*
          SA1    MOD
          HX1    MO.SUB 
          MI     X1,EXIT.    IF SUBROUTINE
          FATAL  E.OV4       OVCAP DIRECTIVE ONLY VALID WITH SUBROUTINE 
          EQ     EXIT.
 DCM      SPACE  4,10 
**        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.
*         ENTER CON. SYMBOL INTO SYMBOL TABLE.
* 
*         ENTRY  (B4) -> SUBPROGRAM NAME (IN *TB*). 
*                (X4) = DPC PROGRAM TYPE FOR BANNER.
*                (X6) = PROGRAM-UNIT COMPILE MODE.
* 
*         EXIT   (B4) -> NEXT ELEMENT OF *TB*.
* 
*         CALLS  ADW,MSG,PVF,SFN,ESY,SSY
  
  
 DCM      SUBR               ...ENTRY/EXIT... 
          SA6    MOD         SET PROGRAM UNIT MODE
          BX6    X4 
          SA4    B4 
          SA6    TL.PTYP
          SA6    A6+ERFO     PROGRAM TYPE TO E FILE 
          MX0    MAX.VAR*CHAR 
          SX2    X4-O.VAR 
          NZ     X2,DCM1     IF PROGRAM NAME NOT VARIABLE 
          BX2    X0*X4       CLEAR TYPE CODE
          LX2    CHAR 
          SX2    X2-1R0 
          PL     X2,DCM1     IF NOT A LETTER
          =A2    B4+1 
          SB7    X2-O.VAR 
          NZ     B7,DCM2     IF LESS THAN 8 CHARACTERS
          CALL   TLV         TRUNCATE NAME
          EQ     DCM2 
  
 DCM1     FATAL  E.PN1       SYNTAX ERROR IN ROUTINE NAME 
          SA4    DCMA        SET *DUMMY* NAME 
  
 DCM2     MX1    WA.SYML
          BX1    X1*X4       NAME ONLY
          CALL   SFN         SPACE FILL NAME OF ROUTINE 
          LX6    -6 
          SA2    TL.PTYP
          MX0    8*CHAR 
          BX1    X0*X2       (X1) = 1ST 8 CHARACTERS OF ROUTINE TYPE
          BX3    -X0*X2      (X3) = LAST 2 CHARACTERS OF ROUTINE TYPE 
          BX5    X0*X6       (X5) = 1ST 8 CHARACTERS OF ROUTINE NAME
          BX0    X3+X5
          SX3    2R 
          BX7    X3+X1
          LX7    -2*CHAR
          LX0    -2*CHAR
          SA1    CO.PW
          BX3    X6 
          SX1    X1-126 
          PL     X1,DCM3     IF L FILE NOT PW MODE
          SA7    A2 
          BX6    X0 
  
 DCM3     SA6    TL.PNAM
          BX6    X3          RESTORE
          =A1    A1+1 
          SX1    X1-136 
          ZR     X1,DCM4     IF E FILE NOT PW 
          SA7    A2+ERFO
          BX6    X0 
  
 DCM4     SA6    A6+ERFO
          MX0    WA.SYML
          BX6    X0*X4
          LX4    X6 
          SA6    IDENT       ROUTINE NAME IN 0L FORMAT
          MESSAGE  HO$MSG,CONSOLE,RCL  *   COMPILING NAME  *
          BX6    X4          RESTORE NAME 
          CALL   SSY         FIND WHERE TO PUT SYMBOL 
          IFNE   TEST,,1
          PL     B7,"BLOWUP"       IF ALREADY IN TABLE
          SA3    MOD
          CLAS=  X2,WB,(NVAR,DEF,ENT,MAT) 
          MX0    -MO.MODEL
          BX7    -X0*X3      ISOLATE MODE 
          ERRNZ  MO.MODEP 
          ERRNZ  WB.MODEP-MO.MODEP
          SBIT   X3,MO.TYPP 
          PL     X3,DCM5     IF NOT EXPLICITLY TYPED
          CLAS=  X2,WB,(TYP,NVAR,DEF,ENT,MAT) 
  
 DCM5     BX7    X2+X7
          LX3    MO.TYPL+MO.TYPP
          MX2    MO.CLIFL 
          LX2    MO.CLIFL+MO.CLIFP
          BX2    X2*X3       EXTRACT CHARACTER LENGTH INFORMATION 
          LX2    -MO.CLIFP+WC.CLIFP 
          ADSYM  A1          ADD *SYMBOL/TAG* TO TABLE. 
          LX7    X0 
          BX6    X0+X4       = DATA FOR T.ENT(42/ROUTINE NAME,18/SYMORD)
          SA7    S=ENTRY
          ADDWD  T.ENT
          SA4    S=ENTRY
          BX5    0           (2OP) = NIL
          LX4    TP.ORDP     (1OP) = MAIN ENTRY 
          EMIT   V=HDR
          LX4    -TP.ORDP+XR.TAGP 
          BX6    X4 
          ADDREF X6,CR.DEF
          =X6    FEC=IMP
          SA6    STAGE
          SA1    B4 
          ZR     X1,EXIT.    IF NAME MISSING, DON'T ADVANCE TOKEN PNTR
          =B4    B4+1 
          EQ     EXIT.
  
 DCMA     LIT    7LXXX****   DUMMY NAME WHEN NAME IN ERROR
 PBM      SPACE  4,10 
**        PBM - PROCESS BUFL OR MRL.
* 
*         CALLED BY *PPA* TO DETERMINE LEGALITY OF PRESUMED 
*         BUFL OR MRL, AND TO RETURN THE BINARY OF THE (LEGAL) CONSTANT.
* 
*         ENTRY  (B4) _ PRESUMED BUFL OR MRL TOKEN. 
*                (X2) = THE TOKEN ITSELF. 
*                (A0) = MAXIMUM VALUE THE CONSTANT CAN TAKE.
* 
*         EXIT   (B4) = UNCHANGED.
* 
*                IF NO ERROR :  
* 
*                (B5) = 0 
*                (X6) = BINARY OF THE CONSTANT
* 
*                IF ERROR OF SOME KIND :  
* 
*                (B5) = SHIFT COUNT TO RECOVER PROPER DIAGNOSTIC
*                       ADDRESS FROM *PPABE* (BUFL ERROR) OR FROM 
*                       *PPAME* (MRL ERROR) 
* 
*         CALLS  DEC,OCT. 
* 
*         USES   X - 0,1,2,3,6,7  A - 1,2,3,4,5  B - 2,5,7. 
  
  
 PBM      SUBR               ENTRY/EXIT...
          SX1    X2-O.OCT 
          NZ     X1,PBM10    IF NOT OCTAL CONSTANT
          CALL   OCT         CONVERT OCTAL CONSTANT 
          EQ     PBM20
  
 PBM10    SX1    X2-O.CONS
          SB5    18D
          NZ     X1,EXIT.    IF ILLEGAL TOKEN 
          CALL   DEC         CONVERT DECIMAL CONSTANT 
          SX2    X1-M.INT 
          SB5    36D
          NZ     X2,EXIT.    IF NOT INTEGER 
  
**        HERE IF CONSTANT OF THE PROPER TYPE HAS BEEN FOUND. 
  
 PBM20    SB5    36D
          MI     X6,EXIT.    IF NEGATIVE CONSTANT 
          SB5    54D
          SX3    A0 
          IX3    X3-X6
          MI     X3,EXIT.    IF CONSTANT TOO LARGE
          =B5    0
          EQ     EXIT.
 PPA      SPACE  4,10 
**        PPA - PROCESS PROGRAM ARGUMENTS.
* 
*         ENTRY  (B4) _ PRESUMED ARGUMENT LIST. 
* 
*         CALLS  ESY,TLV,SSY,PEM,PBM,EMT,TSX,TSY. 
* 
*         USES   ALL REGISTERS. 
  
  
 PPA      SUBR   0           ENTRY/EXIT...
          RJ     COVC        CHECK FOR *OVCAP* DIRECTIVE
          SA2    B4 
          ZR     X2,PPA170   IF ARGLIST OMITTED 
          ERRNZ  O.EOS
          SX1    X2-O.LP
          ZR     X1,PPA10    IF LPAREN PRESENT
          FATAL  E.AG07      ** EXPECTED ARGLIST LPAREN 
  
 PPA10    SA1    IDENT
          SA2    =6LSTART.
          IX1    X1-X2
          ZR     X1,PPA20    IF SPECIAL FIRST CARD (NO HEADER STATEMENT)
          ANSI   E.FD        ** FILE LIST IS NON-ANSI 
  
**        PROGRAM ARGUMENTS LOOP. 
  
 PPA20    =A2    B4+1 
          =B4    B4+1 
          SX1    X2-O.VAR 
          ZR     X1,PPA30    IF FILE NAME FOUND 
          ZR     X2,E.MR1    IF PREMATURE EOS 
          FATAL  E.FD1       ** EXPECTED FILE NAME
          MX0    0
          EQ     PPA130 
  
 PPA30    =A1    B4+1        X1 = TOKEN AFTER VAR 
          MX0    7*CHAR 
          BX6    X0*X2       EXTRACT NAME 
          SA6    FILL.
          SX1    X1-O.VAR 
          NZ     X1,PPA40    IF FILE NAME NOT TOO LONG
          CALL   TLV         TRUNCATE LONG VARIABLE 
  
 PPA40    MX0    1
          BX6    X6+X0       SET BIT 59 ON FILE NAME
          CALL   SSY
          MX0    0
          PL     B7,E.FD2    IF FILE DOUBLY DEFINED 
  
**        (X6) = LEGAL FILE NAME, CHECK FOR EQUIVALENCING.
  
          BX4    X6          SAVE FILE NAME (*WA* ENTRY)
  
 .RM      IFNE   CP#RM,7
          SA2    CO.STAT
          SX5    BUFL.SM     DEFAULT BUFL (STATIC MODE) 
          MI     X2,PPA45    IF *STATIC* MODE 
          SX5    BUFL.DM     DEFAULT BUFL (DYNAMIC) 
 .RM      ELSE
          SX5    0           NO BUFFER SPACE TO ALLOCATE ON SCOPE 2 
 .RM      ENDIF 
  
  
 PPA45    LX5    WC.BFLP
          =A0    0           INDICATE NOT EQUIVALENCED (INITIALLY)
          =A2    B4+1        X2 = TOKEN AFTER FILE NAME 
          =B4    B4+1 
          SX1    X2-O.= 
          NZ     X1,PPA120   IF NOT EQUIVALENCED, DEFINE FILE 
          =A2    B4+1        X1 = EQUIVALENCE ELEMENT 
          =B4    B4+1 
          SX1    X2-O.VAR 
          NZ     X1,PPA60    IF NOT A FILE NAME 
          =A1    B4+1        X1 = TOKEN AFTER FILE NAME 
          MX0    7*CHAR 
          BX6    X0*X2       EXTRACT FILE NAME
          SA6    FILL.2 
          SX1    X1-O.VAR 
          NZ     X1,PPA50    IF FILE NAME NOT TOO LONG
          CALL   TLV         TRUNCATE LONG VARIABLE 
  
 PPA50    MX0    1
          BX6    X6+X0       SET BIT 59 
          CALL   SSY
          MX0    0
          MI     B7,E.FD3    IF FILE NOT DEFINED
          SX5    B7 
          LX5    WC.IEFP     SET *WC* 
          =A0    1           INDICATE EQUIVALENCED FILE 
          =B4    B4+1 
          EQ     PPA120      DEFINE FILE
  
**        HERE TO PROCESS BUFFER LENGTH.
  
 PPA60    SX1    X2-O.SLASH 
          ZR     X1,PPA90    IF NO BUFL 
          SA0    MAX.BUFL 
          RJ     PBM         PROCESS BUFL 
          ZR     B5,PPA80    IF NO ERROR
          SA1    PPABE
          LX1    X1,B5
          SB5    X1          B5 = ADDRESS OF DIAGNOSTIC 
          MX0    0
          JP     B5          ISSUE DIAGNOSTIC 
  
**        HERE TO DEFINE BUFFER LENGTH. 
*         (X6) = BUFFER LENGTH
*         (B4) _ BUFFER LENGTH TOKEN
  
 PPA80    ZR     X6,PPA85    IF BUFL=0 SPECIFIED
          SX6    X6+BUFL.ADD ADD IN DEFAULT ADDENDUM
 PPA85    =A2    B4+1        TOKEN AFTER BUFFER LENGTH
          =B4    B4+1 
          LX6    WC.BFLP
          BX5    X6 
          =A0    0           INDICATE NOT EQUIVALENCED
          SX1    X2-O.SLASH 
          NZ     X1,PPA120   IF NO MRL, DEFINE FILE 
  
**        HERE TO PROCESS MRL, (B4) _ O.SLASH TOKEN.
  
 PPA90    =A2    B4+1        X2 = PRESUMED MRL
          =B4    B4+1 
          SA0    MAX.RECL 
          RJ     PBM         PROCESS MRL
          ZR     B5,PPA110   IF NO ERROR
          SA1    PPAME
          LX1    X1,B5
          SB5    X1          B5 = ADDRESS OF DIAGNOSTIC 
          MX0    0
          JP     B5          ISSUE DIAGNOSTIC 
  
**        HERE TO DEFINE MRL. 
*         (X6) = MRL
*         (B4) _ MRL TOKEN
  
 PPA110   LX6    WC.MRLP
          BX5    X5+X6       MERGE MRL
          =A0    0
          =B4    B4+1 
  
**        EMIT TURPLE TO DEFINE THIS FILE, ADD ENTRY TO SYMBOL TABLE. 
*         (X4) = 42/0LFILENAME
*         (A0) = 1 IF EQUIVALENCED FILE 
*              = 0 IF NOT 
*         (X5) - *WC* ENTRY FOR FILE
*              = BUFL AND MRL (FOR A0 = 0)
*              = SYMTAB *WB* INDEX (FOR A0 = 1) 
  
 PPA120   BX6    X4 
          CLAS=  X2,WB,(NVAR,CGS) 
          SX7    A0 
          LX7    WB.EQUP
          BX7    X7+X2
          BX2    X5 
          ADSYM  T.SYM
          SA1    NARGS
          =X6    X1+1 
          SA6    A1          UPDATE FILE COUNTER
          MX5    0
          SX4    B7 
          LX4    TP.BIASP 
          EMIT   V=FILE 
          =X0    1
  
**        CHECK FOR MORE FILE DECLARATIONS. 
*         (B4) _ NEXT TOKEN.
*         (X0) = 0 IF DIAGNOSTIC RETURNED HERE. 
*              = .NZ. OTHERWISE 
  
 PPA130   BSSENT 0
          SA1    B4 
          SX2    X1-O.COMMA 
          ZR     X2,PPA20    IF COMMA, CONTINUE 
          SX2    X1-O.EOS 
          ZR     X2,E.MR1    ** PREMATURE EOS 
          SX2    X1-O.RP
          ZR     X2,PPA150   IF RP
          ZR     X0,PPA140   IF SUPPRESS ERROR
          FATAL  E.FD10      ** EXPECTED RP OR COMMA
  
 PPA140   =B4    B4+1 
          EQ     PPA130 
  
**        RIGHT PAREN FOUND. CHECK FOR EOS, AND TOO MANY FILES. 
  
 PPA150   =A1    B4+1 
          =B4    B4+1 
          ZR     X1,PPA160   IF EOS 
          ERRNZ  O.EOS
          WARN   E.FD11      ** EXPECTED EOS
  
 PPA160   SA4    NARGS
          SB2    X4-MAX.PARG
          LE     B2,PPA170   IF NOT TOO MANY FILES
          WARN   E.FD12      TOO MANY FILES 
  
**        EMIT *END OF FILE DECLARATIONS* AND 
*         *START OF EXECUTABLES*. 
  
 PPA170   BX4    0
          MX5    0
          EMIT   V=PLIM      INDICATE NO MORE FILES 
          EMIT   V=SEX       INDICATE START OF EXECUTABLES
  
          SA3    CO.DBPM
          SA1    S.Q5PMD
          NZ     X3,PPA180   IF *POST-MORTEM DUMP* SELECTED 
          SA2    CO.DBER
          SA1    A1+B1       Q5RPV
          NZ     X2,PPA180   IF *ERROR RECOVERY* SELECTED 
          SA1    A1+B1       Q5NTRY 
 PPA180   TAGSEX  A1         ENTER INITIALIZER IN SYMTAB
          SA4    PPAB 
          LX7    X0 
          SA7    S=INIT 
          CLAS=  X3,WB,(CGS,DEF,VAR,MAT)
          CALL   TSY         TAG SYMBOL (FILVEC.) 
          SA5    NARGS
          ZR     X5,EXIT.    IF NO FILE-NAME ARGUMENTS
          SA4    PPAC 
          CLAS=  X3,WB,(CGS,DEF,VAR,MAT)
          CALL   TSY         TAG SYMBOL (UPW.)
          EQ     PPAX 
  
 S.Q5PMD  =XLIB  Q5PMD
          =XLIB  Q5RPV
          =XLIB  Q5NTRY 
  
 PPAB     CON    =XS=FILES+7LFILVEC.
 PPAC     CON    S=UPW+4LUPW. 
 PPAE     EQU    SCR
 PPAF     EQU    SCR+1
  
 PPABE    VFD    18/E.FD4,18/E.FD5,18/E.FD6,6/0 
 PPAME    VFD    18/E.FD8,18/E.FD7,18/E.FD9,6/0 
 PSA      SPACE  4,30 
**        PSA - PROCESS SUBPROGRAM ARGLIST. 
* 
*         TRANSLATES SUBPROGRAM DUMMY ARGUMENT LIST FOR FUNCTION, 
*         SUBROUTINE, AND ENTRY STATEMENTS. 
* 
*         WHEN THE SCAN IS FINISHED, IF THERE WERE ANY NON-LABEL ARGS 
*         (THE LOCAL ARG TABLE IS NOT EMPTY), THIS PARAMETER LIST 
*         MUST BE ADDED TO (T.ENTP).  THE LOCAL TABLE IS SCRUNCHED
*         INTO THE PROPER FORMAT, AND WE SCAN (T.ENTP) TO SEE IF AN 
*         IDENTICAL PARAMETER LIST IS ALREADY PRESENT.  IF NOT, A 
*         HEADER WORD (EH.) IS PREFIXED TO THE LOCAL TABLE, AND THE 
*         WHOLE MESS IS ADDED TO (T.ENTP).  ALSO, (N.CPL) IS INCRE- 
*         MENTED TO ACCOUNT FOR THE NEW LIST.  IF THERE IS NOW MORE 
*         THAN ONE ARGLIST IN (T.ENTP), WE MUST SET (N.EPL) TO SO 
*         SIGNIFY.  FINALLY, (WB.PNT) OF THE ENTRY POINT IS SET TO
*         POINT TO THE HEADER WORD IN THE (T.ENTP) ENTRY. 
* 
*         ENTRY  (B4) -> *(* AT BEGINNING OF (POSSIBLE) ARGUMENT LIST.
*                (X4) = SYMORD OF ENTRY POINT.
*                     .ZR. IF ERROR IN ENTRY NAME.
* 
*         USES   ALL
* 
*         CALLS  ALC, COVC, MVE=, SAL.
  
  
 PSA      SUBR   =           ENTRY/EXIT...
          SX6    X4 
          SA4    S=ENTRY
          IX4    X6-X4
          SA6    PSAA        (PSAA) = SYMORD OF THIS ENTRY POINT
  
 .T       IFEQ   TEST,ON
          SA2    T=ARG
          NZ     X2,"BLOWUP" IF GARBAGE IN ARG TABLE
 .T       ENDIF 
  
          ZR     X4,PSA1     IF MAIN ENTRY
          SA1    MOD
          MX4    -MO.MODEL
          BX4    -X4*X1      EXTRACT MODE (IF PRESENT)
          SBIT   X1,MO.FUNP 
          PL     X1,PSA1     IF NOT FUNCTION
          SBIT   X1,MO.CTYPP/MO.FUNP
          SX4    X4-M.CHAR
          NZ     X4,PSA1     IF NOT CHARACTER 
          PL     X1,PSA1     IF NOT ASSUMED SIZE
          SA1    S=VALUE
          SX6    X1+M.CHAR   ORDINAL OF VALUH.
          ADDWD  T.ARG       ENTRY FOR T.ENTP 
  
 PSA1     RJ     SAL         SCAN ARGUMENT LIST 
          RJ     COVC        CHECK FOR *OVCAP* DIRECTIVE
          SA2    T=ARG
          SX6    MAX.SARG 
          BX7    X2 
          IX3    X6-X2
          SA7    PSAB 
          ZR     X2,PSA50    IF NO NON-LABEL ARGUMENTS
          PL     X3,PSA5     IF THIS ARGLIST NOT TOO LONG 
          BX2    X6 
          SHRINK A2,X6
          FATAL  E.AG00      ** TOO MANY DUMMY ARGS 
  
 PSA5     SA1    T.ARG
          SA3    X1          FETCH FIRST ENTRY
          MX6    0
          SB2    A3          (B2) = FWA (T.ARG) 
          SB3    X2+         (B3) = NUMBER OF ARG BYTES NEEDED
          SA6    A3          CLEAR (EH.) WORD 
          SB7    60-EF.ORDL 
          ERRNZ  4*EF.ORDL-60 
  
 PSA10    LX2    X3,B7
          SB7    B7-EF.ORDL 
          BX6    X6+X2       MERGE THIS ENTRY 
          SB3    B3-B1
          PL     B7,PSA15    IF WORD NOT FULL 
          SA6    A6+B1
          SB7    60-EF.ORDL 
          NO
          MX6    0
  
 PSA15    SA3    A3+B1
          GT     B3,PSA10    IF MORE FPS IN LOCAL ARGUMENT LIST 
          SA6    A6+B1       STORE PARTIAL WORD 
          SB3    A6+B1       (B3) = LWA+1 OF SCRUNCHED ARGLIST
          SHRINK A2,B3-B2    SET SCRUNCHED LENGTH OF TABLE
  
*         ADD NEW (T.ENTP) ENTRY, IF UNIQUE.
  
          SA2    T=ENTP 
          SA1    T.ENTP 
          ZR     X2,PSA30    IF NO PREVIOUS ARGLISTS
  
*         DETERMINE IF THE CURRENT ENTRY IS UNIQUE. 
*         (X6) = (T=ARG)
*         (B2) = (T.ARG)
*         (X1) = (T.ENTP) 
*         (X2) = (T=ENTP) 
* 
*         NOTE:  THIS CODE ASSUMES NO TABLE MOVEMENT. 
  
          =B2    B2+1        MATCH ONLY ON ARGUMENTS
          SB3    X6-1        COUNT ONLY ARGUMENT WORDS
          SB7    X1          INITIALIZE TO FIRST HEADER 
          SB5    X2          LENGTH OF T.ENTP 
  
 PSA20    SA1    B7          FETCH HEADER 
          =B5    B5-1        DECREMENT FOR HEADER 
          =B7    B7+1        INCREMENT T.ENTP POINTER 
          HX1    EH.FPC 
          AX1    -EH.FPCL    EXTRACT NUMBER OF ARGUMENTS
          =X1    X1+1        ALLOW FOR THE MANDATORY NULL ENTRY 
          MX0    -2 
          BX0    -X0*X1      FOR MOD4 ARITHMETIC
          AX1    2
          SB6    X1 
          ZR     X0,PSA21    IF PARCELED EXACTLY
          =B6    B6+1 
  
 PSA21    NE     B6,B3,PSA27 IF NOT EQUAL LENGTH, NO MATCH
          =A1    B2-1        INITIALIZE FETCH 
          =A2    B7-1        INITIALIZE FETCH 
          SB4    B6          SEARCH LOOP COUNTER
  
 PSA23    =A1    A1+1        T.ARG ENTRY
          =A2    A2+1        T.ENTP ENTRY 
          =B4    B4-1        DECREMENT LOOP COUNT 
          IX0    X1-X2
          NZ     X0,PSA27    IF NOT A MATCH 
          NZ     B4,PSA23    IF MORE TO CHECK 
  
*         HAVE AN EXACT MATCH.  NOTE MATCH AND EXIT.
  
          SA5    T.ENTP 
          SX1    B7-1        POINT TO HEADER
          IX5    X1-X5       (X5) = EPIX
          EQ     PSA40       PROCESS ENTRY SYMBOL 
  
 PSA27    SB5    B5-B6       DECREMENT T.ENTP COUNT 
          SB7    B7+B6       INCREMENT T.ENTP POINTER 
          ZR     B5,PSA29    IF FINISHED, NO MATCH
          EQ     PSA20       LOOP FOR NEXT ENTRY
  
 PSA29    SX6    B1          INDICATE MULTIPLE PARAMETER LISTS
          SA6    N.EPL
  
*         CONSTRUCT (EH.) HEADER WORD FOR THIS UNIQUE PARAMETER LIST. 
*         THIS OFFSET = PREVIOUS LENGTH 
*         INCREMENT (CP.) LENGTH BY SIZE OF THIS LIST, INCLUDING ZERO 
*         WORD TERMINATOR.
  
 PSA30    SA3    N.CPL
          SA2    PSAB        NARGS = (PSAB) 
          SA1    T.ARG
          SX0    X3+B1       NCZ = (N.CPL) + 1       */ TERMINATOR
          LX3    EH.BIASP 
          SA4    T=ARG
          BX6    X3          (EH.BIAS) = (N.CPL)
          SA5    MOD
          MX7    -MO.MODEL
          BX7    -X7*X5      EXTRACT MODE (IF PRESENT)
          SBIT   X5,MO.FUNP 
          PL     X5,PSA33    IF NOT FUNCTION
          SBIT   X5,MO.CTYPP/MO.FUNP
          SX7    X7-M.CHAR
          NZ     X7,PSA33    IF NOT CHARACTER 
          PL     X5,PSA33    IF NOT ASSUMED SIZE
          SX6    X6+1        ACCOUNT FOR VALUH. 
  
 PSA33    LX2    EH.FPCP
          BX6    X6+X2       MERGE FP COUNT 
          LX2    -EH.FPCP    RESTORE X2 
          SA6    X1 
          IX7    X0+X2       (N.CPL) = NARGS + NCZ
          SA7    A3 
          ALLOC  T.ENTP,X4
          IX5    X2-X4       EPIX = NEW LENGTH - AMOUNT ADDED 
          IX3    X1+X5       DESTINATION = NEW FWA + EPIX 
          SA2    T.ARG
          BX1    X4          WC = AMOUNT ADDED
          MOVE   X1,X2,X3 
  
*         FINALLY, LINK THE ENTRY POINT TO IT'S PARAMETER LIST ENTRY
*         IN (T.ENTP) BY SETTING (WB.PNT) = EPIX+1 .
*                (X5) = EPIX
  
 PSA40    SA1    PSAA 
          SA2    T.SYM
          ZR     X1,PSA50    IF ERROR IN ENTRY NAME 
          SX5    X5+B1
          LX7    X1,B1
          =B7    X2+WB.W
          IX3    X7+X1       (X3) = INDEX OF ENTRY POINT
          ERRNZ  3-Z=SYM
          SA3    X3+B7
          LX5    WB.PNTP
          BX6    X3+X5
          SA6    A3 
  
 .T       IFEQ   TEST,ON
          MX0    -WB.PNTL 
          LX0    WB.PNTP
          BX7    -X0*X3      (X7) = PREVIOUS POINTER
          NZ     X7,"BLOWUP" IF PREVIOUS GARBAGE IN POINTER FIELD 
 .T       ENDIF 
  
 PSA50    SHRINK T=ARG
          EQ     EXIT.
  
 PSAA     EQU    SCR         SAVE SYMORD OF THIS ENTRY POINT
 PSAB     EQU    SCR+1       SAVE NUMBER OF ARGS IN THIS PARM LIST
 SAL      SPACE  4,20 
**        SAL - SCAN ARGUMENT LIST. 
* 
*         SCANS THE ARGUMENT LIST, TO CHECK SYNTAX AND BUILD A
*         TEMPORARY TABLE (T.ARG) CONTAINING THE NON-LABEL DUMMY
*         ARGS IN THIS LIST, IN ORDER.  DUPLICATES ARE DIAGNOSED, AND 
*         ONLY ENTERED ONCE.  EACH ARG IS ALSO MARKED AS (WB.FP) IN THE 
*         SYMBOL TABLE.  IF IT IS NOT YET IN THE FORMAL PARAMETER TABLE,
*         IT IS ADDED TO (T.FPI), AND IT'S FORMAL PARAMETER NUMBER IS 
*         SET INTO (WB.FPNO). 
* 
*         ENTRY  (B4) _ FIRST TOKEN OF PRESUMED ARGUMENT LIST.
* 
*         EXIT   (T.ARG) = SYMBOLS IN THIS ARGLIST. 
* 
*         CALLS  ACV, ADW, ERT, ESY, SCS, SCT, SSY, STY, TLV. 
  
  
 SAL      SUBR   0           ENTRY/EXIT...
          SA1    B4 
          ZR     X1,SAL21    IF EOS -- ARGLIST OMITTED
          ERRNZ  O.EOS
          SX2    X1-O.LP
          NZ     X2,SAL23    IF NO LEFT PAREN 
          SA1    B4+B1
          SB4    B4+B1
          SB7    X1-O.RP
          ZR     X1,E.MR1    IF EOS INSTEAD OF ARGUMENT 
          NZ     B7,SAL30    IF NOT EXPLICIT NULL ARGUMENT LIST 
          SB4    B4+1 
          EQ     SAL58
  
 SAL23    FATAL  E.AG07      ** EXPECTED ARGLIST LPAREN 
          EQ     EXIT.
  
*         OMITTED ARGUMENT LIST.
  
 SAL21    SA1    TB=TYPE
          HX1    KW.JMP 
          AX1    -KW.JMPL    EXTRACT PROCESSOR ADDRESS
          SB7    X1 
          ERRNZ  18-KW.JMPL 
          SB2    KW=ENTR
          SB7    B7-B2
          ZR     B7,EXIT.    IF ENTRY 
          SA1    MOD
          HX1    MO.FUN 
          PL     X1,EXIT.    IF NOT A FUNCTION
          FATAL  E.AG01 
          EQ     EXIT.
  
  
*         LOOP THRU ARGUMENT LIST.
  
 SAL30    SA1    B4          FETCH NEXT TOKEN 
          MX0    TB.TOCL
          SB7    X1-O.VAR 
          BX6    X0*X1
          SA6    FILL.
          ZR     B7,SAL34    IF LETTER
          SB2    X1-O.STAR
          SB7    E.AG04      ** FILL. MUST BE LETTER OR STAR
          NZ     B2,SAL32    IF NOT LABEL PARAMETER 
          SA1    MOD
          HX1    MO.SUB 
          =X6    1
          SA6    =XN.ARP     INDICATE ALTERNATE RETURNS CODE NEC. 
          MI     X1,SAL52    IF SUBROUTINE -- SKIP OVER LABEL PARM
          SB7    E.AG11      ** LABEL PARAMETER IN FUNCTION 
  
 SAL32    ZR     X1,E.MR1    CHECK FOR PREMATURE EOS
          FATAL  B7 
          EQ     SAL52
  
*         INSURE SYMBOL IN TABLE, AND MARK IT AS FORMAL PARAMETER.
  
 SAL34    CALL   SSY         SCAN SYMBOL TABLE
          SX4    X0 
          MI     B7,SAL36    IF NOT PREVIOUSLY ENCOUNTERED
          HX2    WB.FP
          MI     X2,SAL40    IF ALREADY KNOWN AS FP 
          CLAS=  X3,WB,(EQV,COM,PARM,NLST,SAVE,ENT) 
          LX2    1+WB.FPP 
          BX3    X3*X2
          =A1    A2-WB.W+WA.W      X1 = *WA*
          MX2    1
          LX2    1+WA.NFPP
          BX1    X2*X1       EXTRACT WA.NFP 
          BX3    X3+X1
          ZR     X3,SAL38    IF CAN BE AN FP
          FATAL  E.AG12      ** CANNOT BE FP
 .FIX     SET                NEEDS CCT CALL 
          EQ     SAL50
  
*         FIRST APPEARANCE OF SYMBOL.  TYPE IT AND ADD TO SYMTAB. 
*         IF AUTOMATIC LEVEL IS ON MARK THIS FP AS AUTO-LEVELED,
*         UNLESS IT HAS ALREADY BEEN EXPLICITLY LEVELED OR MADE 
*         EXTERNAL. IF WE ARE PAST DECLARATIVE PROCESSING DON'T 
*         SET THE WB.AL BIT SINCE NO FURTHER LEVEL STATEMENTS CAN 
*         OCCUR AND SETTING IT WILL INTERFERE WITH THE DUPLICATE
*         USE OF THE BIT IN EXECUTABLES FOR FLAGGING ASSIGNED GOTO
*         VARIABLES THAT ARE NEVER ASSIGNED TO. 
  
 SAL36    CALL   STY         SET NATURAL TYPE 
          BX7    X1          SET (WB.MODE)
          ADSYM  T.SYM
  
 SAL38    CLAS=  X3,WB,(FP) 
          SA4    CO.AL
          PL     X4,SAL39    IF AUTOMATIC LEVEL OFF 
          CLAS=  X4,WB,(EXT,LEV)
          BX4    X4*X6
          NZ     X4,SAL39    IF ALREADY EXT OR LEVELED
          CLAS=  X3,WB,(FP,LEV,AL)
          SA4    STAGE
          SX7    FEC=STF
          IX4    X4-X7
          MI     X4,SAL38A   IF STILL IN DECLARATIVE OR EARLIER 
          CLAS=  X3,WB,(FP,LEV) 
  
 SAL38A   BX7    X3 
          =X3    .DAL 
          ERRPL  .DAL-2 
          ZR     X3,SAL38B   IF NO LCM
          IFEQ   .MI,1,3
          =X3    0
          SA4    =XCO.TMLC
          ZR     X4,SAL38B   IF TM=LCM NOT SELECTED 
          CLAS=  X3,WB,(LCM) SET LCM BIT
  
 SAL38B   BX7    X7+X3       ADD IN LCM BIT IF LCM PRESENT
          BX3    X7 
          SA7    LEVEL
          SA7    LEVEL2      FORCES CLEARING OF WB.AL AT END OF DECL
  
 SAL39    CLAS=  X4,WB,(SFA)
          BX6    X6+X3
          BX6    -X4*X6      CLEAR STMT FUNC DUMMY ARG FLAG 
          SA6    A2 
  
*         SYMBOL NOW IN SYMTAB.  ADD TO (T.ARG).
*                (X0) = SYMORD
  
 SAL40    SX6    X0 
          BX4    X0 
          SCAN   T.ARG,SCT   CHECK FOR DUPLICATE APPEARANCE 
          MI     B7,SAL42    IF NOT ALREADY IN THIS ARGLIST 
          FATAL  E.AG03 
          EQ     SAL50
  
 SAL42    ADDWD  A1          ADD TO LOCAL ARGLIST 
  
*         SYMBOL NOW IN LOCAL ARGLIST.  INCLUDE IT IN (T.FPI).
*                (X4) = SYMORD
  
 SAL44    MX6    FP.PNTL
          LX6    FP.PNTL+FP.PNTP
          SA6    SCSA        MATCH SYMORD ONLY
          LX6    X4 
          LX6    FP.PNTP
          SCAN   T.FPI,SCS
          PL     B7,SAL50    IF ALREADY PARAMETER 
          ADDWD  A1 
          SA1    T.SYM
          LX0    X4,B1
          BX7    X2          (N.FP) = (T=FPI) 
          =B7    X1+WB.W
          IX3    X0+X4       (X3) = INDEX = SYMORD * Z=SYM
          ERRNZ  3-Z=SYM
          SA1    X3+B7       FETCH SYMTAB (WB)
          LX2    WB.FPNOP    (WB.FPNO) = INDEX IN (T.FPI) 
          SA7    N.FP 
          CLAS=  X0,WB,(VDS)
          BX6    X2+X1
          BX6    -X0*X6      REMOVE WB.VDS
          SA6    A1 
          SBIT   X1,WB.VDSP 
          PL     X1,SAL47    IF NOT VARDIM ARRAY OR SUBSCRIPT 
          SBIT   X1,WB.ARYP/WB.VDSP 
          MI     X1,SAL47    IF ARRAY, NOTHING TO DO
          SA1    T.FPI
          SB7    X7-1 
          SA1    X1+B7       FETCH T.FPI ENTRY
          CLAS=  X6,FP,(VDS)
          BX6    X6+X1
          SA6    A1          UPDATE WITH FP.VDS 
  
*         FOR UNIQUE FORMAL PARAMETERS ON ENTRY STATEMENTS, PROCESS FOR 
*         POSSIBLE ASSUMED LENGTH CHARACTER.
  
 SAL47    SA1    PSAA 
          SA2    S=ENTRY
          IX2    X1-X2
          LX1    X4          FORMAL PARAMETER ORDINAL 
          ZR     X2,SAL50    IF MAIN ENTRY POINT
          BX6    X4 
          SA6    SALA        SAVE ACROSS ACV CALL 
          CALL   ACV         PROCESS ASSUMED LENGTH CHARACTER 
          SA4    SALA        RESTORE
          SA1    T.VDI
          SA2    T=VDI
          ZR     X2,SAL50    IF NO VARDIM 
          SB7    X2-1 
          SA2    X1+B7       LATEST VDI ENTRY 
          MX1    VD.INDL
          LX1    VD.INDL+VD.INDP
          BX7    -X1*X2      CLEAR INDEX
          SA7    A2          UPDATE 
  
*         FILE CROSS-REF FOR SYMBOL.
  
 SAL50    SX6    X4          CONSTRUCT XREF ORD 
          LX6    XR.TAGP
          ADDREF X6,CR.REF
          =A3    B4+1 
          SB7    X3-O.VAR 
          NZ     B7,SAL52    IF NOT LONG NAME 
          CALL   TLV         TRUNCATE NAME
  
 SAL52    SA3    B4+B1
          ZR     X3,E.MR1    IF EOS -- ERROR
          SX2    X3-O.COMMA 
          SB4    A3+B1       B4 = B4 + 2
          ZR     X2,SAL30    IF *,* LOOP ON NEXT ARGUMENT 
          SX2    X3-O.RP
          NZ     X2,E.AG08   IF NO *)* - ERROR
  
 SAL58    SA2    B4 
          ZR     X2,EXIT.    IF *EOS*, STATEMENT ENDED CLEANLY
          ERRNZ  O.EOS
          WARN   E.AG02 
          EQ     EXIT.
  
 SALA     EQU    SCR+2       SAVE F.P. ORDINAL
 TSB      SPACE  4,20 
**        TSB - TRANSLATE SUBPROGRAM BEGIN. 
* 
*         TRANSLATES OPTIONAL ARGUMENT LIST, AND PERFORMS 
*         SUBPROGRAM INITIALIZATION COMMON TO SUBROUTINE AND
*         FUNCTION HEADER STATEMENTS. 
* 
*         CALLS  EMIT, PSA. 
  
  
 TSB      SUBR   0           ENTRY/EXIT...
          SA4    S=ENTRY
          RJ     PSA         PROCESS SUBPROGRAM ARGUMENTS 
  
          BX4    0
          MX5    0
          EMIT   V=SEX       START OF EXECUTABLES 
  
          SA4    TSAA 
          CLAS=  X3,WB,(CGS,VAR)
          CALL   TSY         TAG SYMBOL (EXIT.) 
          EQ     EXIT.
  
 TSAA     VFD    42/5LEXIT.,18/S=EXIT 
 WSA      SPACE  4,10 
**        WSA - WRAPUP SUBPROGRAM ARGUMENTS.
* 
*         CALLED BY KEY/END, WHEN THERE ARE ANY FORMAL PARAMETERS TO
*         A PROCEDURE SUBPROGRAM.  THIS PROCESSING IS DEFERRED UNTIL
*         END STATEMENT, SO THAT ALL FORMAL PARAMETERS ARE KNOWN. 
*         ENTER SUBPROGRAM SYMBOLS IN SYMTAB. 
  
  
 WSA      SUBR   =           ENTRY/EXIT...
          SA4    WSAA 
          CLAS=  X3,WB,(CGS,DEF,VAR,ARY)
          CALL   TSY         TAG SYMBOL (SUB.)
          SA4    A4+B1
          CLAS=  X3,WB,(CGS,DEF,VAR,ARY)
          CALL   TSY         TAG SYMBOL (SUBI.) 
          SA4    A4+B1
          CLAS=  X3,WB,(CGS,DEF,VAR,ARY)
          CALL   TSY         TAG SYMBOL (SUB0I.)
          TAGSEX (=L/SP5./)  SUBSTITUTE PARAMETER ADDRESSES 
          BX6    X0 
          SA6    S=SPA
          TAGSEX (=L/SLI./) 
          BX6    X0 
          SA6    S=SLI
  
          SA4    A4+B1
          SA1    N.EPL
          ZR     X1,WSA40    IF APL COPY NOT NEEDED 
          CLAS=  X3,WB,(CGS,DEF,VAR,ARY)
          CALL   TSY         TAG SYMBOL (CP.) 
          TAGSEX (=L/CPL./) 
          SA4    A4+B1
          BX6    X0 
          SA6    S=CPL
          CLAS=  X3,WB,(CGS,DEF,VAR,ARY)
          CALL   TSY         TAG SYMBOL (GPL.)
 WSA40    EQ     EXIT.
  
 WSAA     VFD    42/4LSUB.,18/S=SUB 
          VFD    42/5LSUBI.,18/S=SUBI 
          VFD    42/6LSUB0I.,18/S=SUB0I 
  
          VFD    42/3LCP.,18/S=CP 
          VFD    42/4LGPL.,18/S=GPL 
 END      SPACE  4,10 
          LIST   D
          END 
