*DECK     BRIDGE - TRANSMOGRIFY PASS 1 OUTPUT.
          IDENT  BRIDGE 
 BRIDGE   SECT   (TRANSMOGRIFY PASS 1 OUTPUT.)
 DEFINES  TITLE  GLOBAL DATA AND STUCTURE DEFINITIONS.
          SST 
  
          DESCRIBE TS.,60    TURPLE STATUS TABLE ENTRY
 FR       DEFINE 1           FUNCTION RESULT (RNU CONTAINS ST. BIAS)
 FRL      DEFINE 1           LOWER FUNCTION RESULT (RNL=CA) 
 DEF      DEFINE 1           DEFERRED PROCESSING FOR THIS TURPLE
 RTV      DEFINE 1           RIGHT BRANCH VISITED (CHAR WALK) 
 SUB      DEFINE 1           SUBSTRING
          DEFINE 1
 CLEN     DEFINE 18          CHAR OF CHAR EXPRESSIONS 
 RNL      DEFINE 18          R-NUMBER OF LOWER RESULT 
 RNU      DEFINE 18          R-NUMBER OF UPPER RESULT 
  
          REDEF  RNL
 FROM     DEFINE 18          FOR CHAR TREE WALK 
  
  
          DESCRIBE AT.,60    ATF (APLIST TYPE INFO) WORD
 LEN      DEFINE 1           PROCESSING I/O LEN 
 IOC      DEFINE 1           PROCESSING I/O CONTROL CODE
 CHAR     DEFINE 1           CHAR TYPE APLIST FOR ASM 
 NUL      DEFINE 1           THIS ITEM HAS NON-UNITY ARRAY LEN
 LEV0     DEFINE 1           LEVEL 0
 MODE     DEFINE 5
 OPT2     DEFINE 6           HIGH 6 BITS OF AP. FORM
          DEFINE 26 
 RES      DEFINE 17          RESERVED SO IO IS REALLY 18
 IO       DEFINE 1           0/1 NON-I/O / I/O
  
          REDEF  OPT2 
 ST       DEFINE 1           I/O DEF
 USE      DEFINE 1           USE OR POSSIBLE USE
 P1       DEFINE 1           DOUBLE WORD REF
          DEFINE 2
 CR       DEFINE 1           CLASS REF
  
 IODP     DEQU   USE,2
  
          DESCRIBE SC.,60    SKELETON DESCRIPTOR WORD 
          DEFINE 1
 PTYP     DEFINE 5           CALL PARAMETER TYPE
 PNUM     DEFINE 6           CALL PARAMETER NUM 
 MAXT     DEFINE 6
          DEFINE 6
 PRO      DEFINE 18          CALL PROCESSOR ADDRESS 
 AD       DEFINE 18          SET ADDRESS
  
          DESCRIBE SE.,60    SET (SKELETON EXPANSION) WORD
 FI       DEFINE 1           FIRST INSTRUCTION IN SKELETON
 ROP      DEFINE 1           ROUNDABLE OPERATION
          DEFINE 1
 TYP      DEFINE 3           .NZ. IF BRANCH OR CALL 
 OC       DEFINE 9           INSTRUCTION OPCODE 
 1TYP     DEFINE 5
 1NUM     DEFINE 6
 2TYP     DEFINE 5
 2NUM     DEFINE 6
 3TYP     DEFINE 5
 3NUM     DEFINE 6
 Q        DEFINE 12 
  
 BR       DEQU   Q,18        BRANCH ADDRESS 
  
          DESCRIBE SE.,60 
          DEFINE 15 
          DEFINE 4
 PRO      DEFINE 18 
 PTYP     DEFINE 5
 PNUM     DEFINE 6
          DEFINE 12 
  
          DESCRIBE SY.,42    SYMBOL INFO IN PRE 
 IH       DEFINE 18          SYMBOL ORDINAL 
 CA       DEFINE 24          OFFSET OR CONSTANT 
          SPACE  4,8
          DESCRIBE SD.,60 
          DEFINE 24 
 RN       DEFINE 18 
 CA       DEFINE 18 
 ADVIL    SPACE  4,8
**        ADVIL - ADVANCE I.L. POINTER. 
*         USED TO SKIP 1 OR MORE TURPLES AFTER PROCESSING AS PART 
*         OF MEGATURPLE.
* 
*         USES   A2, A7 
  
 ADVIL    MACRO  NUM
          SA2    BP 
          SX7    X2+NUM*Z=TURP
          SA7    A2 
          SA2    INDEX
          SX7    X2+NUM 
          SA7    A2 
          DUP    NUM,1
          ADDWRD TST,B0 
          ENDM
 ISSUE    SPACE  4,8
**        ISSUE - ISSUE OPERATION OR PSEUDO TO PB.
  
 ISSUE    MACRO  OP,TAG 
          =X7    OP 
          LX7    PB.GHIJP 
          IFC    NE,/TAG//,3
          XR=    X5,TAG 
          LX5    PB.TAGP
          BX7    X7+X5
          WCODE  X7 
 ISSUE    ENDM
 XR=      SPACE  4,8
**        XR= - X-REGISTER VERSION OF R= PSEUDO INSTRUCTION.
* 
*         IF *EXPR* = *LDREG*, GENERATES NOTHING. 
*         IF *EXPR* = OTHER X-REG, GENERATES BOOLEAN XMIT TO *LDREG*. 
*         IF *EXPR* = ELSE, GENERATES INCREMENT INSTR TO LOAD *LDREG*.
* 
* 
*         XR=       LDREG,EXPR
* 
*         ENTRY  *LDREG* = X-REGISTER TO BE LOADED.  MUST BE X1 THRU X5.
*                *EXPR*  = ADDRESS EXPRESSION FOR VALUE TO BE LOADED. 
* 
*         USES   *LDREG* AND ITS A-REGISTER.
* 
*         CALLS  NONE 
  
  
          PURGMAC   XR= 
  
 XR=      MACRO  R,E
  LOCAL A 
A MICRO 1,, E 
A MICCNT A
  IFEQ A,2,5
A MICRO 1,1, E
  IFC EQ, "A" X ,3
  IFC NE, R E ,1
  B_R E 
  SKIP 6
A MICRO 2,1, R
  IFC GE, "A" 1 ,3
  IFC LT, "A" 6 ,2
  SA"A" E 
  SKIP 1
  ERR (R) NOT X1-X5 "SEQUENCE"
 XR=      ENDM
 REGS     EJECT 
**        IN RLIST MACROS ONE MAY SPECIFY A SPECIFIC DESTINATION REGISTE
*         FOR THE *RI* OF AN INSTRUCTION BY IMMEDIATELY FOLLOWING IT
*         WITH A REGISTER STORE INSTRUCTION.
*         THE NAMES OF THE REGISTER APPEARS IN THE *SO* FIELD FOLLOWED
*         BY A PERIOD, AND PRECEEDED BY A T ONLY IF IT IS A TEMPORARY 
*         REGISTER STORE. 
  
          ECHO   3,R=(B,X),Z=(0,20B)
          ECHO   2,N=(0,1,2,3,4,5,6,7)
 R_N.     EQU    Z+N
 T_R_N.   EQU    SO.TLOCK+Z+N 
 CFTE     SPACE  3,14 
**        CFTE - CONTROL FLOW TABLE ENTRY MACRO 
* 
*                FROM = BLOCK NUMBER OF *FROM* EDGE 
*                TO = BLOCK NUMBER / *IH* OF TARGET BLOCK 
*                TYPE = *IH* IF *TO* IS AN IH AND THIS IS A JUMP EDGE.
  
 CFTE     MACRO  FROM,TO,TYP
          IFC    EQ,/FROM/CBN/,2
          SA1    =XCBN
          ELSE   1
          R=     X1,FROM
          R=     X2,TO
          LX1    CF.FROMP 
          LX2    CF.TOP 
          IFC    EQ,/TYP/IH/,3
          MX7    1
          LX7    1+CF.JPP 
          BX2    X7+X2
          BX1    X1+X2
          ADDWRD CFT,X1 
          ENDM
 CBN      EQUEXT CC$CBN 
  
 GPBUF    MICRO  1,,/GOVG/
 TP       MICRO  1,,/TP/     FOR COMMON SUBSKEL CODE
 BIAS     MICRO  1,,/BIAS/
 ORD      MICRO  1,,/ORD/ 
 TFILE    MICRO  1,,/=XO$FILE/
 O$       MICRO  1,,/O$/
 L$       MICRO  1,,/L$/
 BT       MICRO  1,,/B4/     TEMP B-REG FOR COMDECKS
 GOV      SPACE  4,10 
 SKU.OP   EQU    6
 SKU.RS   EQU    1
 SKU.GOP  EQU    2
 SKU.TMP  EQU    22 
  
 GOVR     BSSZ   SKU.RS 
 GOVRL    BSSZ   SKU.RS 
  
 GOVT     BSSZ   SKU.TMP     OP TYPE OPERAND BUFFER 
 GOVG     BSSZ   SKU.GOP     GENERATED OPERAND COMMUNICATION AREA 
 PRE      TITLE  INITIALIZATION.
 BRIDGE   SUBR   =
          SX1    =XBN=CODE
          CALL   CG$INIT
          ADDWRD ASG,B0      TERMINATE ASG TABLE FOR SEARCH 
          SA6    =XN$VD      FOR PASS 2 VD. RENUMBERING 
          SA1    =XN.GL 
          ALLOC  GLT,X1 
          SETMEM X2,X3       GLT = 0
          ADDWRD APT,B0      API(0) = 0 
          ADDWRD IOT,B0      IOI(0) = 0 
          ADDWRD CAC,B0      CAC(0) = 0  */ FOR STAPL ENTRIES TO POINT T
  
*         IF ARG=COMMON IS SPECIFIED, USER FUNCTION STORES TO APLIST
*         MUST PRESERVE TYPE FIELD, SO WE SELECT I/O STORE-TO-APLIST
*         SKELETONS FOR USE IN NON-I/O CASES SINCE I/O SKEL PRESERVES 
*         THIS TYPE FIELD.
  
          SA1    =XCO.ARGC
          PL     X1,BRG1     IF ARG=COMMON NOT SET
          SA2    APST 
          BX6    X2 
          SA2    A2+1 
          BX7    X2 
          SA6    APSTR+1     APSTR = APSTR(ARC=C) 
          SA7    APSTR0+1    APSTR0 = APSTR0(ARC=C) 
  
*         SETUP CONSTANT USAGE TABLE FOR CON. SQUEEZING.
  
 BRG1     SA1    =XL$CVT
          ZR     X1,PRE.0    IF NO PASS 1 CONSTANTS 
          ALLOC  CUT,X1 
          SA1    =XNSQZLH    SQUEEZE LONG HOLLERITH FLAG
          SETMEM X2,X3,X1 
  
*         INITIALIZE DATA STRUCTURES
  
          MX6    0
          RJ     INS         FAKE STATEMENT ZERO
 PRE      TITLE  MAIN LOOP. 
*         CLEAR OPERAND BUFFERS.
  
 PRE.0    BSS    0
  
*         PROCESS NEXT TURPLE.
  
 PRE.010  RJ     ROT         READ ONE TURPLE
          MX0    -TH.LINEL
          LX1    -TH.LINEP
          BX6    -X0*X1 
          SB5    A1 
          ZR     X6,PRE.1    IF NOT NEW STATEMENT 
          RJ     INS         INITIALIZE NEW STATEMENT 
  
 PRE.1    ADDWRD TST,B0 
          SA1    B5 
          SA2    INDEX
          SX6    X2+B1
          SA6    A2          INDEX=INDEX+1
          LX1    -TH.SKELP
          MX0    -TH.SKELL
          BX6    -X0*X1 
          SB5    A1          OPR = TURP(1)
          BX0    -X6
          SX5    X0+=XV=NOOP
          ZR     X5,PRE.010  IF *NO-OP* 
  
 SUB.RET  SA5    =XF.SCT+X6  SCI=SCT(OP)
          SA6    PREA        SKOP = OP[OPR] 
          LX5    -SC.ADP
          SB4    X5 
          ZR     B4,PRE.900  IF AD[SCI] = 0 
          SA5    B4          SKAD=AD[SCI] 
          LX5    59-SE.FIP
  
 PRE.300  LX5    SE.FIP-59-SE.TYPP
          MX0    -SE.TYPL 
          BX2    -X0*X5      TY = TYP[INST] 
          SB2    X2 
          ZR     B2,PRE.302  IF INSTRUCTION WORD
          JP     B2+PRE.301-1 
  
 PRE.301  EQ     PRE.500     CALL 
          EQ     PRE.600     BRANCH 
  
 PRE.302  LX5    SE.TYPP-SE.OCP 
          MX0    -SE.OCL
          BX6    -X0*X5      OP=OC[INST]
          RJ     CIR         CONVERT INSTRUCTION TO RLIST 
  
 PRE.899  SA5    B4+B1
          SB4    B4+B1       SKAD=SKAD+1
          LX5    59-SE.FIP
          PL     X5,PRE.300  IF NOT LAST INSTRUCTION OF SKELETON
  
 PRE.900  SA1    PREA 
          SA5    F.SCT+X1 
          LX5    -SC.PROP 
          SB6    X5 
          ZR     B6,PRE.0    IF PRO[SCI] = 0  */ NO END PROCESSING
          SX6    PRE.0
          MX0    -SC.PTYPL
          LX5    SC.PROP-SC.PTYPP 
          BX7    -X0*X5 
          SA7    CTYP 
          MX0    -SC.PNUML
          LX5    SC.PTYPP-SC.PNUMP
          BX7    -X0*X5 
          SA7    CNUM 
          SA6    PREB 
          JP     B6 
  
*         PROCESS CALL. 
  
 PRE.500  LX5    SE.TYPP-SE.PROP
          SB6    X5 
          SX6    PRE.899
          MX0    -SE.PTYPL
          LX5    SE.PROP-SE.PTYPP 
          BX7    -X0*X5 
          SA7    CTYP 
          MX0    -SE.PNUML
          LX5    SE.PTYPP-SE.PNUMP
          BX7    -X0*X5 
          SA7    CNUM 
          SA6    PREB 
          JP     B6 
  
*         PROCESS BRANCH. 
  
 PRE.600  LX5    SE.TYPP-SE.BRP 
          SB4    X5          SKAD=BR[INST]
          SA5    B4          INST=[SKAD]
          LX5    59-SE.FIP
          EQ     PRE.300
  
*         RETURN FROM SPECIAL PROCESSOR.
  
 PRE.RET  SA1    PREB 
          SB6    X1 
          JP     B6 
  
 APST     CON    =XV=IPLG1,=XV=IPLG2
 APSTR    CON    =XV=APSTR,=XV=IPLUG
 APSTR0   CON    =XV=APSTR,=XV=IPLG0
 LL.TXT   CON    4           LOCAL L.TXT
 IND0     CON    0           TURPLE INDEX ORIGIN
 INDEX    CON    -1          INDEX
 PREA     BSSZ   1           SKOP 
 PREB     BSSZ   1           SPECIAL PROCESSOR RETURN ADDRESS 
 CTYP     BSSZ   1           CALL PROCESSOR PARAMETER TYP 
 CNUM     BSSZ   1           CALL PROCESSOR PARAMETER NUM 
 OPT2     BSSENT 1           NON ZERO IF OPT = 2
 CSN      BSSZ   1           CURRENT STATEMENT NUMBER 
 OCIOL    CON    OC$LOO      CONTAINS CURRENTLY PROPER OBJECT-LIST OP.
 INS      TITLE  STATEMENT/SEQUENCE PROCESSING. 
**        INS - INITIALIZE NEW STATEMENT. 
* 
*         ENTRY  X6 = CURRENT LINE NUMBER 
  
 INS      SUBR
          SA6    BOSA 
          RJ     TSP         TERMINATE PREVIOUS STATEMENT 
  
 INS10    SA5    O$TXT
          SA1    BOSA 
          BX6    X1 
          SA4    LL.TXT 
          IX0    X4+X5
          SB7    X5+B1
          SA3    X0-4 
          UX7    B2,X3
          NE     B2,B1,INS20 IF LAST IN TXT NOT *BOS* 
          SA6    CSN         SET LAST STMT NUMBER 
          LX6    R1.INP 
          PX7    B1,X6       OC = OC.BOS
          SA7    A3          OVERWRITE PREVIOUS BOS 
          EQ     EXIT.
  
*         ADD THE *BOS* TO THE SEQUENCE AND CONTINUE
  
 INS20    SA2    LXR
          SX7    X4-12000B
          PL     X7,INS30    IF L.TXT GT 12000B 
          SX7    X4-2000B 
          ZR     X2,INS40    IF NO XTERNAL REFS IN SEQ
          MI     X7,INS40    IF L.TXT LT 2000B
  
*         TERMINATE SEQUENCE AS IT IS GETTING UNMANAGEABLE. 
  
 INS30    MX6    0
          SA6    CC$OPTL     NOT WELL-BEHAVED 
          RJ     PCS         PROCESS SEQUENCE 
          SA2    OPT2 
          SA1    CBN
          ZR     X2,INS10    IF OPT NE 2
          SX6    X1+1        CBN = CBN + 1
          SA6    A1 
          CFTE   X1,X6       FLOW <CBN-1, CBN>
          EQ     INS10
  
 INS40    SA6    CSN
          LX6    R1.INP 
          MX7    0
          =B7    OC.BOS 
          BX5    X6 
          RJ     IRI         ISSUE BOS
          EQ     EXIT.
  
 BOSA     BSSZ   1           TEMPORARY CURRENT STATEMENT NUMBER 
 SEG      SPACE  4,8
**        P=SEG - RESET TURPLE COUNTERS.
*         NEXT TURPLE IS ZERO.
  
 P=SEG    BSSENT 0
          MX6    0
          SA6    IND0 
          MX6    -1 
          SA6    INDEX
          RJ     TSP
          EQ     PRE.RET
 TSP      EJECT 
**        TSP - TERMINATE STATEMENT PROCESSING. 
*         REORDERS BUFFERS FOR NEXT STATEMENT PROCESSING OR PCS CALL. 
  
 TSP      SUBR
          SA1    LL.TXT 
          BX6    X1 
          SA6    TXT0        MARK START OF NEXT STATEMENT TXT 
          SA1    IND0 
          SA2    INDEX
          IX6    X1+X2
          SX6    X6+B1
          MX7    -1 
          SA6    A1          IND0 = IND0 + INDEX + 1
          SA7    A2          INDEX = -1 
          MX7    0
          SA7    =XL$TST     L.TST=0
          SA2    =XN.STMAX
          SA1    N.ST 
          MX6    X1+X2
          SA7    A1          N.ST = 0 
          SA6    A2          N.STMAX = MAX (N.ST, N.STMAX)
          SA7    =XL$DTT     L.DTT = 0
          EQ     TSP
  
 TXT0     CON    4           TXT POINTER FOR START OF THIS STATEMENT
 PCS      EJECT 
**        PCS - PROCESS CURRENT SEQUENCE. 
  
 PCS      SUBR
          RJ     TSP         TERMINATE STATEMENT
          SX0    B4 
          SX7    B5 
          LX0    18 
          BX7    X7+X0
          SA7    PCSA 
          SA1    LL.TXT 
          BX7    X1 
          SX6    X1-4 
          SA7    L$TXT       L.TXT = LL.TXT  */PREPARE FOR PAS
          SA6    =XCC$BRN+1  LAST R-NUMBER = L.TXT-4
          RJ     IST         ISSUE STORES TO TEMPS. 
          CALL   CG$PAS 
          SA1    PCSA 
          SB5    X1 
          AX1    18 
          SB4    X1 
          SX7    4
          SA7    TXT0        MARK START OF TXT FOR THIS STATEMENT 
          SA7    LL.TXT 
          SA1    LALS        LOOP ACTIVE STACK LENGTH (NEST DEPTH)
          MX7    0
          BX6    X1 
          SA6    =XCC$LNL 
          SA7    LXR
          EQ     EXIT.
  
 PCSA     BSSZ   1
 LALS     BSSZ   1           LOOP ACTIVE STACK LENGTH 
 IST      EJECT 
**        IST - ISSUE STATEMENT TEMPORARY STORES. 
  
 IST      SUBR
          SA1    =XL$FUN
          ZR     X1,EXIT.    IF NO STORES FLAGGED 
          SA2    =XO$FUN
          SB6    B0 
          MX0    60 
          =X5    0
          SB7    X2 
          CALL   SST# 
          SA1    L$FUN
          LX1    2
          ALLOC  TXT,X1      ALLOC FOR STORES 
          SA1    O$FUN
          SA0    X1-1 
          SB5    X2          O$TXT
          SA1    L$FUN
          MX7    0
          SA7    A1 
          SB2    X3-4        IND = L$TXT
          SB6    X1          I = L$FUN  */NUMBER OF STORES TO INSERT
  
 IST10    ZR     B6,EXIT.    IF I EQ 0
          SA4    A0+B6       INST = FUN(I)
          BX0    X4 
          LX4    -SD.RNP     RNC = RN[INST] 
          SB3    X4+4        RNN = RNC + 1
          SX4    B6 
          LX4    2
          SB4    B3+X4
          GT     B4,B2,IST20 IF RNN+I GT IND
          SX2    B5+B3
          IX3    X2+X4
          SB4    B4-4 
          SX1    B2-B4
          MOVE   X1,X2,X3 
          SB2    B4          IND = RNN+I-4
  
 IST20    SA3    =XS=ST 
          SX4    X0 
          LX3    IH.IHP 
          LX4    IH.CAP 
          BX6    X3+X4
          SB3    OC.ST
          AX0    SD.RNP 
          LX0    R1.RIP 
          SA3    =XF$RDT+OC.ST
          PX7    B3,X0
          SA7    B5+B2
          SA6    A7+B1
          BX7    X3 
          MX6    0
          SA7    A6+B1
          SA6    A7+B1
          SB6    B6-B1       I = I-1
          SB2    B2-4        IND = IND - 1
          EQ     IST10
 CIR      TITLE  INSTRUCTION PROCESSING ROUTINES. 
**        CIR - CONVERT INSTRUCTION TO RLIST. 
* 
*         ENTRY  X6 = OPCODE
*                B4 _ CURRENT SET ENTRY 
*                B5 _ CURRENT TURPLE OPERATOR WORD
* 
*         EXIT  B4,B5 PRESERVED 
* 
 NOV      MACRO  N,X
          SA5    B4 
          MX0    -SE.N_TYPL 
          LX5    -SE.N_TYPP 
          BX1    -X0*X5 
          MX0    -SE.N_NUML 
          LX5    SE.N_TYPP-SE.N_NUMP
          BX2    -X0*X5 
          RJ     GOV
          IFC    EQ,/X//,1
          SA6    CIRV+N-1 
          ENDM
 CIR0     SA1    CIRA 
          SB7    X1 
          RJ     IRI         ISSUE RLIST INSTRUCTION (OC,VAL) 
  
 CIR      SUBR
          SA6    CIRA 
          SA1    =XF$RDT+X6 
          BX7    -X1
          HX7    D.^D 
          SA7    CIRB        SAVE RI FIELD DEFINED PROPERTY 
          LX1    59-D.TYP-1 
          LX2    B1,X1
          MI     X1,CIR1     IF TY[DESCR(OC)] .GE. 2  */  TYPE > 2
* 
*         PROCESS TYPE 1 AND 2 RLIST. 
  
          NOV    3           VAL(3) = RK/SO 
          SX7    4
          SA7    RJOFF       MARK ANY R-NUMBER DEFINED AS RI+4
  
*         SET DEF TO INDICATE RK FIELD DEFINED IF THIS IS 
*         NORMALIZE OR PACK INSTRUCTION.
  
          SA1    CIRA 
          SB2    X1-OC.NR 
          SB3    X1-OC.UP-1 
          MI     B2,CIR05    IF NOT NORMALIZE OR PACK 
          PL     B3,CIR05    DITTO
          MX7    1           SET DEF THIS FIELD 
          SA7    DEF
  
 CIR05    NOV    2           VAL(2) = RJ/IN 
          SA1    CIRB 
          BX7    X1 
          SA7    DEF
          =X7    0
          SA7    RJOFF
          NOV    1,X6        VAL(1) = RI
          SA1    CIRA 
          SA2    F$RDT+X1 
          LX2    59-D.TYP 
          SA5    CIRV+1 
          MX7    0
          SA7    DEF
          SA4    A5+B1
          MI     X2,CIR1A    IF TYPE = 2
          LX5    R1.RJP-R1.RKP
          BX3    X4+X5
          LX3    R1.RKP 
          LX6    R1.RIP 
          BX5    X6+X3
          EQ     CIR0 
  
 CIR1A    LX5    R1.INP-R1.SOP
          BX3    X4+X5
          LX3    R1.SOP 
          LX6    R1.RIP 
          BX5    X6+X3
          EQ     CIR0 
  
*         PROCESS TYPE 3 RLIST. 
  
 CIR1     MI     X2,CIR3     IF TYPE = 4
          SB2    X6 
          SB3    B2-OC.ST 
          ZR     B3,CIR2     IF STORE 
  
          NOV    3           IH/CA
          NOV    2,X6        RF 
          SA1    CIRV+2      IH/CA
          BX5    X6 
          MX0    -SY.CAL
          LX1    -SY.CAP
          BX0    -X0*X1 
          RJ     ACA         ADJUST LONG CA (ISSUE LDC, IA) 
          SA3    CIRV+2 
          BX6    X5 
          SA6    CIRV+1      RF = RFNEW 
          LX0    SY.CAP 
          MX1    -SY.CAL
          LX1    SY.CAP 
          BX6    X1*X3       CLEAR OLD CA 
          BX7    X6+X0       CA = CANEW 
          SA7    A3 
          SA1    CIRB 
          BX7    X1 
          SA7    DEF
          NOV    1,X6        VAL(1) = RI
          MX7    0
          SA7    DEF
          SA1    CIRV+2 
          BX5    X6 
          MX0    -IH.CAL
          LX1    -SY.CAP
          BX6    -X0*X1 
          AX1    SY.IHP 
          SA4    CIRA 
          SA3    CIRV+1 
          LX1    IH.IHP 
          SB6    X4-OC.JPX
          LX6    IH.CAP 
          BX0    X1+X6
          ZR     B6,CIR15    IF X-JUMP  */ FIELD2 IS FOR CA 
          LX3    IH.RFP 
          BX7    X0+X3
          EQ     CIR0 
  
 CIR15    LX3    IH.CAP 
          BX7    X0+X3
          EQ     CIR0 
  
*         PROCESS STORE.
  
 CIR2     NOV    2,X6        ISSUE XMIT AS RJ 
          MX7    0
          LX6    R1.RJP 
          SA5    LL.TXT 
          LX5    R1.RIP 
          BX5    X5+X6
          SB7    OC.XMT 
          RJ     IRI         ISSUE RLIST INSTRUCTION (OC.XMT,VAL) 
          SX6    B1 
          SA6    SMF         SET STORE MODE 
  
          NOV    1,X6 
          MX6    0
          SA6    SMF         CLEAR STORE MODE 
          EQ     CIR
  
*         PROCESS TYPE 4. 
  
 CIR3     NOV    3,X6        VAL(3) = IH
          MX7    0
          LX6    R1.IHP-SY.IHP
          BX5    X6 
          EQ     CIR0 
  
 SMF      BSSZ   1           STORE MODE FLAG
 CIRV     BSS    4           PARAMETER VALUES FOR IRI 
 CIRA     BSS    1           OP CODE
 CIRB     BSSZ   1
 DEF      BSSZ   1           THIS FIELD DEFINED (FOR GOV) 
 RJOFF    BSSZ   1           RJ FIELD OFFSET
 GOV      EJECT 
**        GOV - GET OPERAND VALUE.
* 
*         ENTRY  X1 = OPERAND TYPE
*                X2 = OPERAND NUM 
* 
*         EXIT   X6 = OPERAND VALUE (R-NUMBER OR IMMEDIATE FIELD VALUE) 
* 
*         PRESERVES  B4,B5
  
          PURGMAC SKOP
  
          MACRO  SKOP,OP,NOTLAST,LAST,FTYP,OPEQ 
          IFC    EQ, OPEQ  ,1 
          CON    GOV.OP 
          ENDM
  
 GOV      SUBR
          SA5    GOV.JT+X1
          SA4    INDEX
          MX6    0           GOV = 0
          SB3    X5 
          SB2    X2 
          SB7    X4 
          SA5    DEF
          JP     B3 
 GOV.JT   BSS    0
  
          LOC    0
          LIST   -X,G 
  
          CON    GOV         NULL OPERAND 
*CALL     SKOP   SKELETON OPERAND JUMP TABLE
  
          LIST   *
          LOC    *O 
  
 GOV.A    BSS    0
 GOV.B    BSS    0
 GOV.X    EQ     "BLOWUP" 
  
 GOV.L    BSS    0
 GOV.LU   SB6    B0 
          SA4    B5+B2       O = OPD(NUM) 
          RJ     LOP         LOAD OPERAND 
          EQ     GOV
  
 GOV.LL   SB6    B1 
          SA4    B5+B2       O = OPD(NUM) 
          RJ     LOP         LOAD OPERAND 
          EQ     GOV
  
 GOV.P    SA1    B5+B2       O = OPD(NUM) 
          RJ     GLT         GET SYMBOL/LABEL TAG 
  
 GOVP1    LX3    SY.IHP 
          LX4    SY.CAP 
          BX6    X4+X3       GOV=IHCA[O]
          EQ     GOV
  
 GOV.R    BSS    0
 GOV.RU   SA2    LL.TXT 
          BX6    X2 
          SA2    =XO$TST
          LX6    TS.RNUP
          SA3    X2+B7
          BX7    X6+X3
          SA7    A3          RNU[TST(INDEX)] = LL.TXT 
          LX6    -TS.RNUP    GOV = LL.TXT 
          EQ     GOV
  
 GOV.RL   SA2    LL.TXT 
          BX6    X2 
          SA2    =XO$TST
          LX6    TS.RNLP
          SA3    X2+B7
          BX7    X6+X3
          SA7    A3          RNL[TST(INDEX)] = LL.TXT 
          LX6    -TS.RNLP    GOV = LL.TXT 
          EQ     GOV
  
  
 GOV.T    SA1    GOVT+B2
          BX6    X1 
          PL     X5,GOV      IF FIELD NOT DEFINED HERE, GOV=T(NUM)
          SA4    RJOFF
          SA3    LL.TXT 
          IX6    X3+X4
          SA6    A1          GOV = T(NUM) = LL.TXT + RJOFFSET 
          EQ     GOV
  
 GOV.Q    SA5    B4 
          SX5    X5 
          MX0    -SY.CAL
          BX6    -X0*X5 
          LX6    SY.CAP 
          EQ     GOV
  
 GOV.K    SX6    B2 
          EQ     GOV
  
 GOV.S    SA5    B4 
          SA1    X5 
          BX6    X1 
          LX6    SY.IHP 
          EQ     GOV
  
 GOV.GLU  BSS    0
 GOV.GL   SB6    B0 
          SA4    GOVG+B2
          RJ     LOP
          EQ     GOV
  
 GOV.GLL  SB6    B1 
          SA4    GOVG+B2
          RJ     LOP
          EQ     GOV
  
 GOV.GP   SA1    GOVG+B2
          RJ     GLT         GET SYMBOL/LABEL TAG 
          EQ     GOVP1
 LOP      EJECT 
**        LOP - LOAD OPERAND. 
*         ISSUES LOAD OR STORE OR SET OF OPERAND. 
* 
*         ENTRY  X4 = OPERAND 
*                B6 = LOW, LOWER HALF FLAG
* 
*         EXIT   X6 = R-NUMBER OF OPERAND 
* 
*         PRESERVES          B2,B4,B5 
  
 LOPE     SA1    LOPA 
          SB2    X1+
          MX7    0
          SA7    SMF
  
 LOP      SUBR
          SX6    B2 
          SA6    LOPA 
          SA3    SMF
          =X0    1S1
          BX1    X4          FOR GLT
          LX4    -TP.ADDRP+1
          BX5    X0*X4
          BX0    X3+X5
          SA5    LL.TXT 
          LX5    R1.RIP      RI = LL.TXT
  
*         SELECT OC.LD/ST/STT 
  
          SB7    OC.LD+X0    OPC = OC.LD + (2*ADDR[O]+SMF)
          LX4    TP.ADDRP-1+59-TP.SHRTP 
          PL     X4,LOP1     IF ^SHRT[O]   IF NOT SHORT CONSTANT
  
          SB7    OC.S        OPC = OC.S 
          MX0    -SY.CAL
          LX4    TP.SHRTP-59-TP.BIASP+60
          BX6    -X0*X4 
          SX4    X6-0 
          MX7    0
          PL     X4,LOP05    IF CONSTANT POSITIVE 
          ZR     X4,LOP07    IF -0
  
 LOP05    LX6    R1.INP 
          BX5    X5+X6
          RJ     IRI         ISSUE (S,VAL)
          MX0    -R1.RIL
          LX5    -R1.RIP
          BX6    -X0*X5 
          EQ     LOPE 
  
 LOP07    SX6    60 
          SB7    OC.FMA 
          EQ     LOP05       ISSUE MASK(60) 
  
 LOP1     LX4    TP.SHRTP-TP.INTRP
          MI     X4,LOP2     IF INTR[O]   IF INTERMEDIATE OPERAND 
          RJ     GLT         GET LABEL/SYMBOL TAG 
          SA2    S=CON
          BX2    X2-X3
          NZ     X2,LOP15    IF NOT CONSTANT LOAD 
          SB7    OC.LDC 
          EQ     LOP16
  
 LOP15    SA2    =XS$VD 
          BX6    X2-X3
          NZ     X6,LOP16    IF NOT VARDIM LOAD 
          SB3    B7-OC.LD 
          NZ     B3,LOP16    IF NOT LOAD
          SB7    OC.LDV 
  
  
 LOP16    BX6    X3 
          LX6    18 
          SX3    B7 
          BX6    X3+X6
          SA6    LOPC 
          SA3    SMF
          SX5    X5-4 
          LX3    -1 
          AX3    59 
          BX6    X3*X5
          SA6    LOPB        RI IFF STORE 
          SX2    B6 
          IX0    X4+X2       CA = CA[ORD[O]] + LOW
          MX5    0           RF = 0 
          RJ     ACA         ADJUST LONG CA 
          SA3    LOPC 
          SB7    X3 
          AX3    18 
          LX3    IH.IHP 
          MX6    -IH.CAL
          BX0    -X6*X0 
          LX5    IH.RFP 
          BX3    X3+X5
          LX0    IH.CAP 
          SA5    LOPB 
          BX7    X3+X0
          NZ     X5,LOP17    IF STORE 
          SA5    LL.TXT      RI = LL.TXT
  
 LOP17    RJ     IRI         ISSUE OPC,RI,IH,CA,RF
          LX5    -R1.RIP
          BX6    X5 
          EQ     LOPE 
  
 LOP2     SA2    IND0 
          MX0    -TP.ORDL 
          LX4    TP.INTRP-59-TP.ORDP+60 
          BX6    -X0*X4 
          IX3    X6-X2
          SX1    B7 
          SB7    X3          IND = ORD[O] - IND0
          LX4    TP.ORDP+59-TP.ARYP-60
          PL     X4,LOP3     IF ^ARY[O] 
          MX7    0
          SA7    SMF         CLEAR STORE MODE 
          RJ     GAR         GENERATE ARRAY LOAD(IND) 
          EQ     LOPE 
  
 LOP3     RJ     LIR         LOAD INTERMEDIATE RESULT (IND) 
          EQ     LOPE 
  
 LOPA     BSS    1
 LOPB     BSS    1
 LOPC     BSS    1
 ACA      EJECT 
**        ACA - ADJUST CA.
*         IF ABS(CA) .GT. 377777B, ACA ISSUES LOAD OF CONSTANT AND
*         ADD TO RF (INDEX) IF PRESENT. 
* 
*         ENTRY  X0 = CA, 24-BIT SIGNED 
*                X5 = RF
* 
*         EXIT   X0 = NEW CA (OLD CA OR 0)
*                X5 = NEW RF (OLD RF OR RI OF LAST INSTRUCTION) 
  
 ACA      SUBR
          SB3    59-23
          LX6    B3,X0
          AX6    59-23+17 
          ZR     X6,EXIT.    IF CA NOT LONG 
          LX1    B3,X0
          AX1    B3          SIGN EXTEND CA 
          CALL   CG$SCT      ENTER CA INTO CON. 
          BX7    X5 
          SA7    ACAA        SAVE RF
          SB7    OC.LDC 
          SA2    =XS=CON     IH = CON.
          SA5    LL.TXT      RI = LL.TXT
          LX5    R1.RIP 
          LX6    IH.CAP      CA = CON. ORDINAL
          LX2    IH.IHP 
          BX7    X6+X2
          RJ     IRI         ISSUE LDC RI,CON.,CA 
          SA1    ACAA 
          MX0    0           NEWCA = 0
          ZR     X1,EXIT.    IF NO RF 
          LX5    -R1.RIP
          SX6    X5+4        RI = RI(LDC) + 4 
          LX5    R1.RJP-R1.RIP     RJ = RI(LDC) 
          LX6    R1.RIP 
          BX6    X6+X5
          LX1    R1.RKP      RK = OLD RF
          SB7    OC.IA
          MX7    0
          BX5    X6+X1
          RJ     IRI         ISSUE IA RI,RJ,RK
          MX0    0           CA = 0 
          MX6    -R1.RIL
          LX5    -R1.RIP
          BX5    -X6*X5      NEW RF = RI
          EQ     EXIT.
  
 ACAA     BSS    1
  
  
 IRI      EJECT 
*         IRI - ISSUE RLIST INSTRUCTION.
* 
*         ENTRY  X5 = WORD 1 (LESS OPCODE)
*                X7 = WORD 2
*                B7 = OP CODE 
* 
*         EXIT   X5,X7 PRESERVED
* 
*         PRESERVES B4,B5 
  
  
 IRI      SUBR
          SA1    LL.TXT 
          SA3    =XL$TXT
          SX6    X1+4 
          IX0    X3-X6
          SA6    A1          LL.TXT = LL.TXT + 4
          PL     X0,IRI1     IF LOCAL L.TXT (LL.TXT) .LE. L.TXT 
          BX0    X7 
          ALLOC  TXT,200B 
          SA3    LL.TXT 
          BX6    X3 
          BX7    X0 
  
 IRI1     SA3    F$RDT+B7 
          SA4    =XO$TXT
          IX1    X4+X6
          MX6    0
          SA6    X1-1        RLIST(4) = 0 
          BX6    X3 
          SA6    A6-B1       RLIST(3) = DES(OC) 
          PX6    B7,X5
          SA7    A6-B1       RLIST(2) = R2W 
          SA6    A7-B1       RLIST(1) = (OC,R1W)
          EQ     EXIT.
 LIR      EJECT 
**        LIR    LOAD INTERMEDIATE RESULT.
*         ENTRY  B6 = LOW (0=UPPER, 1=LOWER)
*                B7 = INDEX 
* 
*         EXIT   X6 = R-NUMBER OF INT.
  
 LIR      SUBR
          SA1    =XO$TST
          SB2    59-TS.FRP+B6 
          ERRNZ  TS.FRP-TS.FRLP-1 
          SA2    X1+B7
          LX0    B2,X2
          MI     X0,LIR05    IF ALREADY STORED OUT
          SB2    X2 
          SA1    LXR
          SB3    X1 
          SB3    B2-B3
          PL     B3,LIR1     IF RN LT LXR   */ INT NOT DEFINED BEFORE RJ
  
 LIR05    RJ     STR         STORE INTERMEDIATE RESULT
          SA5    LL.TXT 
          LX5    R1.RIP      RI = LL.TXT
          SA1    =XS=ST 
          LX1    IH.IHP 
          LX2    IH.CAP 
          BX7    X1+X2
          SB7    OC.LD
          RJ     IRI         ISSUE FUNCTION RESULT LOAD 
          LX5    -R1.RIP
          BX6    X5          LIR = RI 
          EQ     LIR
  
*         NOT FUNCTION RESULT. GET R-NUMBER FROM TST. 
  
 LIR1     NZ     B6,LIR2     IF LOWER 
          LX2    -TS.RNUP 
          SX6    X2 
          EQ     LIR         LIR = RNU[TST(INDEX)]
  
 LIR2     LX2    -TS.RNLP 
          SX6    X2 
          EQ     LIR         LIR = RNL[TST(INDEX)]
 SDT      SPACE  4,8
**        SDT - STORE DOUBLE WORD TEMP. 
* 
*         ENTRY AND EXIT SAME AS STR
  
 SDT      SUBR
          SA1    B5 
          MX0    -TH.MODEL
          LX1    -TH.MODEP
          BX0    -X0*X1 
          SB2    X0-M.DBL 
          ZR     B2,SDT10    IF DOUBLE
          EQ     B2,B1,SDT10 IF COMPLEX 
          RJ     STR         SINGLE WORD
          EQ     EXIT.
  
 SDT10    SA1    O$TST
          SA1    X1+B7
          HX1    TS.FR
          MX0    2
          BX0    X0*X1
          LX0    2
          BX6    X1 
          LX1    1+TS.FRP-TS.RNUP 
          SX2    X1          UPPER RN/ST. CA
          LX1    TS.RNUP-TS.RNLP
          SX3    X1          LOWER RN/ST. CA
          SB2    SDT.JT+X0
          JP     B2 
  
 SDT.JT   EQ     SDT20       NEITHER STORED 
          EQ     SDT30       LOWER STORED 
          EQ     SDT40       UPPER STORED 
          EQ     SDT50       BOTH STORED
  
 SDT20    RJ     STR         STORE UPPER
 SDT21    SB6    1
          RJ     STR         STORE LOWER
          SX2    X2-1        CA OF UPPER
          EQ     EXIT.
  
 SDT30    CLAS=  X1,TS,(FRL,RNL)
          BX6    -X1*X6 
          SB2    X3 
          RJ     SFT
          LX1    TS.RNLP
          BX6    X6+X1       RESTORE LOWER R-NUMBER 
          SA6    A1 
          EQ     SDT20
  
 SDT40    SA1    N.ST 
          IX3    X1-X2
          SB2    X3 
          EQ     B2,B1,SDT21 IF NEXT ST. AVAIL. 
          CLAS=  X1,TS,(FR,RNU) 
          BX6    -X1*X6 
          SB2    X2 
          RJ     SFT
          LX1    TS.RNUP
          BX6    X6+X1       RESTORE UPPER R-NUMBER 
          SA6    A1 
          EQ     SDT20
  
 SDT50    IX0    X3-X2
          SB2    X0 
          EQ     B2,B1,EXIT. IF UPPER/LOWER CONTIGUOUS
          CLAS=  X1,TS,(FRL,RNL)
          BX6    -X1*X6 
          SB2    X3 
          RJ     SFT
          LX1    TS.RNLP
          BX6    X6+X1       RESTORE LOWER R-NUMBER 
          SA6    A1 
          EQ     SDT40
 SFT      SPACE  4,8
**        SFT - SCAN FOR TEMPORARY'S PREDECESSOR. 
*         ENTRY  B2 = CA OF ST. CELL
* 
*         EXIT   X1 = R-NUMBER WHICH WAS STORED INTO ST. + CA 
  
 SFT      SUBR
          SA4    =XO$FUN
          SB2    -B2
          SA5    X4-1 
  
 SFT10    =A5    A5+1 
          LX5    -SD.CAP
          SX0    X5+B2
          NZ     X0,SFT10    IF THIS IS NOT DESIRED CA
          LX5    SD.CAP-SD.RNP
          SX1    X5          SFT = RN[FUN(I)] 
          EQ     EXIT.
          SPACE  4,8
**        STR - STORE TEMP RESULT.
* 
*         ENTRY  B6 = LOW 
*                B7 = INDEX 
* 
*         EXIT   X2 = CA
  
 STR      SUBR
          SA1    =XO$TST
          SA3    X1+B7
          SA1    STRA+B6
          SB3    X1 
          LX4    B3,X3
          SB2    59-TS.FRP+B6 
          LX0    B2,X3
          SX2    X4          STR = RNU/RNL[TST(INDEX)]
          MI     X0,EXIT.    IF FR/FRL[TST(INDEX)]  */ ALREADY STORED 
          SA5    =XN.ST 
          MX0    1
          SB2    -B6
          SB2    1+TS.FRP+B2
          LX0    B2 
          MX6    -TS.RNUL 
          BX3    X6*X4
          BX1    X5+X3
          SB3    -B3
          SB3    60+B3
          LX1    B3 
          BX6    X0+X1
          SA6    A3          RNU/RNL[TST(INDEX)] = N.ST, FR/FRL = 1 
  
*         ISSUE STORE INSERTION CONTROL WORD(S).
  
          SX7    X2 
          LX7    SD.RNP 
          ERRNZ  SD.CAP 
          BX1    X7+X5
          BX0    X3 
          ADDWRD FUN,X1 
          BX2    X5 
          SX7    X5+B1
          SA7    A5          N.ST = N.ST + 1
          EQ     EXIT.
  
 STRA     CON    60-TS.RNUP,60-TS.RNLP
          SPACE  4,8
 GAR      EJECT 
* 
*         ENTRY  X1 = OPCODE (LD/ST/STT)
*                B6 = LOW (0=UPPER, 1=LOWER)
*                B7 = IND, INDEX OF TST ENTRY OF TURPLE TO EXPAND 
* 
*         EXIT   X5 = R1 WORD OF REFERENCE. 
*                X6 = R-NUMBER OF REFERENCE.
*                X7 = R2 WORD OF REFERENCE. 
  
 GAR      SUBR
          SX7    B6 
          SA7    GARA 
          SA2    =XO$TST
          BX6    X1 
          SA3    X2+B7       T = TST(IND) 
          SA6    GARB 
          LX3    -TS.RNUP 
          SA1    =XO$DTT
          SB2    X3+B1
          SA4    X1+B2       OP1 = DTT(2,RNU[TST(IND)]) 
          BX7    X4 
          SA4    A4+B1       OP2 = DTT(3,RNU[TST(IND)]) 
          SA7    GARC 
          SA5    LL.TXT 
          SX7    X5-4 
          LX7    R1.RIP 
          SA7    GARD        RIS = LL.ISB - 3 
 .ARY     SKIP               RESTORE IF SUBSCRIPTED SUBSCRIPTS OUTPUT 
          CLAS=  X1,TP,(ARY,INTR) 
          BX0    X1*X4
          BX1    X0-X1
          NZ     X1,GAR10    IF NOT A(B(I)) 
  
*         INNER ARRAY LOAD ALREADY ISSUED.  R-NUMBER IN BIAS. 
  
          MX0    -TP.BIASL
          LX4    -TP.BIASP
          BX7    -X0*X4 
          EQ     GAR20
 .ARY     ENDIF 
  
*         GAR MAY HAVE BEEN CALLED FROM LOP, SO PRESERVE EXIT.
  
 .ARY     SKIP               RESTORE IF SUBSCRIPTED SUBSCRIPTS OUTPUT 
 GAR10    BSS    0
 .ARY     ENDIF 
          SA1    LOP
          =B6    0
          BX6    X1 
          SA6    GARE 
          SA1    LOPA 
          SB2    X1+         MUST PRESERVE ORIGINAL B2 FROM LOP 
          RJ     LOP         LOAD INDEX FUNCTION
          SA1    GARE 
          BX7    X1 
          SA7    LOP
          BX7    X6 
  
 GAR20    SA1    GARC 
          RJ     GLT         GET SYMBOL TAG 
          BX6    X3 
          SA6    GARE 
          SA5    GARA 
          LX4    59-23
          AX4    59-23
          MX0    -SY.CAL
          IX1    X4+X5       CA = BIAS + LOW
          BX5    X7 
          BX0    -X0*X1 
          RJ     ACA         ADJUST LONG CA 
          SA2    GARB 
          LX5    IH.RFP 
          BX7    X5 
          MX6    -IH.CAL
          BX5    -X6*X0 
          LX5    IH.CAP 
          SA3    GARE 
          LX3    IH.IHP 
          BX4    X5+X3
          BX7    X4+X7
          SB7    X2 
          SA5    LL.TXT 
          LX5    R1.RIP 
          SB2    B7-OC.ST 
          NZ     B2,GAR3     IF ^STORE
          SA5    GARD        RI = RIS 
  
 GAR3     RJ     IRI         ISSUE (OP,RI,RF,ORD[OP1],BIAS[OP1]+LOW 
          BX6    X5 
          EQ     GAR
  
 GARA     BSS    1
 GARB     BSS    1
 GARC     BSS    1
 GARD     BSS    1
 GARE     BSS    1
 ROT      TITLE  TURPLE INPUT ROUTINES. 
**        ROT - READ ONE TURPLE.
* 
*         EXIT   X1 = OPERATOR WORD.
*                A1 _ OPERAOR WORD. 
*                4 TURPLES PLUS 1 WORD GUARANTEED IN CORE.
  
 ROT      SUBR
          SA2    BP 
          SA1    RLBL+X2
          SX7    X2+4*Z=TURP
          SX6    X2+Z=TURP
          SA6    A2 
          MI     X7,ROT      IF ANOTHER 4 TURPLES IN THE BUFFER 
          BX1    -X2
          LX5    X6          PRESERVE MOVE BIAS 
          SX3    RLB+X2      NUMBER OF WORDS IN BUFFER
          ZR     X1,ROT10    IF NOTHING IN BUFFER TO MOVE DOWN
          MOVE   X1,RLBL+X2,X3
  
 ROT10    RJ     RFB         REFILL BUFFER
          SA1    BP 
          IX6    X5+X1       ADJUST BP TO ACCOUNT FOR MOVED IL
          SA6    A1 
          SA1    X6+RLBL-Z=TURP 
          EQ     ROT
  
 ROTA     BSSZ   1
 ROW      SPACE  3,8         ROW
**        ROW - READ ONE WORD OF IL FROM BUFFER/*RLB* 
 ROW      SUBR
          SA2    BP 
          SA1    RLBL+X2     FETCH WORD 
          SX6    X2+B1       ADVANCE BUFFER POINTER 
          SA6    A2 
          MI     X2,ROW      IF WORD WAS FROM THE BUFFER
          RJ     RFB         REFILL THE BUFFER
          SA2    BP 
          SA1    RLBL+X2
          SX6    X2+B1       ADVANCE BUFFER INDEX 
          SA6    A2 
          EQ     ROW
 RFB      SPACE  3           RFB
**        RFB - REFILL BUFFER 
  
 RFB      SUBR
          SX6    -L.RLB 
          SA6    BP 
          BX4    -X6
          SX1    B6 
          SX2    B5 
          SX3    B4 
          LX1    18 
          LX2    18+18
          BX0    X1+X2
          BX7    X0+X3
          SA7    RFBA 
          READW  =XF.IL,RLBL+X6,X4  REFILL BUFFER 
          SA2    RFBA 
          SB4    X2 
          AX2    18 
          SB6    X2 
          AX2    18 
          SB5    X2 
          EQ     RFB
  
 RFBA     BSS    1
 L.RLB    EQU    200
 BUFFER   BSS    4*Z=TURP    MUST PRECEDE RLB 
 RLB      BSS    L.RLB
 RLBL     BSS    0
 BP       CON    0
 HDR      TITLE  SPECIAL PROCESSING ROUTINES (*CALL*) 
**        HDR - HEADER TURPLE PROCESSOR.
*         ISSUE IDENT AND TRACE INFORMATION.
  
 P=HDR    BSSENT 0
          ISSUE  OC$IDNT
          SA4    =XMOD
          HX4    MO.BLK 
          MI     X4,PRE.RET  IF BLOCK DATA
          ISSUE  OC$TRAC
          LX4    MO.BLKP-MO.PROP
          SA1    =XS=UPW
          PL     X4,PRE.RET  IF NOT MAIN PROGRAM
          ZR     X1,PRE.RET  IF NO FILE ARGUMENTS 
          ISSUE  OC$BSS,X1   UPW.  BSS 0
          SA2    =XNARGS
          SX7    X2+B1
          LX1    X7,B1       FILETAB LEN = 2 * (NARGS + 1)
          LX1    -PB.TAGP+PB.BIASP
          ISSUE  OC$FVEC,X1 
          EQ     PRE.RET
 FILES    SPACE  4,4
**        FILES - PROCESS FILE INFORMATION. 
  
  
 P=GFD    BSSENT 0           ENTRY... 
*CALL,COMFGFD                GENERATE FILE DECLARATIONS 
          EQ     PRE.RET
 PLIM     SPACE  4,10 
**        PLIM - PROCESS PLIM TURPLE. 
  
  
 P=PLIM   BSSENT 0
*CALL COMFPLI                ISSUE QXNTRY. APLIST 
          EQ     PRE.RET
 C$       TITLE  SPECIAL PROCESSING ROUTINES (*CALL*) 
 C$LOO    SPACE  4,8
**        C$LOO - SPECIFY OBJECT LIST ON/OFF
  
 P=CDLOO  BSSENT 0
          SA1    B5+OR.1OP
          RJ     GLT         GET OPERAND VALUE
          SA1    OCIOL       PROPER OPERATOR
          LX1    PB.GHIJP 
          LX4    PB.BIASP 
          BX7    X1+X4
          WCODE  X7 
          EQ     PRE.RET
 C$DOT    SPACE  4,8
**        C$DOT - SPECIFY ZERO/ONE TRIP DO LOOPS. 
  
 P=CDDOT  BSSENT 0
          SA1    B5+OR.1OP
          RJ     GLT         GET OPERAND VALUE
          BX6    X4 
          SA6    =XWO.DOOT
          EQ     PRE.RET
 C$CS     SPACE  4,8
**        C$CS - SPECIFY FIXED/USER COLLATION.
  
 P=CDCS   BSSENT 0
          SA1    B5+OR.1OP
          RJ     GLT         GET OPERAND VALUE
          BX6    X4 
          SA6    =XWO.CS
          EQ     PRE.RET
 DATA     SPACE  4,8
**        DATA - PROCESS DATA TURPLE AND SUBTABLE.
*         ISSUE DATA INFORMATION FROM IL AS I.DATA PSEUDO 
*         FOLLOWED BY DATA SUB-TABLE. 
  
 P=DATA   BSSENT 0
          ISSUE  I.ECI       END CCG INSTRUCTION FORMAT 
          =A1    B5+OR.1OP
          LX1    -TP.BIASP
          MX0    -TP.BIASL
          BX4    -X0*X1 
          BX1    -X0*X1 
          LX1    PB.BIASP-PB.TAGP 
          ISSUE  I.DATA,X1
  
*         LOOP CALLING WTE TO WRITE DATA INFO TO PREBIN.
  
          =B5    0
          SB6    X4          WORD COUNT 
  
 DATA10   EQ     B5,B6,DATA20      IF DATA EXHAUSTED
          RJ     ROW         READ ONE WORD FROM IL
          BX7    X1 
          =B5    B5+1 
          SB2    DATA10      RETURN ADDRESS 
          JP     =XWTE
  
 DATA20   ISSUE  I.BCI       RESTART CCG INSTRUCTION FORMAT 
          EQ     PRE.RET
 SEX      EJECT 
**        SEX - START OF EXECUTABLES IN IL. 
  
 P=SEX    BSSENT 0
          ISUSE$ CON         USE CON. 
          ISSUE  OC$CON 
          ISUSE$ FMT         USE FMT. 
          ISSUE  OC$FMT 
          ISUSE$ APL
          ISSUE  OC$APL 
          ISUSE$ IOAP 
          ISSUE  OC$IOM 
          ISUSE$ NLST 
          ISSUE  OC$NLST
          ISSUE  OC$BMI 
          SX6    I.LOO
          SA6    OCIOL
          ISUSE  STRT        USE START. 
          SA4    MOD
          HX4    MO.BLK 
          MI     X4,SEX70    IF BLOCK DATA
          SA2    =XCO.DBER
          ZR     X2,SEX04    IF ER NOT SELECTED 
          ISSUE  I.OTR,=XS=LENP 
          ISSUE  6102B,=XS=TRACE   SB0 B2+TRACE.
  
 SEX04    LX4    MO.BLKP-MO.SUBP
          PL     X4,SEX05    IF NOT PROCESSING SUBROUTINE 
          ISSUE  I.BSS,=XS=EXIT 
          SA1    =XN.ARP
          ZR     X1,SEX30    IF NO ALTERNATE RETURNS
          ISSUE  7110B       SX1 0
          ISSUE  I.BSS,=XS=AEXIT
          EQ     SEX30
  
 SEX05    SA2    =XMOD
          HX2    MO.FUN 
          PL     X2,SEX30    IF NOT COMPILING FUNCTION
          ISSUE  I.BSS,=XS=EXIT 
          SA2    =XMOD
          MX0    -MO.MODEL
          SA4    =XS=VALUE
          LX2    -MO.MODEP
          BX3    -X0*X2 
          SB6    X3-M.CHAR
          ZR     B6,SEX30    IF CHARACTER FUNCTION
          SX1    X4+M.DBL 
          =X2    X1+M.CPLX-M.DBL
          LX3    B1,X1
          LX5    B1,X2
          IX1    X3+X1
          IX2    X5+X2
          SA3    O$SYM
          =B7    X3+WB.W
          SA1    X1+B7
          SA2    X2+B7
          BX0    X1+X2
          HX0    WB.MDF 
          PL     X0,SEX20    IF THERE IS NO DOUBLE OR COMPLEX ENTRY 
          =X3    1
          LX3    PB.BIASP-PB.TAGP 
          BX1    X3+X4
          ISSUE  5150B,X1    SA5 VALUE.+1 
          ISSUE  1075B       BX7 X5 
  
 SEX20    ISSUE  5140B,X4    SA4 VALUE. 
          ISSUE  1064B       BX6 X4 
  
 SEX30    SA5    MOD
          MX0    -MO.CLIFL
          LX5    -MO.CLIFP
          BX5    -X0*X5 
          NZ     X5,SEX35    IF CHARACTER FUNCTION
          SA5    =XN.FP 
          ZR     X5,SEX40    IF NO FORMAL PARAMETERS
  
 SEX35    ISSUE  5130B,=XS=TA0     SA3 TEMPA0.
          ISSUE  5203B       SA0 X3+
  
 SEX40    SA4    =XMOD
          HX4    MO.BLK 
          MI     X4,SEX70    IF BLOCK DATA
  
*         ISSUE ENTRY POINT.
  
          ISSUE  I.BSS,=XS=ENTRY
          LX4    MO.BLKP-MO.PROP
          PL     X4,SEX50    IF NOT MAIN PROGRAM
  
          ISSUE  5110B,=XS=FILES   SA1 FILES. 
          ISSUE  I.RJ3,=XS=INIT    RJ QXNTRY. 
          EQ     SEX60
  
 SEX50    ISSUE  I.UJP,=XS=ENTRY   GENERATE ENTRY/EXIT WORD 
          SA4    =XS=ENTRY
          CALL   ISA         ISSUE SAVE A0 / RJ CPL.
          RJ     ICP         ISSUE GLOBAL PARAMETER TABLE 
  
 SEX60    ISUSE  CODE        USE CODE.
  
 SEX70    ISSUE  I.BCI       SIGNALS START OF CCG-STYLE PREBIN
          EQ     PRE.RET
*CALL COMFICP 
 APLISTS  TITLE  SPECIAL PROCESSING ROUTINES (*CALL*) 
 GAP      EJECT 
**        APLIST PROCESSORS.
  
**        GAP - GENERAL (USER FUNCTION) APLIST PROCESSOR. 
  
 P=GAP    BSSENT 0
          MX6    0
          =A1    B5+OR.1OP
          SA6    ATF
          RJ     IAW         ISSUE APLIST WORD
          EQ     PRE.RET
 FAP      SPACE  4,8
**        FAP - BEGIN FUNCTION APLIST.
  
 P=FAP    BSSENT 0
          =A1    B5+OR.OPR
          MX0    -TH.MODEL
          LX1    -TH.MODEP
          BX6    -X0*X1 
          SB2    X6-M.CHAR
          NZ     B2,PRE.RET 
          MX7    0
          SA7    ATF
          SX7    K=AP 
          MX6    1
          LX7    TP.CPFXP 
          SA6    FAF         MARK APLIST STARTED
          SA4    L$APT
          LX4    TP.ORDP
          BX7    X7+X4
          SA7    CAPL 
          MX1    1
          ADDWRD APT,X1      ALLOCATE APLIST
          =A1    B5+OR.1OP
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX1    -X0*X1 
          RJ     GCL         GET FUNCTION LENGTH
          =B2    0           SET LEVEL=0
          RJ     ETT         ENTER TARGET TEMP INTO APLIST
          EQ     PRE.RET
  
 IOD      SPACE  4,8
**        IOD - I/O DATA LIST ITEM. 
  
 P=IOD    BSSENT 0
          CLAS=  X2,AT,(IO) 
          =A1    B5+OR.1OP
          MX0    TP.IODPL 
          BX7    X1 
          HX7    TP.IODP
          BX0    X0*X7
          MX4    1
          LX0    TP.IODPL+AT.IODPP
          LX4    1+AT.NULP
          BX3    X0+X2       IODP[ATF] = IODP[OPD]
          =A2    A1+OR.2OP-OR.1OP 
          HX2    TP.SHRT
          PL     X2,IOD10    IF LENGTH OPERAND NOT SHORT CON
          LX2    1+TP.SHRTP-TP.BIASP
          =X5    1
          MX6    -TP.BIASL
          BX6    -X6*X2 
          IX2    X6-X5
          NZ     X2,IOD10    IF BIAS[TURP(3)] NE 1
          MX4    0           NUL[ATF] = 0 
  
 IOD10    BX6    X3+X4
          SA6    ATF
          BX6    X4 
          SA6    IODA 
          RJ     IAW         ISSUE APLIST WORD FOR DATA ADDRESS 
          CLAS=  X2,AT,(IO,LEN) 
          SA4    IODA 
          =A1    B5+OR.2OP
          BX6    X2+X4       INSERT NON-UNITY LENGTH PROPERTY 
          SA6    ATF
          RJ     IAW         ISSUE LENGTH OF ITEM 
          EQ     PRE.RET
  
 IODA     BSSZ   1
 IOC      SPACE  4,8
**        IOC - I/O CONTROL TURPLE PROCESSOR. 
  
 P=IOC    BSSENT 0
          SA1    B5+OR.2OP
          CLAS=  X2,AT,(IO,IOC) 
          MX0    TP.IODPL 
          BX7    X1 
          HX7    TP.IODP
          BX0    X0*X7
          LX0    TP.IODPL+AT.IODPP
          BX6    X0+X2
          SA6    ATF
          RJ     IAW          ISSUE APLIST WORD FOR CONTROL ITEM
          SA1    =XL$SAP
          SA2    =XO$SAP
          =A5    B5+OR.1OP
          LX5    -TP.BIASP
          MX0    -IA.MODEL
          IX3    X1+X2
          SA4    X3-1 
          LX4    -IA.MODEP
          BX3    X0*X4       CLEAR MODE 
          MX0    -TP.BIASL
          BX5    -X0*X5 
          BX6    X3+X5       MODE[SAP(L$SAP)]=BIAS[TURP(2)] (CODE)
          LX6    IA.MODEP 
          SA6    A4 
          RJ     PNA
          ADDWRD SAP,B0 
          EQ     PRE.RET
 IOU      SPACE  4,8
**        IOU - UNIT CODE TURPLE PROCESSOR. 
*         SEPARATE TURPLE USED FOR UNIT SINCE IT HAS LENGTH 
*         ATTRIBUTE LIKE DATA ITEM. 
  
 P=IOU    BSSENT 0
          CLAS=  X1,AT,(IO,IOC) 
          MX4    1
          LX4    1+AT.NULP
          SA2    B5+OR.2OP
          HX2    TP.SHRT
          PL     X2,IOU10    IF NOT SHORT CON LENGTH
          LX2    1+TP.SHRTP-TP.BIASP
          =X5    1
          MX6    -TP.BIASL
          BX6    -X6*X2 
          IX2    X6-X5
          NZ     X2,IOU10    IF LENGTH NE 1 
          MX4    0
  
 IOU10    BX6    X1+X4
          SA6    ATF
          BX6    X4 
          SA6    IODA 
          =A1    B5+OR.1OP
          RJ     IAW
          MX0    -IA.MODEL
          SA1    O$SAP
          SA2    L$SAP
          IX3    X1+X2
          SA4    X3-1 
          =X1    IC.UNT 
          LX4    -IA.MODEP
          BX6    X0*X4
          BX6    X6+X1       MODE[SAP(L$SAP)] = IC.UNIT 
          LX6    IA.MODEP    RESET UPDATED SAP ENTRY
          SA6    A4 
          CLAS=  X1,AT,(IOC,IO,LEN) 
          SA4    IODA 
          BX6    X1+X4       INSERT NUL PROPERTY
          SA6    ATF
          SA1    B5+OR.2OP
          RJ     IAW         PROCESS LENGTH WORD
          EQ     PRE.RET
 IAW      EJECT 
**        IAW - ISSUE APLIST WORD.
*         CONTROLS ADDITION OF APLIST ITEM TO APPROPIATE (APL OR IOA) 
*         TABLE,  AND FILING OF OPT2 USE/DEF ENTRY. 
* 
*         ENTRY  (X1) = OPD, OPERAND WORD.
  
 IAW      SUBR
  
*         SET AT.LEV0 IF THIS OPD IS LEVEL 0. 
  
          SA2    B5+OR.OPR
          SA3    ATF
          MX0    -TH.MODEL
          LX2    -TH.MODEP
          BX6    -X0*X2 
          LX6    AT.MODEP 
          CLAS=  X4,TP,(LCM,FP) 
          BX0    X4 
          BX7    X3+X6       MODE[ATF] = MODE[TURP(1)]
          BX5    X1 
          BX3    X0*X1
          BX0    X0-X3
          NZ     X0,IAW10    IF OPD NOT LCM AND FP
          SA4    O$SYM
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX6    -X0*X1 
          LX2    B1,X6
          IX6    X6+X2
          =B2    X4+WB.W
          SA2    X6+B2
          MX0    -WB.LEVNL
          LX2    -WB.LEVNP
          BX6    -X0*X2 
          NZ     X6,IAW10    IF LEV[OPD] NE 0 
          MX0    1
          LX0    1+AT.LEV0P 
          BX7    X0+X7
  
 IAW10    SA7    ATF
          SA4    FAF
          MI     X4,IAW20    IF NOT FIRST IAW CALL IN LIST
          BX2    X7 
          LX2    -AT.IOP
          SX7    X2+K=AP
          MX6    1
          LX7    TP.CPFXP 
          SA6    A4          MARK NOT FIRST AP
          SA4    =XL$APT+X2 
          LX4    TP.ORDP
          BX7    X7+X4
          SA7    CAPL 
          MX1    1
          ADDWRD APT+X2,X1
          SX6    X3-1 
          SA6    UAP         LAST USER AP 
  
 IAW20    SA2    ATF
          BX3    X2 
          MX0    -AT.MODEL
          LX2    -AT.MODEP
          BX6    -X0*X2 
          SX2    X6-M.CHAR
          BX1    X5 
          ZR     X2,IAW30    IF MODE[ATF] = M.CHAR
          RJ     PAF         PROCESS NON-CHAR ITEM
          EQ     EXIT.
  
 IAW30    HX3    AT.LEN 
          PL     X3,IAW40    IF NOT PROCESSING CHAR ITEM LENGTH 
          RJ     PCL         PROCESS CHAR LEN 
          EQ     EXIT.
  
 IAW40    RJ     PAC         PROCESS CHARACTER ITEM 
          EQ     EXIT.
  
 UAP      BSS    1           LAST USER SUBROUTINE APLIST
 PCL      EJECT 
**        PCL - PROCESS CHARACTER ARRAY ITEM LENGTH.
  
 PCL      SUBR
          SA3    ATF
          HX3    AT.NUL 
          PL     X3,PCL50    IF NOT ARRAY ITEM
          BX6    X1 
          SA6    PCLA 
          SA1    FARB 
          RJ     GCL         GET LEN/TAG
          BX2    X1 
          =X6    1
          SA6    CLF         FLAG APLIST TO CLW 
          =B7    0
          RJ     AIT         ENTER CLEN TO CLW
          SA1    PCLA 
          RJ     PAF         LENGTH TO CLW
  
*         ELIMINATE LAST CLW PAIR IF ALREADY EXISTS.
  
          SA2    =XO$CLW
          SA3    =XL$CLW
          SA4    X2 
          =A5    A4+1 
          SB6    X2+2 
          IX0    X2+X3
          SB2    X0 
          =A2    B2-1 
          =A1    A2-1 
          SX0    X3-2        INDEX = L$CLW - 2
  
 PCL30    BX6    X1-X4
          BX7    X2-X5
          SA4    A4+2        W1 = W1+2
          BX6    X6+X7       2 CLW WORDS CANNOT BE COMPLEMENTS
          =A5    A4+1        W2 = W2+2
          NZ     X6,PCL30    IF NOT HIT 
          SB3    A4-B2
          ZR     B3,PCL40    IF HIT NOT END OF TABLE
          BX7    X0 
          SA7    A3          L$CLW = L$CLW-2
          SX0    A4-B6       INDEX = W1-O$CLW-2 
  
 PCL40    AX2    B1,X0       BIAS = INDEX/2 
          =X6    0
          SA3    =XS=CL      TAG = CL.
          SA6    CLF         FLAG ADD TO APLIST 
          =B7    0
          RJ     AIT         FILE CL. POINTER TO APLIST 
          EQ     EXIT.
  
 PCL50    ADDWRD SAP,B0 
          EQ     EXIT.
  
 PCLA     BSS    1
 PAF      EJECT 
**        PAF - PROCESS APLIST TURPLE OPERAND WORD. 
*         PAF PRODUCES *APL* OR *IOA* TABLE ENTRY FOR CURRENT APLIST
*         TYPE (APL OR IOD FWA) TURPLE.  ANY REQUIRED CODE TO SETUP 
*         APLIST, SUCH AS STORES TO TEMP OR STORES TO APLIST ARE
*         OUTPUT TO *FUN* AFTER CODE PRECEDING APLIST IS MOVED TO 
*         *FUN* FROM *TXT*.  PAF WILL ALSO PRODUCE *AUD* ENTRY IF OPT=2.
* 
*         ENTRY  X1 = OPD, OPERAND WORD TO PROCESS. 
* 
*                (ATF) = APLIST TYPE FLAG - DEFINES MODE OF OPERATION:  
*                        ATF = 0      USER FUNCTION APLIST
*                        ATF = 1      IO DATA ITEM ADDR. OR IO CTL. ITEM
*                        ATF = 1S59+1 IO DATA ITEM LEN OR CONTROL CODE
  
 P=APRET  BSSENT 0           RETURN FROM SKEL AFTER CODE ISSUE
  
 PAF      SUBR
          BX6    X1 
          SA6    PAFB 
          SA6    GOVG        GPBUF(1) = OPD 
          MX7    0
          SA7    APSKEL      SET TO NO CODE TO ISSUE
          SA4    CAPL 
          BX7    X4 
          =A7    A6+1        GPBUF(2) = CURRENT APLIST
          LX6    59-TP.INTRP
          MX0    -TP.ORDL 
          PL     X6,PAF15    IF ^INTR[OP1]
          LX1    -TP.ORDP 
          SA2    IND0 
          IX3    X1-X2
          BX0    -X0*X3      IND = ORD[OP1] - IND0
          LX6    TP.INTRP-TP.ARYP 
          PL     X6,PAF25    IF ^ARY[OP1] 
          SA2    ATF
          HX2    AT.LEN 
          MI     X2,PAF5     IF PROCESSING LEN, MUST MATERIALIZE
  
          LX1    TP.ORDP-TP.ADDRP-1 
          PL     X1,PAF30    IF NOT ADDR[OP1]  */NOT LOCF 
  
  
*         STORE TO TEMP AND PLACE TEMP IN APLIST. 
  
 PAF5     SB6    B0 
          SA4    GOVG 
          RJ     LOP
          LX6    R1.RJP 
          SA1    LL.TXT 
          MX7    0
          SB7    OC.XMT 
          BX5    X6+X1
          RJ     IRI
          MX0    -R1.RIL
          BX6    -X0*X6 
          LX6    SD.RNP 
          SA5    N.ST 
          LX5    SD.CAP 
          BX1    X5+X6
          ADDWRD FUN,X1 
          SX7    X5+B1
          SA7    A5          N.ST = N.ST + 1
          SB7    B0 
          BX2    X5 
          SA3    S=ST 
          RJ     AIT
          EQ     PAF60
  
 PAF15    LX6    TP.INTRP-TP.ADDRP
          MI     X6,PAF5     IF ADDR[OP1]  */LOCF(X)
          LX6    TP.ADDRP-TP.FPP
          RJ     GLT         GET  SYMBOL/LABEL TAG
          BX2    X4 
          SA1    ATF
          SB7    B0 
          HX1    AT.LEN 
          MI     X1,PAF21    IF I/O LEN 
          ZR     X3,PAF22    IF SHORT CONSTANT
          LX1    AT.LENP-AT.IOP 
          MI     X1,PAF20    IF I/O FWA 
          MI     X6,PAF35    IF FP[OP1] 
  
 PAF20    RJ     AIT
          EQ     PAF40
  
*         CONVERT SHORT CONSTANT ITEM TO CON. ENTRY.
  
 PAF22    SX1    X2-0 
          CALL   CG$SCT 
          SA3    =XS=CON
          SX2    X6 
          SB7    B0 
          RJ     AIT
          EQ     PAF60
  
*         STORE LOCAL COPY OF FP OR LCM I/O LEN.
  
 PAF21    MI     X6,PAF5     IF FP
          LX6    TP.FPP-TP.LCMP 
          MI     X6,PAF5     IF LCM 
          EQ     PAF20
  
 PAF25    SB7    X0 
          SB6    B0 
          SA2    ATF         GET TYPE FLAG
          HX2    AT.LEN 
          MI     X2,PAF26    IF IO LENGTH 
          NZ     X2,PAF25A   IF NOT USER APLIST 
          SA1    N.STMAX
          SA2    N.ST 
          MX6    X1+X2
          SA6    A2          TO AVOID POSSIBLE TEMP STORE CONFLICT
 PAF25A   RJ     SDT         ISSUE TEMP(S)
          EQ     PAF27
  
 PAF26    RJ     STR         ISSUE TEMP 
  
 PAF27    SA3    =XS=ST 
          SB7    B0 
          RJ     AIT
          EQ     PAF60
  
  
*         MARK GPBUF COPY OF OPERAND AS ADDR TO FORCE ADDRESS SET.
  
 PAF30    SA1    GOVG 
          MX7    1
          LX7    1+TP.ADDRP 
          BX6    X7+X1
          SA6    A1          ADDR[GPBUF(1)] = 1 
  
*         PROCESS ARRAY LOAD APLIST.
  
          SA1    O$TST
          MX7    TP.ORDL
          SB3    X1 
          SA2    X0+B3       TST(ORD) 
          LX7    TP.ORDL+TP.ORDP
          LX2    -TS.RNUP 
          SA1    O$DTT
          SB2    X2+B1
          SA1    X1+B2       DTT(2,RNU[TST])
          CLAS=  X4,TP,(LCM,FP) 
          BX0    X4 
          BX3    X0*X1
          BX0    X0-X3
          NZ     X0,PAF3     IF NOT LCM AND FP
          MX0    1
          LX0    1+AT.LEV0P 
          SA2    ATF
          BX7    X0+X2
          SA7    A2 
 PAF3     SB7    B1          FLAG STORE TO APLIST 
          RJ     GLT         GET ARRAY TAG
          MX2    0
          RJ     AIT
          SA1    ATF
          SA2    OPT2 
          =X0    2B 
          SB6    X1+APSTR 
          LX1    1-AT.LEV0P 
          BX0    X0*X1
          SA1    B6+X0       SKEL=APSTR+2*LEVEL0+IO 
          BX7    X1 
          SA7    APSKEL      ISSUE STORE TO APLIST
          ZR     X2,PAF60    IF OPT NE 2
          MX0    1
          LX0    1+AP.CRP 
          BX6    X6+X0
          SA6    A6          MARK ARRAY REF AS CLASS REF. 
          EQ     PAF60
  
*         PREPARE FOR STORE TO APLIST.
  
  
 PAF35    SB7    B1          MARK STORE TO APLIST 
          RJ     AIT
          SA1    ATF
          =X0    2B 
          SB6    X1+APSTR 
          LX1    2-AT.LEV0P 
          BX0    X0*X1
          SA1    B6+X0       SKEL=APSTR+2*LEVEL0+IO 
          BX7    X1 
          SA7    APSKEL 
  
*         SET ADDR BIT IN FP OPERAND. 
  
          SA1    GOVG 
          SX0    TP.ADDRM 
          BX7    X0+X1
          SA7    A1 
  
 PAF40    SA1    OPT2 
          MX0    1
          LX0    1+AP.CRP 
          ZR     X1,PAF60    IF OPT NE 2
          ZR     B7,PAF60    IF IH = 0
          SA1    =XO$SYM
          SB6    X1+B1
          SX7    B7 
          SX3    B7-K.GL
          MX1    0           FLAG *NOT FORMAT*
          PL     X3,PAF55    IF GL
          MX7    -TP.ORDL 
          =A3    PAFB        OPD = TURP(2)
          LX3    -TP.ORDP 
          BX7    -X7*X3 
          LX3    B1,X7
          IX4    X3+X7
          SA1    B6+X4
          HX1    WB.LAB 
          MI     X1,PAF55    IF LABEL 
          LX1    WB.LABP-WB.ARYP
          PL     X1,PAF60    IF ^DIM[WORDB(ORD[OPD])] 
          BX6    X0+X6
          SA6    A6          CR[AP(M.AP)] = 1 
          EQ     PAF60
  
 PAF55    SA2    =XL$AUD
          LX1    WB.LABP-WB.FREFP 
          SX6    X2-1 
          SA6    A2          REMOVE LABEL ENTRY FROM AUD
          MI     X1,PAF60    IF FORMAT
          CFTE   CBN,X7,IH   FLOW <CBN, AP LABEL> 
  
 PAF60    SA1    ATF
          HX1    AT.LEN 
          MI     X1,PAF61    IF NOT FIRST CALL FOR THIS ITEM
          SA4    CAPL 
          =X2    1
          LX2    TP.BIASP 
          IX7    X4+X2
          SA7    A4          BIAS[CAPL] = BIAS[CAPL] + 1
  
 PAF61    SA1    APSKEL 
          ZR     X1,EXIT.    IF NO CODE TO ISSUE
          BX6    X1 
          EQ     SUB.RET
  
 APSKEL   BSS    1
 PAFB     BSS    1
 AIT      EJECT 
**        AIT - ADD APLIST TO APL/IOA AND USE/DEF INFO TO AUT.
* 
*                X2 = CA (24-BIT SIGNED)
*                X3 = IH
*                B7 = 1 IF STORE TO APLIST, ELSE 0. 
  
 AIT      SUBR
          SA4    ATF
          SA1    B5 
          MX7    0
          MI     X4,AIT6     IF I/O LENGTH
  
*         SET AP.P1 BIT IF DOUBLE-WORD ITEM.
  
          MX0    -TH.MODEL
          LX1    -TH.MODEP
          BX0    -X0*X1 
          SB6    X0-M.DBL 
          LX1    TH.MODEP 
          ZR     B6,AIT5     IF DOUBLE
          NE     B6,B1,AIT6  IF NOT COMPLEX 
  
 AIT5     MX7    1
          LX7    1+AP.P1P 
  
 AIT6     SA5    S=CON
          SA7    AITA 
          BX6    X3-X5
          NZ     X6,AIT7     IF IH NE CON.
          MX6    1
          SA6    =XAPCON     FLAG CON. IN APLIST
          HX4    AT.CHAR
          MI     X4,AIT60    IF CHARACTER CONSTANT
          SX1    X2 
          LX7    -AP.P1P
          =X4    X7+1        LENGTH = P1 + 1
          RJ     FMU         MARK CON. ENTRY(S) AS USED 
          EQ     AIT8 
  
*         MARK CON. MEMBERS USED AS APPROPRIATE.
  
 AIT60    SA1    =XO$CAC
          SB6    X2 
          SA5    X1+B6       CAC(BIAS) CONTAINS WC FOR THIS APLIST. 
          MX0    -WC.CLENL
          LX5    -WC.CLENP
          BX6    -X0*X5      X6 = CLEN
          MX0    -WC.BCPL 
          LX5    WC.CLENP-WC.BCPP 
          BX4    -X0*X5      X4 = BCP 
          MX0    -WC.RAL
          LX5    WC.BCPP-WC.RAP 
          BX1    -X0*X5      X1 = RA = BIAS OF FIRST USED CON.
          IX0    X4+X6
          CW     X4,X0       X4 = NUMBER OF WORDS SPANNED 
          RJ     FMU         MARK CONS AS USED
          EQ     AIT8 
  
 AIT7     SA4    S$VD 
          BX6    X3-X4
          NZ     X6,AIT8     IF NOT VARDIM APLIST 
          BX7    X3 
          SX1    X2 
          CALL   CG$AVO      CALL AVO( X1=CA )
          SX2    X1 
          BX3    X7 
  
 AIT8     MX0    -AP.CAL
          SA1    =XCO.ARGC
          SA5    AITA 
          BX6    -X0*X2 
          SA4    ATF
          LX4    -AT.IOP
          SX0    X4 
          LX4    AT.IOP 
          LX0    -1 
          BX0    X0+X1
          AX0    59 
          BX5    X3+X5
          LX6    AP.CAP 
          LX5    AP.IHP 
          BX5    X5+X6
  
*         INCLUDE IO CONTROL AND CHARACTER BITS AND MODE. 
  
          CLAS=  X1,AT,MODE 
          BX1    X0*X1       INCLUDE MODE IF IO OR ARG=C
          BX7    X1*X4
          CLAS=  X1,AT,CHAR 
          LX7    IA.MODEP-AT.MODEP
          BX0    X1*X4
          CLAS=  X1,AT,IOC
          LX0    IA.CHARP-AT.CHARP
          BX7    X0+X7
          BX1    X1*X4
          LX1    IA.IOCP-AT.IOCP
          BX0    X7+X1
          SX7    B7 
          SB7    X3          SAVE TAG 
          LX7    IA.STP 
          LX2    IA.BIASP 
          LX3    IA.TAGP
          BX0    X0+X7
          BX6    X2+X3
          BX1    X6+X0
          MX2    AT.OPT2L 
          SA3    WO.DOOT
          LX3    IA.VARP
          BX1    X1+X3       VAR[AP] = DOTRIP 
          HX4    AT.OPT2
          BX4    X2*X4
          BX5    X5+X4
          SA3    CLF
          ADDWRD SAP+X3,X1   SAP OR CLW 
          SB3    B7-K.GL
          PL     B3,AIT25    IF NOT IN SYMBOL TABLE 
          SA2    O$SYM
          MX1    1
          SB3    B7+B7
          LX1    1+WB.MATP
          SX2    X2+B1
          SB3    B3+B7
          SA2    X2+B3
          BX6    X1+X2
          SA6    A2          MAT[WB(IH)] = 1
  
 AIT25    SA2    OPT2 
          BX1    X5 
          ZR     X2,EXIT.    IF OPT NE 2
          ZR     B7,EXIT.    IF TAG = 0 
          ADDWRD AUD,X1      ADD TO USE/DEF BUFFER
          EQ     EXIT.
  
 AITA     BSS    1
 CLF      BSSZ   1
 FMU      SPACE  4,8
**        FMU - MARK MULTIPLE CON. ENTRIES AS USED. 
*         MULTIPLE ENTRY VERSION OF CG$FCU .
* 
*         ENTRY  X1 = FIRST CON. BIAS 
*                X4 = LENGTH OF USED SPAN.
  
 FMU      SUBR
          SA5    =XO$CUT
          SX7    B1 
          SB6    X4 
          IX0    X5+X1
  
 FMU10    SB6    B6-B1
          SA7    X0+B6
          NZ     B6,FMU10    IF NOT TOP OF ENTRIES
          EQ     EXIT.
 PNA      EJECT 
**        PNA - PROCESS NAMELIST APLIST.
*         CONSTRUCT PSEUDO APLIST FOR NAMELIST ITEMS IN OPT=2.
  
 PNA      SUBR
          SA3    OPT2 
          =A1    B5+OR.1OP
          ZR     X3,EXIT.    IF OPT NE 2
          MX0    -TP.BIASL
          LX1    -TP.BIASP
          BX2    -X0*X1 
          SB7    X2-IC.NML
          NZ     B7,EXIT.    IF BIAS[TURP(2)] .NE. IC.NML 
          =A1    A1+OR.2OP-OR.1OP 
          MX0    TP.IODPL 
          HX1    TP.IODP
          BX6    X0*X1
          LX6    2+AP.USEP
          SA6    IOBITS 
          SA5    =XO$SYM
          LX1    TP.IODPL+TP.IODPP-TP.ORDP
          MX0    -TP.ORDL 
          BX2    -X0*X1 
          LX3    B1,X2
          IX4    X2+X3
          IX0    X5+X4
          SA5    =XO$NLST 
          =A1    X0+WB.W
          MX2    -WB.PNTL 
          LX1    -WB.PNTP 
          BX3    -X2*X1 
          SB7    X3 
          SA5    X5+B7       I=1 , NLSI = NLST(PNT[WB(ORD[TURP(3)])]) 
          MX0    -NG.NMEML
          BX1    X5 
          SB4    B7          B4 PRESERVED ACROSS THE ALLOCATE 
          LX1    -NG.NMEMP
          BX1    -X0*X1 
          SB7    X1          N = NMEM[NLSI] 
          SX1    B7-B1
          ALLOC  AUD,X1 
          SA5    =XO$NLST 
          SA5    X5+B4       I=1 , NLSI = NLST(PNT[WB(ORD[TURP(3)])]) 
  
*         INITIALIZE A7 TO OVERWRITE GROUP NAME AUD ENTRY WITH
*         FIRST MEMBER ENTRY. 
  
          SX1    X2+B6
          SA2    X1-2 
          MX0    -NG.ORDL 
          SB4    30 
          BX7    X2 
          SA7    A2          INITIALIZE A7 WITH FIRST STORE ADDR. -1
  
 PNA10    ZR     B7,EXIT.    IF I = N+1   */ NAMELIST TABLE EXHAUSTED 
          NZ     B4,PNA20    IF CURRENT WORD NOT EXHAUSTED
          SB4    60 
          SA5    A5+1        NLSI = NLSI + 1
  
 PNA20    SB4    B4-15
          AX4    B4,X5
          BX3    -X0*X4 
          MX4    0
          SA1    O$SYM
          LX2    B1,X3
          IX6    X3+X2
          =B2    X1+WB.W
          SA1    X6+B2
          MX7    1
          HX1    WB.ARY 
          BX7    X7*X1
          LX1    WB.ARYP-WB.EQVP
          LX7    1+AP.CRP 
          PL     X1,PNA30    IF MEMBER NOT EQUIVALENCED 
          MX6    -WB.BASEL
          LX1    WB.EQVP+1-WB.BASEP 
          BX3    -X6*X1 
          =A1    A1+WC.W-WB.W 
          MX6    -WC.RAL
          LX1    -AP.CAL
          BX4    -X6*X1 
  
 PNA30    LX3    AP.IHP 
          SA1    IOBITS 
          LX4    AP.CAP 
          BX7    X7+X4
          BX4    X3+X1
          BX7    X7+X4
          SB7    B7-B1       I = I + 1
          SA7    A7+B1       AUD(J) = AP(IH[MEMI],CA[MEMI],ARY[MEMI],UD)
          EQ     PNA10
  
 IOBITS   BSS    1
 PAC      EJECT 
**        PAC - CHARACTER APLIST PROCESSORS.
  
 PAC      SUBR
          BX7    X1 
          HX7    TP.CAT 
          PL     X7,PAC10    IF NOT CAT[OPD]
          RJ     IAC         ISSUE APLIST FOR CONCAT
          EQ     EXIT.
  
 PAC10    RJ     PCI         PROCESS CHARACTER ITEM 
          EQ     EXIT.
 PCO      SPACE  4,8
**        PCO - PROCESS CHARACTER OPERAND.
  
 PCO      SUBR
          BX7    X1 
          HX7    TP.CAT 
          PL     X7,PCO10    IF NOT CAT[OPD]
          RJ     ICE         ISSUE CHARACTER EXPRESSION TO SAP
          EQ     EXIT.
  
 PCO10    RJ     PCI         ISSUE CHARACTER ITEM TO SAP
          EQ     EXIT.
 IAC      EJECT 
**        IAC - ISSUE APLIST FOR CONCAT.
  
 IAC      SUBR
          RJ     CEC         CHECK FOR EVALUATED // 
          ZR     B7,EXIT.    IF ALREADY EVALUATED (ST. TO APLIST) 
          BX7    X1 
          SA7    IACA 
          RJ     SAE         STACK APLIST ENVIRONMENT 
          MX1    0
          SA3    S=ST 
          RJ     PCA         RESERVE APLIST FOR TARGET TEMP 
          SA1    L$SAP
          SA2    L$AUD
          LX2    18 
          BX7    X1+X2
          SA7    IACB 
          SA1    IACA 
          MX6    0
          SA6    FVSUKL      CLEAR *UNKNOWN LENGTH* FLAG
          RJ     ICE         ISSUE EXPRESSION TO APLIST 
  
*         ALLOCATE ST. STORAGE FOR TARGET TEMP AND FILE IN
*         *TST* FOR THIS TURPLE.  NOW THAT WE KNOW LENGTH, WE 
*         RECALL PAC AND TRANSFER APLIST AND AUD ENTRIES TO 
*         SPACES RESERVED FOR THEM. 
  
          =B2    1           SET LEVEL=1
          RJ     ETT         ENTER TARGET TEMP TO SAP 
          SA1    FVSUKL 
          NZ     X1,IAC20    IF EXPRESSION INCLUDES VARIABLE SUBSTRING
          SA1    ETTA+1      GET LEVEL 1 TARGET TEMP
          BX6    X1 
          SA3    IACA 
          SA4    IND0 
          MX2    -TP.ORDL 
          LX3    -TP.ORDP 
          BX2    -X2*X3 
          IX7    X2-X4
          SA4    O$TST
          IX7    X4+X7
          SA6    X7          TST(ORD[OPD]) = ETTA 
  
 IAC20    SA4    OPT2 
          SA2    IACB 
          SA1    L$SAP
          SA5    O$SAP
  
 IAC30    SX6    X1-1 
          IX7    X5+X6
          SA6    A1          L$SAP = L$SAP - 1
          SA3    X7 
          SB6    X2-1 
          BX7    X3 
          SA7    X5+B6       SAP(TSAP) = SAP(L$SAP+1) 
          ZR     X4,IAC40    IF OPT=2 OR IF *AUD* DONE
  
*         UPDATE OPT2 INFO IN *AUD* ENTRY FOR TARGET. 
  
          AX2    18          TSAP = TAUD
          SA1    L$AUD
          SA5    =XO$AUD
          MX4    0
          EQ     IAC30
  
 IAC40    ADDWRD SAP,B0 
          SA1    =XS=MMC
          RJ     CGF
          RJ     PAE         POP APLIST ENVIRONMENT 
          SA1    FVSUKL 
          ZR     X1,IAC50    IF TARGET LEN KNOWN
          RJ     SCA         STORE RETURNED X6 TO APLIST
          SA3    S=ST 
          =B7    1           MARK STORE TO APLIST 
          MX2    0
          RJ     ECA         ENTER ST. TO APLIST
          EQ     EXIT.
  
 IAC50    SA1    ETTB 
          SA3    S=ST 
          RJ     PCA         FILE ST. ETC. IN USER APLIST 
          EQ     EXIT.
  
 IACA     BSS    1
 IACB     BSS    1
 ETT      SPACE  4,8
**        ETT - ENTER TARGET TEMP INTO APLIST.
* 
*         ENTRY  (X1) = CLEN
  
 ETT      SUBR
          BX6    X1 
          CW     X2,X6
          SA3    N.ST 
          IX7    X3+X2
          SA7    A3          ALLOCATE FOR EXPRESSION
          MX6    1
          LX6    1+AT.STP    MARK TARGET ST. ITEM AS *DEF*
          SA6    ATF
          LX1    TS.CLENP 
          LX3    TS.RNUP
          MX6    1
          BX5    X1+X3
          LX6    1+TS.FRP 
          BX6    X5+X6
          SA6    ETTA+B2     ETTA(INDEX) = TST ENTRY
          LX3    WC.RAP-TS.RNUP 
          LX1    WC.CLENP-TS.CLENP
          BX1    X3+X1
          SA3    S=ST 
          BX7    X1 
          SA7    ETTB        ETTB = APLIST ENTRY
          RJ     PCA         RECALL PCA WITH VALID CLEN 
          EQ     EXIT.
  
 ETTA     BSS    2
 ETTB     BSS    1
 PCI      EJECT 
**        PCI - PROCESS CHARACTER ITEM. 
* 
*         ENTRY  X1 = OPD 
* 
*         EXIT   X1 = CLEN
  
 PCI      SUBR
          BX7    X1 
          BX6    X1 
          HX7    TP.INTR
          HX6    TP.ARY 
          BX0    -X7+X6 
          PL     X0,PCI10    IF INTR AND NOT ARY[OPD] 
          RJ     FAR         FORM ARRAY (OR SCALAR) REFERENCE 
          EQ     EXIT.
  
 PCI10    RJ     CEC         CHECK FOR EVALUATED // EXPRESSION
          ZR     B7,EXIT.    IF CEC FILED ST. IN APLIST 
          RJ     FVS         FORM VARIABLE SUBSTRING
          EQ     EXIT.
 CEC      EJECT 
**        CEC - CHECK FOR EVALUATED CONCAT. EXPRESSION. 
* 
*         ENTRY  (X1) = OPD 
* 
*         EXIT   (B7) =  0 IF EXPRESSION ALREADY EVALUATED, ELSE 1
*                (X1) = CLEN IF B7=0, ELSE (X1) = OPD 
*         IF B7 = 0, ST. FILED IN APLIST. 
  
 CEC      SUBR
          BX7    X1 
          LX7    -TP.ORDP 
          SA2    IND0 
          MX0    -TP.ORDL 
          SA3    O$TST
          BX6    -X0*X7 
          IX7    X6-X2       INT = ORD[OPD] - IND0
          IX3    X3+X7
          SA2    X3 
          =B7    1           FLAG NOT EVALUATED 
          HX2    TS.FR
          PL     X2,EXIT.    IF NOT FR[TST(INIT)]  */ NOT EVALUATED 
          LX2    1+TS.FRP-TS.RNUP 
          SX5    X2 
          LX2    TS.RNUP-TS.CLENP 
          SX6    X2 
          LX5    WC.RAP 
          SA6    CECA 
          LX6    WC.CLENP 
          BX1    X5+X6
          SA3    S=ST 
          RJ     PCA         FILE ST., ETC. INTO APLIST 
          SA1    CECA        LEN = CLEN 
          =B7    0
          EQ     EXIT.
  
 CECA     BSS    1
 ICE      EJECT 
**        ICE - ISSUE CHARACTER EXPRESSION. 
*         ICE IS CALLED TO GENERATE APLIST FOR OPERANDS OF CONCAT.
*         STRING, IN *DE-PAREN'ED* ORDER. 
* 
*         ENTRY  (X1) = OPD, MUST BE CONCAT POINTER.
* 
*         EXIT   (X1) = CLEN
  
 ICE      SUBR
          MX6    0           OLD = 0
          SA6    ICEA        LEN = 0
          MX2    0
  
 ICE10    MX0    -TP.ORDL 
          BX6    X2          OLD
          LX1    -TP.ORDP 
          BX5    -X0*X1 
          SA2    IND0 
          SA3    O$TST
          IX7    X5-X2
          SA7    ICEB        IND = ORD[OPD] - IND0
          IX2    X3+X7
          SA2    X2 
          SA4    O$DTT
          MX0    -TS.FROML
          LX2    -TS.FROMP
          BX2    X0*X2
          BX7    X6+X2
          LX7    TS.FROMP 
          SA7    A2          FROM[TST(IND)] = OLD 
          =B2    X4+OR.1OP
          SA1    X7+B2       OPD = 1OP(DTT(IND))
  
 ICE20    BX7    X1 
          HX7    TP.CAT 
          SA2    ICEB        OLD = IND
          MI     X7,ICE10    IF CAT[OPD]  */ PRED. IS CONCAT. 
          RJ     PCI         ISSUE OPERAND
          SA2    ICEA 
          IX6    X2+X1
          SA6    A2          LEN = LEN + CLEN 
  
 ICE30    SA1    ICEB 
          SA2    O$TST
          IX3    X1+X2
          SA4    X3 
          HX4    TS.RTV 
          MI     X4,ICE40    IF RIGHT VISITED [TST(IND)]
  
*         GO UP RIGHT BRANCH. 
  
          SA2    O$DTT
          MX1    1
          BX6    X4+X1
          LX6    1+TS.RTVP
          SB2    X2+OR.2OP
          SA6    A4          RTV[TST(IND)] = 1
          SA1    B2+X6       OPD = 2OP(DTT(IND))
          EQ     ICE20
  
*         BACK DOWN TREE. 
  
 ICE40    MX0    1
          BX6    -X0*X4 
          LX6    1+TS.RTVP
          SA6    A4          RTV[TS(IND)] = 0 
          LX4    1+TS.RTVP-TS.FROMP 
          SX6    X4 
          SA6    ICEB        IND = FROM[TST(IND)] 
          NZ     X6,ICE30    IF IND NE 0
          SA1    ICEA        RETURN CLEN
          EQ     EXIT.
  
 ICEA     BSS    1
 ICEB     BSS    1
 SAE      EJECT 
**        SAE - STACK APLIST ENVIRONMENT. 
  
 SAE      SUBR
          SA1    SAEA        SLEV = SLEV + 1
          =X6    X1+1 
          SA6    A1 
          SA1    CAPL 
          SB2    X6 
          BX6    X1 
          SA6    A1+B2
          SA1    PSAP 
          SA2    L$SAP
          BX6    X1 
          SA6    A1+B2       STACK CAPL,PSAP
          BX6    X2 
          SA6    A1          PSAP = L$SAP 
          SA1    PAUD 
          SA2    L$AUD
          BX6    X1 
          SA6    A1+B2       STACK PAUD 
          BX6    X2 
          SA6    A1          PAUD = L$AUD 
          SA1    ATF
          BX6    X1 
          SA6    A1+B2       STACK ATF
          MX6    0
          SA6    A1          ATF = 0
          MX1    1
          ADDWRD APT,X1      ALLOC APLIST 
          SX7    K=AP 
          LX7    TP.CPFXP 
          SX3    X3-1 
          LX3    TP.ORDP
          BX7    X7+X3
          SA7    CAPL        CAPL POINTS TO ALLOCATED APLIST HEAD 
          EQ     EXIT.
  
 SAEA     BSSZ   1
 PAE      SPACE  4,8
**        PAE - POP APLIST ENVIRONMENT. 
  
 PAE      SUBR
          SA1    SAEA 
          SX6    X1-1 
          SB2    X1 
          SA6    A1          SLEV = SLEV-1
          SA1    CAPL+B2
          BX6    X1 
          SA6    A1-B2
          SA1    PSAP+B2
          BX6    X1 
          SA6    A1-B2
          SA1    PAUD+B2
          BX6    X1 
          SA6    A1-B2
          SA1    ATF+B2 
          BX6    X1 
          SA6    A1-B2
          EQ     EXIT.
 FAR      EJECT 
**        FAR - FORM ARRAY REFERENCE. 
*         FAR WILL EMIT CODE AND ISSUE APLIST FOR SCALAR, CONSTANT- 
*         INDEX ARRAY ELEMENT OR VARIABLE-INDEX ARRAY REFERENCE.
* 
*         ENTRY  (X1) = OPD 
* 
*         EXIT   (X1) = CLEN
  
 FAR0     SA1    FARB 
          RJ     GCL         GET CHAR LEN 
  
 FAR      SUBR
          BX5    X1 
          HX1    TP.INTR
          PL     X1,FAR30    IF NOT INTR[OPD] */ CONSTANT INDEX 
          RJ     SAE         SET UP FOR GENERATED APLIST
          SA2    O$TST
          SA4    IND0 
          BX1    X5 
          MX0    -TP.ORDL 
          LX5    -TP.ORDP 
          SB2    X2 
          BX6    -X0*X5 
          IX6    X6-X4       INDA = ORD[OPD] - IND0 
          SA2    X6+B2
          SA3    O$DTT
          =B3    X2+OR.1OP
          SA4    X3+B3
          BX6    X2 
          SA6    FARA 
          SA2    O$SYM
          MX0    -TP.ORDL 
          LX4    -TP.ORDP 
          BX6    -X0*X4 
          SA6    FARB 
          LX4    TP.ORDP-1-TP.FPP 
          MI     X4,FAR20    IF FP[OPD] 
          LX4    1+TP.FPP 
          BX1    X4 
          RJ     SCB         SUBSUME BIAS AND RESOLVE EQUIV BIAS
          BX1    X6 
          SX3    B7 
          RJ     PCA         FILE CONSTANT ADDRESS PORTION
  
*         PROCESS INDEX VARIABLE. 
  
 FAR10    MX7    0
          SA7    ATF         CLEAR OUT M.CHAR FROM PCA CALL 
          SA1    FARA 
          SA2    O$DTT
          IX3    X1+X2
          SA1    X3+OR.2OP
          RJ     PAF
          EQ     FAR50
  
*         PROCESS FORMAL ARRAY. 
  
 FAR20    LX4    1+TP.FPP 
          BX1    X4 
          RJ     PCAF        FILE HEADER (CONSTANT PORTION) WORD
          EQ     FAR10
  
 FAR30    LX1    1+TP.INTRP-TP.ORDP 
          MX0    -TP.ORDL 
          BX6    -X0*X1 
          SA6    FARB 
          LX1    TP.ORDP-1-TP.FPP 
          MI     X1,FAR40    IF FP[OPD] 
          LX1    1+TP.FPP 
          RJ     SCB         SUBSUME BIAS AND EQUIV BIAS
          BX1    X6 
          SX3    B7 
          RJ     PCA
          EQ     FAR0 
  
 FAR40    LX1    1+TP.FPP 
          BX5    X1 
          RJ     SAE         SETUP FOR APLIST GENERATION
          BX1    X5 
          RJ     PCAF 
          MX7    0
          SA7    ATF
          MX1    1
          LX1    1+TP.SHRTP 
          RJ     PAF         FAKE CONSTANT ZERO INDEX 
  
 FAR50    SA1    =XS=FAR
          RJ     CGF         EMIT CALL FAR
          RJ     PAE         RESTORE ENVIRONMENT
          RJ     SCA         STORE ADDRESS TO APLIST
          =B7    1
          SA3    FARB 
          MX2    0
          RJ     ECA         ENTER ITEM TO MAIN APLIST
          EQ     FAR0 
  
 FARA     BSS    1
 FARB     BSS    1
 FVS      EJECT 
**        FVS - FORM VARIABLE SUBSCRIPT.
* 
*         ENTRY  (X1) = OPD 
* 
*         EXIT   (X1) = CLEN
  
 FVS0     SA1    FVSC 
          RJ     GCL         CLEN = GCL(TAG)
          PL     X2,FVS      CHECK IF ASSUMED SIZE F.P. 
          SA1    FVSF        IF SO, GET CONST. SUBST. SIZE
  
 FVS      SUBR
          SA3    IND0 
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX6    -X0*X1 
          SA4    O$TST
          IX6    X6-X3
          IX2    X4+X6
          SA2    X2 
          SX6    X2 
          SA6    FVSA        INDT IS SUBSTRING TURPLE POINTER 
          SA2    O$DTT
          SB2    X6+OR.2OP
          SA5    X2+B2
          SB7    X2 
          LX5    -TP.ORDP 
          BX2    -X0*X5 
          IX5    X2-X3
          IX5    X4+X5
          SA2    X5 
          SX7    X2 
          SA7    FVSB        INDC IS COLON TURPLE POINTER 
          =A5    A5+OR.1OP-OR.2OP 
          HX5    TP.INTR
          MI     X5,FVS30    IF INTR[1OP(INDT)]  */ ARRAY SUBSTR. 
          LX5    1+TP.INTRP-TP.ORDP 
          BX6    -X0*X5 
          SA6    FVSC        TAG = ORD[1OP(INDT)] 
          SA2    =XS=FVS
          LX5    TP.ORDP-1-TP.FPP 
          BX7    X2 
          SA7    FVSD        ROUT = *FVS* 
          BX6    X5 
          SA6    FVSF        SAVE FP FLAG 
          LX5    1+TP.FPP 
          BX1    X5 
          RJ     SCB         SUBSUME BIAS AND EQV. BIAS 
          SA1    O$DTT
          SA2    FVSB 
          =B6    X2+OR.1OP
          SA3    X1+B6
          =A4    A3+OR.2OP-OR.1OP 
          BX2    X3*X4
          HX2    TP.SHRT
          PL     X2,FVS10    IF NOT CONSTANT SUBSTRING
          LX3    -TP.BIASP
          LX4    -TP.BIASP
          SA5    FVSF        GET FP FLAG
          MI     X5,FVS15    IF CONST. SUBST. OF F.P. 
          MX7    0           FVSF CONTAINS FLAG, SET TO ZERO
          SA7    FVSF        TO AVOID USING FOR CONST. SUBST. SIZE
          LX5    1+TP.FPP 
          CALL   ECS         EVALUATE CONSTANT SUBSTRING
          SA7    FVSC        CLEN = LEN(ECS)
          BX1    X6 
          SX3    B7 
          RJ     PCA         FILE CONSTANT SUBSTRING
          SA1    FVSC 
          EQ     EXIT.
  
 FVS10    SA5    FVSF        GET FP FLAG
          MI     X5,FVS20    IF FP
          BX5    X6 
          RJ     SAE         SETUP FOR APLIST GENERATION
          BX1    X5 
          SX3    B7 
          RJ     PCA         FILE HEADER WORD 
          EQ     FVS60
  
 FVS15    SB3    X3-1        EVALUATE SUBSTRING LENGTH
          SB2    X4 
          SX7    B2-B3       LEN = UB - ( LB - 1 )
          SA7    FVSF        SAVE SUBSTRING LENGTH
  
 FVS20    RJ     SAE         SETUP FOR APLIST 
          LX5    1+TP.FPP 
          BX1    X5 
          RJ     PCAF        FILE FP HEADER WORD
          EQ     FVS60
  
 FVS30    SA2    =XS=FAS     ROUT = *FAS* 
          BX7    X2 
          SA7    FVSD 
          RJ     SAE
          SA1    FVSA 
          SA3    O$DTT
          SB7    X3 
          =B2    B7+OR.1OP
          SA3    X1+B2       DTT(1OP,INDT)
          MX0    -TP.ORDL 
          SA4    IND0 
          LX3    -TP.ORDP 
          BX6    -X0*X3 
          SA1    O$TST
          IX3    X6-X4
          IX6    X1+X3
          SA2    X6 
          SA3    X2+B2
          LX3    -TP.ORDP 
          BX6    -X0*X3 
          SA6    FVSC 
          SX7    X2 
          SA7    FVSE        INDA IS POINTER TO ARRAY TURPLE
          LX3    TP.ORDP-1-TP.FPP 
          MI     X3,FVS40    IF FP ARRAY SUBSTRING
          LX3    1+TP.FPP 
          BX1    X3 
          RJ     SCB         EVALUATE CONSTANT PORTION
          BX1    X6 
          SX3    B7 
          RJ     PCA         FILE HEADER
          EQ     FVS50
  
 FVS40    LX3    1+TP.FPP 
          BX1    X3 
          RJ     PCAF        FILE FP HEADER WORD
  
 FVS50    MX7    0
          SA7    ATF
          SA1    O$DTT
          SA2    FVSE 
          IX3    X1+X2
          SA1    X3+OR.2OP
          RJ     PAF         FILE INDEX 
  
 FVS60    MX7    0
          SA7    ATF
          SA1    O$DTT
          SA2    FVSB 
          IX3    X1+X2
          =A1    X3+OR.1OP
          RJ     PAF         FILE SUBSTRING START 
          SA1    O$DTT
          SA2    FVSB 
          IX3    X1+X2
          =A1    X3+OR.2OP
          RJ     PAF         FILE SUBSTRING END 
          SA1    FVSD 
          RJ     CGF         EMIT CALL ROUT 
          RJ     PAE         RESTORE APLIST ENVIRONMENT 
          RJ     SCA         STORE X6 TO APLIST 
          =B7    1
          SA3    FVSC 
          MX2    0
          RJ     ECA         ENTER ITEM INTO MAIN (USER) APLIST 
          =X7    1
          SA7    FVSUKL      MARK *UNKNOWN LENGTH* EXPRESSION 
          EQ     FVS0 
  
 FVSA     BSS    1
 FVSB     BSS    1
 FVSC     BSS    1
 FVSD     BSS    1
 FVSE     BSS    1
 FVSF     BSS    1
 FVSUKL   BSS    1
 GCL      SPACE  4,8
**        GCL - GET CHARACTER LENGTH. 
* 
*         ENTRY  X1 = ORD, SYMTAB ORDINAL 
* 
*         EXIT   X1 = WC.CLEN[ORD]
*                X3 = VD. TAG IF CTYP=1, ELSE 0 
  
 GCL      SUBR
          LX2    B1,X1
          SA4    O$SYM
          IX3    X1+X2
          MX0    -WC.CLENL
          SB2    X4+WC.W
          SA2    B2+X3
          LX2    -WC.CLENP
          BX1    -X0*X2 
          SA4    =XS$VD 
          LX2    WC.CLENP-1-WC.CTYPP
          AX2    59 
          BX3    X2*X4
          EQ     EXIT.
*CALL COMFSCB 
 CHAR     TITLE  SPECIAL PROCESSING ROUTINES (*CALL*) 
 PCA      EJECT 
**        PROCESS CHARACTER APLIST. 
* 
*         ENTRY  (X1) = WCA 
*                (X3) = SYMTAB INDEX
  
 PCA      SUBR
          SA2    =XS=CON
          =X6    1
          LX6    WC.RBP 
          BX0    X2-X3
          NZ     X0,PCA5     IF NOT CON. REF
          BX1    X6+X1       SET RB = 1 TO PREVENT SQZ AGAINST NON-CON
  
 PCA5     BX5    X3 
          ADDWRD CAC,X1 
          SA4    X2 
          SB6    A6 
          SB3    X3-1 
  
 PCA10    BX0    X6-X4
          =A4    A4+1 
          NZ     X0,PCA10    IF NOT HIT 
          SB2    A4-B6
          GT     B2,PCA20    IF HIT IS NEW ENTRY
  
*         REMOVE ADDED ENTRY AS IT IS ALREADY IN CAC. 
  
          SX7    B3 
          SA7    A3          L$CAC = L$CAC - 1
          =B6    X2+1 
          SB3    A4-B6
  
 PCA20    =B7    0           NOT STORE TO APLIST
          BX3    X5 
          SX2    B3          BIAS 
          RJ     ECA         ENTER INTO APLIST
          EQ     EXIT.
 ECA      SPACE  4,8
**        ECA - ENTER CHARACTER APLIST INTO SAP AND BUMP
*         CAPL BIAS.
* 
*         ENTRY  (X2) = BIAS
*                (X3) = SYMBOL TABLE ORDINAL
*                B7 = 1 IFF STORE TO APLIST ITEM, ELSE 0
  
 ECA      SUBR
          SA5    ATF
          SX4    M.CHAR 
          CLAS=  X1,AT,MODE 
          LX4    AT.MODEP 
          MX0    1
          BX5    -X1*X5 
          LX0    1+AT.CRP 
          BX4    X5+X4
          BX7    X0+X4
          LX0    AT.CHARP-AT.CRP
          BX7    X7+X0
          SA7    A5          MARK ATF AS CHAR, CLASS REF, AND TYPE=CHAR 
          RJ     AIT         ADD TO APLIST
          SA1    ATF
          HX1    AT.LEN 
          MI     X1,EXIT.    IF PROCESSING ITEM LENGTH
          SA2    CAPL 
          =X1    1
          LX1    TP.BIASP 
          IX7    X1+X2
          SA7    A2          BUMP APLIST POSITION COUNTER 
          EQ     EXIT.
 PCAF     EJECT 
**        PCAF - ENTER FP CHAR ITEM APLIST. 
  
 PCAF     SUBR
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX3    -X0*X1 
          LX1    TP.ORDP-TP.BIASP 
          MX0    -TP.BIASL
          BX2    -X0*X1 
          =B7    0           NOT STORE TO APLIST
          RJ     ECA         ENTER APLIST ITEM
          EQ     EXIT.
 IAP      EJECT 
**        IAP - INTRINSIC FUNCTION APLIST PROCESSOR.
*         LOAD OPERAND INTO APPROPRIATE HARD REGISTER.
  
 P=IAP    BSSENT 0
 IAP1     =A4    B5+OR.1OP
          SA1    LOWER
          SB6    X1 
          RJ     LOP         LOAD OPERAND 
          SA1    LL.TXT 
          LX6    R1.RJP 
          MX7    0
          LX1    R1.RIP 
          SB7    OC.XMT 
          BX5    X6+X1
          RJ     IRI         XMT(RNEXT,OPERAND) 
          MX0    -R1.RIL
          BX6    -X0*X6 
          SB7    OC.RS
          SA2    ARGREG 
          SA1    LOWER
          IX4    X2+X1
          LX4    R1.SOP 
          MX7    0
          LX6    R1.RIP 
          BX5    X4+X6
          RJ     IRI         ISSUE REGISTER STORE X1,2,3 OR 4 
  
          SA2    B5 
          SA1    LOWER
          MX0    -TH.MODEL
          NZ     X1,IAP2     IF PROCESSING LOWER
          =X7    1
          LX2    -TH.MODEP
          SA7    A1          LOWER = 1
          BX0    -X0*X2 
          SB7    X0-M.DBL 
          ZR     B7,IAP1     IF DOUBLE
          EQ     B7,B1,IAP1  IF COMPLEX 
  
 IAP2     SA1    ARGREG 
          MX6    0
          SA6    LOWER       LOWER = 0
          SX7    X1+2 
          SA7    A1          ARGREG = ARGREG + 2
          EQ     PRE.RET
  
 ARGREG   CON    X1.
 SUB      EJECT 
**        SUB - USER FUNCTION/SUBROUTINE PROCESSOR. 
  
 P=LIBF   BSSENT 0
          SX7    1
          SA7    FUNA        LIBRARY CALL-BY-REF FUNCTIONS
 P=FUN    BSSENT 0
          =A1    B5+OR.OPR
          MX0    -TH.MODEL
          LX1    -TH.MODEP
          BX6    -X0*X1 
          SX0    X6-M.CHAR
          NZ     X0,FUN10    IF MODE[TURP(1)] NE CHAR 
          SA1    ETTA 
          SA2    INDEX
          BX6    X1 
          SA3    O$TST
          IX4    X2+X3
          SA6    X4          TST(INDEX) = ETTA
          EQ     P=SUB       TO AVOID DFR CALL
  
 FUN10    MX7    1
          SA7    PFUN 
          MX6    0
          EQ     SUBFUN 
  
 P=LIB    BSSENT 0           STOP AND PAUSE 
          SX7    -1 
          SA7    FUNA        FLAG LIBRARY ROUTINE 
  
 P=SUB    BSSENT 0
          MX7    0
          SA7    PFUN 
          MX6    0
  
 SUBFUN   SA1    L$SAP
          SA2    PSAP 
          IX2    X1-X2
          SA1    =XCO.ARGF
          SA6    CPLF 
          SA6    ATF         FLAG NON-IO ROUTINE
          ZR     X2,SUB3     IF NARGS[TURP(3)] EQ 0 
          NZ     X1,SUB6     IF NO TERMINATOR REQUESTED 
  
 SUB5     SA1    FUNA 
          NZ     X1,SUB6     IF NOT USER ROUTINE
          ADDWRD SAP,B0 
  
 SUB6     RJ     CPL         PROCESS PARAMETER LIST 
  
 SUB1     SA1    FUNA 
          SB7    OC.RJ6 
          PL     X1,SUB15    IF NOT CALL BY VALUE 
          SB7    OC.RJ3 
  
 SUB15    SA2    CSN
          =X7    2           INDICATE BEF 
          MI     X1,SUB20    IF BEF 
          =X7    1           INDICATE USER FUNCTION [STYLE] 
  
 SUB20    MX0    -TP.ORDL 
          SA1    B5+B1
          LX1    -TP.ORDP 
          BX3    -X0*X1 
          LX2    R1.CAP 
          LX3    R1.IHP 
          BX5    X2+X3
          LX7    FI.FTP 
          SA1    CPLF 
          BX7    X7+X1
          RJ     IRI         ISSUE RJ 
          SA1    LL.TXT 
          BX6    X1 
          SA6    LXR
          SA1    PFUN 
          ZR     X1,SUB2     IF NOT FUNCTION
          RJ     DFR         DEFINE FUNCTION RESULT 
  
 SUB2     BSS    0
          MX6    0
          SA6    FAF         FLAG NEXT APLIST AS FIRST OF LIST
          SA6    FUNA        RESET TO USER FUNCTION 
          EQ     PRE.RET
  
 SUB3     SA4    FUNA 
          BX1    X1+X4
          NZ     X1,SUB1     IF NO TERMINATOR NEEDED
  
*         ALLOCATE PARAMETER LIST.
  
          SX7    K=AP 
          LX7    TP.CPFXP 
          SA4    L$APT
          LX4    TP.ORDP
          BX7    X4+X7
          SA7    CAPL 
          MX1    1
          ADDWRD APT,X1 
          EQ     SUB5 
  
 PFUN     BSSZ   1           FUNCTION/SUBROUTINE FLAG 
 PAPL     BSSZ   1           LENGTH OF APL BEFORE THIS LIST 
 PIOA     BSSZ   1           LEN OF IOA BEF. THIS (MUST FOLLOW PAPL)
 FUNA     BSSZ   1           USER/BEF FLAG
 LXR      BSSZ   1           LAST ENCOUNTERED EXTERNAL REF. 
 IOF      EJECT 
**        P=IOF - I/O FUNCTION PROCESSOR. 
  
 P=IOF    BSSENT 0
  
*         ADD I/O APLIST TERMINATOR.
  
          SA1    FAF
          NZ     X1,IOF10    IF PARAMETERS ALREADY PROCESSED
          SX7    K=IO 
          LX7    TP.CPFXP 
          SA4    =XL$IOT
          LX4    TP.ORDP
          BX7    X4+X7
          SA7    CAPL 
          MX1    1
          ADDWRD IOT,X1 
  
 IOF10    ALLOC  SAP,2
          SA1    B5+OR.2OP
          LX1    59-TP.BIASP
          AX1    59 
          MX7    0
          BX6    X1 
          SA6    X2+B6
          SA7    A6+B1
          =X7    1
          SA7    ATF         FLAG IO ROUTINE
          RJ     CPL
          SB7    OC.RJ6 
          SA2    CSN
          SA4    =XS=BUFIN
          MX0    -TP.ORDL 
          SA1    B5+B1
          LX1    -TP.ORDP 
          BX3    -X0*X1 
          SX7    3
          BX4    X4-X3
          NZ     X4,IOF20    IF NOT PROCESSING BUFFER IN
          =X7    1           FAKE USER FUNCTION CALL TO KILL COMMON 
  
 IOF20    LX2    R1.CAP 
          LX3    R1.IHP 
          BX5    X2+X3
          LX7    FI.FTP      FI[R2] = 3 
          SA1    CPLF 
          BX7    X7+X1
          RJ     IRI         ISSUE RJ 
  
          SA1    LL.TXT 
          BX6    X1 
          SA6    LXR
          MX6    0
          SA6    FAF
          EQ     PRE.RET
INF       EJECT 
**        P=INF - PROCESS INTRINSIC (EXTERNAL) TURPLE.
  
 P=INF    BSSENT 0
          SB7    OC.RJ3 
          MX0    -TP.ORDL 
          SA1    B5+B1
          LX1    -TP.ORDP 
          BX5    -X0*X1 
          LX5    R1.IHP 
          SA2    O$SYM
          LX0    B1,X5
          IX7    X0+X5
          IX0    X2+X7
          SA2    X0+WC.W
          MX0    -WC.BRPL 
          LX2    -WC.BRPP 
          BX0    -X0*X2 
          LX0    FI.REGPP 
          =X7    2
          LX7    FI.FTP      FI[R2] = 2 
          BX7    X0+X7       REGP[R2] = BRP[WC(ORD[OP1])] 
          RJ     IRI         ISSUE RJ 
          SA1    LL.TXT 
          BX6    X1 
          SA6    LXR
          RJ     DFR         DEFINE FUNCTION RESULT 
  
          SX6    X1.
          SA6    ARGREG      ARGREG = X1. FOR NEXT INF
          EQ     PRE.RET
  
 DFR      EJECT 
**        DFR - DEFINE FUNCTION RESULT. 
* 
*         ISSUE DEF X6 AND DEF X7 IF DOUBLE.  STORE RESULT(S) IN
*         STATEMENT TEMPORARIES AND FILE TEMP ORDINALS IN TST.
  
 P=FRRET  BSSENT 0           RETURN FROM SKELETON 
 DFR      SUBR
          SX6    =XV=DFRS 
          SA2    B5 
          MX0    -TH.MODEL
          LX2    -TH.MODEP
          BX0    -X0*X2 
          SB2    X0-M.DBL 
          ZR     B2,DFR3     IF MODE(TURP(1)) .EQ. M.DBL
          NE     B2,B1,SUB.RET     IF MODE(TURP(1)) .NE. M.CPLX 
  
 DFR3     =X6    X6+1        SELECT V=DFRD
          EQ     SUB.RET
  
 LOWER    BSSZ   1           FLAG FOR PROCESSING UPPER (0) / LOWER (1)
 LRJ      SPACE  4,8
**        LRJ - INSERT LINE NUMBER INTO PREVIOUS RJ6. 
  
 P=LRJ    BSSENT 0
          SA1    LL.TXT 
          SA2    O$TXT
          SA4    CSN
          SB2    X1-4 
          SA3    X2+B2
          LX4    R1.CAP 
          BX7    X3+X4
          SA7    A3          CA[R2] = CSN 
          EQ     PRE.RET
 CPL      EJECT 
**        CPL - CHAIN PARAMETER LIST TO UDT AND PROCESS APLIST. 
  
 CPL      SUBR
          MX0    1
          LX0    1+IH.LDP 
          SA5    LL.TXT 
          SA2    CAPL 
          MX3    -TP.ORDL 
          LX2    -TP.ORDP 
          BX2    -X3*X2 
          SA3    ATF
          SX3    X3+K=AP
          LX3    IH.IP
          BX7    X2+X3
          LX5    R1.RIP 
          SB7    OC.LD
          LX7    IH.IHP 
          BX7    X7+X0
          RJ     IRI         ISSUE LOAD APLIST
          SB7    OC.RS
          SX0    X1.
          LX0    R1.SOP 
          BX5    X0+X5
          MX7    0
          SA7    CPLF 
          RJ     IRI         ISSUE RS X1
          SX1    B4 
          SX0    B5 
          LX1    18 
          BX7    X1+X0
          SA7    CPLA 
  
*         PROCESS APLIST.  ATTEMPT TO SQUEEZE AGAINST EARLIER LIST. 
  
          RJ     PPL
          SA2    OPT2 
          ZR     X2,CPL10    IF OPT NE 2
  
*         SUBMIT APLIST INFO TO GLOBAL OPTIMIZER. 
  
          SA4    L$AUD
          SA5    PAUD 
          IX4    X4-X5       INDEX = PAUD 
          SB2    X4          LEN = L$AUD-PAUD 
          ZR     B2,CPL10    IF LEN  = 0
          SX6    O$AUD
          CALL   CG$CPL 
          LX1    FI.INDXP 
          SX0    X0+1S10
          LX0    FI.LENP
          BX6    X0+X1
          SA6    CPLF 
          SA1    PAUD 
          BX7    X1 
          SA7    L$AUD
  
 CPL10    SA2    CPLA 
          SB5    X2 
          AX2    18 
          SB4    X2 
          EQ     EXIT.
  
 CPLA     BSS    1
 CPLF     BSS    1
 ATF      BSSZ   3
 PAUD     BSSZ   3
 PSAP     BSSZ   3
 CAPL     BSSZ   3
 FAF      BSSZ   1
 PPL      SPACE  4,8
**        PPL - PROCESS PARAMETER LIST
*                SETUP *API* TABLE ENTRY DESCRIBING THE PARAM LIST. 
*                THEN TRY TO REDUCE THE LIST IF IT IS COMMON WITH THE 
*                TAIL END OF ANOTHER APLIST.
* 
*                (X6) = FLAG, 0 IF USER FUNCTION, 1 IF IO 
  
**        AI. - APLIST INDEX TABLE ENTRY FORMAT 
          DESCRIBE AI.,60 
 EQV      DEFINE 1
 BASE     DEFINE 1           BASE MEMBER OF A CLASS OF EQUIV APLISTS
          DEFINE 4
 LINK     DEFINE 18 
 LEN      DEFINE 18 
 INDX     DEFINE 18 
  
 BIAS     DEQU   LEN
 ORD      DEQU   INDX 
  
 PPL0     SX7    B4+         PAP = L.TAB
  
          SA2    ATF
          SA7    PAPL+X2     P_TAB = PAP
  
 PPLE     SA1    ATF
          SA2    O$APT+X1 
          SA3    L$APT+X1 
          SA4    PPLA 
          SX6    X3-1        L$TAB = L$TAB-1
          IX0    X2+X6
          IX4    X2+X4
          SA1    X0 
          BX7    X1 
          SA7    X4          TAB(ORD[CAPL]) = TAB(L$TAB+1)
          SA6    A3 
  
 PPL      SUBR
          SA4    CAPL 
          MX0    -TP.ORDL 
          LX4    -TP.ORDP 
          BX6    -X0*X4 
          SA6    PPLA        ORDL = ORD[CAPL] 
          SA2    ATF
          MX1    1
          BX0    X2 
          ADDWRD APT+X0,X1   SET APT(L$APT) TO *EQV*
          SA4    L$SAP
          SA5    PSAP 
          IX1    X4-X5
          ALLOC  APL+X0,X1
          SA4    O$SAP
          SX3    X2+B6
          IX2    X4+X5
          MOVE   X1,X2,X3 
          BX6    X5 
          SA6    L$SAP
          SA4    L$APT+X0 
          SB7    X4-1 
          SA1    =XO$APT+X0 
          SA2    PAPL+X0
          SA3    =XL$APL+X0 
          SA0    X1 
          IX7    X3-X2
          SB5    X7          LN = LEN[N]   */ LENGTH OF THIS LIST 
          LX7    AI.LENP
          SB4    X3          IN = INDX[N]  */ INDEX TO LWA+1
          LX3    AI.INDXP 
          BX6    X7+X3
          SA6    A0+B7       API(N) = AINFO(0,0,L.APL-PAPL,L.APL) 
  
*         NOW SEARCH THE ACCUMULATED APLISTS AND ATTEMPT TO ELIMINATE 
*         ANY COMMON APLISTS
  
          SA4    =XO$APL+X0 
          SA5    X4-1        BASE = O.APL - 1 
          SB6    B7          J = N
  
 PPL1     SB6    B6-B1       J = J - 1
          SA1    A0+B6       AJ = API(J)
          ZR     B6,PPL0     IF J = 0 
          LX1    59-AI.EQVP 
          MI     X1,PPL1     IF EQV[AJ] 
  
          LX1    1+AI.EQVP-AI.INDXP 
          SB2    X1          IJ = INDX[AJ]
          LX1    AI.INDXP-AI.LENP 
          SB3    X1          LJ = LEN[AJ] 
          SX0    X1 
          SX7    B6 
          LT     B3,B5,PPL2  (LS,EI) = IF( LJ < LN )  (LJ,J) ELSE (LN,N)
          SX0    B5 
          SX7    B7 
  
 PPL2     SA2    A5+B4       SN = BASE + IN 
          SA3    A5+B2       SI = BASE + IJ 
          BX4    -X0         M = -LS
  
 PPL3     BX5    X2-X3
          SX4    X4+1        M = M + 1
          NZ     X5,PPL7     IF SN NE SJ
          MI     X5,PPL7     DITTO
          SA2    A2-B1       SN = SN - 1
          SA3    A3-B1       SJ = SJ - 1
          NZ     X4,PPL3     IF M " 0 
  
*         EQUIVALENCE THE SHORTER LIST TO THE LONGER ONE
  
 PPL3A    SX5    B6+B7
          MX6    1
          LX6    1+AI.EQVP
          IX4    X5-X7       ORD[API(EI)] = J + N - EI
          SX3    B3+B5
          LX4    AI.ORDP
          LX0    1
          IX2    X3-X0       BIAS[API(EI)] = MAX(LJ,LN) - LS
          LX2    AI.BIASP 
          IX4    X2+X4
          BX6    X4+X6
          SB6    X7 
          SA6    A0+B6
          SX7    B4-B5                     (X7) = PAPL
          LX4    -AI.ORDP    K = ORD[API(EI)]  */ ORD OF BASE OF CLASS
          SB5    X4 
          SA4    A0+B5
          SX6    B1 
          LX6    AI.BASEP 
          BX6    X6+X4       BASE[API(K)] = 1  */ MARK AS *BASE*
          SA6    A4 
          NE     B6,B7,PPL4  IF EI " N     */ ELIMINATED NOT LAST 
          SA2    ATF
          SA7    L$APL+X2 
          EQ     PPLE 
  
*         LOWER ONE IS SHORTER, MOVE APLISTS ABOVE IT DOWN
*         RESET ORD OF EQUIVALENCED APLIST TO ORD OF ULTIMATE POSITION, 
*         AS FINAL APLIST INDEX WILL BE MOVED AT PPL EXIT.
  
 PPL4     SA1    A0+B6
          SA2    PPLA 
          MX0    -AI.ORDL 
          LX1    -AI.ORDP 
          BX3    X0*X1
          BX6    X2+X3
          SA6    A1          ORD[API(EI)] = ORDL
          SB6    B1          K = 1
          SX4    B3 
          LX4    AI.INDXP 
          SA3    ATF
          SA1    L$APL+X3 
  
 PPL5     SA2    A0+B6       AK = O.API-1 + K 
          SB6    B6+1        K = K + 1
          LX2    -AI.INDXP
          SB3    X2 
          LX1    AI.INDXP-1-AI.EQVP 
          MI     X2,PPL6     IF EQV[AK] 
          SB3    B3-B2
          MI     B3,PPL6     IF INDX[AK] LT IJ
          IX6    X2-X4
          SA6    A2+         INDX[AK] = INDX[AK] - LEN[AJ]
 PPL6     LE     B6,B7,PPL5  IF K @ N 
  
          LX4    -AI.INDXP
          IX6    X1-X4       L.TAB = L.TAB - LEN[AJ]
          SA6    A1 
          SA6    PAPL+X3     P TAB = L.TAB
          SB6    A5+B1
          SX2    B6+B2
          IX3    X2-X4
          MOVE   B4-B2,X2,X3 MOVE( IN-IJ , O.APL+IJ , O.APL+IJ-LJ ) 
          EQ     PPLE 
  
*         TRY FOR NON-TERMINAL MATCH TO LARGER APLIST.
  
 PPL7     LT     B3,B5,PPL1  IF LJ LT LN
          SA2    A5+B4       SN = BASE + IN 
          SA3    A5+B2       SI = BASE + IJ 
          SX4    -B5         M = -LN
  
 PPL8     BX5    X2-X3
          SX4    X4+1        M = M + 1
          NZ     X5,PPL9     IF NOT MATCH  */ TRY ONE UP IN LIST
          MI     X5,PPL9     DITTO
          SA2    A2-B1       SN = SN - 1
          SA3    A3-B1       SJ = SJ - 1
          NZ     X4,PPL8     IF M NE 0
          EQ     PPL3A       MATCH SUCCESSFUL 
  
 PPL9     SB3    B3-B1       LJ = LJ -  1 
          SB2    B2-B1       IJ = IJ - 1
          EQ     PPL7 
  
 PPLA     BSS    1
 SCA      EJECT 
**        SCA - STORE CHARACTER APLIST. 
*         ISSUES STORE OF X6 FROM SUPPORT ROUTINE TO LOWER
*         LEVEL APLIST WORD.
  
 P=SCRET  BSSENT 0
  
 SCA      SUBR
          SA1    CAPL 
          SA2    ATF
          BX6    X1 
          MX0    -1 
          SA6    GOVG        GPBUF(1) = CAPL
          LX2    -AT.LEV0P
          BX1    -X0*X2 
          LX2    AT.LEV0P-AT.NULP 
          BX3    -X0*X2 
          LX2    AT.NULP-AT.IOP 
          BX2    -X0*X2 
          LX4    B1,X1
          BX0    -X3*X2      IO IFF NOT NUL 
          IX4    X4+X1       +3*LEV0
          LX3    1
          IX1    X0+X4       + 2*NUL
          IX2    X1+X3
          SA1    SCAA+X2
          BX6    X1 
          EQ     SUB.RET
  
 SCAA     BSS    0
          CON    =XV=CAPST   NON IO 
          CON    =XV=CISST   IO SCALAR
          CON    =XV=CIAST   IO ARRAY 
          CON    =XV=CAPST   NON IO, LEVEL 0
          CON    =XV=CIS0S   IO, SCALAR, LEVEL 0
          CON    =XV=CIA0S   IO, ARRAY, LEVEL 0 
 CGF      EJECT 
**        CGF - ISSUE COMPILER GENERATED CHARACTER FUNCTION.
* 
*         ENTRY  X1 = ROUTINE ORDINAL 
  
 CGF      SUBR
          BX7    X1 
          SA7    CGFA 
          RJ     CPL         PROCESS APLIST 
  
*         ISSUE RJ TO ROUTINE 
  
          SB7    OC.RJ6 
          SA2    CSN
          SA1    CGFA 
          LX2    R1.CAP 
          LX1    R1.IHP 
          SX7    4           FUNCTION TYPE FOR CHAR 
          BX5    X2+X1
          LX7    FI.FTP 
          SA1    CPLF 
          BX7    X7+X1       ADD IN OPT=2 APLIST POINTER
          RJ     IRI
          SA1    LL.TXT 
          BX6    X1 
          SA6    LXR         FLAG RJ ISSUED 
          EQ     EXIT.
  
 CGFA     BSS    1
 STORE    EJECT 
**        HSTO - CHARACTER ASSIGNMENT.
  
 P=HSTO   BSSENT 0
          RJ     SAE         STACK APLIST ENVIRONMENT 
          =A1    B5+OR.2OP
          RJ     PCI         ENTER TARGET INTO APLIST 
          SA1    B5+OR.1OP
          RJ     PCO         PROCESS RIGHT-HAND EXPRESSION
          ADDWRD SAP,0       APLIST TERMINATOR
          SA1    =XS=MMC
          RJ     CGF         ISSUE RJ MMC.
          RJ     PAE         RESTORE APLIST ENVIRONMENT 
          EQ     PRE.RET
 HREL     EJECT 
**        HREL - CHARACTER RELATIONAL PROCESSORS. 
*         CALLED AS HREL FOR OPERATOR-TYPE RELATIONAL EXPRESSIONS,
*         OR AS HLEX FOR LEXICAL FUNCTION-TYPE EXPRESSIONS. 
  
 P=HLEX   BSSENT 0
          SA1    =XS=LMC
          BX6    X1 
          SA6    PCRB 
          EQ     PCR10
  
 P=HREL   BSSENT
          SA2    =XWO.CS
          SA1    =XS=FMC+X2  FMC./UMC.
          BX6    X1 
          SA6    PCRB 
  
 PCR10    RJ     SAE         STACK APLIST 
  
*         SAVE CURRENT SKEL POINTERS SO WE MAY CONTINUE AFTER 
*         SUBSKELS HAVE BEEN PROCESSED. 
  
          SA1    PREA 
          SA2    PREB 
          SX6    B4 
          BX7    X1 
          SA6    PCRC 
          SA7    PCRE 
          BX6    X2 
          SA6    PCRD 
          ADDWRD SAP,B0      RESERVE FOR HEADER 
          SA1    CAPL 
          =X2    1
          LX2    TP.BIASP 
          IX6    X1+X2
          SA6    A1          BUMP APLIST POINTER
          =A1    B5+OR.1OP
          RJ     PCO         ISSUE LEFT SIDE
          SA1    L$SAP
          BX6    X1 
          SA6    PCRA        SAVE APLIST SIZE 
          SA1    B5+OR.2OP
          RJ     PCO         ISSUE RIGHT SIDE 
          SA1    PCRA 
          SA2    L$SAP
          SX3    X1-1 
          IX4    X2-X1
          LX3    IA.LEFTP 
          LX4    IA.RITEP 
          MX1    1
          LX1    1+IA.CRHP    REL HEADER TYPE APLIST
          BX6    X3+X4
          SA3    O$SAP
          BX7    X6+X1
          SA7    X3          STORE INTO RESERVED SPOT 
          SA1    PCRB        ROUTINE
          RJ     CGF         ISSUE CALL 
          RJ     PAE         RESTORE APLIST ENVIRONMENT 
  
*         RESTORE ENVIRONMENT TO MAIN SKEL. 
  
          SA1    PCRC 
          SA2    PCRD 
          SA3    PCRE 
          SB4    X1 
          BX6    X2 
          BX7    X3 
          SA6    PREB 
          SA7    PREA 
          EQ     PRE.RET
  
 PCRA     BSS    1
 PCRB     BSS    1
 PCRC     BSS    1
 PCRD     BSS    1
 PCRE     BSS    1
 DOLOOPS  EJECT 
 DOO      SPACE  4,8
**        DOO - MARK SHORT LOOP AS OPTIMIZABLE. 
  
 P=DZO    BSSENT 0
          SX6    =XV=DOZO    ZERO-TRIP OPTIMIZED LOOP 
          EQ     DOO10
  
 P=DOO    BSSENT 0
          SX6    =XV=DOBO    ONE-TRIP OPTIMIZED LOOP
  
 DOO10    SA2    B5+4        DC. VAR (TRIP COUNTER) 
          SA5    B5+2        TRIP COUNT OPERAND 
          SA1    =XCONONE 
          SA3    O$SYM
          MX0    -TP.ORDL 
          SB7    X3+WB.W
          BX5    X1-X5
          ZR     X5,DOO40    IF TRIP COUNT = 1
          SA1    B5+7        LOOP TOP LABEL 
          CLAS=  X5,WB,(DLEN,DLEX)
          LX1    -TP.ORDP 
          BX4    -X0*X1 
          IX7    X4+X4
          IX4    X7+X4
          CLAS=  X1,WB,(DLER,PRD) 
          SA4    B7+X4       WB(LOOP TOP DO.) 
          BX7    X5*X4
          BX1    X1*X4
          HX4    WB.NIN 
          BX7    X5-X7
          MI     X4,PRE.RET  IF INCREMENT VARIABLE OR NEG 
          =A4    A2+5-4      UPPER LIMIT OPERAND
          NZ     X1,DOO30    IF LOOP HAS EXTERNAL REFS, OR ULIM REDEF.
          ZR     X7,DOO30    IF LOOP HAS EXTENDED RANGE 
  
*         LOOP MAY BE COUNTED USING CONTROL VAR., UPPER LIMIT AND INC.
  
 DOO20    LX2    -TP.ORDP 
          BX7    X4 
          HX4    TP.INTR
          SB7    X3+WC.W
          MI     X4,PRE.RET  IF UPPER LIMIT EXPRESSION
          LX4    TP.INTRP-TP.SHRTP
          PL     X4,DOO25    IF NOT SHORT CON UPPER LIMIT 
          LX4    TP.SHRTP+1-TP.BIASP
          SX4    X4 
          ZR     X4,PRE.RET  IF UPPER LIMIT = 0 
  
 DOO25    BSS    0
          BX2    -X0*X2 
          IX0    X2+X2
          IX3    X2+X0
          SA7    B7+X3       WC(DC.) = UPPER LIMIT OPERAND
          EQ     SUB.RET
  
 DOO30    BX7    X4 
          HX7    TP.SHRT
          MI     X7,DOO20    IF UPPER LIMIT IS CONSTANT 
          EQ     PRE.RET     CONTINUE WITH (UNOPTIMIZED) SKEL.
  
 DOO40    LX2    -TP.ORDP 
          MX7    60 
          BX2    -X0*X2 
          IX0    X2+X2
          =B7    B7+WC.W-WB.W 
          IX3    X2+X0
          SA7    B7+X3       WC(DC.) = -0  */ FLAG ONE TRIP LOOP
          EQ     PRE.0
          SPACE  4,8
**        DOZ - PROCESS ZERO-TRIP LOOP BRANCH-AROUND. 
  
 P=DOZ    BSSENT 0
          SA5    OPT2 
          ZR     X5,PRE.RET  IF OPT NE 2
  
*         FILE FLOW TO LOOP-END LABEL, AND NEXT BLOCK.
  
          SA1    B5+8        LOOP END LABEL 
          RJ     GLT         GET LABEL ORDINAL
          CFTE   CBN,X3,IH   FLOW (CBN,LOOPEND) 
          SA4    O$TXT
          SA5    LL.TXT 
          SX3    B6 
          SB7    X4-4 
          SA5    X5+B7
          LX3    R1.INP 
          BX6    X3+X5
          SA6    A5          IN[R1(DOBEGIN BRANCH)] = OLD L.CFT 
          CFTE   CBN,X1+B1   FLOW (CBN,CBN+1) 
  
*         BREAK SEQUENCE. 
  
          EQ     UJP3 
 DOBZ     SPACE 4,8 
**        DOBZ - SET GPBUF(1) TO 1 FOR LONG DOBEGIN ZERO TRIP.
  
 P=DOBZ   BSSENT 0
          SA1    =XCONONE 
          BX6    X1 
          SA6    GOVG 
          EQ     PRE.RET
 DOL      SPACE  4,8
**        DOL - FLAG LONG DO LOOP.
  
 P=DOL    BSSENT 0
          MX6    1
          LX6    1+R2.LONGP 
          SA6    LDF
          EQ     PRE.RET
  
 LDF      BSSZ   1           LONG DOLOOP FLAG 
 DOB      EJECT 
**        DOB - PROCESS DO BEGIN. 
  
 P=DOB    BSSENT 0
          SA1    LALS 
          =X6    X1+1 
          SA6    A1          BUMP LOOP NEST COUNT 
  
*         LOOP IS OPTIMIZABLE IF IT IS INNERMOST AND HAS NO EXITS,
*         ENTRIES, EXTERNAL REFERENCES OR BACKWARD BRANCHES.
  
          SA2    OPT2 
          NZ     X2,PDB1     IF OPT NE 1
  
          SA1    O$SYM
          MX0    -TP.ORDL 
          SA2    B5+7        LOOP START LABEL OPERAND 
          LX2    -TP.ORDP 
          BX3    -X0*X2 
          SB6    X1+B1
          LX2    B1,X3
          IX3    X2+X3
          SA4    B6+X3       WORD B 
          MX0    WB.DLNOL 
          HX4    WB.DLNO
          BX7    X0*X4
          NZ     X7,PDB1     IF LOOP NOT OPTIMIZABLE
  
          RJ     PCS         CODE THE PROLOG
          SX6    1
          SA6    =XCC$OPTL
  
 PDB1     SA2    B5+7 
          MX0    -TP.ORDL 
          LX2    -TP.ORDP 
          BX1    -X0*X2 
          RJ     LAB         PROCESS LOOP-BACK LABEL
          RJ     TSP         KEEP LABEL AT TOP OF SEQ IN OPT=2
          ADVIL  2
  
*         IF LONG LOOP, SET R2.LONG IN BOS. 
  
          SA1    LDF
          ZR     X1,PRE.RET  IF NOT LONG LOOP 
          SA2    O$TXT
          =A3    X2+1 
          MX7    0
          BX6    X1+X3
          SA7    A1          LDF = 0
          SA6    A3          LONG[R2W(BOS)] = 1 
          EQ     PRE.RET
 DOLOOPS  EJECT 
**        DOC - PROCESS DO CONCLUSION.
* 
*         IF SHORT LOOP, CHECK FOR CONSTANT INCREMENT.
*         IF LONG LOOP, SET GPBUF(1) TO -1 SHORT CON. 
  
 P=DOC    BSSENT 0
          SA1    LALS 
          SX6    X1-1 
          SA6    A1          LALS = LALS - 1  */ DECREM. LOOP NEST COUNT
          ADVIL  1
          SA1    CNUM 
          NZ     X1,DOC10    IF LONG LOOP 
  
*         SET RF BIT FOR ALL LOADS IN LOOP CODE.
  
          SA1    F$RDT+OC.LD
          SX3    B1 
          LX3    D.RFP
          BX6    X3+X1
          SA6    A1          RF[RDT(OC.LD)] = 1 
          SX6    =XV=DOC.K
  
*         SELECT OPTIMIZED LOOP CODE IF THIS HAD SHORT CON TRIP COUNT.
  
          SA1    B5+5        TRIP COUNT CELL
          SA3    O$SYM
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          SB7    X3+WC.W
          BX2    -X0*X1 
          IX0    X2+X2
          IX3    X2+X0
          SA2    B5+OR.2OP   INCREMENT
          SA3    B7+X3       WC(TC.)
          HX2    TP.SHRT
          ZR     X3,DOC05    IF NOT OPTIMIZABLE 
          BX6    X3 
          SA6    GOVG        GPBUF(1) = UPPER LIMIT 
          MX7    0
          SA7    A3          WC(TC.) = 0
          SX6    =XV=DC.OC
          MI     X2,DOC01    IF CONSTANT INCREMENT
          SX6    =XV=DC.OV
          EQ     SUB.RET
  
 DOC01    =X0    1
          LX0    TP.BIASP 
          IX7    X3+X0       BIAS = BIAS+1
          HX3    TP.SHRT
          PL     X3,SUB.RET  IF UPPER LIMIT NOT CONSTANT
          BX3    X7 
          LX3    -TP.BIASP-TP.BIASL 
          AX3    60-TP.BIASL+17 
          NZ     X3,SUB.RET  IF ABS(BIAS+1) GE 2**17
          MX0    TP.BIASL 
          LX0    TP.BIASL+TP.BIASP
          BX7    X0-X7       BIAS = -(OLDBIAS+1)
          SA7    GOVG        GPBUF = SHRT(BIAS) 
          SX6    =XV=DC.OS   SELECT OPTIMIZED(SET) SUBSKEL
          EQ     SUB.RET
  
 DOC05    MI     X3,DOC20    IF ONE-TRIP LOOP 
          PL     X2,PRE.RET  IF INCREMENT NOT CONSTANT, CONTINUE
          EQ     SUB.RET     SELECT SUBSKEL 
  
 DOC10    SA1    CONM1
          BX7    X1 
          SA7    GOVG        GPBUF(1) = SHORT CON -1
          EQ     PRE.RET     CONTINUE 
  
 DOC20    MX7    0
          SA7    A3          RESTORE WC(DC.)
          SA5    WO.DOOT
          SX6    =XV=DC.O1   ISSUES I = I + INC 
          ZR     X5,SUB.RET  IF DO=-OT
  
 P=PDE1   BSSENT 0           PROCESS DO END FOR TRIP COUNT = 1
          SA2    F$RDT+OC.LD
          SX3    B1 
          LX3    D.RFP
          BX6    -X3*X2 
          SA6    A2          CLEAR RF BIT IN LOAD DESCRIPTOR
          EQ     PRE.0
  
 TOP      DECMIC 60-TP.BIASP-TP.BIASL 
 BIASL    DECMIC TP.BIASL 
 MID      DECMIC TP.BIASP-1-TP.SHRTP
 CONM1    VFD    "TOP"/0,"BIASL"/-1,"MID"/0,1/1,*P/0
 DOLOOPS  SPACE  4,24 
**        P=PDE - PROCESS DO END. 
  
 P=PDE    BSSENT 0
  
*         RESTORE LD DESCRIPTOR.
  
          SA2    F$RDT+OC.LD
          SA1    OPT2 
          SX3    B1 
          LX3    D.RFP
          BX6    -X3*X2 
          SA6    A2          RF[RDT(OC.LD)] = 0 
          ZR     X1,UJP1     IF OPT .NE. 2
          MX0    -TP.ORDL 
          SA2    B5+4 
          LX2    -TP.ORDP 
          BX3    -X0*X2      IHLB = ORD[TURP(6)]  */ LOOP HEAD LABEL
          SA5    CBN
          CFTE   X5,X3,IH    FLOW( CBN , IHLB ) 
          CFTE   X5,X5+B1    FLOW( CBN , CBN + 1 )
          RJ     PCS         PROCESS LAST LOOP SEQUENCE 
          SA3    CBN         INVENT DUMMY BLOCK FOR POST-STORES 
          SX6    X3+B1
          SA6    A3 
          CFTE   X6,X6+B1 
          EQ     UJP3 
 IOLC     SPACE  4,8
**        P=IOLC - SELECT SUBSKEL TO DEFINE CONTROL VARIABLE OF 
*         COLLAPSED IO IMPLIED-DO.
  
 P=IOLC   BSSENT 0
          SA1    WO.DOOT
          SX6    =XV=IOLC0
          ZR     X1,SUB.RET  IF ZERO TRIP LOOPS IN EFFECT 
          SX6    =XV=IOLC1
          EQ     SUB.RET
 LABELS   EJECT 
**        P=PLA - PROCESS LABEL TURPLE. 
  
 P=PLA    BSSENT 0
          SA1    B5+B1       OPR = TURP(2)
          RJ     GLT         GET LABEL TAG
          BX1    X3 
          RJ     LAB         CALL LAB (LABEL ORD.)
          EQ     PRE.RET
 LABELS   SPACE  4,8
**        ALT - ADD LABEL TO TEXT.
* 
*         ENTRY  X1 = LABEL ORDINAL 
  
 ALT      SUBR
          LX1    R1.IHP 
          BX5    X1 
          SB7    OC.LAB 
          MX7    0
          RJ     IRI
          EQ     ALT
 LABELS   SPACE  4,8
**        GLT - GET LABEL TAG.
* 
*         ENTRY  X1 = LABEL OPERAND WORD. 
* 
*         EXIT   X3 = SYMTAB ORDINAL OR GL ORDINAL+GL BIT.
*                X4 = BIAS
* 
*         PRESERVES  B2,B4,B5,B6,B7,X5,X6,X7
  
 GLT      SUBR
          MX0    -TP.BIASL
          LX1    -TP.BIASP
          BX4    -X0*X1 
          LX1    TP.BIASP-TP.ORDP 
          MX0    -TP.ORDL 
          BX3    -X0*X1 
          LX1    TP.ORDP-TP.CPFXP 
          MX0    -TP.CPFXL
          BX2    -X0*X1 
          NZ     X2,GLT1     IF NOT SYMBOL TABLE SYMBOL 
  
*         CHECK FOR EQUIVALENCE.
  
          LX1    TP.CPFXP-1-TP.EQVP 
          PL     X1,GLT      IF NOT EQUIVALENCED
          SA2    O$SYM
          LX0    B1,X3
          SB3    X2+B1
          IX0    X0+X3
          SA2    X0+B3
          =A1    A2+WC.W-WB.W 
          MX3    -WB.BASEL
          MX0    -WC.RAL
          LX2    -WB.BASEP
          BX3    -X3*X2 
          LX1    -WC.RAP
          BX2    -X0*X1 
          LX4    -TP.BIASL
          AX4    -TP.BIASL
          IX4    X4+X2
          MX0    -TP.BIASL
          BX4    -X0*X4 
          EQ     GLT
  
 GLT1     LX2    IH.IP
          BX3    X2+X3
          EQ     GLT
 LABELS   EJECT 
**        LAB - LABEL DEFINITION. 
*         ENTRY  X1 = SYMBOL ORDINAL. 
  
 LAB      SUBR
          SX2    X1-K.GL
          PL     X2,LAB1     IF GL (ALWAYS ACTIVE)
          SA5    O$SYM
          LX2    B1,X1
          SB6    X5+B1
          IX3    X2+X1
          SA2    B6+X3       WORD B OF SYMBOL ENTRY 
          LX2    59-WB.CGSP 
          MI     X2,LAB1     IF A *DO* GENERATED LABEL
          LX2    WB.CGSP-WB.ACTP
          PL     X2,LAB      IF NOT REFERENCED
  
 LAB1     SA4    CC$OPTL
          NZ     X4,LAB6     IF CC$OPTL .NE. 0  */ ADD LABEL AND CONTINU
          SA5    OPT2 
          NZ     X5,LAB3     IF OPT EQ 2
  
          RJ     ALT         ADD LABEL TO TEXT
          SA3    LL.TXT 
          SX6    X3-8 
          ZR     X6,LAB      IF LABEL FIRST IN SEQ
          RJ     PCS         PROCESS SEQUENCE 
          EQ     LAB
  
 LAB3     SA3    LL.TXT 
          SB3    X3-4 
          ZR     B3,LAB4     IF CODE BUFFERS EMPTY
  
          BX6    X1 
          SA6    LABA 
          RJ     PCS         PROCESS CURRENT SEQUENCE 
          SA1    CBN         PBN = CBN
          SX6    X1+B1       CBN = CBN + 1
          SA6    A1 
          CFTE   X1,X6       FLOW( PBN , CBN )
          SA1    LABA 
  
*         DEFINE BLOCK NUMBER ASSOCIATED WITH THIS LABEL
  
 LAB4     RJ     ALT         ADD LABEL
          SX1    X5 
          CALL   CG$LABD
          EQ     EXIT.
  
 LAB6     RJ     ALT         ADD LABEL
          EQ     LAB
  
 LABA     BSS    1
 ENTRY    EJECT 
**        P=ENT - PROCESS ALTERNATE ENTRY POINT.
*         GENERATE GL FOR ENTRY POINT TO JUMP TO. 
  
  
 P=ENT    BSSENT 0
          SA1    =XN.ALTEN
          SX7    X1+B1
          SA7    A1          N.ALTEN = N.ALTEN + 1
          ADDWRD GLT,B0 
          SX1    X3+K.GL-1
  
*         INSTALL GL NUMBER IN CLEN FIELD OF ENTRY SYMTAB ENTRY.
  
          SA4    B5+OR.1OP   ENTW = TURP(2) 
          SA2    O$SYM
          MX0    -TP.ORDL 
          LX4    -TP.ORDP 
          SB6    X2+WC.W
          BX6    -X0*X4 
          LX2    B1,X6
          MX0    WC.EGLL
          SX3    X3-1 
          IX4    X6+X2
          LX0    WC.EGLL+WC.EGLP
          SA2    B6+X4
          BX2    -X0*X2 
          LX3    WC.EGLP
          BX7    X2+X3
          SA7    A2          EGL[WC(ORD[TURP(3)] = L.GLT-1
  
          RJ     LAB         ISSUE GL 
          SA2    OPT2 
          ZR     X2,PRE.RET  IF OPT NE 2
          SA2    CBN
          CFTE   1,X2        FLOW FROM PSEUDO-ENTRY BLOCK TO HERE 
          EQ     PRE.RET
 EXITS    EJECT 
**        P=PEX - PROCESS EXIT MACRO. 
  
 P=PEX    BSSENT 0
          SA1    CC$OPTL
          SA2    OPT2 
          NZ     X1,PRE.RET  IF IN WELL-BEHAVED LOOP
          ZR     X2,UJP1     IF OPT NE 2
  
          CFTE   CBN,B0      FLOW( CBN , 0 ) */ SHOW FLOW TO EXIT 
          EQ     UJP3 
 PASG     SPACE  4,8
**        P=PASG- PROCESS ASSIGN. 
  
 P=PASG   BSSENT 0
          SA1    CTYP 
          SA2    CNUM 
          RJ     GOV
          SA6    GOVT        T1 = CALL OP = ADDR(LAB) 
          SA1    O$TXT
          SA2    LL.TXT 
          SA4    =XS=TRACE
          IX3    X1+X2
          SA1    X3-4 
          LX4    R1.H2P 
          BX6    X1+X4
          SA6    A1          H2[R1W(LAST OP)] = TRACE.
          =A2    A1+1 
          SA4    O$SYM
          LX2    -IH.IHP
          =B7    X4+WB.W
          SX1    X2 
          LX2    B1,X1
          IX3    X1+X2
          SA4    B7+X3
          SX6    =XV=ASLAB
          HX4    WB.FDEF
          PL     X4,SUB.RET  IF CODE LABEL
          SX6    =XV=ASFMT
          EQ     SUB.RET
 BRANCH   EJECT 
**        UJP - UNCONDITIONAL JUMP  ( UJP LAB ) PROCESSING
  
 P=PGT    BSSENT 0
          SA1    CC$OPTL
          SA2    OPT2 
          NZ     X1,PRE.RET  IF CC$OPTL " 0     */ OPT=1  & OPTIMIZABLE 
          NZ     X2,UJP2     IF OPT EQ 2   */ FLOW ANALYSIS 
  
 UJP1     RJ     PCS         PROCESS CURRENT SEQUENCE 
          EQ     PRE.RET
  
 UJP2     =A1    B5+OR.1OP   LABWRD = TURP(2) 
          RJ     GLT         GET LABEL TAG
          CFTE   CBN,X3,IH   FLOW( CBN , IH[R1] ) 
  
 UJP3     RJ     PCS         PROCESS SEQUENCE 
          SA1    CBN
          SX6    X1+B1       CBN = CBN + 1 */ ADVANCE TO NEXT BLOCK 
          SA6    A1 
          EQ     PRE.RET
 BRANCH   SPACE  4,8
**        GOTO - ASSIGNED / COMPUTED GOTO PROCESSING
  
 P=PAG    BSSENT 0
          SA1    CC$OPTL
          SA2    OPT2 
          NZ     X1,PRE.RET  IF CC$OPTL .NE. 0
          ZR     X2,UJP1     IF OPT .NE. 2
  
*         COLLECT FLOW INFORMATION.  ADD ALL OBJECTS OF ASSIGNS TO
*         THIS VARIABLE TO FLOW GRAPH.
  
          SA1    B5+OR.1OP   LOC = TURP(2)
          RJ     GLT
          MX7    TP.ORBIL 
          LX3    TP.ORDP
          LX4    TP.BIASP 
          BX0    X3+X4
          SA5    =XO$ASG
          SA5    X5 
  
 PAG1     ZR     X5,UJP3     IF LAST ASSIGN ENTRY 
          BX3    X5 
          BX4    X5-X0
          SA5    A5+B1
          BX6    X7*X4
          NZ     X6,PAG1     IF ASG(I) NE LOC 
  
          SX3    X3 
          CFTE   CBN,X3,IH   FLOW (CBN,TARGET[ASG(I)] 
          MX7    TP.ORBIL 
          EQ     PAG1 
 BRANCH   SPACE  4,8
 P=PCG    BSSENT 0
          ADDWRD GLT,B0 
          SA1    CTYP 
          SA2    CNUM 
          RJ     GOV         PLACE PARAMETER (B-REG) IN X6
          SA1    =XL$GLT
          SX7    X1+K.GL-1
          LX7    IH.IHP      IH = L.GLT + K.GL - 1
          SB7    OC.JIN 
          BX5    X6 
          LX5    R1.RIP 
          RJ     IRI         ISSUE JP #GLN+B(J) 
          LX7    -IH.IHP
          BX1    X7 
          RJ     ALT         ISSUE #GLN  BSS  0 
          EQ     PRE.RET
  
 PGTA     BSS    1
 BRANCH   SPACE  4,8
**        P=JGOTO - PROCESS COMPUTED GOTO JUMP TURPLES. 
  
 P=JGOC   BSSENT 0
          SA4    CC$OPTL
          SA3    OPT2 
          NZ     X4,PRE.RET  IF IN WELL-BEHAVED LOOP
          ZR     X3,JGOTO1   IF OPT .NE. 2
          SA1    B5+B1
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX5    -X0*X1 
          CFTE   CBN,X5,IH   FLOW (CBN,ORD[TURP(2)])
          SA3    OPT2 
  
 JGOTO1   SA1    PGTA 
          SX6    X1-1 
          SA6    A1          NLAB = NLAB-1
          NZ     X6,PRE.RET  IF NLAB .NE. 0  */ NOT LAST JUMP 
          ZR     X3,UJP1     IF OPT NE 2
          CFTE   CBN,X1+B1   FLOW <CBN,CBN+1> 
          EQ     UJP3 
 RGT      EJECT 
**        RGT - ALTERNATE RETURN GO TO PROCESSOR. 
  
 P=RGT    BSSENT 0
  
*         SET GPBUF(1) TO LAST USER APLIST + BIAS(1OP), AND 
*             GPBUF(2) TO -2OP. 
  
          =A4    B5+OR.1OP
          SA3    UAP
          CLAS=  X2,TP,BIAS 
          =A1    A4+OR.2OP-OR.1OP 
          BX6    X1-X2       BIAS = -BIAS 
          LX4    -TP.BIASP
          SA6    GOVG+1      GPBUF(2) = -2OP
          =X1    K=AP 
          LX3    TP.ORDP
          LX1    TP.CPFXP 
          SX6    X4 
          BX3    X1+X3
          LX6    TP.BIASP 
          BX7    X3+X6
          =A7    A6-1        GPBUF(1) = LAST APLIST + BIAS[1OP] 
          EQ     PRE.RET
 BRANCH   EJECT 
**        P=IF - COLLECT FLOW FOR IF TURPLES. 
  
 P=IF     BSSENT 0
          ADVIL  1           ADVANCE 1 TURPLE 
          SA1    OPT2 
          ZR     X1,PRE.RET  IF OPT NE 2
          SA2    O$TXT
          SA3    LL.TXT 
          IX4    X2+X3
          SA1    CNUM 
          SX1    X1-1 
          LX1    2
          SB7    X1 
          SB6    X4-3 
          SA5    B6-B7
          ZR     B7,IF2      IF ONLY ONE JUMP IN SKELETON 
  
*         LOOP THROUGH ALL BUT LAST BRANCH, FILING CONTROL FLOW.
  
 IF1      LX5    -IH.IHP
          SB7    B7-4 
          CFTE   CBN,X5,IH
          SA4    A5-B1
          SX3    B6 
          LX3    R1.INP 
          BX6    X3+X4
          SA6    A4          IN[R1] = OLD(L.CFT)
          SA5    A5+4 
          NZ     B7,IF1      IF NOT LAST BRANCH 
  
*         PROCESS LAST BRANCH.  MAY BE UJP (TYPE 2).
  
 IF2      SA3    A5+B1
          LX3    59-D.TYP 
          MI     X3,IF3      IF UJP (TYPE 2)
  
*         MUST BE CONDITIONAL BRANCH (TYPE 3) 
  
          LX5    -IH.IHP
          CFTE   CBN,X5,IH
          SA4    A5-B1
          SX3    B6 
          LX3    R1.INP 
          BX6    X3+X4
          SA6    A4          IN[R1] = OLD(L.CFT)
          CFTE   CBN,X1+B1   FLOW <CBN,CBN+1> 
          EQ     UJP3 
  
 IF3      SA5    A5-1 
          LX5    -R1.IHP
          CFTE   CBN,X5,IH   FLOW <CBN,IH[R1W]> 
          EQ     UJP3 
 DEFER    EJECT 
**        DEFERRED TURPLE PROCESSORS. 
  
**        EDT - ENTER TURPLE INTO DEFERRED TURPLE TABLE.
* 
*         ENTRY  X0 = TS.INFO TO BE INCLUDED IN INDEX ENTRY.
  
 EDT      SUBR
          ALLOC  DTT,3
          SA1    B5 
          SA3    B5+B1
          BX6    X1 
          SA6    X2+B6       DTT(1,L.DTT) = TURP(1) 
          BX7    X3 
          SA1    A3+B1
          SA7    A6+B1       DTT(2,L.DTT) = TURP(2) 
          BX6    X1 
          SA6    A7+B1       DTT(3,L.DTT) = TURP(3) 
          SA3    INDEX
          SA2    O$TST
          IX4    X2+X3
          SX3    B6 
          LX3    TS.RNUP     RNU[TST(IND)] = DTT INDEX
          BX7    X3+X0
          SA7    X4 
          EQ     EXIT.
 PAR      SPACE  4,8
**        PAR - PROCESS ARRAY TURPLE. 
  
 P=PAR    BSSENT 0
          MX0    0
          RJ     EDT         ENTER TURPLE INTO DTT
 .ARY     SKIP               RESTORE IF SUBSCRIPTED SUBSCRIPTS OUTPUT 
          SA1    B5+OR.2OP
          LX1    59-TP.ARYP 
          PL     X1,PRE.RET  IF ^ARY[TURP(3)] 
          LX1    TP.ARYP-TP.INTRP 
          PL     X1,PRE.RET  IF NOT INTR[TURP(3)] 
  
          SA3    IND0 
          SB6    B0 
          MX0    -TP.ORDL 
          LX1    TP.INTRP-TP.ADDRP
          BX4    X1 
          LX1    TP.ADDRP-59-TP.ORDP+60 
          BX6    -X0*X1 
          SX1    OC.LD
          PL     X4,PAR1     IF NOT ADDR[TURP(3)]  */ NOT A(LOCF(B(I))) 
          SX1    OC.STT 
  
 PAR1     IX6    X6-X3
          SB7    X6          IND = ORD[TURP(3)] - IND0
          RJ     GAR         GENERATE ARRAY LOAD
          SA1    =XO$DTT
          SA2    =XL$DTT
          IX0    X1+X2
          SA1    X0-1 
          MX0    -TP.BIASL
          LX1    -TP.BIASP
          BX2    X0*X1
          BX6    X2+X6
          LX6    TP.BIASP 
          SA6    A1          BIAS[OP2(DTT(L.DTT))] = RN(GAR)
 .ARY     ENDIF 
          EQ     PRE.RET
 HCAT     EJECT 
**        HCAT - PROCESS CONCATENATE TURPLE.
  
 P=HCAT   BSSENT 0
          MX0    0
          RJ     EDT         ENTER TURPLE INTO DTT
          EQ     PRE.RET
 HSBS     SPACE  4,8
**        HSBS - PROCESS SUBSTRING TURPLE.
  
 P=HSBS   BSSENT 0
          CLAS=  X0,TS,SUB
          RJ     EDT         ENTER INTO DTT 
          EQ     PRE.RET
 HCOL     SPACE  4,8
**        HCOL - PROCESS COLON TURPLE.
  
 P=HCOL   BSSENT 0
          MX0    0
          RJ     EDT         ENTER TURPLE INTO DTT
          EQ     PRE.RET
 IMULT    EJECT 
**        P=IM - SELECT INTEGER MULTIPLY SUBSKEL ON BASIS OF
*         MULTIPLICAND NATURE.
  
 P=IM     BSSENT 0
*CALL     COMFSIM            SELECT INTEGER MULTIPLY SUBSKEL
 IDIV     EJECT 
**        P=ID - SELECT INTEGER DIVIDE SUBSKEL. 
 P=ID     BSSENT 0
*CALL     COMFSID            SELECT INTEGER DIVIDE SUBSKEL
 MASK     EJECT 
**        P=MASK - SELECT MASK SUBSKEL. 
  
 P=MASK   BSSENT 0
*CALL     COMFSMK            SELECT MASK SUBSKEL
 MOD      EJECT 
**        P=MOD - SELECT MOD SUBSKEL. 
  
 P=MOD    BSSENT 0
*CALL     COMFSMD            SELECT MOD SUBSKEL 
 SHIFT    EJECT 
**        P=SHIFT - SELECT SHIFT SUBSKEL. 
 P=SHIFT  BSSENT 0
*CALL     COMFSSH            SELECT SHIFT SUBSKEL 
 BVD      EJECT 
**        BVD - PROCESS START OF VARDIM CODE. 
  
 P=BVD    BSSENT 0
          SA1    LL.TXT 
          SX6    X1-4 
          ZR     X6,PRE.RET  IF EMPTY SEQUENCE
          RJ     PCS         PROCESS CURRENT SEQUENCE 
          EQ     PRE.RET
 EVD      SPACE  4,8
**        EVD - PROCESS END OF VARDIM CODE. 
  
 P=EVD    BSSENT 0
          SA1    LL.TXT 
          BX6    X1 
          SA6    L$TXT
          ALLOC  VDT,X1 
          BX3    X2 
          SA2    O$TXT
          MOVE   X1,X2,X3    MOVE TXT TO VDT FOR END PROCESSING 
          SX7    4
          SA7    L$TXT
          SA7    LL.TXT 
          EQ     PRE.RET
 FIN      SPACE  4,8
**        P=FIN - TERMINATE IL PROCESSING.
  
 P=FIN    BSSENT 0
          RJ     TSP
          RJ     MDV         MARK VD.S AS MATERIALIZED
          SX7    0
          SA7    =XL$ASG     L.ASG = 0
          SA1    LL.TXT 
          BX7    X1 
          SX6    X1-4 
          SA7    L$TXT
          ZR     X6,BRIDGE   IF EMPTY SEQUENCE
          SA6    =XCC$BRN+1  LRN = L.TXT - 4
          RJ     IST         INSERT STORES TO TEMPS.
          MX6    0
          SA6    L$FUN
          CALL   CG$PAS 
          EQ     BRIDGE 
 ILL      SPACE  4,8
**        ILL - TURPLE CODE LOST. 
  
 P=ILL    BSSENT 0
          EQ     "BLOWUP" 
 MDV      SPACE  4,8
**        MDV - MARK CERTAIN DIMTAB-RESIDENT VARDIMS AS NEEDED. 
* 
*         MDV MARKS SPAN AND LOWER BOUND OF *MAT* DIMTAB AS 
*         NEEDED. 
* 
  
 MDV      SUBR
          MX0    -DM.INFL 
          SA2    =XO$DIM
          SA3    =XL$DIM
          IX7    X2+X3
          SB7    X7 
          SA2    X2-1 
  
 MDV5     SA2    A2+B1
          SB2    A2-B7
          ZR     B2,EXIT.    IF DIMTAB EXHAUSTED
          BX4    X2 
          HX4    DH.VD
          LX2    -DH.DIMP 
          MX3    -DH.DIML 
          BX3    -X3*X2 
          PL     X4,MDV40    IF NOT VARDIM
          LX4    DH.VDP-DH.MATP 
          PL     X4,MDV40    IF NOT NEEDED
          SB6    X3 
  
 MDV10    =A2    A2+1 
          LX2    59-D1.SPANP-DM.TDP 
          PL     X2,MDV20    IF NOT VARIABLE SPAN 
          LX2    1+DM.TDP 
          BX1    -X0*X2 
          CALL   CG$AVO 
  
 MDV20    =A2    A2+1 
          LX2    59-D2.LBP-DM.TDP 
          PL     X2,MDV30    IF NOT VARIABLE LOWER BOUND
          LX2    1+DM.TDP 
          BX1    -X0*X2 
          CALL   CG$AVO 
  
 MDV30    =B6    B6-1 
          NZ     B6,MDV10    IF MORE DIMENSIONS TO GO 
          EQ     MDV5 
  
 MDV40    LX4    B1,X3
          ERRNZ  Z=DD-2 
          SB6    X4 
          SA2    A2+B6
          EQ     MDV5 
 LCC      SPACE  4,10 
 P=LCC    BSSENT
          =A1    B5+OR.1OP
          SX7    OC$LCC 
          LX1    0-TP.BIASP+PB.BIASP
          LX7    PB.GHIJP 
          =A2    B5+OR.2OP
          BX7    X7+X1
          LX2    0-TP.BIASP+PB.TAGP 
          BX7    X7+X2
          WCODE  X7,PRE.RET 
  
          END 
