*DECK     CONRED - FRONT END CONSTANT ARITHMETIC. 
          IDENT  CONRED 
 CONRED   SECT   (FRONT END CONSTANT ARITHMETIC.) 
 CONRED   SPACE  4
***              CONRED PERFORMS COMPILE TIME ARITHMETIC FOR THE
*         FRONT END.  UNLIKE MOST OF THE REST OF PASS 1, CONRED 
*         KNOWS THE TARGET MACHINE FAIRLY INTIMATELY.  THUS, IT 
*         MUST BE THROUGHLY RE-WORKED IN ORDER TO ADAPT THIS COMPILER 
*         TO A COMPUTER OTHER THAN CYBER 70/170.
  
  
*         IN ALLOC
          EXT    ADW,ALC
  
*         IN DATA 
          EXT    DATAFLG,DAT.Z,EDI,KW=DATA
  
*         IN FEC
          EXT    NCM,SCT,CT1
  
*         IN FERRS
          EXT    E.AT16,E.DC,E.DC3,E.DC6,E.DC8,E.DC9,E.DVR1,E.DVR2
          EXT    E.DC1
          EXT    E.DVR3,E.DVR4,FILL.,E.DVL1,E.DAUC,E.DABC,E.DABL,E.DSE
          EXT    E.ANS6 
  
*         IN LABEL
          EXT    PSL
  
*         IN LEX
          EXT    TB=TYPE
*         IN PAR
          EXT    EXT,PARNOW,SMOD,DOA
  
*         IN PEM
          EXT    PDM
  
*         IN PUC
          EXT    ECB,ECS,PIK=PS,S=CON,T=CON,T=DAR,T=DVV,T=PAR,T.CON 
          EXT    T.DAR,T.DIM,T.DVV,T.PAR,T.SYM,BLNKCOM,MOD
  
*         IN QSKEL/FSKEL
          EXT    F.SKEL,F.SCT,V=COLON,V=SUBST 
  
*         IN UTILITY
          EXT    MNS=,MVE=
  
  
 PCCA     BSS    3           TEMPS FOR *PCC*
 PCCB     EQU    PCCA+1 
 PCCC     EQU    PCCA+2 
 PCCD     BSS    3           TEMPS FOR *PCC* TO SAVE (B4)-(B6)
 CCRA     EQU    PCCA        ADDRESS OF CONSTANT REDUCER FOR *CCR*
*CALL SKPSET
*CALL SKPCONQ 
*CALL COMSEIS 
 LVEC     BSSENT 2           OPERAND VALUES, UPPER
 LLVEC    BSSENT 2           OPERAND VALUES, LOWER
 RVEC     BSSENT 1           RESULT, UPPER
 RLVEC    BSSENT 1           RESULT, LOWER
  
 REG=T    BSSENT 0           FOR QCG (USES SAME VECTOR) 
 TVEC     BSS    SKU.TMP     TEMP OPERAND VALUES
 FIELD    BSSZ   3           POINTERS TO I,J,K OPERANDS 
 CTAA     BSSENT 2           SAVE (1OP,2OP) 
 PIK      BSS    1           (PIK=PS+OPCODE)
 OPCODE   BSS    1
 INST=23  VFD    15/00123B   NOMINAL INSTRUCTION (BX1 X2+X3)
 INST=22  VFD    15/00122B
 INST=00  VFD    15/00100B   JKVAL INSTRUCTION (LX1 59) 
 INST=03  VFD    15/00103B   J=B0 INSTRUCTION (NX1 X2)
 INST=73  VFD    15/00173B   J=B7 INSTRUCTION (UX1 B7,X3) 
 INST=32  VFD    15/00132B   KJ INSTRUCTION (BX1 -X2*X3)
 INST=SB  VFD    15/00720B         SET B (SB7 X2+0) 
 IMPLIES  SPACE  4,10 
**        IMPLIES -          CREATE IMPLICATION BIT MASK MICRO. 
* 
*         RELOP  IMPLIES     (RELOP1,RELOP2,...,RELOPN) 
* 
*         INTENDED TO BE USED BY *PCR*, THIS MACRO WILL 
*         CREATE A MICRO NAMED *RELOP* WHICH CONSISTS OF
*         20 OCTAL DIGITS, HAVING A ONE-BIT IN BIT POSITIONS
*         RELOP1,RELOP2,...,RELOPN. 
* 
*         AN EXAMPLE OF THE INTENDED USAGE :  
* 
*         LT     IMPLIES     (O.LT,O.NE,O.LE) 
* 
*         THIS WOULD CREATE A MICRO *LT* HAVING ONE-BITS
*         IN BIT POSITIONS DEFINED BY *PAR* RELATIONAL OPERATORS
*         O.LT, O.NE, O.LE. 
  
          MACRO  IMPLIES,RELOP,RELOPS 
 ''Z      MICRO  1,60, 0000000000_0000000000_0000000000_0000000000_00000
,00000_0000000000 
  
          IRP    RELOPS 
          ERRMI  59-RELOPS
 ''TB     MICRO  61-RELOPS,,/"''Z"/ 
 ''LB     MICRO 
          IFNE   59-RELOPS,,1 
 ''LB     MICRO  1,59-RELOPS, "''Z" 
 ''Z      MICRO  1,60, "''LB"1"''TB"
          IRP 
  
*         CONVERT BINARY TO OCTAL.
  
 RELOP    MICRO 
 ''N      SET 
 .1       DUP    60D/3
 ''N      SET    1+''N
 ''B1     MICRO  3*''N-2,1, "''Z" 
 ''B2     MICRO  3*''N-1,1, "''Z" 
 ''B3     MICRO  3*''N-0,1, "''Z" 
 ''B3     OCTMIC "''B1"*4+"''B2"*2+"''B3",1 
 RELOP    MICRO  1,, "RELOP""''B3"
 .1       ENDD
  
 RELOP    MICRO  1,, "RELOP"B 
 IMPLIES  ENDM
          TITLE  FRONT END NUMERIC CONVERSION ROUTINES. 
 DEC      SPACE  4,20 
**        DEC - CONVERT DECIMAL CONSTANT TO INTERNAL BINARY.
* 
*         ENTRY  (B4) -> FIRST TOKEN OF CONSTANT. 
* 
*                (DATAFLG) = MI IF *DATA* CALLING.
*                          = PL OTHERWISE.
* 
*         EXIT   (B4) -> LAST TOKEN OF CONSTANT.
*                (X1) = MODE OF CONSTANT. 
*                (X2) = 0, OR LOWER HALF OF DOUBLE CONSTANT.
*                (X6) = UPPER OR ONLY HALF OF CONSTANT. 
* 
*         USES   A1-5  B2,7   X0-3,6-7. 
*                (X4,X5 ARE NOT DESTROYED)
*         NOTE
*         NO-ONE SHOULD ATTEMPT TO CHANGE THE ALGORITHM OR FOR THAT 
*         MATTER ANY CODE WITHIN THIS ROUTINE WITHOUT FIRST CHECKING
*         ROUTINES --- KODER,KRAKER,RUN2.3,FTN,COMPASS AND
*         ANY OTHER COMPILER/ASSEMBLER THAT TRANSLATES CONSTANTS INTO 
*         BINARY FORM.
  
  
          ERRNZ  TB.TOTP     ENDEMIC ASSUMPTIONS
          ERRNZ  18-TB.TOTL 
          ERRNZ  TB.TOCL+TB.TOCP-60 
  
**        RESTORE REGISTERS AND EXIT. 
*                (X7) = LOWER HALF OF WORD (IF DOUBLE)
*                (X6) = UPPER HALF
*                (X1) = MODE
  
 DEC60    SA1    DECA        HERE IF EVERYTHING OK
          SA2    A1+B1
          SA0    X1          RESTORE *A0* 
          SB3    X2          RESTORE *B3* 
          SA4    A2+B1       RESTORE *X4* 
          SA5    A4+B1       RESTORE *X5* 
          SA1    A5+B1
          BX2    X7          LOWER PART OF RESULTS
          SA3    A1+B1
          LX7    X1          RESTORE *X7* 
          SX1    B6          MODE 
          SB6    X3          RESTORE *B6* 
          SA3    A3+B1
          SB5    X3          RESTORE *B5* 
          SB4    B4-B1       RESET TO LAST PART OF CONSTANT.
  
 DEC      SUBR   =           ENTRY/EXIT...
          SA1    B4 
          =A2    B4+1 
          =B7    X1-O.CONS
          ZR     B7,DEC7     IF LEADING DIGIT 
          =B7    X1-O.PERIOD
          NZ     B7,DEC3     IF 1ST NOT *.* 
          =B2    X2-O.CONS
          ZR     B2,DEC7     IF NUMBER FOLLOWS PERIOD 
 DEC3     =B4    B4+1        ADVANCE TO NEXT TOKEN
          EQ     DECEX1      ERROR
  
 *        HERE IF GOOD BEGINNING. 
  
 DEC7     SX6    A0 
          SA6    DECA        SAVE *A0*
          SX6    B3 
          SA6    A6+B1       SAVE *B3*
          BX6    X4 
          SA6    A6+B1       SAVE *X4*
          BX6    X5 
          SA6    A6+B1       SAVE *X5*
          BX6    X7 
          SA6    A6+B1       SAVE *X7*
          SX6    B6 
          SA6    A6+B1       SAVE *B6*
          SX6    B5 
          SA6    A6+B1       SAVE *B5*
          SB5    B0          CLEAR B5 
  
*         PROCESS DECIMAL CONSTANT. 
  
          BX2    0           CLEAR
          MX0    CHAR 
          =B6    M.INT
          SX3    0
          MX7    -CHAR
          =B3    1           CLEAR OVERFLOW COUNT (TO 1)
  
*         GET NEXT ELEMENT TO PROCESS FOR NUMBER. 
  
 DEC11    SA4    B4+         LOAD NEXT WORD 
          =B7    X4-O.PERIOD
          SB2    X4-O.CONS
          ZR     X4,DEC40    IF *EOS* 
          ERRNZ  O.EOS
          EQ     B7,B1,DEC16 IF ALPHA 
          ERRNZ  O.PERIOD+1-O.VAR 
          ZR     B2,DEC16    IF NUMERIC 
          NZ     B7,DEC40    IF NO DECIMAL POINT
          MI     B6,DECEX1   IF PREVIOUS DECIMAL POINT - ERROR
          =B6    -1          INDICATE IN FRACTION PART
          =B4    B4+1 
          EQ     DEC11       LOOP 
  
*         BUILD INTEGER NUMBER IN (X3). 
  
 DEC13    IX6    X6+X5       2*LOW PART + DIGIT 
          PL     B6,DEC14    IF NOT IN FRACTIONAL FIELD 
          =B6    B6-1 
 DEC14    LX5    X3,B1       2*HIGH PART
          =B3    B3+1        INCREMENT OVERFLOW COUNT.
          NZ     X1,DEC16    IF OVERFLOW OF 108 BITS
          LX2    3           8*LOW PART 
          =B3    1           RESET OVERFLOW COUNT 
          IX6    X6+X2       10*LOW PART + DIGIT
          LX3    3           8*HIGH PART
          BX2    -X0*X6      CLEAR CARRY FROM LOW PART
          IX5    X3+X5       10*HIGH PART 
          AX6    54          POSITION CARRY 
          IX3    X5+X6       10*HIGH PART + CARRY 
 DEC16    LX4    CHAR        NEXT CHARACTER 
          BX5    -X7*X4 
          SB2    X5+         SAVE CURRENT ELEMENT 
          SX6    X5-1R0 
          LX5    X2,B1       2*LOW PART 
          BX1    X0*X3       PICK OFF ANY CARRY PAST 108 BITS 
          PL     X6,DEC13    IF DIGIT 
          NZ     B2,DEC19    IF NOT END OF WORD 
          =B4    B4+1 
          EQ     DEC11       LOOP 
  
 DEC19    ZR     X1,DEC20    IF NO OVERFLOW 
          SA5    DATAFLG
          MI     X5,DEC20    IF ERROR TO BE SUPPRESSED
          SB5    1           SET FLAG TO INDICATE ERROR PROCESSED 
          WARN   E.DC8
  
 DEC20    SA5    PARNOW 
          SX6    X5-PM=ICE
          ZR     X6,DEC41    IF PROCESSING INTEGER CONSTANT EXPR. 
          SX5    B2-1RE 
          ZR     X5,DEC21    IF *E* 
          =X6    X5+1 
          NZ     X6,DEC41    IF NOT *D* 
          =X5    1
 DEC21    MI     B6,DEC22    IF PREVIOUS DECIMAL POINT
          =B6    -1 
 DEC22    SB3    B6+B3       OVERFLOW - FRACTION DIGIT COUNT
          SA1    B4 
          SB6    X5          SET FLAG (D=1,E=0) 
          MX0    CHAR 
          LX1    CHAR 
          BX6    X0*X1
          MX5    0
          ZR     X6,DEC30    IF NO EMBEDDED EXPONENT
          =B4    B4+1 
          BX6    0
          SB2    E.DC3
          EQ     DEC26       PROCESS EXPONENT 
  
*         HERE IF EMBEDDED EXPONENT --
*         FORM   CONSTANT EXXX
*         OR     CONSTANT DXXX
  
 DEC24    SA1    B4 
          SB7    X1-O.CONS
          SB2    E.DC3
          BX6    0           CLEAR ASSEMBLY REGISTER. 
          ZR     X1,DECEX    IF *EOS* - ERROR 
          NZ     B7,DECEX    IF SEPARATOR - ERROR 
          =B4    B4+1 
  
*         BUILD INTEGER EXPONENT IN (X6). 
  
 DEC26    LX1    CHAR        NEXT DIGIT 
          BX4    -X7*X1 
          SB7    X4-1R9-1 
          ZR     X4,DEC50    IF END OF EXPONENT 
          SX4    B7+1R9-1R0+1 
          PL     B7,DECEX    IF NON-NUMERIC (DELIMITER) 
          MI     X4,DECEX    IF NON-NUMERIC (ALPHA) 
          LX0    X6,B1       2*EXPONENT 
          BX4    X4-X5       SIGN DIGIT 
          LX6    3           8*EXPONENT 
          IX0    X4+X0       2*EXPONENT+DIGIT 
          IX6    X6+X0       10*EXPONENT+ (OR -) DIGIT
          EQ     DEC26       LOOP 
  
*         HERE IF NO EMBEDDED EXPONENT. 
*                (X5) = SIGN OF EXPONENT
*         CHECK FOR FORMS --
*                CONSTANT E+XXX   CONSTANT D+XXX
*         OR     CONSTANT E-XXX   CONSTANT D-XXX
  
 DEC30    SA1    B4+B1       NEXT WORD
          SB4    B4+2 
          =B7    X1-O.PL
          ZR     B7,DEC24    IF *+* 
          =B7    B7-1 
          MX5    60          SET SIGN NEGATIVE
          ZR     B7,DEC24    IF *-* 
          =B4    B4-1 
          BX5    0           SET SIGN POSITIVE
  
*         HERE IF NO EXPONENT SPECIFIED.
*         SET NULL EXPONENT AND SEND *NOTE* ERROR TO OUTPUT.
  
          TRIV   E.DC6
          EQ     DEC52       CONTINUE.
  
 DEC40    ZR     X1,DEC41    IF NO OVERFLOW 
          SA5    DATAFLG
          MI     X5,DEC41    IF ERROR TO BE SUPPRESSED
          SB5    1           SET FLAG TO INDICATE ERROR PROCESSED 
          WARN   E.DC8
  
 DEC41    SB3    B6+B3       OVERFLOW-FRACTIONAL DIGIT COUNT
          MI     B6,DEC45    IF DECIMAL POINT IN NUMBER 
          LX3    54 
          IX6    X2+X3
          LX3    6
          AX3    5
          ZR     X3,DEC60    IF NO OVERFLOW OF 59 BITS
          EQ     DECEX1      ERROR
  
 DEC45    SB6    B0          SET FLAG (E=0) 
          EQ     DEC52
  
 DEC50    SB3    X6+B3       ADD EXPONENT TO SCALING
          AX6    9
          NZ     X6,DECEX1   IF EXPONENT .GT. 512 - ERROR 
  
*         FLOATING CONVERSION BY FSCALE.
*         MODIFY DOUBLE WORD INTEGER INPUT FOR
*         FSCALE WHICH REQUIRES...
*         LOW ORDER INTEGER INTEGER PART, X1, BITS 54-00. 
*         HIGH ORDER INTEGER PART, X2, BITS 58-00.
  
 DEC52    SB5    B5+B6
          NO
          NZ     B5,DEC53    IF DOUBLE PRECISION OR ERROR FLAG SET
          SB2    48 
          NO
          AX1    B2,X2
          ZR     X1,DEC53    IF NO SINGLE PRECISION OVERFLOW
          SA5    DATAFLG
          MI     X5,DEC53    IF ERROR TO BE SUPPRESSED
          WARN   E.DC8
  
 DEC53    MX5    1
          LX3    -1          POSITION HIGH PART 
          BX4    X5*X3       GET CARRY BIT
          BX0    -X5*X3      SET HIGH PART FOR FSCALE 
          LX4    -5          POSITION CARRY BIT 
          BX1    X4+X2       SET LOW PART FOR FSCALE
          SA0    B4 
          SB4    B6 
          SB6    B6+M.REAL   SET MODE 
          ERRNZ  M.REAL+1-M.DBL 
          RJ     FSCALE      CONVERT FLOATING CONSTANT
          BX6    X1 
          BX7    X2 
          SB2    B4 
          SB4    A0 
          ZR     B2,DEC60    IF CONVERSION SUCCESSFUL 
  
 DECEX1   SB2    E.DC        CONVERSION ERROR 
  
 DECEX    FATAL  B2 
          SX1    KW=DATA
          SA2    TB=TYPE
          HX2    KW.JMP 
          AX2    -KW.JMPL 
          IX2    X2-X1
          NZ     X2,PSL      IF NOT PROCESSING DATA STATEMENT 
          MX6    0
          SA6    A1          CLEAR DATA FLAG
          EQ     DAT.Z       EXIT... [TO CLEAN UP AFTER DATA] 
  
 DECA     BSS    7           REGISTER SAVE/RESTORE AREA 
 DTA      SPACE  4,10 
**        DTA -  DPC TO ASCII CONVERSION
* 
*         ENTRY  (X3) = DPC CHARACTER, LEFT JUSTIFIED.
* 
*         EXIT   (X3) = ASCII EQUIVALENT, RIGHT JUSTIFIED.
* 
*         USES   X - 3,5,6,7  A - 5 
  
 DTA      SUBR               ENTRY/EXIT...
          MX6    3
          BX7    X6*X3
          LX7    3           X7 = PROPER TABLE OFFSET 
          SA5    DTACT+X7    X5 = PROPER TABLE WORD 
          LX3    3
          BX7    X6*X3
          LX7    3           X7 = CHARACTER POSITION
          SX6    B6          PRESERVE B6
          SB6    X7 
          LX7    2
          SX7    X7+B6
          SB6    X7+B6       B6 = SHIFT COUNT 
          LX5    B6,X5
          SB6    X6          RESTORE B6 
          MX6    CHAR 
          BX3    X6*X5
          LX3    CHAR        X3 = ASCII CONVERSION
          EQ     EXIT.
  
  
          CODE   A
  
 DTACT    CON    8L:ABCDEFG 
          CON    8LHIJKLMNO 
          CON    8LPQRSTUVW 
          CON    8LXYZ01234 
          CON    8L56789+-* 
          CON    8L/()$= ,. 
 .IP      IFEQ   IP.CSET,IP.C63 
          VFD    30/5L#[]:",6/77B,12/2L!&,12/0
 .IP      ELSE
          VFD    30/5L#[]%",6/77B,12/2L!&,12/0
 .IP      ENDIF 
          CON    8L'?<>@\^; 
  
          CODE   D
 OCT      SPACE  4,30 
**        OCT -  CONVERT OCTAL/HEX CONSTANT TO BINARY.
* 
*         ENTRY  (B4) -> FIRST TOKEN OF OCTAL OR HEX CONSTANT.
* 
*         EXIT   (B4) -> LAST TOKEN OF CONSTANT.
*                (X1) = M.BOOL
*                (X6) = VALUE OF CONSTANT.
* 
*         USES   A1-3   X0-3,X6-7    B2,7.
  
  
 OCT      SUBR   =           ENTRY/EXIT...
          SA3    B4 
          BX6    0           CLEAR ACCUMULATOR
          SB7    3           SET (B7) = LOG2 (RADIX)       /* ASSUME (8)
          SX2    60/3        INITIALIZE DIGIT COUNT 
          SB3    X3 
          MX0    -CHAR
          =B2    O.OCT
          EQ     B2,B3,OCT40 IF OCT TOKEN 
          =B2    B2-O.OCT+O.HEX 
          SB7    B7+1        ADJUST FOR BASE 16 
          SX2    60/4 
          NE     B2,B3,"BLOWUP"    IF NOT HEX TOKEN -- CALLER MESSED UP 
  
 OCT40    LX3    CHAR 
          BX1    -X0*X3 
          SB3    X1-1R8 
          ZR     X1,OCT50    IF WORD EXHAUSTED
          SX1    X1-1R0 
          MI     B3,OCT44    IF CHARACTER NOT TOO BIG FOR OCTAL 
          SB3    X1-10
          SB4    -B1         INDICATE NON-OCTAL CHARACTER 
          MI     B3,OCT44    IF CHARACTER NOT TOO BIG FOR HEX 
          SB7    B0          INDICATE ILL CHARACTER 
  
 OCT44    SX2    X2-1 
          PL     X1,OCT48    IF DIGIT 
          SX1    X1+1R0-1RA+10
          SB3    X1+1RA-10-1RG
          SB4    -B1         INDICATE NON-OCTAL CHARACTER 
          MI     B3,OCT48    IF LEGAL HEX DIGIT [A,B,C,D,E,F] 
          =B7    0           INDICATE INVALID DIGIT 
  
 OCT48    LX6    B7 
          BX6    X1+X6       MERGE NEW DIGIT
          EQ     OCT40       LOOP.. 
  
 OCT50    =A3    A3+1        FETCH NEXT WORD
          SB3    X3 
          EQ     B2,B3,OCT40 IF MORE OF OUR TOKENS
          SX3    B4 
          SB4    A3-B1       ADVANCE TOKEN POINTER
          PL     X2,OCT94    IF NOT TOO MANY DIGITS 
          WARN   E.DC8       ** OCT/HEX CONSTANT TOO LONG 
  
 OCT94    ZR     B7,OCT95    IF PATENTLY ILLEGAL CHARACTER
          PL     X3,OCT96    IF NO HEX DIGITS APPEARED
          SB3    B2-O.OCT 
          NZ     B3,OCT96    IF HEX ALLOWED 
  
 OCT95    WARN   E.DC9       ** ILLEGAL DIGIT IN OCT/HEX CONSTANT 
  
 OCT96    =X1    M.BOOL 
          EQ     EXIT.
 TNK      SPACE  4,20 
**        TNK - TRANSLATE NUMERIC KONSTANT. 
* 
*         ENTRY  (B4) -> FIRST TOKEN OF CONSTANT. 
* 
*         EXIT   (B4) -> LAST TOKEN OF CONSTANT.
*                (X1) = MODE OF CONSTANT. 
*                (X2) = LOWER HALF OF CONSTANT, IF NEEDED.
*                (X6) = UPPER, OR ONLY, HALF OF CONSTANT. 
* 
*         USES   A1-5   B2-3,7   X0-3,6-7.
*                (X4-5 ARE NOT DESTROYED) 
* 
*         CALLS  DEC, FATAL, OCT. 
  
  
 TNK      SUBR   =           ENTRY/EXIT...
          SA3    B4 
          SB2    X3-O.CONS
          =B7    B2+O.CONS-O.PERIOD 
          ZR     B2,TNK2     IF DECIMAL NUMBER
          NZ     B7,TNK4     IF NOT DECIMAL POINT 
  
 TNK2     RJ     DEC         TRANSLATE DECIMAL CONSTANT 
          EQ     EXIT.
  
 TNK4     =B7    B2+O.CONS-O.OCT
          =B2    B7+O.OCT-O.HEX 
          ZR     B7,TNK5     IF OCTAL TOKEN 
          NZ     B2,TNK9     IF NOT HEX TOKEN 
  
 TNK5     ANSI   E.DC1       O.OCT AND O.HEX NON-ANSI 
          RJ     OCT
          EQ     EXIT.
  
 TNK9     FATAL  E.DC        ** CONSTANT CANNOT BE CONVERTED
          EQ     PSL         EXIT..      RETURN FOR NEXT STATEMENT
*CALL     FSCALE             FLOATING DOUBLE PRECISION CONVERSION 
  
          TITLE  CONSTANT REDUCTION.
 CCR      SPACE  4,10 
**        CCR - COMPUTE CONSTANT REDUCTION. 
* 
*         CCR IS CALLED BY PAR/ADT WHEN A TURPLE IS ABOUT TO BE 
*         EMITTED.  IT ATTEMPTS TO REDUCE THE TURPLE IF IT HAS
*         CONSTANT OPERAND(S) --
*         A.  BY PERFORMING THE OPERATION AT COMPILE TIME  (2 + 3)
*         B.  RESULT INDEPENDENT OF VARIABLE OPERAND       (0 / X)
*         C.  ISSUE DIAGNOSTIC FOR END CASES            (OVERFLOW)
* 
*         ENTRY  (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
*                (X7) = INDEX OF REDUCTION SKEL. (IN F.SKEL)
*                (SOPR) = OPERATOR. 
*                (SMOD) = RESULT MODE.
* 
*         EXIT   (X6) .ZR. = TURPLE MUST BE EMITTED.
*                (X4, X5, SOPR) MAY HAVE BEEN CHANGED.
* 
*         ELSE   (X6) .NZ. = RESULT OPERAND FOR SPECIFIED TURPLE. 
*                            DO NOT ISSUE TURPLE. 
*                (X4,X5) = PRESERVED. 
* 
*         USES   ALL BUT A0,  B4-6. 
*         CELLS  (SCR TO SCR+3) 
* 
*         CALLS  LCH, PCA.
  
  
 CCR      SUBR   =           ENTRY/EXIT...
          SA7    CCRA 
  
*         REDUCIBLE OPERATOR FOUND, CHECK FOR CONSTANTS AS OPERANDS.
*         FIRST, CALL LCH AND COMPUTE CONSTANTALITY IN RANGE (0 .. 3),
*         THEN SUBTRACT ONE TO GIVE RANGE (-1 .. 2), VIZ -- 
*                (1OP, 2OP) =  CC     CV    VC    VV
*                FOR 1 VAR  =  0      0     2     2 
*                ADD 2 VAR  =   0      1     0     1
*                FIRST SUM  =   0      1     2     3
*                REDUCE - 1 =  -1      0    +1    +2
*         FOR CONSTANTS AT:  BOTH,   1OP,  2OP,   NEITHER.
  
          SA7    CONRB
          BX1    X4 
          RJ     LCT         LOAD FIRST CONSTANT
          SA6    LVEC 
          MX6    0           INDICATE NO REDUCE 
          SA7    LLVEC
          BX1    X5 
          ZR     B2,EXIT.    IF 1ST IS NOT CONSTANT 
          ZR     X5,CCR8     IF (2OP) IS NIL
          SA2    SMOD        RESULT MODE
          SX2    X2-M.DBL 
          SA3    A2+1        OPERATOR 
          SX3    X3-O.PL
          BX6    X2+X3
          SX2    B2+B1
          BX6    X6+X2
          SA6    CONRB       0 IF RESULT DOUBLE, OPERATOR +, CONST LONG 
          RJ     LCT         LOAD SECOND CONSTANT 
          SA6    LVEC+1 
          MX6    0
          SA7    LLVEC+1
          ZR     B2,EXIT.    IF (2OP) NOT CONSTANT
          SX2    B2+B1
          NZ     X2,CCR8     IF 2OP NOT LONG CONSTANT 
          SA3    CONRB
          MI     X3,CCR8     IF RESULT NOT DBLE, ORT .NE. +, 1OP NOT LNG
          NZ     X3,CCR8     IF RESULT NOT DBLE, OPR .NE. +, 1OP NOT LNG
          SA2    LVEC        1OP UPPER
          SA3    LLVEC       1OP LOWER
          NZ     X2,CONR3    IF 1OP UPPER NOT ZERO
          NZ     X3,CONR3    IF 2OP LOWER NOT ZERO
          LX0    X5 
  
*         HERE IF ATTEMPT TO ADD ZERO TO A DOUBLE PRECISION CONSTANT
  
 CONR2    BX6    X2          UPPER RESULT 
          BX7    X3          LOWER RESULT 
          SA6    RVEC 
          SA7    A6+1 
          BX6    X0 
          EQ     EXIT.
  
 CONR3    SA2    A2+1        2OP UPPER
          SA3    A3+1        2OP LOWER
          NZ     X2,CCR8     IF 2OP UPPER NOT ZERO
          NZ     X3,CCR8     IF 2OP LOWER NOT ZERO
          BX0    X4 
          EQ     CONR2
  
*         REDUCE EXPRESSION AT COMPILE TIME.
  
 CCR8     SA3    CCRA 
          RJ     CTA         PERFORM COMPILE TIME REDUCTION 
          EQ     EXIT.
  
 CONRB    BSS    1
 CTA      EJECT 
**        CTA -  COMPILE TIME ARITHMETIC. 
* 
*         ENTRY  (X3) = INDEX OF CONSTANT REDUCER.
*                (LVEC,LVEC+1) = UPPER HALVES OF (1OP,2OP)
*                (LLVEC,LLVEC+1) = LOWER HALVES OF (1OP,2OP)
*                (TER2+1) = LOWER HALF OF 2OP.
* 
*         EXIT   SAME AS CCR. 
*                (RVEC,RLVEC) = RESULTS IN BINARY OF REDUCTION. 
* 
*         USES   A1-7,  X0-7,  B2-3,B7. 
*         CELLS  (SCR+4). 
* 
*         CALLS  CIO, CFO, NBC. 
  
  
 CTA      SUBR   =           ENTRY/EXIT...
          BX6    X4 
          BX7    X5 
          SA6    CTAA 
          =A7    A6+1 
          SA5    =XF.SKEL+X3-1
  
 CTA10    =A5    A5+1 
          BX2    X5 
          MX0    -SK.TYPL+1 
          AX2    SK.TYPP
          BX0    -X0*X2 
          SB3    X0-M.ISBRN 
          NZ     B3,CTA20    IF THIS INSTRUCTION NOT SKEL BRANCH
          SA5    X5          RESET SKEL POINTER 
  
 CTA20    RJ     ISI         INTERPRET INSTRUCTION SKELETON 
          SA5    A5 
          HX5    SK.END 
          PL     X5,CTA10    IF NOT THROUGH WITH SKEL 
  
*         FORM OPERAND FOR REDUCED VALUE
  
          SA2    RVEC 
          SA3    RLVEC
          SA1    SMOD 
          BX6    X2 
          BX7    X3 
          RJ     NBC
          SA4    CTAA 
          =A5    A4+1        RESTORE ORIGINAL OPERANDS
          EQ     EXIT.
  
*         PROCESS ERROR DETECTED WHILE REDUCING.
  
 CTA.ER   BSS    0
          MX6    0
          SA4    CTAA 
          =A5    A4+1 
          EQ     EXIT.
 PCC      SPACE  4,10 
**        PCC -  PERFORM CHARACTER CONCATENATION. 
*                DOES CONCATENATION OF TWO CHARACTER CONSTANT OPERANDS. 
* 
*         ENTRY  (X3) = LENGTH OF (1OP), IN CHARS 
*                (X7) = LENGTH OF (2OP), IN CHARS 
*                (B3) = CON INDEX OF (1OP)
*                (B2) = CON INDEX OF (2OP)
*         EXIT   (X1) = LENGTH OF RESULT, IN CHARS
*                (X2) = CON INDEX OF RESULT 
*         CALLS  ALC,MVE=,MNS=,NCM
*         USES   ALL BUT B4,B5,B6 
  
  
 PCC      SUBR   =           ENTRY/EXIT.
          IX6    X3+X7       NEWLEN = OP1LEN + OP2LEN 
          BX4    X3 
          SA6    PCCA        (PCCA) = NEWLEN, IN CHARACTERS 
          CW     X5,X6       NEWLEN = NEWLEN / 10 
          SA7    A6-PCCA+PCCB      (PCCB) = OP2LEN
          ALLOC  T.CON,X5    ALLOCATE FOR NEWLEN
          SA2    =1H
          BX6    X2 
          SB2    X1+B2       FWA2 = FWA(T.CON) + INDOP2 
          SX7    B7 
          =A6    B7-1        LWA(T.CON) = 10H 
          SX2    X1+B3       SFWA1 = FWA(T.CON) + INDOP1
          IX3    X7-X5       NEWFWA = LWA(T.CON) + 1 - NEWLEN 
          IX7    X3-X1       NEWIND = NEWFWA - FWA(T.CON) 
          LX5    X4          SAVE (X5) = OP1LEN 
          CW     X1,X4       OP1LEN = OP1LEN / 10 
          IX6    X3+X1
          SB3    X6          (B3) = FWA1 + OP1LEN 
          SA7    PCCC        (PCCC) = NEWIND
          MOVE   X1,X2,X3    MOVE OP1 TO NEW LOCATION 
          SA3    PCCB        LENOP2 = (PCCB)
          BC     X0,X3       LENOP2 = LENOP2 * 6
          WX4    X5,X2       DFB = (X2) = REMAINDER OF LENOP1/10
          ZR     X2,PCC5     IF OP1 MULT OF 10 CHARS
          =B3    B3-1 
  
 PCC5     BC     X3,X2       DFB = DFB * 6
          SX6    B4 
          SX7    B5 
          SX2    B2          SFWA = FWA2
          =B2    0           SFB = 0
          SA6    PCCD        (PCCD) = (B4)
          =A7    A6+1        (PCCD+1) = (B5)
          SX6    B6 
          SX4    B3          DFWA = (B3)
          SB4    X3 
          =A6    A7+1        (PCCD+2) = (B6)
          MOVEB  X0,X2,B2,X4,B4    MOVE OP2 TO END OF OP1 
  
*         BLANK FILL LAST WORD. 
*         (X4) -> NEXT DESTINATION ADDRESS. 
*         (B4) -> DESTINATION NEXT BIT
  
          SA5    PCCC        NEWIND = (PCCC)
          SA3    A5-PCCC+PCCD 
          =A2    A3+1 
          SB4    X3          RESTORE (B4) 
          SB5    X2          RESTORE (B5) 
          =A3    A2+1 
          SA4    T=CON
          SA1    T.CON
          SB6    X3          RESTORE (B6) 
          IX0    X4-X5       NEWLEN = (T=CHAR) - NEWIND 
          SB7    X1          *DO NOT ALLOCATE FOR THIS* 
          SB2    X5+B7       FWACON = FWA(T.CON) + NEWIND 
          BX7    X5 
          SB3    B2+X0       LWACON = FWA CON + NEWLEN
          SA7    A4          (T=CHAR) = (T=CHAR) - NEWLEN = NEWIND
          RJ     NCM
          BX2    X5          NEWIND = (X5)
          SA1    PCCA        NEWLEN = (PCCA)   */IN CHARS 
          MI     B7,PCC20    IF NOT IN TABLE
          SX2    B7+         NEWIND = (B7)
          EQ     EXIT.
  
*         (X0) = NEWLEN IN WORDS. 
  
 PCC20    SA3    T=CON
          IX6    X3+X0
          SA6    A3          (T=CHAR) = (T=CHCAR) + NEWLEN
          EQ     EXIT.
 PCR      SPACE  4,10 
**        PCR -  PROCESS CHARACTER RELATIONALS. 
* 
*         ENTRY  (PCR.1OP) = T.CON INDEX OF 1ST OPERAND 
*                (PCR.1OP+1) = LENGTH OF 1ST OPERAND
* 
*                (PCR.2OP) = T.CON INDEX OF 2ND OPERAND 
*                (PCR.2OP+1) = LENGTH OF 2ND OPERAND
* 
*                (PCR.RO) = RELATIONAL OPERATOR 
* 
*         EXIT   (B6) = UPDATED BY -1 
* 
*                ESTACK(B6-1) = RESULT OF REDUCTION 
* 
*         CALLS  CCS,NBC. 
* 
*         USES   ALL BUT A0  B4,B5,B6.
  
 LT       IMPLIES    (O.LT,O.NE,O.LE) 
 EQ       IMPLIES    (O.EQ,O.GE,O.LE) 
 GT       IMPLIES    (O.GT,O.GE,O.NE) 
  
 PCR      SUBR   =                 ENTRY/EXIT...
          SA4    T.CON
          SA2    PCR.1OP
          SA3    PCR.2OP
          IX1    X4+X2
          SA1    X1          (A1,X1) _ 1ST STRING 
          IX2    X4+X3
          SA2    X2          (A2,X2) _ 2ND STRING 
          =A4    PCR.1OP+1
          SB2    X4          B2 = LENGTH OF 1ST STRING
          =A3    PCR.2OP+1
          SB3    X3          B3 = LENGTH OF 2ND STRING
          RJ     CCS         COMPARE CHARACTER STRINGS
          LDX    X1,"EQ"     X1 = IMPLICATION VECTOR FOR EQ 
          ZR     X7,PCR10    IF 1ST STRING .EQ. 2ND STRING
          LDX    X1,"LT"     X1 = IMPLICATION VECTOR FOR LT 
          MI     X7,PCR10    IF 1ST STRING .LT. 2ND STRING
          LDX    X1,"GT"     X1 = IMPLICATION VECTOR GT 
  
 PCR10    SA2    PCR.RO      X2 = RELOP FROM SOURCE STATEMENT 
          SB2    X2 
          SB3    59 
          SB3    B3-B2
          LX6    X1,B3
          AX6    59 
          MX1    59 
          BX6    X1*X6       X6 = COMPILER TRUE OR FALSE
          SX1    M.LOG       INDICATE TYPE LOGICAL
          MX7    0
          RJ     NBC         GET OPERAND REPRESENTING RESULT
          =B6    B6-1        POP ESTACK 
          =A6    B6-1        STACK RESULT OF REDUCTION
          EQ     EXIT.
  
  
 PCR.1OP  BSSENT 2
 PCR.2OP  BSSENT 2
 PCR.RO   BSSENT 1
 ISI      SPACE  4,10 
**        ISI - INTERPRET SKELETON INSTRUCTION. 
  
 ISI      SUBR
          LX5    -SK.GHP
          MX0    -SK.GHL
          SB2    3
          BX6    -X0*X5 
          SA6    COL.PO      *COL* NEEDS PIK=PS OFFSET
          SA1    =XPIK=PS+X6
          BX7    X1 
          LX6    45+9 
          SA7    PIK
          SA6    OPCODE 
          SA1    INST=23
          LX5    SK.GHP-SK.KFP     RIGHT JUSTIFY K INFO 
          BX6    X1+X6
          HX7    OD.JKV 
          PL     X7,ISI5     IF NOT JK VALUE INSTRUCTION
          MX6    0           LOP WILL DEFINE INSTRUCTION
  
 ISI5     SA6    INST        INITIALIZE FOR NOMINAL INSTRUCTION 
  
 ISI10    MX0    -SR.NUML 
          BX2    -X0*X5 
          LX5    -SR.NUML 
          MX0    -SR.OADL 
          BX1    -X0*X5 
          LX5    -SR.OADL 
          RJ     LOP         LOAD OPERAND 
          =B2    B2-1        FIELDN = FIELDN - 1
          SA6    FIELD+B2    SAVE POINTER TO OPERAND VALUE
          NZ     B2,ISI10    IF NOT FIELD1 (I)
          SA1    PIK
          HX1    OD.COPY
          PL     X1,ISI20    IF NOT JJ INSTRUCTION
          SA4    OPCODE 
          SA2    INST=22
          BX6    X2+X4
          PLUG   AT=INST,FROM=X6
          EQ     ISI30
  
 ISI20    LX1    OD.COPYP-OD.KJP
          PL     X1,ISI30    IF NOT K=J INSTRUCTION 
          SA4    OPCODE 
          SA2    INST=32
          BX6    X2+X4
          PLUG   AT=INST,FROM=X6
  
 ISI30    SA2    FIELD+1
          =A3    A2+1 
          SA2    X2 
          SA3    X3 
          RJ     COL         CHECK OPERAND LEGALITY 
          SA1    FIELD
          SA1    X1 
  
 INST     EQ     "BLOWUP" 
  
*         STORE RESULT. 
  
          SA2    FIELD
          BX7    X1 
          SA7    X2 
          SA1    PIK
          HX1    OD.FPA 
          PL     X1,EXIT.    IF NOT FLOATING POINT ARITHMETIC 
          OR     X7,CTA.ER   IF RESULT OUT OF RANGE 
          ID     X7,CTA.ER   IF RESULT INDEF. 
          EQ     EXIT.
 LOP      SPACE  4,10 
**        LOP - LOAD OPERAND. 
  
          MACRO  SKOP,OP,NOTLAST,LAST,FTYP,OPEQ 
          IFC    EQ,/OPEQ//,5 
          IFC    NE,/LAST/NOTLAST/,2
          IFC    NE,/NOTLAST/NONE/,1
          EQ     LOP.OP 
          IFC    NE,/LAST/NONE/,1 
          EQ     LOP.OP 
          ENDM
  
 LOP      SUBR
          SA4    OPCODE 
          SB3    X1 
          JP     LOP.JT+B3
  
 LOP.JT   BSS    0
          LOC    0
          LIST   -X,G 
*CALL SKOP
  
          LIST   *
          LOC    *O 
  
 LOP.A    BSS    0
 LOP.X    BSS    0
 LOP.P    BSS    0
 LOP.GP   BSS    0
 LOP.GL   BSS    0
 LOP.GLL  BSS    0
 LOP.Q    BSS    0
 LOP.S    BSS    0
          EQ     "BLOWUP" 
  
 LOP.L    SX6    LVEC+X2-1
          EQ     EXIT.
  
 LOP.LL   SX6    LLVEC+X2-1 
          EQ     EXIT.
  
 LOP.R    SX6    RVEC 
          EQ     EXIT.
  
 LOP.RL   SX6    RLVEC
          EQ     EXIT.
  
 LOP.T    SX6    TVEC+X2
          EQ     EXIT.
  
 LOP.B    SA1    INST=73
          NE     B2,B1,LOPB10      IF NOT I FIELD 
          SA1    INST=SB
  
 LOPB10   BX6    X1+X4
          SA6    INST        J = B7 
          EQ     EXIT.
  
 LOP.K    SA1    PIK
          LX2    45 
          HX1    OD.JKV 
          PL     X1,LOP.K10  IF NOT JKVAL INSTR.
          SA1    INST=00
          BX0    X1+X4
          BX6    X0+X2
          SA1    INST 
          BX6    X6+X1
          SA6    A1 
          EQ     EXIT.
  
 LOP.K10  LX1    OD.JKVP-OD.BJP 
          PL     X1,EXIT.    IF NOT B-REG INSTR.
          IFNE   TEST,0,1 
          NZ     X2,"BLOWUP" IF VAL .NZ.
          SA1    INST=03
          BX6    X1+X4
          SA6    INST 
          EQ     EXIT.
 COL      SPACE  4,10 
**        COL - CHECK OPERAND LEGALITY. 
  
 COL      SUBR
          SA1    PIK
          HX1    OD.UP
          PL     X1,COL10    IF NOT UNPACK INSTRUCTION
          BX7    X3 
          RJ     CFO         CHECK FLOATING POINT OPERAND 
          EQ     EXIT.       TO ALLOW REDUCTION OF NINT (IF NO PROBLEM) 
          UX0    B3,X3
          PL     B3,CTA.ER   IF VALUE TOO LARGE TO FIX
          EQ     EXIT.
  
 COL10    LX1    OD.UPP-OD.PKP
          PL     X1,COL20    IF NOT PACK INSTRUCTION
          BX7    X3 
          RJ     CIO         CHECK INTEGER OPERAND
          EQ     EXIT.
  
 COL20    LX1    OD.PKP-OD.FPAP 
          PL     X1,EXIT.    IF NOT FP ARITHMETIC 
          BX7    X2 
          RJ     CFO         CHECK 1OP
          BX7    X3 
          RJ     CFO         CHECK 2OP
          UX7    X2,B2       B2 = EXPONENT OF 1OP 
          SB2    B2+60B 
          UX7    X3,B3       B3 = EXPONENT OF 2OP 
          SB3    B3+60B 
          SB7    1770B+60B   B7 = TEST VALUE
          LX1    OD.FPAP-OD.DIVP
          PL     X1,COL30    IF NOT DIVIDE
          NX1    X3 
          ZR     X1,CTA.ER   IF DIVIDE BY ZERO
          SB2    B2-B3
          GT     B2,B7,CTA.ER      IF RESULT OF DIVIDE WOULD BE BAD 
          EQ     EXIT.
  
 COL30    SA1    COL.PO      X1 = OFFSET INTO PIK=PS TABLE
          SX1    X1-40B      ADDS AND SUBTRACTS HAVE OFFSETS .LT. 40B 
          MI     X1,EXIT.    IF ADD OR SUBTRACT 
          SB2    B2+B3
          GT     B2,B7,CTA.ER      IF RESULT OF MULTIPLY WOULD BE BAD 
          EQ     EXIT.
  
 COL.PO   BSS    1           OFFSET INTO PIK.PS TABLE 
 CFO      SPACE  4,10 
**        CFO - CHECK FL. PT. OPDERAND. 
* 
*         PRESERVES X1,X2,X3 , B3,B4,B5,B6 , A5 
  
 CFO      SUBR
          OR     X7,CTA.ER   IF OPERAND OUT OF RANGE
          ID     X7,CTA.ER   IF OPERAND INDEF.
          EQ     EXIT.
 CIO      SPACE  4,4
**        CIO - CHECK INTEGER ABOUT TO BE FLOATED.
  
 CIO      SUBR
          AX7    60-12
          ZR     X7,EXIT.    IF NOT TOO LARGE 
          EQ     CTA.ER 
 KMOD     SPACE  4,20 
**        KMOD - CONSTANT MODE-CONVERSION SELECTOR MATRIX.
* 
* TYPE    KMOD   B,L,I,R,D,Z,H
  
  
          MACRO  KMOD,TYPE,U,L,I,R,D,Z,H
 E        MICRO 
 .1       ECHO   ,P=(H,Z,D,R,I,L,U) 
          IFC    EQ,/P/--/,2
 E        MICRO  1,,$"E"8/0,$ 
          SKIP   4
          IFC    EQ,/P/**/,2
 E        MICRO  1,,$"E"8/KCNN-KCEE,$ 
          SKIP   1
 E        MICRO  1,,$"E"8/KC_P-KCEE,$ 
 .1       ENDD
* 
 M.TYPE   VFD    4/0,"E"
          ENDM
  
  
 KMOD     BSS    0           CONSTANT MODE-CONVERSION SELECTOR MATRIX 
          LOC    0
 BOOL     KMOD   **,--,**,**,RD,RZ,-- 
 LOG      KMOD   --,**,--,--,--,--,-- 
 INT      KMOD   **,--,**,IR,ID,IZ,-- 
 REAL     KMOD   **,--,RI,**,RD,RZ,-- 
 DBL      KMOD   **,--,DI,**,**,DZ,-- 
 CPLX     KMOD   **,--,ZI,**,ZD,**,-- 
 CHAR     KMOD   --,--,--,--,--,--,** 
 N.TYPE   BSS 
          LOC    *O 
 KCV      SPACE  4,10 
**        KCV - CONVERT CONSTANT VALUE. 
* 
*         ENTRY  (X6, X7) = OLD VALUE OF CONSTANT.
*                (X0) = OLD MODE. 
*                (X1) = DESIRED MODE. 
* 
*         EXIT   (B2) .MI. = ILLEGAL CONVERSION.
*                     .ZR. = NULL CONVERSION (OLD CONSTANT IS EQUIVALENT
*                            VALUE).
*                (X1) = DESIRED MODE. 
*                (X6, X7) = NEW VALUE OF CONSTANT.
* 
*         USES   A1,A2  X0,X2,X3  B7. 
  
  
 KCEE     SB2    -1          INDICATE ILL CONVERSION
  
 KCV      SUBR   =           ENTRY/EXIT...
          SA2    X0+KMOD     FETCH ROW FOR OLD MODE 
          LX1    3           (B2) = 8 * SMOD
          MX0    -8 
          SB2    X1 
          AX3    B2,X2       SLIDE ROW TO DOMINANT COLUMN 
          BX3    -X0*X3 
          AX1    3           RESTORE (X1) = (SMOD)
          SB2    X3-1 
          JP     B2+KCEE+1   ENTER MODE-CONVERTER.. 
  
  
 KCNN     EQU    EXIT.       NULL CONVERSION
  
 KCEE     EQU    KCNN-1      ILL CONVERSION 
  
 KCIR     BSS                INT  ->  REAL
 KCID     BSS                INT  ->  DBL 
 KCIZ     BSS                INT  ->  CPLX
          PX2    X6 
          SB0    +
          NX6    X2 
  
 KCRD     BSS                REAL ->  DBL 
 KCRZ     BSS                REAL ->  CPLX
 KCDZ     BSS                DBL  ->  CPLX
 KCZD     BSS                CPLX ->  DBL 
          SX7    B0          LOWER = ZERO 
          EQ     EXIT.
  
 KCRI     BSS                REAL ->  INT 
 KCDI     BSS                DBL  ->  INT 
 KCZI     BSS                CPLX ->  INT 
          UX2,B7 X6 
          LX6    X2,B7
          EQ     EXIT.
          TITLE  CONSTANT TEST AND MANIPULATION.
 CCS      SPACE  4,10 
**        CCS -  COMPARE CHARACTER STRINGS. 
* 
*         ENTRY  (A1,X1) _ 1ST CHARACTER STRING.
*                (B2) = LENGTH OF THE 1ST STRING. 
* 
*                (A2,X2) _ 2ND CHARACTER STRING 
*                (B3) = LENGTH OF THE 2ND STRING. 
* 
*         EXIT   (X7) = MI IF 1ST STRING .LT. 2ND.
*                     = ZR IF 1ST STRING .EQ. 2ND 
*                     = PLNZ IF 1ST STRING .GT. 2ND.
* 
*         CALLS  GNC. 
* 
*         USES   X - ALL  A - 1,2,5  B - 2,3,7
  
 CCS      SUBR               ENTRY/EXIT...
          SB7    10          NEXT WORD FLAG 
          MX0    CHAR 
  
 CCS10    SX3    B2+B3
          MX7    0
          ZR     X3,EXIT.    IF BOTH STRINGS DONE 
          RJ     GNC         GET NEXT CHARACTERS
          IX7    X4-X3
          NZ     X7,EXIT.    IF STRINGS DONT MATCH HERE 
          EQ     CCS10       CONTINUE 
 GNC      SPACE  4,10 
**        GNC -  GET NEXT CHARACTERS. 
* 
*         MEANT TO BE USED IN CONJUNCTION WITH CCS. 
* 
*         ENTRY  (A1,X1) _ A WORD OF 1ST CHARACTER STRING.
*                (B2) = NUMBER OF CHARACTERS LEFT IN THE STRING.
* 
*                (A2,X2) _ A WORD OF 2ND CHARACTER STRING.
*                (B3) = NUMBER OF CHARACTERS LEFT IN THE STRING.
* 
*                (X0) = CHARACTER MASK IN UPPER 6 BITS. 
* 
*                (B7) = NUMBER OF CHARS IN X1,X2 NOT YET COMPARED.
* 
*         NOTE - WHEN EITHER B2 OR B3 ARE ZERO ON EXIT, 
*                IT INDICATES THAT THE CORRESPONDING STRING HAS BEEN
*                EXHAUSTED, AND THAT THE ASSOCIATED REGISTERS NO LONGER 
*                POINT TO THE STRING. 
* 
*         CALLS  DTA. 
* 
*         USES   X - 1,2,3,4,5,6,7  A - 1,2,5  B - 2,3,7
  
 GNC      SUBR               ENTRY/EXIT...
          NZ     B2,GNC10    IF 1ST STRING NOT EXHAUSTED
          =B2    B2+1        GUARANTEES B2 STAYS ZERO 
          SA1    =10H            SUPPLY BLANKS FROM NOW ON
  
 GNC10    NZ     B3,GNC20    IF 2ND STRING NOT EXHAUSTED
          =B3    B3+1        GUARANTEES B3 STAYS ZERO 
          SA2    =10H            SUPPLY BLANKS FROM NOW ON
  
 GNC20    BX3    X0*X1       ISOLATE CHARACTER FROM 1ST STRING
          RJ     DTA         DPC TO ASCII 
          BX4    X3          PRESERVES ABOVE CONVERSION 
          BX3    X0*X2       ISOLATE CHARACTER FROM 2ND STRING
          RJ     DTA         DPC TO ASCII 
          LX1    CHAR 
          LX2    CHAR 
          =B2    B2-1 
          =B3    B3-1 
          =B7    B7-1 
          NZ     B7,EXIT.    IF NEXT WORD NOT REQUIRED
          =A1    A1+1 
          =A2    A2+1 
          EQ     EXIT.
 LCH      SPACE  4,10 
**        LCH - LOAD VALUE OF CONSTANT. 
* 
*         ENTRY  (X1) = OPERAND FOR PROPOSED CONSTANT.
* 
*         EXIT   (X0) = MODE OF OPERAND.
*                (B2, X3, X6, X7) = SEE BELOW.
* 
*         IF OPERAND NOT CONSTANT --
*                (B2) = 0 
* 
*         IF CHARACTER CONSTANT --
*                (B2) = -2
*                (X6) = WORD INDEX OF VALUE (IN T.CON). 
*                (X7) = CONSTANT LENGTH (CHARS).
* 
*         IF LONG CONSTANT (IN T.CON) --
*                (B2) = -1
*                (X3) = WORD INDEX OF VALUE IN (T.CON). 
*                (X6) = UPPER HALF OF VALUE.
*                (X7) = LOWER HALF. 
* 
*         IF SHORT CONSTANT RESULT -- 
*                (B2) = +1
*                (X6) = VALUE.
* 
* 
*         USES   A1-3,6.   X0-3,6-7.  B2,7. 
*         CALLS  LCT. 
  
  
 LCH      SUBR   =           ENTRY/EXIT...
          MX0    -TP.MODEL
          BX6    X1 
          SB2    B0          PRESET RESULT = NOT CONSTANT 
          LX1    -TP.MODEP
          BX0    -X0*X1      (X0) = MODE OF OPERAND 
          HX6    TP.BIAS
          =B7    X0-M.CHAR
          LX1    TP.MODEP-TP.ORDP 
          AX6    -TP.BIASL   RETURN (X6) = INDEX INTO CON TABLE 
          MX7    -TP.ORDL 
          BX7    -X7*X1      (X7) = (TP.ORD)
          LX1    TP.ORDP-1-TP.INTRP 
          NZ     B7,LCH6     IF OPERAND MODE NOT CHARACTER
  
*         WHEN RESULT IS CHARACTER, IT SHOULD BE AN INTERMEDIATE WHICH
*         POINTS TO A SUBSTRING TURPLE. 
  
          PL     X1,LCH4     IF OPERAND NOT INTERMEDIATE
  
 .T       IFEQ   TEST,ON
          NZ     X6,"BLOWUP" IF BIAS NOT ZERO 
          MI     X6,"BLOWUP"
          SA2    T=PAR
          IX6    X7-X2
          PL     X6,"BLOWUP" IF INTERMEDIATE TOO BIG
 .T       ENDIF 
  
          SA2    T.PAR
          =B7    X2+OR.OPR
          SA3    X7+B7       FETCH OPERATOR WORD OF TURPLE
          MX0    -TH.SKELL
          LX3    -TH.SKELP
          BX6    -X0*X3      (X6) = OPERATOR
          SX7    V=SUBST
          IX6    X6-X7
          NZ     X6,LCH4     IF NOT SUBSTRING TURPLE
          =A3    A3-OR.OPR+OR.1OP 
          MX7    -TP.ORDL 
          SA1    S=CON
          LX3    -TP.ORDP 
          BX6    -X7*X3 
          IX3    X6-X1
          NZ     X3,LCH4     IF NOT SUBSTRING OF CONSTANT 
          LX3    TP.ORDP-1-TP.INTRP 
          MI     X3,LCH4     IF ARRAY INTERMEDIATE
          =A3    A3-OR.1OP+OR.2OP 
          LX3    -TP.ORDP 
          BX2    -X7*X3      (X2) = (2OP.ORD) OF SUBSTRING
  
 .T       IFEQ   TEST,ON
          LX3    TP.ORDP-1-TP.INTRP 
          PL     X3,"BLOWUP" IF (2OP) NOT FURTHER INTERMEDIATE
          SA1    X2+B7
          SX7    V=COLON
          LX1    -TH.SKELP
          MX0    -TH.SKELL
          BX0    -X0*X1 
          IX6    X0-X7
*         IF COLON-INTR-ORD(X2) .GE. SUBST-INTR-ORD THEN BLOWUP.
 .T       ENDIF 
  
          =B7    B7-OR.OPR+OR.1OP 
          SA1    X2+B7       FETCH SUBSTRING FIRST
          =A3    A1-OR.1OP+OR.2OP 
          RJ     LCT         LOAD VALUE 
 .T       IFEQ   TEST,ON,1
          NE     B2,B1,"BLOWUP"  IF NOT SHORT CONSTANT
          BX1    X3 
          SX3    X6-1        (X3) = FIRST CHAR POSITION 
          RJ     LCT         LOAD VALUE OF SUBSTRING-LAST 
 .T       IFEQ   TEST,ON,1
          NE     B2,B1,"BLOWUP"  IF NOT SHORT CONSTANT
          IX7    X6-X3       CONLEN = LAST - (FIRST - 1)
          CW     X1,X3       CFWA = (FIRST - 1) / 10
          SB2    -2          INDICATE CHARACTER CONSTANT
          BX6    X1 
  
 LCH4     =X0    M.CHAR 
          EQ     EXIT.
  
*         RESULT IS NON-CHARACTER.
  
 LCH6     SA2    S=CON
          SX0    B7+M.CHAR
          MI     X1,EXIT.    IF RESULT IS INTERMEDIATE
          LX1    TP.INTRP-TP.SHRTP
          IX2    X7-X2
          MI     X1,LCH8     IF SHORT CONSTANT
          NZ     X2,EXIT.    IF NOT CONSTANT
          SA1    T.CON
          IX7    X1+X6
          SA2    X7+B1       LOAD CONSTANT
          BX3    X6          RETURN (X3) = INDEX INTO (T.CON) 
          SA1    X7 
          SB2    -B1         INDICATE CONSTANT IN (T.CON) 
          BX7    X2 
          LX6    X1 
          EQ     EXIT.
  
 LCH8     SB2    B1 
 .T       IFEQ   TEST,ON,1
          NZ     X7,"BLOWUP" IF SHORT CON WITH ORDINAL
          EQ     EXIT.
 LCT      SPACE  4,10 
**        LCT -  LOAD BINARY OF CONSTANT. 
* 
*         ENTRY  (X1) = OPERAND FOR PROPOSED CONSTANT.
* 
*         EXIT   (X0) = MODE OF OPERAND.
*                (B2, X6, X7) = SEE BELOW.
* 
*         IF OPERAND NOT CONSTANT --
*                (B2) = 0 
*                (X6) = 0 
* 
*         IF LONG CONSTANT (IN T.CON) --
*                (B2) = -1
*                (X6) = UPPER HALF OF VALUE.
*                (X7) = LOWER HALF. 
*                (X1=X6, X2=X7, TRUE IF LONG BIT SET) 
* 
*         IF SHORT CONSTANT --
*                (B2) = +1
*                (X6) = VALUE.
* 
*                USES        A1-2   X0-2,6-7   B2,7.
  
  
 LCT      SUBR   =           ENTRY/EXIT...
          BX6    0
          SB2    B0          INDICATE NOT CONSTANT
          MX0    -TP.MODEL
          BX0    -X0*X1      EXTRACT MODE 
          SB7    X0-M.CHAR
          ZR     B7,EXIT.    IF CHARACTER OPERAND 
          BX2    X1 
          SBIT   X2,TP.INTRP
          MI     X2,EXIT.    IF INTERMEDIATE
          SBIT   X2,TP.SHRTP/TP.INTRP 
          MI     X2,LCT1     IF SHORT CONSTANT
          LX7    X1 
          HX7    TP.ORD      LEFT ADJUST
          AX7    -TP.ORDL    ISOLATE SIGN EXTENDED ORD FIELD
          BX6    0           =0, NO CONSTANT
          SA2    S=CON
          IX2    X7-X2
          NZ     X2,EXIT.    IF NOT *CONSTANT*
          SA2    T.CON
          HX1    -TP.BIAS    LEFT ADJUST
          AX1    -TP.BIASL   ISOLATE SIGN EXTENDED BIAS 
          IX2    X1+X2
          SA1    X2          LOAD CONSTANT (1ST WORD) 
          =A2    A1+1        LOAD CONSTANT (2ND WORD) 
          =B2    -1          INDICATE NOT SHORT CONSTANT
          BX6    X1          1ST WORD 
          LX7    X2          2ND WORD 
          EQ     EXIT.
  
 LCT1     HX1    TP.BIAS
          AX1    -TP.BIASL   SHIFT TO LOW WITH SIGN EXTEND
          =B2    1           INDICATE SHORT CONSTANT
          BX6    X1 
          EQ     EXIT.
 LIR      SPACE  4,10 
**        LIR - LOAD INTEGER OF REAL. 
* 
*         ENTRY  (X2) = FLOATING POINT VALUE. 
* 
*         EXIT   IF VALUE IS AN EXACT INTEGER --
*                (X6) .ZR.
*                (X2) = IFIX (VALUE). 
*                (X7) = OPERAND FOR IFIX (VALUE). 
* 
*         ELSE   (X6) .NZ. = VALUE IS NOT EXACT INTEGER.
*                (X2) PRESERVED.
* 
*         USES   ---
*         CALLS  NCS. 
  
  
 LIR10    =X6    1
  
 LIR      SUBR   =           ENTRY/EXIT...
          UX0,B2 X2 
          LX6    B2,X0
          PX7    X6 
          NX7 
          IX0    X7-X2
          NZ     X0,LIR10    IF NOT EXACT INTEGER 
  
          =X7    M.INT
          SA6    LVEC 
          RJ     NCS         CREATE OPERAND 
          SA2    LVEC 
          BX7    X6 
          MX6    0
          EQ     EXIT.
 NBC      SPACE  4,10 
**        NBC -  ENTER BINARY CONSTANT. 
* 
*         ENTRY  (X1) = MODE OF CONSTANT. 
*                (X6) = UPPER HALF OF CONSTANT. 
*                (X7) = LOWER HALF OF CONSTANT, IF DBL OR CPLX. 
* 
*         EXIT   (X6) = OPERAND REPRESENTING CONSTANT.
* 
*         USES   ALL BUT  A0,A5  X5  B4,B5,B6.
*         CALLS  NCM, NCS.
  
  
 NBC      SUBR   =           ENTRY/EXIT...
          =B2    X1-M.DBL 
          PL     B2,NBC4     IF MULTI-WORD CONSTANT 
          ERRMI  M.CPLX-M.DBL 
          ERRMI  M.CHAR-M.DBL 
  
          SX7    X1 
          CALL   NCS         ENTER SINGLE-WORD CONSTANT 
          EQ     EXIT.
  
*         HERE IF DOUBLE WORD CONSTANT
  
 NBC4     SA6    NBCA        SAVE (NBCA+0, +1) = CONSTANT VALUE 
          SB7    B0          (B7) = ADD IF NOT FOUND
          SA7    A6+B1
 .TEST    IFEQ   TEST,ON
          SB2    X1-M.CHAR
          ZR     B2,"BLOWUP"       IF TYPE CHARACTER -- NFG 
 .TEST    ENDIF 
          SB2    A6          (B2) = FWA VALUE 
          BX6    X1 
          =A6    A7+1        REMEMBER (NBCA+2) = MODE OF CONSTANT 
          SA1    T.CON
          SB3    B2+2        (B3) = LWA+1 OF VALUE
          CALL   NCM         ENTER CONSTANT MULTIPLE
          SA1    S=CON
          SX6    B7 
          LX1    TP.ORDP
          LX6    TP.BIASP    ACTUAL CONSTANT ORDINAL IN BIAS
          SA3    NBCA+2 
          BX2    X1+X6
          LX3    TP.MODEP 
          BX6    X2+X3       OPERAND = SYMORD(CON.) + BIAS + MODE 
          EQ     EXIT.
  
 NBCA     BSS    2           CONSTANT VALUE 
          BSS    1           CONSTANT MODE
 NCS      SPACE  4,20 
**        NCS -  SCAN / ENTER SINGLE WORD CONSTANT INTO CONSTANT TABLE. 
* 
*         CONSTANT TABLE IS SCANNED TO CHECK IF CONSTANT IS ALREADY IN
*         TABLE.  IF SO, ADDS IN REQUESTED MODE BITS AND EXITS. 
* 
*         ENTRY  (X6) = CONSTANT VALUE TO ENTERED.
*                (X7) = MODE OF CONSTANT. 
* 
*         EXIT   (X6) = *TP* ORDINAL FORM OF CONSTANT.
*                       BIAS FIELD CONTAINS SHORT CONSTANT. 
* 
*         USES   A1-3,6-7   X0-3,6-7   B2-3,7.
* 
*         CALLS  ADW,SCT
  
  
 NCS      SUBR   =           ENTRY/EXIT...
 .T       IFEQ   TEST,ON
          SB2    X7-M.DBL 
          PL     B2,"BLOWUP" IF DOUBLE OR COMPLEX OR CHARACTER
          ERRMI  M.CHAR-M.DBL 
 .T       ENDIF 
          BX2    X6 
          AX2    TP.SHRTB-1 
          NZ     X2,NCS10    IF UPPER BITS NOT ALL SAME 
          MX0    -TP.BIASL
          BX6    -X0*X6 
          LX6    TP.BIASP    SHORT CONSTANT TO BIAS FIELD 
          CLAS=  X1,TP,(SHRT) 
          BX2    X6+X7       MERGE MODE 
          IX6    X2+X1
          EQ     EXIT.
  
 NCS10    LX7    TP.MODEP 
          SA7    NCSA        SAVE MODE
          SCAN   T.CON,SCT   SCAN CONSTANT TABLE
          SX3    B7 
          PL     B7,NCS20    IF CONSTANT IN TABLE 
          ADDWD  A1          ENTER CONSTANT 
          =X3    X2-1 
 NCS20    SA1    S=CON
          SA2    NCSA 
          LX1    TP.ORDP
          BX6    X1+X2       CON. SYMBOL ORDINAL
          LX3    TP.BIASP 
          BX6    X3+X6       ACTUAL CONSTANT ORDINAL IN BIAS
          EQ     EXIT.
  
 NCSA     EQU    NBCA        MODE OF CONSTANT 
 SED      TITLE  DATA STATEMENT INTERPRETER 
 SED      EJECT 
**        SED - SIMULATE EXECUTION OF DATA STATEMENT TURPLES. 
*         CALLED BY *DATA* AFTER PARSING OF DATA STATEMENT VARIABLE LIST
*         *SED* INTERPRETIVELY SCANS PARSE OUTPUT IN T.DAR AND
*         CALLS *EDI* FOR EACH ITEM.
 DV.      SPACE  4,8
          DESCRIBE DV.,60    DATA VARIABLE VALUE TABLE (T.DVV)
 VAL      DEFINE 24          CURRENT VALUE OF VARIABLE
          DEFINE 18 
 PNT      DEFINE 18          INDEX TO WORD C OF SYMTAB ENTRY
          SPACE  4,8
 HEREFOR  MACRO  SKEL 
          IRP    SKEL 
 D=SKEL   BSSENT 0
          IRP 
 HEREFOR  ENDM
 SED      SPACE  4,8
 SED      SUBR   =
          SX6    0
          SA6    SED.ERR
          SA6    SEDTURP     I=0
          SHRINK T=DVV,0
  
          HEREFOR (NOOP,ARY,SUBST,COLON,BSS,DOBD2)
 SED.RTN  BSS    0
  
          SA1    SEDTURP
          SA2    T=DAR
          SX6    X1+3        I = I + 1
          IX0    X2-X6
          MI     X0,SED.END  IF I = (T=DAR) 
          SA2    T.DAR
          SA6    A1 
          =B3    X2+OR.1OP
          IX0    X1+X2
          =A1    X0+OR.OPR
          SB5    X0 
          MX0    -TH.SKELL
          LX1    -TH.SKELP
          BX6    -X0*X1 
          SA4    F.SCT+X6    TURPLE CONTROL WORD FOR THIS TURPLE
          LX4    -VS.DRAP 
          SB7    X4 
          ERRNZ  18-VS.DRAL 
          MI     B7,SED10    IF NO *HEREFOR*
          JP     B7          GO TO APPROPRIATE *HEREFOR*
  
 SED10    LX4    VS.DRAP-VS.CRAP
          SX7    X4 
          ERRNZ  18-VS.CRAL 
          ZR     X7,SED15    IF NOT REDUCIBLE, ERROR
          =A4    A1+OR.1OP-OR.OPR 
          =A5    A4+OR.2OP-OR.1OP 
          RJ     CDR         CONSTANT-REDUCE TURPLE 
  
*         STORE CONSTANT-VALUE IN TURPLE HEADER.
  
 SED.STO  MX0    -TH.DVALL
          BX6    -X0*X6 
          SA1    SEDTURP
          SA2    T.DAR
          IX7    X1+X2
          =A1    X7-3+OR.OPR
          LX1    -TH.DVALP
          BX1    X0*X1       CLEAR DVAL 
          BX7    X6+X1       INSERT VALUE 
          LX7    TH.DVALP 
          CLAS=  X1,TH,(DDEF) 
          BX7    X7+X1       INDICATE DATA DEFINED
          SA7    A1 
          EQ     SED.RTN
  
 SED15    SA0    E.DSE       ** SYNTAX ERROR IN DATA STATEMENT
          =X0    1
  
  
*         ERROR IN INTERPRETIVE SCAN.  TERMINATE PROCESSING.
  
 SED.ABT  SX6    1
          SA6    SED.ERR
  
*         PLACE SYM[WA(X0)] IN FILL.
  
          SA1    T.SYM
          LX6    B1,X0
          IX7    X0+X6
          =B6    X1+WA.W
          SA1    B6+X7
          HX1    WA.SYM 
          MX0    WA.SYML
          BX6    X0*X1
          SA6    FILL.
          SB7    A0 
          FATAL  B7 
  
*         END OF INTERPRETIVE SCAN. 
  
 SED.END  SA1    T=DVV
          SA5    SED.ERR
          SA2    T.DVV
          SA3    T.SYM
          MX0    WC.DVPL
          SB5    X3 
          SB6    X1 
          LX0    WC.DVPL+WC.DVPP
          SHRINK T=DVV,0
  
*         CLEAR WC.DVP OF ENTRIES USED. 
  
 SED20    ZR     B6,EXIT.    IF T. EXHAUSTED
          =B6    B6-1 
          SA4    X2+B6
          LX4    -DV.PNTP 
          SA1    B5+X4
          ERRNZ  DV.PNTL-18 
          BX7    -X0*X1 
          SA7    A1 
          EQ     SED20
  
 SEDTURP  BSS    1
 SED.ERR  BSS    1           ERROR FLAG 
 CDR      EJECT 
**        CDR - COMPUTE CONSTANT REDUCTION IN *SED*.
* 
*         ENTRY  (X4) = 1OP 
*                (X5) = 2OP 
*                (X7) = CONSTANT REDUCTION ADDRESS
* 
*         EXIT   (X6) = CONSTANT VALUE
  
 CDR      SUBR
          SA7    CCRA 
          BX1    X4 
          RJ     LCD         LOAD 1OP 
          SA6    LVEC 
          BX1    X5 
          ZR     X5,CDR10    IF 2OP NIL 
          RJ     LCD         LOAD 2OP 
          SA6    LVEC+1 
  
 CDR10    SA3    CCRA 
          RJ     CTA         CONSTANT REDUCE TURPLE 
 .T       IFEQ   TEST,ON,1
          ZR     X6,"BLOWUP" IF NOT REDUCIBLE 
          BX1    X6 
          RJ     LCT         GET CONSTANT VALUE 
          SA1    SEDTURP
          SA2    T.DAR
          IX0    X1+X2
          SB5    X0-3        RESTORE TURPLE POINTER 
          EQ     EXIT.
 LCD      SPACE  4,10 
**        LCD - LOAD CONSTANT FOR *SED*.
*         LCD LOADS A DATA INTERPRETATION CONSTANT VALUE, WHICH 
*         MAY BE A CONSTANT OR THE CURRENT VALUE OF AN INTERPRETED
*         TURPLE OR LOOP/INDEX VARIABLE.
  
 LCD      SUBR
          BX6    X1 
          SA6    LCDA 
          LX6    -TP.MODEP
          MX0    -TP.MODEL
          BX0    -X0*X6 
          SA0    E.DVR4      NOT INTEGER
          SB2    X0-M.INT 
          ZR     X0,LCD5     IF BOOLEAN 
          ERRNZ  M.BOOL 
          NZ     B2,SED.ABT  OF NOT INTEGER 
  
 LCD5     LX6    TP.MODEP-1-TP.INTRP
          MI     X6,LCD10    IF INTERMEDIATE
          RJ     LCT         TRY TO LOAD CONSTANT 
          NZ     B2,EXIT.    IF CONSTANT
  
*         LOAD CURRENT VALUE OFLOOP/INDEX VARIABLE. 
  
          SA1    LCDA 
          SA2    T.SYM
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX6    -X0*X1 
          SB7    X2+WC.W
          LX7    B1,X6
          IX0    X6+X7
          SA2    X0+B7       WORD C OF VAR
          SA1    T.DVV
          LX2    -WC.DVPP 
          SB2    X2-1 
          SA2    X1+B2
          SX0    X6          ORD
          SA0    E.DVR1      VARIABLE FILL. NOT DO INDEX
          MI     B2,SED.ABT  IF NOT STORED INTO 
          ERRNZ  WC.DVPL-18 
          HX2    DV.VAL 
          AX2    -DV.VALL 
          BX6    X2 
          EQ     EXIT.
  
*         GET VALUE OF INTERMEDIATE FROM TURPLE HEADER. 
  
 LCD10    LX1    -TP.ORDP 
          MX0    -TP.ORDL 
          SA2    T.DAR
          BX6    -X0*X1 
          =B2    X2+OR.OPR
          SA1    B2+X6
          CLAS=  X2,TH,(DDEF) 
          BX2    X2*X1
          SA0    E.DSE
          =X0    1
          ZR     X2,SED.ABT  IF NOT YET DEFINED 
          HX1    TH.DVAL
          AX1    -TH.DVALL
          BX6    X1 
          EQ     EXIT.
  
 LCDA     BSS    1
 DVI      EJECT 
          HEREFOR DVI 
          =A2    B5+OR.1OP
          BX1    X2 
          HX2    TP.INTR
          PL     X2,DVI10    IF NOT INTERMEDIATE
          LX2    TP.INTRP-TP.ARYP 
          MI     X2,DVI10    IF ARRAY 
  
*         PROCESS SUBSTRING.
  
          LX1    -TP.ORDP 
          MX0    -TP.ORDL 
          BX6    -X0*X1 
          SA1    B3+X6       1OP
          SA6    DVIA 
          RJ     EDS         EVALUATE DATA SCALAR 
          SA2    DVIA 
          =B4    X2+OR.2OP-OR.1OP 
          SA6    A2          SAVE WC OF BASE
          SA1    B4+B3       2OP
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX6    -X0*X1 
          SA1    B3+X6       COLON 1OP
          =X7    X6+OR.2OP-OR.1OP 
          SA7    DVIB 
          SB4    B7 
          RJ     LCD         GET SUBSTRING START
          BX3    X6 
          SA1    DVIB 
          SA1    B3+X1       COLON 2OP
          RJ     LCD         GET SUBSTRING END
          SA2    DVIA 
          BX4    X6 
          BX6    X2 
          SB7    B4 
  
*         CHECK SUBSTRING START AND END FOR VALIDITY. 
  
          =X0    1
          IX1    X3-X0
          IX2    X4-X0
          BX7    X1+X2       MI IFF EITHER NOT POSITIVE 
          SA1    CLEN        SET BY EDS 
          IX0    X4-X3       MI IFF START GT END
          BX0    X0+X7
          IX2    X1-X3       MI IF START GT CLEN
          BX0    X0+X2
          BX2    X0+X1
          SX0    B6 
          SA0    E.AT16      INVALID SUBSTRING
          MI     X2,SED.ABT  IF INVALID SUBSTRING 
          CALL   ECS         EVALUATE SUBSTRING 
          EQ     DVI20
  
 DVI10    RJ     EDS         EVALUATE SCALAR
  
 DVI20    BX4    X6          PRESERVE X6
          SX6    B7 
          SA6    DVIC        PRESERVE B7
          SX0    B6          PRESERVE B6
          CALL   CT1         GET OPERAND OF VARIABLE
          SB6    X0          RESTORE B6 
          BX5    X6 
          CALL   DOA         DETERMINE OPERAND ADDRESSABILITY 
          SX0    B6          X0 = SYMORD FOR POSSIBLE ERROR 
          ZR     X6,DVI30    IF NOT INVALID STORE TARGET
          FATAL  E.DVL1 
          EQ     SED.END
  
**        CHECK FOR IMPROPER CLASS OF THE REFERENCED SYMBOL.
*         SET DEFINED AND VAR BITS IN SYMTAB ENTRY. 
  
 DVI30    CLAS=  X3,WB,(FP,NVAR,LAB,PARM) 
          BX3    X3*X2
          SA0    E.DAUC 
          NZ     X3,SED.ABT  IF USEAGE CONFLICT 
          CLAS=  X7,WB,(DEF,VAR)
          BX6    X7+X2       MERGE BITS 
          SA6    A2          UPDATE *WB*
  
**        CHECK FOR VARIABLE IN BLANK COMMON OR LOCAL 
*         VARIABLE IN BLOCK DATA PROGRAM UNIT.
  
          =A1    A2-WB.W+WC.W 
          HX2    WB.COM 
          PL     X2,DVI40    IF NOT IN COMMON 
          MX6    -WC.RBL
          LX1    -WC.RBP
          SA3    BLNKCOM
          BX6    -X6*X1      ISOLATE BLOCK NUMBER 
          IX6    X6-X3
          SA0    E.DABC 
          ZR     X6,SED.ABT  IF IN BLANK COMMON 
          SA3    MOD
          HX3    MO.BLK 
          MI     X3,DVI50    IF IN BLOCK DATA 
          ANSI   E.ANS6      ** COMMON PRESET IN BLOCK DATA ONLY
          EQ     DVI50
  
 DVI40    SA3    MOD
          HX3    MO.BLK 
          SA0    E.DABL 
          MI     X3,SED.ABT  IF BLOCK DATA LOCAL VAR
  
 DVI50    BX1    X4 
          SA2    DVIC 
          SA3    COUNT
          SB7    X2 
          BX6    X3 
          CALL   EDI         FILE ADDRESS/COUNT 
          EQ     SED.RTN
  
 DVIA     BSS    1
 DVIB     BSS    1
 CLEN     BSS    1
 COUNT    BSS    1
 DVIC     BSS    1
 EDS      SPACE  4,8
**        EDS - EVALUATE SCALAR FOR DATA. 
* 
*         PRESERVES B3,B5 
  
 EDS      SUBR
          BX3    X1 
          SA1    B5+OR.2OP
          RJ     LCD         GET NUMBER OF ELEMENTS (COUNT) 
          SA6    COUNT
          BX1    X3 
          BX2    X1 
          MX6    0
          HX2    TP.INTR
          PL     X2,EDS10    IF NOT ARRAY 
          LX2    TP.INTRP+1-TP.ORDP 
          MX0    -TP.ORDL 
          BX6    -X0*X2 
          =B6    X6+OR.2OP-OR.1OP 
          SA1    B3+B6
          RJ     LCD         GET INDEX
          =B6    B6+OR.1OP-OR.2OP 
          SA1    B3+B6
  
 EDS10    BX2    X1 
          HX1    TP.BIAS
          AX1    -TP.BIASL
          MX0    -TP.ORDL 
          LX2    -TP.ORDP 
          BX2    -X0*X2      ARRAY ORD
          IX5    X1+X6       BIAS = BIAS + INDEX
          BX7    X5 
          SA7    EDSA        SAVE INDEX 
          SA3    T.SYM
          SB6    X2          ORD FOR CALLER 
          SB2    X3 
          CALL   ECB         EVALUATE CONSTANT BIAS 
  
*         CHECK VALIDITY OF INDEX AND NUMBER OF ELEMENTS. 
  
          RJ     GPS         GET PRODUCT OF SPANS AND CLEN
          SA7    CLEN 
          SA2    EDSA        INDEX
          SA4    COUNT
          AX3    B2,X2       INDEX IN ELEMENTS
          IX0    X3+X4       INDEX + 1 OF LAST ELEMENT
          IX7    X1-X0       MI IFF LAST ELEMENT EXCEEDS SPAN 
          BX7    X3+X7       ALSO MI IF FIRST ELEMENT BELOW SPAN
          SX0    B6 
          SA0    =XE.DVR2    FILL. SUBSCRIPT OUTSIDE ARRAY BOUNDS 
          MI     X7,SED.ABT  IF INVALID REF.
          EQ     EXIT.
  
 EDSA     BSS    1
 GPS      SPACE  4,8
**        GPS - GET PRODUCT OF SPANS AND CLEN.
* 
*         ENTRY  B6 = SYMTAB ORD
* 
*         EXIT   X1 = PRODUCT OF SPANS IN ELEMENTS
*                X2 = DITTO IN WORDS
*                X7 = CLEN (0 IF NOT CHAR)
*                B2 = 1 IF MODE = DOUBLE OR COMPLEX, ELSE 0 
* 
*         PRESERVES B3,B5,B6,B7,X6
  
 GPS      SUBR   =
          SA1    T.SYM
          SX2    B6 
          =B2    X1+WB.W
          LX7    B1,X2
          IX2    X7+X2
          SA1    X2+B2       WB 
          SA2    T.DIM
          MX0    -WB.PNTL 
          SB2    X2 
          LX1    -WB.PNTP 
          BX7    -X0*X1 
          SA2    X7+B2
          MX0    -DH.PSL
          LX2    -DH.PSP
          LX1    WB.PNTP-WB.MODEP-1 
          MX3    -WB.MODEL+1
          BX3    -X3*X1      MODE/2 
          BX1    -X0*X2      PRODUCT OF SPANS IN ELEMENTS 
          =B2    1
          AX2    B2,X1
          SX7    X3-M.DBL/2 
          ZR     X7,EXIT.    IF DOUBLE OR COMPLEX (DEPENDS ON M.DBL/2 = 
          =B2    0
          MX7    0
          BX2    X1 
          SX0    X3-M.CHAR/2
          NZ     X0,EXIT.    IF NOT CHAR (DEPENDS ON NO TYPE = M.CHAR+1)
          =A3    A1+WC.W-WB.W 
          MX0    -WC.CLENL
          LX3    -WC.CLENP
          BX7    -X0*X3 
          BX3    X1 
          CW     X2,X3
          EQ     EXIT.
 EXP.I    SPACE  4,8
**        EXP.I - EXPONENTIAL TURPLE. 
*         EXPANSION OF I**J HAS BEEN DEFERRED UNTIL NOW WHEN I AND J
*         ARE KNOWN.
  
          HEREFOR EXP.I 
          SA1    B5+OR.2OP   EXPONENT 
          RJ     LCD         GET VALUE
          SA6    EXPA 
          SA1    B5+OR.1OP
          RJ     LCD         GET BASE VALUE 
          SA1    EXPA 
          CALL   EXD         EXPAND AND GET VALUE OF I**J 
          BX1    X6 
          RJ     LCT
          EQ     SED.STO     PLACE VALUE IN HEADER AND CONTINUE 
  
 EXPA     BSS    1
 STR.I    EJECT 
          HEREFOR STR.I 
  
*         SIMULATE STORE TURPLE BY FILING VAL(1OP) IN DVV(2OP)
  
          =A1    B5+OR.1OP
          RJ     LCD         GET RIGHT HAND VALUE 
          BX5    X6 
          SA2    B5+OR.2OP   GET TARGET TAG 
          RJ     SDV         STORE DATA VALUE 
          EQ     SED.RTN
 SDV      SPACE  4,8
**        SDV - STORE DATA VALUE. 
* 
*         ENTRY  (X2) = OPERAND OF TARGET 
*                (X5) = VALUE TO BE STORED
  
 SDV      SUBR
          LX2    -TP.ORDP 
          MX0    -TP.ORDL 
          BX6    -X0*X2 
          SB6    X6 
          SA1    T.SYM
          SB7    B6+B6
          SX1    X1+WC.W
          SB7    B7+B6
          SA1    X1+B7       WC OF TARGET 
          SA2    T.DVV
          MX0    -WC.DVPL 
          SB2    X2-1 
          LX1    -WC.DVPP 
          BX7    -X0*X1 
          BX2    X0*X1
          SA3    B2+X7       DVV(DVP) 
          SX6    B7+WC.W
          LX6    DV.PNTP
          NZ     X7,SDV10    IF ALREADY IN DVV
          SA3    T=DVV
          =X7    X3+1 
          BX7    X2+X7
          LX7    WC.DVPP
          SA7    A1          INCLUDE POINTER TO DVV ENTRY IN WC 
          ADDWD  T.DVV
          SA3    A6 
  
 SDV10    MX0    -DV.VALL 
          BX5    -X0*X5 
          LX5    DV.VALP
          BX6    X5+X6
          SA6    A3          VAL[DVV(TARGET)] = VALUE 
          EQ     EXIT.
 DO       EJECT 
          HEREFOR (DOBS,DOBL,DOBZS,DOBZL) 
  
*         PLACE SIMULATED DO-TOP ADDRESS (NEXT TURPLE) IN 
*         WC.BRAD OF DO.N . 
  
          SA3    B5+7 
          SA4    T.SYM
          SA2    SEDTURP
          LX3    -TP.ORDP 
          MX0    -TP.ORDL 
          LX2    WC.BRADP 
          BX6    -X0*X3 
          SB7    X4+WC.W
          LX7    B1,X6
          IX0    X6+X7
          SA1    B7+X0       WORD C OF DO.N FOR THIS LOOP 
          BX7    X2+X1
          SA7    A1          INSTALL BRANCH ADDRESS 
  
*         SET ITERATION COUNT  (DC.N = # OF TRIPS)
  
          SA1    B5+OR.2OP   NUMBER OF TRIPS
          RJ     LCD         LOAD VALUE 
          =A5    B5+OR.1OP
          MX0    -TP.ORDL 
          LX5    -TP.ORDP 
          BX0    -X0*X5      ORD OF CONTROL VARIABLE (1OP)
          SA0    E.DVR3      TRIP COUNT OF FILL. MUST BE POSITIVE 
          =X5    1
          IX5    X6-X5
          MI     X5,SED.ABT  SET B7 AND FILL. ORD 
          BX5    X6 
          SA2    B5+4        DC.N TAG 
          RJ     SDV         STORE VALUE IN DC.N
          EQ     SED.RTN
 DOEND    SPACE  4,8
          HEREFOR (DOC.S,DOC.L) 
  
*         INCREMENT I = I + M3. 
  
          =A1    B5+OR.1OP
          =A3    A1+OR.2OP-OR.1OP 
          RJ     LCD         GET I (1OP)
          BX1    X3 
          BX3    X6 
          RJ     LCD         GET M3 (2OP) 
          IX5    X3+X6
          SA2    B5+OR.1OP
          RJ     SDV         STORE NEW I
          SA1    SEDTURP
          SA2    T.DAR
          IX0    X1+X2
          SA1    X0-3+5      DC.
          BX3    X1 
          RJ     LCD         GET TRIP COUNT 
          =X0    1
          IX5    X6-X0       DC. = DC. - 1
          ZR     X5,SED.RTN  IF DC. = 0  */ LOOP EXHAUSTED
*         CLEAR WC.DVP[L1]  (I) WHEN EXHAUSTED
          BX2    X3 
          RJ     SDV         STORE NEW DC.
  
*         RESET SEDTURP TO BRAD[DO.] TO SIMULATE BRANCH-BACK. 
  
          SA1    SEDTURP
          SA2    T.DAR
          IX0    X1+X2
          =A1    X0-3+4      DO. OPERAND
          SA2    T.SYM
          LX1    -TP.ORDP 
          MX0    -TP.ORDL 
          BX6    -X0*X1 
          SB7    X2+WC.W
          LX7    B1,X6
          IX0    X6+X7
          SA1    B7+X0       WC OF DO.
          LX1    -WC.BRADP
          SX6    X1 
          ERRNZ  WC.BRADL-18
          SA6    SEDTURP
          EQ     SED.RTN
 END      SPACE  4,10 
          LIST   D
          END 
