*DECK GEN 
          IDENT  GEN
 GEN      SECT   (CODE GENERATION)
 FUNLST   SECT   (EXTERNAL LIST ARGUMENT MODE AND LINK PROCESSORS.),1 
  
          SST    A,B,C,D,E,F,G,L,N,X,Z,EXIT.
          NOREF  A,B,C,D,E,F,G,L,N,X,Z,EXIT.
  
 B=GEN    RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  O=SUBL,DIMI,O=OTR
          ENTRY  O=RAGDD,O=RAGDS,O=RAGSD,O=RAGSS,SA=ABS3,SA=ABS6
          ENTRY  SA=BK,STDIF,ZERO,SX=BK,FMASK,SA=AB,SA=AK,SA=AKS6 
          ENTRY  DIMSYM,MXP,CVT,PSO,ALREG,A=ARRAY 
          ENTRY  C=ARRAY,ESF,SSO,VAM,VEL,VIL,SLD
          ENTRY  O=ADD,O=SUB,O=MULT,O=DIV,O=STR,O=LT,O=GE,O=EQ,O=NE 
          ENTRY  O=NOT,O=ANDO,O=XOR,O=ORO,O=UMIN,O=APLUG,O=ASSGN,O=XORN 
          ENTRY  O=STRC,O=ANDN,O=DOB,O=GOA,O=BSS,O=INT,O=RETS,O=RETD
          ENTRY  O=DOC1,O=DOC2,O=DOC3,O=DOC4
          ENTRY  O=DOC3A,O=SHFC,O=SHFS,O=SHFD,O=SHFSA,O=SHFDS,O=DIVP2 
          ENTRY  STR.I,STR.D,SUB.I,ADD.I,MULT.I,O=ORN,INLBASE 
          ENTRY  O=NTR0,O=STR,O=QUITS,LSHF,O=NTR,O=RETN 
          ENTRY  O=NTRX,O=NTRM,O=NTRN,O=NTRY,O=GOTON,IFEN2,O=NTRP 
          ENTRY  IFE1N,IFI111,IFLN2,IFL1N,IFL12,IFBASE,O=QUITP,NSTDIF 
          ENTRY  I..2,I..3,I..4,I..5,I..6 
          ENTRY  I..7,I..8,I..9,I..10,MODTBL,O=GOC,MULT.R 
          ENTRY  R..2,R..3,R..4,R..5,R..6,R..7,R..8,R..9,R..10
          ENTRY  MODECON,O=RANF,O=RTNA,O=XMIT 
          ENTRY  SB=BB,SB=BK,SB=XB,SB=XK,XOR
          ENTRY  DUC.,DUC.1ST,DUC.2ND,DUC.BTH,EIS.PNX,O=EPO 
          ENTRY  O=RJSUB,O=NOOP,NULLOP,CAI,FVD,XMITS3 
          ENTRY  SA=XKS3,SA=BKS3,SA=BKS9,SB=BKS9,SX=BKS9,SX=XKS9
          ENTRY  IADD,SX=XKS3,SX=BKS3,SB=BKS3 
          ENTRY  L.FIV,E.FIV,CRTTAB 
          ENTRY  SX=BB,SX=XB,SX=XK,AFREG
          ENTRY  DIMUL
          ENTRY  O=GOCL,O=RAGD1,O=RAGS1 
  
*         IN FTN
          EXT    CO.SNAP,CO.RND 
  
*         IN TABLES 
          EXT    ARGMODE,ARGCOMA,ATTR,BIFFUN,BIFSHF,BINOUT
          EXT    CHARMAP,DRITE,INTMAC,REFLIN,MOD,MULT(S,MULT,N.TABLE
          EXT    NOLDS,PLUS,PLUS(S,REGB,RANF,REG=B,REG=T,REGX,RGC 
          EXT    REGFILE,RGX,RG=TEMP,RG=LOAD,RG=LODX,RJTDUM,RREG,SHFC 
          EXT    SUBOP,TT=PAR,TT.PAR,TS.SYM,TP.DIM,T.VDIM,T=VDIM,TG.VDIM
          EXT    TT.SCR,TT=SCR,TS.STN,TT=USE,TT.USE,TG.TEM,TEM.MAX,UUC
          EXT    UMINUS,VD.EQ,VD.MULT,VD.INTR,XMITOP,XPOP 
  
*         IN ERRORS 
          EXT    E.AT1,E.AT1A,E.IF7,E.SB2,E.SB3,E.SB4,E.SB6,E.SB7 
          EXT    E.SU2,E.SU3,E.SU8,E.SU9,E.SU10,FILL.,FILL.3,OSE,ERR=F
  
*         IN PIG
          EXT    WIN
  
*         IN ALLOC
          EXT    ALC.00,ALC.CAI,ALC.REG,SCSA,ADW,SCS,NCS
  
*         IN MAIN 
          EXT    WOF
  
*         IN LEX
          EXT    S.RANDM,TSF
  
*         IN REG
          EXT    CLOADJ,REGLK,ABR,ASR,AIR,CDS,CRJ,CIA,CPL,DIT 
          EXT    GST,GNR,LTG,LSC,RLL,RUL,RUT,SFR,SST,SDS,LFP
  
*         IN PAR
          EXT    PAR.NX,POP.STD,SMOD,SOPR,ADT,CT2,SDM,POPX,CURST
  
*         IN CONRED 
          EXT    TER1,TER2,CCR,LCT
  
*         IN FUN
          EXT    ARGNUM 
  
*         IN DO 
          EXT    CDO,DIP
  
*         IN INIT 
          EXT    ESTACK,SCR,SCR2
  
 ESA      SPACE  4,8
**        ESA -  EVUALATE SHIFT CONSTANT
* 
*         ENTRY  (X5) = CONSTANT TO EVUALATE. 
* 
*         EXIT   (B2) < 0, NO CONSTANT PRESENT, (X6) N/A
*                (X0) = MODE (IN ALL CASES) 
*                (X6) = CONVERTED CONSTANT IN THE RANGE OF 0 TO +60.
* 
*         NOTE   CONVERSION OF CONSTANT SHIFT IS THE SAME AS *COMPASS*
*                VER 2.0, 3.0 - AND SHOULD BE.
* 
*         USES   A1,A2,A6,A7  X0  B2,B7 
*         CALLS  LCT
  
  
 ESA      SUBR               ENTRY/EXIT...
          BX1    X5 
          RJ     LCT         GET BINARY OF CONSTANT 
          LE     B2,EXIT.    IF NO CONSTANT OR CONSTANT IS REAL 
          =X2    60 
          PL     X6,ESA5     IF POSITIVE
 +        IX6    X6+X2
          MI     X6,* 
 ESA5     ZR     X6,EXIT.    IF *0* 
 +        IX6    X6-X2
          PL     X6,* 
          IX6    X6+X2
          NZ     X6,EXIT. 
          BX6    X2 
          EQ     EXIT.
 ESF      SPACE  4,8
**        ESF -  EVUALATE SPECIAL *INTRINSIC* FUNCTION. 
* 
*         ENTRY  (B7) = RELATIVE ADDRESS TO *ESFBASE* 
*                (A4) _ SYMBOL TABLE ENTRY. 
* 
*         EXIT   (X1) = OPERATOR WORD.
*                (X2) IF > 0, MACRO ADDRESS FOR FUNCTION. 
*                (X2) IF < 0, FUNCTION REDUCED. 
* 
*         USES   A1,A2,A3  X0  B2,B3,B7 
*         CALLS  ESA, TSF 
  
  
 ESFX     SA1    BIFFUN 
  
 ESF      SUBR   -           ENTRY/EXIT...
          JP     B7+ESFBASE 
  
 ESFBASE  BSS    0           BASE ADDRESS 
  
  
 ES.MASK  RJ     ESA         EVUALATE MASK
          =X2    O=MASK 
          LE     B2,ESFX     IF NOT INTEGER CONSTANT
          MX1    1
          SB7    X6-1 
          =X7    M.UNIV      MODE 
          AX6    B7,X1
          BX1    X6 
          AX1    59 
          BX6    X1*X6
          =B6    B6-1        ELIMINATE FUNCTION 
          RJ     NCS         ENTER NEW CONSTANT 
          =X2    -1          INDICATE REDUCED 
          =A6    B6-1        REPLACE *MASK(CON)* WITH CON 
          EQ     EXIT.
  
 ES.MOD   BX1    X5 
          RJ     LCT
          =X2    O=MOD
          LE     B2,ESFX     IF MODULO NOT CONSTANT 
          SX0    X6-1 
          BX7    X0*X6
          NZ     X7,ESFX     IF MODULO NOT POWER OF 2 
          BX6    -X0
          =X7    M.INT
          RJ     NCS         ENTER CONSTANT 
          =X2    O=MODP2
          BX5    X6 
          EQ     ESFX        EXIT.. 
  
 ES.SHIFT BX1    X5 
          RJ     LCT
          =X2    O=SHIFT
          LE     B2,ESFX     IF NOT INTEGER CONSTANT
          SB7    X6-60
          =X2    -1 
          =B6    B6-1 
          ZR     X6,EXIT.    IF NULL SHIFT
          ZR     B7,EXIT.    IF NULL SHIFT
          BX7    X0 
          =B6    B6+1 
          RJ     NCS         ENTER CONSTANT 
          BX1    X6 
          LX0    X6 
          IFBIT  X0,-SHORT,SHIFT  IF NOT SHORT CONSTANT 
          AX1    P.SHC
          NZ     X1,SHIFT    IF MASK CONSTANT NOT POSSIBLE
          BX0    X6 
          AX0    P.MSHORT 
          ZR     X0,SHIFT    IF NOT MASK CONSTANT 
  
*         SHIFT COUNT MAY NOT BE MASK CONSTANT.  IF MASK CONSTANT 
*         PRESENT, IT MUST BE CONVERTED TO PROPER NEGATIVE CONSTANT.
  
          =B7    X0-1 
          MX1    1
          AX1    X1,B7
          MX0    -L.SHC 
          BX0    -X0*X1 
          LX0    P.SHC
          SX1    M.SHORT+M.INT
          BX6    X0+X1
 SHIFT    BX5    X6 
          =X2    O=SHIFTC 
          SA1    BIFSHF 
          EQ     EXIT.
  
 ES.LOCF  BX1    X5 
          RJ     LCT
          ZR     B2,ES.LOC2  IF NOT CONSTANT
  
 ES.LOC1  BX6    X5 
          =B6    B6-1 
          =A6    B6-1 
          FATAL  =XE.IN1
          =X2    -1 
          EQ     EXIT.
  
 ES.LOC2  BX0    X5 
          LX0    59-P.INTR
          BX6    X5 
          LX6    59-P.ARY 
          BX6    X0-X6
          MI     X6,ES.LOC1  IF NOT ARRAY OR TAG
          SX0    M.ADDR+M.LCF 
          MX2    -L.MODE
          LX2    P.MODE 
          BX5    X2*X5       MODE = UNIV
          BX6    X5+X0
          =X2    -1 
          =B6    B6-1        REPLACE LOCF(ARG) WITH ADDR(ARG) 
          =A6    B6-1 
          EQ     EXIT.
  
 ES.RANF  SX6    B4 
          SA1    S.RANDM
          SA6    SCR
          BX7    X1 
          =A7    A6+1 
          TAGSEX A7          TAG *RANDOM.*
          SA2    SCR
          BX1    X6 
          SB4    X2          RESTORE *B4* 
          BX1    X6 
          RJ     CT2         GET PASS *2* TAG 
          =X3    1
          BX5    X6          =XRANDOM 
          LX3    P.2BIAS
          IX4    X3+X6       =XRANDOM+1 
          SA3    RANF 
          BX6    X3 
          SA6    SOPR 
          RJ     ADT
          =X2    -1 
          EQ     EXIT.
  
 ES.AND   SX2    O=AND
          EQ     EXIT.
  
 ES.OR    SX2    O=OR 
          EQ     EXIT.
  
 ES.XOR   SX2    O=XOR
          EQ     EXIT.
  
 ES.COMPL SX2    O=COMPL
          EQ     EXIT.
 MXP      SPACE  4,8
**        MARK EXTERNAL PROCESS BLOCK START.
* 
*         ENTRY  TT.PAR SET TO CURRENT LENGTH 
* 
*         EXIT   O=EPO ENTERED INTO PARSED FILE.
*         USES   CANNOT DESTROY X4,X5  B4,B5,B6 
  
  
 MXP      SUBR               ENTRY/EXIT...
          SA2    TT=PAR 
          SA1    TT.PAR 
          ZR     X2,MXP5     IF START OF NEW BLOCK
          IX0    X1+X2
          SA3    X0-L.TURP
          SB7    X3-O.MXP 
          ZR     B7,EXIT.    IF LAST TURPLE IS *MXP* TURPLE 
 MXP5     ALLOC  A1,L.TURP
          SA1    REFLIN 
          AX1    CHAR 
          BX6    X1 
          SA6    =XTRLINE    STORE LINE NO. FOR TRACEBACK USE 
          LX6    P.TRC       PUT IN BITS 18-29 OF TURPLE OPERANDS 1 , 2 
          SA2    XPOP 
          SA6    B7-1 
          BX7    X2 
          =A6    A6-1 
          =A7    A6-1 
          EQ     EXIT.
 VAM      SPACE  4,8
**        VAM -  VALIDATE ARGUMENT MODE AGREEMENT FOR INTRINSICS
* 
*         ENTRY  (X1) = ARGUMENT TO CHECK 
*                (X2) = DEFINED ARGUMENT MODE IN LOWER 18 BITS
*                (X3) = FUNCTION NAME, 42/NAME,18/GARBAGE, IGNORED. 
* 
*         EXIT   (X0) = 0 MODE AGREEMENT
*                     " 0,MODE MISMATCH, (X1) = TAG WITH MODE CHANGED 
*                         CORRECT MODE. 
*                (X7) = MODE BITS OF ARGUMENT 
* 
*         USES   X0,X1,X2,X7  B7
*                (FILL. IF ERROR FOUND IN ARGUMENT.)
  
  
 VAM      SUBR               ENTRY/EXIT...
          SX2    X2 
          MX0    -L.MODE
          BX7    -X0*X1 
          BX0    X7-X2
          ZR     X0,EXIT.    IF MODE AGREEMENT
          =X0    0
          ZR     X2,EXIT.    IF DEFINED MODE IS TYPELESS
          NZ     X7,VAM1     IF ARGUMENT IS NOT TYPELESS
          SX2    X2-M.DBL 
          MI     X2,EXIT.    IF DEFINED MODE IS SINGLE TYPE 
 VAM1     MX0    L.SYM
          BX6    X0*X3
          SA6    FILL.
          FATAL  E.SU3
          =X7    M.UNIV      MODE BITS = UNIVERSAL
          EQ     EXIT.
 VEL      EJECT  4,20 
**        VEL -  VALIDATE ARGUMENT LIST FOR EXTERNAL. 
* 
*         ENTRY  (X2) = NUMBER OF ARGUMENT -1 
*                (X4) = CURRENT ROUTINE TAG 
* 
*         EXIT   IF 1ST REFERENCE 
*                (PARM) FIELD SET INTO SYMBOL TABLE 
*                ARGUMENT COUNT CHECKED AGAINST *MAX.SARG*
*                IF NOT 1ST REFERENCE 
*                CHECK AGAINST DEFINED ARGUMENT COUNT.
*                ARGUMENT COUNT CHECKED AGAINST *MAX.SARG*
* 
*                (X3) = PERSERVED.
* 
*         USES   A1,A2,A3,A4,A6  X0  B2,B3,B7 
  
  
 VEL      SUBR               ENTRY/EXIT...
          SA1    TS.SYM 
          AX4    P.2TAG 
          =X2    X2+1        ACTUAL ARGUMENT COUNT
          SB2    X4-C.SYM 
          =X0    M.DEF
          SA4    X1+B2       TAG FROM SYMBOL TABLE
          BX1    X0*X4
          SB2    X2-MAX.SARG
          NZ     X1,VEL30    IF ALREADY DEFINED 
          LX2    P.UARGC
          BX7    X4+X0       SET DEFINED BIT
          IX6    X7+X2       SET ARGUMENT COUNT 
          SB7    E.SU8       EXCEEDS COMPILER LIMITS
          GT     B2,VEL50    IF EXCEEDS COMPILER DEFINED LIMITS 
          SA6    A4          RESET IN SYMBOL TABLE WITH PARMS+DEFINED 
          EQ     EXIT.
  
  
**        HERE IF NOT 1ST REFERENCE TO EXTERNAL 
*         (X2) = ARGUMENT COUNT.
  
 VEL30    MX0    -L.UARGC 
          LX4    -P.UARGC 
          BX0    -X0*X4      LAST ARGUMENT COUNT
          SB7    E.SU2       IN CASE OF ERROR.
 VEL40    IX6    X0-X2
          NZ     X6,VEL50    IF ARGUMENT COUNT NON-AGREEMENT. 
          SB7    E.SU8       EXCEEDS COMPILER LIMITS
          LE     B2,EXIT.    IF DOES NOT EXCEED COMPILER DEFINED LIMITS 
  
**        ARGUMENT COUNT DOES NOT AGREE WITH LAST USAGE OR WITH DEFINED 
*         *ANSI*. 
  
  
 VEL50    =A2    A4-1        LOAD SYMBOL ENTRY
          MX1    L.SYM
          BX6    X1*X2
          SA6    FILL.
          FATAL  B7 
          EQ     EXIT.
 VIL      EJECT  4,20 
**        VIL -  TERMINATE ARGUMENT LIST PROCESSING.
* 
*         ENTRY  (X2) = NUMBER OF ARGUMENT -1 
*                (X4) = CURRENT ROUTINE TAG 
* 
*         EXIT   (X3) = PERSERVED.
*                (A4) _ TAG TABLE ENTRY OF ROUTINE. 
* 
*         USES   A1,A2,A3,A4,A6  X0  B2,B3,B7 
  
  
 VIL      SUBR               ENTRY/EXIT...
          SA1    TS.SYM 
          AX4    P.2TAG 
          =X2    X2+1        ACTUAL ARGUMENT COUNT
          SB2    X4-C.SYM 
          SA4    X1+B2       SYMBOL TABLE ENTRY 
  
**        HERE IF NOT 1ST REFERENCE TO EXTERNAL 
*         (X2) = ARGUMENT COUNT.
  
 VIL30    MX0    -L.ARGC
          LX4    -P.ARGC
          BX0    -X0*X4      DEFINED ARGUMENT COUNT 
          SB7    E.SU10      IN CASE OF ERROR.
          SB2    X2 
          NZ     X0,VIL40    IF NOT INFINITE ARGUMENT COUNT TYPE
          GT1    B2,EXIT.    IF NOT ONE ARGUMENT
          SB7    E.SU9
          EQ     VIL50       OUTPUT ERROR 
  
 VIL40    IX6    X0-X2
          ZR     X6,EXIT.    IF ARGUMENT COUNT AGREEMENT
  
**        ARGUMENT DOES NOT AGREE WITH DEFINED COUNT OF INTRINSIC 
  
 VIL50    =A2    A4-1        LOAD SYMBOL
          MX1    L.SYM
          BX6    X1*X2
          SA6    FILL.3 
          FATAL  B7 
          EQ     EXIT.
 SUBS     SECT   (S U B S C R I P T S),1
 SUBSPTS  EJECT  4,20 
 SUBSPTS  EJECT  4,20 
**        SUBSCRIPTS - FOLLOWING SECTION CONTAINS ALL CODE RELATED TO 
*         PASS 1, AND PASS 2 PROCESSING OF SUBSCRIPTS.
* 
*         1.  GENERAL DESCRIPTION OF ACTION TAKEN DURING PASS 1.
* 
*         2.  GENERAL DESCRIPTION OF ACTION TAKEN DURING PASS 2.
  
 MIS      SPACE  4,20 
**        MISCELLANEOUS CONSTANTS USED BY SUBSCRIPT PROCESSORS. 
* 
*         *DIM* = DIMENSION LENGTH. 
**T DIM   60/DIMENSION LENGTH 
* 
*         *DIMUL* = CURRENT SUBSCRIPT MULTIPLIER. 
**T DIMUL 60/CURRENT SUBSCRIPT MULTIPLIER.
* 
*         *DIMBIAS* = BIAS FOR SUBSCRIPT. 
**T DIMBIAS 12/0,24/RUNNING TOTAL,24/CURRENT BIAS 
* 
*         *DIMSYM* = SYMBOL FOR ARRAY BEING PROCESSED.
**T DIMSYM  18/SATAG,5/0,1/A,18/SVBIAS,18/SDIMNO
*         *A* = *SANSI* 
  
  
 DIM      DATA   0           DIMENSION LENGTH.
 DIMUL    DATA   0           CURRENT SUBSCRIPT MULTIPLIER.
 DIMBIAS  DATA   0           BIAS FOR SUBSCRIPT.
  
 DIMSYM   DATA   0           SYMBOL FOR ARRAY CURRENTLY PROCESSING. 
 SDIMNO   DEFINE 0,18        CURRENT DIMENSION NUMBER.
 SVBIAS   DEFINE 18,MAX.DIM  INDICATE DIMENSIONALITY IS A VARIABLE
 SANSI    DEFINE 36          NO ANSI ERROR FOUND IF 0 
          IFGT   P.SVBIAS+L.SVBIAS,P.SATAG,1
 9        ERR    NUMBER OF SUBSCRIPTS DEFINED EXCEEDS COMPILER LIMITS 
 SUBERR   SPACE  4,8
**        SUBERR - SUBSCRIPT ERROR MACRO
* 
*         SUBERR ERRADDR
* 
*         ERRADDR = ERROR SKELETON ADDRESS (B7).
*                   MUST HAVE RETURN ADDRESS = *. 
  
  
 SUBERR   MACRO  ERRADDR
          =B7    ERRADDR
          RJ     OSE
 SUBERR   ENDM
 CSR      SPACE  4,8
**        CSR -  CHECK SUBSCRIPT RESULTS
* 
*         ENTRY  (X1) = RESULTS FROM SUBSCRIPT JUST FINISHED PROCESSING 
*                (X4) = ARGCOMA 
*                (DIMBIAS) = LOWER 24 BITS = ADDIN CONSTANTS FOUND BY 
*                            *PSO* WHILE PROCESSING CURRENT SUBSCRIPT 
* 
*         EXIT   (X4) = (ARGCOMA) 
*                (X6) = (DIMBIAS) UPDATED 
*                (SRES)= 0, IF RESULTS OF SUBSCRIPT NOT A CONSTANT. 
*                           OTHERWISE BINARY OF SUBSCRIPT CONSTANT. 
* 
*         USES   A1,A2,A3  X0  B2,B7
  
  
 CSR      SUBR               ENTRY/EXIT.. 
  
 SNAP=S   IFNE   TEST        DUMP REGISTERS IF SNAP=S 
          SA2    CO.SNAP
          LX2    1RS
          PL     X2,CSR1SN   IF *S* SNAP NOT SELECTED 
 CSR      REG 
 CSR1SN   BSS    0
 SNAP=S   ENDIF 
  
          MX0    -L.MODE
          BX0    -X0*X1 
          =B2    X0-M.INT 
          ZR     B2,CSR5     IF SUBSCRIPT RESULTS INTEGER.
          =B2    X0-M.UNIV
          ZR     B2,CSR5     IF SUBSCRIPT RESULTS MODELESS
          BX6    X4 
          SA6    MODECON     SAVE *ARGCOMA* 
          =X7    B6-1 
          RJ     ISR         INTEGERIZE SUBSCRIPT 
          SA4    MODECON     RESTORE *ARGCOMA*
 CSR5     RJ     LCT         CHECK IF CONSTANT RESULTS
          SA1    DIMBIAS
          MX0    -L.2BIAS 
          SX7    B2 
          SA6    SRES        SUBSCRIPT RESULT 
          =A7    A6-SRES+SIND  SUBSCRIPT INDICATOR
          SA3    DIMUL       CURRENT MULTIPLIER 
          BX2    -X0*X1      CONSTANTS FOUND WITHIN SUBSCRIPT 
          LX2    60-L.2BIAS 
          AX2    60-L.2BIAS  CURRENT BIAS 
          MI     X3,CSR6     IF CONSTANT TERM 
          =X5    X2-1 
          DX5    X5*X3       (BIAS - 1) * MULTIPLIER
          IX7    X5+X6       ADD ANY CONSTANT RESULT TO BIAS
          EQ     CSR12
  
 CSR6     LX5    B1,X3
          IX7    X2+X6       BIAS+CONSTANT RESULT 
          MI     X5,CSR20    IF VARIABLE DIMENSION MULTIPLIER 
          AX6    B1,X5       ACTUAL MULTIPLIER
          IX7    X7-X6       SUBTRACT MULTIPLIER FROM BIAS
          SA6    A3 
  
*         (X1) = LAST BIAS   36/ LAST BIAS, 24/GARBAGE
*         (X7) = BIAS FOUND WITHIN CURRENT SUBSCRIPT, 36/GARBAGE,24/BIAS
  
 CSR12    AX1    24 
          IX6    X1+X7       ADD IN LAST BIAS - CLEAR CURRENT 
          LX6    24 
          SA6    DIMBIAS     RESET DIMBIAS
          EQ     EXIT.
* 
*          CURRENT MULTIPLIER IS VARIABLE....OUTPUT TURPLES 
*                 (1) VARIABLE MULTIPLIER*CURRENT BIAS
*                 (2) CURRENT RESULT + INTERMEDIATE OF (1)
* 
*          (X2) = CURRENT BIAS
*          (X3) = -VARIABLE MULTIPLIER TAG (P.2TAG PORTION ONLY)
* 
 CSR20    =X2    X2-1 
          =B2    X2-1 
          =X7    0
          ZR     X2,CSR12    UPDATE DIMBIAS, CURRENT BIAS=0.
          BX5    -X3
          SX1    M.INT+M.2PRO 
          LX5    P.2TAG      GENERATE PASS 2 VARIABLE TAG 
          IX5    X5+X1       PASS 2 VARDIM TAG
          LX6    X4 
          SB6    B6+2 
          SA7    ATTR        CLEAR ATTRIBUTES CELL
          SA6    CSRA        SAVE *X4*
          NZ     B2,CSR25    IF DIMBIAS " 1 
          BX6    X5 
          =B6    B6-1 
          =A6    B6-1 
          EQ     CSR30
 CSR25    LX6    X2          CONSTANT BIAS
          RJ     NCS         GENERATE CORRECT CONSTANT TAG. 
*                            (X6) = CONSTANT TAG
*                            (X5) = V.TAG 
          BX4    X6          CONSTANT TAG 
          SA2    MULT        MULTIPLY OPERATOR
          MX0    -L.SBPR
          SX1    O.MULT 
          BX3    X0*X2       CLEAR *SB* PRIORITY
          IX6    X3+X1       PASS 2 MULTIPLY OPERATOR 
          LX3    X6 
          SA6    SOPR        SET CURRENT OPERATOR 
          RJ     SDM
          RJ     ADT         PUT TURPLE ON TT.PAR FILE
 CSR30    SA2    PLUS        PLUS OPERATOR WORD 
          SX1    O.PL 
          MX0    -L.SBPR
          =A5    B6-1        RESULT OF MULTIPLY TURPLE
          BX3    X0*X2       CLEAR *SB* PRIORITY FROM OPERATOR
          =A4    A5-1        RESULT TAG OF CURRENT SUBSCRIPT
          IX6    X3+X1       PASS 2 PLUS OPERATOR 
          LX3    X6 
          SA6    SOPR        SET CURRENT OPERATOR 
          RJ     SDM
          RJ     ADT         PUT PLUS TURPLE ON TT.PAR FILE 
          SA1    DIMBIAS     CURRENT BIAS 
          SA4    CSRA        RESTORE *X4* 
          =X7    0
          EQ     CSR12
 CSRA     BSS    1
 CVT      SPACE  4,20 
**        CVT -  COMPUTE *VARDIM* TAG FOR SUBSCRIPT PROCESSORS. 
* 
*         ENTRY  (B2) = SUBSCRIPT NUMBER FOR V-TAG. 
*                (B3) = ORDINAL OF *TP.DIM* INFO FOR THIS ARRAY.
* 
*         EXIT   (X6) = V-TAG OF USE FOR SUBSCRIPT MULTIPLIER OR
*                    LENGTH DEPENDING ON ENTRY CONDITIONS DEFINED BY
*                    B2.
**T       (X6)  L.TAG/V-TAG, L.BIAS/0, L.FPNO/0, L.2CLAS/0, L.MODE/M.INT
*                       (PASS *2* FORM) 
* 
*         USES   A1,A2,A3,A4,A5,A6,A7  X0  B2,B3,B7 
*                (SCR2 - SCR2+3)
*         NOTE -- X3,X4,X5 ARE PRESERVED. 
* 
*         CALLS  ALLOC
  
  
 CVT      SUBR               ENTRY/EXIT...
          SA1    TP.DIM 
          SA2    B2+DIMPT.
          SB7    X1+B3
          SX6    B2 
          SA3    X2+B7       LOAD TP.DIM ENTRY
          AX2    18 
          SA6    CVTA 
          BX1    X3 
          ZR     X2,CVT10    IF DIMENSIONALITY IN LOW ORDER 
          AX3    P.DIM
 CVT10    BX6    X3 
          IFBIT  X6,-SDIM,CVT20    IF VARDIM TAG NOT PROCESSED
          MX0    -L.TAG 
          BX6    -X0*X3      CURRENT V.TAG
          LX2    X6 
          LX2    P.2TAG 
          EQ     EXIT.
  
*         SUBSCRIPT DIMENSIONALITY IS A VARIABLE AND HAS NOT YET BEEN 
*         PROCESSED INTO A LOCAL *VARDIM* CELL. 
*         (X3) _ SYMBOL TABLE ORDINAL FOR VARIABLE
  
 CVT20    MX0    -L.TAG 
          SA2    TS.SYM 
          LX7    X4 
          BX6    X5 
          SA7    SCR2        SAVE *X4*
          =A6    A7+1        SAVE *X5*
          BX6    -X0*X3 
          LX3    -P.TDIM-1
          MI     X3,CVT22    IF CURRENT DIMENSION IS VARIABLE 
          SX7    M.INT
          RJ     NCS         GENERATE CORRECT CONSTANT
          BX4    X6 
          EQ     CVT30
  
 CVT22    SB7    X2 
          SA1    X6+B7       VARIABLE DIMENSION 
          RJ     CT2         PASS *2* FORM
          BX4    X6 
          NE1    B2,CVT30    IF NOT 1ST SUBSCRIPT 
 CVT25    BSS    0
          ALLOC  T.VDIM,L.TURP
          =X5    B7-1 
  
*         OUTPUT *O.=* MACRO TO *VARDIM* FILE.
*         (X5) = NEXT TABLE ENTRY 
  
          SA2    TG.VDIM     CURRENT VARIABLE DIMENSION TAG 
         =X6    X2+1
          SA1    CVTA 
          SA6    A2 
          SB2    X1 
          RJ     SVT         SET VARDIM TAG IN *DIM* TABLE
          LX7    X4          DIMENSIONALITY 
          BX6    X2          V-TAG
          =A6    X5          OR.2OP = *V-TAG* 
          SA3    VD.EQ
          =A7    A6-1        OR.1OP = VARIABLE DIMENSION
          BX6    X3 
          =A6    A7-1 
          EQ     CVT45       SET EXIT CONDITIONS
  
*         SUBSCRIPT NOT LAST ONE TO BE PROCESSED, CHECK IF
*         NEXT TO LAST ONE ALREADY CONVERTED TO LOCAL CELL AND
*         OUTPUT MULTIPLY TO GET CURRENT SUBSCRIPT. 
*         (X4) = SYMBOL TABLE TAG FOR DIMENSIONALITY
  
CVT30    SA1    DIMUL 
         PL     X1,CVT40    IF FIRST VARIABLE DIMENSION 
         BX2    -X1         PREVIOUS DIM. MULTIPLIER TAG
         SX3    M.INT+M.2PRO
         LX2    P.2TAG
         BX5    X2+X3 
CVT35    ALLOC  T.VDIM,L.TURP 
         LX7    X5          PREVIOUS MULT. TAG (PASS 2 FORMAT)
         LX6    X4          CURRENT DIMENSION TAG 
         SA3    VD.MULT 
         =A7    B7-1
         LX7    X3
         =A6    A7-1
         SA1    T.VDIM      ORIGIN OF T.VDIM FILE 
         =A7    A6-1        MULTIPLY OPERATOR TO T.VDIM 
         SX2    A7          ADDRESS OF MULTIPLY OPERATOR IN T.VDIM
         IX3    X2-X1       RELATIVE ADDRESS OF MULTIPLY TURPLE 
         LX3    P.2TAG
         SA2    VD.INTR       MAKE INTERMEDIATE TAG FOR STORE TURPLE
         BX4    X2+X3 
         EQ     CVT25       PUT STORE TURPLE ON T.VDIM FILE 
CVT40    LX6    X1          PREVIOUS MULTIPLY CONSTANT
         SX7    M.INT 
         RJ     NCS         GENERATE CORRECT CONSTANT TAG 
         LX5    X6
         EQ     CVT35       GENERATE NEW MULTIPLIER.
  
*         SET EXIT CONDITIONS, RESTORE REGISTERS
*         (X2) = V-TAG IN LOW ORDER 18 BITS 
  
 CVT45    SA4    SCR2        RESTORE *X4* 
          BX6    X2 
          =A5    A4+1        RESTORE *X5* 
          AX6    P.2TAG 
          EQ     EXIT.
  
          BSS    0
 DIMPT.   EQU    *-1
          VFD    24/0,18/1,18/1     DIMENSIONALITY = 1
          VFD    24/0,18/0,18/2     DIMENSIONALITY = 2
          VFD    24/0,18/1,18/2     DIMENSIONALITY = 3
          VFD    24/0,18/0,18/3     DIMENSIONALITY = 4
          VFD    24/0,18/1,18/3     DIMENSIONALITY = 5
          VFD    24/0,18/0,18/4     DIMENSIONALITY = 6
          VFD    24/0,18/1,18/4     DIMENSIONALITY = 7
  
 CVTA     DATA   0
 C=ARRAY  SPACE  4,8
**        C=ARRAY -  RESET DIMENSION MULTIPLIER FOR SUBSCRIPT OPERATION.
* 
*         C=ARRAY UPDATES.
*                1. DIMUL   CURRENT SUBSCRIPT MULTIPLIER. 
*                2. DIM     CURRENT DIMENSIONALITY. 
*                3. DIMBIAS (IF LAST SUBSCRIPT RESULTED IN A CONSTANT)
* 
*         ENTRY  (X3) = COMMA OPERATOR. 
*                (X5) = RESULTS FROM CURRENT SUBSCRIPT
*                (B5) _ SPECIAL LEFT PAREN FOR CURRENT ARRAY. 
* 
*         EXIT   (B4) UPDATED BY 1. 
*                IF AN ERROR OCCURED IN PROCESSING CURRENT SUBSCRIPT
*                EXIT IS TO *EOS*.
*                OTHERWISE EXIT IS TO PAR.NX. 
* 
*         USES   A1,A2,A3  X0  B2,B3,B7 
* 
*         CALLS  CSR
  
  
 C=ARRAY  BSS    0           ENTRY... 
          SA4    ARGCOMA
          BX1    X5 
          RJ     CSR         CHECK SUBSCRIPT RESULTS
  
**        (X4) = ARGCOMA
  
          BX0    X4 
          AX4    P.ACM
          SB2    X4          ORDINAL OF DIMENSION 
          SA1    TP.DIM 
          BX6    X0          ARGCOMA IF NOT INTO NEW WORD.
          SA3    X1+B2       LOAD NEXT DIMENSIONALITY WORD. 
          LX0    59 
          SA4    DIM
          MI     X0,C=AR50   IF EVEN SUBSCRIPT NUMBER.
          =X1    1
          AX3    P.DIM       CURRENT DIMENSIONALITY 
          LX1    P.ACM
          IX6    X6+X1       RESET DIMENSIONALITY (TP.DIM) POINTER WORD 
 C=AR50   BSS    0
          SA6    ARGCOMA     UPDATE ARGCOMA.
          SA1    DIMUL
  
  
**        PROCESS BIAS IF DIMENSIONALITY IS CONSTANT
*         (A1) _ DIMUL. 
*         (X1) = LAST VALUE OF *DIMUL*
*         (A4) _ DIM. 
*         (X3) = NEW DIMENSIONALITY.
  
          MX0    -L.DIM 
          BX7    -X0*X3 
          SA7    A4          RESET CURRENT DIMENSION (DIM)
          BX2    X4 
          MI     X1,C=AR75   IF CURRENT MULTIPLIER IS VARIABLE
          LX2    -P.TDIM-1
          MI     X2,C=AR75   IF CURRENT DIMENSION IS VARIABLE 
          IX7    X1*X4
          SA7    A1          RESET DIMENSION MULTIPLIER.
          SA3    SRES 
          LX2    X7 
  
**        RESET DIMENSION MULTIPLIER. 
*         (X2) = CURRENT MULTIPLIER 
*         (X3) " 0, IF CONSTANT RESULTS FROM PREVIOUS SUBSCRIPT.
  
          SB7    X2-1 
          SA4    PLUS(S 
          =X5    O.PL 
          =X1    B7+1 
          SB2    X3 
          NZ     B7,C=AR72   IF CURRENT MULTIPLIER NOT = 1
          NE1    B2,C=AR90   IF CURRENT RESULTS NOT = 1 
          =B6    B6-1        ELIMINATE LAST RESULTS, ALREADY IN DIMBIAS 
          =B4    B4+1        SET = NEXT ELEMENT 
          EQ     PAR.NX      CONTINUE 
  
**        IF RESULTS FROM LAST SUBSCRIPT NOT = 1
*         (X1) = MULTIPLIER IN LOWER 18 BITS
  
 C=AR72   LX1    P.SHC
          =X2    M.SMULT+M.SHORT+M.INT
          ZR     X3,C=AR80   IF PREVIOUS SUBSCRIPT NOT SIMPLE CONSTANT
          =B6    B6-1 
          EQ     C=AR85      BYPASS ADD IN OF CONSTANT. 
  
**        PROCESS SETTING OF VARIABLE DIMENSION TAG AS SUBSCRIPT
*         MULTIPLIER. 
* 
*         (X6) = ARGCOMA
* 
C=AR75   BX0    X6
         SB2    X6          CURRENT SUBSCRIPT NUMBER (1-7)
         AX0    2*18
         SB3    X0          *TP.DIM* ORDINAL (CONTROL WORD) 
         RJ     CVT         COMPUTE NEXT VARDIM MULTIPLIER TAG
         BX1    X2          NEXT MULTIPLIER TAG 
         SA4    PLUS(S      SUBSCRIPT PLUS OPERATOR 
         BX6    -X6         NEGATIVE MULTIPLIER FLAGS VARDIM
         =X2    M.2PRO+M.INT
         SA6    DIMUL       SET NEW MULTIPLIER
          SA3    SIND 
          ZR     X3,C=AR80   IF RESULT NOT CONSTANT 
          =B6    B6-1         REMOVE CONSTANT RESULT FROM ESTACK
          EQ     C=AR85       DONT PUT PLUS OPERATOR ON STACK 
**        PLUS OPERATOR TO STACK TO ADD PREVIOUS SUBSCRIPT VALUE
*         (X1) = MULTIPLIER 
*         (X2) = CLASS AND MODE BITS FOR MULTIPLIER 
*         (X4) = PLUS OPERATOR
  
 C=AR80   =B5    B5+1 
          BX6    X4 
          SA6    B5          PLUS OPERATOR TO OSTACK. 
  
**        MULTIPLIER TO ELEMENT STACK.
*         (X1) = MULTIPLIER SHIFTED BY P.SHC
*         (X2) = TYPE BITS FOR MULTIPLIER 
  
 C=AR85   BX6    X1+X2
          SA4    MULT(S 
          SA6    B6          MULTIPLIER TO ESTACK.
          =B6    B6+1 
          =X5    O.STAR 
  
**        ADD OR MULTIPLY TO OPERATOR STACK (B5)
*         (X4) = OPERATOR STACK WORD (EITHER PLUS OR MULTIPLY)
*         (X5) = DPC FOR OPERATOR.
  
 C=AR90   MX0    -L.SBPR
          =B5    B5+1 
          BX1    X0*X4
          =B4    B4+1 
          IX6    X1+X5
          SA6    B5          OPERATOR TO STACK
          EQ     PAR.NX      CONTINUE.
 A=ARRAY  EJECT  4,20 
**        PROCESS CLOSING PAREN FOR CURRENT SUBSCRIPT.
*         POP HOLDING STACK FOR SUBSCRIPT.
* 
*         ENTRY  (X2) = (ARGCOMA) = (SCR+1) 
*                (X4) = RESULTING TAG FOR LAST SUBSCRIPT IN THIS
*                       REFERENCE 
* 
* 
*         FORMS OF STACK ENTRY IS --
* 
*         A.  SIMPLE SUBSCRIPT
*                N    =  ARGMODE. 
*                N+1  =  ARGCOMA
*                N+2  = (DIMSYM)
* 
*         B.  SUBSCRIPTED SUBSCRIPT FORM IS 
*                N - N+2 SAME AS SIMPLE SUBSCRIPT FORM. 
*                N+3  =  CURRENT DIMENSION
*                N+4  =  CURRENT DIMENSION BIAS 
*                N+5  =  ARRAY DIMENSION ORDINAL. 
  
  
 A=ARRAY  BSS    0
          SX4    X2+1        SUBSCRIPT NUMBER 
          BX1    X5          RESULTS OF SUBSCRIPT 
          RJ     CSR         CHECK SUBSCRIPT RESULTS
  
**        LOAD COMPUTED OFFSET FROM *DIM* TABLE 
*         (X6) = (DIMBIAS)
  
          SA2    DIMSYM 
          SA1    TS.SYM 
          AX2    P.2TAG 
          SA3    TP.DIM 
          SB3    X2-C.SYM 
          SA2    X1+B3       TAG WORD FROM SYMBOL TABLE 
          MX0    -L.PNT 
          AX2    P.PNT
          BX1    -X0*X2 
          MX0    -L.DIMOS 
          SB3    X1 
          SA1    X3+B3       DIMENSION INFO WORD
          AX6    24 
          BX3    -X0*X1      DIMENSION OFF-SET COMPUTED AT DECLARATIVE
  
**        (X6) = BIAS - TP.DIM
*         (X4) = (ARGCOMA) FOR SUBSCRIPT. 
*         (A2) _ DIMBIAS
  
  
          SA1    DIMSYM 
          SA6    DIMBIAS     RESET BIAS 
          SX1    X1          NUMBER OF DIMENSIONS ONLY
          SX4    X4          SUBSCRIPT COUNT ONLY 
          IX0    X1-X4
          BX3    X6 
          SB2    X0+0 
          ZR     B2,A=AR20   IF REFERENCE MATCHES DIMENSION.
          PL     B2,A=AR10   IF FEWER SUBSCRIPTS THAN DIMENSIONED 
          SUBERR =XE.SB8     FATAL -- TOO MANY SUBSCRIPTS 
          EQ     A=AR15 
  
 A=AR10   SUBERR =XE.SB2     SUBSCRIPTED WITH FEWER THAN DIMENSIONED
  
 A=AR15   SA3    DIMBIAS
  
**        DETERMINE TYPE OF SUBSCRIPT AND PROCESS EITHER BY OUTPUT OF 
*         A *SUBSCRIPT* MACRO, OR A SIMPLE OPERAND TO OTHER MACRO 
* 
*         (X3) = CONSTANT BIAS ON ARRAY REFERENCE 
  
 A=AR20   SX1    M.LONG 
          SA4    B6-2        1ST OPERAND
          MX0    -L.2BIAS 
          BX1    X1*X4       SET/CELL LONG BIT
          ZR     X1,A=AR52   IF NOT DOUBLE WORD ARRAY 
          LX3    1           MULTIPLY BIAS BY *2* FOR DOUBLE WORD 
 A=AR52   LX3    P.2BIAS
  
**        ADD IN BIAS FIELD.
*         (X4) = ARRAY
*         (X5) = ADDRESS FUNCTION FOR *ARRAY* REFERENCE.
  
          LX0    P.2BIAS
          BX1    X0*X4       CLEAR BIAS FIELD.
          BX3    -X0*X3 
          =B3    0           INDICATE IGNORE OPERATOR.
          BX6    X3+X1
          =B6    B6-1        ELIMINATE ADDRESS FUNCTION 
          SA1    SIND        CONSTANT INDICATOR FOR ADDRESS FUNCTION
          BX2    X5 
          SA6    A4          ADD IN BIAS FIELD TO ARRAY TAG.
          SA2    B5-3 
          =A5    A2+1 
          BX6    X2 
          LX7    X5 
          =A3    A5+1 
          =A5    A3+1 
          SA6    DIM         RESET (DIM)
          SB5    B5-4 
          BX6    X3 
          =A7    A6+1        RESET (DIMUL)
          BX7    X5 
          =A6    A7+1        RESET (DIMBIAS)
          =A7    A6+1        RESET (DIMSYM) 
          NZ     X1,POPX     IF SUBSCRIPT RESULTED IN CONSTANT
  
**        ADDRESS FUNCTION OTHER THAN SIMPLE CONSTANT.
*         OUTPUT SUBSCRIPT MACRO. 
  
          BX1    X4 
          =B6    B6+1        ADDRESS FUNCTION ELEMENT NEEDED
          IFBIT  X1,-LONG,A=AR56     IF NOT DOUBLE WORD ARRAY 
          =X5    1           2ND OPERAND
          =A4    B6-1        1ST OPERAND = ADDRESS FUNCTION 
          SA3    SHFC 
          LX5    P.PTAGM
          =B6    B6+1 
          BX6    X3 
          SA6    SOPR 
          RJ     ADT
  
 A=AR56   =A4    B6-1        2ND OPERAND
          SX0    M.2ARY+M.INTR
          BX1    X0*X4
          BX1    X0-X1
          MX5    0
          NZ     X1,A=AR57   IF NOT SUBSCRIPTED SUBSCRIPT 
          SA3    XMITOP 
          BX6    X3 
          =B6    B6+1        INCREMENT FOR XMIT TURPLE
          SA6    SOPR 
          RJ     ADT
 A=AR57   MX0    1
          SA2    ARGMODE
          LX0    P.AMADDR+1 
          SA1    ATTR 
          BX7    X0*X2       BRING DOWN ADDRESS BIT FROM *ARGMODE*
          AX7    P.AMADDR-P.OPADDR
          SA3    SUBOP
          =A4    B6-2        1ST OPERAND
          IX6    X3+X7       ADD ADDRESS BIT, IF SET
          =A5    A4+1        2ND OPERAND
          AX7    P.OPADDR-P.ADDR
          SX0    X7+M.ARY+M.2ARY
          BX7    X0+X1       ADD IN M.ARY BIT 
          SA7    ATTR        ATTRIBUTE = ARRAY
          SA6    SOPR        SUBSCRIPT OPERATOR.
          BX3    X6 
          EQ     POP.STD
 ISR      SPACE  4,8
**        ISR -  INTEGERIZE SUBSCRIPT 
* 
*         ENTRY  (X1) = SUSBCRIPT OTHER THAN INTEGER TO BE CONVERTED. 
*                (X4) = ARGCOMA.
* 
*         EXIT   (X1) = TAG FOR INTEGERIZED RESULTS.
* 
*         USES   A1,A2,A3,A4,A5,A6,A7  X0  B2,B3,B7 
*         CALLS  ADT, NCS 
  
  
 ISR45    MX0    -L.MODE
          =X7    M.INT
          BX2    X0*X5       EVERYTHING BUT MODE
          BX5    X7+X2       DUMMY MODE AS INTEGER
 ISR50    SUBERR B7 
          SA2    ISRA+1 
          BX7    X5 
          SA7    X2          SET NEW OPERAND BACK 
          LX1    X5 
  
 ISR      SUBR               ENTRY/EXIT...
          =X6    M.INT
          SA7    ISRA+1      SAVE ADDRESS OF OPERAND
          SA6    SMOD        SET RESULT MODE TO INTEGER 
          BX5    X1 
          RJ     LCT         CHECK IF CONSTANT
          SB3    X0-M.REAL
          PL     B3,ISR5     IF FLOATING POINT
          SB2    X0-M.LOG 
          SB7    E.SB4
          NZ     B2,ISR45    IF NOT LOGICAL 
          SB7    E.SB6       SUBSCRIPT CAN NOT BE LOGICAL 
          EQ     ISR45
  
*         IF SUBSCRIPT IS FLOATING POINT
  
 ISR5     BX1    X5 
          ZR     B2,ISR10    IF NOT SIMPLE CONSTANT 
          =X7    M.INT
          UX0,B7 X6          CONVERT TO INTEGER 
          LX6    B7,X0
          RJ     NCS         ENTER CONSTANT AS INTEGER
          BX5    X6 
          SB7    E.SB4
          EQ     ISR50       EXIT.. 
  
*         SUBSCRIPT NOT SIMPLE CONSTANT 
  
 ISR10    LX7    X4 
          SA7    ISRA        SAVE *X4*
          SA3    INTMAC 
          =X4    0           DUMMY 1ST OPERAND
          BX6    X3 
          =B6    B6+1        DUMMY OPERAND FOR *INT*
          SA6    SOPR 
          RJ     ADT         ADD TURPLE 
          SA1    B6-1        RESET SUBSCRIPT OPERAND
          BX5    X1 
          SB7    E.SB4
          SA4    ISRA        RESTORE *X4* 
          EQ     ISR50       OUTPUT NOTE DIAGNOSTIC 
  
 ISRA     DATA   0           SAVE *X4*
          DATA   0           SAVE OPERAND ADDRESS 
 PSO      EJECT 
**        PSO -  PROCESS SUBSCRIPT OPERATION. 
* 
*         *PSO* CHECKS EACH TURPLE BEING POPPED WHILE PROCESSING A
*         SUBSCRIPT TO ANALYZE IF CURRENT TURPLE CAN BE REDUCED TO A
*         SIMPLER TURPLE, COMPLETELY ELIMINATED, ADDED TO PREVIOUS
*         TURPLE OR POPPED AS IS. 
*         *PSO* ALSO CHECKS FOR NON-ANSI SUBSCRIPT OPERATIONS, AND
*         WHETHER CURRENT OPERATION DEFINES A SUBSCRIPT TO BE OUTSIDE 
*         THE LIMITS FOR CURRENT ARRAY SUBSCRIPT IS OPERATING ON. 
* 
*         ENTRY  CALLED FROM *POP*
*                (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
* 
*                (B4) _ NEXT CHARACTER IN *SB*. 
*                (B6)-2 _ 1ST OPERAND FOR OPERATOR. 
*                (B6)-1 _ 2ND OPERAND FOR OPERATOR. 
* 
*                (A7) _ 2ND OPERAND FOR LAST TURPLE POPPED. 
* 
*         EXIT   (X3) = 0 SUBSCRIPT PROCESSED.
*                       (X3,X4,X5) NOT PRESERVED. 
* 
*                (X3) " 0 CONTINUE NORMAL FLOW. 
*                       (X3,X4,X5) PRESERVED. 
* 
*         USES   A1,A2,A3,A6,A7  X0  B2,B3,B7 
*                (SCR2) 
*         NOTE   IF REDUCED ALSO USES - A4,A5 
* 
*         CALLS  CCR, LCT, PCA, PVD 
  
  
 PSONX    SA3    SOPR        RELOAD OPERATOR WORD 
 PSOX     =X0    M.SMULT     CLEAR *SMULT* ON BOTH OPERANDS FOR PASS 2
          LX1    X4 
          BX2    X5 
          AX1    P.TGB
          AX2    P.TGB
          SX1    X1-C.VDIM/1S13 
          ZR     X1,PSO80    IF 1ST OPERAND IS *PROGRAM* TAG
          BX4    -X0*X4 
 PSO80    SX2    X2-C.VDIM/1S13 
          ZR     X2,PSO81    IF 2ND OPERAND IS *PROGRAM* TAG
          BX5    -X0*X5 
  
 PSO81    BSS    0
  
  
 PSO      SUBR   -           ENTRY/EXIT...
          SA2    ARGMODE
          SB7    X2-A=ARRAY 
          NZ     B7,EXIT.    IF NOT IN ARRAY SUBSCRIPT - EXIT 
          SA2    ="SUBOPS2"  ANSI TEST (SUBSCRIPT ALREADY NOTED)
          SB2    X3 
          LX0    B2,X2
          MI     X0,PSO10    IF LEGAL ANSI OPERATOR.
          SA2    ARGCOMA
          BX6    X4 
          =X4    X2+1 
          SA6    ISRA 
          SUBERR E.SB3
          SA4    ISRA 
  
**        CHECK IF THIS PART OF SUBSCRIPT IS INTEGER OR MODELESS
  
 PSO10    SA2    SMOD 
          =B7    X2-M.INT 
          =B2    X2-M.UNIV
          AX2    18 
          =B3    0
          ZR     B7,PSO15    IF DOMINANT MODE = INTEGER 
          ZR     B2,PSO15    IF DOMINANT MODE = MODELESS
          =B3    1
  
 PSO15    ZR     X2,PSO20    IF NO MIXED MODE 
          BX6    X4 
          SA1    ARGCOMA
          SA6    ISRA 
          =X4    X1+1 
          SUBERR E.SB7
          SA4    ISRA        RELOAD *X4*
  
**        CHECK IF CURRENT TURPLE IS A SIMPLE CONSTANT COMBINATION. 
  
 PSO20    SB7    X3-O.MULT
          =X0    M.SMULT
          NZ     B7,PSO25    IF NOT PROCESSING MULTIPLY, NOT SUBS RESULT
  
*         CHECK IF PROCESSING SUBSCRIPT RESULTS 
  
          SA1    B6-2        1ST  OPERAND 
          =A2    A1+1        2ND  OPERAND 
          BX7    X0*X1       EXTRACT SUBSCRIPT MULTIPLIER BIT 
          BX0    X0*X2
          IX6    X7+X0
          SA6    DIMI        SET IF PROCESSING SUBSCRIPT MULTIPLIER 
          ZR     B3,PSO25    IF SUBSCRIPT IS INTEGER
          ZR     X6,PSO25    IF NOT END OF SUBSCRIPT
  
**        TERM PROCESSING IS RESULTS OF SUBSCRIPT AND IS NOT INTEGER
*         OUTPUT CONVERSION *TURPLE* AND CONTINUE PROCESSING WITH 
*         RESULTS OF CONVERSION * MULTIPLIER. 
  
          SX7    B6-2 
          LX6    X3 
          NZ     X0,PSO22    IF 2ND IS DIMENSION MULTIPLIER 
          BX1    X2 
          =X7    X7+1 
 PSO22    SA6    MODECON     SAVE OPERATOR
          SA2    ARGCOMA
          =X4    X2+1        CURRENT SUBSCRIPT NUMBER 
          RJ     ISR         INTERIZE SUBSCRIPT RESULTS 
          SA3    MODECON     RELOAD OPERATOR
          SA4    B6-2 
          BX6    X3 
          =A5    A4+1 
          SA6    SOPR 
 PSO25    RJ     CCR         CHECK FOR CONSTANT REDUCTION 
          SA3    SOPR        RELOAD OPERATOR. 
          ZR     X6,PSO30    IF NOT CONSTANT COMBINATION. 
  
**        HERE IF CURRENT TURPLE IS REDUCED TO SIMPLE TERM
  
          =B6    B6-1        UPDATE ESTACK
          BX3    0           INDICATE SUCCESS.
          =A1    B6-1 
          =A6    B6-1 
          IFBIT  X1,-SMULT,PSOX 
          SA5    DIMUL
          MX0    1
          BX6    X5+X0
          SA6    A5 
          EQ     PSOX 
  
**        HERE IF NOT SIMPLE CONSTANT COMBINATION 
  
 PSO30    SA2    ="SUBOPS"
          MI     B3,PSOX     IF NOT OF OPERANDS CONSTANT
  
**        HERE IF ONE OPERAND IS CONSTANT, CHECK IF OF THE FORM --
*         VARIABLE +- CONS  OR  CONS +- VARIABLE
*         (B3) = 0, 1ST = CONSTANT
*         (B3) = 1, 2ND = CONSTANT
  
          LX0    X2 
          SA2    TER1        CONSTANT 
          BX1    X5 
          ZR     B3,PSO35 
          BX1    X4 
          SA2    TER2        CONSTANT 
  
**        (X1) = TAG TERM (OTHER THAN CONSTANT) 
*         (X2) = CONSTANT TERM (IN BINARY)
*         (X3) = OPERATOR.
*         (DIMI) = *SMULT* BIT IF PRESENT IN ONE OF OPERANDS. 
  
 PSO35    SB7    X3 
          BX7    X2 
          LX0    B7,X0
          SA2    SMOD        DOMINANT MODE
          SB7    X2-M.INT 
          BX6    X1 
          ZR     B7,PSO40    IF DOMINANT MODE IS INTEGER
          SB7    X2-M.UNIV
          NZ     B7,PSOX     IF DOMINANT MODE NOT UNIVERSAL 
  
**        (X6) = TAG TERM 
*         (X7) = CONSTANT IN BINARY. (INTEGER FORM) 
  
 PSO40    PL     X0,PSOX     IF NOT + OR - OR * 
          MX0    -L.MODE
          BX2    -X0*X4 
          SX2    X2-M.INT 
          NZ     X2,EXIT.    IF NOT TYPE INTEGER - EXIT...
          BX2    -X0*X5 
          SX2    X2-M.INT 
          NZ     X2,EXIT.    IF NOT TYPE INTEGER - EXIT...
          SB7    X3-O.PL
          ZR     B7,PSO45    IF + 
          =B7    B7+O.PL-O.MIN
          BX1    X6 
          NZ     B7,PSOX     IF * OPERATOR
          BX7    -X7
          NZ     B3,PSO45    IF CONSTANT IS 2ND TERM
          =B3    -1 
          BX7    -X7         ADD
  
**        ELIMINATE OPERATION INVOLVING CONSTANT. 
* 
*         RESET BIAS WITH CONSTANT ADD IN.
*         (X1) = VARIABLE TO RETURN TO STACK. 
*         (X7) = CONSTANT ADD IN
* 
*         REDUCES STACK ENTRY COMPLETELY STORING RESULTS AS LAST OPERAND
*         FOR SUBSCRIPT. AND SETS HIGH ORDER BIT IN *DIMUL* IF ONE OF 
*         OPERANDS IS CURRENT *SUBSCRIPT* MULTIPLIER. 
  
  
 PSO45    SA2    DIMBIAS
          MX0    -24
          BX3    -X0*X2 
  
          LX3    60-L.2BIAS  SIGN EXTEND
          AX3    60-L.2BIAS  SIGN EXTEND
  
          IX6    X3+X7
          BX3    -X0*X6      LOWER 24 BITS ONLY 
          BX2    X2*X0       CLEAR CURRENT BIAS FOR UPDATED BIAS
          =B6    B6-1 
          BX6    X3+X2       PUT BACK IN BIAS 
          BX7    X1 
          SA6    A2          UPDATE BIAS. 
          BX3    0           INDICATE REDUCED.
          =A7    B6-1        VARIABLE BACK TO ELEMENT STACK 
          PL     B3,PSOX     IF NOT (CONSTANT - VARIABLE) 
          MX0    -L.SBPR
          SA2    UMINUS 
          =X1    O.UMIN 
          BX4    X0*X2       NOT *SB* PRIORITY
          =B5    B5+1 
          BX6    X4+X1       ADD *DPC* FOR UNARY MINUS
          =A6    B5          SET UNARY MINUS FOR OPERATOR ON VARIABLE 
          EQ     PSOX 
 PVD      SPACE  4,8
 SSO      EJECT 
**        SSO -  SET UP SUBSCRIPT OPERATIONS. 
* 
*         ENTRY  PARSER HAS ENCOUNTED AN ARRAY FOLLOWED BY A *(*
*                *SSO* SETS CONDITIONS FOR PARSER TO INDICATE WE ARE
*                NOW IN SUBSCRIPT MODE. 
* 
*                (A2) = ARGMODE.
*                (X5) = PASS *1* ARRAY TAG. (FROM SYMBOL TABLE.)
* 
*         EXIT   (X7) = ORDINAL OF NEXT DIMENSIONALITY FOR (ARGCOMA)
*                THE FOLLOWING CELLS ARE ESTABLISHED AS ACTIVE. 
*         DIMUL  =   SET TO *1* - FOR MULTIPLIER OF 1ST SUBSCRIPT.
* 
*         DIM    =   VALUE FOR 1ST DIMENSION SPECIFIED ON DECLARATIVE 
*                    DIMENSION CARD FOR CURRENT ARRAY.
*                    36/0,24/CURRENT DIMENSION MULTIPLIER.
* 
*         DIMBIAS=   24/RUNNING TOTAL, 18/UNDEFINED, 24/CURRENT BIAS
*                =    0,0,0 
* 
*         DIMSYM =   18/ARRAY TAG, 6,0, 18/VARIABLE SUBSCRIPTS, 
*                    1/ANSI,18/NUMBER OF DIMENSIONS.
* 
*         (X7) = POINTER TO DIMENSION INFORMATION RELATIVE TO TP.DIM. 
  
  
 SSO      SUBR               ENTRY/EXIT...
          SB2    X2-A=ARRAY 
          NZ     B2,SSO5     IF NOT ALREADY IN SUBSCRIPT. 
  
**        HERE IF SUBSCRIPTED SUBSCRIPT.
  
          SA2    DIMSYM 
          IFBIT  X2,SANSI,SSO5     IF ERROR ALREADY OUTPUTTED.
          SA2    ARGCOMA
          =X4    X2+1 
          SUBERR E.SB3       OUTPUT SUBSCRIPT ERROR.
  
**        RESET SUBSCRIPT PROCESSING CELLS. 
  
 SSO5     =X6    0
          MX0    -L.PNT 
          SA1    DIM
          AX5    P.PNT
          =A2    A1+1 
          BX7    X1 
          =A3    A2+1 
          SA6    DIMI 
          SA6    A3          CLEAR BIAS CELL
          =A4    A3+1 
          =A7    B5+1        SAVE CURRENT DIMENSIONALITY IN *OSTACK*
          LX6    X2 
          BX7    X3 
          =A6    A7+1        SAVE CURRENT MULTIPLIER IN *OSTACK*
          SB5    B5+4 
          LX6    X4 
          =A7    A6+1        SAVE CURRENT BIAS IN *OSTACK*
          =A6    A7+1        SAVE CURRENT SYMBOL IN *OSTACK*
          SA1    TP.DIM 
          BX2    -X0*X5      POINTER TO TP.DIM ORDINAL
          AX5    P.TAG-P.PNT
          LX5    P.SATAG
          SB2    X2 
          =X6    1
          BX7    X5          ARRAY TAG
          SA3    B2+X1       LOAD DIMENSION CONTROL WORD. 
          SA6    DIMUL       CURRENT MULTIPLIER.
  
**        SET DIM = CURRENT DIMENSION 
  
          SB7    P.DIM
          =A2    A3+1 
          AX6    B7,X2
          BX0    X3 
          =X2    0
          =X1    B2+2 
          IFBIT  X0,-VDIM,SSO7     IF NOT VARIABLE DIMENSION
          SX2    B2 
          LX2    18          BASE ADDRESS OF *DIM* INFO 
 SSO7     SA6    DIM         CURRENT DIMENSION
  
**        SET DIMOR = ORDINAL RELATIVE TO TP.DIM ENTRY. 
  
          SB3    P.NDIM 
          IX4    X1+X2       ADD IN VDIM FLAGS, IF THERE
  
**        SET DIMBIAS = COMPLEMENT SET AT DECLARATIVE TIME. 
  
          MX0    -L.DIMOS 
          AX1    B3,X3       NUMBER OF DIMENSIONS.
          IX6    X7+X1
          LX7    X4          DIMENSION ORDINAL. 
          SA6    DIMSYM      SAVE ARRAY NAME. 
          EQ     EXIT.
 SVT      SPACE  4,8
**        SVT -  SET VARDIM TAG IN *DIM* TABLE. 
* 
*         ENTRY  (B2) = SUBSCRIPT NUMBER FOR V-TAG. 
*                (B3) = ORDINAL OF *TP.DIM* INFO FOR THIS ARRAY.
*                (X2) = *V-TAG* TO BE ENTERED.
* 
*         EXIT   (X2) = PASS *2* TAG FOR *V-TAG*
*                TP.DIM ENTRY REPLACE WITH *V-TAG*
* 
*         USES   A1,A2,A3,A6  X0,X7  B7 
  
  
 SVT      SUBR               ENTRY/EXIT...
          SA3    TP.DIM 
          SA1    B2+DIMPT.
          SB7    X3+B3
          SA3    X1+B7
          MX7    2
          AX1    18 
          MX0    P.DIM
          SB7    X1 
          LX7    P.TDIM+1 
          BX1    X2 
          ZR     B7,SVT10    IF DIMENSIONALITY IN LOW ORDER 
          LX1    P.DIM
          LX0    P.DIM
          LX7    P.DIM
 SVT10    BX6    X0*X3       CLEAR OLD BITS 
          BX3    X6+X7       ADD IN *SDIM* BIT
          =X0    M.INT+M.2PRO 
          BX6    X3+X1       ADD IN V-TAG 
          LX2    P.TAG
          SA6    A3          RESET TAG INTO *DIM* TABLE 
          IX2    X2+X0
          EQ     EXIT.
 O=SUBS   EJECT  4,8
**        PASS 2 PROCESSING OF A SUBCRIPTED ARRAY.
* 
*         ENTRY HERE FROM ARITH WHEN SUBSCRIPT TURPLE FOUND.
*         PROCESSING IS DEFERRED UNTIL USE OF SUBSCRIPTED ARRAY IS
*         DETERMINED.  IF THE SUBSCRIPT IS A SUBSCRIPTED ARRAY, THEN
*         ARRAY IS PROCESSED. 
* 
*         ENTRY  (B4) _ START OF SUBSCRIPT ARRAY TURPLE. (OPERATOR WORD)
*                (B4+1)_ ARRAY TAG.+ BIAS    (OR.1OP) 
*                (B4+2)  INTERMEDIATE        (OR.2OP) 
* 
*         EXIT   (B4) UPDATED, EXIT TO EIS.PNX. 
*         USES   CANNOT DESTROY *B4*. 
  
  
 O=SUBL   BSS    0
 .T       IFNE   TEST 
          SA5    B4+OR.2OP
          SX0    M.2ARY+M.INTR
          BX1    X0*X5
          BX1    X0-X1
          NZ     X1,SUBL     IF NOT SUBSCRIPTED SUBSCRIPT 
          TRUBL 
 .T       ENDIF 
 SUBL     =B4    B4+L.TURP
          EQ     EIS.PNX     SET POST PROCESSING FLAG 
  
 SLD      SPACE  4,15 
**        SLD -  SUBSCRIPT LOAD.
* 
*         CALLED WHEN PROCESSING AN INTERMEDIATE AND FOUND THAT IT IS AN
*         ARRAY LOAD. 
* 
*         EXIT   SUBSCRIPT LOADED IN (X6) REGISTER. 
*                (X6) = REGISTER - (0R0). 
*                (B3) = REGISTER - (0TR). 
* 
*         (NOLDS) = (NOLDS) +1
* 
*         USES   A1,A2,A3,A4,A5  X0  B2,B3,B5,B6,B7 
*                CELLS -  SCR2 TO SCR2+6
  
 SLD      SUBR               ENTRY/EXIT...
          SX6    B4 
          BX7    X4 
          SA2    TT.PAR 
          LX1    X5 
          IX6    X6-X2
          AX1    P.JPAD 
          SA6    SAVEB4      SAVE *B4*
          SB4    X1 
          SX6    A4 
          =A6    A6+1        SAVE *A4*
          SB4    X2+B4       SUBSCRIPT TURPLE 
          =A7    A6+1        SAVE *X4*
          =X7    0           SET VALUE WANTED FLAG
          IFBIT  X5,-ADDR,SLD1
          =X7    SX=AK-SA=AK ADD IN TO OP-CODE FOR ADDRESS/VALUE
 SLD1     SA7    ADDR        =0 IF VALUE
          SA5    B4+OR.2OP   ADDRESS FUNCTION TAG 
          SA1    RREG 
          MX6    -0 
          BX7    X1 
          SA6    A1 
          SX6    B2 
          SA7    ALREG       SAVE HARD REGISTER FLAG
          SA6    TYPLOD 
          SX0    X7-R.X6
          MI     X0,SLD15    IF NOT STORE REGISTER
  
*         LOCK STORE REGISTER TO FORCE THE OTHER STORE REGISTER TO BE 
*         USED FOR ANY STORES TO TEMPORARIES
  
          MX0    -3 
          BX0    -X0*X7 
          SB7    X0          (00R) HARD REGISTER FLAG 
          RJ     RLL         LOCK HARD REGISTER 
 SLD15    DRITE  X5 
          BX6    0
          SA6    TRIP        RESET RE-TRY INDICATOR 
          SB3    RG=LOAD
          SB2    B0 
          SB7    B1 
          RJ     GST         GET STATUS OF ADDRESS FUNCTION 
          SX2    B2-REG.A       (B2) = 0TR
          MI     X2,SLD17       IF B REG
          BX0    -X6
          AX0    3              (X0) = -(00R) 
          SB7    X0-REG.X+R.X6  (B7)=0 IF AF IN X6, -1 IF IN X7 
          LT     B0,B7,SLD17    IF NOT IN STORE REG 
          SX0    RLOCK          SET LOCK BIT MASK 
          SA2    B7+REGFILE+R.X7 GET OTHER STORE REG
          BX0    X0*X2          EXTRACT LOCK BIT
          =X7    1
          ZR     X0,SLD17       IF NOT LOCKED 
          SA2    B2+REGFILE     GET REGFILE ENTRY OF AF 
          BX7    X2+X7          INSURE USE [AF] .NEQ. 0 
          SA7    A2             RESET REGFILE 
          RJ     RUT            CLEAR AF-REG
          SX0    B2-REG.X       0TR - 020 
          AX0    3
          ZR     X0,SLD16       IF X REG
          SB2    B3+REG.X       B2 = 02R
          RJ     RUT            CLEAR X REG 
 SLD16    =B2    0              UPPER PART
          =B7    0              PARTIAL STATES
          RJ     GST            GET STATES OF ADDRESS FUNCTION
 SLD17    SB3    RG=LOAD
          SA2    =XGSTC         GET POINTER TO STATUS WORD
          BX7    X2          SAVE LOCATION OF ADDRESS FUNCTION STATUS 
          SA7    AFSTS
          SB6    "BLOWUP"    **** DEBUG ****
          ZR     B2,SLD2     IF TAG NOT IN REGISTER 
          BX0    X6 
          AX0    3
          SA2    X0+REGX
          BX0    X5-X2
          IFBIT  X2,INTR,SLD3  IF INTERMEDIATE, NO CONFLICT 
          AX0    L.RUSE 
          ZR     X0,SLD3     IF CORRECT TAG 
 SLD2     MX0    L.2TAG+L.2BIAS+L.2FPNO 
          BX1    X0*X1
          RJ     LTG         LOAD ADDRESS FUNCTION
          SA2    TRIP 
          ZR     X2,SLD3     IF NO RECORD OF TROUBLE
          SA3    SAVEB2      (0TR) ARRAY LOAD REG 
          SB3    X3 
          NE     B2,B3,SLD3  IF NO CONFLICT 
  
**        PROBLEM DUE TO ADDRESS FUNCTION AND ARRAY LOAD CLAIMING 
*         SAME REGISTER.  ADDRESS FUNCTION MUST BE COPIED TO ANOTHER
*         REGISTER. 
  
          AX6    3
          SX7    B6 
          SB7    X6 
          SA7    SAVEB6      SAVE B6
          RJ     RLL         LOCK ADDRESS FUNCTION REGISTER 
          RJ     AIR         ASSIGN INTERMEDIATE REGISTER 
          PL     B2,SLD25    IF REGISTER FREE 
          RJ     ASR         ASSIGN STORE REGISTER
 SLD25    SA3    SAVEB2      (0TR) ADDRESS FUNCTION REGISTER
          SB5    X3 
          SX6    B2          (0TR) *I* REGISTER 
          MX0    -3 
  
*         MAKE ADJUSTMENTS TO *REGFILE* 
  
          BX7    0
          SA7    B5+REGFILE+REG.X-REG.A  CLEAR OLD REGFILE ENTRY
  
*         COMPILE TRANSMIT INSTRUCTION
  
          BX2    -X0*X6      (00R) *I* REGISTER 
          BX7    -X0*X3      (00R) *J* REGISTER 
          LX2    3
          IX7    X7+X2
          SX7    X7+XMITS3
          LX7    P.LI15+3 
          SB5    B2 
          WCODE  X7 
  
*         ADJUST/RESTORE REGISTERS
  
          SB2    B5          (0TR) NEW ADDRESS FUNCTION REGISTER
          MX0    -3 
          SX6    B2 
          BX6    -X0*X6 
          LX6    3           (0R0) NEW ADDRESS FUNCTION REGISTER
          SA2    SAVEB6 
          SB6    X2          RESTORE B6 
 SLD3     SA1    AFSTS
          SB7    X1          ORDINAL IN TABLE OF STATUS WORD
          AX1    18 
          SA2    X1          FETCH TABLE ORIGIN 
          SA1    X2+B7
          SB3    B0 
          RJ     SST         SET STATUS OF ADDRESS FUNCTION 
  
          AX6    3
          SB7    X6 
          RJ     RLL         LOCK ADDRESS FUNCTION REGISTER 
          SA1    ALREG
          SX6    B2 
          BX7    X1 
          SA6    AFREG
          SA7    RREG        RESET HARD REGISTER FLAG 
          SX0    X7-R.X6
          MI     X0,SLD32    IF NOT STORE REGISTER
          MX0    -3 
          BX0    -X0*X7 
          SB7    X0          (00R) HARD REGISTER FLAG 
          RJ     RUL         UNLOCK HARD REGISTER 
 SLD32    SB3    RG=LOAD
          RJ     GNR         GET ARRAY LOAD REGISTER
          SX7    B2 
          SA7    SAVEB2 
          SA5    B4+OR.2OP   ADDRESS FUNCTION TAG 
          SB3    RG=LOAD
          SB2    B0 
          SB7    B1 
          RJ     GST         GET STATUS OF ADDRESS FUNCTION (AGAIN) 
          SA2    =XGSTC 
          BX7    X2          SAVE LOCATION OF ADDRESS FUNCTION STATUS 
          SA7    AFSTS
          SB6    "BLOWUP"    **** DEBUG ****
          NZ     B2,SLD35    IF TAG IN REGISTER 
          SX6    1
          SA6    TRIP        SET RE-TRY INDICATOR 
          EQ     SLD2 
  
 SLD35    SA5    SAVEB2 
          SB2    X5          RESTORE B2 
          SB2    B2+REG.X-REG.A 
          SA5    B4+OR.1OP
          SX6    B2 
          BX7    X5          ARRAY TAG - PASS 3 FORMAT
          SA6    ALREG
          SA7    ALTAG
          SA3    AFREG
          MX7    -3 
          BX6    -X7*X3      (00R)
          AX3    3           (00T)
          SB7    X6          (00R) FOR *RUL*
          SX4    SA=BK
          ZR     X3,SLD4     IF *B* REGISTER
          SX4    SA=XK
          RJ     RUL         UNLOCK ADDRESS FUNCTION REGISTER 
 SLD4     SA3    TYPLOD      TYPE OF LOAD (0=UPPER HALF, 1= LOWER HALF) 
          SA1    ALTAG       ARRAY LOAD TAG 
          LX3    P.2BIAS
* 
*         (X1)    = ARRAY TAG 
*         (X5)    = ARRAY TAG 
*         (X4)    = SA=XK OR SA=BK
*         (ALREG) =  I REGISTER (OTR) 
*         (AFREG) = J REGISTER (OTR)
*         (ADDR)  = 0 IF VALUE WANTED 
*                 = 20000 IF ADDRESS WANTED 
* 
          SA2    ADDR 
          IX1    X1+X3
          BX3    X1 
          IX4    X2+X4       ADD IN VALUE FLAG
          MX0    -L.2FPNO 
          AX3    P.2FPNO
          BX2    -X0*X3      *FP* NUMBER
          ZR     X2,SLD8     IF TAG NOT FORMAL PARAMETER
  
*         RELOCK ADDRESS FUNCTION REGISTER TO AVOID CONFLICT WITH 
*         *FP* LOAD REGISTER IN LCM/ECS CASE. 
  
          BX7    X1 
          SA7    SAVEX1      SAVE X1
          BX7    X2 
          SA7    SAVEX2      SAVE X2
          RJ     RLL
          SA1    ALREG
          SX2    X1-R.X6
          MI     X2,SLD42 
          SB7    X1-REG.X 
          RJ     RLL         HARD STORE REG MUST ALSO BE LOCKED 
  
 SLD42    SA1    SAVEX1 
          SA2    SAVEX2      RESTORE X2 
          RJ     LFP         LOAD ADDRESS OF FP 
          SA3    ALREG
          SX0    X3-R.X6
          MI     X0,SLD44 
          SB7    X3-REG.X 
          RJ     RUL
 SLD44    SA3    AFREG
          MX0    -3 
          BX3    -X0*X3      (00R) ADDRESS FUNCTION REGISTER
          SB7    X3 
          RJ     RUL         UNLOCK ADDRESS FUNCTION REGISTER 
          SA2    ADDR        ADDRESS/VALUE FLAG 
          SA5    =XALTAG     RELOAD TAG FOR *CLT* 
          RJ     =XCLT       CHECK FOR LCM/ECS TAG
          NZ     X3,SLD5     IF NOT LCM OR ECS TAG
  
**        FORMAL LCM/ECS TAG. 
*         OUTPUT TO INTERMEDIATE FILE 
*                IXI    XJ+XK 
  
          SX6    B2          (0TR) *FP* SET REGISTER
          MX0    -3 
          BX6    -X0*X6      (00R)
          SX1    =XIADD 
          BX7    X1+X6       SET *K* REGISTER IN INSTRUCTION
          LX7    P.LI15 
          SX4    B6          (R00) *FP* LOAD REGISTER 
          AX4    6           (--R)
          MX0    -3 
          BX4    -X0*X4      (00R)
  
 #DAL     IFNE   .DAL,0 
  
          SA5    ADDR 
          NZ     X5,SLCMPA   IF ADDRESS WANTED
          LX4    60-12
          IX7    X7+X4       ADD IN *J* REGISTER
          SA1    ALREG       (0TR) ARRAY LOAD REGISTER
          SB7    X1-R.X6+RGFILE 
          NG     B7,SLD45    IF NOT STORE REGISTER
          SA6    SLDSR       SAVE SET REGISTER
          LX6    60-9 
          IX7    X7+X6       ADD IN *I* REGISTER
          EQ     SLD47
  
 SLD45    MX0    -3 
          BX6    -X0*X1      (00R) ARRAY LOAD REGISTER
          LX6    60-9 
          IX7    X7+X6       ADD IN *I* REGISTER
 SLD47    WCODE  X7,SLCMPB   COMPILE ADDRESS COMPUTATION
  
 #DAL     ELSE
          EQ     SLCMPA 
  
 #DAL     ENDIF 
  
 SLD5     SA3    =XAFREG     (0TR) ADDRESS FUNCTION REGISTER
          SX6    B2          (00R) *FP* B REGISTER
          AX3    3           (00T) ADDRESS FUNCTION REGISTER
          SX1    SA=XB
          NZ     X3,SLD6     IF NOT IN *B* REGISTER 
          SX1    SA=BB
 SLD6     IX4    X1+X2       ADD IN ADDRESS/VALUE FUNCTION
          BX7    X6+X4       SET *K* REGISTER IN INSTRUCTION
          LX7    P.LI15 
          EQ     SL.CMP      CONTINUE 
  
**        ADD IN BIAS FIELD FOR TAG IN (X1) 
  
 SLD8     LX4    P.LI15      OP-CODE
          AX1    P.2BIAS     TAG,BIAS 
          LX1    P.LBIAS
          IX7    X4+X1       OP-CODE+TAG+BIAS 
          RJ     =XCLT       CHECK FOR LCM/ECS TAG
          NZ     X3,SL.CMP   IF NOT LCM OR ECS TAG
  
**        ADDRESS OF LCM/ECS TAG REQUIRED.
*         OUTPUT TO INTERMEDIATE FILE 
*                SAJ    L.XX       POINTER WORD 
*                SXK    XI+RELAD-1 (XI) = SUBSCRIPT, RELAD = RELATIVE 
*                                       ADDRESS OF ARRAY IN BLOCK 
*                IXK    XJ+XK 
  
          SA7    SLDA        SAVE PARTIAL SET INSTRUCTION 
  
*         LOCK SOME REGISTERS 
  
          SA2    AFREG       (0TR) ADDRESS FUNCTION REGISTER
          MX0    -3 
          BX2    -X0*X2      (00R)
          SB7    X2 
          RJ     RLL         LOCK ADDRESS FUNCTION REGISTER 
          SA2    ALREG       (0TR) ARRAY LOAD REGISTER
          MX0    -3 
          BX2    -X0*X2      (00R)
          SB7    X2 
          RJ     RLL         LOCK ARRAY LOAD REGISTER 
  
          RJ     =XCLP       COMPILE LOAD OF POINTER
          SA1    SLDA        RELOAD PARTIAL SET INSTRUCTION 
  
 #DAL     IFNE   .DAL,0 
  
          SA2    ADDR 
          NZ     X2,SLD82    IF ADDRESS WANTED
  
**        VALUE REQUIRED FOR LCM/ECS TAG. 
*         IT CAN ONLY BE A 7000 LEVEL 2 ITEM. 
  
          MX0    -L.LBIAS 
          LX0    P.LBIAS
          BX7    -X0*X1      BIAS 
          SX1    =XSX=XK
          LX1    P.LI15 
          IX7    X7+X1       OPCODE + BIAS
          EQ     SLD84
  
 #DAL     ENDIF 
  
 SLD82    SA2    OPBIAS      MASK TO GET RID OF TAG 
          BX7    X2*X1       OPCODE+BIAS
  
*         GET RELATIVE ADDRESS OF ARRAY 
  
 SLD84    SA1    =XTA.NAM 
          LX5    -P.2TAG
          MX0    -L.PWF 
          BX4    -X0*X5      (X4) = TAG ORDINAL 
          SB3    X1          (B3) = FWA TA.NAM
          AX4    1
          SA1    X4+B3       FETCH ADDRESS TABLE ENTRY
          MX0    -L.RELADD
          BX4    -X0*X1      (X4) = RELATIVE ADDRESS
          LX4    P.LBIAS
          IX7    X7+X4       ADD RELATIVE ADDRESS TO BIAS 
          MX0    1
          LX0    1+P.LBIAS+L.LBIAS
          BX4    X0*X7       EXTRACT POSSIBLE OVERFLOW BIT
          LX4    -L.LBIAS 
          IX7    X4+X7       ADD IN OVERFLOW BIT
          BX7    -X0*X7      MASK OUT OVERFLOW BIT
          SA2    =XAFREG
          MX0    -3 
          BX4    -X0*X2      EXTRACT *J* REGISTER 
          LX4    60-12
          IX7    X7+X4       ADD IN *J* REGISTER
  
 #DAL     IFNE   .DAL,0 
  
          SA5    ADDR 
          NZ     X5,SLD89    IF ADDRESS WANTED
          SA1    ALREG       (0TR) ARRAY LOAD REGISTER
          SB7    X1-R.X6+RGFILE 
          NG     B7,SLD87    IF NOT STORE REGISTER
  
*         FOR LCM STORES, THE SET REGISTER AND LOAD REGISTER MUST BE
*         DIFFERENT.  FOR LOADS, THEY ARE THE SAME. 
  
          SA7    SLDSET      SAVE PARTIAL INSTRUCTION 
          SX1    B5          (0TR) POINTER-WORD REGISTER
          BX1    -X0*X1      (00R)
          SB7    X1 
          RJ     RLL         LOCK POINTER-WORD REGISTER 
          SA7    SLDPWR      SAVE POINTER-WORD REGISTER 
          =B3    =XRG=SET 
          RJ     GNR         GET SET REGISTER 
          SA3    SLDPWR      (00R) POINTER-WORD REGISTER
          SB5    X3 
          SB7    X3 
          RJ     RUL         UNLOCK POINTER-WORD REGISTER 
          AX6    3           (00R) SET REGISTER 
          SA1    SLDSET      RELOAD PARTIAL INSTRUCTION 
          BX7    X1 
          SA6    SLDSR       SAVE SET REGISTER
          EQ     SLD88
  
 SLD87    BX6    -X0*X1      (00R) ARRAY LOAD REGISTER
  
 SLD88    BX5    X6 
          EQ     SLD9 
  
 SLD89    BSS    0
  
 #DAL     ENDIF 
  
          SA1    =XALREG
          BX6    -X0*X1 
          BX5    X6 
 SLD9     LX6    60-9        *I* REGISTER 
          IX7    X6+X7       ADD IN *I* REGISTER
          WCODE  X7          OUTPUT INSTRUCTION TO SET BLOCK-REL. ADDR. 
          SX1    =XIADD 
          BX7    X1+X5       ADD *K* REGISTER TO OPCODE 
          LX5    6           (R00)
          BX7    X7+X5       *I* AND *K* REGISTER SAME
          MX0    -3 
          SX1    B5          (0TR) POINTER-WORD REGISTER
          BX1    -X0*X1      (00R)
          LX1    3           (0R0)
          BX7    X7+X1       ADD IN *J* REGISTER
          LX7    P.LI15      ALIGN
          WCODE  X7          OUTPUT INSTRUCTION TO COMPUTE ADDRESS
  
*         UNLOCK REGISTERS
  
          SA2    AFREG       (0TR) ADDRESS FUNCTION REGISTER
          MX0    -3 
          BX2    -X0*X2      (00R)
          SB7    X2 
          RJ     RUL         UNLOCK ADDRESS FUNCTION REGISTER 
          SA2    ALREG       (0TR) ARRAY LOAD REGISTER
          MX0    -3 
          BX2    -X0*X2      (00R)
          SB7    X2 
          RJ     RUL         UNLOCK ARRAY LOAD REGISTER 
  
          EQ     SLCMPB 
  
  
**        OUTPUT CODE TO LOAD ARRAY INTO REGISTER.
* 
*         (AFREG) = REGISTER FOR *J* PART OF INSTRUCTION. 
*         (ALREG) = REGISTER FREE FOR LOAD. (0TR) 
*         (X7) = INSTRUCTION OP-CODE IN HIGH ORDER + BIAS IF PRESENT
  
 SL.CMP   SA2    AFREG
          MX0    -3 
          BX4    -X0*X2      EXTRACT *J* REGISTER 
 SLCMPA   LX4    60-12
          IX7    X7+X4       ADD IN *J* REGISTER
          SA1    ALREG
          BX6    -X0*X1 
          LX6    60-9        *I* REGISTER 
          IX7    X6+X7       ADD IN *I* REGISTER
          WCODE  X7,SLCMPQ   COMPILE ARRAY LOAD 
  
 SLCMPB   BSS    0
  
 #DAL     IFNE   .DAL,0 
  
          SA5    ADDR 
          SA2    ALREG       (0TR)
          NZ     X5,SLCMPM   IF ADDRESS WANTED
  
**        VALUE OF 7000 LEVEL 2 TAG REQUIRED. 
*         OUTPUT TO INTERMEDIATE FILE 
*                RXJ    XJ
*         OR
*                WXJ    XK
  
          SB7    X2-R.X6+RGFILE 
          MX0    -3 
          BX3    -X0*X2      (00R)
          NG     B7,SLCMPD   IF NOT STORE REGISTER
          SA4    SLDSR       (00R) SET REGISTER 
          SX7    LCMW 
          EQ     SLCMPE 
  
 SLCMPD   BX4    X3 
          SX7    LCMR 
 SLCMPE   LX3    3           (0R0)
          BX3    X3+X4       ADD *J* AND *K* REGISTERS
          IX7    X7+X3
          LX7    P.LI15 
          WCODE  X7          OUTPUT LCM R/W INSTRUCTION 
 SLCMPM   BSS    0
  
 #DAL     ENDIF 
  
 SLCMPQ   SA5    ADDR 
          SA2    ALREG       (0TR)
          ZR     X5,SL.CMP0  IF ADDRESS NOT REQUESTED 
          =X5    M.ADDR 
 SL.CMP0  SX5    X5+M.2ARY
          SA1    TYPLOD 
          SB2    X2 
          SB3    X1 
  
*         DEFINE ARRAY LOAD RESULTS.
  
          RJ     DIT         DEFINE INTERMEDIATE
  
*         RESTORE REGISTERS AND EXIT. 
  
 SL.CMP10 SA5    SAVEB4 
          =X7    0
          =A1    A5+1 
          SA2    TT.PAR 
          IX5    X5+X2
          SB4    X5          RESTORE *B4* 
          =A2    A1+1 
          SA3    NOLDS
          SA7    AFREG
          SA4    X1          RESTORE *A4* 
          =X7    X3+1 
          BX4    X2          RESTORE *X4* 
          SA7    A3          UPDATE NO. OF LOADS
          EQ     EXIT.
  
 OPBIAS   SYMASK (LI12,LBIAS) 
 SLDA     BSS    1
 ALTAG    DATA   0           PASS 3 ARRAY LOAD TAG
 SRES     DATA   0
 SIND     DATA   0
 SAVEB4   DATA   0
 SAVEA4   DATA   0
 SAVEX4   DATA   0
 DIMI     DATA   0
 ALREG    DATA   0
 AFREG    DATA   0
 ADDR     DATA   0
 SAVEB2   DATA   0
 SAVEB6   DATA   0
 TRIP     DATA   0
 SAVEX1   DATA   0
 SAVEX2   DATA   0
 AFSTS    CON    "BLOWUP"    LOCATION OF ADDRESS FUNCTION STATUS WORD 
  
 #DAL     IFNE   .DAL,0 
  
 SLDPWR   DATA   0
 SLDSET   DATA   0
 SLDSR    DATA   0
  
 #DAL     ENDIF 
  
          EJECT 
****      TABLE OF ALL KNOWN INTRINSIC AND BASIC EXTERNAL FUNCTIONS 
*         DEFINED AT COMPILE TIME.
* 
  
  
          MACRO  NLINE,NAME,ARGTYP,FUNTYP,NOARGS,NANSI,SPEC 
 B        SET    1
          IFC    EQ,*NANSI*NONANSI*,1 
 B        SET    0
          IFC    EQ,*SPEC**,2 
 F.NAME   VFD    L.FDPC/0L_NAME,1/0,L.FBEF/0,L.FANSI/B,L.FJPAD/O=NAME-IN
,LBASE,L.FARGM/M.ARGTYP,L.FARGC/NOARGS,L.MODE/M.FUNTYP
          SKIP   1
 F.NAME   VFD    L.FDPC/0L_NAME,1/0,L.FBEF/0,L.FANSI/B,L.FJPAD/ES.NAME-E
,SFBASE+1S8,L.FARGM/M.ARGTYP,L.FARGC/NOARGS,L.MODE/M.FUNTYP 
 NLINE    ENDM
  
          MACRO  EXTBF,NAME,ARGTYP,FUNTYP,NOARGS,NANSI
 B        SET    1
          IFC    EQ,*NANSI*NONANSI*,1 
 B        SET    0
 Y        MICRO  1,, NAME 
 Z        MICCNT Y
 C        SET    54-Z*CHAR
 F.NAME   VFD    L.FDPC/0L_NAME,1/0,L.FBEF/1,L.FANSI/B,L.FJPAD/C,L.FARGM
,/M.ARGTYP,L.FARGC/NOARGS,L.MODE/M.FUNTYP 
 EXTBF    ENDM
 INLINE   EJECT 
**        INLINE TABLE FORMAT.
* 
*         +---------------------------------+---+-+--------+--+-----+--+
*         +                                 +///+A+        +A + NUM + M+
*         +    F U N C T I O N     N A M E  +///+N+   REL  +R + OF  + O+
*         +                                 +///+S+ ADDRESS+G + ARGS+ D+
*         +          ( IN  DPC )            +///+I+        +M +     + E+
*         +---------------------------------+---+-+--------+--+-----+--+
* 
* 
*         EXTERNAL TABLE FORMAT.
* 
*         +---------------------------------+-+-+-+--------+--+-----+--+
*         +                                 +/+B+A+        +A + NUM + M+
*         +    F U N C T I O N     N A M E  +/+E+N+  SHIFT +R + OF  + O+
*         +                                 +/+F+S+  COUNT +G + ARGS+ D+
*         +          ( IN  DPC )            +/+ +I+        +M +     + E+
*         +---------------------------------+-+-+-+--------+--+-----+--+
* 
* 
*         SYMBOL TABLE ENTRY FORMAT FOR EITHER *BEF* OR *INTRINSIC* 
* 
*         +-----------------+-------+--------+--+-----+-------------+--+
*         +                 +///////+ SHIFT  +A + NUM +             + M+
*         +   T    A    G   +///////+ COUNT  +R + OF  +  C L A S S  + O+
*         +                 +///////+  OR    +G + ARGS+             + D+
*         +                 +///////+ ADDRESS+M +     +             + E+
*         +-----------------+-------+--------+--+-----+-------------+--+
*                18            7        9      3   6         15      3
*                                   +--- PNT----+-PARM+ 
 FIV      EJECT 
 FIV      BSS    0
          LOC    0
  
****      START OF ALL INTRINSICS.
  
 ABS      NLINE  REAL,REAL,1
 AIMAG    NLINE  CPLX,REAL,1
 AINT     NLINE  REAL,REAL,1
 AMAX0    NLINE  INT,REAL 
 AMAX1    NLINE  REAL,REAL
 AMIN0    NLINE  INT,REAL 
 AMIN1    NLINE  REAL,REAL
 AMOD     NLINE  REAL,REAL
 AND      NLINE  UNIV,UNIV,,NONANSI,SPEC
 CMPLX    NLINE  REAL,CPLX,2
 CONJG    NLINE  CPLX,CPLX,1
 COMPL    NLINE  UNIV,UNIV,1,NONANSI,SPEC 
 DABS     NLINE  DBL,DBL,1
 DBLE     NLINE  REAL,DBL,1 
 DIM      NLINE  REAL,REAL,2
 DMAX1    NLINE  DBL,DBL
 DMIN1    NLINE  DBL,DBL
 DMOD     EXTBF  DBL,DBL,2
 DSIGN    NLINE  DBL,DBL,2
 FLOAT    NLINE  INT,REAL,1 
 IABS     NLINE  INT,INT,1
 IDIM     NLINE  INT,INT,2
 IDINT    NLINE  DBL,INT,1
 IFIX     NLINE  REAL,INT,1 
 INT      NLINE  REAL,INT,1 
 ISIGN    NLINE  INT,INT,2
 LOCF     NLINE  UNIV,INT,1,NONANSI,SPEC
 MASK     NLINE  INT,UNIV,1,NONANSI,SPEC
 MAX0     NLINE  INT,INT
 MAX1     NLINE  REAL,INT 
 MIN0     NLINE  INT,INT
 MIN1     NLINE  REAL,INT 
 MOD      NLINE  INT,INT,2,,SPEC
 OR       NLINE  UNIV,UNIV,,NONANSI,SPEC
 RANF     NLINE  UNIV,REAL,1,NONANSI,SPEC 
 REAL     NLINE  CPLX,REAL,1
 SHIFT    NLINE  UNIV,UNIV,2,NONANSI,SPEC 
 SIGN     NLINE  REAL,REAL,2
 SNGL     NLINE  DBL,REAL,1 
 XOR      NLINE  UNIV,UNIV,,NONANSI,SPEC
****
 EXTBF    EJECT  4,8
****      START OF BASIC EXTERNAL FUNCTIONS (BEFS). 
  
 DACOS    EXTBF  DBL,DBL,1
 DASIN    EXTBF  DBL,DBL,1
 DATAN    EXTBF  DBL,DBL,1
 DATAN2   EXTBF  DBL,DBL,2
 DCOS     EXTBF  DBL,DBL,1
 DEXP     EXTBF  DBL,DBL,1
 DLOG     EXTBF  DBL,DBL,1
 DLOG10   EXTBF  DBL,DBL,1
 DSIN     EXTBF  DBL,DBL,1
 DTAN     EXTBF  DBL,DBL,1
 DSQRT    EXTBF  DBL,DBL,1
 DTANH    EXTBF  DBL,DBL,1,NONANSI
 DSINH    EXTBF  DBL,DBL,1,NONANSI
 DCOSH    EXTBF  DBL,DBL,1,NONANSI
  
 CABS     EXTBF  CPLX,REAL,1
 CCOS     EXTBF  CPLX,CPLX,1
 CEXP     EXTBF  CPLX,CPLX,1
 CLOG     EXTBF  CPLX,CPLX,1
 CSIN     EXTBF  CPLX,CPLX,1
 CSQRT    EXTBF  CPLX,CPLX,1
  
 SIN      EXTBF  REAL,REAL,1
 COS      EXTBF  REAL,REAL,1
 SQRT     EXTBF  REAL,REAL,1
 TAN      EXTBF  REAL,REAL,1,NONANSI
 ATAN     EXTBF  REAL,REAL,1
 ALOG     EXTBF  REAL,REAL,1
 ALOG10   EXTBF  REAL,REAL,1
 ATAN2    EXTBF  REAL,REAL,2
 ATANH    EXTBF  REAL,REAL,1
 TANH     EXTBF  REAL,REAL,1
 SINH     EXTBF  REAL,REAL,1,NONANSI
 COSH     EXTBF  REAL,REAL,1,NONANSI
 ASIN     EXTBF  REAL,REAL,1,NONANSI
 ACOS     EXTBF  REAL,REAL,1,NONANSI
 EXP      EXTBF  REAL,REAL,1
 ERF      EXTBF  REAL,REAL,1
 ERFC     EXTBF  REAL,REAL,1
 SIND     EXTBF  REAL,REAL,1
 COSD     EXTBF  REAL,REAL,1
 TAND     EXTBF  REAL,REAL,1
****
 L.FIV    BSS    0           LENGTH OF *FIV* TABLE
          LOC    *O 
 E.FIV    EQU    *-1
          POPMAC INLINE 
          POPMAC EXTBF
 EXPON    EJECT  4,8
 STINS    SPACE  4,8
**        STINS - SET INSTRUCTION DEPENDING ON TYPES. 
  
  
 STINS    MACRO  INSTS
 A        MICRO 
 B        SET    60 
 C        SET    16 
 .1       IRP    INSTS
 A        MICRO  1,,."A",C/INSTS. 
 B        SET    B-C
 .1       IRP 
          VFD    B/0"A" 
 STINS    ENDM
  
  
 CRTTAB   STINS  (SX=BB,SX=BB,-SB=BB) 
          STINS  (SA=AB,-SA=AB,SB=XB) **** TEMP SB=XB ****
          STINS  (-XMIT,-XMIT,SB=XB)
  
          POPMAC STINS
 CWI      SPACE  4,10 
 RMAC     SECT   (SKELETONS FOR CODE GENERATION.-MACRUN),1
 DEFUJP   EJECT  4,8
**        DEFUJP - DEFINE INSTRUCTIONS FOR UNCONDITIONAL JUMPS
  
  
          MACRO  DEFUJP,INST,OPC,TYPE 
 INST     EQU    OPC_BS3
 INST     MACRO  K
          FORM   (0,OPC,K),INST,TYPE
 INST     ENDM
 DEFUJP   ENDM
 DEFINS   SPACE  4,8
**        DEFINS - DEFINE INSTRUCTIONS
  
  
          MACRO  DEFINS,INST,OPC,TYPE 
 A        MICRO  1,, 9
          IFEQ   TYPE,M.BRAN,1
 A        MICRO  1,, 6
 INST     EQU    OPC_BS"A"
 INST     MACRO  I,J,K
          FORM   (I,J,K),INST,TYPE
 INST     ENDM
 DEFINS   ENDM
  
  
**        PURGE STORE, THE 7RM STORE MACRO IN SYSTEXT 
  
          PURGMAC  STORE
 DMOD     EJECT  4,20 
**        DMOD - BUILD MODE OF OPERATION POINTER WORD FOR SELECTING 
*                APPROPRIATE INSTRUCTIONS FOR A GIVEN OPERATOR
*         TYPE = 1ST 3 CHARACTERS MUST BE 0=
*         U,L,I,R,D,C = PROCESSING ADDRESSES FOR
*                U = UNIVERSAL. 
*                L = LOGICAL. 
*                I = INTEGER. 
*                R = REAL 
*                D = DOUBLE 
*                C = COMPLEX
* 
*         MUST NOT USE SCRATCH SYMBOL *Z* - SEE FORM, FORME 
  
  
          MACRO  DMOD,TYPE,U,L,I,R,D,C
 B        MICRO  3,,/TYPE/
 E        MICRO  ,, 
.1        ECHO   ,P=(C,D,R,I,L,U) 
 A        MICRO  1,1,/P/
 .2       IFC    EQ,*"A"*E* 
 E        MICRO  1,,$"E"8/E.EXBASE,$
 .2       ELSE
 E        MICRO  1,,$"E"8/"B".P-TYPE,$
.1        ENDD
 TYPE     VFD    12/0,"E" 
 DMOD     ENDM
  
 E.EXBASE EQU    377B 
  
 ITYPE    EJECT  4,20 
**        ITYPE - FIELD DEFINITIONS FOR INSTRUCTION SKELETON WORDS. 
  
  
 ITYPE    DEFINE 54,6 
  
  
 M.COND   EQU    0           CONDITIONAL
 M.NORM   EQU    1           ARITHMETIC OP-CODES
 M.INCR   EQU    2           LOAD REGISTER OP-CODES 
 M.BRAN   EQU    3           BRANCH OP-CODES
 M.SHIF   EQU    4           REGISTER SHIFT OP-CODES
 M.ICALL  EQU    5           IF NEEDS TO CALL A EXTERNAL PROCESSOR TO 
 M.IUSE   EQU    6           IF USE ANOTHER SKELETON. 
 M.IRST   EQU    7           IF RESET TO ANOTHER SKELETON.
 M.LOAD   EQU    10B         LOAD/STORE INSTRUCTIONS
  
**        VALUES *11* THRU *37* NOT CURRENTLY USED. 
  
 M.IEND   EQU    40B         END OF SKELETON
 P.IEND   EQU    59 
  
 IOPC     DEFINE 45,9        OPCODE.
 INUM     DEFINE 17,6        REGISTER/ CONSTANT.
 IOAD     DEFINE 12,5        ORDINAL. 
 IQF      DEFINE 0,12        K IF CONSTANT ADD IN.
  
**        SKELETON EXPANSION FORMAT.
* 
**T SKELETON  6/ TYP, 9/OPCODE, 6/I, 5/I, 6/J, 5/J, 6/K, 5/K, 12/Q FIELD
**T,    6/ ,9/ , 6/NUM, 5/ADDR, 6/NUM, 5/ADDR, 6/NUM, 5/ADDR,12/CONSTANT
  
**        MICROS USED WITHIN SKELETON FIELDS TO DEFINED A PARTICULAR
*         TYPE OF OPERATION/OPERAND OR CONSTANT 
  
 M1       MICRO  1,, CL1
 M2       MICRO  1,, CM1
 M3       MICRO  1,, CU1
 N1       MICRO  1,, CL2
 N2       MICRO  1,, CM2
 N3       MICRO  1,, CU2
 K-1      MICRO  1,, +777776B      MINUS ONE
 TAG1     MICRO  1,, CU2           TAG FIELD FROM OR.1OP
 TAG2     MICRO  1,, CU2           TAG FIELD FROM OR.2OP
  
 DOBEG    MICRO  1,, CL4           DO BEGIN LABEL 
 DOINCR   MICRO  1,, CU2           DO INCREMENT TAG (CONSTANT)
 DOLIM    MICRO  1,, CU3           DO LIMIT VALUE   (CONSTANT)
 DOINIT   MICRO  1,, CU1           DO INITIAL VALUE (CONSTANT)
 IMACROS  EJECT  4,8
**        INSTRUCTION MACROS
  
**        BRANCH UNIT 
  
 RJQ      DEFUJP 2,M.BRAN 
 JPQ      DEFUJP 3,M.BRAN 
 EQJ      DEFUJP 4,M.BRAN 
  
 #DAL     IFNE   .DAL,0 
  
          ENTRY  LCMR,LCMW
 LCMR     DEFINS 014,M.BRAN  FAKE *RXJ  XK* AS BRANCH FOR *DEFINS*
 LCMW     DEFINS 015,M.BRAN  FAKE *WXJ  XK* AS BRANCH FOR *DEFINS*
  
 #DAL     ENDIF 
  
 ZRJ      DEFINS 030,M.BRAN 
 NZJ      DEFINS 031,M.BRAN 
 PLJ      DEFINS 032,M.BRAN 
 MIJ      DEFINS 033,M.BRAN 
  
 IRJ      DEFINS 034,M.BRAN 
 ORJ      DEFINS 035,M.BRAN 
 DFJ      DEFINS 036,M.BRAN 
 IDJ      DEFINS 037,M.BRAN 
  
 EQB      DEFINS 040,M.BRAN 
 NEB      DEFINS 050,M.BRAN 
 LEB      DEFINS 060,M.BRAN 
 GEB      DEFINS 060,M.BRAN 
 LTB      DEFINS 070,M.BRAN 
 GTB      DEFINS 070,M.BRAN 
  
**        BOOLEAN UNIT
  
 XMIT     DEFINS 10,M.SHIF
 AND      DEFINS 11,M.NORM
 OR       DEFINS 12,M.NORM
 XOR      DEFINS 13,M.NORM
 ZERO     DEFINS 13,M.NORM
 XMITC    DEFINS 14,M.NORM
 ANDN     DEFINS 15,M.NORM
 ORN      DEFINS 16,M.NORM
 LGDIFC   DEFINS 17,M.NORM
 XORN     DEFINS 17,M.NORM
  
**        SHIFT UNIT. 
  
 LSHF     DEFINS 20,M.SHIF
 RSHF     DEFINS 21,M.SHIF
 LSHFB    DEFINS 22,M.SHIF
 RSHFB    DEFINS 23,M.SHIF
 NORMZ    DEFINS 24,M.NORM
 RNORMZ   DEFINS 25,M.NORM
 UPACK    DEFINS 26,M.NORM
 PACK     DEFINS 27,M.NORM
 FMASK    DEFINS 43,M.NORM
  
**        ADD UNIT. 
  
 FADD     DEFINS 30,M.NORM
 FSUB     DEFINS 31,M.NORM
 DFADD    DEFINS 32,M.NORM
 DFSUB    DEFINS 33,M.NORM
 RFADD    DEFINS 34,M.NORM
 RFSUB    DEFINS 35,M.NORM
  
**        LONG ADD UNIT.
  
 .76      IFEQ   .CPU,76
          ENTRY  IADD 
 .76      ENDIF 
  
 IADD     DEFINS 36,M.NORM
 ISUB     DEFINS 37,M.NORM
  
**        MULTIPLY UNIT.
  
 FMULT    DEFINS 40,M.NORM
 RMULT    DEFINS 41,M.NORM
 DMULT    DEFINS 42,M.NORM
 IMULT    DEFINS 42,M.NORM
  
**        DIVIDE UNIT.
  
 FDIV     DEFINS 44,M.NORM
 RDIV     DEFINS 45,M.NORM
 NOOP     DEFINS 46,M.NORM
 POPCNT   DEFINS 47,M.NORM
  
**        INCREMENT UNIT
  
 SA=AK    DEFINS 50,M.INCR
 SA=BK    DEFINS 51,M.INCR
 SA=XK    DEFINS 52,M.INCR
 SA=XB    DEFINS 53,M.INCR
 SA=AB    DEFINS 54,M.INCR
 SA=AMB   DEFINS 55,M.INCR
 SA=BB    DEFINS 56,M.INCR
 SA=BMB   DEFINS 57,M.INCR
  
 SB=AK    DEFINS 60,M.INCR
 SB=BK    DEFINS 61,M.INCR
 SB=XK    DEFINS 62,M.INCR
 SB=XB    DEFINS 63,M.INCR
 SB=AB    DEFINS 64,M.INCR
 SB=AMB   DEFINS 65,M.INCR
 SB=BB    DEFINS 66,M.INCR
 SB=BMB   DEFINS 67,M.INCR
  
  
 SX=AK    DEFINS 70,M.INCR
 SX=BK    DEFINS 71,M.INCR
 SX=XK    DEFINS 72,M.INCR
 SX=XB    DEFINS 73,M.INCR
 SX=AB    DEFINS 74,M.INCR
 SX=AMB   DEFINS 75,M.INCR
 SX=BB    DEFINS 76,M.INCR
 SX=BMB   DEFINS 77,M.INCR
  
 LOAD     DEFINS 50,M.LOAD
 LOADB    DEFINS 60,M.LOAD
 STORE    DEFINS 50,M.LOAD
  
*         THESE EQUATES ARE FOR EXTERNAL REFERENCES 
  
 SA=ABS3  EQU    SA=AB/1S3
 SA=ABS6  EQU    SA=AB/1S6
 SA=AKS6  EQU    SA=AK/1S6
 SA=XKS3  EQU    SA=XK/1S3
 SA=BKS3  EQU    SA=BK/1S3
 SA=BKS9  EQU    SA=BK/1S9
 SB=BKS9  EQU    SB=BK/1S9
 SX=BKS9  EQU    SX=BK/1S9
 SX=XKS9  EQU    SX=XK/1S9
 SX=XKS3  EQU    SX=XK/1S3
 SX=BKS3  EQU    SX=BK/1S3
 XMITS3   EQU    XMIT/1S3 
 SB=BKS3  EQU    SB=BK/1S3
  
 .76      IFEQ   .CPU,76
          ENTRY  SX=BKS3
 SX=BKS3  EQU    SX=BK/1S3
 .76      ENDIF 
 SSP      SPACE  4,8
 FORM     EJECT  4,8
**        FORM - FORM INSTRUCTION SKELETON FOR COMPILING A GIVEN
*                SEQUENCE OF CODE.
* 
*         ALL INSTRUCTION TO BE COMPILED BY ARITH MUST BE IN THE FORM 
*         OF SKELETON INSTRUCTIONS TO BE EXPANDED BY *EIS*, THE 
*         GENERAL INSTRUCTION EXPANDER. 
* 
*         *FORM* HAS 3 ARGUMENTS -- 
*                1ST = I,J,K PORTIONS OF INSTRUCTIONS.
*                2ND = OPCODE 
*                3RD = TYPE OF OP-CODE. 
  
  
 FORM     MACRO  IJK,OPCODE,TYPE
**               FLUSH PREVIOUS SKELETON
          VFD    "H""L""Q"
 L        MICRO 
 Q        MICRO  1,,$,L.IQF/0$
 X        SET    TYPE 
 H        MICRO  1,,$L.ITYPEM/X,L.IOPCM/OPCODE/1S6$ 
.1        IRP    IJK
          IFC    EQ,  IJK ,2
          SETCON 0
          SKIP   7
**                           DEFINE BASE FOR THIS PORTION 
          IFC    LT, IJK 0 ,2 
**                           HERE IF LETTER.
          SETOTH IJK
          SKIP   4
          IFC    LT, IJK * ,2 
**                           HERE IF CONSTANT.
          SETCON IJK
          SKIP   1
**                           HERE SPECIAL CHARACTER 
          SETOTH IJK
.1        IRP 
 FORM     ENDM
  
  
 ITYPEM   DEFINE P.ITYPE,L.ITYPE
 IOPCM    DEFINE P.IOPC,L.IOPC
 INUMM    DEFINE P.INUM,L.INUM
 IOADM    DEFINE P.IOAD,L.IOAD
 IQFM     DEFINE P.IQF,L.IQF
          NOREF  L.IOPCM,L.INUMM,L.IOADM,L.IQFM 
 REGSET   SPACE  4,8
**        REGSET - SET REQUIRED REGISTERS FOR *LOAD* / *STORE*
*                  SKELETON EXPANSIONS. 
* 
*         REGSET (I=TR,J=TR,K=TR) 
*                T = TYPE OF REGISTER  *R.X*, *R.B* OR *R.A*
*                R=  0-7. 
  
  
 REGSET   MACRO  IJK
.1        IRP    IJK
 A        MICRO  3,, IJK
 C        MICRO  1,,$"C"18/"A"-RGFILE,$ 
.1        IRP 
          VFD    "C"6/0 
 REGSET   ENDM
 SETCON   SPACE  4,8
**        SETCON-  SET CONSTANT FORM OF SKELETON FOR CURRENT PORTION
*                  OF INSTRUCTION PROCESSING. 
* 
*         EXIT   MICRO *L* RESET. 
*                IF Q FIELD PRESENT MICRO *Q* BUILT.
* 
*         A *Q* FIELD IS INDICATED BY THE FIRST CHARACTER BEING A PLUS
*         OR MINUS SIGN.
* 
* 
*         CALLED BY *FORM* WHEN ITH PORTION IS A CONSTANT.
  
  
 SETCON   MACRO  IJK
 A        SET    IJK
.1        IFC    LT, IJK +
* 
*                            HARD NUMERIC REGISTER FIELD
* 
 L        MICRO  1,,$"L",L.INUMM/IJK,L.IOADM/AT.K-SBASE$
.1        ELSE
* 
*                            18-BIT *Q* FIELD 
* 
 D        OCTMIC A,6
 .2       IFLT   A,0
 B        MICRO  1,2, "D" 
 C        MICRO  3,, "D"
 L        MICRO  1,,$"L",L.INUMM/"B"B,L.IOADM/AT.Q-SBASE$ 
 Q        MICRO  1,,$,L.IQF/"C"B$ 
 .2       ELSE
 B        DECMIC A/1S12 
 D        DECMIC A-"B"*1S12 
 L        MICRO  1,,$"L",L.INUMM/"B",L.IOADM/AT.Q-SBASE$
 Q        MICRO  1,,$,L.IQF/"D"$
 .2       ENDIF 
.1        ENDIF 
 SETCON   ENDM
 SETOTH   SPACE  4,8
**        SETOTH- SET OTHER TYPE FIELD FOR *FORM* MACRO.
  
  
 SETOTH   MACRO  IJK
 A        MICRO  1,, IJK
 B        MICCNT A
 C        MICRO  B,1, IJK 
 F        SET    1
 D        MICRO  B-1,1, IJK 
          IFC    GT, "D" Z ,2 
 F        SET    2
 C        MICRO  B-1,2, IJK 
 G        SET    B-F
 E        MICRO  1,G, IJK 
 A        MICMIC 1,T."E"
 N        MICRO  "C"*2+6,2,-"A"-
 E        MICRO  1,, "A"
 L        MICRO  1,,$"L",L.INUMM/"N",L.IOADM/AT."E"-SBASE$
 SETOTH   ENDM
 ENDF     SPACE  4,8
**        ENDF - FLUSH LAST SKELETON WORD.
* 
*         ENDF
  
  
 ENDF     MACRO 
          VFD    "H""L""Q"
 H        MICRO 
 L        MICRO 
 Q        MICRO 
 ENDF     ENDM
 ENDS     SPACE  4,20 
**        ENDS - END MACRO SKELETON.
* 
*         GENERATES ENDING *SKELETON* FOR AN *RMAC* MACRO.
* 
*         ENDS
  
  
 ENDS     MACRO 
 X        SET    X+M.IEND 
          VFD    "H""L""Q"
 H        MICRO 
 L        MICRO 
 Q        MICRO 
 ENDS     ENDM
 SETSPC   EJECT  4,8
**        DEFINITION OF SPECIAL SKELETONS AVAILABLE WHEN TYPE FIELD 
*         OF SKELETON IS = M.SPEC 
  
 ITYPE    DEFINE 54,6        TYPE 
 MATTR    DEFINE 36,18       ATTRIBUTES 
 MARG     DEFINE 18,18       ARGUMENT IF PRESENT
 MJPAD    DEFINE 0,18        ADDRESS TO BE SET TO 
 SETSPC   SPACE  4,8
**        SETSPC- SET SPECIAL SKELETON
  
  
 SETSPC   MACRO  TYPE,WHERE,ARG 
          VFD    "H""L""Q"
 H        MICRO  1,,$L.ITYPE/X,L.MATTR/0,L.MARG/ARG,L.MJPAD/WHERE$
 X        SET    TYPE 
 L        MICRO 
 Q        MICRO 
 SETSPC   ENDM
 RESET    SPACE  4,8
**        RESET - RESET CURRENT INSTRUCTION SKELETON POINTER TO ARGUMENT
*         ARG = WHERE TO RESET SKELETON TO.  IF NEGATIVE *ARG* INDICATES
*               RELATIVE TO TT.PAR WHERE NEXT *TURPLE* IS TO BE FOUND 
  
  
 RESET    MACRO  TO,ARG 
          SETSPC M.IRST,TO,ARG
 RESET    ENDM
 USESKL   SPACE  4,8
**        USESKL - USE ANOTHER SKELETON TO PARTIAL PROCESS
*                  CURRENT TURPLE.
  
  
 USESKL   MACRO  TO,ARG 
          SETSPC M.IUSE,TO,ARG
 USESKL   ENDM
 CALL     SPACE  4,8
**        CALL - CALL AN EXTERNAL PROCESSOR TO PROCESS/ OR PARTIALLY
*                PROCESS CURRENT TURPLE.
* 
*         NOTE - IF CALL IS TO USE OR.1OP OR OR.2OP AS ARGUMENT, *L*
*                MUST BE PREFIX FOLLOWED BY EITHER *1* OR *2* ONLY. 
*                ALL OTHER CASES SHOULD PREFIX ARGUMENT WITH A *0+*.
  
  
 CALL     MACRO  TO,ARG 
.1        IFC    LT, ARG 0
 A        MICRO  2,1, ARG 
 B        OCTMIC "A",1
          SETSPC M.ICALL,TO,-"B"
.1        ELSE
          SETSPC M.ICALL,TO,ARG 
.1        ENDIF 
 CALL     ENDM
 TYPES    EJECT 
 MICMIC   SPACE  4,8
**        MICMIC- GET MICRO OF MICRO. 
*         MIC = RESULTING MICRO.
*         N   = STARTING CHARACTER POSITION.
*         CMIC= CURRENT MICRO.
  
  
          MACRO  MICMIC,MIC,N,CMIC
 MIC      MICRO  N,,/"CMIC"/
 MICMIC   ENDM
 ALLMIC   SPACE  4,8
****      MICROS TO TRANSLATE REQUESTED TYPE OF OPERATION INTO
*         INTERNAL ADDRESS AND NUMBERS. 
  
  
 T.B      MICRO  1,,/SB     010203040506070809101112/ 
 T.X      MICRO  1,,/SX   00010203040506070809101112/ 
 T.L      MICRO  1,,/L      010204050708101113141617/ 
 T.LN     MICRO  1,,/LN     010204050708101113141617/ 
 T.LB     MICRO  1,,/LB     010204050708101113141617/ 
 T.R      MICRO  1,,/RR     010204050708101113141617/ 
 T.LU     MICRO  1,,/L      010204050708101113141617/ 
 T.LNU    MICRO  1,,/LN     010204050708101113141617/ 
 T.LL     MICRO  1,,/LL     010204050708101113141617/ 
 T.LNL    MICRO  1,,/LNL    010204050708101113141617/ 
 T.RU     MICRO  1,,/RR     010204050708101113141617/ 
 T.RL     MICRO  1,,/RL     010204050708101113141617/ 
 T.T      MICRO  1,,/ST     0001020304050607080910111213141516171819/ 
 T.TG     MICRO  1,,/TG     010204050708101113141617/ 
 T.CL     MICRO  1,,/CNL    010204050708101113141617/ 
 T.CM     MICRO  1,,/CNM    010204050708101113141617/ 
 T.CU     MICRO  1,,/CNU    010204050708101113141617/ 
  
**          CLEAR ENTITY TYPE OF MACROS.
  
 T.*B     MICRO  1,,/CB     010203040506070809101112/ 
 T.*X     MICRO  1,,/CX     010203040506070809101112/ 
 T.*T     MICRO  1,,/CT     0001020304050607080910111213141516171819/ 
 T.*L     MICRO  1,,/CL     010204050708101113141617/ 
 T.*LU    MICRO  1,,/CLU    010204050708101113141617/ 
 T.*LL    MICRO  1,,/CLL    010204050708101113141617/ 
****
 INST     EJECT 
**        INSTRUCTION SKELETONS.
  
 H        MICRO                    SET UP MICROS FOR SKELETONS
 L        MICRO 
 Q        MICRO 
 ADD      SPACE  4,20 
**        1.  ADD INSTRUCTIONS. 
  
  
 O=ADD    DMOD   I,E.AT1A,I,R,D,C 
 ADD.I    IADD   R1,L1,L2 
          ENDS
 ADD.R    FADD   T1,L1,L2 
          NORMZ  R1,0,*T1 
          ENDS
 ADD.D    FADD   T1,LNU1,LNU2 
          DFADD  T2,LU1,LU2 
          FADD   T3,LL1,LL2 
          NORMZ  T4,0,*T1 
          FADD   T5,*T2,*T3 
          FADD   T6,T4,T5 
          NORMZ  T7,0,*T6 
          DFADD  T8,*T4,*T5 
          NORMZ  T9,0,*T8 
          FADD   RU1,T7,T9
          DFADD  RL1,*T7,*T9
          ENDS
 ADD.C    FADD   T1,LU1,LU2 
          NORMZ  RU1,0,*T1
          FADD   T2,LL1,LL2 
          NORMZ  RL1,0,*T2
          ENDS
 RADD     SPACE  4,8
**        ROUNDED ADD INSTRUCTIONS
  
  
          ENTRY  O=RADD 
 O=RADD   DMOD   I,E.AT1A,I,R,D,C 
 RADD.I   IADD   R1,L1,L2 
          ENDS
 RADD.R   RFADD  T1,L1,L2 
          NORMZ  R1,0,*T1 
          ENDS
 RADD.D   RESET  ADD.D
          ENDS
 RADD.C   RFADD  T1,LU1,LU2 
          NORMZ  RU1,0,*T1
          RFADD  T2,LL1,LL2 
          NORMZ  RL1,0,*T2
          ENDS
 SUBTRACT SPACE  4,20 
**        2.  SUBTRACT INSTRUCTIONS.
  
  
 O=SUB    DMOD   I,E.AT1A,I,R,D,C 
 SUB.I    ISUB   R1,L1,L2 
          ENDS
 SUB.R    FSUB   T1,L1,L2 
          NORMZ  R1,0,*T1 
          ENDS
 SUB.D    FSUB   T1,LNU1,LNU2 
          DFSUB  T2,LU1,LU2 
          FSUB   T3,LL1,LL2 
          RESET  ADD.D+3
          ENDS
 SUB.C    FSUB   T1,LU1,LU2 
          NORMZ  RU1,0,*T1
          FSUB   T2,LL1,LL2 
          NORMZ  RL1,0,*T2
          ENDS
 RSUB     SPACE  4,8
**        ROUNDED SUBTRACT INSTRUCTIONS 
  
  
          ENTRY  O=RSUB 
 O=RSUB   DMOD   I,E.AT1A,I,R,D,C 
 RSUB.I   ISUB   R1,L1,L2 
          ENDS
 RSUB.R   RFSUB  T1,L1,L2 
          NORMZ  R1,0,*T1 
          ENDS
 RSUB.D   RESET  SUB.D
          ENDS
 RSUB.C   RFSUB  T1,LU1,LU2 
          NORMZ  RU1,0,*T1
          RFSUB  T2,LL1,LL2 
          NORMZ  RL1,0,*T2
          ENDS
 UMINUS   SPACE  4,20 
**        4.  UNARY MINUS 
  
  
 O=UMIN   DMOD   I,E.AT1A,I,I,D,D 
 UMIN.I   XMITC  R1,L2
          ENDS
 O=NOT    EQU    UMIN.I 
 UMIN.D   XMITC  RU1,LU2
          XMITC  RL1,LL2
          ENDS
 MULTIPLY SPACE  4,20 
**        5.  MULTIPLY INSTRUCTIONS.
  
  
 O=MULT   DMOD   I,E.AT1A,I,R,D,C 
 MULT.I   BSS    0
          IMULT  R1,L1,L2 
          ENDS
 MULT.R   FMULT  R1,L1,L2 
          ENDS
 MULT.D   FMULT  T1,LL1,LNU2
          FMULT  T2,LNU1,LL2
          FADD   T3,*T1,*T2 
          FMULT  T4,LNU1,LNU2 
          DMULT  T5,LU1,LU2 
          FADD   T6,*T3,*T5 
          FADD   RU1,T4,T6
          DFADD  RL1,*T4,*T6
          ENDS
 MULT.C   FMULT  T1,LNU1,LNU2 
          FMULT  T2,LNL1,LNL2 
          FSUB   T3,*T1,*T2 
          NORMZ  RU1,0,*T3
          FMULT  T4,LU1,LL2 
          FMULT  T5,LL1,LU2 
          FADD   T6,*T4,*T5 
          NORMZ  RL1,0,*T6
          ENDS
 RMULT    SPACE  4,8
**        ROUNDED MULTIPLY
  
  
          ENTRY  O=RMULT
 O=RMULT  DMOD   I,E.AT1A,I,R,D,C 
 RMULT.I  IMULT  R1,L1,L2 
          ENDS
 RMULT.R  RMULT  R1,L1,L2 
          ENDS
 RMULT.D  RESET  MULT.D 
          ENDS
 RMULT.C  RMULT  T1,LNU1,LNU2 
          RMULT  T2,LNL1,LNL2 
          RFSUB  T3,*T1,*T2 
          NORMZ  RU1,0,*T3
          RMULT  T4,LU1,LL2 
          RMULT  T5,LL1,LU2 
          RFADD  T6,*T4,*T5 
          NORMZ  RL1,0,*T6
          ENDS
 DIVIDE   SPACE  4,20 
**        6.  DIVIDE INSTRUCTIONS.
  
  
 O=DIV    DMOD   I,E.AT1A,I,R,D,C 
 DIV.I    PACK   T1,0,L2
          NORMZ  T2,0,*T1 
          PACK   T3,0,L1
          FDIV   T4,*T3,*T2 
          UPACK  T5,B1,*T4
          LSHFB  R1,*B1,*T5 
          ENDS
 DIV.R    FDIV   R1,L1,L2 
          ENDS
 DIV.D    FDIV   T1,LNU1,LNU2 
          FMULT  T2,T1,LNU2 
          FSUB   T3,LNU1,T2 
          DFSUB  T4,LU1,*T2 
          NORMZ  T5,0,*T3 
          FADD   T6,*T4,*T5 
          DMULT  T7,T1,LNU2 
          FSUB   T8,LL1,*T7 
          FADD   T9,*T6,*T8 
          FMULT  T10,T1,LL2 
          FSUB   T11,*T9,*T10 
          FDIV   T12,*T11,LU2 
          FADD   T13,T1,T12 
          NORMZ  T14,0,*T13 
          DFADD  T15,*T1,*T12 
          FADD   RU1,T15,T14
          DFADD  RL1,*T15,*T14
          ENDS
 DIV.C    FMULT  T1,LNU1,LNL2 
          FMULT  T2,LNL1,LNU2 
          FSUB   T3,*T2,*T1 
          NORMZ  T4,0,*T3 
          FMULT  T5,LU1,LNU2
          FMULT  T6,LL1,LNL2
          FADD   T7,*T5,*T6 
          NORMZ  T8,0,*T7 
          FMULT  T9,LU2,LNU2
          FMULT  T10,LL2,LNL2 
          FADD   T11,*T9,*T10 
          NORMZ  T12,0,*T11 
          FDIV   RU1,*T8,T12
          FDIV   RL1,*T4,*T12 
          ENDS
 RDIV     SPACE  4,8
**        ROUNDED DIVIDE
* 
* 
          ENTRY  O=RDIV 
 O=RDIV   DMOD   I,E.AT1A,I,R,D,C 
 RDIV.I   RESET  DIV.I
          ENDS
 RDIV.R   RDIV   R1,L1,L2 
          ENDS
 RDIV.D   RESET  DIV.D
          ENDS
 RDIV.C   RMULT  T1,LNU1,LNL2 
          RMULT  T2,LNL1,LNU2 
          RFSUB  T3,*T2,*T1 
          NORMZ  T4,0,*T3 
          RMULT  T5,LU1,LNU2
          RMULT  T6,LL1,LNL2
          RFADD  T7,*T5,*T6 
          NORMZ  T8,0,*T7 
          RMULT  T9,LU2,LNU2
          RMULT  T10,LL2,LNL2 
          RFADD  T11,*T9,*T10 
          NORMZ  T12,0,*T11 
          RDIV   RU1,*T8,T12
          RDIV   RL1,*T4,*T12 
          ENDS
 LOGICAL  SPACE  4,20 
**        7.  LOGICAL / MASKING OPERATORS.
*             VAR1 .OP. VAR2 = MODELESS  (THANK YOU, 3600)
*             LOG1 .OP. LOG2 = LOGICAL
  
  
*O=NOT    SEE UNARY MINUS OPERATOR. (O=UMIN)
 O=ANDO   AND    R1,L1,L2 
          ENDS
 O=ORO    OR     R1,L1,L2 
          ENDS
 O=XOR    XOR    R1,L1,L2 
          ENDS
 O=ORN    ORN    R1,L1,L2 
          ENDS
 O=ANDN   ANDN   R1,L1,L2 
          ENDS
 O=XORN   XORN   R1,L1,L2 
          ENDS
 RELAT    SPACE  4,8
**        8.  RELATIONALS.
*             VAR1 .OP. VAR2 = PERFORM IN VAR MODE, RESULTS = LOGICAL 
*             LOG1 .OP. LOG2 = ILLEGAL. 
  
  
  
 O=LT     DMOD   I,E.AT1A,I,R,D,R 
 LT.I     ISUB   T1,L1,L2 
          FMASK  T2,0,0 
          IADD   R1,*T1,*T2 
          ENDS
 LT.R     FSUB   T1,L1,L2 
          NORMZ  R1,0,*T1 
          ENDS
 LT.D     FSUB   T1,LL1,LL2 
          FSUB   T2,LNU1,LNU2 
          NORMZ  T3,0,*T2 
          DFSUB  T4,LU1,LU2 
          FADD   T5,*T1,*T4 
          FADD   RU1,*T3,*T5
          ENDS
  
 O=GE     DMOD   I,E.AT1A,I,R,D,R 
 GE.I     ISUB   T1,L1,L2 
          FMASK  T2,0,0 
          IADD   T3,*T1,*T2 
          XMITC  R1,*T3,0 
          ENDS
 GE.R     FSUB   T1,L1,L2 
          NORMZ  T2,0,*T1 
          XMITC  R1,*T2,0 
          ENDS
 GE.D     DFSUB  T1,LNU1,LNU2 
          FSUB   T2,LU1,LU2 
          NORMZ  T3,0,*T2 
          FSUB   T4,LL1,LL2 
          FADD   T5,*T1,*T4 
          FADD   T6,*T3,*T5 
          XMITC  RU1,*T6,0
          ENDS
  
  
 O=NE     DMOD   I,E.AT1A,I,R,D,D 
 NE.I     FMASK  T1,0,0 
          ISUB   T2,L1,L2 
          IADD   T3,*T2,T1
          ISUB   T4,*T1,T3
          OR     R1,*T4,*T3 
          ENDS
 NE.R     FSUB   T1,L1,L2 
          NORMZ  T2,0,*T1 
          FMASK  T3,0,0 
          ISUB   T4,*T3,T2
          OR     R1,*T2,*T4 
          ENDS
 NE.D     FSUB   T1,LU1,LU2 
          FSUB   T2,LL1,LL2 
          NORMZ  T3,0,*T1 
          FMASK  T4,0,0 
          NORMZ  T5,0,*T2 
          OR     T6,*T3,*T5 
          ISUB   T7,*T4,T6
          OR     RU1,*T7,*T6
          ENDS
  
 O=EQ     DMOD   I,E.AT1A,I,R,D,D 
 EQ.I     ISUB   T1,L1,L2 
          FMASK  T2,0,0 
          IADD   T3,*T1,T2
          ISUB   T4,*T2,T3
          LGDIFC R1,*T4,*T3 
          ENDS
 EQ.R     FSUB   T1,L1,L2 
          NORMZ  T2,0,*T1 
          FMASK  T3,0,0 
          ISUB   T4,*T3,T2
          LGDIFC R1,*T2,*T4 
          ENDS
 EQ.D     FSUB   T1,LU1,LU2 
          NORMZ  T2,0,*T1 
          FSUB   T3,LL1,LL2 
          FMASK  T4,0,0 
          NORMZ  T5,0,*T3 
          OR     T6,*T2,*T5 
          ISUB   T7,*T4,T6
          LGDIFC RU1,*T7,*T6
          ENDS
 O=REL1   SPACE  4,8
**        SKELETONS THAT MAKE USE OF THE SHIFT INSTRUCTION TO PERFORM 
*         ARITHMETIC OPERATIONS.
* 
*         INTEGER MULTIPLY SKELETONS. 
  
  
 O=SHFC   XMIT   T1,L1
          LSHF   T1,CM2 
          XMIT   R1,*T1 
          ENDS
 O=SHFD   XMIT   T1,LN1,0 
          LSHF   T1,CU2,0 
          XMIT   T2,L1,0
          LSHF   T2,CM2,0 
          ISUB   R1,*T2,*T1 
          ENDS
 O=SHFDS  XMIT   T1,LN1,0 
          LSHF   T1,CM2,0 
          ISUB   R1,*T1,L1
          ENDS
 O=SHFS   XMIT   T1,LN1,0 
          LSHF   T1,CU2,0 
          IADD   T2,*T1,L1
          LSHF   T2,CM2 
          XMIT   R1,*T2 
          ENDS
 O=SHFSA  XMIT   T1,LN1,0 
          LSHF   T1,CU2,0 
          IADD   R1,*T1,L1
          ENDS
  
**        INTEGER DIVIDE BY POWER OF 2 SKELETON 
  
 O=DIVP2  XMIT   T1,L1
          RSHF   T1,CM2 
          XMIT   R1,*T1 
          ENDS
 O=STR    SPACE  4,8
**        11.  STORE SKELETONS RELATIVE TO DOMINANT MODE
*              *TURPLE* FORM -
*                            OR.1OP = RIGHT MEMBER. 
*                            OR.2OP = LEFT  MEMBER. 
  
  
 O=STR    DMOD   I,I,I,R,D,C
 STR.I    BSS    0
 STR.R    STORE  R2,L1
          ENDS
  
 STR.D    BSS    0
 STR.C    STORE  RU2,LU1
          STORE  RL2,LL1
          ENDS
 MODECON  SPACE  4,20 
**        MODE CONVERSION SKELETONS 
* 
*         KEY TO *MC* OPERANDS FOR MODE CONVERSION PROCESSING.
*         *MC* = 1, RESULTS TO UPPER REGISTER.
*              = 2, RESULTS TO LOWER REGISTER.
  
 MODECON  DATA   0           MODE CONVERSION FLAG USED DURING *PASS* 2
                             TO PROCESS CONVERSION. 
  
 ITOR     PACK   T1,0,L2     INTEGER TO REAL CONVERSION 
          NORMZ  R1,0,*T1 
          ENDS
  
 ITOD     PACK   T1,0,L2     INTEGER TO DOUBLE CONVERSION 
          NORMZ  RU1,0,*T1
          FMASK  RL1,0,0
          ENDS
 ITOC     EQU    ITOD        INTEGER TO COMPLEX CONVERSION
  
 RTOI     UPACK  T1,6,L2     REAL TO INTEGER CONVERSION 
          LSHFB  R1,6,*T1 
          ENDS
  
 RTOD     XMIT   RU1,L2      REAL TO DOUBLE CONVERSION
          FMASK  RL1,0,0
          ENDS
  
 DTOI     UPACK  T1,7,LU2    DOUBLE TO INTEGER
          LSHFB  R1,7,*T1 
          ENDS
 CTOI     EQU    DTOI 
  
 DTOC     XMIT   RU1,LU2     DOUBLE TO COMPLEX CONVERSION 
          FMASK  RL1,0,0
          ENDS
 CTOD     EQU    DTOC        COMPLEX TO DOUBLE
 MCTBL    EJECT  4,8
**        MCTBL - MODE CONVERSION TABLE BUILD MACRO.
  
  
          MACRO  MCTBL,DUMY,U,L,I,R,D,C,NAB,NAE 
 E        SET    0
          IRP    NAB
 B        DECMIC 5-M.NAB
 E        SET    1S"B"+E
          IRP    NAB
 G        SET    0
          IRP    NAE
 J        DECMIC 5-M.NAE
 G        SET    1S"J"+G
          IRP    NAE
 F        MICRO  ,, 
.1        ECHO   ,P1=(C,D,R,I,L,U)
 A        MICRO  1,1, P1
          IFC    EQ,$"A"$E$,3 
 A        MICRO  4,, P1 
 F        MICRO  1,,$"F"8/E.EXBASE,$
          SKIP   4
          IFC    EQ,$"A"$*$,2 
 F        MICRO  1,,$"F"8/0,$ 
          SKIP   1
 F        MICRO  1,,$"F"8/P1-MODECON,$
.1        ENDD
          VFD    6/E,6/G,"F"
 MCTBL    ENDM
 MODTBL   SPACE  4,8
**        MCTBL - TABLE TO FORM JUMP ADDRESSES FOR MODE CONVERSION. 
*         FORM IS OPERAND TO BE CONVERTED VS DOMINANT MODE
* 
*         KEY 
*                * = NO MODE CONVERSION.
*         PREFIX E = ERROR IN MODE CONVERSION.
*         X TO Y   = MODE CONVERSION TO BE PROCESSED. 
*         MCTBL EXPANDED TO USE HIGH ORDER 12 BITS
*         NAB - NON-ANSI COMBINATIONS WITH *+-/ OPERATORS 
*         FORM IS MODE OF OPERAND TO CONVERTED VERSUS DOMINANT MODE 
*         NAE - NON ANSI EXPONENTIATION 
*         FORM IS BASE VERSUS EXPONENT
  
  
 MODTBL   BSS    0
 M.UNIV   MCTBL  *,ERR1,*,*,RTOD,RTOD,(),() 
 M.LOG    MCTBL  ERR1,*,ERR1,ERR1,ERR1,ERR1,(),() 
 M.INT    MCTBL  *,ERR1,*,ITOR,ITOD,ITOC,(REAL,DBL,CPLX),(REAL,DBL,CPLX)
 M.REAL   MCTBL  *,ERR1,RTOI,*,RTOD,RTOD,(),(CPLX)
 M.DBL    MCTBL  *,ERR1,DTOI,*,*,DTOC,(CPLX),(CPLX) 
 M.CPLX   MCTBL  *,ERR1,CTOI,*,CTOD,*,(),() 
  
          POPMAC MCTBL
 INTRINS  EJECT  4,4
**        12. INTRINSIC FUNCTIONS.
  
  
 INLBASE  BSS    0           BASE ADDRESS OF INLINES. 
 O=ABS    XMIT   T1,LN2,0 
          RSHF   T1,59,0
          XOR    R1,L2,*T1
          ENDS
 O=IABS   EQU    O=ABS
 O=AIMAG  XMIT   R1,LL2,0    IMAGINARY PART OF COMPLEX ARGUMENT 
          ENDS
 O=AINT   ZERO   T1 
          PACK   T2,0,*T1 
          FADD   T3,L2,*T2
          NORMZ  R1,0,*T3 
          ENDS
 O=MAX0   ISUB   T1,LN1,LN2  I=MAX0(I1,I2)
          XMIT   T2,*T1,0 
          RSHF   T2,59,0
          AND    T3,T2,L2 
          ANDN   T4,L1,*T2
          IADD   R1,*T3,*T4 
          ENDS
 O=DMAX1  FSUB   T1,LNU1,LNU2 
          DFSUB  T2,LNU1,LNU2 
          FSUB   T3,LNL1,LNL2 
          NORMZ  T4,0,*T1 
          FADD   T5,*T2,*T3 
          FADD   T6,*T4,*T5 
          XMIT   T7,*T6,0 
          RSHF   T7,59,0
          AND    T8,T7,LU2
          AND    T9,T7,LL2
          ANDN   T10,LU1,T7 
          ANDN   T11,LL1,*T7
          IADD   RU1,*T8,*T10 
          OR     RL1,*T9,*T11 
          ENDS
 O=MIN0   ISUB   T1,LN2,LN1   I=MIN0(I1,I2) 
          RESET  O=MAX0+1 
          ENDS
 O=DMIN1  FSUB   T1,LNU2,LNU1 
          DFSUB  T2,LNU2,LNU1 
          FSUB   T3,LNL2,LNL1 
          RESET  O=DMAX1+3
          ENDS
 O=AMAX1  FSUB   T1,LN1,LN2  R=AMAX1(R1,R2) 
          XMIT   T2,*T1,0 
          RSHF   T2,59,0
          AND    T3,T2,L2 
          ANDN   T4,L1,*T2
          IADD   R1,*T3,*T4 
          ENDS
 O=AMIN1  FSUB   T1,LN2,LN1  R=AMIN1(R1,R2) 
          RESET  O=AMAX1+1
          ENDS
  
 O=MAX1   EQU    O=AMAX1     I=MAX1(R1,R2)  (MODE CONVERSION TO FOLLOW) 
 O=MIN1   EQU    O=AMIN1     I=MIN1(R1,R2)  (MODE CONVERSION TO FOLLOW) 
 O=AMAX0  EQU    O=MAX0      R=AMAX0(I1,I2) (MODE CONVERSION TO FOLLOW) 
 O=AMIN0  EQU    O=MIN0      R=AMAN0(I1,I2) (MODE CONVERSION TO FOLLOW) 
  
 O=AMOD   FDIV   T1,LN1,LN2 
          ZERO   T2 
          PACK   T3,0,*T2 
          FADD   T4,*T3,*T1 
          NORMZ  T5,0,*T4 
          FMULT  T6,T5,LN2
          DMULT  T7,*T5,L2
          DFSUB  T8,LN1,T6
          FSUB   T9,L1,*T6
          FSUB   T10,*T8,*T7
          NORMZ  T11,0,*T9
          FADD   T12,*T11,*T10
          NORMZ  R1,0,*T12
          ENDS
  
 O=AND    EQU    O=ANDO 
 O=COMPL  EQU    O=NOT
  
 O=CONJG  XMIT   RU1,LU2
          XMITC  RL1,LL2
          ENDS
 O=DABS   XMIT   T1,LNU2
          RSHF   T1,59
          XOR    RU1,T1,LU2 
          XOR    RL1,*T1,LL2
          ENDS
  
 O=DBLE   XMIT   RU1,L2 
          FMASK  RL1,0,0
          ENDS
 O=CMPLX  XMIT   RU1,L1 
          XMIT   RL1,L2 
          ENDS
  
 O=DIM    FSUB   T1,L1,L2 
          NORMZ  T2,0,T1
          XMIT   T3,*T1 
          RSHF   T3,59,0
          ANDN   R1,*T2,*T3 
          ENDS
  
 O=DSIGN  XMIT   T1,LNU1
          RSHF   T1,59,0
          XOR    T2,T1,LU1
          XOR    T3,*T1,LL1 
          XMIT   T4,LU2 
          RSHF   T4,59,0
          XOR    RU1,*T2,T4 
          XOR    RL1,*T3,*T4
          ENDS
  
 O=FLOAT  PACK   T1,0,L2
          NORMZ  R1,0,*T1 
          ENDS
 O=IFIX   BSS    0
 O=INT    BSS    0
 O=IDINT  UPACK  T1,6,L2
          LSHFB  R1,6,*T1 
          ENDS
  
 O=SIGN   BSS    0
 O=ISIGN  XMIT   T1,LN1 
          RSHF   T1,59,0
          XOR    T2,*T1,L1
          XMIT   T3,L2
          RSHF   T3,59,0
          XOR    R1,*T3,*T2 
          ENDS
  
 O=IDIM   ISUB   T1,L1,L2 
          XMIT   T2,T1
          RSHF   T2,59,0
          ANDN   R1,*T1,*T2 
          ENDS
  
 O=MASK   FMASK  T1,0,1 
          SB=XK  6,L2,-1
          RSHFB  T2,6,*T1 
          XMIT   T3,T2
          RSHF   T3,59,0
          AND    R1,*T2,*T3 
          ENDS
  
 O=MOD    PACK   T1,0,LN2    I=MOD(J,K) 
          NORMZ  T2,0,*T1 
          PACK   T3,0,LN1 
          FDIV   T4,*T3,*T2 
          UPACK  T5,6,*T4 
          LSHFB  T6,6,*T5 
          IMULT  T7,*T6,L2
          ISUB   R1,L1,*T7
          ENDS
  
 O=MODP2  XMIT   T1,LN1      MOD(INP, POWER OF 2 CONSTANT)
          RSHF   T1,60
          XOR    T2,L1,T1 
          ANDN   T3,*T2,L2
          XOR    R1,*T3,*T1 
          ENDS
  
 O=OR     EQU    O=ORO
  
 O=RANF   DMULT  T1,LL2,LU1 
          CALL   O=RNF,L1 
          NORMZ  R1,0,*T1 
          ENDS
  
 O=REAL   XMIT   R1,LU2 
          ENDS
 O=SNGL   EQU    O=REAL 
  
  
*         VARIABLE SHIFT
  
 O=SHIFT  SB=XB  6,L2 
          LSHFB  R1,6,L1
          ENDS
  
*         CONSTANT SHIFT
  
 O=SHIFTC SB=BK  6,,"N3"
          LSHFB  R1,6,L1
          ENDS
 IFMAC    EJECT  4,8
**        13. IF INSTRUCTION SKELETONS. 
  
  
 IFBASE   BSS    0           BASE FOR *IF* JUMP SKELETONS.
  
 IFI123   ZRJ    0,L1,"N2"
          PLJ    0,L1,"N3"
          EQJ    "N1" 
          ENDS
 IFD123   OR     T1,LU1,LL1 
          ZRJ    T1,0,"N2"
          PLJ    0,*T1,"N3" 
          EQJ    "N1" 
          ENDS
  
 IFI122   FMASK  T1,0,0 
          IADD   T2,*T1,L1
          PLJ    0,*T2,"N2" 
          EQJ    "N1" 
          ENDS
 IFR122   NORMZ  T1,0,L1
          PLJ    0,*T1,"N2" 
          EQJ    "N1" 
          ENDS
 IFD122   FADD   T1,LU1,LL1 
          NORMZ  T2,0,*T1 
          PLJ    0,*T2,"N2" 
          EQJ    "N1" 
          ENDS
  
 IFI113   FMASK  T1,0,0 
          ISUB   T2,*T1,L1
          PLJ    0,*T2,"N1" 
          EQJ    "N3" 
          ENDS
 IFR113   XMITC  T1,L1,0
          NORMZ  T2,0,*T1 
          PLJ    0,*T2,"N1" 
          EQJ    "N3" 
          ENDS
 IFD113   FADD   T1,LU1,LL1 
          XMITC  T2,*T1,0 
          NORMZ  T3,0,*T2 
          PLJ    0,*T3,"N1" 
          EQJ    "N1" 
          ENDS
  
 IFI121   ZRJ    0,L1,"N2"
          EQJ    "N1" 
          ENDS
  
 IFIN23   ZRJ    0,L1,"N2"
          PLJ    0,L1,"N3"
          ENDS
 IFDN23   OR     T1,LU1,LL1 
          ZRJ    0,T1,"N2"
          PLJ    0,*T1,"N3" 
          ENDS
  
 IFI1N3   FMASK  T1,0,0 
          IADD   T2,*T1,L1
          MIJ    0,T2,"N1"
          NZJ    0,*T2,"N3" 
          ENDS
 IFR1N3   NORMZ  T1,0,L1
          MIJ    0,T1,"N1"
          NZJ    0,*T1,"N3" 
          ENDS
 IFD1N3   FADD   T1,LU1,LL1 
          NORMZ  T2,0,*T1 
          MIJ    0,T2,"N1"
          NZJ    0,*T2,"N3" 
          ENDS
  
 IFI12N   ZRJ    0,L1,"N2"
          MIJ    0,L1,"N1"
          ENDS
 IFD12N   FADD   T1,LU1,LL1 
          NORMZ  T2,0,*T1 
          ZRJ    0,T2,"N2"
          MIJ    0,*T2,"N1" 
          ENDS
  
 IFIN22   FMASK  T1,0,0 
          IADD   T2,*T1,L1
          PLJ    0,*T2,"N2" 
          ENDS
 IFRN22   NORMZ  T1,0,L1
          PLJ    0,*T1,"N2" 
          ENDS
 IFDN22   FADD   T1,LU1,LL1 
          NORMZ  T2,0,*T1 
          PLJ    0,*T2,"N2" 
          ENDS
  
 IFI1NN   FMASK  T1,0,0 
          IADD   T2,*T1,L1
          MIJ    0,*T2,"N1" 
          ENDS
 IFR1NN   NORMZ  T1,0,L1
          MIJ    0,*T1,"N1" 
          ENDS
 IFD1NN   FADD   T1,LU1,LL1 
          NORMZ  T2,0,*T1 
          MIJ    0,*T2,"N1" 
          ENDS
  
 IFINN3   FMASK  T1,0,0 
          ISUB   T2,*T1,L1
          MIJ    0,*T2,"N3" 
          ENDS
 IFRNN3   XMITC  T1,L1,0
          NORMZ  T2,0,*T1 
          MIJ    0,*T2,"N3" 
          ENDS
 IFDNN3   FADD   T1,LU1,LL1 
          XMITC  T2,*T1,0 
          NORMZ  T3,0,*T2 
          MIJ    0,*T3,"N3" 
          ENDS
  
 IFI11N   FMASK  T1,0,0 
          ISUB   T2,*T1,L1
          PLJ    0,*T2,"N1" 
          ENDS
 IFR11N   XMITC  T1,L1,0
          NORMZ  T2,0,*T1 
          PLJ    0,*T2,"N1" 
          ENDS
 IFD11N   FADD   T1,LU1,LL1 
          XMITC  T2,*T1,0 
          NORMZ  T3,0,*T2 
          PLJ    0,*T3,"N1" 
          ENDS
  
 IFIN2N   ZRJ    0,L1,"N2"
          ENDS
  
 IFI1N1   NZJ    0,L1,"N1"
          ENDS
  
 IFI111   EQJ    "N1" 
          ENDS
  
 IFL12    MIJ    0,L1,"N1"
          EQJ    "N2" 
          ENDS
 IFLN2    PLJ    0,L1,"N2"
          ENDS
 IFL1N    MIJ    0,L1,"N1"
          ENDS
  
 IFEN2    NZJ    0,L1,"N1"
          ENDS
 IFE1N    ZRJ    0,L1,"N1"
          ENDS
 IFTBL    EJECT 
**        IFTBL- GENERATE *IF* TABLE JUMP ADDRESS FOR PROCESSING
*                3-BRANCH *IF* STATEMENTS.
  
 IFTBL    MACRO  PRE,M,L,I,R,D,C
 C        MICRO  ,, 
.1        ECHO   ,P1=(M,L,I,R,D,C)
 A        MICRO  1,1, P1
 .2       IFC    EQ,*E*"A"* 
C         MICRO  1,,$"C"8/-1,$
 .2       ELSE
 C        MICRO  1,,$"C"8/IF_P1_PRE-IFBASE,$
 .2       ENDIF 
.1        ENDD
          VFD    "C"*P/0
 IFTBL    ENDM
 STDIF    SPACE  4,8
**        TABLES FOR COMPILING *IF* JUMP CODE ON 3-BRANCH IF. 
  
*         ENTRIES WHEN UPCOMING STATEMENT NUMBER NOT REFERENCED.
  
 STDIF    BSS    0
          IFTBL  123,I,ERR7,I,I,D,I 
          IFTBL  113,I,ERR7,I,R,D,R 
          IFTBL  122,I,ERR7,I,I,D,I 
          IFTBL  121,I,ERR7,I,I,I,I 
  
**        ENTRIES WHEN UPCOMING STATEMENT NUMBER REFERENCED ONLY ONCE.
  
          IFTBL  N23,I,ERR7,I,I,D,I 
          IFTBL  1N3,I,ERR7,I,R,D,R 
          IFTBL  12N,I,ERR7,I,I,D,I 
  
**        ENTRIES WHEN UPCOMING STATEMENT NUMBER IS REFERENCED
*         MORE THAN ONCE. 
  
 NSTDIF   BSS    0
          IFTBL  NN3,I,ERR7,I,R,D,R 
          IFTBL  11N,I,ERR7,I,R,D,R 
          IFTBL  N22,I,ERR7,I,R,D,R 
          IFTBL  1NN,I,ERR7,I,R,D,R 
          IFTBL  1N1,I,ERR7,I,I,I,I 
          IFTBL  N2N,I,ERR7,I,I,I,I 
 RTOIC    SPACE  4,8
**        14.  REAL RAISED TO INTEGER CONSTANT. 
  
  
 R..2     FMULT  R1,L1,LN1
          ENDS
 R..3     FMULT  T1,LN1,LN1 
          FMULT  R1,*T1,L1
          ENDS
 R..4     FMULT  T1,L1,LN1
          FMULT  R1,*T1,T1
          ENDS
 R..5     FMULT  T1,LN1,LN1 
          FMULT  T2,T1,T1 
          FMULT  R1,*T2,L1
          ENDS
 R..6     FMULT  T1,L1,LN1
          FMULT  T2,T1,T1 
          FMULT  R1,*T1,*T2 
          ENDS
 R..7     FMULT  T1,LN1,LN1 
          FMULT  T2,T1,L1 
          FMULT  T3,*T1,T1
          FMULT  R1,*T2,*T3 
          ENDS
 R..8     FMULT  T1,L1,LN1
          FMULT  T2,*T1,T1
          FMULT  R1,*T2,T2
          ENDS
 R..9     FMULT  T1,LN1,LN1 
          FMULT  T2,*T1,T1
          FMULT  T3,*T2,T2
          FMULT  R1,*T3,L1
          ENDS
 R..10    FMULT  T1,L1,LN1
          FMULT  T2,T1,T1 
          FMULT  T3,*T2,T2
          FMULT  R1,*T1,*T3 
          ENDS
 ITOIC1   SPACE  4,8
**        15A.  INTEGER RAISED TO INTEGER CONSTANT
*               (INTEGER MULTIPLY INSTRUCTION AVAILABLE.) 
  
 I..2     IMULT  R1,L1,LN1
          ENDS
 I..3     IMULT  T1,LN1,LN1 
          IMULT  R1,*T1,L1
          ENDS
 I..4     IMULT  T1,L1,LN1
          IMULT  R1,*T1,T1
          ENDS
 I..5     IMULT  T1,LN1,LN1 
          IMULT  T2,*T1,T1
          IMULT  R1,*T2,L1
          ENDS
 I..6     IMULT  T1,LN1,LN1 
          IMULT  T2,*T1,L1
          IMULT  R1,*T2,T2
          ENDS
 I..7     IMULT  T1,LN1,LN1 
          IMULT  T2,T1,L1 
          IMULT  T3,*T1,T1
          IMULT  R1,*T2,*T3 
          ENDS
 I..8     IMULT  T1,L1,LN1
          IMULT  T2,*T1,T1
          IMULT  R1,*T2,T2
          ENDS
 I..9     IMULT  T1,LN1,LN1 
          IMULT  T2,*T1,T1
          IMULT  T3,*T2,T2
          IMULT  R1,*T3,L1
          ENDS
 I..10    IMULT  T1,LN1,LN1 
          IMULT  T2,*T1,T1
          IMULT  T3,*T2,L1
          IMULT  R1,*T3,T3
          ENDS
 DOMAC    EJECT  4,12 
**        *DO* STATEMENT MACROS.
* 
*         A.  *DO* BEGIN CODE.
  
  
 O=DOB    CALL   O=CAR       CLEAR REGISTER FILE
          XMIT   X6,L1
          CALL   CBSS,L2
          CALL   DIP         SET *DO* CONDITIONS
          ENDS
  
 DOCONC   SPACE  4,20 
**        B.  *DO* CONCLUSION CODE. 
*                GENERAL FORM OF TURPLE FOR *DOC* MACROS IS 
* 
*         NOTE - *DOC* MACROS ALWAYS ARE USED WITH A DOUBLE TURPLE. 
* 
*                1ST TURPLE.
*                OR.OPR = O=DOCX, WHERE X CAN BE 1,2 OR 3.
*                OR.1OP = INDEX OF *DO* 
*                OR.2OP = INCREMENT OF *DO* 
* 
*                2ND TURPLE, (ALWAYS FOLLOWING 1ST) 
* 
*                OR.OPR = DUMMY (ECHO OF 1ST) 
*                OR.1OP = LIMIT OF *DO* 
*                OR.2OP = *DO* BEGIN STATMENT TAG.
  
**        O=DOC1
*                1. INCREMENT IS VARIABLE 
*                2. LIMIT IS VARIABLE 
  
 O=DOC1   IADD   X6,L1,L2 
          ISUB   T1,L3,X6 
          PLJ    0,*T1,"DOBEG"
          RESET  -L.TURP
          ENDS
  
**        O=DOC2
*                1. INCREMENT IS SHORT
*                2. LIMIT IS VARIABLE 
  
 O=DOC2   SX=XK  X6,L1,"DOINCR" 
          ISUB   T1,L3,X6 
          PLJ    0,*T1,"DOBEG"
          RESET  -L.TURP
          ENDS
  
  
**        O=DOC3
*                1.  INCREMENT IS SHORT 
*                2.  LIMIT IS SHORT 
  
 O=DOC3   SX=XK  X6,L1,"DOINCR" 
          SX=XK  T1,X6,"DOLIM"
          MIJ    0,*T1,"DOBEG"
          RESET  -L.TURP
          ENDS
  
**        O=DOC3A, SAME CONDITIONS OF *DO* INDICES AND *DO* LOOP IS 
*                  WELL BEHAVED.
*                (B6) IS ASSIGNED *DO* INDEX ACROSS *DO* LOOP 
  
  
 O=DOC3A  LOADB  L1,,+R.B5-RGFILE 
          SB=BK  5,5,"DOINCR" 
          SB=BK  6,5,"DOLIM"
          LTB    6,0,"DOBEG"
          CALL   CDO         CLEAR *DO* 
          RESET  -L.TURP
          ENDS
  
**        O=DOC4
*                1.  INCREMENT IS VARIABLE
*                2.  LIMIT IS SHORT 
  
  
 O=DOC4   IADD   X6,L1,L2 
          SX=XK  T1,X6,"DOLIM"
          MIJ    0,*T1,"DOBEG"
          RESET  -L.TURP
          ENDS
 MISC     EJECT  4,8
**        14. MISCELLANEOUS SKELETONS.
  
  
**        UNCONDITIONAL GOTO
 O=GOTON  EQJ    "N1" 
          ENDS
  
**        ASSIGNED GOTO 
 O=GOA    SB=XB  6,L1,0 
          CALL   CBJ                   COMPILE *B* JUMP 
          ENDS
  
**        COMPUTED GOTO 
 O=GOC    CALL   O=CAR       *KLUDGE* 
          SX=XK  T1,LN1,-1   X1 = (NUMBER OF BRANCHES)
,                            SX0   X1-1 
          SX=XK  T2,LN1,CL2  SX7  X1-(NUMBER OF BRANCHES) 
          ORN    T3,*T1,*T2  BX6   -X7+X0 
          CALL   O=CDW
          RSHF   T3,59       AX6   59 
          ANDN   T4,L1,*T3   BX0   -X6*X1 
          SB=XB  6,*T4
          ENDS
  
**        COMPUTED GOTO IF LINE NUMBER .GE. 7777B 
 O=GOCL   CALL   O=CAR
          SX=XK  T1,L1,+1 
          SX=XK  T2,T1,-2 
          SX=XK  T3,T1,CL2
          ORN    T4,*T2,*T3 
          CALL   O=CDW
          RSHF   T4,59
          ANDN   T5,*T1,*T4 
          SB=XB  6,*T5
          ENDS
  
 O=ASSGN  SX=BK  X6,0,"M1"
          SA=BK  6,0,"N3" 
          ENDS
  
 O=BSS    CALL   CBSS,L1     DEFINE LABEL 
          ENDS
  
**        SKELETONS FOR SUBPROGRAM EXIT.
  
 O=QUITP  SA=BK  1,0,+CT.TRAC 
          ENDF
 O=QUITS  CALL   O=CDW
          EQJ    "N1" 
          CALL   O=CAR
          ENDS
  
 O=RTNA   CALL   O=CDW
          SA=AK  5,0,CL1
          SA=BK  4,0,+CT.TPA0 
          SB=XB  6,5
          SA=XB  0,4
          CALL   CBJ
          CALL   O=CAR
          ENDS
  
 O=RET0   CALL   CBSS,+CT.RETN     SUBROUTINE 
          ENDS
  
**        FUNCTION RESULT RETURN MACROS --
*                (2OP) = VALUE. + MODE
  
 O=RETD   CALL O=CAR
          XMIT   X7,LL2      FUNCTION - DOUBLE RESULTS
          XMIT   X6,L2
          ENDS
  
 O=RETS   CALL   O=CAR
          XMIT   X6,L2       FUNCTION - SINGLE RESULTS
          ENDS
  
**        ENTRY POINT DEFINITION MACROS --
*                ("M1") = ENTRY POINT TAG 
*                ("N1") = TAG OF FIRST INST AFTER ENTRY POINT.
*                ("N3") = TAG OF MAIN ENTRY POINT, IF REQUIRED. 
  
 O=RETN   CALL   O=CDW
          SA=BK  2,0,+CT.TPA0         RESTORE (A0)
          SA=XB  0,2
          ENDF
 O=NTR    CALL   CBSS,L1           MAIN ENTRY, NO ARGS
          EQJ    "M1" 
          ENDS
  
 O=NTRM   SB=BK  6,0,+CT.BEGIN
          CALL   CBSS,+CT.INIT
          ENDF
 O=NTRN   SX=AB  6,0
          SA=AB  0,1
          SA=BK  6,0,+CT.TPA0 
          ENDS
  
 #FID     IFNE   .FID,0 
          ENTRY  O=NTRN1
 O=NTRN1  SX=AB  6,1
          SA=BK  6,0,+CT.TPA1 
          ENDS
 #FID     ENDIF 
  
 O=NTRX   JPQ    +CT.BEGIN
          ENDS
  
 O=NTRY   CALL   CBJ,+7 
          ENDS
  
 O=NTR0   CALL   CBSS,L1           ENTRY POINT, NO ARGS 
          EQJ    "M1" 
          ENDF
 O=NTR1   SA=BK  5,0,"M1" 
          XMIT   7,5,5
          SA=BK  7,0,"N3" 
          CALL   O=CAR
          ENDS
  
 O=NTRP   SB=BK  6,0,"N1"    ENTRY WITH ARGUMENTS 
          EQJ    +CT.INIT 
          ENDS
**        VOID THE INSTRUCTION STACK AFTER POSSIBLY STORING INTO IT.
          ENTRY  O=VOID 
 O=VOID   RJQ    "M1"        VOID CPU INSTRUCTION STACK 
          CALL   CBSS,L1
          RJQ    "M1"        DUMMY WORD 
          ENDS
  
**        SET TRACEBACK WORD. 
  
 O=STRC   CALL   O=CDW
          XMIT   X7,L1
          SA=BK  7,0,"N1" 
          ENDS
  
**        SET LINE NUMBER IN ENTRY POINT. 
  
 O=SLNO   SA=BK  1,0,"M1" 
          FMASK  T2,30
          SX=BB  T3,7 
          AND    T4,*T2,1 
          OR     7,*T4,*T3
          SA=BK  7,0,"M1" 
          ENDS
  
**        TRANSMIT. 
  
 O=XMIT   XMIT   R1,L1
          ENDS
 O=IO     SPACE  4,8
**        SOME *I/O* SKELETONS. 
  
  
 O=APLUG  LOAD   L2                PLUG (NEW) ADDRESS INTO AP-LIST. 
          FMASK  T1,36
          AND    T2,*T1,L2
          OR     R1,L1,*T2
          ENDS
 O=RAG    SPACE  4,8
**        O=RAG - LOAD ARGUMENT INTO REGISTER FOR CALL-BY-VALUE.
* 
*                (1OP) = SECOND ARGUMENT (OR DUMMY).
*                (2OP) = FIRST  ARGUMENT. 
  
  
 O=RAGS1  LOAD   L2,,+R.X1-RGFILE SINGLE ARGUMENT 
          ENDS
  
 O=RAGD1  LOAD   LU2,,+R.X1-RGFILE
          LOAD   LL2,,+R.X2-RGFILE
          ENDS
  
 O=RAGSS  LOAD   L1,,+R.X1-RGFILE  1OP = SINGLE , 2OP = SINGLE
          LOAD   L2,,+R.X3-RGFILE 
          ENDS
  
 O=RAGSD  LOAD   L1,,+R.X1-RGFILE  1OP = SINGLE , 2OP = DOUBLE
          LOAD   LU2,,+R.X3-RGFILE
          LOAD   LL2,,+R.X4-RGFILE
          ENDS
  
 O=RAGDS  LOAD   LU1,,+R.X1-RGFILE 1OP = DOUBLE , 2OP = SINGLE
          LOAD   LL1,,+R.X2-RGFILE
          LOAD   L2,,+R.X3-RGFILE 
          ENDS
  
 O=RAGDD  LOAD   LU1,,+R.X1-RGFILE 1OP = DOUBLE , 2OP = DOUBLE
          LOAD   LL1,,+R.X2-RGFILE
          LOAD   LU2,,+R.X3-RGFILE
          LOAD   LL2,,+R.X4-RGFILE
          ENDS
 ADDSUB   SPACE  4,8
**        O=ADSUB - ADDRESS SUBSTITUTION TURPLES
* 
*                (1OP) = TAG TO BE SUBSTITUTED. 
*                (2OP) = TAG FOR LOCATION OF SUBSTITUTION.
  
  
 O=RJSUB  XMIT   X2,L1
          LSHF   X2,30
          SA=BK  1,0,+CT.RJS
          OR     X7,X1,X2 
          SA=AB  7,L2,0 
          ENDS
 ARI      SECT   (A R I T H),1
 CAI      EJECT  4,20 
**        CAI -  COMPILE ARITHMETIC INSTRUCTION.
* 
*         (P A S S   --  T W O  OF A ONE PASS COMPILER.)
* 
*         ENTRY  TT.PAR = PARSED FILE TO PROCESS. 
*                TT.SCR = EXTERNALS TO PROCESS. 
* 
*         EXIT   TT=PAR = 0 
*                TT=USE = 0 
*                TT=SCR = 0 
  
  
**        EXIT --   P A S S   T W O.... 
  
  
**        EXIT THRU HERE IF BINARY SUPPRESSED OR LOCAL ERRORS FOUND.
  
 CAIX     BSS    0
  
 TEST     IFNE   TEST 
          SA5    PARSLEN
          SA4    TT=PAR 
          IX0    X5-X4
          AX0    59 
          BX7    -X0*X5 
          BX6    X0*X4
          IX6    X6+X7
          SA6    A5          RESET MAXIMUM PARSED FILE LENGTH 
          EQ     CAIXSN      CONTINUE 
          ENTRY  PARSLEN
 PARSLEN  DATA   0
          DIS    ,/ LARGEST PARSED FILE LENGTH./
  
 CAIXSN   BSS    0
 TEST     ENDIF  TEST 
          SA1    DRITE
          ZR     X1,CAI10    IF DELAYED STORE NOT SET 
          IFBIT  X1,-2ARY,CAI10 
          DRITE  DEACTIVATE 
 CAI10    BSS    0
  
          SHRINK TT=PAR,0 
          SA2    TT=USE 
          SHRINK TT=SCR,X6
          SHRINK A2,X6
          SA6    CURST       RESET STARTING PASS 1 BLOCK
  
*         RESTORE *TAG* BACK TO SYMBOL TABLE
  
          SA1    TT.USE 
          SA3    TS.SYM 
          SB6    X2 
          SB5    X1 
          SB4    X3 
          =X0    C.SYM
          =B6    B6-1 
          LE     B6,CAI35    IF NULL USE TABLE, AVOID.. 
  
*         LOOP THROU *TT.USE* FOR TAG THAT NEED TO BE RESTORED. 
  
 CAI30    SA1    B5+B6       LOAD TAG 
          BX6    X1 
          AX1    P.TAG
          IX3    X1-X0
          SA6    X3+B4       RESET SYMBOL TABLE ENTRY 
          =B6    B6-1 
 CAI35    PL     B6,CAI30    IF NOT END OF TABLE
  
**        RESET TEM.MAX TO MAXIMUM TEMPORARY TAG. 
  
          SA2    TEM.MAX
          SA3    TG.TEM 
          IX0    X2-X3
          AX0    60-1 
          BX4    X0*X3
          BX6    -X0*X2 
          IX6    X4+X6
          SA6    A2          RESET TEM.MAX
          SX6    C.TEM
          SA6    A3          RESET TG.TEM 
  
**        CLEAR ALL INTERMEDIATE REGISTERS. 
*         ASSOCIATES FOR INTERMEDIATES MUST BE CLEARED BECAUSE THEY 
*         RELATE TO THE SEQUENCE WITHIN WHICH THEY OCCUR, AND THEY
*         THEREFORE POINT NOWHERE NOW THAT THE PRESENT PARSED FILE HAS
*         BEEN ERASED.
  
          BX6    0
          SB7    R.X7-R.X0
 CAI40    SA2    REGX+B7
          SA1    =XREGA+B7
          MI     B7,CAIY     IF ALL REGISTERS EXAMINED
          SBIT   X2,INTR
          SBIT   X1,INTR
          =B7    B7-1 
          PL     X2,CAI41    IF NOT INTERMEDIATE
          SA6    A2          CLEAR ASSOCIATE
 CAI41    PL     X1,CAI40    IF NOT INTERMEDIATE
          SA6    A1          CLEAR A REG ENTRY
          EQ     CAI40
  
  
 CAIY     BSS                EXIT.. 
 CAI      EQ     "BLOWUP"    ENTRY... 
          SHRINK TT=USE,0 
          SA1    ERR=F
          NZ     X1,CAIX     IF FATAL ERRORS IN PARSED FILE 
  
**        SET-UP USAGE TABLE -- THEN SORT FROM HIGHEST TO LOWEST USAGE
  
          SA1    BINOUT 
          SA2    TT=PAR 
          PL     X1,CAIX     IF BINARY SUPPRESSED 
          BX6    0
          SA1    TT.PAR 
          ZR     X2,CAIX     IF NULL PARSED FILE - EXIT.. 
          SA6    ARGNUM      CLEAR ARGUMENT COUNT (FOR O=ARG) 
          RJ     DUC         DEFINED USE COUNT FOR *PASS* 1 FILE
          BX6    0
          ADDWD  TT.PAR      END INDICATOR. 
          SA4    TT.PAR 
 TEST     IFNE   TEST 
  
**        DUMP NUMBER OF TERMS FOUND (ONLY IF IN TEST MODE) 
  
          SA2    CO.SNAP
          LX2    1RA
          PL     X2,CAI2SN   IF *ARITH* SNAP NOT REQUESTED
          DUMPT  TT.USE      DUMP USE TABLE 
          DUMPT  TT.SCR 
          RJ     =XSN.PAR 
 CAI2SN   BSS    0
 TEST     ENDIF 
  
**        PROCESS EXPANSION OF PARSED FILE FOR CODE GENERATION. 
  
          SB4    X4          PRESET *B4* TO START OF PARSED FILE
          SA1    ALC.CAI
          BX7    X1          LOCK (B4) _ PARSED FILE
          SA7    ALC.REG
          RJ     EIS         EXPAND INSTRUCTION SKELETONS 
          SA1    ALC.00      UNLOCK (B4)
          BX7    X1 
          SA7    ALC.REG
          EQ     CAIX        EXIT.. 
  
 RESFLG   DATA   0           SKELETON ADDRESS WHEN PROCESSING MODE
                             CONVERSION IN EIS. 
 FVD      EJECT  4,15 
**        FVD -  FLUSH VARIABLE DIMENSION CODE. 
* 
*         COMPILES CODE TO PRE-COMPUTE VARIABLE DIMENSION ADDRESS 
*         FUNCTIONS, WHEN NECESSARY.  WILL NOT COMPILE ANYTHING IF NO 
*         VARIABLE DIMENSIONS OCCURRED IN THE SUBPROGRAM. 
* 
*         ENTRY  T.VDIM TABLE CONTAINS *TURPLES* TO BE PROCESSED. 
*                TT.PAR IS A NULL TABLE.
* 
*         EXIT. 
*                CODE DEFINED BY *TURPLES* IN *T.VDIM* SENT TO
*                INTERMEDIATE FILE. 
* 
*         USES   ALL
*         CALLS  ALLOC, CAI 
  
  
 FVD      SUBR               ENTRY/EXIT...
          SA1    MOD
          SA3    T=VDIM 
          =X6    M.PFNC+M.PSUB
          BX0    X6*X1
          SB6    X3 
          ZR     X0,EXIT.    IF NOT PROCEDURE SUBPROGRAM
          ZR     X3,FVD9     IF NO VARIABLE DIMENSION CODE
  
**        FLUSH *T.VDIM* TABLE - OUTPUT INTERMEDIATE FILE CODE. 
  
          ALLOC  TT.PAR,X3   ALLOCIATE SPACE FOR *TURPLES*
          SX3    B7-B6       DESTINATION ADDRESS
          SA1    T=VDIM      WC 
          SA2    T.VDIM      SOURCE ADDRESS 
          MVE    X1,X2,X3    MOVE *TURPLES* TO PARSER TABLE 
          SHRINK T=VDIM      COLLAPSE T.VDIM
          RJ     CAI         FLUSH TABLE
          DRITE  DEACTIVATE 
  
**        COMPILE DUMMY *RJT* WORD IF NECESSARY.
  
  
 FVD9     SA1    RJTDUM 
          ZR     X1,EXIT. 
          CBSS   X1 
          =X6    0           ROUTINE NAME 
          =X3    0           TRACEBACK LINE NUMBER
          CRJ    MUST 
          EQ     EXIT.
 DUC      SPACE  4,20 
**        DUC -  DEFINE *USE* COUNT ON OPERANDS IN *PASS* 1 FILE FOR
*                *PASS* 2 PROCESSING OF REGISTER ASSIGNMENT.
* 
*         ENTRY  PARSED FILE BUILT AND FWA OF TABLE IT IS IN CONTAINED
*                IN REGISTER (X1).
* 
* 
*         EXIT   USE COUNT SET IN --
*                IF *OPERAND* WAS A *TAG* - 
*                *TAG* BITS IN *TS.SYM* REPLACED WITH *USE* COUNT.
* 
*                IF *OPERAND* WAS A *CONSTANT* OR *INTERMEDIATE*
*                *USE* COUNT IN *BIAS* POSITION OF *OPERAND*
* 
*                (SCSA) = (USEMASK) 
* 
*         USES   ALL REGISTERS. 
*                (SCSA, TT.SCR, TT.SYM, TT.USE) 
*         CALLS  ADDWD, SCS 
* 
*         NOTE - NEITHER ADDWD, NOR SCS MAY DESTROY (X4,X5  B4,B5,B6) 
  
 USEMASK  SYMASK (2TAG,2BIAS,2FPNO,2CLAS) 
  
 DUC      SUBR               ENTRY/EXIT.. 
          SA3    USEMASK
          SA2    A1+N.TABLE  LOAD LENGTH OF TABLE BEING PROCESSED 
          BX7    X3 
          IX0    X2+X1
          SA7    SCSA        SET MASK FOR *SCS* SCAN
          SB4    A1          SAVE TABLE ADDRESS 
          SX4    X2-L.TURP   LENGTH -L.TURP 
          SB5    X1          FWA OF TABLE 
          BX1    X2 
          SA3    X4+B5
          EQ     DUC10       CONTINUE 
  
**        REGISTER ALLOCATION 
*         (X2) = WORD FROM TABLE
*         (X4) = DECREMENT WORD 
* 
*         (B4) _ TABLE ORIGIN WORD OF TABLE BEING SCANNED 
*         (B5) = FWA OF TABLE 
*         (B6) = REMAINING LENGTH TO SCAN 
  
  
 DUC.     BSS    0           NULL OPERATOR. 
 DUC2     SA1    B4 
          SB5    X1          RESET FWA OF TABLE SCANNING
 DUC6     SA3    X4+B5       NEXT ENTRY 
          MI     X4,EXIT.    IF FINISHED
  
*         DETERMINE TYPE OF OPERAND 
*         (X3) = OPERATOR WORD
  
 DUC10    SA1    X3+CHARMAP 
          =X4    X4-L.TURP
          =A2    A3+OR.2OP   PRELOAD 2ND OPERAND
          SB7    X1 
          SB6    DUC2 
          BX1    X2 
          JP     B7          JUMP TO PROCESS OPERANDS 
  
*         1ST OPERAND ONLY. 
  
 DUC.1ST  =A2    A2-OR.2OP+OR.1OP 
          BX1    X2 
          EQ     DUC15
  
*         BOTH OPERAND. 
  
 DUC.BTH  SB6    DUC12
          =X4    X4+L.TURP+1
          EQ     DUC15
  
*         PROCESS 1ST OPERAND WHEN *BOTH* REQUESTED.
  
 DUC12    SA1    B4 
          SB6    DUC2 
          SB5    X1 
          SA2    X4+B5
          =X4    X4-L.TURP-1
          BX1    X2 
  
*         SET OPERANDS USE COUNT. 
*         (X1) = (X2) = OPERANDS
*         (B6) = EXIT ADDRESS.
  
 DUC.2ND  BSS    0
 DUC15    BX3    X2 
          AX3    P.TGB
          SB7    X3-C.STN/1S13
          NZ     B7,DUC152   IF NOT STATEMENT NUMBER
          JP     B6 
  
 DUC152   IFBIT  X1,SHORT,DUC30    IF SHORT CONSTANT
          IFBIT  X1,INTR/SHORT,DUC40   IF INTERMEDIATE
          SB7    X3-C.SYM/1S13
          ZR     B7,DUC16           IF SYMBOL 
          SB7    X3-C.CON/1S13
          ZR     B7,DUC37           IF CONSTANT 
          SB7    X3-C.PRO/1S13
          ZR     B7,DUC37           IF PROGRAM TAG
          SB7    X3-C.VDIM/1S13 
          ZR     B7,DUC37           IF VAR-DIM
          SB7    X3-C.TEM/1S13
          ZR     B7,DUC37           IF TEMP TAG 
          JP     B6                IF TAG NOT DEFINED 
  
*         CURRENT ENTITY IS DEFINED TO BE IN THE SYMBOL TABLE.
*         CHECK IF *1ST* USE
  
 DUC16    IFBIT  X1,2ARY/INTR,DUC37   IF ARRAY
          IFBIT  X1,ADDR/2ARY,DUC37  IF ADDRESS SET 
          BX1    X2 
          SA5    TS.SYM 
          AX1    P.2TAG 
          SB2    X5 
          SX7    X1-C.SYM 
          SA3    X7+B2       LOAD SYMBOL TABLE ENTRY
          =X5    1
          BX0    X3 
          LX0    59-8        *** TEMPORARY ***
          PL     X0,DUC25    IF 1ST USE 
          SX1    RLOCK
          BX3    X3-X1       TURN OFF NOT LAST USE BIT
          IX6    X3+X5
          BX6    X6+X1       TURN ON NOT LAST USE BIT 
          SA6    A3          UPDATE USE COUNT 
          SA6    A2          REPLACE PARSED FILE ENTRY
          JP     B6          EXIT 
  
**        PROCESS *SYMBOL TABLE TAG*
*         FIRST USE OF TAG, REPLACE SYMBOL TABLE ENTRY WITH THE PARSED
*         FILE ENTRY REPLACING *MODE* BITS WITH *0* AND SETTING THE 
*         LOCK BIT TO INDICATE NOT THE *1ST* USE.  TAKE THE *TS.SYM*
*         ENTRY AND PUT IT IN *TT.USE* FOR *CAI* TO USE TO PUT BACK INTO
*         THE SYMBOL TABLE. 
  
 DUC25    MX7    -L.RUSE
          =X1    RLOCK
          BX7    X7*X2
          LX6    X3 
          BX7    X7+X1       INDICATE NOT 1ST USE 
          IX7    X7+X5
          SA7    A3 
          SA7    A2          REPLACE PARSED FILE ENTRY
          ADDWD  TT.USE      ADD *SYMBOL* TABLE ENTRY TO USE TABLE
          JP     B6 
  
*         HERE IF *OPERAND IS SHORT CONSTANT. 
  
 DUC30    MX0    -L.MODE
          BX5    -X0*X2 
          LX5    P.2FPNO
          BX2    X2+X5
  
*         HERE IF *OPERAND IS CONSTANT, PROGRAM, VAR-DIM, OR ARRAY TAG. 
*         HERE ALSO FOR SET TO SYMBOL TABLE TAG.
  
  
 DUC37    SA3    B4 
          SB5    X3 
          SB5    A2-B5
          LX6    X2 
          =X5    1
          SCAN   TT.SCR,SCS 
          MI     B7,DUC38    IF NOT ALREADY IN TABLE
          IX6    X2+X5       ADVANCE USE COUNT
          SA6    A2 
          SA1    TT.SCR 
          EQ     DUC39
  
*         *OPERAND* NOT IN TABLE (1ST) USE) SET USE COUNT =1, AND ADD 
*         TO TABLE. 
  
 DUC38    BX6    X3*X6       SET USE COUNT = 1
          IX6    X6+X5
          ADDWD  TT.SCR 
  
*         HERE TO REPLACE PARSED FILE ENTRY AND RESET (SDSA)
*         (B5) = RELATIVE PARSED FILE ADDRESS.
*         (A6) = TT.SCR ADDRESS OF *OPERAND*. 
*         (X1) = FWA TT.SCR.
*         (X6) = PARSED FILE ENTRY WITH USE COUNT ADDED.
  
 DUC39    SA3    B4 
          SB7    X1 
          MX0    L.2TAG 
          SB5    B5+X3
          SX1    A6-B7
          BX6    -X0*X6 
          SX2    X1+C.SCR 
          BX7    X3 
          LX2    P.2TAG 
          IX6    X6+X2       REPLACE *TAG* WITH TT.SCR ORDINAL
          SA6    B5          REPLCE PARSED FILE ENTRY 
          JP     B6          NEXT 
  
*         *OPERAND* IS INTERMEDIATE.
  
 DUC40    BX3    X2 
          MX7    -L.MODE
          =X0    1
          AX3    P.JPAD 
          BX6    -X7*X2 
          LX0    P.MODC 
          SA5    X3+B5       OPERATOR WORD FOR INTERMEDIATE 
          LX6    P.DMOD 
          IX7    X5+X0       ADVANCE USE COUNT
          BX6    X2+X6
          MX0    -L.RUSE
          SA7    A5          REPLACE OPERATOR WORD
          BX6    X0*X6
          AX7    P.MODC 
          BX7    -X0*X7 
          IX6    X6+X7       ADD USE COUNT TO OPERAND 
          SA6    A2          REPLACE ENTRY IN PARSED FILE 
          =X3    M.LONG 
          IFBIT  X1,-2ARY/INTR,DUC42
          BX7    X3*X2
          AX5    P.MODC 
          =A1    A5+OR.2OP
          AX7    P.LONG 
          BX3    X1 
          IFBIT  X1,-INTR,DUC42 
          BX5    -X0*X5 
          AX3    P.JPAD 
          IX0    X5+X7
          SA1    X3+B5
          LX0    P.MODC 
          IX6    X1+X0
          SA6    A1 
 DUC42    JP     B6 
  
 EIS      EJECT  4,20 
**        EIS -  EXPAND INSTRUCTION SKELETON. 
* 
*         HEART OF PASS TWO PROCESSING.  *EIS* USES THE PARSED FILE,
*         BUILT DURING PASS ONE AS A PSEUDO- MICRO PROGRAMMING FILE TO
*         GENERATE OBJECT CODE FOR THE CURRENT SEQUENCE.  EACH TURPLE 
*         IS EXPANDED USING THE OR.OPR WORD AS THE ADDRESS FOR THE
*         SKELETON.  AS EACH PORTION OF THE INSTRUCTION IS PROCESSED
*         *EIS* KEEPS TRACK OF REGISTERS USED, TYPE OF USAGE, OP-CODES
*         AND SEQUENCE BREAKS WITHIN THE PASS ONE FILE. 
* 
* 
*         SPECIAL CASING IS DONE WHEN THE OP-CODE FOR A GIVEN EXPANSION 
*         DEFINES EITHER A LOAD OR STORE OPERATION.  AFTER THE J PORTION
*         OF A LOAD INSTRUCTION IS SET INTO *INS.REG*, EIS LOOKS AT THE 
*         TYPE OF REGISTERS USED TO DETERMINE WHAT TYPE OF LOAD 
*         INSTRUCTION IS TO BE COMPILED.  IN DOING THIS, *EIS* MIGHT
*         HAVE TO INSERT SPECIAL SEQUENCES OF SKELETONS TO GET THE
*         REGISTERS SET-UP CORRECTLY FOR ADDRESS GENERATION.
* 
*         CURRENTLY THERE ARE FOUR MAJOR ROUTES *EIS* MAY TAKE
*         1.  NON-STANDARD PROCESSORS 
*             EXTERNAL PROCESSOR MUST BE CALLED TO EXPAND CURRENT 
*             SKELETON. 
*         2.  A RESET OF SKELETON 
*             CURRENT SKELETON USES ANOTHER SKELETON TO COMPLETE
*             EXPANSION OF CURRENT TURPLE.
*         3.  A CALL DURING SKELETON EXPANSION
*             SUB-PROCESS INSIDE SKELETON REQUIRES A SPECIAL PROCESSOR
*             TO HANDLE SUB-FUNCTION OF TURPLE. 
*         4.  A USE OF ANOTHER SKELETON FOR A SUB-PROCESS OF CURRENT
*             TURPLE. 
*             CURRENT TURPLE IS PARTIAL DEFINED BY ANOTHER SKELETON.
* 
*         ENTRY  (B4) _ 1ST PARSED TURPLE.
* 
*         EXIT   CODE COMPILED FOR PARSED FILE. 
* 
*         --------------- L O C K  -  R E G I S T E R S --------------
* 
*                       B4 _ POINTS TO CURRENT TURPLE.
*                       A4,X4 = CURRENT INSTRUCTION SKELETON. 
* 
*         NO ROUTINE INTERNAL TO *EIS* MAY DESTROY ABOVE REGISTERS. 
*         ------------------------------------------------------------
  
  
 EIS      SUBR   0
          SX6    R.X5-R.X0
          MX7    -1 
          SA6    RGX         INITIALIZE REGISTER USAGE
          =X6    X6+1 
          SA7    REGLK
          SA7    =XSTRGLK 
          SA6    RGC         INITIALIZE LOAD REGISTERS
  
*         RESET REGISTER SKELETON WORDS 
  
 RESET    ECHO   ,CLASS=(INTR,TEMP,LOAD,LODX,STOR)
          =A1    =XRG=CLASS+2 
          BX6    X1 
          =A6    A1-1 
 RESET    ENDD
  
 EIS.PNX  =A5    B4+OR.OPR
          MX6    0
          BX0    X5 
          SA6    NOLDS       CLEAR NUMBER OF LOADS
          ZR     X5,EISX     IF END OF PARSED FILE. (*EOS* FOUND.)
          =X6    X6+1 
          SA6    UUC
  
          AX5    P.JPAD      SHIFT TO INSTRUCTION SKELETON ADDRESS
          IFBIT  X0,-NONSTD,EIS5
 NONSTD   SPACE  4,8
**        IF NON-STANDARD OPERATOR (LIKE SUBSCRIPT,OR FUNCTION) 
*         *EIS* JUMPS TO THE PROCESSOR WITH 
* 
*         (X0) = CURRENT OPERATOR SHIFTED BY P.NONSTD.
*         (B4) _ START OF CURRENT TRIPLE. 
*         (B7) = 0
  
          =B7    0
  
          SB2    X5          PROCESSOR ADDRESS
          JP     B2          JUMP TO PROCESSOR. 
  
**        ENTRY  (X5) = CURRENT PARSED FILE OPERATOR WORD.
  
 EIS5     SB2    X5          INSTRUCTION SKELETON ADDRESS 
          =A4    B2-1        DUMMY LOAD TO ACTIVATE *A4*
 EIS.LNX  SX6    -3 
          BX5    0           CLEAR REGISTER ASSEMBLE - 000. 
          SA6    IJK
          =A4    A4+1 
 SPECIAL  SPACE  4,8
**        CHECK IF SKELETON REQUIRES SPECIAL HANDLING 
* 
*         USESKL - TEMPORARY USE OF DIFFERENT SKELETON X RETURNING TO 
*                  CURRENT SKELETON.
*         RESET  - RESET SKELETON TO X. 
*         CALL   - EXTERNAL PROCESSOR *RJ* TO X.
*         OTHER  - NORMAL PROCESSING. 
* 
*         ENTRY  (X4) = CURRENT SKELETON WORD.
  
          BX0    X4 
          AX0    P.ITYPE
          MX1    -L.ITYPE+1 
          BX2    -X1*X0 
          SA1    X2+EIS.TYP 
          BX7    X2 
          SB7    X1 
          SA7    OPTYP
          JP     B7          JUMP TO PROCESS TYPE 
  
 EIS.TYP  BSS    0
          CON    EIS.COND    CONDITIONAL
          CON    EIS.LN1     ARITHMETIC TYPE INSTRUCTION
          CON    EIS.LN1     DEFINED INCREMENT INSTRUCTION
          CON    EIS.BRN     BRANCH 
          CON    EIS.SHF     SHIFT/XMIT 
          CON    EIS.CALL    CALL 
          CON    EIS.USEL    USE-SKEL 
          CON    EIS.RSET    RESET
          CON    EIS.LOD     LOAD/STORE INSTRUCTION 
  
**        IF PROCESSING *RESET* SKELETON
  
 EIS.RSET SB2    X4 
          PL     B2,EIS.RST5 IF HARD ADDRESS OF SKELETON
          SB2    B2-L.TURP
          SB4    B4-B2
          EQ     EIS.PNX     CONTINUE TO NEXT REQUESTED *TURPLE*
 EIS.RST5 SA4    B2 
          EQ     EIS.LN1     CONTINUE WITH NEXT SKELETON
  
**        IF PROCESSING *CALL* SKELETON 
  
 EIS.CALL SB2    X4          JUMP ADDRESS 
          AX4    P.MARG 
          SX1    X4 
  
**        WHEN (P.MARG) IS POSITIVE, IT CONTAINS THE ARGUMENT TO THE
*         MACRO.
  
          PL     X1,EIS.CL5  IF ARGUMENT IS CONSTANT
  
**        WHEN (P.MARG) IS NEGATIVE, THE MACRO ARGUMENT IS IN THE PARSED
*         TURPLE, AND (P.MARG) IS THE COMPLEMENT OF THE ORDINAL IN THE
*         TURPLE WHICH CONTAINS THE ARGUMENT. 
  
          SB7    X4 
          SA1    B4-B7       LOAD ARGUMENT FROM PARSED FILE 
 EIS.CL5  JP     B2          EXECUTE CALLED ROUTINE 
  
**        IF PROCESSING *USESKL* SKELETON 
  
 EIS.USEL SX3    A4+1 
          SA4    X4 
          BX6    -X3
          SA6    RESFLG 
          EQ     EIS.LN1     CONTINUE 
  
**        IF PROCESSING *LOAD* TYPE INSTRUCTION.
  
 EIS.LOD  MX0    -L.IQF 
          BX6    -X0*X4 
          ZR     X6,EIS.LN1  IF NO HARD REGISTER SPECIFIED
          SA6    RREG        SET HARD REGISTER
          SA6    HREG        SET LOCK FLAG
          EQ     EIS.LN1
  
**        EIS.LN1 - START PROCESSING OF CURRENT SKELETON. 
* 
*         ENTRY  (A4),(X4) = CURRENT SKELETON WORD. 
*                (IJK) = -3.
  
 EIS.COND BSS    0
 EIS.BRN  BSS    0
 EIS.SHF  BSS    0
 EIS.NOOP BSS    0
 EIS.LN1  MX0    L.IOPC 
          LX0    P.IOPC+L.IOPC
          BX6    X0*X4       EXTRACT OP-CODE FIELD
          LX4    -L.IQF 
          AX6    P.IOPC      TO LOW ORDER 
          SA6    OPCODE      CURRENT OP-CODE
  
**        RETURN HERE FOR NEXT PROCESSING OF NEXT PORTION OF INSTRUCTION
*         CURRENTLY EXPANDING WITHIN SKELETON.
  
 EIS.NX   SA1    IJK
          MX0    -L.IOAD
          SB7    X1-3 
          GT     B7,B1,EIS.CMP     IF FINISHED. 
 EIS.JP   SPACE  4,20 
**        HERE IF NOT END OF CURRENT SKELETON.
*         JUMP TO PROCESSOR FOR CURRENT PORTION OF INSTRUCTION. 
* 
*         ENTRY  (X0) = MASK OF -L.IOAD 
*                (X4) = SKELETON SHIFTED BY N*L.IOAD
* 
*         EXIT   (X3) = (INUM) FIELD. 
*                (X6) = 0 
  
          =X6    1
          BX1    -X0*X4 
          SA2    X1+AT.BASE 
          MX0    -L.INUM
          LX4    -L.IOAD
          SA6    UUC         SET UPDATE USE COUNT INCREMENT 
          SB2    X2          ADDRESS OF PROCESSOR.
          =B7    0
          BX3    -X0*X4      REGISTER/CONSTANT NUMBER.
          SX6    0           CLEAR REGISTER ASSIGNMENT. 
          JP     B2 
 TYPES    EJECT  4,20 
**        INDIVIDUAL PROCESSOR SECTION FOR SPECIFIED TYPE OF REQUEST
*         NOTE   AT.I TABLE MAY NOT EXCEED 5 BITS IN LENGTH,
*                MAXIMUM LENGTH =37B... 
  
  
 AT.BASE BSS    0           BASE ADDRESS. 
 AT.CB    CON    EIS.CB      CLEARING OF *B*
 AT.CLU   CON    *+4S15      CLEAR UPPER PART OF LOAD REG. (NOT USED) 
 AT.CLL   CON    *+4S15      CLEAR LOWER PART OF LOAD REG. (NOT USED) 
 AT.CNL   CON    EIS.CNL     SET ITH PORTION = LOWER  PART OF FILE WORD 
 AT.CNM   CON    EIS.CNM     SET ITH PORTION = MIDDLE PART
 AT.CNU   CON    EIS.CNU     SET ITH PORTION = UPPER  PART OF FILE WORD 
 AT.CT    CON    EIS.CT      CLEAR TEMPORARY
 AT.CX    CON    *+4S15      CLEAR *X* ASSIGNMENT (NOT USED)
 AT.HR    CON    *+4S15      ASSIGN HARD REGISTER (NOT USED)
 AT.K     CON    EIS.K       LOAD OF *K*
 AT.L     CON    EIS.L       LOAD OF SINGLE TAG 
 AT.LB    CON    *+4S15      LOAD OF *B* REGISTER (NOT USED)
 AT.LL    CON    EIS.LL      LOAD OF LOWER PART 
 AT.LNL   CON    EIS.LNL
 AT.LN    CON    EIS.LNU     LOAD TAG NOT RESETTING USE COUNT 
 AT.RR    CON    EIS.IR      PROCESS INTERMEDIATE 
 AT.RL    CON    EIS.IRL     PROCESS INTERMEDIATE LOWER 
 AT.SB    CON    EIS.SB      SET *B* REGISTER 
 AT.ST    CON    EIS.ST      SET TEMPORARY REGISTER 
 AT.SX    CON    EIS.SX      SET *X* REGISTER 
 AT.Q     CON    EIS.Q       PROCESS IF *Q* FIELD PRESENT 
  
 L.ATABLE EQU    *-AT.BASE   SEE NOTE ABOVE...
 SBASE    EQU    AT.BASE
          NOREF  SBASE       *SBASE* USED ONLY IN MACRO DEFINITIONS 
 EIS.CMP  EJECT  4,20 
**        COMPILE - FLUSH INSTRUCTION TO LONG FILE. 
* 
*             HERE WHEN  I,J,K AND Q PORTIONS OF SKELETON HAVE BEEN 
*             EVALUATED.
* 
*         ENTRY  INS.REG = REGISTERS - IJK
*                (X1) = REGISTERS - I00 
*                (X6) = REGISTERS - 0I0 
*                (X4) = SKELETON WORD SHIFTED TO P.ITYPE FIELD. 
  
  
 EIS.CMP  SA2    OPTYP
          MX0    -L.IOPC
          LX1    X4          SAVE 
          SB7    X2-M.LOAD
          NZ     B7,EIS.CM1  IF NOT *LOAD* OP-CODE
  
**        TERMINATE INSTRUCTION *LOAD* OPERATOR 
  
          BX3    X4 
          SA1    RREG 
          LX3    59-P.IEND+P.IOPC 
          SB7    X1+XMIT
          NZ     B7,NULLOP   IF LOAD SATISFIED
          BX2    -X1
          MX7    -1 
          SA5    INS.REG
          SA7    A1          INDICATE SATISFIED 
          IX7    X2+X5
          LX7    P.LI15 
          EQ     EIS.CM6
  
 EIS.CM1  BX2    -X0*X4      OPCODE FIELD 
  
**         DUMP CURRENT INSTRUCTION.
  
          BX3    X2 
          AX3    3
          LX4    -L.IOPC
          SB2    X3 
          SA5    INS.REG
          MX0    -L.ITYPE 
          BX0    -X0*X4      TYPE FIELD.
  
          LX5    60-L.IOPC-3-3
  
**        IF ONLY ONE LOAD INSTRUCTION COMPILED FOR THIS TURPLE CHECK 
*         FOR PRELOAD CANDIDATE.
*         (X2) = OP-CODE
*         (X5) = I,J,K PORTION OF INSTRUCTION 
*         (A5) _ INS.REG
  
 EIS.CM5  SB3    X2          SAVE 9 BIT OPCODE FOR PRELOAD TEST 
          LX2    60-L.IOPC
          BX3    X0 
          SA1    NOLDS
          IX7    X2+X5       OPCODE + I,J,K PORTION.
          SB7    X1-2 
          LX3    59-P.IEND+P.ITYPE
          PL     B7,CBREAK   IF PROCESSED MORE THAN ONE LOAD
  
**        CHECK CURRENT OP-CODE AND NEXT TO SEE IF PRELOAD CAN BE SET 
*         IN MOTION.
*                CURRENT OP-CODE CAN NOT BE ANY TYPE OF JUMP INSTRUCT 
* 
*                NEXT TURPLE MUST BE A STANDARD ARITHMETIC OPERATOR.
* 
*         CALLS  CPL
  
  
          SA2    B4+L.TURP
          =B7    0           INDICATE CLEARING OF REGISTERS REQUIRED
          ZR     B3,CBREAK5  IF UNCONDITIONAL BREAK 
          SB2    X2-O.EOS 
          SB7    B3-XMIT/1S6
          =A1    A2+OR.1OP
          MI     B7,CBREAK5  IF CONDITIONAL JUMP
          SB7    X2-O.= 
          ZR     B2,CBREAK   IF NEXT OPERATOR IS *EOS*
          PL     B7,CBREAK   IF NOT AN ARITHMETIC OPERATOR
*         RJ     CPL         CHECK FOR PRELOAD OF OPERAND 
 CREAK    EJECT  4,8
**        CBREAK - CHECK IF CURRENT OPCODE BEING COMPILED 
*         BREAKS THE CURRENT REGISTER ALLOCATION SEQUENCE.
* 
*         NOTE - GENERAL RETURN ADDRESS FOR EXTERNAL PROCESSORS.
*         ENTRY  (X3) = SKELETON SHIFTED BY P.IEND
*                (X7) = INSTRUCTION ABOUT TO BE ADDED TO TT.LF
  
 CBREAK   SA2    DRITE
          MX0    12 
          BX5    X0*X7
          =B7    0           INDICATE CLEARING OF REGISTERS REQUIRED
          ZR     X5,CBREAK5  IF UNCONDITIONAL BREAK IN REGISTERS
          LX5    L.IOPC-3 
          ZR     X2,COMPILE  IF NO DELAYED STORE
          SB7    X5-XMIT/1S9 (XMIT = CONDITIONALS +1) 
          PL     B7,COMPILE  IF NOT A *JUMP* INSTRUCTION
 CBREAK5  BX6    X3 
          SA7    ESTACK      SAVE INSTRUCTION 
          =A6    A7+1        SAVE END FLAG
          SX7    B7 
          =A7    A6+1        SAVE CLEAR REGISTER FLAG 
          DRITE  DEACTIVATE 
          SA2    ESTACK+2 
          MI     X2,CBREAK10 IF NO REGISTER CLEARING REQUIRED 
          RJ     CIA         CLEAR REGISTER FILE
 CBREAK10 SA2    ESTACK 
          =A3    A2+1 
          BX7    X2 
  
**        COMPILE - OUTPUT INSTRUCTION TO LONG FILE.
* 
*         ENTRY  SAME AS *CBREAK* 
  
 EIS.CM6  BSS    0
 COMPILE  WCODE  X7           INSTRUCTION TO LONG FILE
  
**        NULLOP - NULL PROCESSING
* 
*         ENTRY  SAME AS *CBREAK* (X7) IGNORED. 
  
 NULLOP   BSS    0
          =X6    0
          =X7 
          SA6    INS.REG     CLEAR REGISTER ASSEMBLY CELL 
          =A7    A6+1        CLEAR OPCODE CELL
          SA1    REGLK
          =A7    A1+1        *I* PORTION
          =A6    A7+1        *J* PORTION
          SB7    X1 
          RJ     RUL         UNLOCK REGISTER
          MX6    -1 
          SA6    REGLK
 EIS.CM7  PL     X3,EIS.LNX  IF NOT LAST INSTRUCTION IN SEQUENCE. 
 O=NOOP   BSS    0           IF NULL PROCESSING FOR *TURPLE*
          =B4    B4+L.TURP
          SA1    RESFLG 
          BX3    X1 
          ZR     X3,EIS.PNX  IF NO RESET OF SKELETON
  
**        RESET SKELETON TO ORGINAL SKELETON WHICH CAUSED RESET FLAG TO 
*         BE TURNED ON. 
*         (X1) = RESFLG 
  
          =B4    B4-L.TURP
          BX6    0
          PL     X3,RESET5   IF NOT *USKEL* 
          BX2    -X1
          SA6    A1          CLEAR *RESFLG* 
          SA4    X2 
          EQ     EIS.LN1     CONTINUE WHERE I LEFT OFF
  
 RESET5   SA4    X3-1 
          SA6    A1          CLEAR RESET FLAG.
          SA6    A2          RESET MODE CONVERSION FLAG 
          EQ     EIS.LNX     CONTINUE FROM WHERE WE LEFT OFF. 
 HARDRG   EJECT  4,8
**        2.  ASSIGN TEMPORARY REGISTER.
**            A.  ASSIGN TEMPORARY *B* REGISTER.
  
  
 EIS.SB   SB6    X3          SAVE ORDINAL 
          =X1    -1 
          RJ     ABR         ASSIGN *B* REGISTER
          SX7    B2 
          SA7    B6+REG=B    SET *B* REGISTER ASSIGNED CELL 
          EQ     EIS.LRF
 EIS.SX   EJECT  4,8
**        ASSIGN *X* REGISTER 
* 
*         ENTRY  (X3) = REGISTER REQUESTED TO ASSIGN
* 
*         IF REGISTER REQUESTING IS NOT A STORE REGISTER, REGISTER IS 
*         SET WITH NO CHECKING OF USEFILE.
*         IF A STORE REGISTER IS REQUESTED, A CHECK IS MADE OF THE
*         USEFILE TO MAKE SURE WE ARE NOT ABOUT TO CLOBBER A DEFINED
*         RESULT. 
  
  
 EIS.SX   SX6    X3 
          SB7    X3-R.X6+REG.X
          LX6    3           =0R0 
          SB6    X3          =00R 
          MI     B7,EIS.SX5  IF NOT REQUESTING *STORE* REGISTER 
          MX0    -L.RUSE
          SA1    X3+REGX
          BX2    -X0*X1 
          ZR     X2,EIS.SX5  IF USE COUNT *0* 
          DRITE  DEACTIVATE 
          SX6    B6 
          LX6    3           =0R0 
  
**        CHECK FOR USELESS *XMIT* INSTRUCTION ON SOFT TRANSFER OP-CODE 
* 
*         (X6) = 0R0, REQUESTED REGISTER. 
*         (INS.REG) = REGISTERS ASSIGNED SO FAR.
  
 EIS.SX5  SA1    B6+REGX
          MX0    -L.RUSE
          BX1    -X0*X1 
          ZR     X1,EIS.SX10 IF REGISTER FREE 
          SB2    B6+REG.X-RGFILE
          RJ     RUT
 EIS.SX10 SA2    OPCODE 
          SB7    X2-XMIT/1S6
          NZ     B7,EIS.REG  IF NOT *XMIT*
          SA2    INS.REG
  
**        CHECK IF *XMIT* INTO SAME REGISTER
  
          MX1    -3 
          BX0    X6-X2
          AX0    3
          BX0    -X1*X0 
          NZ     X0,EIS.REG  IF NOT *XMIT* INTO SAME REGISTER 
          SA4    A4          RELOAD SKELETON WORD 
          SBIT   X4,IEND
          BX3    X4 
          EQ     NULLOP      NULLIFY OP-CODE
 EIS.ST   EJECT  4,8
**            C.  ASSIGN TEMPORARY *X* REGISTER.
*                 ASSIGN X0, X7, X6 IN THAT ORDER, IF ALL ARE IN USE
*                 KILLS ANY DELAYED STORES.  IF ONE FREED USES REGISTER 
*                 FROM DELAYED STORE, IF NOT USES ONE OF LOAD REGISTERS 
*                 DEPENDING ON HOW MANY LOAD REGISTERS ARE LOCKED.
  
  
 EIS.ST   SA1    X3+REG=T 
          SB6    X3          ORDINAL OF TEMPORARY 
          SB2    X1          REGISTER - 0TR 
          NZ     X1,EIS.ST30 IF ALREADY LOADED - USE IT 
  
**        CHECK FOR UNNECESSARY TRANSMIT INSTRUCTION.  IF FOUND,
*         MAKE *I* REGISTER SAME AS *J* REGISTER SO THAT *PIG* WILL 
*         ELIMINATE INSTRUCTION.
  
          SA2    OPCODE 
          SB7    X2-XMIT/1S6
          NZ     B7,EIS.ST10 IF NOT *XMIT*
          SA2    INS.REG
          MX0    -3 
          AX2    3
          BX0    -X0*X2      *J* REGISTER 
          SA2    X0+REGX     REGFILE ENTRY FOR *J* REGISTER 
          MX1    -L.RUSE
          BX1    -X1*X2      USE COUNT
          NZ     X1,EIS.ST10 IF USE COUNT NOT ZERO
  
*         TRANSMIT INSTRUCTION IS UNNECESSARY 
  
          SB2    X0+REG.X-RGFILE   *I* REGISTER - 0TR 
          EQ     EIS.ST30 
  
 EIS.ST10 SB3    RG=TEMP
          RJ     SFR
          ZR     X7,EIS.ST30 IF TEMP REGISTER AVAILABLE 
          SA1    RGX
          ZR     X1,EIS.ST20 IF NON-INTERMEDIATE NOT AVAILABLE
          SB2    X1 
          RJ     RUT
          EQ     EIS.ST30 
  
  
**        TAKE CARE TO AVOID DEADLOCK THAT WILL OCCUR IF BOTH STORE 
*         REGISTERS ARE ASSIGNED AS TEMPORARY *X* REGISTERS.
  
 EIS.ST20 SA1    REGFILE+R.X6 
          SA2    REGFILE+R.X7 
          =X3    MAX.USEC 
          MX0    -L.RUSE
          BX1    -X0*X1      USE COUNT ON *X6*
          BX1    X3-X1
          ZR     X1,EIS.ST25 IF *X6* IS TEMPORARY 
          BX2    -X0*X2      USE COUNT ON *X7*
          BX1    X3-X2
          ZR     X1,EIS.ST25 IF *X7* IS TEMPORARY 
  
*         NEITHER *X6* NOR *X7* IS TEMPORARY. 
  
          RJ     ASR         ASSIGN STORE REGISTER
          EQ     EIS.ST30 
  
*         USE TEMP REGISTER OF LOWEST USE COUNT.
  
 EIS.ST25 RJ     RUT
  
**        FOUND REGISTER FREE FOR TEMPORARY ASSIGNMENT. 
*         (B2) = 0TR. 
*         (B6) = ORDINAL OF TEMPORARY.
  
 EIS.ST30 SX3    B6 
          SX7    B2 
          LX3    P.TAG
          =X2    MAX.USEC 
          MX0    -3 
          BX6    X2+X3       DUMMY TAG FOR RGFILE 
          SA7    B6+REG=T    SET *REG=T* FILE 
          SA6    B2+REGFILE 
          BX6    -X0*X7 
          LX6    3
          EQ     EIS.LRF
 CLTEMP   EJECT  4,20 
**        CLEAR REGISTER ASSIGNMENT FOR CURRENT SKELETON. 
*             A.  PROCESS TEMPORARY - WITH CLEARING OF T-REGISTER.
  
 EIS.CT   SA2    X3+REG=T    LOAD TEMPORARY REGISTER CELL 
          =X7    0
          MX1    -3 
          SA7    A2          CLEAR TEMPORARY REGISTER CELL
  
**        CLEAR *USEFILE* USAGE COUNT ON REGISTER POINTED TO BY *0TR* 
*         IN *X2*.
*         (X1) = REGISTER MASK. 
*         (X2) = 0TR FOR REGISTER TO BE CLEARED.
  
 EIS.CT5  BX6    -X1*X2      REGISTER ONLY = 00R
          SB2    X2 
          BX7    0
          LX6    3           =0R0 
          SA7    X2+REGFILE 
          EQ     EIS.LRF
  
 EIS.CB   EJECT  4,8
*             B. CLEAR *B* REGISTER 
 EIS.CB   SA2    X3+REG=B 
          =X7    0
          SA7    A2          CLEAR *B* REGISTER LOCAL CEL 
          EQ     EIS.CT5     CONTINUE 
 EIS.CX   SPACE  4,8
**            D. PROCESS LOAD OF LOWER PART OF DOUBLE TYPE VARIABLE.
*                 ENTRY - (X3) = RELATIVE ORDINAL OF TAG TO BE LOADED.
*                         (B7) = REGISTER NUMBER. IF 0 - ANY REGISTER.
  
 EIS.LNL  =X6    0
          SA6    UUC
  
 EIS.LL   SA5    X3+B4       TAG TO BE LOADED 
          =X6    1           INDICATE LOWER HALF
          EQ     EIS.L2 
 EIS.L    EJECT  4,8
**           C. PROCESS LOAD INTO *A*,*X* REGISTER. 
*                ENTRY - (X3) = RELATIVE ORDINAL OF TAG TO BE LOADED. 
*                        (B7) = REGISTER NUMBER. IF 0 - ANY REGISTER. 
  
 EIS.LNU  SPACE  4,8
**        EIS.LNU - SAME AS EIS.L BUT DOES NOT RESET USE COUNT OF 
*         TAG BEING LOADED. 
  
  
 EIS.LNU  =X6    0
          SA6    UUC
 EIS.L    SA5    X3+B4       TAG TO BE LOADED 
          =X6    0           UPPER HALF 
  
 EIS.L2   SA6    TYPLOD 
          SX0    RLOCK
          SB6    X6 
          BX5    -X0*X5 
          LX6    P.TYPE 
          BX5    X5+X6
          DRITE  DEACTIVATE 
          BX1    X5 
          SB2    B6 
          =B7    1           FULL STATUS
          BX0    X5 
          IFBIT  X1,-INTR,EIS.L5  IF NOT INTERMEDIATE 
          IFBIT  X0,-2ARY,EIS.L5 IF NOT ARY-LOD 
          DRITE  DEACTIVATE 
          SB2    B6 
          RJ     SLD         PROCESS SUBSCRIPT LOAD 
          EQ     EIS.L22
  
 EIS.L5   SB3    RG=LOAD
          RJ     GST         GET STATUS OF TAG
          SA2    =XGSTC 
          LX3    X7 
          BX7    X2          SAVE LOCATION OF TAG STATUS WORD 
          SA7    EISLA
          SB6    "BLOWUP"    **** DEBUG ****
          BX7    X3 
          MX0    L.2TAG+L.2BIAS+L.2FPNO 
          SA3    TYPLOD 
          BX2    X5 
          BX1    X0*X1
          LX3    P.2BIAS
          IFBIT  X2,SHORT,EIS.L10 IF SHORT CONSTANT 
          IX1    X1+X3
          IFBIT  X2,2EQUIV/SHORT,EIS.L7 
          NZ     B2,EIS.L12   IF TAG IN REGISTER
 EIS.L7   RJ     LTG         LOAD TAG 
          EQ     EIS.L15
  
 EIS.L10  SB3    RG=LODX
          NZ     B2,EIS.L12  IF TAG IN REGISTER 
          RJ     LSC         LOAD SHORT CONSTANT
          EQ     EIS.L15
  
 EIS.L12  ZR     B7,EIS.L15  IF TAG IN CORRECT REGISTER 
          SA7    EIS.INST    SAVE INSTRUNCION 
          AX6    3
          =A6    A7+EIS.JREG-EIS.INST  SAVE *J* REGISTER
          RJ     GNR         GET REGISTER 
          SA2    EIS.JREG 
          BX3    X6 
          =A1    A2-EIS.JREG+EIS.INST 
          IX0    X6+X2       =0IJ 
          SB5    B2 
          IX7    X1+X0       OP-CODE + IJ 
          LX7    P.LI15+3 
          WCODE  X7 
          SA1    =XSTRGLK 
          MI     X1,EIS.L13  IF NO ASSIGNMENT TO CLEAR
          SA1    X1+REGFILE 
          SX0    RLOCK
          BX6    -X0*X1      UNLOCK STORE REGISTER
          SA6    A1 
 EIS.L13  BX6    X3 
          SB2    B5 
  
*         INDICATE TAG IN REGISTER IN REGISTER. 
*         UPDATE USE COUNT ON TAG AND PUT IN RGFILE.
*         (B2) = REGISTER (0TR) 
*         (X5) = TAG (FROM PARSED FILE) 
*         (X6) = REGISTER (0R0) 
*                (EISLA) = LOCATION OF TAG STATUS WORD
  
 EIS.L15  SA3    UUC
          SX7    B0 
          BX6    X3 
          SA7    A3          SET USE COUNT TO ZERO
          SA6    EIS.LUC     SAVE USE COUNT 
          SA3    TYPLOD 
          SA1    EISLA
          SB7    X1          ORDINAL IN TABLE OF STATUS WORD
          AX1    18 
          SA2    X1          FETCH ORIGIN OF TABLE
          SA1    X2+B7
          SB3    X3 
          RJ     SST         SET STATUS OF TAG
          SX7    B2 
          SA7    EIS.LJ      SAVE OTR OF REG TAG IS IN
          =X3    MAX.USEC 
          MX0    -L.RUSE
          SX1    -B2
          SB7    X1+R.X6
          LT     B0,B7,EIS.L21 IF NOT STORE REGISTER
          SA2    B7+REGFILE+R.X7 LOAD OTHER STORE REG.
          BX1    -X0*X2      USE COUNT ON STORE REG.
          BX2    X3-X1
          NZ     X2,EIS.L21  IF STORE REG NOT TEMPORARY 
          SB3    RG=TEMP
          RJ     SFR
          SX6    B2         OTR ASSIGNED BY SFR 
          SA6    EIS.LX 
          NZ     X7,EIS.L19  IF TEMPORARY REG NOT AVAILABLE 
          SA1    IJK
          SA2    EIS.LJ     REG HOLDING OPD 
          SB2    X2 
          ZR     X1,EIS.L21  IF PROCESSING J PART 
          EQ     EIS.L20     XMIT 
  
 EIS.L19  SB3    RG=LODX
          RJ     GNR
          SX7    B2 
          SA7    EIS.LX      SAVE REG ASSIGNED
          SA3    TYPLOD      STATUS - 0=UPPER,1=LOWER 
          SB2    X3 
          SB3    RG=STOR
          SB7    B0          STATUS OF TAG ONLY 
          RJ     GST
          SA2    =XGSTC 
          BX6    X2 
          SA6    EISLA       SAVE LOCATION OF STATUS
          NZ     B2,EIS.L20  IF TAG IN REG - XMIT 
          SA2    EISLA       LOCATION OF TAG STATUS WORD ADDRESS
          SB7    X2          ORDINAL IN TABLE OF STATUS WORD
          AX2    18 
          SA2    X2          FETCH TABLE ORIGIN 
          SA1    X2+B7
          MX0    L.2TAG+L.2BIAS+L.2FPNO 
          SA3    TYPLOD      STATUS - 0=UPPER , 1=LOWER 
          BX1    X0*X1
          LX3    P.2BIAS
          IX1    X1+X3       ADD BIAS 
          SA3    EIS.LX 
          SB2    X3          ASSIGNED REG 
          MX0    -3 
          BX6    -X0*X3 
          LX6    3           ORO
          RJ     =XCLI
          EQ     EIS.L21
  
 EIS.L20  SA2    EIS.LX      OTR OF REG TO TRANSMIT TO
          SB2    X2 
          MX0    -3 
          BX2    -X0*X2      (00R) *I* REGISTER 
          SA3    EIS.LJ 
          SX6    0
          SB5    X3            OTR OF REG TRANSMITTING FROM 
          BX7    -X0*X3        (00R) *J* REGISTER 
          SA1    B5+REGFILE        *X* REGFILE ENTRY
          SA3    B5+REGFILE-REG.A  *A* REGFILE ENTRY
          BX1    X3-X1
          AX1    L.RUSE 
          NZ     X1,EIS.LA      IF TAGS NOT EQUAL CLEAR X REG ONLY
          SA6    A3             CLEAR OLD *A* REGFILE ENTRY 
 EIS.LA   SA6    A1             CLEAR OLD *X* REGFILE ENTRY 
          LX2    3
          IX7    X7+X2
          SX7    X7+XMITS3
          LX7    P.LI15+3 
          SB5    B2 
          WCODE  X7          XMIT 
          SB2    B5            OTR OF REG HOLDING OPD.
 EIS.L21  SA1    EIS.LUC
          BX7    X1 
          SA3    TYPLOD 
          SA7    UUC         RESTORE USE COUNT
          SA1    EISLA       LOCATION OF TAG STATUS WORD ADDRESS
          SB7    X1          ORDINAL IN TABLE OF STATUS WORD
          AX1    18 
          SA2    X1          FETCH TABLE ORIGIN 
          SA1    X2+B7
          SB3    X3 
          RJ     SST         SET STATUS OF TAG
          MX0    -3 
          SX1    B2 
          BX6    -X0*X1 
          LX6    3           ORO
 EIS.L22  SA1    HREG 
          ZR     X1,EIS.LRF  IF HARD REGISTER TO REMAIN UN-LOCKED 
          BX2    X6 
          MX7    0
          LX2    -3 
          SA7    A1          CLEAR HREG 
          SB7    X2 
          RJ     RLL         LOCK REGISTER
          EQ     EIS.LRF
  
  
 EISLA    CON    "BLOWUP"    LOCATION OF TAG STATUS WORD
 EIS.LUC  DATA   0           SAVED USE COUNT OF TAG 
 EIS.LJ   DATA   0           OTR OF REG TAG IS IN 
 EIS.LX   DATA   0           REG ASSIGNED AFTER GNR CALL
 RESULT   EJECT  4,8
**        SET INTERMEDIATE RESULT REGISTER. 
*             ENTRY  B4 - START OF INSTRUCTION GROUP (TURPLE) 
*             EXIT   (X6) REGISTER NUMBER - 0R0.
*             USES   A1,A2,A3  X0  B2,B7
*             CALLS  CDS
  
  
 EIS.IRL  =A5    B4+OR.1OP   RIGHT MEMBER 
          =B6    1           RESULTS OF LOWER HALF
          EQ     EIS.IR1
  
**        SCAN INTERMEDIATE REGISTERS - *X7,X6,X0*
  
 EIS.IR   SA2    B4 
          SB6    B0          RESULTS OF UPPER HALF
          =A5    B4+OR.1OP   RIGHT MEMBER 
  
 EIS.IR1  =A2    B4+OR.OPR
          BX6    X6-X6
          SB7    X2-O.= 
          SA6    UUC
          NZ     B7,EIS.IR9  IF NOT PROCESSING *STORE* TURPLE 
          SB2    B6          TAG TYPE 
          =B7    0           STATUS OF TAG ONLY 
          RJ     GST         GET STATUS OF RIGHT MEMBER 
          SX0    B2-R.X6+RGFILE 
          PL     X0,EIS.IR2  IF IN *STORE* REGISTER 
          RJ     ASR         ASSIGN STORE REGISTER
          SX7    -XMIT
          SA7    RREG        INDICATE LOAD NOT SATISFIED
  
  
*         CHECK LEFT MEMBER FOR VARIABLE TYPE 
  
 EIS.IR2  SA5    B4+OR.2OP        LEFT MEMBER 
          =X0    RLOCK
          BX2    X5 
          BX5    -X0*X5 
          IFBIT  X2,-INTR,EIS.IR5 
  
*         LEFT MEMBER IS A *SUBSCRIPTED ARRAY INVOLVING ADDRESS FUNCTION
  
          SA1    RREG 
          SX6    B2 
          SB7    X1+XMIT
          SA6    A1          SET HARD REGISTER
          NZ     B7,EIS.IR3  IF LOAD SATISFIED
          SA3    INS.REG
          MX0    -3 
          BX2    -X1
          BX1    -X0*X6      =00I 
          IX7    X3+X2
          LX1    6
          IX7    X7+X1
          LX7    P.LI15 
          WCODE  X7 
 EIS.IR3  SB2    B6 
          =X7    1
          SA7    UUC
          RJ     SLD
          EQ     EIS.REG
  
*         SET DELAYED STORE IN MOTION 
  
 EIS.IR5  SB3    B2 
          SB2    B6 
          RJ     SDS          SET DELAYED STORE 
          EQ     EIS.REG
  
*         CHECK IF PROCESSING *STORE* TURPLE. 
  
 EIS.IR9  SA2    B4+L.TURP
          SB7    X2-O.= 
          NZ     B7,EIS.IR10 IF RESULTS NOT INPUT IN *STORE*E 
          RJ     ASR         FIND AVAILABLE STORE REGISTER
          EQ     EIS.IR30    CONTINUE 
  
*         IF INTERMEDIATE NOT INPUT INTO *STORE* TURPLE 
  
 EIS.IR10 RJ     AIR         ASSIGN INTERMEDIATE REGISTER 
          PL     B2,EIS.IR20 IF REGISTER AVAILABLE
          RJ     ASR         USE STORE REGISTER 
          EQ     EIS.IR30 
  
 EIS.IR20 ZR     X7,EIS.IR30 IF REGISTER FREE 
          RJ     RUT
  
**        (B2) = 0TR. FOR RESULTS.
  
 EIS.IR30 =X5    0
          SB3    B6          INTERMEDIATE TYPE (UPPER/LOWER)
          RJ     DIT         DEFINE INTERMEDIATE
          EQ     EIS.REG
 REGPRO   EJECT  4,8
**        REGPRO - HELP ME DETERMINE IF REGISTERS ARE BEING ASSIGNED
*         CORRECTLY.
* 
*         ENTRY  (B2) = REGISTER BEING CLOBBERED, RESET ETC.
*                (X6) = CALLER NAME IN 3R FORMAT. 
* 
*         EXIT   MESSAGE PRINTED. 
* 
*         DESTROYS *A1,X1, X6*
  
 SNAP=H   IFNE   TEST        IF IN TEST MODE
  
 REGPRO   SUBR   0
  
          ENTRY  REGPRO 
  
          SA1    CO.SNAP
          LX1    1RH
          PL     X1,REGPROX  IF NOT REQUESTED.
          SA1    =7L
          BX6    X1+X6
          SA6    REGLNN      CALLER NAME. 
 REGFILE  CORE   REGB,L.RGFILE
          RJ     =XSVR
          SA1    =XSVB+4
          SA2    TT.PAR 
          SX0    X1 
          IX1    X0-X2
          RJ     =XCOD       CONVERT TO DPC 
          SA6    REGLNO 
          SA1    =XSVB+2
          SX1    X1 
          RJ     =XCOD       CONVERT TO DPC 
          SA6    REGLNW 
          SA1    RGC
          RJ     =XCOD
          SA6    REGRGC 
          SA1    RGX
          RJ     =XCOD
          SA6    REGRGX 
          PLINE  REGLN       PRINT CONTENTS OF RGC, RGX 
          RJ     =XRSR
          EQ     REGPRO      CONTINUE 
  
 REGLN    DATA   30H REGISTER REASSIGNMENT -HELP- 
 REGLNO   DATA   10H
 REGLNW   DATA   10H
 REGLNN   DATA   0
          DATA   10H  RGC = 
 REGRGC   DATA   0
          DATA   10H  RGX = 
 REGRGX   DATA   0
 REGLNE   DATA   0
  
 SNAP=H   ENDIF 
 EIS.MC   SPACE  4,8
 EIS.K    EJECT  4,8
**        SET CONSTANT FOR CURRENT INSTRUCTION. 
  
 EIS.K    SX6    X3          6 BIT TYPE CONSTANT. 
          SB7    X3-10B 
          =B2    -1          INDICATE NOT A REGISTER (FOR EIS.LRF)
          PL     B7,EIS.LRF  IF IN CORRECT FIELD
          LX6    3
          EQ     EIS.LRF
  
 EIS.Q    SA2    A4          RELOAD 
          MX0    -L.IQF 
          BX3    -X0*X2      LOWER 12 BITS
          MX1    -L.INUM
          LX2    -L.IQF-L.IOAD
          BX1    -X1*X2 
          LX1    L.IQF
          IX6    X1+X3       18 - BIT *Q* FIELD 
          LX6    60-18+6     SHIFT TO Q POSITION
          EQ     EIS.REG
 EIS.CNL  EJECT  4,8
*         8.  SET ITH PORTION OF INSTRUCTION TO CONTENTS OF PARSE FILE. 
*             WILL HANDLE EITHER A TAG OR CONSTANT THAT IS RIGHT
*             JUSTIFIED WITHIN THE APPROPRIATE FIELD. 
* 
*             THREE DEFINED PROCESSORS ARE -- 
*             CNU = ELEMENT IN UPPER  L.2TAG BITS OF WORD.
*             CNM = ELEMENT IN MIDDLE L.2TAG BITS OF WORD.
*             CNL = ELEMENT IN LOWER  L.2TAG BITS OF WORD.
  
  
 EIS.CNU  SB2    P.PTAGU     ELEMENT IN UPPER L.2TAG BITS 
          EQ     EIS.CNX
 EIS.CNM  SB2    P.PTAGM     ELEMENT IN MIDDLE L.2TAG BITS
          EQ     EIS.CNX
 EIS.CNL  SB2    P.PTAGL     ELEMENT IN LOWER L.2TAG BITS 
  
**        SET ELEMENT INTO (X6) READY FOR ADD IN TO INSTRUCTION BUILD 
*         WORD
* 
*         (B2) = RELATIVE SHIFT COUNT 
*         (X3) = RELATIVE WORD IN PARSED FILE TO USE. 
  
 EIS.CNX  SA1    X3+B4       LOAD PARSED FILE WORD
          MX0    -L.2TAG
          AX2    B2,X1       SHIFT TO LOW ORDER OF WORD 
          SA5    OPTYP
          BX6    -X0*X2      EXTRACT FIELD
          SB7    X5-M.SHIF
          ZR     B7,EIS.REG  IF NOT PROCESSING ADDRESS (K)
          LX6    60-18+3+3   SHIFT TO APPROPIATE BIT FOR INSTRUCTION
          EQ     EIS.REG
 EIS.LRF  SPACE  4,20 
**        LOCK REGISTER FILE FOR REGISTER USED IN CURRENT INSTRUCTION 
* 
*         ENTRY  (B2) = 0TR 
*                (X6) = 0R0, AS ABOVE.
* 
*         EXIT   LOCK BIT SET IN *RGFILE* IF ASSIGNMENT IS FOR *K* PART 
*                OF INSTRUCTION.
*                CLEAR LOCK BIT ON *K* IF PROCESSING *J*
  
  
 EIS.LRF  SA2    IJK
          SA1    REGLK
          MX7    -1 
          PL     X2,EIS.LRF5 IF NOT PROCESSING *K*
          MI     B2,EIS.REG  IF A CONSTANT (NOT A REGISTER) 
          SX5    B2 
          MX1    -3 
          BX2    -X1*X5      GET REGISTER -00R
          SB7    X2 
          RJ     RLL         LOCK REGISTER
          SA7    REGLK       SAVE REGISTER  -00R. 
          =A7    A7+1 
          EQ     EIS.REG     CONTINUE 
  
 EIS.LRF5 SA7    A1          CLEAR *REGLK*
          NZ     X2,EIS.REG  IF NOT PROCESSING *J*
          SA7    CLOADJ 
          SB7    X1 
          RJ     RUL         UNLOCK REGISTER
          EQ     EIS.REG     CONTINUE 
 REG      EJECT  4,8
**        9.  SET REGISTER IN TO BUILD REGISTER,(X5), AND CONTINUE
*             TO NEXT.
*             ENTRY  (X6) = REGISTER - 0R0
* 
*             EXIT   (X1) REGISTER SHIFTED APPROPRIATELY. 
*                    (X4) SHIFTED BY -L.INUM
*                    (B6) UPDATED BY 3. 
*                    INS.REG =  REGISTER ADDED IN PROPER POSITION.
  
  
 EIS.REG  SA3    IJK
          SA1    INS.REG
          SB6    X3 
          PL     X3,EIS.RG5  IF POSITIVE SHIFT
          SB6    B6+60       NO DROPPING THE BITS.. 
 EIS.RG5  LX2    B6,X6
          BX6    X1+X2
          LX4    -L.INUM
          SX7    X3+3 
          SA6    A1          UPDATE ASSIGNED
          SA7    A3          UPDATE *IJK* 
          EQ     EIS.NX      CONTINUE FOR NEXT PORTION OF INSTRUCTION.
  
 INS.REG  DATA   0           IJK PARTS OF INSTRUCTION 
 OPCODE   DATA   0           OPCODE 
 IJK      DATA   0           = 3 PROCESSING *I* PART
                             = 0    -       *J*  -
                             =-3    -       *K*  -
 OPTYP    DATA   0           M.XXX FOR OP-CODE FIELD OF SKELETON
  
 TYPLOD   DATA   0           TYPE OF LOAD 
  
  
 EIS.INST DATA   0           INSTRUNCION TO PUT TAG IN CORRECT REGISTER 
 EIS.JREG DATA   0           *J* REGISTER FOR ABOVE 
 HREG     BSSZ   1           LOCK HARD REGISTER FLAG
 O=XXX    EJECT  4,20 
**        O=XXX - THIS SECTION CONTAINS SPECIAL PROCESSING ROUTINES 
*                 USED FOR EXPANSION OF SKELETONS.
 O=CDW    SPACE  4,8
**        O=CDW - CHECK *DRITE* FLAG, AND PROCESS IF SET. 
* 
*         ENTRY  (B4) _ CURRENT *TURPLE* BEING PROCESSED. 
* 
*         EXIT   *DRITE* CLEARED. 
*                (B4) _ AS ENTRY - L.TURP, EXIT TO EIS.PNX TO CONTINUE
*                       PROCESSING OF ORGINAL *TURPLE*
* 
*         CALLS  CDS
  
  
 O=CDW    SB6    A4          SAVE SKELETON ADDRESS
          DRITE  DEACTIVATE 
 O=CDWX   SA3    B6          RELOAD SKELETON WORD 
          SBIT   X3,IEND
          EQ     NULLOP      CONTINUE WITH EXPANSION
 O=CAR    SPACE  4,8
**        O=CAR - CLEAR ALL REGISTER ASSOCIATES.
* 
*         ENTRY  (B4) _ CURRENT *TURPLE* BEING PROCESSED. 
* 
*         EXIT   *DRITE* CLEARED. 
*                ALL REGISTER ASSOCIATES CLEARED. 
*                (B4) _ AS ENTRY - L.TURP, EXIT TO EIS.PNX TO CONTINUE
*                       PROCESSING OF ORGINAL *TURPLE*
* 
*         CALLS  CAR. 
  
  
 O=CAR    SB6    A4          SAVE SKELETON ADDRESS
          RJ     CIA         CLEAR REGISTER FILE
          EQ     O=CDWX 
 O=EPO    SPACE  4,15 
**        O=EPO -  EXTERNAL PROCESSOR SET-UP
* 
*         ENTRY  (B4) _ PARSED FILE ENTRY 
* 
  
  
 O=EPO    =A1    B4+OR.2OP
          =B4    B4+L.TURP
          BX7    X1 
          AX7    P.TRC       42/0,18/TRACEBACK LINE NUMBER
          SA7    =XTRACE     SAVE FOR USE BY *FUN*
          EQ     EIS.PNX     CONTINUE 
 O=OTR    SPACE  4,8
**        O=OTR - OBJECT TIME REPRIEVE CODE 
* 
*         ENTRY  (B4) _ PARSE FILE ENTRY
* 
  
 O=OTR    =A1    B4+OR.2OP
 #FID     IFNE   .FID,0 
          SA5    =XCO.ID
          PL     X5,O=OTR20  IF FID CODE NOT REQUIRED 
  
          SA2    TT.PAR 
          SX6    B4 
          SA5    ALC.00 
          IX6    X6-X2       GET INDEX INTO PARSE TABLE 
          BX7    X5 
          SA6    O=OTRB      SAVE INDEX 
          SA7    ALC.REG     UNLOCK B4
          SA5    O=OTRA 
          LX6    X1 
          BX5    X1-X5
          SA6    A5          SET PREV LINE NUMBER TO OTR LINE NUMBER
          ZR     X5,O=OTR30  IF SAME LINE AS PREVIOUS, IGNORE THE OTR 
  
          =X6    1
          SA6    =XCIAA      SET LOCK CLEAR FLAG
          RJ     =XCIA       CLEAR REGISTER ASSOCIATES
          BX6    0
          SA6    =XCIAA      CLEAR LOCK FLAG
          CBSS   1           FLUSH CODE FROM WINA 
          RJ     =XPIG       MAKE LINE NUMBER TABLE ENTRY 
          SA5    O=OTRB 
          SA1    TT.PAR 
          IX5    X5+X1       PARSE TABLE ADDRESS
          SA1    X5+OR.2OP   RESTORE A1 AND X1
          BX6    X1          RESTORE CURRENT LINE NUMBER
 O=OTR10  BSS 
          =A5    A1-OR.2OP+OR.1OP  GET LABEL FROM OTR TURPLE
          SX2    X5 
          NZ     X2,O=OTR20  IF NO LNT ENTRY REQUIRED 
  
          SA6    =XPIGLINE
          BX6    X5 
          SA6    =XPIGLAB 
 O=OTR20  BSS 
 #FID     ENDIF 
          =B4    B4+L.TURP
          BX6    X1 
          AX6    P.TRC
          SA6    =XTRACE     SAVE FOR USE BY *FUN*
          LX6    P.LBIAS
          BX5    X6          PRESERVE LINE NUMBER 
          CBSS   1           FORCE UPPER
          SX1    SB=BKS3
          SX1    X1+2 
          BX7    X1 
          LX7    P.LI12 
          BX7    X5+X7
 #FID     IFEQ   .FID,0 
          WCODE  X7,EIS.PNX 
 #FID     ELSE
          WCODE  X7 
          SA1    =XCO.ID
          PL     X1,EIS.PNX  IF FID CODE NOT NECESSARY
  
          TAGSEX =XS.FID
          CRJ    NONE 
 O=OTR30  BSS 
          SA1    TT.PAR 
          SA5    O=OTRB      PARSE TABLE INDEX
          SA2    ALC.CAI
          IX5    X1+X5       PARSE TABLE ADDRESS
          BX6    X2 
          =B4    X5+L.TURP   ADDRESS OF NEXT TURPLE 
          SA6    ALC.REG     RELOCK B4
          EQ     EIS.PNX
  
  
          ENTRY  O=OTRA 
 O=OTRA   DATA   0           LINE NUMBER OF PREVIOUS OTR
 O=OTRB   BSS    1           PARSE TABLE INDEX SAVED HERE 
 #FID     ENDIF 
 CBSS     SPACE  4,8
**        CBSS - DEFINE LABEL.
* 
*         ENTRY  (X1) = LABEL TO DEFINE.
*                (X4) = SKELETON WORD 
* 
*         EXIT   TO *CBREAK*
*                (X3) = SKELETON SHIFTED BY P.IEND
*                (X7) = INSTRUCTION FORMATTED FOR LONG FILE 
*         IF LABEL IS INACTIVE STATEMENT NUMBER, WILL EXIT TO *NULLOP*
*                WITHOUT COMPILING ANYTHING.
* 
*         USES   CANNOT DESTROY  A0,A4  B4
  
  
 CBSS     BSS    0           ENTRY... 
          SB7    X1-C.STAT
          SA2    TS.STN 
          BX3    X4 
          SB2    X1-C.STAT-C.DIF
          SBIT   X3,IEND
          MI     B7,CBSS3    IF NOT A STATEMENT LABEL 
          PL     B2,CBSS3    IF NOT A STATEMENT LABEL 
          SA2    X2+B7
          SBIT   X2,SNINA 
          MI     X2,NULLOP   IF INACTIVE STATEMENT LABEL, EXIT..
  
 CBSS3    CBSS   X1,,X7 
          EQ     CBREAK      EXIT.. 
 CBJ      SPACE  4,10 
**        CBJ -  COMPILE *B* JUMP.
* 
*         ENTRY  (A4,X4) = SKELETON WORD
* 
*         EXIT   TO EIS.CMP 
*                (X7) = INSTRUCTION TO COMPILE
*                (X3) = SKELETON SHIFTED BY P.IEND
  
  
 CBJ      BSS    0           ENTRY... 
          SX1    R.B6-RGFILE ** B6 ONLY **
          =X2    I.JP 
          BX3    X4 
          LX2    P.LI12 
          BX7    X1+X2
          SBIT   X3,IEND
          EQ     CBREAK      RETURN TO COMPILE INSTRUCTION
 O=RNF    SPACE  4,8
**        O=RNF - RESET RANDOM. 
*                 RESETS RANDOM. TO THE UNNORMALIZED PRODUCT OF THE 
*                 LAST VALUE OF RANDOM. * KERNEL
  
 O=RNF    BSS    0
          SB3    =XRG=STOR
          LX5    X1          PRESERVE RANDOM. SYMTAB ORDINAL
          RJ     GNR         GET A STORE REGISTER 
          MX0    -3          FOR STATUS 
          SX1    B2 
          BX1    -X0*X1 
          SB6    X1 
  
*         (B6) = STORE REGISTER TO USE
  
          SA1    REG=T       *T1* 
          BX1    -X0*X1      *T1* REGISTER
          SX2    X1-6 
          PL     X2,RNF1     IF NO TRANSMIT (*T1* IN STORE REGISTER)
          SB3    3
          SX3    XMIT 
          LX2    X1,B3
          BX2    X1+X2
          SX1    B6 
          BX3    X2+X3
          LX1    6
          BX7    X1+X3
          LX7    P.LI15 
          WCODE  X7          OUTPUT TRANSMIT
          MX0    -3          RESTORE STATUS MASK
          SX1    B6          RESTORE STORE REGISTER 
  
*         (X1) = STORE REGISTER 
  
 RNF1     LX5    L.TAG
          SX5    X5-C.SYM 
          SA2    TS.SYM 
          IX2    X2+X5
          SX5    22000B      TRANSMIT INSTRUCTION TO RESET RANDOM.
          SA3    X2 
          BX3    -X0*X3      RANDOM. REGISTER 
          BX5    X5+X1
          LX3    3
          SX2    X3+SA=AB 
          LX1    6
          BX7    X1+X2
          LX7    P.LI15 
          LX3    3
          BX5    X3+X5
          WCODE  X7          OUTPUT STORE 
          LX5    P.LI15 
          BX7    X5 
          WCODE  X7          OUTPUT TRANSMIT
          EQ     NULLOP      CONTINUE PROCESSING SKELETON.. 
  
          LIST   D
          END 
