*DECK     KEY 
          IDENT  KEY
 KEY      SECT   (KEYWORD STATEMENT PROCESSORS),1 
  
          SST    A,B,C,D,EXIT.
          NOREF  A,B,C,D,EXIT.
  
 B=KEY    RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  END1B,END1C,LCC66,GOTA,RTU,EMT,CRL,SVALUE. 
          ENTRY  NAM20
  
*         IN FTN
          EXT    F.LGO,LOP=M,LOP=R
  
*         IN TABLES 
          EXT    ASSN,ARGCOMA,ARGMODE,CCNT,CHARMAP,CALLOP,CALLARM,CSNTAG
          EXT    DOORD,DTI,ENTRY.,ERROP,EXTCAL,ETF,FLOW,GOASS,GOTARM
          EXT    HANGER,LDEAD,MOD,MULS,NARGS,NOPATH,NTRCNT,OPRETD,OPRETS
          EXT    OPDUM,REFNUM,REFVAR,RTNCNT,SB.STNL,STN,TT.PAR,TS.SYM 
          EXT    TP.NLST,TP.DIM,TP=DO,TS.ENT,TG.PRO,TS.STN,TT=PAR,T.VDIM
          EXT    TT=SCR,TT.SCR,TP=NLST,VALUE.,NOLIST,SLIST
  
*         IN ERRORS 
          EXT    E.AC5,E.AC8,E.AC9,E.AES,E.ANS,E.AP,E.AP1,E.ART,E.AS2 
          EXT    E.AS3,E.AS4,E.AS5,E.CL,E.CL1,E.CL2,E.CT,E.FM,E.GO,E.GO1
          EXT    E.GO2,E.GO2A,E.GO3,E.GO4,E.GO5,E.GO6,E.GO7,E.GO8,E.LN1 
          EXT    E.LN2,E.LN3,E.LN4,E.ME,E.MR1,E.MR2,E.M$2,E.M$3,E.OV
          EXT    E.OV1,E.OV3,E.PT,E.PT1,E.PT2,E.PT3,E.RA,E.RA1,E.SN16 
          EXT    E.APR,E.APR1,E.SPR,E.SPR1,E.SPR3,E.SU2,E.XC,FILL.
          EXT    E.SU1,E.LN 
          EXT   E.CL3 
  
*         IN BATCH
          EXT    RUN5 
  
*         IN HEADER 
          EXT    DCM,PPA,PSA
  
*         IN PIG
          EXT    WIN
  
*         IN END
          EXT    END
  
*         IN ALLOC
          EXT    ADW,ESY,SSY,NCS,CPM
  
*         IN MAIN 
          EXT    CUS.RET,PSP,PSP.F,ASL,ASK
  
*         IN LEX
          EXT    S.ACGOR,OCT,STY,TRV,TSF,S.END,S.PAUSE
  
*         IN IF 
          EXT    INIF,IFSN,IFREL1 
  
*         IN IO 
          EXT    LGR,TO 
  
*         IN NUM
          EXT    PSN,STN0R,ISN
  
*         IN REG
          EXT    CIA,CRJ,CDS
  
*         IN PAR
          EXT    CURST,PAR,FAL
  
*         IN GEN
          EXT    O=NTR0,O=NTRP,O=QUITS,O=BSS,O=NTR,O=RETN,O=NTRX,O=NTRM 
          EXT    O=NTRN,O=NTRY,O=GOTON,O=QUITP,SA=BKS3,ZERO,CAI 
          EXT    MXP,VEL,O=RTNA 
  
*         IN INIT 
          EXT    AGNK,CALLTAG,SCR,CST.BOS 
  
*         IN DECL 
          EXT    CCT
  
 AGN      SPACE  4
**        AGN -  PROCESS "ASSIGN" STATEMENT.
  
  
          HEREIF ASSIGN 
          SA4    B4 
          SB7    X4-O.CONS
          NZ     B7,E.AS4    IF NO LABEL
  
          RJ     ASL         ADJUST STATEMENT LABEL 
          =X6    CR.STR 
          =X7    CR.AGN 
          SA6    REFVAR 
          =B2    M.SNLAB
          BX6    X1 
          SA7    REFNUM 
          SA1    TP=DO
          NZ     X1,AGN1     IF INSIDE DO LOOP
          =X7    0
          SA7    =XISASG     INDICATE NOT INSIDE DO LOOP
          EQ     AGN11
 AGN1     SA6    =XISASG     SET ASSIGN FLAG IN ISN 
 AGN11    RJ     ISN         IDENTIFY STATEMENT NUMBER
  
          SA1    B4 
          =A6    AGNK        SAVE LABEL TAG 
          SB7    X1-O.COMMA 
          NZ     B7,AGN2     IF NO COMMA
          =B4    B4+1 
          WARN   E.AS5
  
 AGN2     SX5    LGR
          SA5    X5+TO
          SA1    B4 
          MX0    2*CHAR 
          BX6    X0*X1
          BX3    X0*X5
          IX3    X3-X6
          ZR     X3,AGN4     IF *TO*
          SA6    FILL.
          WARN   E.AS2
  
 AGN4     RJ     ASK         ADJUST STATEMENT KEYWORD *TO*
          RJ     TRV         TRANSLATE THE VARIABLE 
          MI     X0,PSN      IF ERROR 
          SA4    TS.SYM 
          SX3    M.DEF
          BX6    X3+X6
          SA6    X4+B7       SET DEFINED BIT IN SYMBOL TABLE
          =A3    B4+1 
          BX5    X2          PASS *2* TAG 
          SB7    X1-M.INT 
          SB3    ASSN 
          SB3    -B3
          =B4    B4+1        BUMP B4 FOR POSSIBLE ERROR MESSAGE 
          ZR     B7,AGN5     IF INTEGER VARIABLE
          WARN   E.AS3
  
 AGN5     ZR     X3,AGN7     IF NEXT ELEMENT *EOS*
          WARN   E.XC        ** IGNORED ENDING CRUD **
  
 AGN7     SA1    TT.PAR 
          SA4    AGNK        (1OP) = STATEMENT LABEL
*         =X5    X5          (2OP) = VARIABLE 
          AX4    P.TAG
          RJ     EMT
          EQ     PSN         EXIT.. 
  
          HEREIF TO 
          EQ     E.FM 
 BKD      SPACE  4,8
**        BKD -  PROCESS "BLOCKDATA" STATEMENT. 
*         EXIT   TO MASTER LOOP.
*         CALLS  1.  DCM = ASSEMBLE THE PROGRAM NAME. 
  
  
          HEREIF BLOCKDATA
  
          SA1    B4 
          SA2    BKDA 
          =X7    0
          ZR     X1,BKD1     IF NAME NOT SPECIFIED
          ANSI   =XE.ANS4    NON-ANSI FORM OF BLOCK DATA
          EQ     BKD2 
 BKD1     BX6    X2 
          SA6    B4          DEFAULT NAME TO *SB* 
          SA7    B4+B1
 BKD2     =X6    M.PBLK      PROGRAM-UNIT COMPILE MODE
          SA7    =XBA.PRO 
          SA4    =9ABLOCKDATA 
          RJ     DCM         DISPLAY COMPILING MESSAGE
          EQ     PSP         CONTINUE 
  
 BKDA     CON    7LBLKDAT.+O.VAR
 CLL      SPACE  4,20 
**        CLL -  PROCESS "CALL" STATEMENT.
  
  
          HEREIF CALL 
  
          SA1    B4 
          SB7    X1-O.VAR 
          NZ     B7,E.CL     IF NO NAME SUPLIED.
          RJ     MXP
          SX7    CR.SUB 
          SA7    REFVAR      INITIALIZE REFERENCE TYPE
          TAGSUB B4 
          BX1    X6 
          CLAS=  X3,(ENT,VAR,ASF,INLINE,BEF)
          SX2    P.EXT
          RJ     CCT         CHECK FOR CONFLICTING TYPE 
          ZR     X6,PSN      IF CONFLICTING TYPE
          BX0    X6 
          IFBIT  X0,-FUN,CCL14
          ANSI   E.CL3        SAME NAME USED AS A FUNCTION AND SUB
 CCL14    BSS    0
          MX0    -L.FPNO
          AX1    P.FPNO 
          MX3    L.TAG+L.MODE 
          BX4    -X0*X1      EXTRACT SYMBOL TABLE *PARM* FIELD
          LX3    L.MODE 
          LX4    P.2FPNO     F.P. NUMBER TO PASS *2* FIELD
          BX1    X3*X6       TAG + MODE 
          LX2    X6 
          IX6    X1+X4       TAG + PARM + MODE, PASS *2* TAG
          =A1    B4+1 
          BX5    X2          REMEMBER PASS *1* TAG
          SA6    CALLTAG     SAVE PASS *2* TAG FOR PARSER 
          SBIT   X2,DEF 
          SB2    X1-O.VAR 
          NZ     B2,CLL15    IF NOT LONG NAME 
          SB2    B7          SAVE B7
          RJ     =XTLV       TRUNCATE NAME
          SB7    B2          RESTORE B7 
          =A1    B4+1 
 CLL15    SB2    X1-O.LP
          ZR     X1,CLL40    IF NO PARAMETERS 
          MI     X2,CLL20    IF NOT FIRST USE 
          SA2    TS.SYM 
          BX7    X5 
          SA7    X2+B7       STORE BITS INTO SYMBOL TABLE 
  
 CLL20    NZ     B2,CLL50    IF NOT PAREN 
          =B4    B4+1        POINT TO *(* 
          =X6    O.SLP
          SA6    A1          SET DUMMY *(* FOR PARSER 
          SA1    CALLARM
          SA2    TT=SCR 
          LX2    36 
          BX6    X1 
          BX7    X2 
          SA7    ARGCOMA
          SA6    ARGMODE
          RJ     PAR         REDUCE TO SIMPLEST EXPRESSION
  
 CLL25    ALLOC  TT.PAR,L.TURP
          SA1    =XTRLINE    EMIT(O=RJT, SUBR, LINENO.) 
          SA2    =XCALLTAG
          BX7    X2 
          BX6    X1 
          SA1    =XEXTCAL 
          =A6    B7-L.TURP+OR.2OP 
          BX6    X1 
          =A7    A6-OR.2OP+OR.1OP 
          =A6    A7-OR.1OP+OR.OPR 
  
  
**        HERE WHEN ALL ARGUMENTS HAVE BEEN PROCESSED.
*         PROCESS EXTERNAL JUMP AND EXIT TO MASTER LOOP.
  
          EQ     PSN         EXIT.. 
  
  
**        HERE IF NULL LIST.
*         PROCESS EXTERNAL JUMP AND EXIT TO MASTER LOOP.
  
 CLL40    MI     X2,CLL41    IF NOT 1ST USE.
          SA2    TS.SYM 
          =X0    M.DEF
          BX6    X5+X0
          SA6    X2+B7       RESET INDICATING DEFINED, ARGUMENTS = 0. 
          =X7 
          EQ     CLL25       CONTINUE.. 
  
**        HERE IF ALREADY USED, CHECK ARGUMENT COUNT AGREEMENT. 
  
 CLL41    AX5    P.UARGC
          MX0    -L.UARGC 
          BX7    -X0*X5 
          ZR     X7,CLL25    IF ARGUMENT COUNT AGREES 
          WARN   E.SU2       ARGUMENT COUNT NOT CONSISTENT. 
          EQ     CLL25
  
 CLL50    SB2    X1-O.COMMA 
          =B4    B4+1 
          NZ     B2,E.CL1    IF NO *,* - ERROR
          SA2    TT=SCR 
          LX2    36 
          BX7    X2 
          SA7    ARGCOMA
          RJ     CRL         PROCESS CALL STATEMENT RETURNS  LIST 
          LX6    X2 
          SA6    SCR+1       FOR FAL
          SA4    CALLTAG     ROUTINE TAG NEEDED BY VEL
          RJ     VEL         VALIDATE ARGUMENT LIST 
          RJ     FAL         FLUSH ARGUMENT LOAD TURPLES
          EQ     CLL25
  
 CERN     SPACE  4,8
**        CRL -  PROCESS CALL STATEMENT RETURNS LIST
* 
*         ENTRY  (B4) _ COMMA PRECEDING (HOPEFULLY) *RETURNS* 
*                (X2) = (ARGCOMA) 
* 
*         EXIT   *TURPLES* FOR RETURNS LIST PARAMETERS ADDED TO TT.SCR
*                (X2) = (ARGCOMA) UPDATED 
* 
*         USES   A1,A3,A6,A7  X0,X4  B2,B3,B7 
*         NOTE - X5 IS PRESERVED
* 
*         CALLS  ISN
  
  
 CRL      SUBR               ENTRY/EXIT...
          BX6    X5 
          SA6    SAVEX5      X5 MAY CONTAIN OPERAND NEEDED LATER
          SA1    B4+B1
          SB4    B4+B1
          MX0    LG.VAR*CHAR
          SB7    X1-O.VAR 
          BX6    X0*X1
          NZ     B7,CRLERR   IF NOT LETTER - ERROR
          MX4    4*CHAR 
          BX4    X4*X1
          SA3    =0LRETU
          IX4    X4-X3
          NZ     X4,CRLERR   IF FIRST 4 LETTERS NOT *RETU*
          SA3    =0LRETURNS 
          IX4    X6-X3
          ZR     X4,CRL10    IF *RETURNS* 
          WARN   E.AC9
 CRL10    ANSI   E.ANS
          SA1    B4+B1
          SB4    B4+B1
          SX4    X1-O.( 
          NZ     X4,E.AP     IF NO *(* - ERROR
          MX5    0           BOTH ARGS DUMMY FOR -0 WORD TURPLE 
          SB3    CALLOP 
          SB3    -B3
          SA1    TT.SCR 
          RJ     EMT         O=ARG TREATS THIS ONE SPECIAL
          SX6    X2+B1       UPDATE ARGCOMA VALUE 
          SA6    ARGCOMA
          =B4    B4+1 
 CRL20    SA1    B4 
          MX0    LG.STN*CHAR
          SB7    X1-O.CONS
          BX6    X0*X1
          SA6    FILL.
          ZR     B7,CRL30    IF DIGIT 
          MX0    L.CDPC 
          SA2    X1+CHARMAP 
          NZ     X2,CRL21    IF NOT VARIABLE
          LX2    X1 
 CRL21    BX6    X2*X0
          SA6    FILL.
          FATAL  E.CL2       RETURNS ARG MUST BE NUMERIC
          EQ     CRL40
  
 CRL30    SA1    CR.CALL
          BX7    X1 
          SA7    REFNUM 
          =B2    M.SNLAB+M.SNREF
          RJ     ISN         IDENTIFY STATEMENT NUMBER
          BX5    X6          STATEMENT NUMBER TAG 
          MX4    0           1ST OPERAND = DUMMY
          SB3    CALLOP 
          SB3    -B3
          SA1    TT.SCR 
          RJ     EMT
 CRL40    SA2    ARGCOMA
          SX6    X2+B1       UPDATE ARGCOMA 
          SA6    ARGCOMA
          =A3    B4+1 
          ZR     X3,E.MR1    IF PREMATURE *EOS* 
          SA1    A3+B1
          SX4    X3-O.COMMA 
          SB4    A3+B1
          ZR     X4,CRL20    IF *,* LOOP ON NEXT ARGUMENT 
          SX4    X3-O.) 
          NZ     X4,E.AP1    IF NO *)* - ERROR
          ZR     X1,CRL50    IF *EOS* 
          WARN   E.AC8
 CRL50    SA5    SAVEX5 
          SA2    ARGCOMA
          SB2    X2-MAX.SARG
          LE     B2,EXIT.    IF DOESNT EXCEED COMPILER LIMIT
          SA4    CALLTAG
          AX4    P.2TAG 
          SA1    TS.SYM 
          SB2    X4-C.SYM 
          SA4    X1+B2
          =A1    A4-1 
          MX0    L.SYM
          BX6    X0*X1
          SA6    =XFILL.3 
          FATAL  =XE.SU8
          EQ     EXIT.
  
*         IF NOT RETURNS FOLLOWING *ARGUMENT LIST* *,*
  
 CRLERR   SA2    X1+=XCHARMAP 
          NZ     X2,CRLERR1  IF NOT VAR OR CONS 
          LX2    X1 
 CRLERR1  MX0    L.CDPC 
          BX6    X0*X2
          SA6    FILL.
          EQ     E.AC5
  
 SAVEX5   DATA   0
          SPACE  4,8
 CTU      SPACE  4
**        CON -  PROCESS "CONTINUE" STATEMENT.
*         EXIT   TO MASTER LOOP.
  
  
          HEREIF CONTINUE 
  
          RJ     MXP         MARK EXTERNAL PROCESS
          =A2    B4 
          SA4    STN
          ZR     X2,CON      IF E.O.S.
          WARN    =XE.XC     GARBAGE IGNORED AT E.O.S.
 CON      SA2    INIF 
          ZR     X2,CON15    IF *CONTINUE* NOT OBJECT OF *IF* 
          NOTE   E.GO2A      IF RESULTS IN A TRANSFER TO NEXT LINE
          EQ     PSN
  
 CON15    ZR     X4,E.CT     IF NO STATEMENT NUMBER 
          EQ     PSN         CONTINUE 
 END1     SPACE  4,8
**        END1 - START OF END STMNT 
*         EXIT   TO *END* PROCESSING  (PASS 2). 
  
  
          HEREIF END
  
          SA1    NOLIST 
          SA3    LOP=M
          SA4    LOP=R
          MI     X1,END1     IF IN *LIST,ALL* MODE AT END LINE TIME 
  
*         HERE IF IN *LIST,NONE* MODE AT END LINE TIME. 
  
          MX6    0
          SA6    A3+         SET TO *NO REF MAP*
          SA6    A4+         SET TO *NO REF MAP*
  
*         CHECK FOR LABELLED END. 
  
 END1     SA2    SB.STNL
          ZR     X2,END1A    IF NO STATEMENT LABEL
          BX6    X2 
          SA6    FILL.
          WARN   E.SN16      ** STATEMENT LABEL IGNORED **
  
 END1A    SA5    "SB.KEY" 
          MI     X5,E.ME     IF GENERATED END LINE  (RETURN -1B)
  
 END1B    SA2    MULS 
          BX6    0
          SA6    A2 
          NZ     X2,E.M$2    IF MULT STATMT ON LINE (RETURN -1C)
  
 END1C    SA1    B4 
          ZR     X1,END1E    IF END OF STATEMENT
          WARN   E.XC        ** TRAILING GARBAGE IGNORED ** 
  
 END1E    SA5    MOD
          SA1    FLOW 
          IFBIT  X5,PBLK,END IF *BLOCK DATA*
          NZ     X1,END      IF NO FLOW INTO *END* STATEMENT
          SA1    NOPATH 
          NZ     X1,END      IF LAST STATEMENT WAS A TRANSFER OF CONTROL
          ANSI   E.AES       NON ANSI USAGE.
          IFBIT  X5,PPRO/PBLK,END1D              IF MAIN PROGRAM
          EQ     END
  
 END1D    RJ     SER         COMPILE END INSTRUCTIONS 
          EQ     END         RETURN 
 FCT      SPACE  4,8
**        FCT -  PROCESS "FUNCTION" STATEMENT.
*         EXIT   TO MASTER LOOP.
*         CALLS  1.  DCM = ASSEMBLE THE PROGRAM NAME. 
*                2.  PSA = PROCESS ANY FORMAL PARAMETER LIST. 
*                3.  TRV = ENTER *VALUE.* INTO SYMBOL TABLE.
  
  
          HEREIF FUNCTION 
  
          SA2    B4 
          SA1    ETF
          BX6    X2 
          NZ     X1,FCT2     IF FUNCTION EXPLICITLY TYPED 
          SB7    X2-3 
          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
          RJ     STY
 FCT2     SX6    X1+M.PFNC   SUBPROGRAM MODE
          SA4    =8AFUNCTION
          RJ     DCM         DISPLAY COMPILING MESSAGE
          RJ     PSA         PROCESS SUBPROGRAM ARGUMENTS 
          SB4    SVALUE.
          RJ     TRV         ENTER THE FUNCTION-VALUE CELL
          SA3    MOD
          MX0    -L.MODE
          BX6    X0*X6
          SA2    TS.SYM 
          BX3    -X0*X3 
          IX6    X6+X3       INSURE MODE IS SAME AS MAIN ENTRY
          SA6    X2+B7       RESET TAG IN SYMBOL TABLE. 
          SX7    B7 
          SA7    VALUE. 
          EQ     PSP
  
 SVALUE.  VFD    42/0LVALUE.,18/O.VAR 
 LCC      SPACE  4,8
**        LCC -  HANDLE EMBEDDED LOADER CONTROL CARDS.
* 
*         DIRECTIVES CURRENTLY KNOWN ARE -- 
*                "OVERLAY"
*                "LDSET"
* 
*         EXIT   TO RUN.X, SO THAT A FOLLOWING *IDENT* MAY BE DETECTED. 
  
  
          HEREIF LDSET
  
          SA3    =5RLDSET 
          SB2    5*CHAR 
          EQ     LCC
  
  
          HEREIF OVERLAY
          SA3    =7ROVERLAY 
          SB2    3*CHAR 
  
 LCC      SA2    B4 
          BX7    X3 
          SA7    =XLDRFLG 
          =A1    =XFV.LGO 
          ZR     X1,RUN5     IF BINARY OUTPUT SUPPRESSED (B=0)
          MX0    -CHAR
          SB7    X2-O.( 
          ZR     X2,E.OV     ** WARN -- NULL LCC IS IGNORED **
          SA6    SCR
          NZ     B7,E.OV1    ** FATAL - LCC MISSING BEGINNING LPAREN ** 
          BX6    X3 
  
 LCC2     SA1    X2+CHARMAP 
          NZ     X1,LCC3     IF NOT *SYMBOL*
          BX1    X0*X2       USE *SB* 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 
          =A2    A2+1 
          NZ     X2,LCC2     IF NOT *EOS* 
          LX6    X6,B2       LEFT JUSTIFY 
          BX7    0
          =A6    A6+1 
          =A7    A6+1        INSURE END-OF-LINE 
  
 .CMLOD   IFNE   .CMLOD      FORCE LGO TO DISK
          SA3    LGOIO
          MI     X3,LCC6     IF BINARY ON DISK
          MX6    -1 
          SA6    A3          INDICATE LGO ON DISK 
          NOTE   E.OV2       ** LCC STOPS CMLOD **
          SA1    T.LGO
          SA4    T=LGO
          WRITEW BO,X1,X4 
 .CMLOD   ENDIF 
  
  
          IFEQ   CP#RM,7,2
 LCC6     BSS    0
          SKIP   1
 LCC6     RECALL F.LGO
  
          SB7    SCR+1
          SX1    A7-B7
          SX0    B4          SAVE (B4)
          WRITEC F.LGO,SCR+1,X1 
          WRITER F.LGO,RCL
          SB4    X0          RESTORE (B4) 
          SA2    SB.STNL
          ZR     X2,LCC64    IF NO STATEMENT LABEL
          BX6    X2 
          SA6    FILL.
          WARN   E.SN16      ** STATEMENT LABEL IGNORED **
  
 LCC64    SA1    CCNT 
          SB7    X1-1 
          ZR     B7,E.OV3    IF CONTINUED     (RETURN  LCC66) 
  
 LCC66    SA2    =XT.DLBUF
          SX1    X2+1        FWA CARD TO PRINT (SEE FORMAT OF T.DLBUF)
          SA3    X2 
          SX2    X3-2        LEN OF CARD TO PRINT IN WORDS
          SA4    =XCP.LSTF
          ZR     X4,NOTPRT   IF L = 0 
          PLINE  X1,X2       PRINT CARD 
 NOTPRT   SA1    MULS 
          ZR     X1,RUN5     IF NO $ STATEMENT SEPARATOR
          BX6    0
          SA6    A1 
          EQ     E.M$3       ** MULTIPLE STATEMENT IGNORED AFTER LCC ** 
 NAM      SPACE  4,8
**        NAM -  PROCESS "NAMELIST" SPECIFICATION.
* 
*         TRANSLATES NAMELIST DECLARATIONS INTO TP.NLST, IN A FORM
*                CONVENIENT FOR RELOCATION PROCESSING.
* 
*         EXIT   TO MASTER LOOP.
* 
*         NAMELIST [ /<GROUP-NAME>/ <ITEM> [,<ITEM>] ]
* 
*         [...]  INDICATES MAY BE REPEATED. 
*         <GROUP-NAME> #  THE NAME OF THIS NAME-LIST GROUP.  IT MAY NOT 
*                DUPLICATE AN ENTRY ALREADY IN SYMBOL TABLE.
*         <ITEM> #  <SIMPLE-VARIABLE> OR <ARRAY>. 
  
  
          HEREIF NAMELIST 
  
          WARN   E.ANS       NON-ANSI USE - WARNING 
          SB4    B4+1        POINT TO GROUP-NAME
  
**        NAM1 - BEGIN PROCESSING GROUP-NAME. 
*         ENTRY  B4 _ TO GROUP-NAME 
*         GROUP-NAME WILL BE ENTERED INTO TS.NAM, AND INTO TT.NAM WITH
*                *NLST* BIT ON AND *ARR* FIELD POINTING TO ORDINAL OF 
*                THE FIRST TP.FMT ENTRY TO BE MADE FOR THIS GROUP.
  
  
 NAM1     SA1    B4-B1       -1  EXPECT SLASH 
          SA2    B4          +0  REQUIRE GROUP-NAME 
          SA3    B4+B1       +1  EXPECT SLASH 
          SX4    X1-O.SLASH 
          NZ     X4,E.LN     IF STNTAX ERROR
          ZR     X2,E.MR2    IF *EOS* - ERROR 
          MX0    L.SYM
          BX6    X0*X2
          =B7    X2-O.VAR 
          NZ     B7,E.LN2    IF NO LETTER, ERR..
          SB7    X3-O.VAR 
          NZ     B7,NAM15    IF NOT LONG NAME 
          RJ     =XTLV       TRUNCATE NAME
          =A3    B4+1 
 NAM15    SX4    X3-O.SLASH 
          NZ     X4,E.LN1    IF NO */* AFTER NAME 
          SCAN   TS.SYM,SSY 
          PL     B7,E.LN3    IF ALREADY DEFINED, ERR..
          SA3    TP=NLST
          =X4    M.NLST+M.DEF+M.NAML+M.VAR
          LX3    P.PNT
          BX7    X3+X4
          SB4    B4+2        B4 NOW POINTS TO FIRST VARIABLE IN LIST
          ADSYM  A1 
          =A3    A6-1        RE-LOAD GROUP NAME 
          SX7    X3 
          BX6    X3-X7
          ADDWD  TP.NLST     PUT GROUP-NAME IN THE NAMELIST 
  
**        NAM2 - PROCESS EACH ITEM IN THE GROUP.
*         ENTRY  B4 _ VARIABLE NAME TAG 
  
  
 NAM2     SA1    B4 
          ZR     X1,=XE.MR3  IF *EOS* - FATAL ERROR 
          SX2    X1 
          BX5    X1-X2       ISOLATE AND SAVE NAME
          RJ     TRV         TRANSLATE VARIABLE 
 NAM20    SA2    TS.SYM 
          SA4    ENTRY. 
          SB2    X4 
          SB2    B2-B7
          NZ     B2,NAM20A   IF NOT FUNCTION NAME 
          SA4    VALUE. 
          SB7    X4          RESET WITH VALUE. ORDINAL
          IX4    X4+X2
          SA4    X4 
          BX6    X4          RESET WITH VALUE. SYMTAB ENTRY 
          MX0    L.SYM
          SA5    SVALUE.
          BX5    X0*X5       USE VALUE. 
 NAM20A   SX0    M.DEF
          BX6    X0+X6
          SA6    X2+B7       SET DEFINED BIT ON 
          BX7    X6 
          IFBIT  X7,-LEV,NAM20B    IF NOT LEVEL 
          LX7    P.LEV+1-P.LEVN    RIGHT JUSTIFY LEVEL NUMBER 
          MX0    -L.LEVN
          BX3    -X0*X7      (X3) = LEVEL NUMBER
          SX3    X3-3 
          NZ     X3,NAM20B   IF NOT LEVEL 3 
          FATAL  =XE.LV11 
          EQ     NAM3 
  
 NAM20B   MX0    -L.FPNO
          LX6    -P.FPNO
          SA2    TP.DIM 
          BX7    -X0*X6      FORMAL PARAMETER NO., IF ANY 
          LX6    -P.PNT+P.FPNO
          SA7    NAMFP
          MX0    -L.PNT 
          BX3    -X0*X6      ISOLATE TP.DIM ORDINAL 
          SB6    X3 
          MX0    L.NDIM 
          SA3    X2+B6       FETCH 1ST DIM WORD 
          SBIT   X6,ARY/PNT-1 
          BX2    X0*X3       ISOLATE NUMBER OF DIMS 
          IX1    X1+X5
          IFBIT  X3,VDIM,E.LN4
          LX2    -P.NDIM
          AX6    -0 
          SB5    B7          SAVE (B5) = TAG ORDINAL
          =B6    B6+1 
          AX0    X2,B1
          BX2    X6*X2
          SA4    TP=NLST
          LX2    6           **** QQ SHIFT COUNT
          BX5    X1+X2
          ALLOC  TP.NLST,X0+2 
          SA2    TP.DIM 
          IX3    X1+X4
          BX6    X5 
          SX5    X5 
          SA4    X2+B6       FETCH 2ND DIM WORD 
          MX7    0
          SA6    X3          STORE NAME/NDIM/TYPE WORD
          SA1    NAMFP
          AX5    6           ISOLATE NUMBER OF DIMS 
          SA7    A1          CLEAR FOR NEXT ITEM
          NZ     X1,NAM21    IF FORMAL PARAMETER
          SX7    B5+C.VAR 
          EQ     NAM22
  
 NAM21    MX7    1
          =X1    X1-1        F.P.ORD
          LX7    28+1        INDICATE FP
          BX7    X7+X1       31/0,1/1,28/F.P.ORD
  
 NAM22    ZR     X5,NAM23    IF SIMPLE VAR. 
          IX7    X7+X4
 NAM23    =A7    A6+1        STORE ADDRESS (+ 1ST DIM) WORD 
          AX5    1           = NDIMS / 2  =  NUMBER OF DIM WORDS TO COPY
          =B2    X5 
  
 NAM25    =A4    A4+1 
          BX7    X4 
          =B2    B2-1 
          =A7    A7+1 
          PL     B2,NAM25    IF REST OF DIMS NOT YET XFERED 
  
  
**        NAM3 - NOW CHECK FOR SEPARATOR, AND QUIT OR GO BACK FOR MORE. 
*         IF SEPARATOR IS NOT A COMMA, WE ENTER A ZERO WORD TO INDICATE 
*                END-OF-GROUP, AND CHECK FOR *EOS*
*                IF *EOS* WE ARE THRU.
*         IF SEPARATOR IS A COMMA, WE RETURN TO *NAM2*. 
  
  
 NAM3     SA4    B4+B1       FETCH NEXT SEPARATOR 
          SB4    A4+B1       POINT TO NEXT ITEM 
          SX2    X4-O.COMMA 
          ZR     X2,NAM2     IF COMMA 
          BX6    0
          ADDWD  TP.NLST     ADD END-OF-GROUP MARK
          NZ     X4,NAM1     CONTINUE WITH NEXT GROUP 
          EQ     PSP
  
 NAMFP    DATA   0           FORMAL PARAMETER NO., IF ANY 
 NTR      SPACE  4,8
**        NTR -  PROCESS "ENTRY" STATEMENT. 
*         EXIT   TO MASTER LOOP.
  
  
          HEREIF ENTRY
  
          ANSI   E.ANS       NON ANSI STATEMENT.
          DRITE  DEACTIVATE 
          SA2    MOD
          IFBIT  X2,PPRO,E.PT1
          BX6    0
          SA6    NOPATH      RESET STATEMENT-NO.-REQD .FLAG 
          SA1    =XSTAGE
          SX2    =XCPM=ASF
          IX1    X1-X2
          MI     X1,NTR14    IF IN DECLARATIVE PROCESSING 
          SA2    TP=DO
          ZR     X2,NTR14    IF NOT INSIDE A *DO* 
          WARN   E.PT2
 NTR14    SA2    B4 
          SA1    B4+B1
          ZR     X2,E.PT3    IF *EOS* 
          SB7    X2-O.VAR 
          NZ     B7,=XE.PT4  IF NOT VARIABLE
          MX0    L.SYM
          BX6    X0*X2
          SA6    FILL.
          ZR     X1,NTR2     IF NOT EXTRA GARBAGE 
          =B4    B4+1 
          WARN   E.XC        NONSENSE IGNORED AFTER NAME
 NTR2     SCAN   TS.SYM,SSY  FIND WHERE TO PUT *SYMBOL/TAG* 
          PL     B7,E.PT     IF ALREADY DEFINED, ERR..
          =X7    M.ENT+M.DEF+M.NVAR 
          BX4    X6 
          ADSYM  A1          ADD *SYMBOL/TAG* TO TABLE. 
          BX6    X0+X4
          SX5    X0+C.VAR+1 
          ADDWD  TS.ENT 
          BX2    X5 
          LX2    P.TAG
          ADDREF X2,CR.NTR
          SA2    FLOW 
          SA1    TG.PRO 
          BX7    0
          =X6    X1+1 
          SA7    A2          INDICATE *FLOW* INTO NEXT STATEMENT
          SA6    A1 
          SA6    INIF        FORCE LABEL AFTER STATEMENT
          NZ     X2,NTR5     IF NO FLOW INTO THIS STATEMENT 
          CLONG  X6,I.EQ
  
**        NEXT ADD AN ENTRY POINT TURPLE TO PARSED FILE.
*         FIRST, ISSUE TURPLE TO MOVE RETURN ADDRESS TO EXIT WORD.
*                (1OP) = ENTRY POINT TAG FOR THIS ENTRY POINT 
*                (2OP) (UPPER) = TAG OF MAIN ENTRY POINT
*         ENTRY  (X5) = TAG FOR THIS ENTRY POINT
 NTR5     SA1    ENTRY.      MAIN ENTRY POINT 
          BX4    X5          TAG FOR THIS ENTRY POINT 
          =X7    1
          SX5    X1+C.VAR 
          SB3    O=NTR0 
          SA7    NTRCNT      INDICATE *ENTRY* STATEMENT OCCURRED
          LX5    P.2TAG 
          SA1    TT.PAR 
          RJ     EMT         EMIT O=NTR0 TURPLE 
**        FOR A MACHINE WITH AN INSTRUCTION STACK, IT IS NOW
*         NECESSARY TO VOID THE STACK BECAUSE THE RETURN ADDRESS
*         JUST STORED INTO MAY ALREADY BE IN THE STACK. 
*                (1OP) = LABEL TO USE FOR VOID-STACK-WORD 
*                (2OP) = DUMMY
  
          SA1    TG.PRO      LAST CREATED LABEL 
          SB3    =XO=VOID 
          =X6    X1+1 
          MX5    0           DUMMY SECOND ARGUMENT
          SA6    A1 
          BX4    X6          LABEL TO BE CREATED
          SA1    TT.PAR 
          RJ     EMT         EMIT TURPLE TO VOID STACK
  
**        LASTLY, ISSUE TURPLE TO JUMP TO INITIALIZATION CODE, IF 
*         PARAMETERS ARE PRESENT. 
*                (1OP) = DUMMY
*                (2OP) = TAG OF NEXT STATEMENT
          SA1    NARGS
          ZR     X1,PSN      IF NO ARGS 
          SA5    INIF        TAG OF NEXT STATEMENT
          MX4    0
          SB3    O=NTRP      ENTRY WITH PARAMETERS
          SA1    TT.PAR 
          RJ     EMT
          EQ     PSN         EXIT.. 
 PATCH    SPACE  4,8
**        PAT -  PROCESS "PATCH" STATEMENT
*                (ONLY IN *TEST* MODE)
* 
*         STATEMENT CONSISTS OF THE WORD *PATCH*, FOLLOWED BY AN
*                ADDRESS, THEN ANY SEPARATOR, AND THEN THE CONTENTS OF
*                THE NEW WORD.  BLANKS ARE IGNORED.  THE *B* SUFFIX IS
*                NOT ALLOWED. 
* 
*         C A U T I O N   --  ACTIVATE AND USE THIS STATEMENT AT YOUR 
*                            OWN RISK.  CONTROL DATA CORP. NOT RESPON-
*                            SIBLE FOR ANY RESULTS OF THE USE OF A
*                            *PATCH* STATEMENT. 
* 
*         ERROR CHECKING IS THE ABSOLUTE POSSIBLE MINIMUM.  IT IS NOT 
*                LOGICALLY POSSIBLE TO USE IN MANY CASES. 
*         COMPILER DE-BUGGING CONVIENIENCE ITEM  O N L Y. 
  
  
 TEST     IFNE   TEST 
  
          HEREIF PATCH
  
          =A3    B4-1 
          RJ     OCT         ASSEMBLE ADDRESS WHERE PATCH IS TO GO
          SA6    PATA 
          =A3    A3+1        SKIP OVER SEPARATOR
          RJ     OCT         ASSEMBLE CONTENTS OF WORD
          SA1    PATA 
          SA6    X1          STORE NEW WORD 
          EQ     PSP.F
  
 PATA     DATA   0           SAVE CELL FOR ADDRESS FIELD. 
  
 TEST     ENDIF 
 PAU      SPACE  4,8
**        PAU -  PROCESS "PAUSE" STATEMENT. 
*         EXIT   TO *SPR* WITH (B3) = *PAUSE* INDICATION. 
  
  
          HEREIF PAUSE
  
          =B6    S=PAU       INDICATE *PAUSE* 
          RJ     SPR         COMPILE PAUSING INSTRUCTIONS 
          CRJ    NONE        COMPILE  *RJ =XPAUSE.* 
          SA1    DTI
          NZ     X1,E.SPR3   ANSI - PAUSE N.F.G AS DO-TERM
          EQ     PSN         EXIT.. 
 PPG      SPACE  4,8
**        PPG -  PROCESS "PROGRAM" STATEMENT. 
*         EXIT   TO MASTER LOOP.
*         CALLS  1.  WARN (NON-ANSI STATEMENT). 
*                2.  DCM = ASSEMBLE THE PROGRAM NAME. 
*                3.  PPA = PROCESS ANY FILE DECLARATION LIST. 
  
  
          HEREIF PROGRAM
  
          SX6    M.PPRO      SET SUBPROGRAM MODE
          SA4    =7APROGRAM 
          RJ     DCM         DISPLAY COMPILING MESSAGE
          ANSI   E.ANS       NON ANSI STATEMENT 
          RJ     PPA         PROCESS PROGRAM MESSAGE
          EQ     PSP         RETURN TO MASTER LOOP
          SPACE  4           RTN
**        RTN -  PROCESS "RETURN" STATEMENT.
*         EXIT   MASTER LOOP
*         CALLS  CLT - TO CLEAR REGISTER ASSOCIATES.
*                RTU - IF NOT IN A MAIN PROGRAM.
*                SER - IF MAIN PROGRAM, ACT LIKE *END*. 
  
  
  
          HEREIF RETURN 
  
          SA2    DOORD
          SA3    MOD
          ZR     X2,RTN1     IF NOT INSIDE A *DO* 
          SA1    TS.STN 
          SB2    X2 
          =X0    M.SNEX 
          SA4    X1+B2
          BX7    X4+X0
          SA7    A4          INDICATE *DO* HAS AN EXTERNAL REFERENCE
 RTN1     =X6    1
          SBIT   X3,PPRO
          SA6    NOPATH 
  
**        VALIDATE SYNTAX -- NOTHING MAY FOLLOW THE KEYWORD.
  
          SA1    B4 
          NZ     X1,RTN9     IF NOT *EOS* 
 RTN2     PL     X3,RTN4     IF NOT MAIN PROGRAM
  
**        WHEN IN MAIN PROGRAM, ACT LIKE *END*. 
  
 RTN3     RJ     SER         SET *END* RETURN CODE
          EQ     E.ART       ** RETURN IN MAIN IS NON-ANSI ** (EXIT PSN)
  
**        IN SUBPROGRAM, JUMP TO *CT.RETN*. 
  
 RTN4     SA1    INIF 
          NZ     X1,RTN8     IF OBJECT OF 1-BRANCH *IF* 
  
**        SET (HANGER) AND RETURN TO MASTER LOOP TEMPORARILY, TO FIND 
*                OUT WHAT NEXT STATEMENT IS.
  
          SX6    RTN5 
          SA6    HANGER 
          EQ     PSN         GET NEXT STATEMENT 
*         ... 
 RTN5     =A1    "SB.KEY"    BACK HERE WITH NEXT STATEMENT
          SA2    RTNCNT 
          SB7    X1-END=
          ZR     B7,RTN6     IF NEXT IS *END* 
  
**        IF THE NEXT STATEMENT IS NOT THE *END* LINE, COMPILE JUMP TO
*                THE RETURN CODE, AND UPDATE COUNT OF *RETURN*
*                STATEMENTS.
  
          =X6    X2+1        COUNT *RETURN* STATEMENTS
          SB3    O=QUITS
          SA6    A2 
          SA1    TT.PAR 
          SX4    CT.RETN
          BX5    X4 
          RJ     EMT         EMIT  (O=QUITS,  CT.RETN)
          EQ     CUS.RET     EXIT.. 
  
**        IF *RETURN* IMMEDIATELY PRECEDES *END* LINE, NO JUMP IS 
*                NECESSARY.  WE ALSO INDICATE THIS FACT (BY COMPLEMENT- 
*                ING (RTNCNT), AS THIS MAY MEAN THE *BSS* FOR *CT.RETN* 
*                IS NOT NEEDED. 
  
 RTN6     BX6    -X2
          SA6    A2 
          EQ     CUS.RET     EXIT.. 
  
**        WHEN *RETURN* IS OBJECT OF A 1-BRANCH *IF*, CHANGE THE JUMP.
*                DECREMENT (*TG.PRO*), AS THE FORMER TAG WILL NOT BE
*                USED IN THE ALTERED CODE.  CLEAR (INIF) TO KEEP THAT 
*                TAG FROM BEING GENERATED.
*         ENTRY  (A1) _ INIF. 
*                (IFREL1) = MACRO ADDRESS FOR OPPOSITE *IF* JUMP. 
  
 RTN8     SA2    TG.PRO 
          SA3    TT.PAR 
          SX6    X2-1        RESET (TG.PRO) 
          SA4    TT=PAR 
          SA5    IFREL1      IF MACRO ADDRESS FOR ONE BRANCH
          BX7    0
          SA6    A2 
          IX0    X3+X4       = LWA TT.PAR 
          SX6    CT.RETN
          LX5    P.JPAD 
          BX3    X6 
          SA4    RTNCNT 
          LX3    P.PTAGM
          SA2    X0-L.TURP+OR.OPR 
          MX1    L.JPAD 
          IX6    X3+X6       BROADCAST TAG
          SA7    A1 
          =A6    X0-L.TURP+OR.2OP  RESET JUMP TARGET
          BX3    -X1*X2      CLEAR OLD MACRO ADDRESS
          SA7    NOPATH      CLEAR NO PATH FLAG 
          =X6    X4+1        INCREMENT COUNT OF *RETURN* STATEMENTS.
          IX7    X3+X5       ADD ANEW 
          SA6    A4 
          SA7    A2          RESET MACRO ADDRESS
          EQ     PSN         EXIT.. 
  
 RTN9     PL     X3,RTN91    IF NOT MAIN PROGRAM
          WARN   E.XC 
          EQ     RTN3 
  
 RTN91    SB7    X1-O.VAR 
          ZR     B7,RTN93    IF LETTER
          EQ     E.RA 
  
 RTN93    MX0    L.SYM
          BX6    X0*X1
          SCAN   TS.SYM,SSY 
          MI     B7,E.RA1    IF NOT ALREADY DEFINED, ERR..
          IFBIT  X2,-RP,E.RA1 IF NOT RETURNS PARAMETER, ERR.. 
          ANSI   E.ANS       ALTERNATE RETURN STATEMENT IS NON-ANSI 
          MX4    -L.2FPNO 
          AX6    P.2FPNO
          BX4    -X4*X6      EXTRACT PARAMETER ORDINAL
          SX4    X4-1 
          SA1    TT.PAR 
          SB3    O=RTNA 
          MX5    0
          RJ     EMT         EMIT  (O=RTNA) 
          SA1    B4+B1
          SB4    B4+B1
          ZR     X1,RTN96    IF *EOS* 
          WARN   E.XC 
 RTN96    SA1    INIF 
          ZR     X1,RTN98    IF NOT OBJECT OF 1-BRANCH *IF* 
          BX7    0
          SA7    NOPATH      CLEAR NOPATH FLAG
 RTN98    EQ     PSN
 RTU      SPACE  4,8
**        RTU - COMPILE RETURN INSTRUCTIONS.
* 
*         CALLED IN A SUBROUTINE OR FUNCTION WHEN A *RETURN* OR *END* 
*         STATEMENT IS ENCOUNTERED TO COMPILE INSTRUCTIONS TO EXIT. 
* 
*         1.  *RETURN.* BSS 0 
*         2.  IF *FUNCTION* -- LOAD *VALUE.* INTO (X6/X7).
*         3.  RESTORE (A0). 
*         4.  FALL TO ENTRY/EXIT WORD.
* 
*         USES   ALL
*         CALLS  ALLOC
  
  
 RTU      SUBR               ENTRY/EXIT...
          SA2    RTNCNT 
          SA1    TT.PAR 
          ZR     X2,RTU2     IF NO MULTIPLE *RETURN*
  
**        IF ANY *RETURN* STATMENTS COMPILED JUMPS TO THE EXIT CODE, WE 
*                HAD BETTER DEFINE A LABEL (*CT.RETN*) THERE. 
  
          SB3    O=BSS
          SX4    CT.RETN
          BX5    X4 
          RJ     EMT         EMIT  (O=BSS, CT.RETN) 
  
**        IF THIS IS A *FUNCTION*, COMPILE CODE TO LOAD THE RESULT
*                REGISTER(S). 
*         ENTRY  (A1,X1) _ TT.PAR.
  
 RTU2     SA5    MOD
          MX0    -L.MODE
          BX4    -X0*X5      ISOLATE MODE 
          SA2    VALUE. 
          SBIT   X5,PFNC
          SB3    OPRETD 
          SB3    -B3
          PL     X5,RTU4     IF NOT A *FUNCTION*
          SBIT   X5,LONG/PFNC 
          SX6    X2+C.VAR 
          MI     X5,RTU3     IF DOUBLE-WORD RESULT
          SB3    OPRETS 
          SB3    -B3
 RTU3     LX6    P.2TAG 
          BX5    X6+X4
          =X4    0           1ST = DUMMY
          RJ     EMT         EMIT  (O=RETURN-VALUE, (VALUE.)) 
  
**        IF THIS SUBPROGRAM HAD ARGUMENTS, (A0) WAS SAVED AND CLOBBERED
*                WHEN IT WAS ENTERED.  RESTORATION CODE IS NEEDED.
*                ALSO, WE NOW DO THE ACTUAL ENTRY POINT DEFINITION NOW. 
*         ENTRY  (A1,X1) _ TT.PAR.
  
 RTU4     SA3    NARGS
          SA2    ENTRY. 
          SX4    X2+C.VAR 
          SB3    O=NTR
          ZR     X3,RTU5     IF NO ARGUMENTS
          SB3    O=RETN 
 RTU5     BX5    0
          SB6    X3 
          RJ     EMT         (O=ENTRY, (ENTRY.))
  
*         OUTPUT O=OTR TURPLE, IF NECESSARY 
  
          SA2    =XCO.ER
          ZR     X2,RTU55    IF NO OTR
          SB3    =XOTROP
          SB3    -B3
          SA5    ENTRY. 
          =X4    1           NO LABEL, NO LNT ENTRY 
          AX5    18          LINE NUMBER ONLY 
          LX5    P.TRC       POSITION FOR TURPLE
          RJ     EMT
  
 RTU55    BSS    0
  
          SB3    O=NTRX 
          ZR     B6,RTU8     IF NO ARGUMENTS
  
**        WHEN THERE WERE ARGUMENTS, AFOREMENTIONED SAVE (A0) CODE IS 
*                TO BE COMPILED.  WHAT BRAND DEPENDS ON OCCURRANCE OF 
*                *ENTRY* STATEMENTS.
*         ENTRY  (NTRCNT) = NUMBER OF *ENTRY* STATEMENTS IN THIS
*                SUBPROGRAM.
*                (A1,X1) _ TT.PAR.
  
          SA2    NTRCNT 
          SB3    O=NTRN 
          ZR     X2,RTU6     IF NO *ENTRY* STATMENTS
          SB3    O=NTRM 
 RTU6     BX4    0
          BX5    0
          RJ     EMT         EMIT  (SAVE (A0) CODE) 
  
 #FID     IFNE   .FID,0 
          SA2    =XCO.ID
          PL     X2,RTU7     IF FID CODE NOT NECESSARY
  
          SB3    =XO=NTRN1   SAVE-A1 SKELETON 
          RJ     EMT         EMIT SAVE-A1 TURPLE
 RTU7     BSS 
 #FID     ENDIF 
  
**        THAT IS ALL FOR THE PARSED FILE.  NOW THE VARIABLE DIMENSION
*                INITIALIZATION CODE WILL BE COMPILED (BY *FVD*).  THE
*                ONLY THING AFTER THAT IS TO JUMP TO THE BEGINNING OF 
*                THE ROUTINE (*CT.BEGIN*).  THE JUMP TYPE, HOWEVER, 
*                DEPENDS ON MULTIPLE ENTRY POINTS.  WE WILL ADD THE 
*                PROPER JUMP MACRO TO THE VAR-DIM TABLE.
  
          SA2    NTRCNT 
          SB3    O=NTRX 
          ZR     X2,RTU8     IF NO *ENTRY* STATEMENTS 
          SB3    O=NTRY 
  
**        IF THIS ROUTINE HAD NO ARGUMENTS, WE DECIDED EARILER TO COME
*                DIRECTLY DOWN HERE.
*         ENTRY  (B3) = ADDRESS OF JUMP MACRO.
  
 RTU8     SA1    T.VDIM 
          BX4    0
          =X5    0
          RJ     EMT         EMIT  (JUMP TO *CT.BEGIN*) 
          EQ     EXIT.
 GOT      SPACE  4,20 
**        GOT -  PROCESS "GO TO" STATEMENTS.
* 
*         *GOT* PROCESSES ALL FORMS OF *GO TO* STATEMENTS --
*                1. GO TO SN
*                2. GO TO I (SN1,SN2,.....SNN)     (NON-ASA)
*                   GO TO I,(SN1,SN2,.....SNN)
*                3. GO TO   (SN1,SN2,.....SNN),I
*                   GO TO   (SN1,SN2,.....SNN) I   (NON-ASA)
* 
*         ENTRY  B4 _ ELEMENT FOLLOWING *GO TO* 
*         EXIT   MASTER LOOP
  
  
          HEREIF GOTO 
  
          SA1    B4          POINTING TO 1ST ELEMENT AFTER *GOTO* 
          =X6    CR.GOTO
          ZR     X1,E.GO1    IF MISSING OBJECT OF GO TO - ERROR 
          SX2    X1-O.( 
          SA6    REFNUM      INDICATE FOR CROSS REFERENCE MAP.
          =X6    CR.VGOTO 
          =A3    B4+1 
          SA6    REFVAR 
          ZR     X2,GOT20    IF COMPUTED GO TO
          SB2    X1-O.VAR 
          NZ     B2,GOT5     IF NOT VARIABLE. 
          EQ     GOT10
 GOTON    EJECT  4,8
**        HERE IF SIMPLE TRANSFER TO STATEMENT NUMBER.
  
 GOT5     BX6    X1 
          NZ     X3,E.GO     IF NO *EOS* - ERROR
          =B2    M.SNLAB+M.SNREF
          RJ     ISN         GO IDENTIFY STATEMENT NUMBER 
          NG     X6,CPM      IF ERROR IN STATEMENT NUMBER 
          SA1    STN0R
          SA2    STN
          IX0    X1-X2
          NZ     X0,GOT6     IF NOT TRANSFER TO ITSELF
          WARN   E.GO7       WARNING
 GOT6     BX5    X6          SAVE TAG.
          SA1    INIF 
          =X6    1
          SA6    NOPATH      INICATE POSSIBLE NO-PATH.
          AX5    P.TAG
          SX6    0
          ZR     X1,GOT7     IF NO OBJECT OF AN *IF*
  
**        GO TO SN FOUND TO BE OJBECT OF A ONE BRANCH *IF* STATMENT.
* 
*         IN THIS CASE WE RESET THE GENERATED TAG CELL, SINCE THE TAG 
*         WILL NOT BE USED IN THE NEW JUMP MACRO.  NEXT WE REPLACE THE
*         IF JUMP MACRO PUT INTO THE PARSED FILE BY THE *IF* PROCESSOR
*         AND RESET IT TO A --
*                IF(L) 1,N  - WHERE *1* IS THE LABEL DEFINED BY THE 
*                             GO TO SN. 
*         NEXT WE CHECK IF THE *IF* WAS FOUND ON A *DO* TERMINATOR LINE 
*         IF SO WE EXIT TO PSN AND FINISH PROCESSING THE *DO* 
* 
*         (X5) = STATEMENT NUMBER TAG SHIFTED BY P.TAG
  
          SA6    NOPATH      CLEAR
          SA2    TG.PRO 
          SA6    A1          CLEAR *INIF* 
          SA3    =XFLOW 
          NZ     X3,PSN      IF NO PATH 
          SX6    X1-1 
          LX3    X5 
          SA4    TT.PAR 
          SA1    IFREL1 
          =X0    O.IF 
          LX1    P.JPAD 
          BX7    X1+X0
          SA1    TT=PAR 
          SA6    A2          RESET GENERATED TAG CELL. (TG.PRO) 
          IX0    X1+X4       LWA+1 OF PARSED FILE.
          IFNE   P.PTAGL,,1 
          AX3    P.PTAGL
          SA7    X0-L.TURP   RESET MACRO TO *IFL1N* 
          BX6    X3          STATEMENT TAG FOR JUMP 
          SA1    DTI
          SA6    X0-L.TURP+OR.2OP 
          NZ     X1,PSN      IF IN *DO* TERMINATION -- EXIT.. 
          SX6    1
 GOT7     SA6    IFSN        INDICATE INIF OR NOT.
          BX6    X5 
          SA6    GOTA        SAVE TAG.
          =X6    GOT7A       RETURN ADDRESS 
          SA6    HANGER 
          EQ     PSN         GET NEXT EXECUTABLE..
  
**        RETURN WITH NEXT EXECUTABLE IN *SB* AND NEXT ACTIVE LABEL 
*         IN *CSNTAG* IF ONE EXISTS.
* 
*         EVALUATE IF THE GO TO SN IS A TRANSFER TO THE NEXT EXEC.
*         IF SO IGNORE AND NOTE IT TO THE PROGRAMMER.  IF GO TO IS PART 
*         OF AN IF AND THE ABOVE IS NOT TRUE WE EXIT TO PSN.  IF NOT
*         OBJECT OF AN IF WE ADD O=GOTO MACRO TO PARSED FILE AND EXIT AS
*         ABOVE.
  
 GOT7A    SA2    GOTA        RESTORE TAG. 
          SA3    CSNTAG 
          BX0    X2-X3
          SA1    IFSN 
          NZ     X0,GOT7B    IF NOT SIMPLE JUMP TO NEXT STATEMENT.
          ZR     X1,E.GO2    IF NOT PROCESSING OBJECT OF AN IF. 
          NOTE   E.GO2A      IF RESULTS IN A TRANSFER TO NEXT LINE
          EQ     CUS.RET
  
**        HERE IF JUMP MUST BE COMPILED.
*         ADD *GOTON* SKELETON TO PARSED FILE.
*         (NOT-TRUE IF PART OF AN *IF*) 
  
 GOT7B    NZ     X1,CUS.RET  IF PART OF 1-BRANCH IF 
          RJ     MXP
          ALLOC  TT.PAR,L.TURP
          SA4    GOTA 
          SX5    O=GOTON
          LX7    X4 
          BX6    0
          =X1    O.GOTO 
          =A7    B7-L.TURP+OR.2OP 
          LX5    P.JPAD 
          =A6    A7-OR.2OP+OR.1OP 
          BX7    X5+X1       ADD IN OPERATOR
          SX6    X2-1 
          =A7    A6-OR.1OP+OR.OPR 
          SA6    CURST             RESET SQEEZE START PASTED *GOTO* 
          EQ     CUS.RET           RETURN TO FINISH PROCESSING HANGER 
 GOTOVR   EJECT  4,8
**        PROCESS ASSIGNED *GO TO*     GO TO VAR,(N,,,,,,,) 
*         WHERE VAR MUST BE A SIMPLE INTEGER VARIABLE.
  
 GOT10    RJ     TRV         TRANSLATE VARIABLE.
          SB7    X1-M.INT 
          ZR     B7,GOT10A   IF INTEGER VARIABLE
          WARN   =XE.GO1A    OBJECT OF GOTO NOT INTEGER 
 GOT10A   BX5    X2          PASS *2* TAG 
          =B4    B4+1 
          SA2    B4 
          SB7    X2-O.COMMA 
          ZR     B7,GOT10B   IF *,* 
          ANSI   E.GO5       NON-ANSI FORM
          EQ     GOT10C 
 GOT10B   =B4    B4+1 
          SA2    B4 
 GOT10C   SB7    X2-O.( 
          ZR     B7,GOT10E   IF *(* 
          SA3    X2+=XCHARMAP 
          MX0    L.CDPC 
          ZR     X3,GOT10D   IF *O.VAR* OR *O.CON*
          LX2    X3 
 GOT10D   BX6    X0*X2
          SA6    FILL.
          EQ     E.GO3
 GOT10E   =B4    B4+1 
 GOT11    SA1    B4 
          ZR     X1,PSN      MISSING RIGHT PAREN ALREADY DIAGNOSED
          BX6    X1 
          =B2    M.SNLAB+M.SNREF
          RJ     ISN         IDENTIFY STATEMENT NUMBER
          SA2    STN0R
          SA3    STN
          =A4    B4+1 
          IX2    X3-X2
          SB4    B4+2 
          SX3    X4-O.COMMA 
          NZ     X2,GOT12    IF NOT REFERENCE TO CURRENT LABEL
          WARN   E.GO8       STATEMENT CAN TRANSFER TO ITSELF - WARNING 
 GOT12    ZR     X3,GOT11    IF *,* 
          SB2    X3+O.COMMA-O.) 
          NZ     B2,E.GO     IF NOT *)* - ERROR...
          =A1    B4 
          ZR     X1,GOT13    IF NOTHING AFTER *)* 
          WARN   E.AC8       ILLEGAL CHAR AFTER RIGHT PAREN 
  
**        EMIT ASSIGNED GOTO TURPLE --
*                (OPR) = O=GOA
*                (OR.1OP) = (X5) = VARIABLE TAG FOR GO TO.
*                (OR.2OP) = (X5) =   -      -    -   -  -  (DUMMY)
  
 GOT13    BX6    X5 
          SA6    GOTA 
          RJ     MXP
          SA5    GOTA 
          ALLOC  TT.PAR,L.TURP
          SA3    GOASS
          BX7    X5 
          LX6    X5 
          =A7    B7-L.TURP+OR.2OP 
          =A6    A7-OR.2OP+OR.1OP 
          BX7    X3 
          =A7    A6-OR.1OP+OR.OPR 
          EQ     GOT80       CONTINUE 
 GOTO()   EJECT  4,8
*         PROCESS COMPUTED *GO TO*
  
 GOT20    =B6    1           PROCESS COMPUTED GO TO 
  
*         LOOP TO END OF PARAMETER LIST OF STATEMENT NUMBERS. 
  
 GOT21    SA1    B4+2 
          =X2    X1-O.COMMA 
          SB4    B4+2 
          =B6    B6+1 
          ZR     X2,GOT21    IF *,* 
          =X1    X1-O.) 
          NZ     X1,E.GO     IF NOT *)* - ERROR...
          SB4    B4+2 
          =A1    B4-1 
          =X1    X1-O.COMMA 
          ZR     X1,GOT23    IF *,* 
          ANSI   E.GO4       NON ANSI FORM. 
          =B4    B4-1 
 GOT23    SA1    GOTARM 
          BX7    0
          LX6    X1 
          SA7    ARGCOMA
          SA6    ARGMODE
          SX6    B6 
          SA6    GOTA        SAVE NUMBER OF BRANCHES
          RJ     MXP
          RJ     PAR         PARSE THE INDEX EXPRESSION 
  
          RJ     CAI         COMPILE INSTRUCTIONS 
  
**        CODE HAS NOW BEEN COMPILED TO SET (B7) TO THE CORRECT INDEX 
*                VALUE.  NEXT COMES THE INDEXED JUMP AND THE *ACGOER* 
*                CALL.
  
          SA1    TG.PRO 
          =X2    I.JP 
          =X6    X1+1        UPDATE PROGRAM TAG 
          LX2    P.LI12 
          =X7    -6 
          SA6    A1 
          BX4    X6 
          LX6    P.LTAG 
          BX3    -X7+X2 
          WCODE  X3+X6       COMPILE   JP   B6+TAG
          CBSS   X4          COMPILE TAG BSS 0
  
          TAGSEX S.ACGOR
          SA3    =XTRLINE    SET UP LINE NO. FOR TRACEBACK
          CRJ    MUST        COMPILE     RJT =XGOTOER.
  
          SA1    "SB.BOS" 
          SB4    X1+2 
  
*         BUILD JUMP CODE FOR COMPUTED *GO TO*
  
 GOT32    SA1    B4 
          =A2    B4-1 
          BX6    X1 
          SB7    X2-O.RP
          ZR     B7,GOT80    IF END OF STATEMENT LABEL LIST 
          =B2    M.SNLAB+M.SNREF
          RJ     ISN         IDENTIFY STATEMENT NUMBER
          MX7    L.TAG
          BX6    X7*X6       ISOLATE TAG
          SA1    STN0R
          SA2    STN
          =X7    I.EQ 
          BX7    X7+X6
          LX7    -L.LI12
          WCODE  X7          * EQ  N.TAG* 
          IX3    X2-X1
          NZ     X3,GOT42    IF NOT REFERENCE TO CURRENT LABEL
          WARN   E.GO8       STATEMENT CAN TRANSFER TO ITSELF - WARNING 
 GOT42    SB4    B4+2 
          EQ     GOT32       LOOP 
  
*         HERE IF *GO TO* WAS PROCESSED 
  
 GOT80    RJ     CIA         CLEAR ALL REGISTER ASSOCIATES
          =X6    1
          SA6    NOPATH      SET POSSIBLE NO-PATH INDICATOR 
          EQ     PSN         EXIT.. 
 GOTA     DATA   0           OLD STATEMENT NUMBER.
 STP      SPACE  4
**        STP -  PROCESS "STOP" STATEMENT.
*         EXIT   *SPR* WITH (B3) = *STOP* INDICATOR.
  
  
          HEREIF STOP 
  
          =B6    S=STOP      INDICATE *STOP*
          RJ     SPR         COMPILE TERMINATING INSTRUCTIONS 
          =X7    I.EQ 
          BX7    X6+X7
          LX7    -L.LI12
          WCODE  X7          COMPILE  *EQ =X_ROUTINE.*
          SA1    INIF 
          NZ     X1,PSN      IF OBJECT OF 1-BRANCH IF 
          =X6    1
          SA6    NOPATH      INDICATE NO-PATH.
          EQ     PSN         EXIT.. 
 SUB      SPACE  4,8
**        SUB -  PROCESS "SUBROUTINE" STATEMENT.
*         EXIT   TO MASTER LOOP.
*         CALLS  1.  DCM = ASSEMBLE THE PROGRAM NAME. 
*                2.  PSA = PROCESS ANY FORMAL PARAMETER LIST. 
  
  
          HEREIF SUBROUTINE 
  
          SX6    M.PSUB      SET SUBPROGRAM MODE
          SA4    =10HSUBROUTINE 
          RJ     DCM         DISPLAY COMPILING MESSAGE
          RJ     PSA         PROCESS SUBPROGRAM ARGUMENTS 
          EQ     PSP         EXIT 
 SER      SPACE  4,8
**        SER -  COMPILE *END* INSTRUCTIONS.
* 
*         CALLED BY *END* AND *RETURN* STATEMENTS, IF IN MAIN PROGRAM.
* 
*         COMPILES LOAD OF (X1) = TRACE., FOLLOWED BY *EQ* JUMP TO
*         =XEND.
* 
*         CALLS  DRITE, TAGSEX, WCODE.
  
  
 SER      SUBR               ENTRY/EXIT...
          TAGSEX S.END
          AX6    P.TAG
          SA1    TT.PAR 
          BX5    X6 
          LX4    X6 
          SB3    O=QUITP
          RJ     EMT         EMIT  (O=END, =XEND.)
          EQ     EXIT.
 EMT      SPACE  4,8
**        EMT -  EMIT *TURPLE* TO DESIGNATED TABLE. 
* 
*         ENTRY  (A1,X1) = TABLE *TURPLE* IS TO BE ADDED TO.
*                (B3) .GE. 0 = MACRO ADDRESS. 
*                     .LT. 0 = COMPLEMENT OF ADDRESS OF *SETOP* WORD. 
*                (X4) = (1OP).
*                (X5) = (2OP).
*         EXIT   (A1,X1) PRESERVED. 
*         USES   A2,A3,A6,A7  B2,B7  X0,X2,X3,X6,X7 
*         CALLS  ALLOC
  
  
 EMT      SUBR               ENTRY/EXIT...
          ALLOC  A1,L.TURP
          SA3    OPDUM
          SX2    B3 
          BX6    X5 
          LX7    X4 
          =A6    B7-1        (2OP)
          LX2    P.JPAD 
          =A7    A6-1        (1OP)
          PL     B3,EMT2     IF (B3) IS MACRO ADDRESS 
          SA3    -B3
          BX2    0
 EMT2     BX6    X3+X2
          =A6    A7-1        (OPR)
          EQ     EXIT.
 SPR      SPACE  4,30 
**        SPR -  COMPILE TERMINATING/PAUSING INSTRUCTIONS.
* 
*         CALLED BY *STOP* AND *PAUSE*. 
* 
*         ENTRY  (B6)  0 IF PAUSE 
*                     +1 IF STOP
*                (B4) _ NEXT *SB* ENTRY AFTER KEYWORD 
*         EXIT   INSTRUCTIONS COMPILED TO LOAD PROPER ARGUMENT. 
*                (X6) = TAG OF ROUTINE TO JUMP TO.
* 
*         THE FIRST ELEMENT AFTER THE KEYWORD MAY BE -- 
*                (A)  EMPTY 
*                (B)  A STRING OF AT MOST 5 OCTAL DIGITS. 
*                (C)  CHARACTER STRING SURROUNDED BY QUOTES (").
  
**        PREPARE JUMP TAG FOR APPROPRIATE ROUTINE. 
  
  
 SPR60    TAGSEX B6+S.PAUSE 
          MX0    L.TAG
          BX6    X0*X6       ISOLATE TAG
  
 SPR      SUBR   0
  
 #FID     IFEQ   .FID,0 
          SA1    B4 
 #FID     ELSE
          SX6    B4 
          SX7    B6 
          SA6    SPRA 
          =A7    A6+1 
          RJ     =XCAI       DUMP PARSE FILE TO LONG FILE 
          SA1    SPRA 
          SB4    X1          RESTORE B4 *** ALLOC DOES NOT MOVE *SB* ***
          =A2    A1+1 
          SA1    X1          (B4) 
          SB6    X2 
 #FID     ENDIF 
  
          ZR     X1,SPR17    IF ARGUMENT NOT PRESENT
          =A2    B4+1 
          =B2    X1-O.HOLL
          =B3    X1-O.CONS
          ZR     X2,SPR13    IF *EOS* 
          WARN   E.XC        ** EXTRA TRAIL GUNK IGNORED ** 
 SPR13    ZR     B2,SPR20    IF HOLLERITH CONSTANT. 
          NZ     B3,SPR15    IF NO DIGITS 
  
**        HERE IF SIMPLE ARGUMENT.
  
          SA1    B4 
          MX0    7*CHAR 
          BX1    X0*X1       STRIP OFF TYPE 
          MX0    5*CHAR 
          BX6    -X0*X1 
          ZR     X6,SPR14 
          WARN   =XE.SPR2 
 SPR14    =X7    M.UNIV 
          BX5    X0*X1
          SA3    B4-1 
          RJ     =XOCT
          ZR     X2,SPR14A   IF ALL OCTAL DIGITS
          ANSI   =XE.SPR5    NON OCTAL DIGITS 
 SPR14A   LX6    X5 
          RJ     NCS         SCAN/ENTER INTO CONSTANT TABLE.
          EQ     SPR50       CONTINUE.
  
**        ILLEGAL ARGUMENT -- FLAG AND TREAT AS NIL.
  
 SPR15    WARN   E.SPR
  
**        NO ARGUMENT CASE -- COMPILE CLEAR OF X1.
  
 SPR17    =X5    M.SHORT
          RJ     =XESC       PUT ZERO  IN CONSTANTS TABLE 
          BX6    X5          CONSTANT TAG 
          EQ     SPR50
  
  
**        HERE IF HOLLERITH CONSTANT FORM 
  
 SPR20    ANSI   =XE.SPR4 
          SA1    B4 
          BX6    X1 
          AX1    P.LCON 
          MX0    -L.LCON
          BX1    -X0*X1 
          SB2    X1-7 
          MI     B2,SPR50    IF .LE. 7 WORD CONSTANT
          NOTE   E.SPR1 
  
**        COMPILE LOAD OF ARGUMENT
*                (X6) = TAG FOR ARGUMENT
  
 SPR50    MX0    L.TAG
          SX1    SA=BKS3+10B
          BX6    X0*X6
          BX7    X1+X6
          LX7    P.LI12 
          WCODE  X7,SPR60    COMPILE INSTRUCTION AND EXIT.. 
  
  
 #FID     IFNE   .FID,0,1 
 SPRA     BSS    2           SAVE B4 AND B6 
          LIST D
          END 
