*DECK     KEY - KEYWORD STATEMENT TRANSLATION.
          IDENT  KEY
 KEY      SECT   (KEYWORD STATEMENT TRANSLATION.) 
 KEY      SPACE  4
*         IN ALLOC
          EXT    ADW,ALC
  
*         IN FEC
          EXT    ARGCOMA,ARGMODE,ASK,ASL,ASSTAG,CALLTAG,CCT,CSB,CSLTAG
          EXT    CT1,CUS.RET,DTI,ERT,ESTACK,ESY,FEC=STF,FEC.RIF,FEC.RTF 
          EXT    FEC.RTN,FLOW,HANGER,IFLEVEL,NOPATH,OCT,OIL,REFLIN
          EXT    REFNUM,REFVAR,RTNCNT,SCT,SSY,STAGE,STY,TLV,TRV,TSX 
          EXT    WANFP
  
  
*         IN FERRS
          EXT    E.ANS,E.ANS3,E.AS1,E.AS2,E.AS3,E.AS4,E.AS5,E.CL1,E.CL2 
          EXT    E.CL3,E.CT,E.CT1,E.EN,E.EN1,E.EN2,E.EN3,E.EN4,E.EN5
          EXT    E.EN6,E.EN7,E.EN8,E.FM,E.GO,E.GO1,E.GO2,E.GO3,E.GO4
          EXT    E.GO5,E.GO6,E.GO7,E.GO8,E.GO9,E.AS7,CLASS,FILL.2 
          EXT    E.IF00,E.IF01,E.IF02,E.IF03,E.IF04,E.IF05,E.IF06,E.IF07
          EXT    E.IF09,E.IF10,E.IF11,E.IF12,E.IF13,E.IF14,E.IF15,E.MDO 
          EXT    E.ME1,E.MR2,E.MR3,E.NL,E.NL1,E.NL2,E.NL3,E.NL4,E.OV3 
          EXT    E.SPR1,E.SPR2,E.SPR4,E.SPR5,FILL.,FILL.3,MOD.DPC 
          EXT    E.NL5
  
*         IN HEADER 
          EXT    PSA,WSA
  
*         IN IDP
          EXT    IDP= 
  
*         IN LABEL
          EXT    ALU,FBS,ISL,PDA,PSL,RBE,STL0R
  
*         IN LEX
          EXT    CST,SB=CONT,TB=LABL,TB=LABR,TB=TYPE,TB=1ST 
  
*         IN PAR
          EXT    CALLARM,CMR,CURST,C=CERR,CF=AC,EAL,ECC,EMT,GAPOP,IFARM 
          EXT    NOOPP,OPDUM,PAR,PJXARM,POP.STD,VEL 
  
*         IN PEM
          EXT    ANSI=,PDM
  
*         IN PUC
          EXT    CONZER,CONZERI,LJS,MOD,NOLIST,N.ARP,N.FP,N.GL,S=ENTRY
          EXT    S=EXIT,S=TRACE,S=VALUE,T=ARG,T=BLST,T=NLST,T=PAR 
          EXT    T.ARG,T.ASG,T.BLST,T.DIM,T.ENT,T.NLST,T.PAR
          EXT    T.SYM,WO.LOA,WO.LOR,T.CON,T.SLARG,T=SLARG
  
*         IN QSKEL/FSKEL
          EXT    F.IFN,F.IFS,OM=IF,V=AGOTO,V=ASSGN,V=BSS,V=CGOTO,V=ENTR 
          EXT    V=GOTO,V=IFF,V=IFT,V=I111,V=JGOTO,V=NOOP,V=PAUS,V=RET
          EXT    V=RGOTO,V=RTNK,V=STOP,V=SUBR 
  
*         IN UTILITY
          EXT    MVE=,ZTB 
 AGN      SPACE  4,20 
**        AGN -  PROCESS "ASSIGN" STATEMENT.
  
  
          HEREIF ASSIGN 
          SA4    B4 
          SB7    X4-O.CONS
          NZ     B7,E.AS4    IF NO LABEL
  
          CALL   ASL         ADJUST STATEMENT LABEL 
          =X6    CR.STR 
          =X7    CR.AGN 
          =X2    0           NO REFERENCE BITS FOR ASSIGNED LABEL 
          SA6    REFVAR 
          BX6    X1 
          SA7    REFNUM 
          CALL   ISL         IDENTIFY STATEMENT LABEL 
          MI     X6,PSL      IF ERROR IN STATEMENT LABEL
          SA1    T.SYM
          MX2    -TP.ORDL 
          LX6    -TP.ORDP 
          BX2    -X2*X6      EXTRACT SYMORD 
          SB7    X2 
          LX2    1
          SB7    X2+B7       CONVERT TO INDEX 
          =B7    B7+WB.W
          SA1    X1+B7       X1 = *WB* OF LABEL 
          CLAS=  X2,WB,(ACT)
          BX7    X2+X1       INDICATE LABEL IS ACTIVE 
          SA7    A1          UPDATE *WB*
          LX6    TP.ORDP     RESTORE X6 
          SA1    B4 
          CLAS=  X2,TP,(ADDR) 
          BX6    X6+X2       MERGE IN TP.ADDR BIT 
          SA6    ASSTAG      SAVE LABEL TAG 
          SB7    X1-O.COMMA 
          NZ     B7,AGN2     IF NO COMMA
          =B4    B4+1 
          WARN   E.AS5
  
 AGN2     SA5    =0LTO
          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     SX5    1+=0 
          SX3    2*CHAR-1 
          LX3    KW.LENP
          BX5    X3+X5       PSEUDO *SATTR* FOR ASK 
          CALL   ASK         ADJUST STATEMENT KEYWORD *TO*
          SB2    0           ENTRY NOT ALLOWED
          CALL   TRV         TRANSLATE THE VARIABLE 
          MI     X0,PSL      IF TRV DETECTED ERROR
          CLAS=  X4,WB,(SFA)
          CLAS=  X3,WB,(VAR,DEF,AGN)
          BX7    X3+X2
          BX7    -X4*X7      CLEAR WB.SFA (IF PRESENT)
          SA7    A2          UPDATE SYMTAB (WB) AS *DEFINED*
          =A3    B4+1 
          MX7    -WB.MODEL
          BX5    X6          REMEMBER (X5) = PASS 1 TAG-FORM
          LX2    -WB.MODEP
          BX1    -X7*X2      EXTRACT (X1) = MODE OF SYMBOL
          SB5    B7          SAVE *WB* INDEX FOR LATER EQUIVALENCE TEST 
          =B4    B4+1        BUMP B4 FOR POSSIBLE ERROR MESSAGE 
          SB7    X1-M.INT 
          ZR     B7,AGN5     IF INTEGER VARIABLE
          WARN   E.AS3
  
 AGN5     ZR     X3,AGN6     IF NEXT ELEMENT *EOS*
          ERRNZ  O.EOS
          WARN   E.AS1
  
 AGN6     LX2    WB.MODEP-WB.ARYP-1 
          PL     X2,AGN7     IF NOT AN ARRAY
          SA4    CLASS+WB.ARYP
          BX7    X4 
          SA7    FILL.2 
          =A4    B4-1        X4 = VAR TOKEN 
          MX7    WA.SYML
          BX7    X7*X4       X7 = 0LSYMBOL
          SA7    FILL.
          FATAL  E.AS7       ** CONFLICT - VAR PREVIOUSLY USED AS ARRAY 
  
 AGN7     SA4    ASSTAG      (P1) = STATEMENT LABEL 
*         =X5    X5          (P2) = VARIABLE
          EMIT   V=ASSGN,2ND
  
*                (B5) = *WB* INDEX OF VARIABLE
  
          SA1    T.SYM
          SA2    X1+B5       FETCH *WB* ENTRY 
          SBIT   X2,WB.EQVP 
          PL     X2,AGN8     IF NOT EQUIVALENCED
          =A1    A2-WB.W+WC.W 
          LX2    WB.EQVL+WB.EQVP
          MX0    WB.BASEL 
          HX2    WB.BASE
          BX2    X0*X2       ISOLATE BASE MEMBER ORDINAL
          LX2    WB.BASEL 
          HX1    WC.RA
          AX1    -WC.RAL     ISOLATE RELATIVE ADDRESS (BIAS)
          LX2    AG.ORDP
          LX1    AG.BIASP 
          BX1    X1+X2
          EQ     AGN9 
  
 AGN8     MX0    TP.ORBIL 
          HX5    TP.ORBI
          BX1    X0*X5       ISOLATE (X1) = ORBI OF VARIABLE
          LX1    -TP.ORBIP+AG.ORBIP 
 AGN9     HX4    TP.ORD 
          AX4    -TP.ORDL    ISOLATE (X4) = SYMORD OF LABEL 
          LX4    AG.LABP
          BX6    X1+X4       T.ASG ENTRY
          SCAN   T.ASG,SCT
          PL     B7,PSL      IF ALREADY IN TABLE
          ADDWD  T.ASG
          EQ     PSL         EXIT...
 BRK      SPACE  4,10 
**        BRK - PROCESS *BREAK* STMT. 
  
  
 .T       IFEQ   TEST,ON
          HEREIF BREAK
  
 FTNBREAK BREAK 
          EQ     FEC.RTN
 .T       ENDIF 
 CLL      SPACE  4,20 
**        CLL -  PROCESS "CALL" STATEMENT.
  
  
          HEREIF CALL 
  
          SHRINK T=SLARG,0
          SHRINK T=ARG,0
          SX7    CR.SUB 
          SA7    REFVAR      INITIALIZE REFERENCE TYPE
          SA1    B4          LOAD SUBROUTINE NAME 
          MX0    TB.TOCL
          SB7    X1-O.VAR 
          ERRNZ  18-TB.TOTL 
          HX1    TB.TOC 
          BX6    X0*X1
          SA6    FILL.
          SA6    CALLSYM
          NZ     B7,E.CL2    IF SUBROUTINE NAME MISSING 
          CALL   SSY         SCAN SYMBOL TABLE
          MI     B7,CLL24    IF NAME NOT PREVIOUSLY ENCOUNTERED 
          CLAS=  X3,WB,(VAR,ENT,INTF,GENF,PARM,NLST)
          SX1    WB.SUBP
          CALL   CCT         CHECK FOR CONFLICTING TYPE 
          MI     X0,PSL      IF CLASS CONFLICT
          CLAS=  X3,WB,(NVAR,EXT,SUB) 
          SBIT   X2,WB.FUNP 
          PL     X2,CLL22    IF NOT A FUNCTION
          MX3    0
          WARN   E.CL3       FUNCTION USED AS SUBROUTINE
  
 CLL22    SBIT   X2,WB.TYPP/WB.FUNP 
          PL     X2,CLL23    IF NOT TYPED 
          WARN   E.CL4       **SUBROUTINE APPEARED IN TYPE DECLARATION
  
 CLL23    LX2    1+WB.TYPP   RESTORE (X2) = SYMTAB (WB.) ENTRY
          BX7    X3+X2
          SA7    A2+         UPDATE SYMBOL ATTRIBUTES 
          EQ     CLL30
  
 CLL24    CLAS=  X3,WB,(NVAR,EXT,SUB) 
          BX7    X3 
          MX2    0           *WC* 
          ADSYM  A1          ENTER ROUTINE NAME IN SYMTAB 
  
**        ROUTINE TO CALL IS NOW IN THE SYMTAB. 
*                (X0) = SYMORD. 
  
 CLL30    BX5    X0 
          LX0    XR.TAGP
          ADDREF X0,CR.SUB
          BX0    X5 
          CALL   CT1         CONSTRUCT (TP) FORM OPERAND
          SA2    T=BLST 
          ZR     X2,CLL33    IF NO BLOCK STRUCTURES 
          CLAS=  X0,WB,(DLER)  LOOP HAS EXTERNAL REFERENCE
          CALL   PDA         PROPOGATE DO LOOP ATTRIBUTES 
 CLL33    MX7    0
          SA6    CALLTAG     SAVE OPERAND OF ROUTINE TO CALL
          =A1    B4+1 
          SB2    X1-O.VAR 
          SA7    CLLA        INDICATE NO LABEL PARAMETERS 
          NZ     B2,CLL35    IF NOT LONG NAME 
          CALL   TLV         TRUNCATE NAME
          =A1    B4+1 
 CLL35    SB2    X1-O.LP
          NZ     B2,CLL60    IF NO LPAREN -- NO PARAMETER LIST
          =B4    B4+1        POINT TO *(* 
          =X6    O.SLP
          SA6    A1          SET DUMMY *(* FOR PARSER 
          =A1    B4+1 
          SB7    X1-O.RP
          =A1    A1+1 
          ZR     B7,CLL60    IF EXPLICIT NULL PARAMETER LIST
          SA1    CALLARM
 .T       IFEQ   TEST,ON
          SA2    T=ARG
          NZ     X2,"BLOWUP" IF GARBAGE LEFT IN (T.ARG) 
 .T       ENDIF 
          BX6    X1 
          MX7    0           ARGCOMA = 0
          SA7    ARGCOMA
          SA6    ARGMODE
          CALL   PAR         PARSE / EMIT PARAMETER LIST
          SA5    CF=AC       (2OP) = NUMBER OF ARGUMENTS
          NO
          LX5    TP.BIASP 
  
*         HERE WHEN ALL ARGUMENTS HAVE BEEN PROCESSED.
*         EMIT RETURN JUMP TO THE EXTERNAL, 
*         EMIT INDEXED JUMP TO ALTERNATE RETURN LABELS, AND 
*         EXIT TO FRONT END CONTROLLER. 
*                (X5) = NUMBER OF ARGS IN THIS CALL, IN BIAS FIELD. 
  
 CLL40    SA4    CALLTAG
          EMIT   V=SUBR      (CALLTAG, NARGS) 
          SA3    CLLA 
          SA2    CONZERI
          ZR     X3,CLL48    IF NO LABELS IN PARAMETER LIST 
          SA1    A3+B1
          LX3    TP.BIASP 
          LX1    TP.BIASP 
          BX5    X3+X2       (2OP) = NUMBER OF LABEL ARGS 
          BX4    X1+X2       (1OP) = NUMBER OF NORMAL ARGS
          EMIT   V=RGOTO,BOTH 
          SA4    CLLC        (3OP) = GL 
          RJ     EGL         EMIT GENERATED LABEL 
  
 CLL48    SA1    T=PAR
          SX6    X1-1        INHIBIT SQUEEZE ACROSS CALL
          SA6    CURST
          EQ     PSL         EXIT...
  
  
*         HERE IF PARAMETER LIST OMITTED. 
  
 CLL60    ZR     X1,CLL62    IF EOS 
          FATAL  E.CL1       ** MISSING LPAREN AT BEGINNING OF PARM LIST
 CLL62    SA4    CALLTAG
          MX7    0           ARGCOUNT = 0 
          CALL   VEL         VALIDATE EXTERNAL LIST 
          MX5    0           (2OP) = ARGCOUNT 
          EQ     CLL40
  
 CLLA     BSS    1           NUMBER OF LABEL ARGS 
 CLLB     BSS    1           NUMBER OF NORMAL ARGS
 CLLC     BSS    1           GL FOR LABEL RETURN ARGS 
 CALLSYM  EQU    CLLB        NAME OF SUBROUTINE 
 CRL      SPACE  4,20 
**        CRL - PROCESS CALL STATEMENT ALTERNATE RETURN LABELS. 
* 
*         ENTRY  (A2,X2) = NL = (T=ARG)        */ NUMBER OF LABEL ARGS
*                (CF=AC) = NA                  */ TOTAL ARG COUNT 
*                (T.ARG) = NORMAL ARGUMENTS.
*                (T.SLARG) = ALTERNATE RETURN LABELS. 
* 
*         EXIT   (CF=AC) = NA + 1              */ TO ACCOUNT FOR THE GL 
*                (CLLA) = NL. 
*                (CLLB) = NA - NL              */ NUMBER OF NORMAL ARGS 
*                (CLLC) = GL OPERAND. 
*                ALL ARGS ON T.ARG. 
*                RETURN GL ON T.ARG BETWEEN NORMAL AND LABEL ARGS.
* 
*         USES   A1-4,A6-7   X0-4,X6-7  B2-3,7. 
*         CALLS  MOVE.
  
  
 CRL      SUBR   =           ENTRY/EXIT...
          SA3    CF=AC
          BX6    X2          (CLLA) = NL
          IX7    X3-X2       (CLLB) = NA - NL 
          SA4    N.GL 
          SA6    CLLA 
          =A7    A6-CLLA+CLLB 
          SX7    X3+B1       (CF=AC) = NA + 1 
          SA7    A3 
          SX7    X4+B1       ADVANCE GL COUNT 
          CLAS=  X1,TP,(GL) 
          LX4    TP.ORDP
          BX6    X4+X1       CONSTRUCT GL FOR RETURN
          SA7    A4 
          SA6    CLLC 
          ADDWD  T.ARG       STACK RETURN GL
          SA5    T=SLARG     X5 = NUMBER OF ALTERNATE RETURNS 
          BX4    X2          SAVE OLD T.ARG LENGTH
          ALLOC  A1,X5
          IX3    X1+X4       X3 = DESTINATION OF MOVE 
          SA2    T.SLARG     X2 = SOURCE
          MOVE   X5,X2,X3 
          SHRINK T=SLARG,0   SET (T.SLARG) EMPTY
          EQ     EXIT.
 CON      SPACE  4,10 
**        CON -  PROCESS "CONTINUE" STATEMENT.
* 
*         EXIT   TO FRONT END CONTROLLER. 
  
  
          HEREIF CONTINUE 
  
          =A2    B4 
          SA4    TB=LABR
          ZR     X2,CON2     IF EOS 
          ERRNZ  O.EOS
          WARN   E.CT1
 CON2     SA2    INIF 
          ZR     X2,CON4     IF *CONTINUE* NOT OBJECT OF *IF* 
          TRIV   E.GO5       IF RESULTS IN A TRANSFER TO NEXT LINE
          EQ     PSL         EXIT...
  
 CON4     ZR     X4,E.CT     IF NO STATEMENT LABEL
          EQ     PSL         EXIT...
 END      SPACE  4,20 
**        END - PROCESS *END* STATEMENT.
* 
*         EXIT   TO FRONT END CONTROLLER *FEC*. 
  
  
          HEREIF END
  
          SA1    SB=CONT
          NZ     X1,E.OV3    IF *END* NOT ON ONE LINE 
  
 END23    BSSENT 0           RETURN FROM ERROR PROCESSOR (MISSING END)
  
*         HEREIF EOS
  
          SA1    NOLIST 
          SA3    WO.LOA 
          SA4    WO.LOR 
          MI     X1,END20    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 ATTRIBUTES* 
          SA6    A4          SET TO *NO REFERENCE MAP*
  
 END20    SA1    B4 
          ZR     X1,END26    IF END OF STATEMENT
          ERRNZ  O.EOS
          WARN   E.ME1
  
 END26    SA5    MOD
          HX5    MO.BLK 
          MI     X5,END90    IF BLOCKDATA, FINISHED 
          SA4    FLOW 
          LX5    MO.BLKP-MO.PROP
          PL     X5,END60    IF NOT MAIN PROGRAM
          NZ     X4,END80    IF NO FLOW INTO END LINE 
          RJ     SER         COMPILE END INSTRUCTIONS 
          EQ     END80
  
 END60    BSS 
 .T       IFEQ   TEST,ON
          SA1    MOD
          CLAS=  X6,MO,(FUN,SUB)
          BX0    X6*X1
          ZR     X0,"BLOWUP"  IF NOT PROCEDURE SUBPROGRAM 
 .T       ENDIF 
          NZ     X4,END74    IF NO FLOW INTO END LINE 
          MX4    0
          BX5    0
          EMIT   V=RET
  
 END74    SA1    N.FP 
          ZR     X1,END80    IF NO FORMAL PARAMETERS
          CALL   WSA         WRAP-UP SUBPROGRAM ARGUMENTS 
  
 END80    RJ     MND         MATERIALIZE NAMELIST DIMENSIONS
 END90    EQ     FEC.RTF     RETURN TO CONTROLLER...
 ENT      SPACE  4,10 
**        ENT -  TRANSLATE "ENTRY" STATEMENT. 
* 
*         EXIT   TO FRONT END CONTROLLER. 
  
  
          HEREIF ENTRY
  
          SA2    MOD
          SBIT   X2,MO.PROP 
          MI     X2,E.EN1    IF IN PROGRAM
          BX6    0
          SA6    NOPATH      RESET STATEMENT-NO.-REQD .FLAG 
          SA1    STAGE
          SX2    FEC=STF
          IX1    X1-X2
          MI     X1,ENT1     IF IN DECLARATIVE PROCESSING 
          SA2    T=BLST 
          NZ     X2,E.EN2    IF INSIDE A BLOCK STRUCTURE
  
 ENT1     SA2    B4+
          ZR     X2,E.EN3    IF *EOS* 
          SB7    X2-O.VAR 
          NZ     B7,E.EN4    IF NOT VARIABLE
          MX0    TB.TOCL
          BX6    X0*X2
          SA6    FILL.
          SA6    ENTA        SAVE FOR T.ENT 
          CALL   SSY         SCAN SYMBOL TABLE
          SA3    MOD
          CLAS=  X5,WB,(NVAR,DEF,ENT,MAT) 
          HX3    MO.FUN 
          MI     B7,ENT20    IF NOT IN SYMTAB 
          SB7    E.EN5
          PL     X3,ENT80    IF NOT COMPILING A FUNCTION
          CLAS=  X4,WB,(NVAR,VAR,FP)
          BX4    X4*X2
          SB7    E.EN 
          NZ     X4,ENT80    IF PRIOR CONFLICTING REFERENCE 
          BX5    X2+X5       MERGE ENTRY BITS 
          EQ     ENT40
  
*         HERE IF NOT IN SYMTAB 
*                (X3) = (MOD) [MO.FUN EXPOSED]
  
 ENT20    MI     X3,ENT21    IF FUNCTION
          =X7    0
          MX2    0
          EQ     ENT22
  
 ENT21    CALL   STY         SET IMPLICIT TYPE [FUNCTION ENTRY] 
          BX7    X1          DEFAULT (WB.) = TYPE ONLY
  
 ENT22    ADSYM  T.SYM       ENTRY NAME 
  
*         NAME IS IN SYMTAB.  CLASS DOES NOT CONFLICT.
*                (X0) = SYMORD. 
*                (A2, X2) = CURRENT SYMTAB (WB.). 
*                (X5) = (WB.) ATTRIBUTES FOR ENTRY POINT. 
  
 ENT40    SA3    MOD
          RJ     CEM         CHECK ENTRY POINT MODE 
          NZ     B7,ENT80    IF MODE CONFLICT 
          BX6    X5+X2
          SA6    A2          MARK AS ENTRY POINT
          SA1    S=VALUE
          MX4    -WB.MODEL
          LX2    -WB.MODEP
          BX2    -X4*X2      ISOLATE MODE OF THIS ENTRY 
          IX1    X1+X2       X1 = SYMORD OF PROPER VALUE. SYMBOL
          SB3    X1 
          LX1    1
          SB3    X1+B3       CONVERT TO INDEX 
          SA1    T.SYM
          =B3    B3+WB.W
          SA1    X1+B3       *WB* 
          LDBIT  X5,WB.MDFP 
          BX6    X1+X5
          SA6    A1          SET *DEFINITION REQUIRED* FLAG 
          SA1    ENTA 
          BX6    X0+X1       (T.ENT) ENTRY = NAME AND SYMORD
          SX5    X0 
          SB5    B7+         SAVE WB INDEX
          ADDWD  T.ENT
          LX4    X5 
          LX4    TP.ORDP
          MX5    0
          EMIT   V=ENTR      (ENTRY-POINT-NAME,0) 
          LX4    -TP.ORDP    (X4) = SYMORD OF ENTRY NAME
          BX6    X4 
          EQ     ENT90
  
  
*         HERE FOR ERRORS.  DO NOT MARK THE NAME AS AN ENTRY. 
*                (B7) = DIAGNOSTIC. 
*                (X0) = SYMORD. 
*                (A2, X2) = CURRENT SYMTAB ENTRY. 
  
 ENT80    FATAL  B7 
          CLAS=  X7,WB,(VAR)
          BX6    X0          SET SYMORD FOR XREF
          BX7    X2+X7
          MX4    0           INDICATE ERROR 
          SA7    A2          MARK SYMBOL AS VARIABLE INSTEAD OF ENTRY 
  
  
*         HERE TO FINISH ENTRY SEMANTICS, AND ARGLIST.
*                (X4) .NZ. =  SYMORD OF ENTRY NAME. 
*                     .ZR. IF ERROR.
*                (X6) = SYMORD FOR CROSS-REF. 
  
 ENT90    =B4    B4+1 
          LX6    XR.TAGP
          MX7    0
          SA7    FLOW        INDICATE *FLOW* INTO NEXT STMT 
          SA1    WANFP
          SA7    A1          AVOID SETTING WA.NFP 
          BX7    X1 
          SA7    ENTA        PRESERVE OLD VALUE OF CELL 
          ADDREF X6,CR.DEF
          CALL   PSA         PROCESS SUBPROGRAM ARGLIST 
          SA1    ENTA 
          BX7    X1 
          SA7    WANFP       RESTORE OLD VALUE OF CELL
          CALL   OIL         ENTRY BREAKS THE SEQUENCE
          EQ     PSL         EXIT.. 
  
 ENTA     BSS    1
 NAM      SPACE  4,20 
**        NAM - TRANSLATE "NAMELIST" GROUP SPECIFICATION. 
* 
*         TRANSLATES NAMELIST DECLARATIONS INTO (T.NLST), IN A FORM 
*         PRESCRIBED BY THE GID.
* 
*         EXIT   TO FRONT END CONTROLLER. 
* 
*         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 T.FMT ENTRY TO BE MADE FOR THIS GROUP. 
  
  
 NAM1     SETMEM NAMB,2      CLEAR WORKING BUFFER 
          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.NL     IF SYNTAX ERROR
          ZR     X2,E.MR2    IF *EOS* - ERROR 
          MX0    WA.SYML
          BX6    X0*X2
          =B7    X2-O.VAR 
          NZ     B7,E.NL2    IF NO LETTER 
          SB7    X3-O.VAR 
          NZ     B7,NAM1.5   IF NOT LONG NAME 
          CALL   TLV         TRUNCATE NAME
          =A3    B4+1 
  
 NAM1.5   SX4    X3-O.SLASH 
          NZ     X4,E.NL1    IF NO */* AFTER NAME 
          CALL   SSY         SEARCH FOR SYMBOL
          PL     B7,E.NL3    IF ALREADY DEFINED 
          SA3    T=NLST 
          CLAS=  X4,WB,(NVAR,NLST,DEF)
          BX7    X3 
          LX3    WB.PNTP
          SA7    NAMA        INITIALIZE START INDEX 
          =B4    B4+2        ADVANCE B4 TO FIRST VARIABLE IN LIST 
          BX7    X3+X4
          MX2    0           *WB* 
          ADSYM  A1 
          SX6    X0 
          SB7    NG.GROPP 
          BX1    0           CLEAR MEMBER COUNT 
          LX6    NG.GROPP 
          PX7    X1,B7
          SA6    NAMB+1      INITIALIZE ACCUMULATOR 
          SA7    A6-B1
          SA1    T=NLST 
          BX6    X1 
          SA6    NAMC        T.NLST SAVE FOR ERROR RECOVERY 
          SA1    WO.LOR 
          PL     X1,NAM2     IF NO CROSS REFERENCE SELECTED 
          SX6    X0 
          SX1    CR.DEF 
          LX6    XR.TAGP     CONSTRUCT XREF TAG 
          ADDREF X6,X1
  
  
**        NAM2 - PROCESS EACH ITEM IN THE GROUP.
*                (B4) _ VARIABLE NAME TOKEN FOR MEMBER
  
 NAM2     SA1    B4 
          =B2    1           INDICATE (VALUE.) OK (FOR TRV) 
          SB7    E.MR3       ** PREMATURE E.O.S.
          ZR     X1,NAM.ERR  IF EOS 
          MX0    WA.SYML
          BX6    X0*X1       SYMBOL ONLY
          SB3    X1-O.VAR 
          SA6    FILL.
          SB7    E.NL5
          NZ     B3,NAM.ERR  IF NOT VARIABLE
          CALL   TRV         TRANSLATE VARIABLE 
          SB7    FEC.RTN
          MI     X0,NAM.ERR  IF TRV DETECTED ERROR
          CLAS=  X4,WB,(DEF,VAR)
          BX6    X2+X4       MERGE IN REQUIRED ATTRIBUTES 
          CLAS=  X4,WB,(SFA)
          BX6    -X4*X6      CLEAR WB.SFA (IF PRESENT)
          SA6    A2          UPDATE SYMTAB (WB) 
          SBIT   X2,WB.ARYP 
          PL     X2,NAM3     IF NOT ARRAY 
          SA2    T.DIM
          LX6    -WB.PNTP 
          MX3    -WB.PNTL 
          BX6    -X3*X6      T.DIM INDEX OF ARRAY 
          SB6    X6 
          SA3    X2+B6       DIM HEADER FOR ARRAY 
          SBIT   X3,DH.ASP
          SB7    E.NL4       ** NAMELIST MEMBER CANNOT BE ASSUMED SIZE
          MI     X3,NAM.ERR  IF ASSUMED SIZE ARRAY
  
  
**        ADD SYMBOL TO GROUP.
*                (X0) = SYMORD. 
  
 NAM3     SA5    NAMB        FETCH (PARCEL INDEX, MEMBER COUNT) 
          SA2    A5+B1
          UX1,B7 X5 
          SB7    B7-NG.ORDL 
          LX0    B7 
          SX5    X1+B1       COUNT MEMBERS
          BX6    X2+X0       MERGE NEW SYMBOL 
          NZ     B7,NAM4     IF WORD NOT FULL 
          ADDWD  T.NLST      ADD FULL WORD TO GROUP-DEF 
          SB7    4*NG.ORDL
          MX6    0           CLEAR ACCUMULATOR
  
 NAM4     PX7    X5,B7
          SA6    A5+B1
          SA7    A5          SAVE (PARCEL INDEX, MEMBER COUNT)
  
  
**        CHECK FOR SEPARATOR 
*         IF SEPARATOR IS A COMMA, WE RETURN TO *NAM2*. 
*         IF SEPARATOR IS NOT A COMMA, WE FLUSH THE WORKING BUFFER, AND 
*                SET NUMBER OF MEMBERS IN HEADER WORD.
*         IF *EOS* WE ARE THRU. 
  
  
          SA5    B4+B1       FETCH NEXT SEPARATOR 
          SB4    A5+B1       POINT TO NEXT ITEM 
          SX2    X5-O.COMMA 
          ZR     X2,NAM2     IF COMMA 
          SA4    NAMB+1 
          ZR     X4,NAM5     IF NO PARTIAL ACCUMULATOR WAITING
          BX6    X4 
          ADDWD  T.NLST      APPEND REST OF MEMBERS 
  
 NAM5     SA3    NAMA        FETCH INDEX OF GROUP START 
          SA2    A3+B1
          IX1    X1+X3       (X1) _ GROUP HEADER WORD 
          SX6    X2          (X6) = NUMBER OF MEMBERS 
          SA3    X1 
          LX6    NG.NMEMP 
          BX7    X3+X6       FILL IN NUMBER OF MEMBERS
          SA7    A3 
          NZ     X5,NAM1    IF NOT EOS, CONTINUE WITH NEXT GROUP
          EQ     FEC.RTN
  
**        HERE IF ERROR.  COLLAPSE T.NLST TO PREVIOUS CONDITION.
* 
*         (B7) = EXIT ADDRESS 
  
 NAM.ERR  SA1    NAMC        PREVIOUS T=NLST
          SHRINK T=NLST,X1
          JP     B7          EXIT...
  
 NAMA     BSS    1           START INDEX OF CURRENT GROUP 
 NAMB     BSSZ   2           (PARCEL INDEX, MEMBERS), ACCUMULATOR 
 NAMC     BSS    1           LENGTH OF T.NLST AT START OF CURRENT GROUP 
 PATCH    SPACE  4,20 
**        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 
          CALL   OCT         ASSEMBLE ADDRESS WHERE PATCH IS TO GO
          SA6    PATA 
          =A3    A3+1        SKIP OVER SEPARATOR
          CALL   OCT         ASSEMBLE CONTENTS OF WORD
          SA1    PATA 
          SA6    X1          STORE NEW WORD 
          EQ     FEC.RTN
  
 PATA     DATA   0           SAVE CELL FOR ADDRESS FIELD. 
  
 TEST     ENDIF 
 PAU      SPACE  4,10 
**        PAU - TRANSLATE "PAUSE" STATEMENT.
* 
*         SEE ANSI 11.13
* 
*         EXIT   TO *PSL*.
*         CALLS  SPR. 
  
  
          HEREIF PAUSE
  
          SB5    S.PAUSE
          RJ     SPR         COMPILE PAUSING INSTRUCTIONS 
          EQ     PSL         EXIT...
 RTN      SPACE  4,20 
**        RTN - TRANSLATE "RETURN" STATEMENT. 
* 
*         SEE ANSI 15.8 
* 
*         SET (NOPATH), UNLESS OBJECT OF LOGICAL IF.
*         IF MAIN PROGRAM, ACTION SAME AS FLOW INTO END-LINE. 
*         IF ALTERNATE RETURN, COMPILE JUMP EXPRESSION. 
*         IF SIMPLE RETURN AND NOT MAIN PROGRAM, THEN, IF OBJECT
*         OF LOGICAL-IF, RESET IF-TARGET INSTEAD OF EMITTING ANOTHER
*         TURPLE. 
* 
*         EXIT   *PSL*. 
* 
*         CALLS  EMIT, FATAL, PJX, RIT, SER.
  
  
          HEREIF RETURN 
  
          SA5    MOD
          SA2    S=ENTRY
          SBIT   X5,MO.PROP 
          MI     X5,RTN1     IF MAIN PROGRAM
          LX2    XR.TAGP
          ADDREF X2,CR.RET
  
 RTN1     SA2    T=BLST 
          ZR     X2,RTN2     IF NOT INSIDE A BLOCK STRUCTURE
          CLAS=  X0,WB,(DLER)  LOOP HAS EXTERNAL REFERENCE
          CALL   PDA         PROPOGATE DO LOOP ATTRIBUTES 
  
 RTN2     MX6    1
          SA6    NOPATH 
  
**        VALIDATE SYNTAX -- NOTHING MAY FOLLOW THE KEYWORD.
  
          SA1    B4 
          NZ     X1,RTN9     IF NOT *EOS* 
          PL     X5,RTN4     IF NOT MAIN PROGRAM
  
**        WHEN IN MAIN PROGRAM, ACT LIKE *END*. 
  
 RTN3     RJ     SER         SET *END* RETURN CODE
          EQ     E.ANS3      RETURN IN MAIN PROGRAM NON-ANSI
  
**        IN SUBPROGRAM, JUMP TO *CT.RETN*. 
  
 RTN4     SA1    INIF 
          NZ     X1,RTN8     IF OBJECT OF 1-BRANCH *IF* 
  
          BX4    0
          MX5    0
          EMIT   V=RET
          EQ     PSL         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     SA4    S=EXIT 
          SA3    RTNCNT 
          BX6    0
          LX4    TP.ORDP
          SA6    NOPATH      CLEAR NOPATH CONDITION 
          =X7    X3+1        COUNT RETURN STATEMENTS
          SA7    A3 
          RJ     RIT         RESET IF TARGET
          EQ     PSL         EXIT...
  
*         EXPRESSION FOLLOWING KEYWORD.  PARSE IT AND EMIT ALTERNATE
*         RETURN TURPLE.
  
 RTN9     PL     X5,RTN92    IF NOT MAIN PROGRAM
          WARN   E.SPR4 
          EQ     RTN3 
  
 RTN92    SBIT   X5,MO.FUNP/MO.PROP 
          PL     X5,RTN94    IF NOT FUNCTION
          FATAL  E.SPR5      ALTERNATE RETURN ILLEGAL IN FUNCTION 
          EQ     RTN4 
  
 RTN94    SX6    V=RTNK 
          SA6    N.ARP       INDICATE ALTERNATE RETURN HAPPENED 
          MX7    0           (2OP) = NIL
          RJ     PJX         PARSE JUMP EXPRESSION
          SA1    INIF 
          ZR     X1,RTN98    IF NOT OBJECT OF 1-BRANCH *IF* 
          BX7    0
          SA7    NOPATH      CLEAR NOPATH FLAG
  
 RTN98    EQ     PSL         EXIT...
 STP      SPACE  4,10 
**        STP - TRANSLATE "STOP" STATEMENT. 
* 
*         SEE ANSI 11.12
* 
*         EXIT   *PSL*. 
*         CALLS  SPR. 
  
  
          HEREIF STOP 
  
          SB5    S.STOP 
          RJ     SPR         COMPILE TERMINATING INSTRUCTIONS 
          SA1    INIF 
          NZ     X1,PSL      IF OBJECT OF 1-BRANCH IF 
          MX6    1
          SA6    NOPATH      INDICATE NO-PATH.
          EQ     PSL         EXIT...
          TITLE  'GOTO' STATEMENTS. 
 GOT      SPACE  4,20 
**        GOT - PROCESS "GO TO" STATEMENT KEYWORD.
* 
*         ANSI
*         11.1   GOT -  GOTO SN 
*         11.2   GOA -  GOTO IVAR 
*                       GOTO IVAR , (SN LIST) 
*                       GOTO IVAR   (SN LIST) 
*         11.3   GOC -  GOTO (SN LIST) , IEXP 
*                       GOTO (SN LIST)   IEXP 
* 
*         ENTRY  (B4) _ TOKEN FOLLOWING KEYWORD.
*         EXIT   FRONT END CONTROLLER 
  
  
          HEREIF GOTO 
  
          SA1    B4 
          =X6    CR.GOTO
          ZR     X1,E.GO1    IF MISSING OBJECT OF GO TO - ERROR 
          SX2    X1-O.LP
          SA6    REFNUM      SET CROSS REFERENCE LETTER 
          =X6    CR.VGOTO 
          =A3    B4+1 
          SB6    B0          INITIALIZE (B6) FOR GOC
          SA6    REFVAR 
          ZR     X2,GOC      IF *(* -- COMPUTED GOTO
          SA2    DTI
          ZR     X2,GOT      IF NOT DO TERMINATOR 
          SA2    INIF 
          NZ     X2,GOT      IF GOTO APPENDED TO LOGICAL IF 
          FATAL  E.MDO       ONLY FOR UNCONDITIONAL/ASSIGNED GOTO 
  
 GOT      SB2    X1-O.VAR 
          ZR     B2,GOA      IF VARIABLE -- ASSIGNED GOTO 
 GOT      SPACE  4,20 
**        GOT - TRANSLATE UNCONDITIONAL GOTO. 
* 
*         IF OBJECT OF LOGICAL-IF, THEN 
*                RESET IF-TARGET, INSTEAD OF EMITTING ANYTHING. 
*         ELSE
*                SET (NOPATH), EMIT V=GOTO. 
  
          BX6    X1 
          NZ     X3,E.GO     IF NO *EOS* - ERROR
          CLAS=  X2,WB,(GOTO,SREF)
          CALL   ISL         IDENTIFY STATEMENT LABEL 
          MI     X6,FEC.RTN  IF ERROR IN LABEL
          SA1    STL0R
          SA2    TB=LABR
          IX0    X1-X2
          NZ     X0,GOT6     IF NOT TRANSFER TO ITSELF
          WARN   E.GO7       WARNING
  
 GOT6     BX5    X6          SAVE TAG.
          SA1    INIF 
          MX6    1
          SA6    NOPATH      INICATE POSSIBLE NO-PATH.
          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 PSL AND FINISH PROCESSING THE *DO* 
* 
*         (X5) = STATEMENT NUMBER ORDINAL.
  
          SA6    NOPATH      CLEAR
          BX4    X5 
          RJ     RIT         RESET IF TARGET
          SA1    DTI
          NZ     X1,PSL      IF IN *DO* TERMINATION -- EXIT...
          SX6    1
          BX5    X4 
  
 GOT7     SA6    IFLN        INDICATE INIF OR NOT 
          BX6    X5 
          SA6    GOTA        SAVE TAG.
          =X6    GOT7A       RETURN ADDRESS 
          SA6    HANGER 
          EQ     PSL         GET NEXT EXECUTABLE
  
**        RETURN WITH NEXT EXECUTABLE IN *TB* AND NEXT ACTIVE LABEL 
*         IN *CSLTAG* 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 PSL.  IF NOT
*         OBJECT OF AN IF WE ADD O=GOTO MACRO TO PARSED FILE AND EXIT AS
*         ABOVE.
  
 GOT7A    SA2    GOTA        RESTORE TAG. 
          SA3    CSLTAG 
          BX0    X2-X3
          SA1    IFLN 
          NZ     X0,GOT7B    IF NOT SIMPLE JUMP TO NEXT STATEMENT.
          ZR     X1,E.GO2    IF NOT PROCESSING OBJECT OF AN IF. 
          TRIV   E.GO5       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 
          SA4    GOTA        (P1) = LABEL 
          BX5    0           (P2) = NIL 
          EMIT   V=GOTO 
          SA1    T=PAR
          SX6    X1-1 
          SA6    CURST             RESET SQEEZE START PASTED *GOTO* 
          EQ     CUS.RET           RETURN TO FINISH PROCESSING HANGER 
 GOA      SPACE  4,30 
**        GOA - TRANSLATE ASSIGNED GOTO.
  
  
 GOA      SB2    B1          INDICATE (VALUE.) IS LEGAL 
          CALL   TRV         TRANSLATE VARIABLE 
          MX3    -WB.MODEL
          CLAS=  X1,WB,(SFA)
          CLAS=  X5,WB,(AGO2) 
          BX7    X2+X5
          BX7    -X1*X7      CLEAR WB.SFA (IF PRESENT)
          SA7    A2          INDICATE *APPEARED IN ASSIGNED GOTO* 
          LX7    -WB.MODEP
          BX1    -X3*X7 
          HX2    WB.ARY 
          PL     X2,GOA10    IF NOT AN ARRAY
          SA2    CLASS+WB.ARYP
          BX7    X2 
          SA7    FILL.2 
          SA2    B4+
          MX7    WA.SYML
          BX7    X7*X2       X7 = 0LSYMBOL
          SA7    FILL.
          FATAL  E.AS7       ** CONFLICT - VAR PREVIOUSLY USED AS ARRAY 
  
 GOA10    LX5    X6          (X5) = PASS 1 TAG FORM 
          SB7    X1-M.INT 
          ZR     X1,GOA20    IF BOOLEAN VARIABLE
          ERRNZ  M.BOOL 
          ZR     B7,GOA20    IF INTEGER VARIABLE
          WARN   E.GO4       ** OBJECT OF GOTO NOT INTEGER
 GOA20    SB4    B4+B1
          SA2    B4 
          SB7    X2-O.COMMA 
          NZ     B7,GOA22    IF COMMA MISSING 
          SB4    B4+B1
          SA2    B4 
 GOA22    SB7    X2-O.LP
          ZR     X2,GOA70    IF EOS -- STATEMENT LABEL LIST OMITTED 
          ZR     B7,GOA30    IF LEFT PAREN
          FATAL  E.GO3
  
*         SCAN STATEMENT LABEL LIST.
*                VALIDATE SYNTAX. 
*                MARK LABELS AS (WB.SREF).
  
 GOA30    SB4    B4+B1
 GOA32    SA1    B4 
          ZR     X1,PSL      MISSING RIGHT PAREN ALREADY DIAGNOSED
          BX6    X1 
          CLAS=  X2,WB,(GOTO,SREF)
          CALL   ISL         IDENTIFY STATEMENT LABEL 
          SA1    STL0R
          SA3    TB=LABR
          =A4    B4+1 
          IX2    X3-X1
          SB4    B4+2 
          SX3    X4-O.COMMA 
          NZ     X2,GOA36    IF NOT REFERENCE TO CURRENT LABEL
          TRIV   E.GO8       STATEMENT CAN TRANSFER TO ITSELF 
 GOA36    ZR     X3,GOA32    IF COMMA, LOOP 
          =B2    X3-O.RP+O.COMMA
          NZ     B2,E.GO     IF NOT *)* - ERROR...
          =A1    B4 
          ZR     X1,GOA60    IF NOTHING AFTER *)* 
          ERRNZ  O.EOS
          WARN   E.GO9
  
**        EMIT ASSIGNED GOTO TURPLE --
*                (OPR) =  V=AGOTO . 
*                (1OP) = (X5) = VARIABLE TAG OF TARGET. 
*                (2OP) = NIL. 
  
 GOA60    BX6    X5 
          SA6    GOTA 
          SA4    GOTA        (L1) = VARIABLE TO GOTO
          BX5    0           (P2) = NIL 
          EMIT   V=AGOTO,1ST
          MX6    1           SET NOPATH INDICATION
          SA6    NOPATH 
          EQ     PSL         EXIT.. 
  
*      1. HERE TO CHECK IF *GO TO IVAR* IS WITHIN A BLOCK STRUCTURE.
*      2. CHECK T.BLST FOR DO LOOPS AND SET WB.DLEX FOR THE DO'S
*         SYMBOL TABLE ENTRY. 
  
 GOA70    SA2    T=BLST 
          ZR     X2,GOA60    IF NOT IN A BLOCK STRUCTURE
          CLAS=  X3,WB,(DLEX) 
          LX0    X3 
          SA1    T.BLST 
          SB2    X2-1 
  
 GOA80    SA3    X1+B2       FETCH LC. WORD FOR BLOCK 
          LX3    -LC.CNTP 
          SB3    X3          NUMBER OF WORDS IN THIS T.BLST ENTRY 
          ERRNZ  18-LC.CNTL 
          HX3    LC.DO
          AX3    -LC.DOL
          SB2    B2-B3
          ZR     X3,GOA88    IF NOT DO LOOP 
          SB3    B2+DORT.W+1
          SA4    X1+B3
          HX4    TP.ORD 
          AX4    -TP.ORDL    EXTRACT ORDINAL
          SB3    X4 
          LX4    1
          SB3    B3+X4       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          SB3    B3+WB.W
          SA4    T.SYM
          SA4    X4+B3       *DO* COMPILER GENERATED SYMBOL *WB* ENTRY
          BX6    X0+X4       SET WB.DLEX
          SA6    A4          UPDATE 
  
 GOA88    PL     B2,GOA80    IF MORE BLOCKS 
          EQ     GOA60       EMIT *GO TO* TURPLE
 GOC      SPACE  4,20 
**        GOC - TRANSLATE COMPUTED *GOTO*.
* 
*         ENTRY  (B6) = 0.
*                (B4) _ *(* IN FRONT OF STATEMENT LABEL LIST. 
* 
*         1.  COUNT NUMBER OF LABELS IN LIST. 
*         2.  PARSE THE INDEX EXPRESSION. 
*         3.  PAR CALLS (C=GOT) TO EMIT INDEXED JUMP TURPLE.
*         4.  UPON RETURN FROM PAR, LOOP THRU LABELS AGAIN
*                AND EMIT JUMP TURPLE FOR EACH TARGET.
  
  
 GOC      BSS    0           ENTRY... 
  
 GOC2     SA1    B4+2 
          =X2    X1-O.COMMA 
          SB4    B4+2 
          =B6    B6+1 
          ZR     X2,GOC2     IF COMMA, LOOP 
          =X1    X1-O.RP
          NZ     X1,E.GO     IF NOT *)* - ERROR...
          SX6    O.SLP
          SA6    B4          PROTECT FOR POSSIBLE UNARY MINUS 
          SA1    B4+B1
          SB4    A1+B1       ADVANCE TOKEN POINTER BY 2 
          =X1    X1-O.COMMA 
          ZR     X1,GOC4     IF OPTIONAL COMMA PRESENT
          =B4    B4-1 
  
 GOC4     SX7    B6          SET (2OP) = NUMBER OF BRANCHES 
          SX6    V=CGOTO
          LX7    TP.BIASP 
          RJ     PJX         PARSE JUMP EXPRESSION
          SA1    TB=1ST      (X1) = ADDR OF TOKEN FOLLOWING KEYW *GOTO* 
          SB4    X1+B1       ADVANCE OVER THE (O.LP)
  
*         BUILD JUMP CODE FOR COMPUTED GOTO.
  
 GOC6     SA1    B4 
          =A2    B4-1 
          BX6    X1 
          SB7    X2-O.SLP 
          ZR     B7,PSL      IF END OF STATEMENT LABEL LIST 
          CLAS=  X2,WB,(GOTO,SREF)
          CALL   ISL         IDENTIFY STATEMENT LABEL 
          BX4    X6          (P1) = STATEMENT LABEL 
          MX5    0           (P2) = NIL 
          EMIT   V=JGOTO
          SA1    STL0R
          SA2    TB=LABR
          IX3    X2-X1
          NZ     X3,GOC7     IF NOT REFERENCE TO CURRENT LABEL
          TRIV   E.GO8       STATEMENT CAN TRANSFER TO ITSELF 
  
 GOC7     SB4    B4+2 
          EQ     GOC6        LOOP.. 
  
 GOTA     EQU    CLLA        SAVE OLD STATEMENT LABEL 
          TITLE  'IF' STATEMENTS. 
 INIF     CONENT 0           (GL) WHEN PROCESSING A LOGICAL IF, ELSE 0
 IFNEST   DATA   0           .NZ. = IF NESTED IF
 IFMOD    CONENT 0           RESULTANT MODE OF IF EXPRESSION
 IFRESLT  CONENT 0           RESULTANT OPERAND FROM IF EXPRESSION 
 IFREL1   DATA   0           OPPOSITE *IF* ORDINAL
 IFREL2   CONENT 0           .NZ. = (OPPOSITE) ORD. PAIR FOR SINGLE REL.
 IFLN     BSZENT 4           IF STATEMENT LABEL TAGS
 IFSA     DATA   0           ENTRY CONDITION ON *B4*
 IFSB     VFD    TB.TOCL/4LTHEN,TB.TOTL/O.VAR 
 ELFA     VFD    TB.TOCL/2LIF,TB.TOTL/O.VAR 
 ELS      SPACE  4,10 
**        ELS - TRANSLATE "ELSE" STATEMENT. 
* 
*         SEE ANSI 11.8 
  
  
          HEREIF ELSE 
          SA2    T=BLST 
          ZR     X2,ELS      IF NO BLST TABLE 
          RJ     FIB         FINISH PREVIOUS IF BLOCK 
          SA1    B4+
          NZ     X1,ELF      IF NOT *ELSE*
          SA1    T.BLST 
          SA2    T=BLST 
          SB5    X2-Z=BLST-1+BLIA.W 
          =X6    0
          SA6    X1+B5       INDICATE NO FURTHER *ELSE* OR *ELSEIF* 
 ELS      EQ     PSL         EXIT 
 ELF      SPACE  4,10 
**        ELF - TRANSLATE "ELSEIF" STATEMENT. 
* 
*         SEE ANSI 11.7 
  
  
 ELF      BSS    0
          SA2    ELFA 
          IX2    X1-X2
          NZ     X2,E.FM     IF NOT *ELSEIF*
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.LP
          NZ     B2,E.IF12   IF NOT *(* 
          =X6    O.SLP
          SA6    B4 
          SA2    IFARM
          =X7    0
          BX6    X2 
          SA7    ARGCOMA
          SA6    ARGMODE
          SA7    IFREL1      CLEAR ONE RELATIONAL *IF* CELL 
          CALL   PAR         PARSE THE *ELSEIF* EXPRESSION
          =A1    B4+1 
          =B4    B4+1 
          SA2    IFSB 
          IX2    X1-X2
          ZR     X2,ELF1     IF *THEN*
          FATAL  E.IF14 
          EQ     ELF2 
  
 ELF1     =A1    B4+1 
          =B4    B4+1 
          ZR     X1,ELF2     IF NO TRAILING GARBAGE 
          ERRNZ  O.EOS
          WARN   E.IF08 
  
 ELF2     SA2    IFMOD
          =X2    X2-M.LOG 
          ZR     X2,ELF3     IF ELSEIF EXPRESSION LOGICAL 
          FATAL  E.IF01 
  
 ELF3     RJ     CIM         CONSTRUCT IF MEGATURPLE
          SA1    T.BLST 
          SA2    T=BLST 
          SB5    X2-Z=BLST-1+BLIA.W 
          SA7    X1+B5       UPDATE ADVANCE GENERATED LABEL 
          EQ     PSL
 EIF      SPACE  4,10 
**        EIF - PROCESS "END IF" STATEMENT. 
* 
*         SEE ANSI 11.9 
  
  
          HEREIF ENDIF
          SA1    B4+
          ZR     X1,EIF0     IF NO TRAILING GARBAGE 
          ERRNZ  O.EOS
          WARN   E.IF08      */ EXPECTED EOS, FOUND FILL. 
  
 EIF0     SA1    IFLEVEL
          =X6    X1-1 
          MI     X6,E.IF13
          SA6    A1+         DECREMENT BLOCK IF LEVEL 
  
 EIF1     SA1    T.BLST 
          SA2    T=BLST 
          ZR     X2,PSL      AN ENDIF WITH NOTHING IN BLST - LEAVE
          SB5    X2-1 
          SA3    X1+B5       FETCH COUNT WORD 
          LX3    -LC.DOP
          SB2    X3          EXTRACT DO INDEX 
          ERRNZ  18-LC.DOL
          ZR     B2,EIF2     IF LAST T.BLST ENTRY IS BLOCK IF 
          LX3    LC.DOP-LC.CNTP 
          SX0    X3          EXTRACT COUNT
          ERRNZ  18-LC.CNTL 
          IX0    X2-X0
          SB2    X0+DO.W
          SA3    X1+B2       FETCH DO TERMINATOR
          HX3    DO.TAG 
          AX3    -DO.TAGL    EXTRACT ORDINAL
          SB2    X3 
          BX4    X3 
          LX4    TP.ORDP     PRESERVE FOR RBE CALL
          LX3    1
          SB2    X3+B2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          SA1    T.SYM
          SA5    X1+B2       FETCH *WA* 
          AX5    WA.STLP     EXTRACT LABEL
          CALL   LJS         LEFT JUSTIFY 
          SA6    FILL.
          FATAL  E.IF15 
          LX6    X4          DO TERMINATOR (TP. FORMAT) 
          CALL   RBE         REMOVE THE INCORRECT DO LOOP 
          EQ     EIF1 
  
 EIF2     CALL   FBS         FINISH THE BLOCK STRUCTURE 
          SA1    T.BLST 
          SA2    T=BLST 
          SB5    X2-Z=BLST-1+BLIB.W 
          SA5    X1+B5       FETCH BLOCK IF BOTTOM LABEL
          =A4    A5-BLIB.W+BLIA.W 
          MX6    1           INDICATE ELSE
          ZR     X4,EIF3     IF LAST ARM WAS AN ELSE
          LX6    X5 
          SA6    EIFA        SAVE 
          RJ     EGL         EMIT LAST IF GENERATED LABEL 
          SA5    EIFA 
          SX6    0           INDICATE NOT ELSE
  
 EIF3     SA6    EIFA        ELSE INDICATION
          SA1    T=PAR
          LX7    X1 
          SA7    CURST       DONT SQUEEZE PAST IF BLOCK 
          SA1    T.BLST 
          SA2    T=BLST 
          SB2    X2-1 
          SA2    X1+B2       FETCH LC WORD
          SBIT   X2,LC.GLMP 
          SA3    EIFA        ELSE INDICATION
          BX6    -X2*X3      .NOT. GLM .AND. ELSE 
          SA6    A3          SAVE FOR NOPATH ANALYSIS 
          PL     X2,EIF4     IF BOTTOM LABEL NOT TO MATERIALIZE 
          LX4    X5 
          RJ     EGL         EMIT BLOCK IF BOTTOM LABEL 
  
 EIF4     SA2    NOPATH 
          SA1    EIFA 
          BX1    X1*X2
          NZ     X1,EIF5     IF ALL ARMS UNCONDITIONAL CONTROL CHANGE 
          ZR     X2,EIF5     IF LAST ACTIVE STATEMENT NOT BRANCH
          MX6    0
          SA6    A2          CLEAR
          SA6    FLOW        CLEAR
  
 EIF5     SA2    T=BLST 
          SX2    X2-Z=BLST-1
          SHRINK A2,X2
          ZR     X2,PSL      IF NO NESTED BLOCK STRUCTURES
          SA1    CSLTAG 
          ZR     X1,PSL      IF ENDIF UNLABELLED
          BX6    X1 
          =B7    X1+WB.W
          LX1    1
          SB7    X1+B7       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B2    1           INDICATE LABEL DEFINITION
          SA1    TB=LABL
          BX7    X1 
          SA7    FILL.2      SAVE FOR POSSIBLE DIAGNOSTIC 
          CALL   ALU         ANALYZE LABEL USAGE
          EQ     PSL         EXIT 
  
 EIFA     BSS    1
 IFS      SPACE  4,10 
***       IFS -  PROCESS "IF" STATEMENT.
* 
*         ENTRY  B4 - *(* FOLLOWING *IF*. 
  
  
 IFS      BSSENT 0           ENTRY... 
          =B4    B4+1        SET PAST *IF* IN *SB*. 
          =X6    O.SLP
          SA6    B4          DUMMY TO SET UP PARSED MODE. 
          SA2    IFARM
          =X7    0
          BX6    X2 
          SA7    ARGCOMA
          SA6    ARGMODE
          SA7    IFREL1      CLEAR ONE RELATIONAL *IF* CELL 
  
          CALL   PAR         PARSE IT 
  
**        RETURN FROM PARSER WITH *B4* _ CLOSING *)* OF *IF*
*         (IFMOD) = RESULTANT MODE OF *IF* EXPRESSION 
*         (IFRESLT) = RESULT EXPRESSION TAG, EITHER AN INTERMEDIATE OR
*                     SIMPLE VARIABLE 
  
          SA1    B4+1 
          MX0    TB.TOCL
          =B4    B4+1        POINT TO 1ST OF OBJECT 
          ZR     X1,E.IF00   IF MISSING OBJECT OF *IF*
          =B2    X1-O.CONS
          BX6    X0*X1
          SA6    FILL.       RESET FILL.
          SA2    IFMOD
          ZR     B2,IFL      IF OBJECT OF *IF* IS A STATEMENT LABEL 
          SB7    X2-M.LOG 
          NZ     B7,E.IF09   IF EXPRESSION MODE NOT LOGICAL 
          SA2    INIF 
          NZ     X2,E.IF11   IF LOGICAL IF IS OBJECT OF IF
  
 IFS11    BSSENT 0           ...RETURN FROM ERROR PROCESSOR.
          SA4    B4 
          SA2    IFSB 
          BX6    X4-X2
          NZ     X6,IFS30    IF FIRST TOKEN OF OBJECT NOT = 'THEN'
          SA3    B4+B1
          ZR     X3,IFT      IF THIS IS A BLOCK-IF
  
 IFS30    CALL   CST         CLASSIFY STMT (OBJECT OF *IF*) 
          SA5    TB=TYPE     (X5) = STMT TYPE INFO FOR OBJECT OF *IF* 
          ZR     X5,E.FM     IF *UNTYPED*, NOT A FORTRAN STATEMENT
          BX0    X5 
          SBIT   X0,KW.NIFP 
          MI     X0,E.IF06   IF THIS STATEMENT NOT OK AS OBJECT OF *IF* 
          SA1    DTI
          ZR     X1,IFS40    IF NOT *DO* TERMINATOR 
          LX0    KW.NIFP-KW.DONP
          PL     X0,IFS40    IF NOT (*ILL DO TERM*) 
          ANSI   E.IF02      OBJECT OF IF IS ILLEGAL DO TERMINAL
  
 IFS40    SA1    FLOW 
          NZ     X1,FEC.RIF  IF NOT PATH, RETURN TO CONTROLLER... 
          RJ     CIM         CONSTRUCT IF MEGATURPLE
          SA7    INIF        INDICATE GL TO BE ISSUED AFTER OBJECT
          SA1    T=PAR
          BX6    X1 
          SA6    CURST
          EQ     FEC.RIF     EXIT TO FEC... 
 IFT      SPACE  4,10 
**        IFT - PROCESS BLOCK-IF. 
* 
*         SEE ANSI 11.6 
  
  
 IFT      SA1    IFLEVEL
          =X6    X1+1 
          SA6    A1          INCREMENT BLOCK IF LEVEL 
          ALLOC  T.BLST,Z=BLST
          RJ     CIM         CONSTRUCT IF MEGATURPLE
          SA1    T.BLST 
          SA2    T=BLST 
          SB5    X2-Z=BLST+BLIB.W 
          =X6    1
          LX6    TP.ORDP
          IX6    X6+X7       MAKE BOTTOM GENERATED LABEL
          SA6    X1+B5       SET BOTTOM POINTER GENERATED LABEL 
          =A7    A6-BLIB.W+BLIA.W 
          SB5    X2-Z=BLST+BLIC.W      BLIC.W  EQU  DO.W
          MX7    0
          SA7    X1+B5       INSURE THIS LOCATON CLEAR FOR BLOCK *IFS*
          SA1    REFLIN 
          SX6    Z=BLST+1 
          LX1    -XR.LINEP+LC.LINEP 
          BX6    X1+X6
          ADDWD  T.BLST 
          SA1    N.GL 
          =X6    X1+1 
          SA6    A1          INCREMENT GENERATED LABEL COUNT
          EQ     PSL
 IFL      SPACE  4,10 
**        IFL - STATEMENT LABEL IF. 
* 
*         ENTRY  (B4) _ FIRST STATEMENT LABEL.
*                SAVE STATEMENT LABELS IN (IFLN) AND RETURN TO MASTER 
*                LOOP TO GET NEXT EXECUTABLE STATEMENT. 
* 
*                RETURN TO IFL50 AND SET-UP SKELETON MACRO FOR PROPER 
*                JUMP FOR *IF*. 
  
  
 IFL      SA1    IFMOD       MODE OF IF EXPRESSION
          SA2    F.IFS       SELECTION MATRIX 
          LX1    3
          SB2    X1          SHIFT COUNT
          LX2    X2,B2       EXTRACT SKELETON (RELATIVE)
          PL     X2,IFL20    IF EXPRESSION LEGAL
          AX1    3           RESTORE TP.MODE
          SA2    X1+MOD.DPC  DPC OF MODE
          BX6    X2 
          SA6    FILL.3 
          FATAL  E.IF07 
  
 IFL20    SA1    INIF 
          BX6    X1 
          SA6    IFNEST 
          =X6    CR.IFN 
          SB6    0
          SA6    REFVAR      INDICATE OBJECT OF IF REFERENCE. 
          SA1    B4          PRELOAD 1ST STATEMENT LABEL
          =B5    3           MAXIMUM NUMBER OF STATEMENT LABELS POSSIBLE
          =X6    1
          SA6    IFFLAG      INDICATE INACTIVE LABEL (FOR ISL)
  
**        IDENTIFY STATEMENT LABELS.
  
 IFL30    =B4    B4+1 
          CLAS=  X2,WB,(GOTO,SREF)
          BX6    X1 
          CALL   ISL         IDENTIFY STATEMENT LABEL 
          SA1    B4 
          SA6    B6+IFLN     SAVE TAG.
          =B2    X1-O.COMMA 
          =B6    B6+1 
          ZR     X1,IFL40    IF *EOS* 
          NZ     B2,E.IF03   IF NOT *,* 
          =A1    B4+1 
          =B4    B4+1 
          ZR     X1,IFL40    IF *EOS* 
          NE     B6,B5,IFL30 LOOP ON NEXT LABEL 
          =B4    B4-1 
          SA1    B4          TEST FOR CLEAN STATEMENT ENDING
          NZ     X1,E.IF03   IF NOT *EOS* 
  
*         GO OFF TO HANGER PROCESSING.
  
 IFL40    =X6    0
          MX7    0
          SA7    IFFLAG 
          SB7    B6-3 
          =A6    A6+1        INDICATE END OF TABLE
          MI     B7,E.IF10   IF LESS THAN 3 LABELS
          SA1    DTI
          SX7    IFL50       (X7) = RETURN ADDR FOR *HANGER*
          =X6    0
          SA7    HANGER      SET RETURN ADDRESS 
          SA6    INIF        INDICATE TO *PSL* NO TAG NECESSARY 
          ZR     X1,PSL      IF NOT DO TERMINAL 
          FATAL  E.MDO       *ILLEGAL DO TERMINAL*
          EQ     PSL         RETURN FOR NEXT EXECUTABLE STATEMENT 
  
**        HERE WITH NEXT EXECUTABLE STATEMENT.
  
 IFL50    =X7    0
          SA1    IFLN+2      PRELOAD *3RD* STATEMENT LABEL
          SA7    HANGER 
          LX6    X1          SAME *3RD* LABEL 
          SA4    CSLTAG      NEXT EXECUTABLE STATEMENT TAG
          LX4    TP.ORDP
          SB4    3+1
  
 IFL52    =B4    B4-1 
          IX0    X1-X4       COMPARE TARGET LABEL WITH UPCOMING LABEL 
          =A1    A1-1        LOAD NEXT LABEL
          ZR     X0,IFL60    IF MATCH 
          NZ     B4,IFL52    IF NOT END OF TABLE
  
**        SET-UP JUMP FOR COMPILING CODE FOR IF-JUMP. 
  
 IFL60    SA1    IFLN        1ST
          SX5    B4          SET UPCOMING STATEMENT LABEL FLAG
          =A2    A1+1        2ND
          BX7    0
          IX3    X1-X6       1ST-3RD
          NZ     X3,IFL61    IF 1ST"3RD 
          SX7    X7+3 
 IFL61    BX0    X2-X6       2ND-3RD
          NZ     X0,IFL62    IF 2ND"3RD 
          SX7    X7+2 
 IFL62    IX0    X1-X2       1ST-2ND
          NZ     X0,IFL63    IF 1ST"2ND 
          =X7    X7+1 
  
**        HERE WITH 
*         (X7) = 0 = 1ST"2ND"3RD       (X5)  1 = 1ST = N
*                1 = 1ST=2ND                 2 = 2ND = N
*                2 = 2ND=3RD                 3 = 3RD = N
*                3 = 3RD=1ST                 0 = N NOT REFERENCED.
*                6 = 1ST=2ND=3RD
  
 IFL63    SA1    T.SYM
          SA2    IFLN-1 
          =X1    X1-WA.W+WB.W 
          SB4    3+1
  
 IFL63A   =B4    B4-1 
          ZR     B4,IFL63B   IF END OF TABLE
          =A2    A2+1 
          MI     X2,IFL63A   IF LABEL IS BAD (SYNTAX ERROR) 
          IX0    X2-X4
          ZR     X0,IFL63A   IF MATCH 
          LX2    -TP.ORDP 
          MX0    -TP.ORDL 
          BX2    -X0*X2      ISOLATE ORDINAL
          SB5    X2 
          LX2    1
          SB5    X2+B5       CONVERT ORDINAL TO INDEX 
          SA3    X1+B5       *WB* OF LABEL
          =X6    1
          LX6    WB.ACTP
          BX6    X6+X3
          SA6    A3          MARK LABEL AS ACTIVE 
          EQ     IFL63A 
  
 IFL63B   SA1    IFNEST 
          NZ     X1,IFL64    IF APPENDED TO LOGICAL IF
          MX6    1
          SA6    NOPATH      INDICATE NO PATH TO NEXT STATEMENT 
  
 IFL64    SB3    X7-6 
          NZ     B3,IFL70    IF NO POSSIBLE NULL-TRANSFER.
          ZR     X5,IFL65    IF NOT NULL TRANSFER.
          WARN   E.IF05      DO NOTHING STATEMENT 
          EQ     CUS.RET     FINISH PROCESSING HANGER.
  
 IFL65    SX3    V=I111 
          SA1    IFNEST 
          NZ     X1,IFL90    IF APPENDED TO LOGICAL IF
          TRIV   E.IF04 
          SA4    IFLN        1ST LABEL (=2ND LABEL = 3RD LABEL) 
          MX5    0
          EMIT   V=GOTO 
          EQ     CUS.RET     FINISH PROCESSING HANGER 
  
 IFL70    SA1    IFMOD
          SB6    F.IFS
          =B3    0
          ZR     X5,IFL80    IF NO REFERENCE TO UPCOMING LABEL
          SB6    X5+F.IFS+3 
          ZR     X7,IFL80    IF ONLY ONE REFERENCE AND NO 2 ALIKE 
          SB6    F.IFN-4
          =X7    X7+1 
          =B3    1
          SB2    X5-3 
          LX7    1           *2 
          PL     B2,IFL80    IF NEXT IS THIRD IF-TARGET 
          =B3    0
  
*         HERE WITH --
*         (B3) = OFFSET FOR STATEMENT LABEL CONFIGURATION.
*         (B6) = BASE TABLE TO USE. 
*         (X7) = SPECIAL OFFSET WHEN *N* IS ONE OF STATEMENT LABELS.
  
 IFL80    SA2    IFMOD       DM = (IFMOD) 
          SB3    X7+B3       (B3) = COMPLETE OFFSET 
          MX0    8
          LX2    3
          SA1    B3+B6       LOAD MODE SELECTION VECTOR 
          SB2    X2          (B2) = 8 * DM
          LX3    X1,B2
          BX2    X0*X3       EXTRACT RELATIVE SKELETON NUMBER 
          MI     X2,CUS.RET  IF EXPRESSION MODE ILLEGAL 
          LX2    8
          SA1    FLOW 
          SX3    X2+OM=IF    (X3) = COMPLETE SKELETON NUMBER
          NZ     X1,CUS.RET  IF NO PATH 
  
*         EMIT TURPLE TO IL (PARSED FILE).
* 
*         ENTRY  (X3) = SKELETON FOR THIS IF. 
*                (IFLN) = VECTOR OF JUMP TARGET TAGS. 
* 
*         A THREE-BRANCH IF MEGA-TURPLE CONSISTS OF TWO TURPLES,
*         ORGANIZED AS FOLLOWS -- 
*         1.  OPR = IF-MACRO SKELETON ADDRESS.
*                (P1) = EXPRESSION RESULT          (IFRESLT)
*                (P2) = 1ST LABEL.                 (IFLN+0) 
*         2.  OPR = NOOP SKELETON.
*                (P3) = 2ND LABEL.                 (IFLN+1) 
*                (P4) = 3RD LABEL.                 (IFLN+2) 
  
 IFL90    SX7    X3          EXTRACT SKELETON ADDRESS 
          SA2    OPDUM+DUC=1ST
          LX7    SP.SKELP 
          SA4    IFRESLT     (P1) = IF-EXPRESSION RESULT
          BX6    X2+X7
          SA5    IFLN        (P2) = LABEL 1 
          SA6    IFSA        STORE IF-OPERATOR
          EMIT   A6,* 
          SA4    A5+B1       (P3) = LABEL 2 
          SA5    A4+B1       (P4) = LABEL 3 
          EMIT   NOOPP,*
  
          SA2    IFNEST 
          ZR     X2,CUS.RET  IF THIS ARITH IF NOT OBJ OF LOG IF 
          CALL   CSB         EMIT BSS TURPLE
          BX6    0
          SA6    IFNEST      SO ONLY ONE BSS TURPLE EMITTED 
          EQ     CUS.RET     RETURN TO FINISH PROCESSING HANGER 
  
 IFFLAG   BSZENT 1
 CIM      SPACE  4,10 
**        CIM -  CONSTRUCT IF MEGATURPLE
* 
*         EXIT   (X7) = GENERATED LABEL (IF FALSE JUMP) (TP. FORMAT)
  
  
 CIM      SUBR               ...ENTRY/EXIT... 
          SX4    V=IFF       (X4) = NORMAL LOGIC SKELETON 
          SX5    V=IFT       (X5) = OPPOSITE LOGIC SKELETON 
          SA2    IFREL2 
          ZR     X2,CIM1     IF CONDITION IS NOT SINGLE-RELATIONAL
  
  
**        IF CONDITION IS SINGLE RELATIONAL.  THE LAST TURPLE IN THE
*         PARSE FILE IS NOW A RELATIONAL WHICH COMPUTES THE DESIRED 
*         LOGICAL VALUE.  CHANGE ITS (OPR) TO THE CORRESPONDING IF-1REL 
*         SKELETON, THUS USING IT AS THE FIRST TURPLE OF THE IF MEGA- 
*         TURPLE WE ARE TO CONSTRUCT. 
  
          SA3    T.PAR
          SA4    T=PAR
          IX0    X3+X4       (X0) = LWA+1 PARSED FILE 
          SX7    X2 
          SA1    X0-Z=TURP+OR.OPR 
          MX6    -TH.SKELL
          IFEQ   TEST,ON,1
          MI     X7,"BLOWUP" NO OPPOSITE SPECIAL
          AX2    30 
          SA7    IFREL1      OPPOSITE LOGIC SKELETON
          LX1    -TH.SKELP
          BX0    X6*X1
          BX7    X0+X2       SET LAST TURP = NORMAL 1-REL LOGIC 
          LX7    TH.SKELP 
          SA7    A1 
          EQ     CIM2 
  
  
**        CONDITION IS A GENERAL EXPRESSION.
*                EMIT FIRST TURPLE OF IF. 
  
 CIM1     LX4    SP.SKELP 
          SA1    OPDUM+DUC=1ST
          SX7    X5 
          BX6    X4+X1       (OP) = NORMAL GENERAL LOGIC SKEL 
          SA7    IFREL1 
          SA4    IFRESLT     (P1) = RESULT OF IF-EXPRESSION 
          MX5    0
          SA6    IFSA 
          EMIT   A6,* 
  
  
**        IN EITHER CASE, FINISH UP THE IF-MEGATURPLE.
*                EMIT SECOND TURPLE, CONTAINING THE BRANCH TARGET.
  
 CIM2     SA3    N.GL 
          CLAS=  X2,TP,(GL) 
          SX6    X3+B1       ADVANCE GENERATED LABEL COUNT
          LX3    TP.ORDP
          SA6    A3 
          BX5    X2+X3       (P2) = GENERATED-LABEL OF DESTINATION
          MX4    0           (P1) = NIL 
          EMIT   V=NOOP 
          BX7    X5 
          EQ     EXIT.
 FIB      SPACE  4,10 
**        FIB -  FINISH IF BLOCK
* 
*         ENTERED WHEN ELSE OR ELSEIF ENCOUNTERED.  FINISHES THE
*         PREVIOUS IF BLOCK.
* 
*         USES   X0,X1,X2,X3,X4,X5,X6  B2,B5  A1,A2,A3,A4,A5,A6 
* 
*         CALLS  EGL, EMT, FBS, LJS, PDM
  
  
 FIB      SUBR               ...ENTRY/EXIT... 
          SA1    IFLEVEL
          ZR     X1,E.IF13   IF NO BLOCK IF STRUCTURE ACTIVE
  
 FIB1     SA1    T.BLST 
          SA2    T=BLST 
          SB5    X2-1 
          SA3    X1+B5       FETCH COUNT WORD 
          LX3    -LC.DOP
          SB2    X3          EXTRACT DO INDEX 
          ERRNZ  18-LC.DOL
          ZR     B2,FIB2     IF LAST T.BLST ENTRY IS BLOCK IF 
          LX3    LC.DOP-LC.CNTP 
          SX0    X3          EXTRACT COUNT
          ERRNZ  18-LC.CNTL 
          IX0    X2-X0
          SB2    X0+DO.W
          SA3    X1+B2       FETCH DO TERMINATOR
          HX3    DO.TAG 
          AX3    -DO.TAGL    EXTRACT ORDINAL
          SB2    X3 
          BX4    X3 
          LX4    TP.ORDP     PRESERVE FOR RBE CALL
          LX3    1
          SB2    X3+B2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          SA1    T.SYM
          SA5    X1+B2       FETCH *WA* 
          AX5    WA.STLP     EXTRACT LABEL
          CALL   LJS         LEFT JUSTIFY 
          SA6    FILL.
          FATAL  E.IF15 
          LX6    X4          DO TERMINAL (TP. FORMAT) 
          CALL   RBE         REMOVE THE INCORRECT DO LOOP 
          EQ     FIB1 
  
 FIB2     CALL   FBS         FINISH THE BLOCK ARM 
          SA1    T.BLST 
          SA2    T=BLST 
          SB5    X2-Z=BLST-1+BLIB.W 
          SA2    NOPATH 
          ZR     X2,FIB3     IF LAST ACTIVE STATEMENT NOT BRANCH
          MX6    0
          SA6    A2          CLEAR NOPATH 
          SA6    FLOW        CLEAR
          EQ     FIB4 
  
 FIB3     SA4    X1+B5
          MX5    0
          EMIT   V=GOTO      JUMP TO BOTTOM OF BLOCK IF STRUCTURE 
          SA2    =XCO.DBID
          ZR     X2,FIB3A    IF NOT *DB=ID* 
          SA1    B4 
          ZR     X1,FIB3A    IF NOT *ELSE IF* 
          SA2    T=PAR
          SX2    X2-6 
          MI     X2,FIB3A    IF LESS THEN 2 TURPLES 
          SA1    T.PAR
          IX1    X1+X2
          SA4    X1          FIRST OF NEXT TO LAST TURPLE 
          SA1    A4+Z=TURP   FIRST OF LAST TURPLE 
          BX6    X4 
          LX7    X1 
          SA6    A1 
          SA7    A4 
          SA4    A4+OR.1OP   SECOND OF NEXT TO LAST TURPLE
          SA1    A4+Z=TURP   SECOND OF LAST TURPLE
          BX6    X4 
          LX7    X1 
          SA6    A1 
          SA7    A4 
          SA4    A4+OR.1OP   THIRD OF NEXT TO LAST TURPLE 
          SA1    A4+Z=TURP   THIRD OF LAST TURPLE 
          BX6    X4 
          LX7    X1 
          SA6    A1 
          SA7    A4 
  
 FIB3A    CLAS=  X6,LC,(GLM)
  
 FIB4     SA1    T.BLST 
          SA2    T=BLST 
          =B5    B5-BLIB.W+BLIA.W 
          SA4    X1+B5       FETCH PREVIOUS ADVANCE LABEL (GL)
          ZR     X4,E.IF13   IF PREVIOUS ELSE, THIS LEVEL 
          SB2    X2-1 
          SA2    X1+B2
          BX6    X6+X2       MERGE IN LC.GLM (IF PRESENT) 
          SA6    A2 
          SA1    T=PAR
          BX7    X1 
          SA7    CURST       DONT SQUEEZE PAST IF ARM 
          RJ     EGL         EMIT GENERATED LABEL 
          EQ     EXIT.
          TITLE  SUBROUTINES. 
 CEM      SPACE  4,20 
**        CEM - CHECK ENTRY POINT MODE. 
* 
*         WILL DETECT MODE CONFLICTS BETWEEN FUNCTION MAIN ENTRY
*         AND ANOTHER ENTRY POINT.
* 
*         ENTRY  (A2,X2) = SYMTAB (WB.) OF AN ENTRY POINT 
*                (X3) = CONTENTS OF (MOD).
* 
*         EXIT   (B7) .ZR. = NO ERROR DETECTED. 
*                     .NZ. = ERROR MESSAGE ADDRESS. 
* 
*         USES   A1,4.  X1,3-4,6.  B7.
  
  
 CEM      SUBR               ENTRY/EXIT...
          SB7    B0 
          HX3    MO.FUN 
          PL     X3,EXIT.    IF NOT COMPILING A FUNCTION
          MX4    -MO.MODEL
          LX3    MO.FUNP+1-MO.MODEP 
          BX1    -X4*X3      ISOLATE MODE OF MAIN ENTRY 
          SX1    X1-M.CHAR
          ERRNZ  WB.MODEL-MO.MODEL
          LX2    -WB.MODEP
          BX4    -X4*X2      ISOLATE MODE OF THIS ENTRY 
          LX2    WB.MODEP 
          SX4    X4-M.CHAR
          NZ     X1,CEM15    IF MAIN ENTRY NOT CHARACTER
          ZR     X4,CEM5     IF THIS ENTRY IS CHARACTER 
          SB7    E.EN6
          EQ     EXIT.
  
 CEM5     =A4    A2-WB.W+WC.W 
          LX3    MO.MODEP-MO.CLIFP
          LX4    -WC.CLIFP
          CLAS=  X1,MO,(CLIF) 
          LX1    -MO.CLIFP
          BX3    X4-X3       COMPARE CHAR TYPE INFO 
          BX3    X1*X3
          ZR     X3,EXIT.    IF CHAR INFO EQUAL 
          SB7    E.EN7
          EQ     EXIT.
  
**        HERE IF MAIN ENTRY NOT TYPE CHARACTER 
  
 CEM15    NZ     X4,EXIT.    IF THIS ENTRY NOT CHARACTER
          SB7    E.EN8
          EQ     EXIT.
 EGL      SPACE  4,10 
**        EGL -  EMIT GENERATED LABEL 
* 
*         EMITS THE GENERATED LABEL (V=BSS) AND FLUSHES THE IL. 
* 
*         ENTRY  (X4) = GENERATED LABEL TO ISSUE (TP. FORMAT) 
* 
*         USES   ALL (PRESERVES B4) 
* 
*         CALLS  EMT, OIL 
  
  
 EGL      SUBR               ...ENTRY/EXIT... 
          SX6    B4 
          MX5    0           OR.20P IS NULL 
          SA6    EGLA        SAVE (B4)
          EMIT   V=BSS       THE GL 
          CALL   OIL
          SA1    EGLA 
          SB4    X1          RESTORE (B4) 
          EQ     EXIT.
  
 EGLA     BSS    1           SAVE (B4)
 MND      SPACE  4,10 
**        MND - MATERIALIZE NAMELIST DIMENSIONS.
* 
*         MARKS (T.DIM) ENTRIES WHICH NEED TO APPEAR IN THE RUNTIME DIM 
*         TABLE BECAUSE OF NAMELIST.  FOR EACH ARRAY WHICH IS A MEMBER
*         OF A MATERIALIZED NAMELIST GROUP, THE (DH.MAT) BIT IS SET IN
*         IT'S (T.DIM) ENTRY. 
* 
*         THIS MARKING IS NOT PERFORMED UNTIL THE END OF PASS 1, SO THAT
*         UNREFERENCED NAMELIST GROUPS WILL NOT CAUSE ANY RUNTIME DIM 
*         WORDS TO BE GENERATED.  THE TASK CANNOT BE DEFERRED UNTIL THE 
*         BEGINNING OF PASS 3 BECAUSE CCG PASS 2 MUST BE ABLE TO FIGURE 
*         OUT WHICH (VD.) CELLS CAN BE THROWN AWAY. 
* 
*         USES   ALL. 
  
  
 MND      SUBR   0           ENTRY/EXIT...
          SA1    T.NLST 
          SA2    T=NLST 
          SA3    T.SYM
          SA4    T.DIM
          BX7    0           MARK (T.NLST) LWA+1 WITH ZERO WORD 
          IX6    X2+X1
          SB6    X4          (B6) = FWA (T.DIM) 
          MX0    -NG.ORDL 
          SA7    X6 
          ERRMI  FUDGE-1     CODE REQUIRES SLOP WORD
          SA5    X1          FETCH FIRST GROUP HEADER 
          =B5    X3+WB.W     (B5) = FWA SYMTAB (WB.)S 
          SA7    A5-B1       INITIALIZE DESCRIPTOR STORE ADDRESS
          ERRMI  FUDGE-1     REQUIRES SLOP WORD BELOW TABLE 
  
*         BEGIN NEXT GROUP. 
*                (X5) = GROUP HEADER WORD.
  
 MND20    ZR     X5,MND70    IF TABLE TERMINATOR
          BX7    X5 
          LX5    -NG.NMEMP
          BX2    -X0*X5      (B4) = COUNT OF MEMBERS IN GROUP 
          ERRNZ  NG.NMEML-NG.ORDL 
          SB4    X2 
 .T       IFEQ   TEST,ON,1
          ZR     B4,"BLOWUP" IF EMPTY GROUP 
          LX5    NG.NMEMP-NG.GROPP POSITION FIRST MEMBER AT TOP 
          BX1    -X0*X5      (X1) = SYMORD OF GROUP 
          SB2    X1+B5
          LX2    X1,B1
          SA1    B2+X2       FETCH SYMTAB (WB.) FOR GROUPNAME 
          ERRNZ  3-Z=SYM
          HX1    WB.MAT 
          MI     X1,MND28    IF GROUP WAS REFERENCED
          SX6    B4+2+3      ROUND UP BYTES IN THIS DESCRIPTOR
          AX6    2           DIV 4
          ERRNZ  60-4*NG.ORDL 
          SB3    A5 
          SA5    X6+B3       ADVANCE TO NEXT GROUP
          EQ     MND20
  
 MND28    SB7    A7+B1
          SA7    A7+B1       COPY MATERIAL DESCRIPTOR WORD
          SX6    A5-B7       (X6) = DISTANCE NEW HOME LAGS OLD ONE
          LX1    WB.MATP+1-WB.PNTP
          IX6    X1-X6       UPDATE GROUP DEFN POINTER IN SYMTAB
          =B7    60/NG.ORDL-2 
          LX6    WB.PNTP
          MX7    -WB.PNTL 
          CLAS=  X4,WB,(MAT)
          SA6    A1 
  
*         PROCESS MEMBER OF GROUP.  IF IT IS AN ARRAY, SET DIM MAT. 
*                (X5) = NEXT MEMBER AT TOP. 
*                (X7) = DIM INDEX EXTRACTION MASK.
*                (B4) = COUNT OF MEMBERS LEFT IN THIS GROUP.
*                (B7) = COUNT OF MEMBERS LEFT IN CURRENT WORD.
  
 MND30    LX5    NG.ORDL
          BX1    -X0*X5      (X1) = SYMORD OF MEMBER
 .T       IFEQ   TEST,ON,1
          ZR     X1,"BLOWUP" IF EMPTY BYTE
          SB2    X1+B5
          LX2    X1,B1
          SA1    B2+X2       SYMTAB (WB.) FOR THIS MEMBER 
          ERRNZ  3-Z=SYM
          BX6    X1+X4       MARK MEMBER MATERIALIZED 
          HX1    WB.ARY 
          SA6    A1 
          PL     X1,MND40    IF NOT ARRAY 
          LX1    -WB.PNTP+WB.ARYP+1 
          BX3    -X7*X1      T.DIM INDEX OF ARRAY 
          SA2    X3+B6       DIM HEADER FOR ARRAY 
          LX4    -WB.MATP+DH.MATP 
          BX6    X2+X4       SET *MAT* BIT
          LX4    -DH.MATP+WB.MATP 
          SA6    A2 
*         IFBIT  X3,DH.ASP,"BLOWUP"      IF ASSUMED-SIZE ARRAY
  
 MND40    =B7    B7-1 
          =B4    B4-1 
          NZ     B7,MND45    IF MORE MEMBERS IN THIS WORD 
          ZR     B4,MND45    IF NO MORE MEMBERS IN THIS GROUP 
          SA5    A5+B1
          SB7    60/NG.ORDL 
          BX7    X5          COPY MATERIAL DESCRIPTOR WORD
          SA7    A7+B1
          MX7    -WB.PNTL 
 MND45    NZ     B4,MND30    IF GROUP HAS MORE MEMBERS
          SA5    A5+1 
          EQ     MND20       LOOP.. 
  
 MND70    SA2    T.NLST 
          SX3    A7+B1       (X3) = LWA+1 MATERIAL DESCRIPTOR SPACE 
          IX6    X3-X2
          SHRINK T=NLST,X6
          EQ     EXIT.
 PJX      SPACE  4,10 
**        PJX - PARSE JUMP EXPRESSION.
* 
*         EVALAUTES JUMP INDEX EXPRESSION FOR RETURN AND GOTO.
*                MODE IS COERCED TO INTEGER.
* 
*         ENTRY  (X6) = SKELETON ADDRESS. 
*                (X7) = OPERAND FOR (2OP).
  
  
 PJX      SUBR   0           ENTRY/EXIT...
          SA1    PJXARM 
          SA6    PJXB 
          SA7    A6-B1
          MX6    0
          BX7    X1 
          SA6    ARGCOMA
          SA7    ARGMODE
          CALL   PAR         PARSE EXPRESSION, EMIT JUMP
          SA1    T=PAR
          BX6    X1          INHIBIT SQUEEZE ACROSS JUMP
          SA6    CURST
          EQ     EXIT.
 C=PJX    SPACE  4,10 
**        C=PJX - PROCESS *EOS* OF COMPUTED *GOTO*. 
* 
*                IF NOT AT *EOS* - COMMA IS ILLEGAL 
  
  
 C=PJX    BSSENT 0           ENTRY... 
          SA2    B4 
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          ZR     X2,PJX4     IF AT *EOS*
          ERRNZ  O.EOS
          WARN   E.GO9
          EQ     C=CERR 
  
 PJX4     BX2    -X0*X5      (X2) = MODE OF EXPRESSION
          =X6    M.INT
          LX5    TP.MODEP 
          IX3    X2-X6
          ZR     X3,PJX8     IF INTEGER EXPRESSION
          ANSI   E.GO6       ** MUST BE INTEGER 
          CALL   CMR         COERCE MODE OF RESULT
          ZR     B7,PJX8     IF MODE CONVERTED OKAY 
          FATAL  B7 
  
 PJX8     SA3    DUC=1ST+OPDUM
          SA2    PJXB 
          BX4    X5          (1OP) = EXPRESSION RESULT
          LX2    SP.SKELP 
          SA5    A2-B1       (2OP) = (PJXA) 
          BX3    X2+X3       FORM (X3) = OPERATOR 
          EQ     POP.STD     EXIT.. 
  
 PJXA     EQU    CLLA        SAVE (2OP) 
 PJXB     EQU    CLLB        SAVE (OPR) 
          ERRNZ  CLLA+1-CLLB
 RIT      SPACE  4,10 
**        RIT - RESET IF TARGET.
* 
*         WHEN THE OBJECT OF A ONE-BRANCH IF IS A RETURN OR 
*         SIMPLE GOTO STATEMENT, THEN THE (ALREADY EMITTED) 
*         IF-TURPLES ARE MODIFIED TO AVOID A DOUBLE JUMP. 
*         DECREMENT (TG.PRO), AS THE FORMER TAG WILL NOT BE USED
*         BY THE ALTERED TURPLES.  CLEAR (INIF) TO KEEP THAT GL FROM
*         BEING DEFINED.
* 
*         ENTRY  (X4) = LABEL TO BRANCH TO (TP. FORM).
*                THE LAST 2 TURPLES CURRENTLY IN (T.PAR) ARE THE
*                            IF MEGA-TURPLE.
*                (IFREL1) = OPPOSITE LOGIC MACRO ADDRESS. 
* 
*         EXIT   (INIF) = 0.
*                (TG.PRO) DECREMENTED.
  
  
 RIT      SUBR               ...ENTRY/EXIT... 
          SA2    N.GL 
          SA3    T.PAR
          SX6    X2-1        RESET (TG.PRO) 
          SA1    T=PAR
          BX7    0
          SA5    IFREL1      OPPOSITE LOGIC MACRO ADDRESS 
          IX0    X3+X1       (X0) = LWA+1 OF (T.PAR)
          SA6    A2 
          MX1    -TH.SKELL
          SA7    INIF 
          SA2    X0-2*Z=TURP+OR.OPR 
          BX7    X4 
          LX2    -TH.SKELP
          BX3    X1*X2       CLEAR OLD MACRO ADDRESS
          BX6    X3+X5       SET OPPOSITE LOGIC 
          SA7    X0-Z=TURP+OR.2OP  RESET JUMP TARGET
          LX6    TH.SKELP 
          SA6    A2 
          EQ     EXIT.
 SER      SPACE  4,10 
**        SER -  COMPILE *END* INSTRUCTIONS.
* 
*         CALLED BY *END* AND *RETURN* STATEMENTS, IF IN MAIN PROGRAM.
* 
*         CALLS  SRJ. 
  
  
 SER      SUBR               ...ENTRY/EXIT... 
          SA5    S=TRACE
          SB6    ESTACK+1 
          LX5    TP.ORDP
          BX6    X5 
          SB5    S.END
          SA6    B6-B1
          RJ     SRJ         EMIT APL AND RJ
          EQ     EXIT.
  
 S.END    =XLIB  END5 
 SPR      SPACE  4,30 
**        SPR - COMPILE TERMINATING/PAUSING INSTRUCTIONS. 
* 
*         CONTAINS COMMON TRANSLATION FOR STOP AND PAUSE. 
*         SEE ANSI 11.12 + 11.13 FOR ARGUMENT DESCRIPTION.
*         THE FIRST ELEMENT AFTER THE KEYWORD MAY BE -- 
*                (A)  EMPTY.
*                (B)  A STRING OF AT MOST 5 DIGITS. 
*                (C)  CHARACTER STRING SURROUNDED BY QUOTES (').
* 
*         EMITS APL TURPLE FOR THE ARGUMENT, FOLLOWED BY STOP OR
*         PAUSE TURPLE.  DIGIT STRING ARGUMENT (CASE B) IS FIRST
*         CHANGED INTO A CHARACTER CONSTANT.
* 
*         ENTRY  (B5) _ NAME OF ROUTINE.
*                (B4) _ FIRST TOKEN AFTER KEYWORD.
* 
*         EXIT   STOP OR PAUSE TURPLE EMITTED.
* 
*         CALLS  ADDWD, ECC, FATAL, SCT, SRJ, WARN. 
  
  
 SPR      SUBR   0           ENTRY/EXIT...
          SA1    B4 
          SB6    ESTACK+1 
          =A2    B4+1 
          ZR     X1,SPR20    IF EOS -- ARGUMENT NOT PRESENT 
          =B2    X1-O.CHAR
          =B3    X1-O.CONS
          ZR     X2,SPR13    IF SECOND TOKEN IS EOS 
          ERRNZ  O.EOS
          WARN   E.SPR4 
 SPR13    ZR     B3,SPR30    IF DIGIT 
          NZ     B2,SPR15    IF NOT CHAR CONSTANT 
          LX1    -TB.SHCP 
          MX0    -TB.SHCL 
          MX7    -TB.CLCNL
          BX2    -X0*X1      CHAR INDEX = SHC [TB ENTRY]
          LX1    TB.SHCP-TB.CLCNP 
          BX1    -X7*X1      CHAR LEN = CLCN [TB ENTRY] 
          EQ     SPR40
  
 SPR15    WARN   E.SPR1      ILLEGAL ARGUMENT 
  
*         NO ARGUMENT CASE -- EMIT ZERO PARAMETER.
  
 SPR20    SA2    CONZER      STACK SHORT CONSTANT OF ZERO 
          BX6    X2 
          SA6    B6-B1
          EQ     SPR60
  
*         HERE IF NUMERIC STRING. 
  
 SPR30    SA1    B4 
          MX0    TB.TOCL
          BX1    X0*X1       EXTRACT DIGITS 
          MX2    5*6
          BX6    -X2*X1 
          ZR     X6,SPR34    IF MORE THAN 5 DIGITS
          WARN   E.SPR2      ** EXCESS DIGITS TRUNCATED 
 SPR34    BX1    X0*X1
          CALL   ZTB         ELIMINATE COLONS 
          SCAN   T.CON,SCT   SCAN FOR DUPLICATE STRING
          SX2    B7+1 
          SX4    5           LENGTH = 5 
          PL     B7,SPR36    IF STRING ALREADY EXISTS 
          ADDWD  A1 
 SPR36    =X2    X2-1 
          BX1    X4 
  
*         HERE IF CHARACTER CONSTANT. 
*                (X1) = CHAR LEN
*                (X2) = CHAR INDEX
  
 SPR40    CALL   ECC         EMIT CHARACTER CONSTANT
 SPR60    RJ     SRJ         COMPILE APL AND RJ 
          EQ     EXIT.
  
 S.PAUSE  =XLIB  PAUS5
 S.STOP   =XLIB  STOP5
 SRJ      SPACE  4,10 
**        SRJ - EMIT APL AND RJ.
* 
*         EMIT CALL TO END, STOP OR PAUSE.
*         NAME OF PROCESSOR ROUTINE IS ENTERED IN SYMTAB. 
* 
*         ENTRY  (B5) _ NAME OF LIBRARY ROUTINE.
*                OPERAND FOR MESSAGE ON TOP OF ESTACK.
* 
*         CALLS  EAL,TAGSEX,ADDWD.
  
  
 SRJ      SUBR   0           ENTRY/EXIT...
          SX7    1+ 
          SA7    CF=AC       INDICATE 1 ARGUMENT
          =A1    B6-1        X1 = ARGUMENT
          =B6    B6-1        POP THE ARGUMENT 
          BX6    X1 
          ADDWD  T.ARG       ARGUMENT IS ON T.ARG 
          SA3    GAPOP
          CALL   EAL         EMIT AP LIST 
          TAGSEX B5          FORM OPERAND FOR ROUTINE 
          BX4    X6          (P1) = ROUTINE 
          SB7    B5-S.PAUSE 
          SX5    B1          (2OP) = 1 ARGUMENT 
          SB3    V=STOP 
          LX5    TP.BIASP 
          NZ     B7,SRJ6     IF NOT *PAUSE* 
          SB3    V=PAUS 
 SRJ6     CALL   EMT         EMIT TURPLE
          EQ     EXIT.
          SPACE  4,10 
          LIST D
          END 
