*DECK     PAR - EXPRESSION TRANSLATION. 
          IDENT  PAR
 PAR      SECT   (EXPRESSION TRANSLATION.)
 PAR      SPACE  4
***       PAR - EXPRESSION TRANSLATION. 
* 
*         PAR TRANSLATES FORTRAN EXPRESSIONS INTO INTERMEDIATE LANGUAGE 
*         TURPLES, OR, WITH THE HELP OF CONRED, CONSTANT EXPRESSIONS ARE
*         SOMETIMES REDUCED TO A SIMPLE OPERAND.  THIS DECK IS ORGANIZED
*         AS FOLLOWS -- 
* 
*         CNF - COMPILE ASSIGNMENT STATEMENT. 
*         PIX - PARSE/REDUCE INTEGER CONSTANT EXPRESSION. 
*         PARSER CONTROL TABLES.
*         PAR - OPERATOR PRECEDENCE PARSER. 
*                PARSE/ANALYZE NEXT ELEMENT.
*                PARSE/ANALYZE CONSTANT ELEMENT.
*                PARSE/ANALYZE SYMBOLIC ELEMENT.
*                PARSE/ANALYZE NEXT SEPARATOR.
*         POP - SYNTHESIZE SEMANTICS. 
*                POP/EMIT SIMPLE OPERATORS. 
*                POP/EMIT SUBSTRING.
*                POP/EMIT DO LOOP INDICIES. 
*                POP/EMIT EXPONENTIATION. 
*                POP/EMIT APLIST AND FUNCTION REFERENCE.
*                POP/EMIT ARRAY SUBSCRIPTS. 
*         SUBROUTINES.
  
  
*         IN ALLOC
          EXT    ADW,ALC,ALC.REG,ALC.STF,ALC.00 
  
*         IN CONRED 
          EXT    CCR,DEC,KCV,LCH,LCT,LIR,NBC,NCS,OCT,PCC
          EXT    PCR,PCR.1OP,PCR.2OP,PCR.RO 
  
*         IN DATA 
          EXT    CFC,C=DVL,DAT.Z
  
*         IN DECL 
          EXT    A=DBD,CDBB,C=DBD,DIRT,KW=COMM
  
*         IN FEC
          EXT    ARGCOMA,ARGMIS,ARGMODE,BBC,CALLTAG,CHARMAP,CT1,DATFLG
          EXT    ERT,ESTACK,ESY,FEC=EXU,INSTF,LDEAD,NCS,OSTACK,PARMODE
          EXT    REFVAR,SLT,SSY,STAGE,STY,TLV,TSX,ZLE,ZLEQUAL 
  
*         IN FERRS
          EXT    DO.DPC,E.AT01,E.AT02,E.AT03,E.AT04,E.AT05,E.AT06,E.AT07
          EXT    E.AT08,E.AT09,E.AT10,E.AT13,E.AT14,E.AT15,E.AT16,E.AT17
          EXT    E.AT18,E.AT19,E.AT20,E.AT21,E.ANS4,E.ANS5,E.DC1
          EXT    E.DC4,E.DM01,E.DM11,E.DM14,E.DM17,E.DM18,E.DM21,E.DO00 
          EXT    E.DO02,E.DO04,E.DO15,E.DO16,E.DVL1,E.DO17,E.DVR5 
          EXT    E.INF,E.INF1,E.INF2,E.INF3 
          EXT    E.LP1,E.LP2,E.LP3,E.LV11,E.PX1,E.PX5,E.PX6,E.PX7 
          EXT    E.SB2,E.SB3,E.SB4,E.SB5,E.SB6,E.SB7,E.SF09,E.SF10
          EXT    E.SU01,E.SU02,E.SU03,E.SU05,E.SU07,E.SU08,E.SU09,E.SU10
          EXT    E.SU11,E.TY2,E.TY4,E.TY9,E.VA01,E.VA03,E.VA04,E.VA05 
          EXT    E.VA06,E.VA07,E.VA08,E.VA11,E.VA12,E.VA13
          EXT    E.XP1,E.XP3,E.XP4,E.XP5,E.XP6,E.XP7,E.ZEMT 
          EXT    E.MDE5,ERL=CON,ERL=XPR,FILL.,FILL.2,FILL.3,MOD.DPC,OSE 
          EXT    E.SF13,E.SF15
          EXT    E.AT11 
  
*         IN FLINK
          EXT    MDD,PDC
  
*         IN FSNAP
          EXT    SN.EMT,SN.PAR
  
*         IN FTN
          EXT    COD,CO.ANSI,CO.DBSB,CO.DBTB,CO.RNDD,CO.RNDM,CO.SNAP
          EXT    CO.DOLG
  
*         IN IDP
          EXT    REG=,RSR=,SNP=,SV=B,SVR= 
  
*         IN IO 
          EXT    A=BLWA,A=BMOD,A=DOCI,A=DOCS,A=FMT,A=ICC,A=ICCX,A=ICI 
          EXT    A=ICIX,A=ICL,A=STR,A=UNT,CML,C=BFWA,C=CNT,C=DOCI,C=DOCS
          EXT    C=FMT,C=ICC,C=ICCX,C=ICI,C=ICIX,C=ICL,C=IOL,C=UNT,IDCEX
          EXT    A=FOU,C=FOU,IODIR,IOJ
  
*         IN KEY
          EXT    CRL,C=PJX,IFMOD,IFREL2,IFRESLT 
  
*         IN LABEL
          EXT    CDIFLG,DDR,DOMODE,ISL,PDA,PSL
  
*         IN LEX
          EXT    TB=TYPE,TB=1ST 
  
*         IN PEM
          EXT    ANSI=,MDERR=,PDM 
  
*         IN PUC
          EXT    CONONE,CONZER,GCL,MOD,N.CT,SCR,S=BU,S=CON,S=CT,S=RD
          EXT    S=VALUE,S=VD,T=ARG,T=BLST,T=DIM,T=ILI,T=IOARG,T=PAR
          EXT    T=SLARG,T=SYM,T.ARG,T.BLST,T.CON,T.DIM,T.IOARG,T.PAR 
          EXT    T.SLARG,T.STF,T.SYM,T.TB,VTRUE,WOF,WO.CS,WO.DOLG 
          EXT    NSQZLH,T.PCS,T=PCS 
          EXT    CONZERI
  
*         IN QSKEL/FSKEL
          EXT    F.IMCV,F.INTF,F.MODC,F.SKCR,F.SKNAM
          EXT    OMI=CPX,OMI=LCF,OMI=LEN,OM=ADD,OM=AND,OM=CONV,OM=DIV 
          EXT    OM=DOC,OM=EQ,OM=EQV,OM=GE,OM=INL,OM=LT,OM=MUL,OM=NE
          EXT    OM=NOT,OM=OR,OM=STR,OM=SUB,OM=UMI,OM=XOR,V=ADD.I 
          EXT    V=APIOC,V=APIOD,V=APIOU,V=ARY,V=BSS,V=CAT,V=CMPLX
          EXT    V=COLON,V=DOBL,V=DOBS,V=DOBZL,V=DOBZS,V=DVC.R,V=DVI
          EXT    V=ERR,V=EXP.I,V=FAP,V=FUNC,V=GAP,V=GPL,V=IAP,V=INT 
          EXT    V=INTF,V=LGE,V=LIBF,V=LLT,V=MASK,V=MUL.C,V=MUL.D 
          EXT    V=MUL.I,V=MUL.R,V=NOOP,V=NOT.L,V=RANF,V=SHIFT,V=STR.H
          EXT    V=STR.I,V=SUBST,V=SUB.I,V=UMI.I,V=XMIT,Z.IMCV,Z.INTA 
          EXT    Z.INTF,Z.SKCR
  
*         IN UTILITY
          EXT    MVE= 
 POEM     SPACE  4,10 
**        GENERAL COMMENT TO THOSE WHO GET THIS FAR --
* 
*         I THINK THAT I SHALL NEVER SEE
*         A SUBROUTINE THAT WORKS FOR ME
*         A MACRO OR ZERO TEST
*         THAT ISNT JUST A RODENTS NEST 
*         A STRING THAT DOESNT ALWAYS STRAY 
*         AND MIX UP BITS IN WILD ARRAY 
*         A PROCESS WITH RE-ENTRANT FLAIR 
*         THAT ISNT JUST A LOOPING SNARE
*         ROUTINES WHOSE TIMINGS ARE NOT SLAIN
*         WHEN INTERRUPTS BEGIN TO RAIN 
*         ONLY GOD CAN MAKE A TREE
*         BUT, BUGS ARE MADE BY GUYS LIKE ME. 
* 
*         TRADITIONAL.
 MISS     SPACE  4,10 
          MACRO  PARSNAP,NAME 
 NAME     REG 
 OPSTACK  CORE   OSTACK,8 
 ELSTACK  CORE   ESTACK,8 
 ARGCMOM  CORE   ARGCOMA,3
          ENDM
 MICROS   SPACE  4,10 
**        BITMASK MICROS. 
  
  
 M.OKINT  BITMIC (M.BOOL,M.INT) 
 M.OKDO   BITMIC (M.BOOL,M.INT,M.REAL,M.DBL)
 M.OKDOC  BITMIC (M.INT,M.REAL,M.DBL) 
 M.OKNUM  BITMIC (M.BOOL,M.INT,M.REAL,M.DBL,M.CPLX) 
          SPACE  4,10 
**        MISCELLANEOUS CELLS USED BY PARSER. 
  
  
 PARPA    EQU    SCR         *TREX* PRESERVES PROCESSOR ADDRESS HERE
 PARNOW   BSSENT 1           ACTIVE VALUE OF (PARMODE)
 ATTR     CON    0           ATTRIBUTES PER TRE 
 SMOD     BSSENT 1           SUB-EXPRESSION DOMINANT MODE 
 SOPR     BSSENT 1           MODE CONVERSION OPERATOR 
 CURST    BSSENT 1           LOW LIMIT (T.PAR) INDEX FOR SQUEEZE
 LASTOP   CON    0           SET = TO LAST OPERATOR IN PARSED FILE UPON 
                             ENTRY TO POP.
 LASTAD   CON    0           SET = TO LAST ADDRESS OF PARSE FILE UPON 
                             ENTRY TO POP.
 POPDPC   BSS    2           DPC FOR OPERATOR CAUSING POP 
 POPPER   EQU    POPDPC+1    OPERATOR (SETOP) WORD FOR *POPDPC* 
  
 LASTREL  BSS    1           OPERATOR OF LAST RELATIONAL POPPED 
 CMLFLG   BSS    1           I/O RESTART CALLS INDICATOR
  
 CSYMBOL  CON    0LSYMBOL    CURRENTLY BEING ANALYZED 
 CSYTAG   BSS    1           (TP.) OPERAND FOR CURRENT SYMBOL 
 CSYREF   BSS    1           CURRENT SYMBOL NAME USED IN REF MAP
 CSYWB    CON    0           SYMTAB ATTRIBUTE WORD OF CURRENT SYMBOL
  
  
 TEMPS    BSS    3           SCRATCH CELLS FOR -- 
 TREB     EQU    TEMPS       1     PAR.VAR
 EXPA     EQU    TEMPS       1     POP.EXP
 EXPB     EQU    TEMPS+1     1
 EQLA     EQU    TEMPS       1     POP.EQL
 EQLB     EQU    TEMPS+1     1
 EQLC     EQU    TEMPS+2     1
 RELA     EQU    TEMPS       1     POP.REL
 MSPA     EQU    TEMPS       1     MSP
 SSRA     EQU    TEMPS       1     SSR
 VILA     EQU    TEMPS       1     VIL
 VILB     EQU    TEMPS+1     2     VIL
 CATA     EQU    TEMPS       1     POP.CAT
 CATB     EQU    TEMPS+1     1
  
 TER2     BSS    2           CAN HOLD CONSTANT 2OP
  
  
 FUNI     MACRO  FUNT,RJOP,SUFF,APOP
          VFD    12/2000B+MF.FUNT,18/RJOP,12/2000B+1R_SUFF,18/APOP
          ENDM
  
          BSS    1           WORKING COPY OF (FUNCALL(I)) 
 FUNCALL  FUNI   LIB,LIBOP,"XBYNAM",GAPOP 
          FUNI   BEF,INFOP,"XBYVAL",IAPOP 
          FUNI   LIB,LIBOP,"XUPNAM",GAPOP 
 CNF      EJECT  4,20 
**        CNF - COMPILE NORMAL FORMULA. 
  
  
 CNF      BSSENT 0           ENTRY... 
          SA1    ZLEQUAL
          =B4    X1+1        START AT RIGHT SIDE OF LAST *=*
          BX6    X1 
          SA6    ZLE         SET
          SA1    X1 
          AX1    TB.TOTL
          ERRNZ  TB.TOTP
          ZR     X1,CNF1     IF NO MULTIPLE ASSIGNMENT
          ANSI   E.AT09 
  
*         PARSE STATEMENT.
  
 CNF1     SA3    CNFARM 
          =X7    0
          LX6    X3 
          SA7    ARGCOMA
          SA6    ARGMODE
          RJ     PAR         PARSE STATEMENT
          EQ     PSL         EXIT.. 
          TITLE  PIX - PARSE INTEGER CONSTANT EXPRESSION. 
PIX       SPACE  4,10 
**        PIX -  PARSE INTEGER CONSTANT EXPRESSION. 
* 
*         ENTRY  (B4) _ FWA EXPRESSION IN TOKEN BUFFER. 
*                (B4)-1 _ A TOKEN WHICH WILL BE DESTROYED.
* 
*         EXIT   (X5) = OPERAND FOR EXPRESSION RESULT.
*                (X6) = VALUE OF EXPRESSION.
*                (X0) = ACTUAL MODE OF EXPRESSION.
*                (B4) _ SEPARATOR TOKEN WHICH TERMINATED EXPRESSION.
* 
*         USES   ALL. 
* 
*         CALLS  LCT, PAR, PDM. 
  
  
 PIX      SUBR   =           ENTRY/EXIT...
          SX7    B4 
          SA7    PIXB 
          SA3    PIXARM 
          =X6    PM=ICE      ALLOW ONLY INTEGER CONSTANT EXPRESSIONS
          SA6    PARMODE
          SA1    T=PAR
          BX6    X3 
          LX7    X1          REMEMBER OLD LENGTH OF (T.PAR) 
          SA6    ARGMODE
          SA7    PIXA 
          SB4    B4-B1       TOKEN BUFFER POINTER -> BEFORE EXPR
          BX6    0
          =X7    O.SLP       MARK EXPRESSION START BY SPECIAL LPAREN
          SA6    ARGCOMA
          SA7    B4 
          RJ     PAR         REDUCE THE EXPRESSION
          =X6    0
          SA6    PARNOW 
          SA3    PIXA 
          BX1    X5 
          SHRINK T=PAR,X3    DISCARD NON-CONSTANT PARTS OF EXPR 
          CALL   LCT
          ZR     B2,PIX8     IF RESULT NOT ARITHMETIC CONSTANT
          ZR     X0,EXIT.    IF RESULT MODELESS 
          =B2    X0-M.INT 
          ZR     B2,EXIT.    IF RESULT MODE INTEGER 
  
PIX8      SA5    PIXB 
          SX7    B4 
          SB4    X5          POINT TO BEGIN. OF EXPRESSION
          FATAL  E.PX1       FILL. NOT INTEGER CONSTANT EXPRES. 
          SB4    X7 
  
 PIX9     SA5    CONONE      RETURN RESULT AS INTEGER CONSTANT ONE
          SX6    B1 
          =X0    M.INT
          EQ     EXIT.
  
 PIXA     BSS    1           SAVES OLD PARSED FILE LENGTH 
 PIXB     BSS    1
 C=PIX    SPACE  4,10 
**        C/A =PIX - END OF INTEGER CONSTANT EXPRESSION.
  
  
 C=PIX    BSS    0           COMMA TERMINATED EXPRESSION
          SB4    B4+1 
  
 A=PIX    BSS    0           RIGHT PAREN TERMINATED EXPRESSION
          EQ     PAREXIT     EXIT.. 
 PKX      SPACE  4,10 
**        PKX -  PARSE CONSTANT EXPRESSION. 
* 
*         CALLS PARSER TO EVALUATE AN EXPRESSION, AND RESTRICTS 
*         THE RESULT TO BEING A CONSTANT.  IF THE RESULT IS A SHORT 
*         CONSTANT, ITS VALUE IS RETURNED.
* 
*         ENTRY  (B4) -> FWA EXPRESSION IN TOKEN BUFFER.
*                (B4)-1 -> A TOKEN WHICH WILL BE DESTROYED. 
*                (X6) = VALUE TO BE STORED INTO *PARMODE*.
* 
*         EXIT   (B4) -> SEPARATOR TOKEN WHICH TERMINATED EXPRESSION. 
*                (B5) = MODE OF EXPRESSION RESULT.
*                (B6) = CONSTANT LENGTH IN CHARS OR WORDS.
* 
*         IF CONSTANT RESULT IN TABLE --
*                (B2) = -1
*                (X6) = WORD INDEX OF VALUE (IN T.CON)
* 
*         IF SHORT CONSTANT RESULT -- 
*                (B2) = 1 
*                (X6) = VALUE OF EXPRESSION.
* 
*         IF RESULT NOT CONSTANT -- 
*                (B2) = 0 
*                (X6) = 0 
* 
*         NOTE THAT MODE AND LENGTH ARE ALWAYS RETURNED CORRECTLY,
*         EVEN IF THE EXPRESSION IS FAULTY. 
* 
*         USES   ALL. 
* 
*         CALLS  LCT, PAR, PDM. 
  
  
 PKX      SUBR   =           ENTRY/EXIT...
          SA6    PARMODE
          SA3    PIXARM 
          SA1    T=PAR
          BX6    X3 
          LX7    X1          REMEMBER OLD LENGTH OF (T.PAR) 
          SA6    ARGMODE
          SA7    PKXA 
          SX6    B4          REMEMBER (PKXB) = ORIGINAL CURSOR
          SB4    B4-B1       TOKEN BUFFER CURSOR -> BEFORE EXPR 
          SA6    PKXB 
          BX6    0
          =X7    O.SLP       MARK EXPRESSION START BY SPECIAL LPAREN
          SA6    ARGCOMA
          SA7    B4 
          RJ     PAR         REDUCE THE EXPRESSION
  
          MX0    -TP.MODEL
          BX6    X5 
          SB6    B1          CONLEN = 1 
          LX5    -TP.MODEP
          BX1    -X0*X5      (X1) = MODE OF RESULT
          HX6    TP.BIAS
          =B7    M.CHAR 
          SB5    X1          CONMODE
          LX5    TP.MODEP-TP.ORDP 
          AX6    -TP.BIASL   RETURN (X6) = INDEX INTO CON TABLE 
          MX0    -TP.ORDL 
          BX4    -X0*X5      (X4) = (TP.ORD)
          LX5    TP.ORDP-1-TP.INTRP 
          NE     B5,B7,PKX6  IF RESULT MODE NOT CHARACTER 
          LX5    TP.INTRP+1 
          BX1    X5 
          CALL   LCH         SEE IF CONSTANT
          SB7    E.PX6       ** EXPRESSION MUST BE CONSTANT 
          ZR     B2,PKX8     IF NOT CONSTANT, ERROR 
          SB7    E.TY4       ** CHARACTER CONSTANT MUST BE .LE. 2**15-1 
          SX1    MAX.CL+1 
          IX1    X7-X1
          PL     X1,PKX8     IF CHARACTER COUNT .GE. 2**15
          =B2    -1          INDICATE LONG CON
          SB5    X0          M.CHAR 
          SB6    X7          LENGTH IN CHARACTERS 
          EQ     EXIT.
  
*         RESULT IS NON-CHARACTER.
  
 PKX6     SB3    M.DBL
          SA2    S=CON
          SB2    B1          INDICATE SHORT CONSTANT
          LT     B5,B3,PKX7  IF NOT DOUBLE-WORD RESULT
          =B6    2           CONLEN = 2 
  
 PKX7     SB7    E.PX6       ** EXPRESSION MUST BE CONSTANT 
          MI     X5,PKX8     IF RESULT IS INTERMEDIATE
          LX5    TP.INTRP-TP.SHRTP
          IX2    X4-X2
          MI     X5,PKX9     IF SHORT CONSTANT
          SB2    -B1         INDICATE CONSTANT IN (T.CON) 
          ZR     X2,PKX9     IF RESULT ARITHMETIC CONSTANT
  
*         ISSUE DIAGNOSTIC FOR FAULTY EXPRESSION. 
  
 PKX8     SA2    PKXB        RESET TOKEN CURSOR FOR DIAGNOSTIC
          SB3    B4 
          SB4    X2 
          FATAL  B7 
          SB4    B3 
          SB2    0+          INDICATE NO CONSTANT 
          BX6    0
  
 PKX9     SA3    PKXA 
          NO
          BX7    X3 
          SA7    T=PAR       DISCARD NON-CONSTANT PARTS OF EXPR 
*         SHRINK
          EQ     EXIT.
  
 PKXA     EQU    PIXA        SAVES OLD PARSED FILE LENGTH 
 PKXB     BSS    1           SAVES INITIAL TOKEN CURSOR 
          TITLE  PARSER CONTROL TABLES. 
 CONO     SPACE  4,20 
**        F.CONO - CURRENT OP VERSUS NEXT OP LEGALITY MATRIX. 
* 
*         TABLE IS SET UP WITH EACH OPERATOR/OPERAND HAVING A UNIQUE BIT
*         COMBINATION.
* 
*         THE APPEARANCE OF AN OPERATOR IN THE LIST FOR OPERATOR
*         DEFINED IN LOCATION FIELD MEANS IT IS A LEGAL NEXT FOR THAT 
*         OPERATOR. 
* 
*         FORMAT OF TABLE IS -- 
* 
*         IF SET TO 0 - ILLEGAL COMBINATION.
*         IF        1 - LEGAL   COMBINATION.
* 
*         ALSO IN THE LOWER 18 BITS OF THE OPERATOR/OPERAND WORD IS THE 
*         JUMP ADDRESS FOR TRANSLATION OF THE ELEMENT.
  
  
          MACRO  CONO,TOK,ADDR,OPOK 
* 
*                            VERIFY SYNCHRONIZATION WITH TOKEN ORDER. 
          IFC    NE,/TOK//,1
 O.TOK    BSS 
*                            CHECK FOR "DITTO" TOKEN SET. 
          IFC    NE,/OPOK/DITTO/,1
 DITTO    MICRO  1,, OPOK 
*                            SET LEGALITY BITS. 
 .1       ECHO   ,THIS=("DITTO")
          POS    60+O.DEF-O.THIS
          VFD    1/1
 .1       ENDD
*                            SET ELEMENT PROCESSOR ADDRESS. 
          POS    18 
          VFD    18/PAR.ADDR
 CONO     ENDM
 CONOTBL  SPACE  4,30 
****      CONO TABLE FOR PARSER.
  
  
 ARICON   MICRO  1,, HOLL,QHOLL,RLCON,CONS,OCT,HEX
 CONSTS   MICRO  1,, "ARICON",CHAR,TRUE,FALSE 
 NAME     MICRO  1,, VAR,STFA 
 RELAT    MICRO  1,, LT,LE,EQ,NE,GE,GT
 LOGIC    MICRO  1,, AND,EQV,OR,XOR,NEQV
 ARITH    MICRO  1,, PL,MIN,MULT,DIV
 ANYOP    MICRO  1,, EOS,"CONSTS",PERIOD,VAR,"ARITH",UMIN,EXP,"RELAT"___
,,"LOGIC",NOT,CAT,LP,RP,=,COMMA,COLON,SLP 
 PREUNAR  BITMIC (O.=,O.COMMA,O.LP,O.LT,O.LE,O.NE,O.EQ,O.GE,O.GT,O.AND,O
,.NOT,O.OR,O.XOR,O.NEQV,O.SLP,O.EOS,O.COLON,O.DOBI,O.DCBI)
  
  
 F.CONO   BSS 
          LOC    O.DEF
 EOS      CONO   EOS
 HOLL     CONO   HOL,("ARITH","RELAT","LOGIC",RP,COMMA,COLON,EOS) 
 QHOLL    CONO   HOL,("ARITH","RELAT","LOGIC",RP,COMMA,COLON,EOS) 
 RLCON    CONO   HOL,("ARITH","RELAT","LOGIC",RP,COMMA,COLON,EOS) 
 CHAR     CONO   CHR,(CAT,"RELAT","LOGIC",RP,COMMA,EOS) 
 CONS     CONO   DEC,("ANYOP")
 OCT      CONO   OCT,("ANYOP")     LET TNK CHECK NEXT TOKEN 
 HEX      CONO   OCT,("ANYOP")
 PERIOD   CONO   DEC,(CONS) 
 VAR      CONO   VAR,(VAR,"ARITH",EXP,LP,RP,=,COMMA,CAT,COLON,"RELAT"___
,,"LOGIC",EOS)
 TRUE     CONO   TRU,(RP,COMMA,"LOGIC",EOS) 
 FALSE    CONO   FAL,DITTO
  
 PL       CONO   PL,("ARICON",PERIOD,"NAME",LP) 
 MIN      CONO   MIN,DITTO
 MULT     CONO   MULT,DITTO 
 DIV      CONO   DIV,DITTO
 UMIN     CONO   STD,DITTO
 EXP      CONO   STD,DITTO
  
 LT       CONO   STD,("ARICON",PERIOD,CHAR,"NAME",PL,MIN,LP)
 GE       CONO   STD,DITTO
 EQ       CONO   STD,DITTO
 NE       CONO   STD,DITTO
 LE       CONO   STD,DITTO
 GT       CONO   STD,DITTO
  
 NOT      CONO   STD,("ARICON",PERIOD,TRUE,FALSE,"NAME",PL,MIN,NOT,LP)
 AND      CONO   STD,("CONSTS",PERIOD,"NAME",PL,MIN,NOT,LP) 
 XOR      CONO   XOR,DITTO
 NEQV     CONO   STD,DITTO
 EQV      CONO   STD,DITTO
 OR       CONO   STD,DITTO
 CAT      CONO   CAT,(CHAR,"NAME",LP) 
  
 LP       CONO   LP,("CONSTS",PERIOD,"NAME",PL,MIN,NOT,COLON,LP)
 RP       CONO   RP,(VAR,"ARITH",EXP,CAT,COLON,LP,RP,=,COMMA,"RELAT"____
,,"LOGIC",EOS)
 =        CONO   EQL,("CONSTS",PERIOD,"NAME",PL,MIN,LP,NOT) 
 COMMA    CONO   CM,("CONSTS",PERIOD,"NAME",PL,MIN,STAR,LP,NOT,DOBI,EOS)
 COLON    CONO   COL,("ARICON",PERIOD,"NAME",PL,MIN,STAR,LP,RP,NOT,EOS) 
 SLP      CONO   DLP,("CONSTS",PERIOD,"NAME",PL,MIN,STAR,LP,NOT)
 STFA     CONO   STFD,("ARITH",EXP,RP,COMMA,CAT,COLON,"RELAT","LOGIC",__
,EOS) 
 ILL      CONO   STOP,("ANYOP") 
          LOC    *O 
  
*         OTHER TOKEN SETS USED BY PARSER.
  
 ACONS    BSS    0           (TNK)  LEGAL AFTER ARITH CONSTANT
          CONO   ERR,("ARITH",EXP,"RELAT","LOGIC",RP,COMMA,COLON,EOS) 
  
 FEXPR    BSS    0           (PAR)  LEGAL FIRST TOKEN TO PARSE
          CONO   ERR,("CONSTS",PERIOD,"NAME",PL,MIN,LP,NOT,SLP) 
****
          PURGMAC CONO
 POPNX    SPACE  4,30 
**        F.POPNX - VECTOR OF OPERATOR SYNTHESIZER (POPPER) ADDRESSES.
* 
* TOK     POPNX  ADDR 
  
          MACRO  POPNX,TOK,ADDR 
 O.TOK    VFD    42/,18/POP.ADDR
          ENDM
  
  
 F.POPNX  BSS 
          LOC    O.DEF
 EOS      POPNX  ERR
 HOLL     POPNX  ERR
 QHOLL    POPNX  ERR
 RLCON    POPNX  ERR
 CHAR     POPNX  ERR
 CONS     POPNX  ERR
 OCT      POPNX  ERR
 HEX      POPNX  ERR
 PERIOD   POPNX  ERR
 VAR      POPNX  ERR
 TRUE     POPNX  ERR
 FALSE    POPNX  ERR
  
 PL       POPNX  PL 
 MIN      POPNX  STD
 MULT     POPNX  MUL
 DIV      POPNX  DIV
 UMIN     POPNX  UM 
 EXP      POPNX  EXP
  
 LT       POPNX  REL
 GE       POPNX  REL
 EQ       POPNX  REL
 NE       POPNX  REL
 LE       POPNX  LE          REVERSED TO O.GE 
 GT       POPNX  GT          REVERSED TO O.LT 
  
 NOT      POPNX  NOT
 AND      POPNX  LOG
 XOR      POPNX  LOG
 NEQV     POPNX  LOG
 EQV      POPNX  LOG
 OR       POPNX  LOG
 CAT      POPNX  CAT
  
 LP       POPNX  PN 
 RP       POPNX  RP 
 =        POPNX  EQL
 COMMA    POPNX  CM 
 COLON    POPNX  COL
 SLP      POPNX  PN          SPECIAL LEFT PAREN 
  
 STFA     POPNX  ERR
 ILL      POPNX  ERR
          LOC    *O 
  
          PURGMAC POPNX 
 SETPRI   SPACE  4,30 
**        SETPRI - DEFINE OPERATOR PRIORITY.
* 
*  OPR    SETPRI             SET PR.OPR TO COUNTER. 
*  OPR    SETPRI EXPR        SET PR.OPR TO EXPRESSION.
* 
*         EACH *SETPRI* CALL INCREMENTS PRIORITY COUNTER BY 3 
*         UNLESS AN EXPLICIT PRIORITY PARAMETER IS SPECIFIED. 
*         THE INCREMENT VALUE OF 3 IS AD HOC.  IT WORKS FOR THE 
*         PRESENT SET OF OPERATORS. 
* 
*         THE PRIORITY SYMBOLS ARE USED IN THE *SETOP* WORDS (BELOW). 
*         PRIORITIES EVENTUALLY DRIVE THE PARSER STACK/POP DECISION.
*         THE PARSER FETCHES A (SETOP) WORD FROM THE (F.PRIOR) VECTOR 
*         CORRESPONDING TO EACH INCOMING TOKEN.  THE TOKEN BUFFER 
*         PRIORITY (TH.TBPR) OF THIS WORD IS COMPARED WITH THE STACK
*         PRIORITY (TH.STPR) OF THE OPERATOR AT THE TOP OF (OSTACK).
* 
*         IF TOKEN PRIORITY .GE. STACK PRIORITY -- STACK TOKEN. 
*         IF TOKEN PRIORITY .LT. STACK PRIORITY -- POP STACK TOP. 
  
  
          MACRO  SETPRI,OPNAME,PRIORITY 
          LOC    PRIORITY  PR.SET 
 OPNAME   BSS 
* 
          IFC    EQ,//PRIORITY/,1 
 PR.SET   SET    PR.SET+3 
          ENDM
 PR.SET   SPACE  4,10 
**        PRIORITY STACK LISTED FROM LOWEST TO HIGHEST PRIORITY.
  
  
 PR.SET   SET    5           LOWEST PRIORITY
  
 PR.RPAR  SETPRI
 PR.LPAR  SETPRI
 PR.EQUAL SETPRI
 PR.SLP   SETPRI PR.EQUAL    SUBSCRIPT LEFT PAREN 
 PR.SPL   SETPRI PR.SLP+1    SUBSCRIPT PLUS 
 PR.SMULT SETPRI PR.SPL+1    SUBSCRIPT MULTIPLY 
 PR.COM   SETPRI
 PR.COL   SETPRI             COLON
 PR.EQV   SETPRI
* FV                         NOTE XOR PRECEDENCE CHANGE FROM FTN 4
 PR.XOR   SETPRI PR.EQV 
 PR.NEQV  SETPRI PR.XOR 
 PR.OR    SETPRI
 PR.AND   SETPRI
 PR.NOT   SETPRI
 PR.REL   SETPRI             LT, LE, NE, EQ, GE, GT 
 PR.CAT   SETPRI             // 
 PR.PL    SETPRI
 PR.MI    SETPRI PR.PL
 PR.UMIN  SETPRI
 PR.MULT  SETPRI
 PR.DIV   SETPRI PR.MULT
 PR.SDIV  SETPRI PR.MULT+2
 PR.IDIV  SETPRI PR.MULT-1
 PR.EXP   SETPRI
 PR.ILL   SETPRI             HIGHEST PRIORITY 
          LOC    *O 
 SETOP    SPACE  4,30 
**        SETOP - MACRO TO SET UP OPERATOR ENTRY. 
* 
*         SETOP  TBPR,STPR,SKEL,ATTR
* 
*                TBPR = TOKEN BUFFER PRIORITY.
*                STPR = STACK PRIORITY. 
*                SKEL = SKELETON WHICH GENERATES CODE FOR THIS OPERATOR.
*                ATTR = PARSING ATTRIBUTES. 
* 
*         GENERATES ONE WORD IN TURPLE HEADER (SP.) FORMAT. 
*         SEE THE DESCRIPTION OF (SP.) IN TEXT FOR LAYOUT.
* 
*         UPON EMISSION OF A TURPLE, THE (SP.) FORMAT WILL BE CONVERTED 
*         TO (TH.) FORMAT.
  
  
 SETOP    MACRO  TBP,STP,JPA,CLS
 A        MICRO 
          IFC    NE,/JPA//,1
 A        MICRO  1,,/=X_JPA/
          VFD    SP.SKELL/"A" 
* 
          IRP    CLS
          POS    SP.CLS_P+1 
          VFD    1/1
          IRP 
* 
          POS    SP.STPRP+SP.STPRL
 C        SET    STP+TBP
          IFC    LT,/STP/+/,2 
          IFC    NE,/STP//,1
 C        SET    STP
          VFD    SP.STPRL/C,SP.TBPRL/TBP
          ENDM
  
  
          MACRO  SOPENT,LAB,TBP,STP,JPA,CLS 
 LAB      SETOP  TBP,STP,JPA,(CLS)
          ENTRY  LAB
          ENDM
 F.PRIOR  SPACE  4,30 
**        F.PRIOR - OPERATOR PRIORITY VECTOR. 
* 
*         VECTOR OF STANDARD FORTRAN OPERATORS.  THE VECTOR IS
*         INDEXED BY TOKEN TYPES FROM O.SEP THRU O.ILL. 
*         THE PRIOP MACRO INSURES THE VECTOR REMAINS IN ORDER.
  
  
          MACRO  PRIOP,LAB,TBP,STP,JPA,CLS
 O.LAB    SETOP  TBP,STP,JPA,(CLS)
          ENDM
  
  
 F.PRIOR  BSS    0
          LOC    O.SEP
 PL       PRIOP  PR.PL,+1,OM=ADD,(AS,COM,BND) 
 MIN      PRIOP  PR.MI,+1,OM=SUB,(AS,BND) 
 MULT     PRIOP  PR.MULT,+1,OM=MUL,(AS,DIS,COM,BND) 
 DIV      PRIOP  PR.DIV,+1,OM=DIV,(DIS,BND) 
 UMIN     PRIOP  PR.UMIN,,OM=UMI,(UNAR,BND) 
* FV                         NOTE EXP ASSOCIATION CHANGE FROM FTN 4 
 EXP      PRIOP  PR.EXP            SEE POP.EXP
  
 LT       PRIOP  PR.REL,,OM=LT,(CHAR) 
 GE       PRIOP  PR.REL,,OM=GE,(CHAR) 
 EQ       PRIOP  PR.REL,,OM=EQ,(CHAR,COM) 
 NE       PRIOP  PR.REL,,OM=NE,(CHAR,COM) 
 LE       PRIOP  PR.REL,,OM=GE,(CHAR)          REVERSED TO O.GE 
 GT       PRIOP  PR.REL,,OM=LT,(CHAR)          REVERSED TO O.LT 
  
 NOT      PRIOP  PR.NOT,,OM=NOT,(MASK,UNAR) 
 AND      PRIOP  PR.AND,+1,OM=AND,(AS,COM,MASK) 
 XOR      PRIOP  PR.XOR,+1,OM=XOR,(AS,COM,MASK) 
 NEQV     PRIOP  PR.XOR,+1,OM=XOR,(AS,COM,MASK) 
 EQV      PRIOP  PR.EQV,+1,OM=EQV,(AS,COM,MASK) 
 OR       PRIOP  PR.OR_,+1,OM=OR_,(AS,COM,MASK) 
  
 CAT      PRIOP  PR.CAT,+1,V=CAT,(AS,CHAR,MDLS) 
  
 LP       PRIOP  PR.LPAR,-1,,(NSQZ) 
 RP       PRIOP  PR.RPAR
 =        PRIOP  PR.EQUAL,-1,OM=STR,(CHAR)
 COMMA    PRIOP  PR.COM,+1,,(MDLS,NSQZ,UNAR)
 COLON    PRIOP  PR.COL,+1,,(MDLS)
 SLP      PRIOP  PR.ILL,,V=ERR
 STFA     PRIOP  PR.ILL 
 ILL      PRIOP  PR.ILL,,V=ERR
          LOC    *O 
 SPECOPS  SPACE  4,20 
**        INVENTED OPERATORS. 
* 
*         THESE OPERATORS DO NOT DIRECTLY APPEAR IN THE SOURCE. 
*         THAT IS, THEY HAVE NO CORRESPONDING TOKENS TO INVOKE
*         THEM.  THE SETOPS IN THE FIRST SET ARE STACKED BY THE 
*         PARSER IN SPECIAL CIRCUMSTANCES.  FOR EXAMPLE, IF A 
*         DIVIDE IS TURNED INTO A RECIPROCAL MULTIPLY.
  
  
 IDIV     SETOP  PR.IDIV,+2,OM=DIV,(DIS,BND)
 SDIV     SETOP  PR.SDIV,+1,OM=MUL,(AS,DIS,COM,BND) 
 MINUSOP  SETOP  O.MIN,0,OM=SUB,(AS,BND)
 CRDIV    SETOP  O.DIV,0,V=DVC.R,(DIS,BND,MDLS) 
 /OP/     SPACE  4,10 
**        /OP/ - GENERATED INTEGER OPERATORS. 
* 
*         DEFINED AS SMALL CONSTANTS. 
*         SEE USAGE IN SUBROUTINE *ASE* FOR DETAILS.
  
  
 INTEG    BSS 
          QUAL   OP          DEFINE OPERATOR CODES AS SHORT CONSTANTS 
          LOC    0
 PLUS     SETOP  O.PL,0,V=ADD.I,(AS,COM,MDLS) 
 MINUS    SETOP  O.MIN,0,V=SUB.I,(AS,BND,MDLS)
 UMIN     SETOP  O.UMIN,0,V=UMI.I,(UNAR,BND,MDLS) 
 MULT     SETOP  O.MULT,0,V=MUL.I,(AS,DIS,COM,MDLS) 
          LOC    *O 
          QUAL   *
 STATOPS  SPACE  4,10 
**        THE FOLLOWING SETOPS ARE NOT USED ON THE PARSING STACKS.
*         THEY ARE MERELY TEMPLATES FOR (TH.) EMISSION.  THEREFORE, 
*         THERE ARE NO PRIORITY IMPLICATIONS OF THESE.  NEW ENTRIES 
*         ARE ADDED AS MAY BE CONVIENIENT FOR TURPLE EMITTERS.
*         THE (TH.TBPR) IS SPECIFIED ONLY TO DRIVE THE USE-COUNT
*         DETERMINATION IN *QCG*. 
  
  
 DO.BEG   SOPENT O.BOTH,0,V=DOBZS,(MDLS,NSQZ) 
          SETOP  O.BOTH,0,V=DOBS,(NSQZ,MDLS)
          SETOP  O.BOTH,0,V=DOBZL,(NSQZ,MDLS) 
          SETOP  O.BOTH,0,V=DOBL,(NSQZ,MDLS)
 DO.END   SETOP  O.BOTH,0,OM=DOC,(NSQZ) 
  
  
 MULROP   SOPENT O.MULT,0,V=MUL.R,(AS,DIS,COM,MDLS) 
 NOTLOP   SETOP  O.NOT,0,V=NOT.L,(MDLS,UNAR)
 IN.EXP   SETOP  O.EXP,0,,(MDLS,BND)
ARYOP     SOPENT O.ARY,0,V=ARY,(MDLS) 
 DVLOP    SOPENT O.NONE,0,V=DVI,(MDLS,NSQZ) 
 ERROP    SOPENT O.ERR,0,V=ERR,(BND,MDLS,NSQZ)
 FUNOP    SETOP  O.NONE,0,V=FUNC,(MDLS,NSQZ)
 INFOP    SETOP  O.NONE,0,V=INTF,(MDLS,NSQZ,BND)
 LIBOP    SETOP  O.NONE,0,V=LIBF,(MDLS,NSQZ,BND)
 FAPOP    SETOP  O.NONE,0,V=FAP,(MDLS,NSQZ,BND) 
 GAPOP    SOPENT O.1ST,0,V=GAP,(MDLS,NSQZ,UNAR) 
 IAPOP    SETOP  O.1ST,0,V=IAP,(MDLS,NSQZ,UNAR) 
 IOCTL    SOPENT O.2ND,0,V=APIOC,(MDLS,NSQZ)
 IODTA    SOPENT O.BOTH,0,V=APIOD,(MDLS,NSQZ) 
 IOUNT    SOPENT O.BOTH,0,V=APIOU,(MDLS,NSQZ) 
 COLOP    SETOP  O.COLON,0,V=COLON,(MDLS,NSQZ)
 SUBST    SETOP  O.BOTH,0,V=SUBST,(MDLS,NSQZ) 
 INTMAC   SETOP  O.MODC,0,V=INT,(MDLS,UNAR) 
 MCVOP    SETOP  O.MODC,0,OM=CONV,(UNAR)
 NOOPP    SOPENT O.SPACE,0,V=NOOP,(MDLS,NSQZ) 
 OPBSS    SOPENT O.NONE,0,V=BSS,(MDLS,NSQZ) 
 XMITOP   SETOP  O.1ST,0,V=XMIT,(MDLS)
  
  
 OPDUM    SOPENT O.NONE,0,,(MDLS,NSQZ)
          SETOP  O.1ST,0,,(MDLS,NSQZ) 
          SETOP  O.2ND,0,,(MDLS,NSQZ) 
          SETOP  O.BOTH,0,,(MDLS,NSQZ)
 RANOP    SETOP  O.BOTH,0,V=RANF,(MDLS,NSQZ)
 EXPOP    SETOP  O.NONE,0,V=EXP.I,(MDLS)  FOR DATA ONLY 
 LGEOP    SETOP  O.BOTH,0,V=LGE 
 LLTOP    SETOP  O.BOTH,0,V=LLT 
 BIFFUN   SETOP  O.BOTH,0,,(MDLS) 
  
  
 STRHOP   SETOP  O.=,0,V=STR.H,(MDLS,NSQZ)
 VD.EQ    SOPENT O.=,0,V=STR.I,(MDLS,NSQZ)
 VD.MI    SOPENT O.MIN,0,V=SUB.I,(AS,MDLS)
 VD.MU    SOPENT O.MULT,0,V=MUL.I,(AS,DIS,COM,MDLS) 
 VD.PL    SOPENT O.PL,0,V=ADD.I,(AS,COM,MDLS) 
 VD.GP    SOPENT O.1ST,0,V=GPL,(MDLS,NSQZ)
 NEGOP    SPACE  4,10 
**        F.NEGOP - NEGATION OF OPERATOR. 
  
  
 F.NEGOP  BSS 
          LOC    O.LT 
 O.NEGOP  BSS                LOWER LIMIT OF NEGATABLE OPS 
  
 LT       PRIOP  O.GE,0,OM=GE 
 GE       PRIOP  O.LT,0,OM=LT 
 EQ       PRIOP  O.NE,0,OM=NE,(COM) 
 NE       PRIOP  O.EQ,0,OM=EQ,(COM) 
 LE       PRIOP  O.GT,0      NONE SUCH
 GT       PRIOP  O.LE,0      NONE SUCH
  
 Z.NEGOP  BSS                UPPER LIMIT OF NEGATABLE OPS 
          LOC    *O 
 SETARM   SPACE  4,50 
**        SETARM - SET *ARGMODE* CELL FOR USE BY *PARSER*.
* 
*         SETARM REF,(ATTR),COMAD,PARAD 
* 
*         REF   = CROSS REFERENCE VALUE.
*         ATTR  = ATTRIBUTE BITS FOR THIS *ARGMODE*.
*         COMAD = C=XXX PROCESSOR ADDRESS FOR COMMA.
*         PARAD = A=XXX PROCESSOR ADDRESS FOR PAREN.
* 
*         FOR DEFINITION OF VARIOUS FIELDS AND THEIR USE SEE WRITE-UP 
*         OF CELL *ARGMODE*.
  
  
 SETARM   MACRO  REF,ATTR,COMAD,PARAD 
          IFEQ   REF,,2 
          VFD    AM.REFL/55B
          SKIP   1
          VFD    AM.REFL/REF
          IRP    ATTR 
          POS    AM.ATTR_P+1
          VFD    1/1
          IRP 
          POS    AM.ATRP
          VFD    AM.COML/=X_COMAD 
          VFD    AM.PADL/=X_PARAD 
 SETARM   ENDM
  
  
          MACRO  SARENT,LAB,REF,ATTR,COMAD,PARAD
 LAB      SETARM REF,(ATTR),COMAD,PARAD 
          ENTRY  LAB
          ENDM
  
  
 ARRARM   SETARM ,,C=ARRAY,A=ARRAY
 CALLARM  SARENT CR.PAR,(ARE,FUN,LEV3),C=CALL,A=CALL
 CNFARM   SETARM ,(EQ),C=CERR,PAR.NX
 DATARM   SARENT CR.DAT,(ARE,EQ,EOS),C=DVL,A=DVL  DATA STATEMENT
 DOARM    SARENT CR.DOI,(EQ),C=DO,A=DO         DO CONTROL 
 EXTFARM  SETARM CR.PAR,(ARE,FUN,LEV3),C=FUN,A=FUN
 IFARM    SARENT CR.IF,,C=CERR,A=IF            IF EXPRESSION
 INFARM   SETARM CR.INF,,C=INF,A=INF
 LPARM    SETARM ,,C=CERR,A=EXPR
 LBARM    SARENT CR.DEC,(COL),C=DBD,A=DBD      LOWER BOUND EXPRESSION 
 UBARM    SARENT CR.DEC,,C=DBD,A=DBD           UPPER BOUND EXPRESSION 
 PIXARM   SETARM ,(RP,COL),C=PIX,A=PIX
 PJXARM   SARENT CR.VGOTO,(EOS),C=PJX,PAR.NX   JUMP EXPRESSION
 SBSARM   SETARM CR.REF,(COL),C=SBS,A=SBS      SUBSTRING
 STFARM   SETARM CR.REF,,C=STFA,A=STFA
 ESFARM   SETARM CR.REF,,C=CERR,A=STFE
  
*         I/O SETARMS 
  
 BUFMOD   SARENT ,(RP),C=CERR,A=BMOD           BUFFER I/O MODE
 BUFFWA   SARENT ,,C=BFWA,C=CERR               BUFFER I/O FWA 
 BUFLWA   SARENT ,,C=CERR,A=BLWA               BUFFER I/O LWA 
 CNTARM   SARENT ,,C=CNT,C=CERR                ENCODE/DECODE COUNT
 DOCOLI   SARENT CR.DOI,,C=DOCI,A=DOCI         DO COLLAPSE INDUCTION
 DOCOLS   SARENT ,,C=DOCS,A=DOCS               DO COLLAPSE SUBSCRIPTS 
 FMTARM   SARENT ,(ARE,EOS,RP),C=FMT,A=FMT     FORMAT 
 FOUARM   SARENT ,(ARE,EOS,RP),C=FOU,A=FOU     FORMAT OR UNIT 
 ICCARM   SARENT ,(RP),C=ICC,A=ICC             I/O CONTROL CHAR VARIABLE
 ICCXARM  SARENT ,(RP),C=ICCX,A=ICCX           I/O CONTROL CHAR EXPR
 ICIARM   SARENT ,(RP),C=ICI,A=ICI             I/O CONTROL INT VARIABLE 
 ICIXARM  SARENT ,(RP),C=ICIX,A=ICIX           I/O CONTROL INT EXPR 
 ICLARM   SARENT ,(RP),C=ICL,A=ICL             I/O CONTROL LOG VARIABLE 
 IOARGM   SARENT CR.OUT,(ARE,EQ,EOS),C=IOL,A=LIST    OUTPUT LIST ITEM 
          SETARM CR.INP,(ARE,EQ,EOS),C=IOL,A=LIST    INPUT LIST ITEM
 STRARM   SARENT ,(ARE,RP),C=CERR,A=STR        ENCODE/DECODE STRING ADDR
 UNTARM   SARENT CR.IOU,(ARE,EOS,RP),C=UNT,A=UNT     UNIT SPECIFIER 
          TITLE  PARSING (ANALYSIS).
 PARSE    EJECT 
**        PAR -  ARITHMETIC STATEMENT PARSING ROUTINE.
* 
*         A GENERAL PURPOSE *ONE-PASS* ARITHMETIC PARSING ROUTINE USING 
*         PSEUDO REVERSE POLISH ALGORITHM. (N-TURPLE) 
* 
*         THIS ROUTINE WILL TRANSLATE ANY ARITHMETIC, LOGICAL,
*         RELATIONAL, OR MASKING EXPRESSION INTO PSEUDO- POLISH 
*         NOTATION. 
* 
*         ENTRY  (B4) _ FIRST TOKEN TO PROCESS. 
*                (ARGMODE) = PRESET TO INDICATE CURRENT MODE OF 
*                            EXPRESSION *PARSE* WILL HANDLE.
*                            CONTROLS THE OUTERMOST PAREN LAYER.
*                (ARGCOMA) = PRESET TO CURRENT ARGUMENT COUNT.
*                            CAN BE GARBAGE IF NOT NEEDED.
*                (PARMODE) = PARSE MODE FOR ENTIRE EXPRESSION.
*                (CURST) = ORDINAL, RELATIVE TO T.PAR, POINTING TO
*                          BREAK FOR SQUEEZING PROCESS. 
* 
*         EXIT   (B4) _ LAST TOKEN PROCESSED. 
*                (PARMODE) = 'PM=EXPR', RESET FOR NORMAL PARSE. 
* 
* 
*         --------------- L O C K  -  R E G I S T E R S --------------
*                (B4) _ CURRENT TOKEN.
*                (B5) _ CURRENT OP-STACK ENTRY. 
*                (B6)-1 _ TOP ELEMENT (ESTACK) ENTRY. 
*         NO ROUTINE CALLED BY *PAR* MAY DESTROY ANY OF THE ABOVE REGS. 
*         ------------------------------------------------------------
* 
*         USES   ALL REGISTERS. 
  
  
  
 PAR      SUBR   =           ENTRY/EXIT...
          SHRINK T=PCS
          SA1    T=PAR
          SA2    ARGMODE
          SA3    PARMODE
          BX7    X3          SET (PARNOW) = (PARMODE) 
          SA7    PARNOW 
          SB6    ESTACK      (B6) -> ELEMENT STACK
          BX6    X1 
          MX7    0
          ERRNZ  PM=EXPR
          SX0    X2-A=LIST
          ERRNZ  18-AM.PADL 
          ERRNZ  AM.PADP
          SA7    A3          RESET (PARMODE) FOR NEXT TIME
          NZ     X0,PAR1     IF NOT I/O LIST ITEM 
          SA1    DATFLG 
          NZ     X1,PAR1     IF PROCESSING *DATA* 
          =X7    1
 PAR1     SB5    OSTACK      (B5) -> OPERATOR STACK 
          SA7    CMLFLG 
          HX2    AM.REF 
          AX2    AM.REFP
          BX7    0
          SA6    LDEAD       SET = LENGTH + 1 OF T.PAR ON ENTRY 
          SA7    INSTF       INDICATE NO STATEMENT FUNCTION EXPANSION 
          SA7    IFREL2      INDICATE NOT IF OF ONE RELATIONAL
          SX6    X2 
          =X7    O.EOS
          SA6    REFVAR      RESET CURRENT REFERENCE VALUE
          SA7    OSTACK      EOS TO OPERATOR STACK
          SA5    B4 
          SB3    X5 
          SA3    FEXPR
          LX4    B3,X3
          MI     X4,PAR.NX   IF FIRST ELEMENT LEGAL 
  
**        NOTE - FOLLOWING IS A ***KLUDGE*** DESIGNED TO PREVENT
*         A MODE-OUT WHEN PROCESSING :    DATA 1XX
  
          SA1    PARNOW 
          SX0    X1-PM=DATA 
          NZ     X0,PAR5     IF NOT *DATA* CALLING
          SA1    ERL=CON
          BX6    X1 
          SA6    FILL.3      SET FILLER FOR DIAGNOSTIC
          FATAL  E.DVL1      DATA VARIABLE LIST CONTAINS CONSTANT 
          EQ     DAT.Z       GO TO DATA ERROR PROCESSOR 
  
 PAR5     FATAL  E.AT10      ILLEGAL FIRST ELEMENT OF STATEMENT 
          ZR     X5,PAR.EOS  IF *EOS* FIRST ELEMENT 
          ERRNZ  O.EOS
          SB2    X5-O.ILL 
          ZR     B2,PAR.STOP IF INVALID STRING TOKEN
          SA5    B4+1        POINT TO NEXT TOKEN
          EQ     PAREX11
 A=EXPR   SPACE  4,8
**        A=EXPR - POP EXPRESSION PAREN.  DO NOTHING BUT MARK 
*         TOP OF ESTACK AS *EXPR*.
  
 A=EXPR   =A1    B6-1 
          CLAS=  X2,TP,(EXPR) 
          BX7    X1+X2
          SA7    A1 
*         EQ     PAR.NX 
          TITLE  PARSE/ANALYZE NEXT ELEMENT.
 PAR.NX   EJECT  4,20 
**        PARSE MASTER LOOP.
*         PAR.NX LOADS THE NEXT ELEMENT AND FOLLOWING ELEMENT AND 
*         CHECKS IF AN ILLEGAL OPERATOR/OPERAND COMBINATION IS ABOUT
*         TO BE PROCESSED.
* 
*         IF LEGAL COMBINATION -- 
*                JUMP TO PROCESS ELEMENT. 
* 
*         IF ILLEGAL COMBINATION -- 
*                JUMP TO PAR.EX TO OUTPUT COMBINATION THAT IS IN ERROR
*                AND EXIT PAR.
* 
*         UPON EXIT FROM PAR.NX REGISTERS ARE SET TO -- 
* 
*                (X1) = CURRENT *TB* ENTRY. 
*                (X2) = CURRENT OPERATOR PRIORITY TABLE ENTRY (SETOP).
*                (X3) = LAST OPERATOR STACK ENTRY.
*                (X5) = NEXT *TB* ENTRY.
*                (B4) _ CURRENT *TB* ENTRY. 
*                (B5) _ CURRENT *OSTACK* ENTRY. 
  
 PAR.NX   BSSENT 0           ENTRY... 
          SA1    B4          CURRENT *TB* ENTRY 
          SA5    B4+B1       NEXT *TB* ENTRY
          ZR     X1,PAR.EOS  IF END OF STATEMENT  (*EOS*) 
          ERRNZ  O.EOS
          SB3    X5 
          ERRNZ  18-TB.TOTL 
          SA3    X1-O.DEF+F.CONO
          ERRNZ  18-TB.TOTL 
          LX4    B3,X3
          SA2    X1-O.SEP+F.PRIOR 
          SB7    X3          JUMP ADDRESS 
          SA3    B5 
  
 SNAP=Z   IFEQ   TEST,ON     DUMP PARSE TABLES
          SA3    CO.SNAP
          LX3    1RZ
          PL     X3,PAR.NXS  IF PARSE SNAP NOT SELECTED 
          SA3    B5 
 MASTER   PARSNAP 
 PAR.NXS  SA3    B5 
 SNAP=Z   ENDIF 
  
 .T       IFEQ   TEST,ON
          =B2    X1-O.DEF 
          MI     B2,"BLOWUP" TOKEN VERRY ILL
          SB2    X1-O.ILL 
          GT     B2,"BLOWUP" THIS TOKEN TOO BIG FOR CONO TABLE
 .T       ENDIF 
  
          SB2    O.ENDNX
          GT     B3,B2,PAREX IF FOLLOWING TOKEN OUT OF CONO TABLE 
          PL     X4,PAREX    IF ILLEGAL OPERATOR COMBINATION
          JP     B7          JUMP TO ANALYZE CURRENT TOKEN
          TITLE  PARSE/ANALYZE CONSTANT ELEMENT.
 O.TRUE   SPACE  4,10 
**        HERE IF ELEMENT IS LOGICAL CONSTANT.
  
  
 PAR.TRU  BSS    0           ENTRY...    (FROM CONO)
 PAR.FAL  BSS    0           ENTRY...    (FROM CONO)
          SA3    PARNOW 
          SB7    X3-PM=DIM
          NZ     B7,PAR.FAL1       IF NOT 'DIM BOUND' PARSING 
          SB7    E.DM01 
          RJ     DBE         OUTPUT DIMENSION BOUND MODE ERROR
          SA1    CONONE 
          LX6    X1 
          EQ     TNK.ES 
  
 PAR.FAL1 SB7    X1-O.TRUE
          ERRNZ  O.TRUE+1-O.FALSE 
          SA1    B7+VTRUE 
          BX6    X1 
  
  
 TNK.ES   BSS    0           CONSTANT OPERAND TO ESTACK 
          SB4    B4+B1       ADVANCE TOKEN POINTER
          SA6    B6 
          SB6    B6+1        ADVANCE ESTACK TOP 
          EQ     PAR.NX 
 PAR.TNK  SPACE  4,10 
**        TNK - CONVERT NUMERIC CONSTANTS.
* 
*         CALLS  DEC, OCT, NBC. 
  
  
 PAR.OCT  BSS    0           O.OCT + O.HEX = BOOLEAN CONSTANTS
          ANSI   E.DC1       O.OCT AND O.HEX NON-ANSI 
          MDERR  E.MDE2      OCTAL AND HEX ARE MACHINE DEPENDENT
          CALL   OCT
          EQ     TNK.DBL
  
  
 PAR.DEC  BSS    0           O.CONS = DECIMAL CONSTANT
          CALL   DEC         TRANSLATE CONSTANT TO BINARY VALUE 
  
  
*         TNK.DBL - ENTRY WHEN COMPLEX CONSTANT DISCOVERED. 
*                (X1) = MODE OF CONSTANT. 
*                (X2) = LOWER HALF OF VALUE (IF DOUBLE-WORD). 
*                (X6) = UPPER (OR ONLY) HALF OF VALUE.
  
 TNK.DBL  SA3    PARNOW 
          SB7    X3-PM=DIM
          NZ     B7,TNK.DBL5    IF NOT 'DIM BOUND' PROCESSING 
          ZR     X1,TNK.DBL5    IF MODE BOOLEAN 
          SB2    X1-M.INT 
          ZR     B2,TNK.DBL5    IF MODE INTEGER 
          SB7    E.DM01 
          RJ     DBE         OUTPUT DIMENSION BOUND MODE ERROR
          =X1    M.INT
          =X6    1           DUMMY UP A CONSTANT 1
 TNK.DBL5 BX7    X2 
          CALL   NBC         ENTER BINARY OF CONSTANT 
          SA2    B4+B1
          SA1    ACONS
          =B4    B4+1 
          SB3    X2 
          SA6    B6 
          LX4    B3,X1
          =B6    B6+1 
          MI     X4,PAR.NX   IF NEXT OK TO FOLLOW CONSTANT
          =A1    B4-1 
          SA5    B4          SET TOKEN FOR ERROR MESSAGE
          SB4    B4-1 
          SB2    X1-O.RP
          NZ     B2,PAREX    IF NOT COMPLEX CONSTANT
          SA4    ARGMODE
          SBIT   X4,AM.RPP
          PL     X4,PAREX    IF NO SPECIAL PROCESSING 
          =B4    B4+1 
          SB7    E.PX5
          EQ     PAREX
 TNK.PARM SPACE  4,10 
**        ELEMENT IS A PARAMETER SYMBOL.
* 
*         ENTRY  (B7) = SYMTAB *WB* INDEX.
*                (A2, X2) = SYMTAB (WB).
  
  
 TNK.PARM BSS    0           ENTRY ... FROM TRE 
          LX2    -WB.MODEP
          MX3    -WB.MODEL
          BX3    -X3*X2      EXTRACT MODE 
          LX2    WB.MODEP 
          NZ     X3,TNKPR0   IF NOT BOOLEAN 
          ERRNZ  M.BOOL 
          MDERR  E.MDE2 
  
 TNKPR0   SA3    PARNOW 
          SX3    X3-PM=DIM
          NZ     X3,TNKPR1   IF NOT 'DIM BOUND' PARSE 
          MX7    -WB.MODEL
          LX2    -WB.MODEP
          BX1    -X7*X2      EXTRACT MODE 
          LX2    WB.MODEP    RESTORE X2 TO NOMINAL POSITION 
          SB2    X1-M.INT 
          ZR     X1,TNKPR1   IF MODE BOOLEAN
          ZR     B2,TNKPR1   IF MODE INTEGER
          SB7    E.DM01 
          RJ     DBE         OUTPUT ILLEGAL MODE DIAGNOSTIC 
          SA1    CONONE 
          LX6    X1 
          EQ     TNK.ES 
  
 TNKPR1   MX7    -WB.MODEL
          LX2    -WB.MODEP
          LX0    XR.TAGP
          BX5    -X7*X2      (X5) = MODE
          =A4    A2-WB.W+WC.W 
          SA1    REFVAR 
          BX6    X0 
          ADDREF X6,X1       ENTER REFERENCE TABLE
          MX6    -WC.RAL
          LX4    -WC.RAP
          SB2    X5-M.CHAR
          BX7    -X6*X4      (X7) = INDEX OF CONSTANT 
          ZR     B2,TNKPR4   IF CHARACTER PARAMETER 
          SA3    T.CON
          SB7    X7          CONSTANT INDEX 
          SA1    X3+B7       UPPER HALF 
          =A2    A1+1        LOWER HALF (MAY BE NEEDED) 
          LX6    X1 
          BX1    X5          MODE 
          LX7    X2 
          CALL   NBC         ENTER BINARY OF CONSTANT 
          SA3    B4+1 
          LX3    -TB.TOTP 
          SB7    X3-O.LP
          ERRNZ  18-TB.TOTL 
          NZ     B7,TNK.ES   IF NOT FOLLOWED BY LEFT PAREN
          FATAL  E.AT20      ** ILLEGAL USE OF PARAMETER
          =B4    B4+1        B4 _ LEFT PAREN
          RJ     SPE         SKIP PARENTHESIZED EXPR
          PL     B2,PSL      IF *EOS* FOUND BY SPE
          EQ     TNK.ES 
  
 TNKPR4   MX6    -WC.CLENL
          LX4    WC.RAP-WC.CLENP
          LX2    X7          (X1) = CHAR INDEX  = (WC.RA) 
          BX1    -X6*X4      (X2) = CHAR LENGTH = (WC.CLEN) 
          SA3    B4+1 
          LX3    -TB.TOTP 
          SB7    X3-O.LP
          ERRNZ  18-TB.TOTL 
          NZ     B7,PAR.CHR1 IF NOT FOLLOWED BY LEFT PAREN
          FATAL  E.AT18      ** SUBSTRING ILLEGAL FOR PARAMETER FILL. 
          LX3    TB.TOTP-TB.IOCPP 
          SB4    X3          SKIP OVER THE PARENTHESIZED GROUP
          EQ     PAR.CHR1 
 PAR.HOL  SPACE  4,10 
**        HERE IF ELEMENT IS A *HOLLERITH CONSTANT*.
  
  
 PAR.HOL  BSS    0
          MDERR  E.MDE2      ALL HOLLERITH FORMS ARE MACHINE DEPENDENT
          ANSI   E.AT08      HOLLERITH IS NON-ANSI
          BX0    X1 
          AX0    TB.LCONP 
          MX2    -TB.LCONL
          BX7    -X2*X0 
          SB7    X7-1 
          ZR     B7,PAR.HOL5 IF LENGTH=1, OK
          SA2    ARGMODE
          SB7    X2-A=CALL
          ZR     B7,PAR.HOL1 IF SUBROUTINE ARGUMENT 
          SB7    X2-A=FUN 
          ZR     B7,PAR.HOL1 IF FUNCTION ARGUMENT 
          ERRNZ  18-AM.PADL 
          TRIV   E.AT03      HOLLERITH MORE THAN ONE WORD - TRUNCATED 
          EQ     PAR.HOL2 
  
 PAR.HOL1 SX6    1
          SA6    NSQZLH      SET FLAG TO NOT SQUEEZE
  
 PAR.HOL2 BSS    0
          LX1    -TB.SHCP 
          SX6    X1          INDEX INTO (T.CON) 
          ERRNZ  18-TB.SHCL 
          SA1    S=CON
          LX1    TP.ORDP
          LX6    TP.BIASP 
          BX6    X1+X6       FORM CON. *P1* ENTRY 
          EQ     TNK.ES      GO ENTER STACK 
  
 PAR.HOL5 LX1    -TB.SHCP 
          SA2    T.CON
          SB7    X1 
          ERRNZ  18-TB.SHCL 
          SA1    X2+B7       BINARY OF CONSTANT 
          =X7    M.BOOL 
          LX6    X1 
          CALL   NCS         PROVIDE TP.SHRT WHEN APPROPRIATE 
          EQ     TNK.ES      GO ENTER STACK 
 PAR.CHR  SPACE  4,10 
**        PAR.CHR - ELEMENT IS A CHARACTER CONSTANT.
* 
*         STACK A SUBSTRING OPERAND (INTERMEDIATE). 
* 
*         ENTRY  (X1) = CURRENT TOKEN.
* 
*         CALLS  ECC. 
  
  
 PAR.CHR  BSS    0           ENTRY ... FROM (F.CONO)
          SA3    PARNOW 
          LX1    -TB.SHCP 
          MX7    -TB.CLCNL
          MX0    -TB.SHCL 
          BX2    -X0*X1      CHAR IND = SHC [TB ENTRY]
          SB7    E.DM01 
          LX1    TB.SHCP-TB.CLCNP 
          BX1    -X7*X1      CHAR LEN = CLCN [TB ENTRY] 
          SX3    X3-PM=DIM
          NZ     X3,PAR.CHR1       IF NOT 'DIM BOUND' PARSE 
          RJ     DBE         OUTPUT DIMENSION BOUND MODE ERROR
          SA1    CONONE 
          LX6    X1 
          EQ     TNK.ES 
  
PAR.CHR1  RJ     ECC         EMIT CHARACTER CONSTANT
          SB4    B4+B1
          EQ     PAR.NX 
          TITLE  PARSE/ANALYZE SYMBOLIC ELEMENT.
 TRE      SPACE  4,20 
**        TRE - TRANSLATE ELEMENT.
* 
*         TRE FIRST SCANS THE SYMBOL TABLE TO CHECK IF ELEMENT HAS
*         ALREADY BEEN TAGGED.  IF IT HAS IT DOES SOME SIMPLE SYNTAX
*         CHECKING AND EXITS.  IF NOT IT THEN CHECKS THE SYNTAX USAGE 
*         AND DEPENDING ON ITS USE WILL EITHER ---
*                A.  CALL TSF TO TRANSLATE SPECIAL FUNCTION, OR,
*                B.  ENTER TAG INTO SYMBOL TABLE AS A VARIABLE. 
* 
*         IN ALL CASES TRE WILL SET UP THE EXIT CONDITIONS NEEDED FOR 
*         PARSE TO MAKE SENSE OUT OF THIS MESS. 
* 
*         ENTRY  (B4) _ TOKEN TO TRANSLATE. 
*                       (MUST CONTAIN O.VAR BITS IN LOW ORDER.) 
* 
*         EXIT   (X6) = SYMBOL TABLE ENTRY. 
*                (B2) = PAR.NX     IF VARIABLE, 
*                     = PAR.SUB    IF ARRAY,
*                     = PAR.FUN    IF FUNCTION
* 
*         USES   CANNOT DESTROY   A4-5,A7   B4-B6.
* 
*         CALLS  SCAN, TRV, TSF.
  
  
 PAR.VAR  BSS    0
          SA1    B4 
          MX0    TB.TOCL
          BX6    X0*X1       SYMBOL ONLY
          BX7    0
          SA6    FILL.       IN CASE OF ERROR 
          SA7    ATTR        CLEAR ATTRIBUTE CELL 
          SA6    CSYMBOL     SAVE CURRENT SYMBOL
          =A2    B4+1 
          SB7    X2-O.VAR 
          NZ     B7,PAR.VAR2 IF LESS THAN 8 CHARACTERS IN NAME
          CALL   TLV         TRUNCATE NAME -- SORT OF 
  
 PAR.VAR2 CALL   SSY         SEARCH SYMBOL TABLE
          SA3    REFVAR 
          CLAS=  X7,WB,(VAR)
          SB2    X3-CR.STR
          NZ     B2,TRE6     IF NOT PROCESSING A *SET*
          CLAS=  X7,WB,(VAR,DEF)
  
 TRE6     MI     B7,TRE80    IF *NIT* 
  
**        HERE IF ELEMENT ALREADY IN SYMBOL TABLE.
* 
*         GO THRU SEQUENCE OF CHECKS FOR PROPER USE.
* 
*         1. CHECK IF PARAMETER.
*                YES - GO TO TNK.PARM.
*                NO  - GO TO 2. 
* 
*         3. CHECK IF CLASS " VARIABLE. 
*                YES - CHECK AND PROCESS THE REQUIRED NONVARIABLE.
*                NO  - GO TO 3. 
* 
*         3. CHECK IF CLASS = ARRAY.
*                YES - CHECK IF FOLLOWED BY *(*.
*                      IF NOT OUTPUT FATAL MESSAGE NOTING REFERENCE TO
*                      AN ARRAY WITHOUT SUBSCRIPT (AS REQUIRED).
*                NO  - GO TO 4. 
* 
*         4. TREAT AS A VARIABLE. 
*                    - CHECK IF FOLLOWED BY *(*.
*                      IF SO OUTPUT ILLEGAL USE OF VARIABLE.
  
  
          HX6    WB.PARM
          MI     X6,TNK.PARM       IF PARAMETER VARIABLE
          CALL   CT1         CONSTRUCT (TP.) FORM OPERAND 
          SA6    CSYTAG 
          =A6    A6-CSYTAG+CSYREF 
          BX6    X2          SAVE (WB)
          CLAS=  X4,WB,(SFA)
          BX6    -X4*X6      CLEAR WB.SFA (IF PRESENT)
          SA1    B4+B1       FETCH NEXT TOKEN 
          LX3    X2 
          =A6    A6-CSYREF+CSYWB
          SX0    X1-O.LP
          SBIT   X3,WB.VARP 
          PL     X3,TRE30    IF NOT VARIABLE
          SBIT   X3,WB.ARYP/WB.VARP 
          PL     X3,TRE22    IF NOT ARRAY 
          BX6    X6+X7
          CLAS=  X7,TP,(ARR)
          SB2    PAR.SUB
          SA6    A2          RESET TAG WITH APPROPRIATE CLASS BITS
          SA7    ATTR 
          RJ     CIL         CHECK IF ILLEGAL LEVEL 
          ZR     X0,TREX     IF ARRAY FOLLOWED BY *(* 
          SA3    ARGMODE
          HX3    AM.ARE 
          MX4    1
          PL     X3,TRE15    IF ENTIRE ARRAY REFERENCE ILLEGAL
          SA1    B4-1        FETCH PREVIOUS TOKEN 
          SX1    X1-O.LP
          ZR     X1,TRE14    IF LP PRECEDES, OK 
          SX1    X1+O.LP-O.SLP
          ZR     X1,TRE14    IF SPECIAL LP PRECEDES, OK 
          SX1    X1+O.SLP-O.COMMA 
          ZR     X1,TRE14    IF COMMA PRECEDES, OK
          SX1    X1+O.COMMA-O.DOBI
          ZR     X1,TRE14    IF DO-BEGIN PRECEDES, OK 
          EQ     TRE15       IF PREVIOUS TOKEN INDICATES INVALID
  
 TRE14    SX0    X0+O.LP-O.RP 
          ZR     X0,TRE16    IF RP FOLLOWS, OK
          SX0    X0+O.RP-O.COMMA
          ZR     X0,TRE16    IF COMMA FOLLOWS, OK 
          SX0    X0+O.COMMA-O.EOS 
          ZR     X0,TRE16    IF EOS FOLLOWS, OK (FOR I/O LISTS) 
  
 TRE15    FATAL  E.VA08      ** ARRAY MISSING SUBSCRIPT 
  
 TRE16    BX1    X4*X3       SET (TP.ARE) = (AM.ARE)
          LX1    TP.AREP+1
          SB2    PAR.NX 
          BX7    X1+X7       UPDATE (ATTR)
          SA7    A7 
          EQ     TREX        EXIT.. 
  
  
*         HERE IF POSSIBLE VARIABLE.
  
 TRE22    BX6    X6+X7       ADD IN CLASS BITS
          SB2    PAR.NX      INDICATE VARIABLE
          SA6    A2          RESET TAG WITH APPROPRIATE CLASS BITS
          RJ     CIL         CHECK ILLEGAL LEVEL
          NZ     X0,TREX     IF NOT FOLLOWED BY LEFT PAREN
          SA1    B4+B1
          SB2    PAR.SBS
          HX1    TB.COL 
          MI     X1,TREX     IF SUBSTRING LPAREN
          FATAL  E.VA03      ILLEGAL *(* FOLLOWING VARIABLE NAME
  
*         SKIP OVER BAD PARENTHESIZED EXPRESSION. 
  
          =B4    B4+1 
          RJ     SPE         SKIP PARENTHESIZED EXPRESSION
          PL     B2,PSL      IF *EOS* FOUND 
          SB2    PAR.NX 
          EQ     TREX        EXIT.. 
  
*         HERE IF POSSIBLE FUNCTION/SUBROUTINE. 
  
 TRE30    SB2    PAR.FUN     INDICATE EXTERNAL
          SBIT   X3,WB.NVARP/WB.VARP
          PL     X3,TRE70    IF VARIABLE
          =A5    B4-1        X5 = TOKEN BEFORE POSSIBLE FUNCTION
          SX4    X0+O.LP-O.COMMA
          SB3    X5-O.COMMA 
          SX5    X5-O.SLP 
          SBIT   X3,WB.FUNP/WB.NVARP
          PL     X3,TRE40    IF NOT A FUNCTION
          ZR     X0,TREX     IF FOLLOWED BY *(* - OK
  
*         REFERENCE TO A FUNCTION/SUBROUTINE WITHOUT A LEFT PAREN,
*         LEGAL IF INSIDE OF A FUNCTION ARGUMENT LIST.
  
 TRE30.1  BX7    X3 
          SB2    PAR.NX 
          SB7    E.VA04 
          SA1    ARGMODE
          SBIT   X1,AM.FUNP 
          PL     X1,TRE35    IF STAND ALONE EXTERNAL NOT ALLOWED
          SX0    X0+O.LP-O.RP 
          ZR     X0,TRE31    IF FOLLOWED BY RP
          NZ     X4,TRE35    IF NOT FOLLOWED BY A COMMA 
  
 TRE31    ZR     X5,TRE33    IF PRECEDED BY A SPECIAL LP
          SX5    X5+O.SLP-O.LP
          ZR     X5,TRE33    IF PRECEDED BY LP
          NZ     B3,TRE35    IF NOT PRECEDED BY A COMMA 
  
 TRE33    SB7    E.VA05 
          LX7    WB.FUNP-WB.INTFP 
          SBIT   X3,WB.DEXTP/WB.FUNP
          MI     X3,TREX     IF DECLARED AS EXTERNAL
          PL     X7,TRE35    IF NOT DECLARED AS INTRINSIC 
  
*         CHECK WHETHER INTRINSIC NAME ALLOWED AS ACTUAL ARGUMENT.
  
          MX0    -WB.JPFL 
          LX3    1+WB.DEXTP-WB.JPFP 
          BX7    -X0*X3      JPFI = JPF[WBI] = INTRINSIC TABLE INDEX
          SX0    Z.INTA 
          SB7    E.VA06 
          IX3    X7-X0
          MI     X3,TRE35    IF FUNC NAME NOT ALLOWED 
  
*         APPEND SUFFIX TO INTRINSIC FUNCTION NAME. 
  
          SA1    X7+F.INTF
          SA2    FUNCALL
          SA7    /CF/IT 
          RJ     TXI         TAG EXTERNAL INTRINSICS
          SA1    /CF/TP 
          SA3    CSYTAG 
          CLAS=  X2,TP,(ORD)
          BX1    X2*X1       GET ORD FROM (/CF/TP)
          BX6    -X2*X1      GET REST OF ATTRIBUTES FROM (CSYTAG) 
          SB2    PAR.NX 
          BX6    X1+X6
          SA6    CSYTAG      UPDATE CSYTAG
          EQ     TREX        EXIT...
  
 TRE35    FATAL  B7 
          EQ     TREX        EXIT...
  
*         HERE IF POSSIBLE SUBROUTINE.
  
 TRE40    SBIT   X3,WB.SUBP/WB.FUNP 
          PL     X3,TRE60    IF NOT A SUBROUTINE
          ZR     X0,TRE41    IF FOLLOWED BY *(* 
          SA3    ARGMODE
          =B2    PAR.NX 
          SBIT   X3,AM.FUNP 
          MI     X3,TREX     IF STAND ALONE OK THIS CASE
          FATAL  E.VA04      ** EXTERNAL REFERENCE REQUIRES ARGUMENTS 
          EQ     TREX 
  
 TRE41    WARN   E.VA07      ** SUBROUTINE USED AS FUNCTION 
          SB2    PAR.FUN     TREAT AS FUNCTION
          EQ     TREX        EXIT.. 
  
*         HERE IF DEFINED AS NOT-VAR BUT NOT A SUBROUTINE/FUNCTION. 
  
 TRE60    SBIT   X3,WB.ENTP/WB.SUBP 
          PL     X3,TRE65    IF NOT ENTRY POINT 
          SA3    S=VALUE
          MX0    -WB.MODEL
          LX6    -WB.MODEP
          BX1    -X0*X6      ISOLATE MODE OF THIS ENTRY NAME
          LX6    WB.MODEP 
          IX0    X3+X1       (X0) = SYMORD OF PROPER VALUE. SYMBOL
          SA1    MOD
          HX1    MO.FUN 
          PL     X1,TRE62    IF NOT IN FUNCTION SUBPROGRAM
          SA2    PARNOW 
          SB7    X2-PM=DIM
          SB2    B7+PM=DIM-PM=DATA
          ZR     B7,TRE62    IF PARSING DIMENSION BOUND 
          NZ     B2,TRE63    IF NOT PARSING DATA STATEMENT
  
 TRE62    SA1    S=BU 
          BX0    X1 
          FATAL  E.VA01      ** ILLEGAL USE OF ENTRY NAME 
  
 TRE63    CALL   CT1         CONSTRUCT (TP.) FORM OPERAND 
          SA6    CSYTAG 
          BX6    X2          SAVE *WB*
          SA1    B4+B1       FETCH NEXT TOKEN 
          SX0    X1-O.LP
          SA6    CSYWB
          EQ     TRE22
  
 TRE65    SBIT   X3,WB.NLSTP/WB.ENTP
          MI     X3,E.VA13   IF NAMELIST GROUP NAME 
          SBIT   X3,WB.DEXTP/WB.NLSTP 
          PL     X3,TRE70    IF UNCLASSIFIED NON-VARIABLE 
          ZR     X0,TRE70    IF FOLLOWED BY *(*, OKAY 
          SBIT   X3,WB.FUNP/WB.DEXTP
          EQ     TRE30.1     TREAT AS FUNCTION IN THIS CONTEXT
 TRE70    SPACE  4,30 
*         CHECK UNCLASSIFIED TAG FOR POSSIBLE VARIABLE OR FUNCTION
*         CLASSIFICATION. 
* 
*         ANSI COMMENT......
*         ANSI ALLOWS A PROGRAMMER TO DEFINE AN INTRINSIC FUNCTION IN A 
*         TYPE STATEMENT.  THUS A SYMBOL BY THE NAME OF A KNOWN 
*         INTRINSIC FUNCTION WILL BE SET INTO OUR SYMBOL TABLE BUT WILL 
*         NOT HAVE A CLASSIFICATION ON ITS USE.  WE ALSO HAVE TO WATCH
*         OUT FOR A SYMBOL THAT IS IN THE SYMBOL TABLE THAT HAS ONLY THE
*         *EXTERNAL* CLASSIFICATION BITS ON.  IN *EXTERNAL* CASE IT IS
*         SORT OF SIMPLE, CONTEXT TELLS USE WHAT TO DO. 
*                IN THE CASE OF A SYMBOL THAT HAS MERELY BEEN TYPED, WE 
*         MUST CHECK IF IT IS A *BEF* OR *INLINE* AND THEN CHECK IF THE 
*         MODE OF TYPING IS THE SAME AS THE EXPLICIT TYPING GIVEN THE 
*         FUNCTION BY ANSI. 
*         IF IT IS, THEN SYMBOL IS THE INTRINSIC DEFINED BY 
*         ANSI.  IF NOT, ITS DEFAULT IS SET TO A VARIABLE OR
*         EXTERNAL FUNCTION DEPENDING ON THE CONTEXT. 
* 
* 
*         ENTRY  (X0) = 0, IF FOLLOWED BY *(*.
*                (X6) = SYMTAB (WB) FOR SYMBOL IN PROGRESS. 
*                (A2) = ADDRESS OF SYMTAB (WB). 
*                (X7) = CLASS BITS (ONLY IF FOUND TO BE A VARIABLE).
*                (B7) = INDEX OF SYMTAB (WB). 
* 
*         EXIT   (X6) = UPDATED (WB) WORD.
*                       ALSO UPDATED IN TABLE OFF OF *A2*.
*                (B2) = PAR.XX PROCESSING ADDRESS FOR PARSER. 
* 
*         CALLS  SLT. 
  
  
 TRE70    LX2    X7 
          =B2    PAR.NX 
          BX1    X6 
          NZ     X0,TRE76    IF NOT FOLLOWED BY *(* - SET VARIABLE BIT
  
**        HERE IF ENTITY FOLLOWED BY *(*, BUT DOES NOT HAVE CLASS.
*         IF DECLARED EXTERNAL, SET CLASS = USER FUNCTION.
*         ELSE IF FOLLOWED BY SUBSTRING LPAREN, IT MUST BE
*                A CHARACTER VARIABLE.
*         ELSE IF IT IS A FORMAL PARAMETER, CLASS = USER FUNCTION.
*         ELSE SET CLASS = FUNCTION,
*                IF IN TABLE, FUNT = INTRINSIC, ELSE FUNT = USER. 
  
          HX1    WB.DEXT
          SA3    B4+B1
          MI     X1,TRE74    IF DECLARED EXTERNAL 
          HX3    TB.COL 
          SB2    PAR.SBS
          MI     X3,TRE78    IF FOLLOWED BY SUBSTRING LPAREN
          LX1    WB.DEXTP-WB.FPP
          MI     X1,TRE74    IF FORMAL PARAMETER
  
*         HERE IF NOT FORMAL PARAM.  CHECK IF ENTITY APPEARED IN TYPE 
*         STATEMENT AND TYPE AND NAME SAME AS AN INTRINSIC. 
  
          MX0    WA.SYML
          =A3    A2-WB.W+WA.W 
          SX5    B7          REMEMBER (X5) = WB INDEX OF SYMBOL 
          BX1    X0*X3       SYMBOL ONLY
          CALL   SLT         SCAN LIBRARY TABLE 
          SA1    T.SYM
          SB7    X5          RESTORE (B7) = WB INDEX
          SA2    X1+B7       RESTORE (A2) -> SYMTAB (WB)
          MI     B2,TRE74    IF NOT IN TABLE -- USER FUNCTION 
          SA1    B2+F.INTF
          SBIT   X1,IT.GNOP 
          MX0    -WB.MODEL
          LX0    WB.MODEP 
          PL     X1,TRE71    IF NOT GENERIC ONLY INTRINSIC
          WARN   E.TY9
          EQ     TRE72
  
 TRE71    BX1    X6-X3
          BX1    -X0*X1 
          ZR     X1,TRE72    IF DECLARED MODE AGREES WITH INTRIN TABLE
          WARN   E.TY2       ** CONFLICTING MODE IGNORED
  
*         CONFIRMED AS INTRINSIC FUNCTION.
  
 TRE72    SA1    STAGE
          SX4    FEC=EXU
          BX6    X0*X6       CLEAR USER DEFINED MODE
          IX4    X4-X1
          MX0    0
          BX6    X6+X3       MERGE IN NEW CLASS BITS
          NZ     X4,TRE73    IF NOT IN EXECUTABLES
          CLAS=  X0,WB,(TYP)
  
 TRE73    BX6    -X0*X6      CLEAR EXPLICIT TYPE BIT (AS APPLICABLE)
          SA6    A2 
          =A1    A2-WB.W+WC.W 
          BX7    X1+X7       MERGE (WC.FUNI) PER SLT
          SB2    PAR.FUN
          SA7    A1 
          EQ     TREX        EXIT.. 
  
*         CONFIRMED USER FUNCTION.
  
 TRE74    BSS 
 .USER    IFNE   MF.USER
          =A3    A2-WB.W+WC.W 
          =X0    MF.USER
          LX0    WC.FUNTP 
          BX7    X0+X3       SET FUNCTION TYPE = USER FUNC
          SA7    A3 
 .USER    ENDIF 
          CLAS=  X3,WB,(NVAR,FUN,EXT) 
          BX6    X6+X3       MERGE NEW CLASS BITS 
          SB2    PAR.FUN
          SA6    A2          UPDATE INFO IN SYMTAB
          EQ     TREX        EXIT.. 
  
*         HERE IF NAME NOT FOLLOWED BY LEFT PAREN.
*         A.  IF EXTERNAL BIT SET, CONTINUE, NOT SETTING ANY OTHER BITS.
*         B.  IF NOT (A), SET VARIABLE BITS DEFINED IN (X2).
  
 TRE76    HX1    WB.DEXT
          PL     X1,TRE78    IF NOT DECLARED EXTERNAL, CHANGE CLASS 
          SB7    E.VA04 
          SX0    X0+O.LP-O.RP 
          ZR     X0,TRE77    IF FOLLOWED BY RP
          NZ     X4,TRE35    IF NOT FOLLOWED BY A COMMA 
  
 TRE77    ZR     X5,TREX     IF PRECEDED BY A SLP 
          SX5    X5+O.SLP-O.LP
          ZR     X5,TREX     IF PRECEDED BY LP
          NZ     B3,TRE35    IF NOT PRECEDED BY A COMMA 
          EQ     TREX 
  
 TRE78    BX6    X6+X2       CONFIRMED AS VAR 
          SA6    A2 
          EQ     TREX        EXIT.. 
  
*         HERE IF ELEMENT NOT IN SYMBOL TABLE.
*         CHECK IF FOLLOWED BY NON-COLON LEFT PAREN.
*         IF YES, MUST BE A FUNCTION REFERENCE -- CALL *SLT*. 
*         IF NO,  MUST BE A SIMPLE VARIABLE -- ADD TO TABLE AND EXIT. 
  
 TRE80    =A1    B4+1 
          SX2    X1-O.LP
          SX4    PAR.NX 
          NZ     X2,TRE83    IF NOT FOLLOWED BY LPAREN
          HX1    TB.COL 
          PL     X1,TRE90    IF NOT SUBSTRING LPAREN
          SX4    PAR.SBS
  
 TRE83    CALL   STY         SET MODE 
          IX7    X7+X1       ADD IN CLASS FIELD 
          ADSYM  T.SYM       ADD SYMBOL, TAG TO TABLE 
          CALL   CT1         CONSTRUCT OPERAND FOR SYMBOL 
          SB2    X4 
          SA6    CSYTAG      SAVE P2 TAG
          =A6    A6-CSYTAG+CSYREF 
          BX6    X2 
          EQ     TREX        EXIT.. 
  
*         HERE IF NOT IN TABLE AND FOLLOWED BY *(*. 
*         EXIT   (NEXT) = 0, SYMBOL ALREADY USED, ARGUMENT COUNT SET. 
  
 TRE90    BX1    X6 
          CALL   SLT         SCAN LIBRARY TABLE 
          BX5    X7          REMEMBER SYMTAB (WC) PER SLT 
          MX1    0
          BX2    0
          PL     B2,TRE94    IF INTRINSIC FUNCTION
          CALL   STY         SET IMPLICIT TYPE
  
 TRE94    BX7    X1+X3       *WB* 
          BX2    X2+X5       *WC* 
          SA7    CSYWB
          ADSYM  T.SYM       ADD NAME TO SYMTAB 
          CALL   CT1         CONSTRUCT OPERAND FOR SYMBOL 
          SA6    CSYTAG 
          =A6    A6-CSYTAG+CSYREF 
          SB2    PAR.FUN     INDICATE EXTERNAL
          BX6    X2 
*         EQ     TREX        EXIT.. 
  
  
**        EXIT ROUTINE, BUT CHECK IF CROSS REFERENCE HAS BEEN REQUESTED 
*         FIRST.... 
*         ENTRY  (CSYMBOL, CSYTAG) = SET UP.
*                (X6) = SYMTAB PROPERTY WORD (WB).
*                (B2) = PROCESSOR ADDRESS.
  
 TREX     SA6    CSYWB
          LX6    -WB.MODEP
          MX1    -WB.MODEL
          BX1    -X1*X6      EXTRACT MODE 
          LX6    WB.MODEP 
          NZ     X1,TREX00   IF NOT MODE BOOLEAN
          ERRNZ  M.BOOL 
          MDERR  E.MDE2 
  
 TREX00   BX1    X6 
          HX1    WB.FUN 
          HX6    WB.EXT 
          BX1    X1*X6
          PL     X1,TREX0A   IF NOT EXTERNAL FUNCTION 
          SA1    =0LDATE
          SA2    CSYMBOL
          SA3    =0LTIME
          SA4    =0LCLOCK 
          BX1    X1-X2
          ZR     X1,TREX0    IF *DATE*
          BX1    X3-X2
          ZR     X1,TREX0    IF *TIME*
          BX1    X4-X2
          NZ     X1,TREX0A   IF NOT *CLOCK* 
  
 TREX0    MDERR  E.MDE5      ** DATE, TIME, AND CLOCK ARE MACHINE DEP.
  
 TREX0A   LX6    WB.EXTP+1   RESTORE X6 
          SA1    CMLFLG 
          ZR     X1,TREX1    IF NOT INPUT LIST ITEMS
          PL     X1,TREX1    IF NOT ARRAY SUBSCRIPT 
          BX1    X6 
          HX1    WB.FUN 
          PL     X1,TREX1    IF NOT A FUNCTION
          SA1    T=ILI
          ZR     X1,TREX1    IF NO INPUT LIST ITEMS 
          SX6    B2 
          SA6    PARPA       PRESERVE PROCESSOR ADDRESS (B2)
          =X6    1           INDICATE RESTART 
          CALL   IOJ         ISSUE RESTART
          SA1    PARPA
          SA2    CSYWB
          SB2    X1          RESTORE B2 
          BX6    X2          RESTORE X6 
  
 TREX1    SA1    PARNOW 
          ZR     X1,TREX8    IF STANDARD PARSE
          SX1    X1-PM=DIM
          NZ     X1,TREX8    IF NOT 'DIM BOUND' PARSING 
          SBIT   X6,WB.VARP 
          SB7    E.DM17 
          PL     X6,TREX2    IF NOT VARIABLE
          SBIT   X6,WB.ARYP/WB.VARP 
          SB7    E.DM18 
          MI     X6,TREX2    IF ARRAY 
          SA1    MOD
          SB7    E.DM14      ** ADJUSTABLE ARRAY CANT BE IN MAIN PROGRAM
          SBIT   X1,MO.PROP 
          MI     X1,TREX2    IF IN MAIN PROGRAM 
          SA1    TB=TYPE
          SB7    E.DM21      ** ADJUSTABLE ARRAY CANT BE IN COMMON
          LX1    -KW.JMPP 
          SB3    X1 
          ERRNZ  18-KW.JMPL 
          SB3    -B3
          SX1    B3+KW=COMM 
          ZR     X1,TREX2    IF PROCESSING COMMON ARRAY 
          SA1    T.SYM
          SA2    DIRT 
          SB3    X2 
          SA1    X1+B3       FETCH ARRAY *WB* 
          SBIT   X1,WB.COMP 
          MI     X1,TREX2    IF PROCESSING COMMON ARRAY 
          SA1    CSYTAG 
          MX0    -TP.MODEL
          LX1    -TP.MODEP
          BX1    X0*X1       CLEAR MODE 
          =X0    M.INT
          IX6    X1+X0       FORCE MODE INTEGER 
          LX6    TP.MODEP 
          SA6    A1 
          SA1    T.SYM
          HX6    TP.ORD 
          AX6    -TP.ORDL    EXTRACT ORDINAL
          SB3    X6 
          LX6    1
          SB3    X6+B3       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B3    B3-WA.W+WB.W 
          SA1    X1+B3
          CLAS=  X6,WB,(VDS)
          BX6    X6+X1
          SA6    A1          SET VDS BIT FOR THE VARIABLE 
          EQ     TREX9
  
 TREX2    RJ     DBE         OUTPUT DIMENSION ERROR 
          =A1    B4+1 
          SX1    X1-O.LP
          NZ     X1,TREX6    IF NOT *(* FOLLOWING ILLEGAL NAME
          =B4    B4+1 
          =B3    1           INITIALIZE *LP* COUNTER
          =B2    0           INITIALIZE *RP* COUNTER
  
 TREX3    =B4    B4+1 
          SA1    B4 
          ZR     X1,PSL      IF *EOS*, EXIT...
          SB7    X1-O.LP
          ZR     B7,TREX4    IF *(* 
          SB7    X1-O.RP
          ZR     B7,TREX5    IF *)* 
          EQ     TREX3
  
 TREX4    =B3    B3+1 
          EQ     TREX3
  
 TREX5    =B2    B2+1 
          NE     B2,B3,TREX3
  
 TREX6    SA1    CONONE 
          =B6    B6+1 
          LX6    X1 
          =A6    B6-1 
          =B4    B4+1        ADVANCE CURSOR PAST *)*
          EQ     PAR.NX 
  
 TREX8    SBIT   X6,WB.VDSP 
          PL     X6,TREX9    IF NOT FORWARD REFERENCE FORMAL PARAMETER
          FATAL  E.AT04 
  
 TREX9    SA2    CSYREF 
          HX2    TP.ORD 
          SX5    B2          SET (X5) = PROCESSOR ADDRESS 
          AX2    -TP.ORDL    ISOLATE (X2) = SYMBOL ORDINAL
          LX2    XR.TAGP
          SA1    REFVAR      TYPE OF REFERENCE
          LX6    X2 
          SA3    ARGMODE
          SB7    A=UNT
          SB7    -B7
          SB7    X3+B7
          NZ     B7,TREX10   IF NOT UNIT SPECIFIER
          SA3    CSYTAG 
          MX0    -TP.MODEL
          BX0    -X0*X3      EXTRACT MODE 
          SX0    X0-M.CHAR
          NZ     X0,TREX10   IF NOT INTERNAL FILE 
          SA3    IODIR
          SX1    CR.OUT 
          ZR     X3,TREX10   IF READ
          SX1    CR.INP 
  
 TREX10   ADDREF X6,X1
 VARX     SPACE  4,10 
**        VARX - TRANSLATION OF SYMBOL COMPLETE.
* 
*         ENTRY  (X5) = PROCESSOR ADDRESS.
*                (ATTR) = ATTRIBUTE BITS TO BE SET FOR PASS 2.
*                (CSYMBOL, CSYTAG, CSYWB) = SET UP. 
  
  
          SB2    X5          (B2) = PROCESSOR JUMP ADDRESS
          SA5    CSYTAG      FETCH (X5) = PASS 1 TAG FORM 
          SA4    ATTR 
          =B4    B4+1 
          SB6    B6+B1       ADVANCE ESTACK POINTER 
          BX6    X4+X5       MERGE P2 ATTRIBUTE BITS
          SA6    B6-B1       STACK THE SYMBOL 
          SA2    CMLFLG 
          ZR     X2,PAR.VAR7 IF NOT INPUT I/O LIST ITEMS
          =A2    B4+1 
          SX0    X2-O.LP
          CALL   CML         CHECK FOR MATCH IN LIST TABLE
  
*         TRANSFER TO SELECTED PROCESSOR -- 
*                (X6) = EL-STAK ENTRY = P2 TAG OF SYMBOL. 
  
 PAR.VAR7 JP     B2          JUMP TO PROCESS TRANSLATED SYMBOL
PAR.STFD  SPACE  4,10 
**        STFD - PARSE STATEMENT FUNCTION DUMMY ARG. TOKEN. 
  
 PAR.STFD LX1    -TB.ACTEP
          SA5    X1 
          ERRNZ  TB.ACTEL-18
          MX0    -TB.ORDL 
          LX1    TB.ACTEP-TB.ORDP 
          BX6    -X0*X1 
          SA2    T.SYM
          LX0    B1,X6
          =B7    X2+WB.W
          IX0    X0+X6
          SA2    B7+X0       WB(DUMMY)
          =A3    A2+WC.W-WB.W 
          MX0    -WB.MODEL
          LX2    -WB.MODEP
          BX6    -X0*X2 
          MX0    -WC.CLENL
          LX3    -WC.CLENP
          BX1    -X0*X3 
          MX7    0           CLEAR ATTRIBUTE SUMP 
          SA7    ATTR        UPDATE 
          RJ     CLM         COERCE MODE AND CHARACTER LENGTH 
          BX6    X5 
          SA6    B6          STACK CONVERTED ACTUAL 
          =B6    B6+1 
          =B4    B4+1 
          ZR     B7,STFD1    IF NO CONVERSION PROBLEM 
          FATAL  B7 
          EQ     PAR.NX 
  
 STFD1    =A1    B4-1 
          LX1    -TB.ACTEP   ACTUAL ARGUMENT POINTER
          SA1    X1 
          ERRNZ  18-TB.ACTEL
          IX1    X1-X5
          ZR     X1,PAR.NX   IF NO MODE COERSION
          ANSI   E.SF13      ** DUMMY/ACTUAL ARGUMENT TYPES MUST MATCH
          EQ     PAR.NX 
 PAR.SUB  SPACE  4,20 
**        HERE IF ELEMENT IS *ARRAY(*.
  
 PAR.SUB  SA1    CO.DBSB
          PL     X1,PAR.SUB1 IF SUBSCRIPTS IN-LINE
          SA1    T=PAR
          BX6    X1 
          SA6    CURST       INHIBIT SQUEEZE
  
 PAR.SUB1 RJ     SSO         SET UP SUBSCRIPT OPERATOR
                             *SSO* RETURNS  (X4) = NEW *ARGMIS*,
                                            (X7) = NEW *ARGCOMA*. 
          SA1    CMLFLG 
          ZR     X1,PAR.SUB2 IF NOT I/O INPUT LIST ITEM 
          MI     X1,PAR.SUB2 IF FLAG ALREADY SET FOR A *(*
          =X6    -B5         FLAG SET TO ADDR OF *(*
          SA6    A1 
  
 PAR.SUB2 SA3    ARRARM 
          BX6    X3 
          =B3    O.SLP
          EQ     PAR.SPS     ENTER PAREN STACK
 PAR.SBS  SPACE  4,10 
**        HERE IF ELEMENT IS SUBSTRINGED VARIABLE.
* 
*         ENTRY  (X6) = VARIABLE BEING SUBSTRINGED. 
* 
*         EXIT   TO PAR.SPS --
*                ARGMIS = OPERAND FOR VARIABLE. 
  
  
 PAR.SBS  BSS    0           ENTRY... 
 .T       IFEQ   TEST,ON
          SA1    B4 
          HX1    TB.COL 
          PL     X1,"BLOWUP" IF NOT SUBSTRING LPAREN
 .T       ENDIF 
  
          SA1    CMLFLG 
          ZR     X1,PAR.SBS5 IF NOT I/O INPUT LIST ITEM 
          MI     X1,PAR.SBS5 IF FLAG ALREADY SET FOR SUBSTRING *(*
          =X7    -B5         FLAG SET TO ADDRESS OF *(* 
          SA7    A1 
  
 PAR.SBS5 BX4    X6          ARGMIS = OPERAND 
          LX6    -TP.MODEP
          MX1    -TP.MODEL
          SA3    SBSARM 
          BX7    -X1*X6 
          SB3    O.SLP
          SB2    X7-M.CHAR
          LX7    AC.MODEP    ARGCOMA = [MODE, CNT=0]
          BX6    X3          ARGMODE = (SBSARM) 
          ZR     B2,PAR.SPS  IF MODE = CHARACTER
          FATAL  E.AT16      ** CAN ONLY SUBSTRING CHAR 
          RJ     SPE         SKIP THE SUBSTRING 
          SB4    B4+1 
          EQ     PAR.NX      CONTINUE 
 PAR.FUN  SPACE  4,20 
**        HERE IF ELEMENT IS A *FUNCTION* OF SOME KIND .... 
  
  
 PAR.FUN  BX0    X6 
          HX0    TP.ORD 
          SA1    T.SYM
          AX0    -TP.ORDL    ISOLATE (X0) = SYMORD OF FUNCTION
          IX7    X0+X0
          =B7    X1+WC.W
          IX3    X0+X7       (X3) = INDEX = Z=SYM * ORDINAL 
          ERRNZ  3-Z=SYM
          SA5    X3+B7       FETCH SYMTAB WORD (WC) 
          MX1    -WC.FUNTL
          LX5    -WC.FUNTP
          BX2    -X1*X5      ISOLATE TYPE OF FUNCTION 
          SB7    X2 
          JP     B7+FUNT     PROCESS EACH FUNCTION TYPE 
  
 FUNT     BSS    0
          LOC    0
  
 MF.USER  SA3    EXTFARM
          EQ     FUN.XU      EXTERNAL USER
  
 MF.STF   EQ     FUN.IS      INLINE STATEMENT FUNCTION
  
 MF.LIB   SA3    INFARM 
          EQ     FUN.IN      INTRINSIC FUNCTION 
  
 MF.BEF   LX5    WC.FUNTP    RESTORE (X5) = SYMTAB (WC) 
          EQ     "BLOWUP"    **** DOES NOT HAPPEN IN PHASE 0 **** 
  
 MF.INL   SA3    INFARM 
          EQ     "BLOWUP" 
  
          LOC    *O 
 FUN.IS   SPACE  4,10 
**        HERE IF REFERENCE TO STATEMENT FUNCTION.
* 
*         CALL STMFT/SFR TO EXPAND THE REFERENCE BY SUBSTITUTING
*         PARAMETERS. 
* 
*         EXIT   TO PAR.SPS --
*                (B4) -> FIRST TOKEN OF EXPANSION, IN (T.STF).
*                (B6) RESET ABOVE STATEMENT FUNCTION ESTACK ENTRY.
*                (INSTF) RESET TO INDICATE IN STATEMENT FUNCTION. 
*                (ALC.REG) = LOCKS (B4) TO (T.STF). 
*                 ARGMODE = (STFARM). 
*                 ARGMIS = OPERAND FOR FUNCTION NAME. 
*                 ARGCOMA = B3. 
  
  
 FUN.IS   =A5    A5+WB.W-WC.W 
          HX5    WB.SFX 
          PL     X5,FUN.IS1  IF NOT RECURSIVE FUNCTION NEST 
          FATAL  E.SF10 
          EQ     PAR.STOP 
  
 FUN.IS1  BX4    X6          ARGMIS = FUNCTION NAME OPERAND 
          SA3    STFARM 
          =B6    B6-1        UNSTACK SF NAME
          =X7    B6 
          LX7    AC.EARGP    ARGCOMA = (ESTACK(ARG1),COMMA COUNT) 
          BX6    X3 
          SB3    O.SLP
          EQ     PAR.SPS     SET PAREN STACK
 FUN.II   SPACE  4,10 
**        HERE IF INTRINSIC FUNCTION REFERENCE. 
  
 FUN.IN   BSS 
          SA1    CSYMBOL     NAME OF INTRINSIC
          SB3    O.ILP       SET INTRINSIC LEFT-PAREN 
          LX0    AS.ORDP
          IX4    X1+X0       (X4) = ARGMIS   = AS.[SYM, ORD]
          SA2    =4LLOCF
          IX7    X1-X2
          NZ     X7,FUN.IN1  IF THIS IS NOT 'LOCF'
          CLAS=  X1,AM,(ARE,FUN,LEV3) 
          BX3    X1+X3       ALLOW UN-LOADABLE NAMES
  
 FUN.IN1  BX6    X3          ARGMODE
          BX7    0           CLEAR ARGCOMA INITIALLY
          ERRNZ  M.BOOL      IF FALSE, MUST INITIALIZE AC.MODE TO M.BOOL
          EQ     PAR.SPS     ENTER PAREN STACK
 FUN.XU   SPACE  4,10 
**        HERE IF REFERENCE TO AN EXTERNAL FUNCTION.
  
 FUN.XU   LX5    WC.FUNTP-1-WC.CTYPP
          PL     X5,FUN.XU4  IF NOT ASSUMED-LENGTH CHARACTER
          MX1    1
          BX7    -X1*X5      CLEAR (WC.CTYP), TO AVOID FURTHER MESSAGES 
          LX7    WC.CTYPP+1 
          SA7    A5 
          FATAL  E.VA12      ** F.P. FUNCTION WITH LENGTH=(*) 
 FUN.XU4  MX2    -TP.MODEL
          BX4    X6 
          LX6    -TP.MODEP
          BX7    -X2*X6      EXTRACT (X7) = MODE OF FUNCTION
          ERRMI  AC.MODEL-WB.MODEL
          BX6    X3 
          LX7    AC.MODEP 
          SA2    T=BLST 
          ZR     X2,FUN.XU5  IF NOT IN BLOCK STRUCTURE
          CLAS=  X0,WB,(DLER) 
          BX5    X7 
          CALL   PDA         PROPOGATE DO LOOP ATTRIBUTE
          BX7    X5 
 FUN.XU5  SB3    O.SLP
          EQ     PAR.SPS
          TITLE  PARSE/ANALYZE NEXT SEPARATOR.
 PAR.SPS  SPACE  4,25 
**        SPS - SET PARENTHESIS STACK.
* 
* 
*         ENTRY  (X4) = NEW VALUE FOR ARGMIS. 
*                (X6) = NEW VALUE FOR ARGMODE.
*                (X7) = NEW VALUE FOR ARGCOMA.
*                (B3) = TOKEN VALUE TO BE ENTERED IN OSTACK.  MUST BE 
*                       A LEFT PAREN OPERATOR (O.LP, O.SLP, ETC.).
*                (B4) _ LEFT PAREN IN *TB*. 
* 
*         EXIT   WITH *ADDOP* ENTRY CONDITIONS SET. 
*                (X1) = SPECIAL LEFT PAREN TOKEN VALUE (=B3 ON ENTRY).
*                (X2) = STANDARD LEFT PAREN OPERATOR. 
*                (B3) = TOKEN VALUE OF NEXT *TB* ENTRY. 
*                (B4) _ NEXT *TB* ENTRY.
*                (B5) = ADVANCED BY:  1 
* 
*         RESET ... 
*                (ARGMODE,ARGCOMA,ARGMIS).
*                (REFVAR).
* 
*         OPERATOR STACK UPON EXIT ...
*                N = LEFT PAREN OPERATOR
* 
*         PARSER CONTEXT STACK ( T.PCS ) UPON EXIT ...
*                N - 2      =  OLD ARGMODE
*                N - 1      =  OLD ARGCOMA
*                N          =  OLD ARGMIS 
  
  
 PAR.SPS  SA6    SV67        SAV NEW ARGMODE
          SA7    A6+1        SAV NEW ARGCOMA
          SA2    ARGMODE
          LX6    X2 
          ADDWD  T.PCS       SAVE OLD VALUE FOR ARGMODE TO T.PCS
          SA5    ARGCOMA
          LX6    X5 
          ADDWD  T.PCS       SAVE OLD VALUE FOR ARGCOMA TO T.PCS
          SB2    ESTACK-4 
          SB7    E.LP3       ** EXPRESSION TOO COMPLICATED
          GE     B5,B2,POP.RP5     IF OUT OF ROOM 
          SA3    ARGMIS 
          BX6    X3 
          ADDWD  T.PCS       SAVE OLD VALUE FOR ARGMIS TO T.PCS 
          SX1    B3          DPC FOR *(*
          SA2    SV67 
          SA3    A2+1 
          BX6    X2          NEW ARGMODE
          LX7    X3          NEW ARGCOMA
          SA6    ARGMODE     RESET NEW *ARGMODE*
          SA7    ARGCOMA     RESET NEW *ARGCOMA*
          BX0    X6 
          LX7    X4 
          HX0    AM.REF 
          SA7    ARGMIS      RESET NEW *ARGMIS* 
          SA2    F.PRIOR-O.SEP+O.LP 
          AX0    AM.REFP
          =B4    B4+1        UPDATE TO NEXT ELEMENT 
          BX7    X0 
          SA6    A3          RESET NEW *ARGMIS* 
          SA7    REFVAR      SET REFERENCE CELL TO NEW VALUE
          MX0    -SP.TBPRL
          SB5    B5+B1
          LX0    SP.TBPRP 
          BX3    X0*X2
          IX6    X3+X1       CONSTRUCT LOP INSTAK SETOP WORD
          SA6    B5 
          =A5    B4 
          SB3    X5 
          ERRNZ  18-TB.TOTL 
          SA3    X1-O.DEF+F.CONO
          LX4    B3,X3
          MI     X4,PAR.NX   IF CURRENT / NEXT TOKEN PAIR LEGAL 
  
*         CHECK FOR IRREGULAR SYNTAX ALLOWED FOR -- 
*         ( )    FUNCTION WITH NO ARGUMENTS.
*         ( :    SUBSTRING DEFAULT FIRST. 
  
          SB2    X5-O.RP
          SA2    ARGMODE
          LX2    -AM.PADP 
          ERRNZ  18-AM.PADL 
          NZ     B2,PAR.SPS2 IF NOT RIGHT PAREN 
          SB2    X2-A=FUN 
          ZR     B2,PAR.SPS1 IF PROCESSING FUNCTION 
          SB2    X2-A=STFA
          ZR     B2,PAR.SPS1 IF PROCESSING ASF
          SB2    X2-A=INF 
          NZ     B2,PAREX    IF NOT PROCESSING INTRINSIC FUNCTION 
 PAR.SPS1 SA2    ARGCOMA
          MX7    AC.CNTL-1
          LX7    AC.CNTL+AC.CNTP
          BX7    X2+X7       MAKE COUNT -1 FOR NULL ARGUMENT LIST 
          SA7    A2 
          EQ     PAR.NX 
  
 PAR.SPS2 =B2    B2+O.RP-O.COLON
          NZ     B2,PAR.SPS5 IF NOT COLON 
          SB2    X2-A=SBS 
          NZ     B2,PAREX    IF NOT SUBSTRING LPAREN
          SA1    CONONE 
          BX6    X1 
          SB6    B6+B1       INVENT AND STACK DEFAULT FIRST OPERAND 
          SA6    B6-B1
          EQ     PAR.NX 
  
 PAR.SPS5 =B2    B2+O.COLON-O.EOS 
          NZ     B2,PAREX    IF NOT EOS 
          =B4    B4-1        **KLUDGE** TO PREVENT MODE OUT ON  ( EOS 
          EQ     PAREX
  
 SV67     BSS    2
 PAR.CM   EJECT  4,8
**        PROCESS COMMA OPERATOR. 
* 
*         WHEN A COLON IS LEGAL, IT IS PARSED THE SAME AS A COMMA.
** FV     IT WOULD BE NICE TO TELL HERE A BIT ABOUT (OSTACK) FLUSHING.
*         MOTIVATION FOR THE FOLLOWING CODE IS NOT EXACTLY STRAIGHT-
*         FORWARD.
  
  
 PAR.CM   BSS    0
          SA4    ARGMODE
          ZR     X5,PAR.CM9  IF *,* FOLLOWED BYE *EOS*
          ERRNZ  O.EOS
  
*         POP HOLDING STACK FOR ARGUMENT. 
*         JOINED HERE BY COLON PARSING. 
  
 PAR.CM5  LX3    -SP.STPRP
          MX4    -SP.STPRL
          BX3    -X4*X3      EXTRACT (X3) = LOP STACK PRIORITY
          SB7    PR.SLP+1 
          SB7    -B7
          SB7    X3+B7
          MI     B7,PAR.CM7  IF NOT ARITHMETIC OPERATOR 
          =X6    O.COMMA
          SA3    B5          (X3) = POPP-ED OPERATOR
          LX6    SP.TBPRP 
          =B5    B5-1 
          LX1    X6 
          SA6    POPDPC      INDICATE *,* CAUSING POP 
          RJ     POP         POP OPERATOR 
          SA3    B5 
          EQ     PAR.CM5     LOOP 
  
*         SET COMMA INTO OPERATOR STACK AND POP ARGUMENT. 
  
 PAR.CM7  SA1    B4 
          LX1    -TB.TOTP 
          SA2    F.PRIOR-O.SEP+X1 
          ERRNZ  18-TB.TOTL 
          MX0    -SP.TBPRL
 .T       IFEQ   TEST,ON     ASSERT:  TOKEN IN [COMMA, COLON] 
 A        BITMIC (O.COMMA,O.COLON)
          SB7    X1 
          SA3    ="A" 
          LX6    X3,B7
          PL     X6,"BLOWUP"
 .T       ENDIF 
          LX0    SP.TBPRP 
          LX1    SP.TBPRP 
          BX3    X0*X2       FORM COP INSTAK SETOP WORD 
          IX6    X3+X1
          =A6    B5+1        *,* OPERATOR TO OP-STACK 
  
*         POP COMMA OPERATOR.  ADD IMPLIED COMMA TO OPERATOR STACK
*         IF NEXT IS *EOS*. 
  
          BX3    X6 
          SA1    B5 
          RJ     POP         POP COMMA OPERATOR 
          SA3    ARGMODE
          LX3    -AM.PADP 
          ERRNZ  18-AM.PADL 
          SB7    X3-A=ARRAY 
          ZR     B7,PAR.CM8  IF SUBSCRIPT DONT INHIBIT SQUEEZE
          SA1    T=PAR
          BX6    X1 
          SA6    CURST       RESET SQUEEZE LIMIT
  
 PAR.CM8  SB7    X3-A=LIST
          ZR     B7,PAREXIT  IF IN I/O LIST 
          SB7    X3-A=DVL 
          ZR     B7,PAREXIT  IF IN DATA VARIABLE LIST 
          =B4    B4+1        NEXT 
          EQ     PAR.NX 
  
*         HERE IF COMMA FOLLOWED BY *EOS*.  LEGAL ONLY IN I/O LIST. 
  
 PAR.CM9  SB2    X4-A=LIST
          NZ     B2,PAREX    IF NOT I/O LIST PROCESSING 
          =B4    B4+1 
          EQ     PAR.NX      CONTINUE TO NEXT 
 PAR.COL  SPACE  4,10 
**        PAR.COL - PARSE COLON.
* 
*         VERIFY THAT COLON IS LEGAL IN THIS (ARGMODE). 
*         THEN HANDLE AS IF IT WERE A COMMA.  THIS MEANS THAT ALL (C=)
*         PROCESSORS FOR CONTEXTS WHERE COLON IS LEGAL MUST BE ABLE TO
*         PROPERLY DISCRIMINATE BETWEEN COMMA AND COLON.
* 
*         ALSO PERMITS IRREGULAR SYNTAX FOR OMITTED SUBSTRING-LAST. 
  
  
 PAR.COL  BSS                ENTRY... 
          SA4    ARGMODE
          LX4    -AM.PADP 
          SB7    X4          (B7) = PAREN POPPER ADDRESS
          ERRNZ  18-AM.PADL 
          LX4    AM.PADP-1-AM.COLP
          PL     X4,PAR.ERR  IF COLON NOT PERMITTED 
          SB2    X5-O.RP
          NZ     B2,PAR.CM5  IF NOT FOLLOWED BY RPAREN
          SB2    A=SBS
          EQ     B2,B7,PAR.CM5     IF A SUBSTRING COLON 
          SB2    A=PIX
          EQ     B2,B7,PAR.CM5     IF PIX CALL -- DIAGNOSIS BY CALLER 
          EQ     PAREX
 PAR.LP   EJECT  4,8
**        HERE IF UNQUALIFIED LEFT PARENTHESIS. 
*         IF THIS IS AN ARRAY SUBSTRING LPAREN, THEN (TB.SBS) WILL
*         HAVE BEEN SET WHEN THE SUBSCRIPT RPAREN WAS FOUND.  OTHERWISE,
*         IF IT IS NOT PART OF A COMPLEX CONSTANT, THEN IT ENCLOSES 
*         SOME EXPRESSION.
  
  
 PAR.LP   BSS    0
          SA4    B4 
          HX4    TB.SBS 
          PL     X4,PAR.LP2  IF NOT A SUBSTRING LEFT PAREN
          SA1    B6-B1
          BX6    X1          OBJECT OF SUBSTRING IS STACK TOP 
          EQ     PAR.SBS
  
 PAR.LP2  LX4    -TB.SBSP 
          RJ     CFC         CHECK FOR COMPLEX CONSTANT 
          SB4    A4 
          ZR     X0,PAR.LP5  IF CPLX CONST
          =X7 
          SA1    LPARM
          SB3    O.LP 
          BX6    X1 
          MX4    0
          EQ     PAR.SPS
  
 PAR.LP5  BX6    X1          REAL PART, IMAGINARY IN X2 
          =X1    M.CPLX 
          =B4    B4-1 
          EQ     TNK.DBL
 PAR.DLP  SPACE  4,10 
**        HERE IF DUMMY LEFT PAREN AT BEGINNING OF *TB* FOUND.
* 
*         PROCESS BY SETTING PAREN STACK TO PROPER MODE FOR OPERATING 
*         WITHIN CURRENT STATEMENT, THEN ADD SPECIAL PAREN TO OPERATOR
*         STACK.
  
 PAR.DLP  BSS    0
          SA3    ARGMODE
          SA2    ARGCOMA
          SB3    X1          OPERATOR 
          BX6    X3 
          LX7    X2 
          EQ     PAR.SPS     SET PAREN STACK
 PAR.RP   SPACE  4,10 
**        HERE FOR ALL RIGHT PARENS.
* 
** FV            ----- THIS NEEDS WORK ---- 
*         THE CONO TABLE ENTRY FOR RIGHT PAREN ALLOWS TWO FOLLOWERS 
*         WHICH ARE NOT PERMITTED IN NORMAL CONTEXTS -- 
*                O.LP     O.VAR 
*         ARE LEGAL RIGHT PAREN FOLLOWER TOKENS ONLY WHEN --
*                CHARARY (SUBX) (F : L) 
*                IOVERB (IOCTL) VAR 
*                IOVERB (IOCTL) (IOLOOP...) 
*                IF (EXPR) VAR ...
*         THE CHARACTER ARRAY SUBSTRING CONTEXT IS DISCOVERED BY
*         THE CODE BELOW.  THE OTHER STRANGE CONTEXTS ARE DENOTED 
*         BY THE (AM.RP) BIT IN THE CURRENT (ARGMODE).  WHEN NONE 
*         OF THESE "SPECIAL" RULES APPLY, WE MUST TREAT VAR AND LP
*         AS CONO VIOLATIONS. 
* 
*         ENTRY  (A5, X5) = NEXT TOKEN. 
  
  
 PAR.RP   BSS 
          MX7    1
          SB7    O.LP 
          SB2    X5          (B2) = NEXT TOKEN
          ERRNZ  TB.TOTP
          HX5    TB.COL 
          SA4    ARGMODE
          NE     B7,B2,PAR.RP1     IF NOT FOLLOWED BY LEFT PAREN
          SB2    A=DOCS 
          SB7    X4 
          ERRNZ  18-AM.PADL 
          ERRNZ  AM.PADP
          EQ     B2,B7,IDCEX IF I/O LOOP SCAN -- STOP COLLAPSE
          PL     X5,PAR.RP2  IF NOT A COLON LP
          SB7    X4-A=ARRAY 
          NZ     B7,PAR.RP2  IF THIS NOT END OF ARRAY SUBSCRIPT 
          LX5    TB.COLP-TB.SBSP
          BX6    X7+X5       MARK THE LP AS ARRAY SUBSTRING 
          LX6    TB.SBSP+1
          SA6    A5 
          EQ     PAR.STD
  
 PAR.RP1  SB7    O.VAR
          NE     B7,B2,PAR.STD     IF NOT FOLLOWED BY VAR 
          SB2    X4-A=IF
          ZR     B2,PAR.STD  IF PARSING *IF* STATEMENT
  
 PAR.RP2  HX4    AM.RP
          MI     X4,PAR.STD  IF SPECIAL SYNTAX ALLOWED
          SA5    A5          RELOAD TOKEN FOR ERROR MESSAGE 
          EQ     PAREX3 
 PAR.=    SPACE  4,20 
**        EQUAL SIGN - ADVANCE THRU CHAIN.
  
  
 PAR.EQL  BSS    0
          SA4    ARGMODE
          MX0    1
          LX0    AM.EQP+1 
          BX0    X0*X4
          NZ     X0,PAR.EQL2 IF *=* ALLOWED 
          FATAL  E.AT06      ILLEGAL USE OF ASSIGNMENT OPERATOR 
          =B4    B4+1        BYPASS BAD *=* 
          EQ     PAR.NX 
  
 PAR.EQL2 SA4    ZLE
          ZR     X4,PAR.STD  IF ZERO LEVEL EQUAL SIGN 
          =B4    B4+1        IGNORE ( SEE *EOS* PROCESS.) 
          EQ     PAR.NX      CONTINUE ...  (IGNORING *=*) 
 PAR.DIV  SPACE  4,8
**        DIVIDE - CHECK FOR POSSIBLE INTEGER DIVIDE. 
  
 PAR.DIV  =A4    B6-1        LAST OPERAND 
          MX0    -TP.MODEL
          LX4    -TP.MODEP
          SA5    MULTOG 
          =X6    1
          BX7    -X0*X4 
          LX6    SP.STPRP 
          SX4    X7-M.INT-1 
          BX6    X5-X6       TOGGLE MULTOG (FOR A/B*C*D === A/B *(C*D) )
          SA6    A5 
          PL     X4,PAR.STD  IF NOT POSSIBLE INTEGER DIVIDE 
          SA2    IDIV        THIS POPS ALL MULTS
          EQ     PAR.STD
 PAR.PL   SPACE  4,10 
**        PLUS - CHECK WHETHER UNARY OR BINARY. 
  
  
 PAR.PL   BSS    0
          =A4    B4-1        LOAD LAST OPERATOR 
          SA5    ="PREUNAR" 
          SB7    X4 
          LX0    B7,X5
          PL     X0,PAR.STD  IF NOT UNARY PLUS
          SA4    CONZER 
          BX7    X4 
          SA7    B6 
          =B6    B6+1 
          EQ     PAR.STD
 PAR.MI   SPACE  4
**        MINUS - CHECK WHETHER UNARY OR BINARY.
  
  
 PAR.MIN  BSS    0
          =A4    B4-1        LOAD LAST OPERATOR 
          SA5    ="PREUNAR" 
          SB7    X4 
          LX0    B7,X5
          PL     X0,PAR.STD  IF NOT UNARY MINUS 
          SA2    F.PRIOR-O.SEP+O.UMIN 
          =X1    O.UMIN 
          EQ     PAR.STD     PROCESS AS UNARY MINUS 
 PAR.MULT SPACE  4,20 
**        STAR - MAY BE STATEMENT LABEL PARAMETER INDICATOR.
  
  
 PRELABL  BITMIC (O.LP,O.SLP,O.COMMA) 
 POSTLAB  BITMIC (O.COMMA,O.RP) 
  
 PAR.MULT BSS    0
          SA4    B4-B1
          SA5    ="PRELABL" 
          SB7    X4 
          ERRNZ  18-TB.TOTL 
          LX7    X5,B7
          PL     X7,PAR.MU10 IF NOT UNARY STAR
          SA4    ARGMODE
          LX4    -AM.PADP 
          SB2    X4-A=CALL
          NZ     B2,PAREX    IF NOT IN SUBROUTINE ARGLIST 
          SA4    B4+B1
          SA2    A4+B1
          SB7    X4-O.CONS
          SB2    X2 
          NZ     B7,PAREX    IF STAR NOT FOLLOWED BY DIGIT(S) 
          SA5    ="POSTLAB" 
          LX7    X5,B2
          PL     X7,PAREX    IF LABEL NOT STANDING ALONE
          SB4    A2          ADVANCE TOKEN POINTER PAST LABEL 
          BX6    X4 
          CLAS=  X2,WB,(ALRN,SREF)
          CALL   ISL         IDENTIFY STATEMENT LABEL 
          MI     X6,PAREX11  IF ERROR IN LABEL
          MX4    -TP.MODEL   = -7 
          ERRNZ  7-N.TYPE 
          BX6    -X4+X6      **** KLUDGE **** 
          SA6    B6          STACK THE LABEL OPERAND
          SB6    B6+B1
          EQ     PAR.NX 
  
 PAR.MU10 SA4    MULTOG 
          IX2    X2-X4
          =X5    1
          LX5    SP.STPRP 
          BX7    X4-X5
          SA7    A4 
          EQ     PAR.STD
  
 MULTOG   BSSZ   1
 PAR.STD  SPACE  4,20 
**        XOR - DIAGNOSE NON-ANSI 
  
 PAR.XOR  ANSI   E.AT21 
*         EQ     PAR.STD     FALL THROUGH FOR NOW 
  
  
**        PAR.STD - MAKE STACK OR POP DECISION. 
* 
*         COMPARE CURRENT OPERATOR (COP) TO LAST OPERATOR (LOP) --
*         IF COP .GE. LOP  --  ADD COP TO OPERATOR STACK. 
*         IF COP .LT. LOP  --  POP LOP, AND LOOP TO PERFORM SAME CHECK
*                           ON NEW STACK TOP, AGAIN.
* 
*         ENTRY  (X1) = COP, TOKEN TYPE FOR CURRENT OPERATOR. 
*                (X2) = SETOP WORD FOR COP. 
*                (X3) = LOP, LAST OPERATOR (INSTACK *SETOP* WORD).
* 
*         EXIT   PAR.ADOP -- IF COP BECOMES .GE. LOP. 
*                PAR.NX   -- WHEN POP REPLIES ENUF DONE.
* 
*         CALLS  POP. 
  
  
 PAR.STD  BSS    0
          MX5    CH.DPCL
          SA4    X1+CHARMAP 
          HX4    CH.DPC 
          BX6    X5*X4       X6 = DPC OF COP
          SA6    FILL.2      SET FILLER FOR E.AT14
  
 PAR.CAT  LX3    -SP.STPRP
          SB4    B4+B1
          MX4    -SP.STPRL
          LX2    -SP.TBPRP
          BX5    -X4*X3 
          MX4    -SP.TBPRL
          BX0    -X4*X2      EXTRACT (X0) = TOKEN BUFFER PRIORITY 
          IX0    X0-X5
          LX3    SP.STPRP    RESTORE LAST OPERATOR
          LX2    SP.TBPRP    RESTORE CURRENT OPERATOR 
          PL     X0,PAR.ADOP IF COP .GE. LOP, ADD TO OPSTACK
  
*         SET UP FOR *POP* CALL.
*                (X1) = COP.
*                (X3) = OPSTACK ENTRY FOR OPERATOR TO BE POPPED.
  
          BX6    X1 
          =B5    B5-1 
          LX7    X2 
          SA6    POPDPC      SAVE *DPC* FOR OPERATOR
          =B4    B4-1 
          =A7    A6-POPDPC+POPPER  SAVE OPERATOR STACK WORD (SETOP WORD)
          RJ     POP         POP OPERATOR 
  
*         RETURN FROM *POP*.
*         IF *POPPER* HAS BEEN SET NEGATIVE, OPERATOR HAS BEEN
*         NULLED  (I.E., WHEN RIGHT PAREN POPPING LEFT PAREN).
  
          SA2    POPPER 
          SA3    B5          RELOAD LAST OPERATOR 
          =A1    A2-POPPER+POPDPC 
          PL     X2,PAR.STD  CONTINUE CHECK FOR POPPING 
          EQ     PAR.NX      NEXT 
 PAR.ADOP EJECT  4,8
**        ADD OPERATOR TO OP-STACK. 
* 
*         ENTRY  (X1) = DPC FOR OPERATOR. 
*                (X2) = CURRENT OPERATOR STACK ENTRY. 
* 
*         EXIT   (B5) = UPDATED TO POINT TO CURRENT OPERAND.
*                (X6) = OPERAND ADDED TO ESTACK.
  
  
 PAR.ADOP MX0    -SP.TBPRL
          SB5    B5+B1       UPDATE POINTER 
          SB2    ESTACK-8 
          SB7    E.LP3       ** EXPRESSION TOO COMPLICATED
          GE     B5,B2,POP.RP5     IF OSTACK TOO FULL 
          LX0    SP.TBPRP 
          BX3    X0*X2
          IX6    X3+X1       PRIORITY + ORIGINAL ENTRY
          SA6    B5          ADD TO STACK 
          EQ     PAR.NX 
 ERR      EJECT  4,8
**        HERE IF ILLEGAL COMBINATION OF CURRENT/NEXT TOKENS. 
* 
*         ENTRY  (X1) = TOKEN VALUE FOR OPERATOR. 
*                (X5) = NEXT TOKEN (THE ONE FOLLOWING (X1)).
  
  
 PAR.ERR  BSS    0
  
 PAREX    SA4    ARGMODE
          BX0    X4 
          SBIT   X0,AM.RPP
          PL     X0,PAREX2   IF NO SPECIAL SYNTAX ALLOWED 
  
 PAREX1   SB2    X1-O.RP
          NZ     B2,PAREX3   IF NOT LOOKING AT *)*
          JP     B7          CONTINUE 
  
 PAREX2   SB2    X4-A=IF
          ZR     B2,PAREX1   IF IN *IF* PROCESSING
  
 PAREX3   MX0    CH.DPCL
          SA2    X1+CHARMAP 
          NZ     X2,PAREX5   IF NOT *SYMBOL*
          BX2    X1          USE (TB.TOC) 
  
 PAREX5   BX6    X0*X2
          SA2    X5+CHARMAP 
          SA6    FILL.       SET FILLER 
          NZ     X2,PAREX10  IF NOT *SYMBOL*
          BX2    X5 
  
 PAREX10  BX6    X0*X2
          SB7    E.AT02 
          SA6    A6+B1       SET FILLER 
          FATAL  B7          OUTPUT ERROR 
  
 PAREX11  =X4    X5-O.COMMA 
          ZR     X4,PAREX13  IF COMMA 
          =X1    X5-O.RP
          NZ     X1,PAREX15  IF NOT RP
  
 PAREX13  SB4    B4+1        MOVE PAST IT 
  
 PAREX15  SA5    B4 
          ZR     X5,PAREX16  IF EOS 
          ERRNZ  O.EOS
          =B4    B4+1 
  
 PAREX16  BX4    0
          MX5    0
          EMIT   ERROP,*
          SA5    CDIFLG 
          ZR     X5,PAREX17  IF NO DO INDICATION ERROR
          SA1    T.BLST 
          SA2    T=BLST 
          =B2    X2-1 
          SA1    X1+B2       X1 = LC. WORD
          LX1    -LC.CNTP 
          SB2    X1-1-DO.W
          ERRNZ  LC.CNTL-18 
          SA1    A1-B2       X1 = DO.W
          LX1    -DO.IODP 
          SB2    X1          IMPLIED DO INDICATION
          ERRNZ  18-DO.IODL 
          NZ     B2,PAR.STOP IF ERROR IN IMPLIED DO 
  
 PAREX17  SA1    ARGMODE
          SB7    X1-A=CALL
          ERRNZ  18-AM.PADL 
          ZR     B7,PAR.STOP EXIT IF PROCESSING CALL ARGUMENT 
          EQ     PAR.NX      CONTINUE..  (IGNORING NASTY CHARACTER) 
 PAR.EOS  EJECT  4,8
**        END OF STATEMENT (*EOS*) TOKEN ENCOUNTERED. 
* 
*         PROCESSING WHEN *EOS* FOUND IS DEPENDENT UPON THE VALUE OF
*         *ZLE*.  UPON ENTRY TO *PAR* THE CONDITION OF *ZLE* WAS SET TO 
*         INDICATE WHETHER AN *=* WAS FOUND DURING THE TABBING OF THE 
*         CURRENT STATEMENT BEING PROCESSED.  *ZLE* UPON ENTRY TO THIS
*         SECTION POINTS TO THE LAST *=* FOUND DURING TABS PROCESS, 
*         WHERE ALL PREVIOUS *=* CONTAIN A LINK TO PREVIOUS *=* . 
*         THUS A SIMPLE CHECK IF DONE ON *ZLE* TO DETERMINE IF WE HAVE
*         PROCESSED WHAT IS ON THE LEFT HAND SIDE OF THE *=*S, OR 
*         WHETHER THERE WAS ONE FOR THIS STATEMENT.  IN ANY CASE WE WILL
*         LINK BACKWARDS THRU THE TABBED *TB* TILL WE FINALLY COME TO 
*         THE TERMINAL LEFT MEMBER OF THE STATEMENT.
* 
*         GENERAL FLOW. 
* 
*         A.  FLUSH REMAINDER OF OP-STACK.
*         B.  CHECK IF LAST *=* (LEFT MEMBER) HAS BEEN PROCESSED. 
*             1.  IF YES - SET ENDING CONDITIONS AND EXIT.
*             2.  IF NO  - RESET *TB* POINTER,(B4), AND *ZLE* TO NEW
*                         CONDITION.
* 
*         VISUAL EXAMPLE. 
* 
*                0        1         2         3         4 
*                12345678901234567890123456789012345678901
*                A=B=C=D=E=F=R**2-K+L-ARR(I,J,K+L,4,5,6,7)
*                           ZLE=12  (ENTRY TO PAR)
*         POINTER=        8 
*         POINTER=      6 
*         POINTER=    4 
*         POINTER=  2 
  
  
 PAR.EOS  BSS    0
          SB3    OSTACK 
          SB3    B5-B3
          GT     B3,PAR.EOS6 IF OPERATOR STACK NOT EMPTY
          SA1    ZLE
          ZR     X1,PAR.EOS3 IF TRUE *EOS*
          SA2    X1 
          =X6    O.EOS
          AX2    TB.TOCP
          SA6    A2          REPLACE *=* WITH *EOS* 
          SB4    X2          RESET *B4* TO *=*
          SA1    TB=1ST 
          =B2    1
          NZ     X2,PAR.EOS1 IF NOT LAST *=*
          SB4    X1          RESET TO STARTING POSITION 
          =B2    0
  
 PAR.EOS1 BX6    X2 
          SA3    B4+B2
          SA6    ZLE         RESET TO NEXT LEVEL
          =X1    O.=
          =X6    CR.STR 
          SB7    X3-O.VAR 
          ERRNZ  18-TB.TOTL 
          SA2    F.PRIOR-O.SEP+O.=
          SA6    REFVAR      SET UP FOR *STORE* 
          ZR     B7,PAR.ADOP IF LEFT MEMBER IS A SYMBOL 
          FATAL  E.VA11      ILLEGAL LEFT MEMBER
  
*         HERE IF LAST *=* PROCESSED. 
  
 PAR.EOS3 SA1    ARGMODE
          =X3    O.COMMA
          SBIT   X1,AM.EOSP 
          PL     X1,PAREXIT  IF NO SPECIAL EOS PROCESSING 
          BX6    X3 
          SA1    T.PAR
          SA2    T=PAR
          ZR     X2,PAR.EOS4 IF NO PARSE FILE 
          SB7    X2-Z=TURP
          SA2    X1+B7       FETCH LAST TURPLE
          MX0    -TH.OVALL
          LX2    -TH.OVALP
          BX2    -X0*X2      EXTRACT LAST OPERATOR
          SX2    X2-O.ERR 
          ZR     X2,PAREXIT  IF LAST WAS ERROR TURPLE 
  
 PAR.EOS4 =X1    O.EOS
          =A6    B5+1 
          LX1    SP.TBPRP 
          RJ     POP         POP LAST ARGUMENT
 PAREXIT  SPACE  4,10 
**        PAREXIT - EXIT PARSER.
* 
*         ENTRY  (B4) _ TOKEN WHICH STOPPED SCAN.  I.E., 1 PAST 
*                       LAST TOKEN TRANSLATED.
* 
*         EXIT   (B4) _ LAST TOKEN TRANSLATED BY PARSER.
  
  
 PAREXIT  BSSENT 0           EXIT PARSER THROUGH HERE 
  
 SNAP=P   IFEQ   TEST,ON     DUMP PARSED FILE 
          SA1    CO.SNAP
          LX1    1RP
          PL     X1,PAR.EOSA IF SNAP NOT REQUESTED
          CALL   SN.PAR 
 PAR.EOSA BSS    0
 SNAP=P   ENDIF 
  
 SNAP=Z   IFEQ   TEST,ON     DUMP PARSE TABLES
          SA1    CO.SNAP
          LX1    1RZ
          PL     X1,PAR.EOSS IF PARSE SNAP NOT SELECTED 
 PARSEXIT PARSNAP 
 PAR.EOSS BSS    0
 SNAP=Z   ENDIF 
  
          =B4    B4-1        RESET TO LAST ELEMENT PROCESSED
          EQ     PARX        EXIT.. 
 EOS6     SPACE  4,10 
**        FLUSH REMAINING OP STACKS.
  
 PAR.EOS6 SA3    B5          OPERATOR TO POP
          =B5    B5-1 
          MX0    -SP.TBPRL
          LX3    -SP.TBPRP
          BX2    -X0*X3      EXTRACT (X2) = COP TOKEN BUFFER PRIORITY 
          SB2    X2-O.SLP 
          SB3    X2-O.LP
          LX3    SP.TBPRP 
          ZR     B2,PAR.EOS8 IF *(* BEING POPPED
          NZ     B3,PAR.EOS7 IF NOT POPPING *LP*
          SB7    E.LP1
          EQ     POP.RP5     TAKE ERROR EXIT
  
 PAR.EOS7 BX6    0
          SA1    B5 
          SA6    POPPER 
          =A6    A6-POPPER+POPDPC 
          RJ     POP         POP OPERATOR 
          SA1    POPPER 
          PL     X1,PAR.EOS  IF NO PROCESSING NOT SET 
          =B4    B4-1        RESET *B4* 
          =B5    B5-1 
          EQ     PAR.EOS     CONTINUE 
  
 PAR.EOS8 SA5    ARGMODE
          HX5    AM.EOS 
          PL     X5,PAR.EOS9 IF EOS DOESNT UNSTACK *(*
          SX1    O.RP 
          =X7    -1 
          SA7    POPPER 
  
 PAR.EOS9 BX6    X1 
          SA6    POPDPC      UPDATE   DPC   FOR OPERATOR
          =X1    O.EOS       INDICATE *(* BEING POPPED BY  *EOS*
          LX1    SP.TBPRP 
          RJ     POP
 PAR.STOP SPACE  4,10 
**        PAR.STOP - CATASTROPHIC ERROR FOUND IN CURRENT STATEMENT. 
*                OUTPUT ERROR TURPLE AND EXIT BACK TO MASTER LOOP,
*                IGNORING RETURN TO CALLER OF PAR.
* 
*         EXIT   TO *PSL* TO START NEXT STATEMENT.
* 
*         CALLS  ADT. 
  
  
 PAR.STOP SA3    ERROP
          SHRINK T=SCR       IN CASE OF ERRORS
          =X7    0
          BX4    0
          LX6    X3 
          =X5    0
          SA7    SMOD 
          =A6    A7-SMOD+SOPR 
          RJ     ADT         ADD ERROR TURPLE 
          SA2    T.TB 
          SB3    X2 
          SB3    B4-B3
          =A1    B4+1        PREFETCH 
          =X6    1
  
 STOP1    SA1    A1-1        FETCH TOKEN
          SB2    X1-O.DOCI
          ZR     B2,PSL      IF DO CONCLUSION, NO HANGING IMPLIED DO
          SB2    X1-O.DOBI
          ZR     B2,STOP2    IF DO BEGIN, HANGING IMPLIED DO
          SB3    B3-1 
          PL     B3,STOP1    IF NOT FINISHED
          EQ     PSL         EXIT 
  
 STOP2    SA6    CDIFLG      ERROR IN DO INDICATION 
          EQ     PSL         START ANEW 
          TITLE  POPPING (SYNTHESIS). 
 POP      EJECT  4,20 
**        POP - EMIT TURPLES FOR TOP OPERATOR.
*                PROCESSING.
* 
*         ENTRY  (X1) = OPERATOR CAUSING (X3) TO BE POPPED. 
*                (X3) = CURRENT OPERATOR BEING POPPED.
* 
** FV     EXPLAIN (B5) BETTER, SOMETIME.
*                (B5) _ OPERATOR BELOW OF OPERATOR BEING POPPED.
*                E.G., IF  .AND.  WERE POPPED BY  .NOT. , THE OPSTACK 
*                    WOULD LOOK LIKE BELOW,  WITH B5 POINTING TO *EOS*. 
*                      OPSTACK =    0     1     2 
*                                 EOS .AND. .NOT. 
*                            B5     ' 
* 
*                (B6)-1  _  TOP OPERAND IN ESTACK.
* 
*         EXIT   (B6)-1  _  TOP OPERAND IN ESTACK.
*                TOP OPERAND = RESULT OF POPPED OPERATION.
*                (B5) _ TOP OPERATOR IN OSTACK. 
*                (B4) _ NEXT TOKEN. 
* 
*                NOTE- NOT ALL SUB-PROCESSORS RELATED TO *POP* EXIT THRU
*                      POPX.
*                    A.  TO PAR.NX - PARENTHESIS POPPERS. 
*                    B.  TO PAR.ADOP - WHEN OPERATOR CHANGED. 
*         USES   ALL. 
  
 IOL.RTN  BSSENT 0           ...RETURN FROM IOL 
  
 POP      SUBR   0
          MX6    -SP.TBPRL
          SA5    T.PAR
          LX1    -SP.TBPRP
          SX7    B0          CLEAR RESULT MODE
          BX1    -X6*X1      ISOLATE OP CAUSING POP 
          LX3    -SP.TBPRP
          SA7    SMOD 
          BX2    -X6*X3      EXTRACT (X2) = TOKEN TYPE OF POPPED OP 
          LX3    SP.TBPRP 
          SA4    T=PAR
          SB3    X1          (B3) = TOKEN TYPE OF OPERATOR CAUSING POP
          LX6    X3 
          SA7    ATTR        CLEAR ATTRIBUTE CELL 
          IX0    X4+X5
          SA6    SOPR        SAVE OPERATOR
          SX7    X0-Z=TURP+OR.OPR 
          SA7    LASTAD      LAST TURPLE OPERATOR ADDRESS 
          SA4    B6-2        1ST OPERAND INTO (X4)
          SA5    X7 
          SA2    X2-O.DEF+F.POPNX 
          SB7    O.ILL
          GT     B3,B7,"BLOWUP" 
          BX6    X5 
          =X7    0
          SA6    LASTOP      SET LAST OPERATOR
          =B2    0           ALWAYS A *0* UPON EXIT 
          =A5    A4+1        2ND OPERAND INTO (X5)
  
 SNAP=Z   IFEQ   TEST,ON     DUMP PARSE TABLES
          SA5    CO.SNAP
          LX5    1RZ
          PL     X5,POPS     IF PARSE SNAP NOT SELECTED 
          =A5    A4+1 
 POPP     PARSNAP 
 POPS     =A5    A4+1 
 SNAP=Z   ENDIF 
  
          BX6    X3          CURRENT OPERATOR 
          SB7    X2 
          SBIT   X6,SP.COMP 
          PL     X6,POP.JP   IF NOT COMMUTATIVE OPERATOR
  
**        FIX ORDER OF COMMUTATIVE OPERATORS IN TAG NUMERIC ORDER.
* 
** FV            FIX COMMUTATIVE SORT ORDER --
*         6      INTR.
*         5      ARY  --  DOUBLE, SINGLE. 
*         4      VAR / PROGRAMMER  -- DOUBLE, SINGLE. 
*         3      VAR / INVENTED --  CONSTANTS LAST. 
*         0      SHORT CONSTANT.
* 
*         SORT BY (ORBI) WITHIN EACH ABOVE CLASS. 
  
 .KEY     ECHO   ,OP=(4,5),KY=(1,2) 
          BX.KY  X.OP 
          LX.OP  -TP.INTRP
          SX6    B1 
          AX.KY  TP.ORBIP 
          BX7    X6*X.OP     KEY = 1S8 * INTR 
          LX7    TP.ORBIL+8 
          LX.OP  TP.INTRP-TP.SHRTP
          BX.KY  X.KY+X7
          BX7    -X.OP*X6    KEY += 1S1 * (NOT SHORT) 
          LX7    TP.ORBIL+1 
          LX.OP  TP.SHRTP-TP.MODEP
          MX6    -TP.MODEL
          BX.KY  X.KY+X7
          BX7    -X6*X.OP    KEY += 1S4 * MODE
          LX7    TP.ORBIL+4 
          ERRMI  8-4-TP.MODEL 
          LX.OP  -TP.MODEP   RESTORE (X.OP) = OPERAND 
          BX.KY  X.KY+X7
 .KEY     ENDD
  
          IX7    X1-X2       SORT BY (KEY, ORD, BIAS) 
          BX1    X4 
          PL     X7,POP.JP   IF IN NUMERIC ORDER
          BX4    X5 
          LX5    X1 
  
**        ENTER POPPING ROUTINE WITH -- 
*                (B2) = ALWAYS A *0* UPON EXIT. 
*                (B3) = TOKEN TYPE OF OPERATOR CAUSING POP. 
*                (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
*                (X7) .GE. 0, IF OPERANDS NOT REVERSED. 
  
 POP.JP   JP     B7          JUMP TO POPPER...
 POP.ERR  SPACE  4,10 
**        POP.ERR - SOMETHING UNCLEAN HAPPENED. 
* 
*         EMIT ERROR TURPLE.
  
  
 POP.ERR  BSS    0
          SA3    ERROP
          =X7    0           CLEAR OPERATOR CELL
          MX4    0
          BX5    0           (1OP) = (2OP) = NIL
          SA7    SOPR 
          EQ     POP.ST1     ADD ERROR TURPLE 
 POP.STD  SPACE  4,20 
**        STD -  SET DOMINANT MODE / ADD TURPLE TO PARSED FILE. 
* 
*         ENTRY  (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
* 
*         CALLS  SDM. 
  
  
 POP.STD  BSSENT 0
  
*         IF POPPING CAUSED BY OPR. WITH LOWER PRIORITY THAN MULT,
*         RESET MULT TOGGLE SO NEXT * WILL BE 'POPABLE'.
  
          MX0    -SP.TBPRL
          SA1    POPPER 
          LX1    -SP.TBPRP
          BX7    -X0*X1 
          MX6    0
          SX7    X7-PR.MULT 
          PL     X7,POP.ST0  IF COP GE PRIOR(*) 
          SA6    MULTOG      MULTOG = 0 
  
 POP.ST0  RJ     SDM         SET DOMINANT MODE
  
  
**        ST1 -  ADD TURPLE TO PARSED FILE. 
* 
*         ENTRY  (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
* 
*         CALLS  ADT, OMC.
  
  
 POP.ST1  BSS    0           ENTRY... 
          BX6    X3 
          SA6    SOPR        SET OPERATOR CELL
          RJ     OMC
          RJ     ADT         ADD TURPLE 
          EQ     POPX        EXIT.. 
 C=OPER   EJECT  4,20 
**        POP.CM - PROCESSING OF A COMMA. 
* 
*         C=XXX PROCESSING SECTION. 
* 
*         ENTRY  (ARGMODE) = CURRENT VALUE FOR C= IN DEFINED FIELD. 
*                (X3) = CURRENT OPERATOR WORD FOR COMMA.
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
* 
*         EXIT   SEE INDIVIDUAL PROCESSORS. 
*                (NOTE - NOT ALL PROCESSORS EXIT DIRECTLY THRU *POP*...)
  
  
 POP.COL  BSS    0
 POP.CM   BSS    0
          SA1    ARGCOMA
          SA2    ARGMODE
          SX0    B1 
          LX0    AC.CNTP
          IX6    X1+X0       UPDATE NUMBER OF ARGUMENTS 
          MX0    -AM.COML 
          BX7    X2 
          AX2    AM.COMP
          BX0    -X0*X2      C=XXX ADDRESS
          SA6    A1 
          SB2    X0 
  
*         TRANSFER TO PROCESSORS WITH  ...
*                (X2) = (ARGMODE) SHIFTED BY AM.COMP. 
*                (X6) = CURRENT VALUE OF *ARGCOMA*. 
  
          JP     B2          JUMP TO INDIVIDUAL PROCESSOR 
 C=ERR    SPACE  4,10 
**        C=CERR - IF COMMA NOT ALLOWED FOR PAREN LEVEL CURRENTLY IN. 
  
  
 C=CERR   BSSENT 0           ENTRY... 
          FATAL  E.AT05 
 C=ERR    BSSENT 0           ENTRY... 
          EQ     POP.ERR
 POP.RP   SPACE  4,10 
**        POP.RP - RIGHT PAREN BEING POPPED.
*         OUTPUT ERROR, TOO FEW LEFT PARENS - SCANNING STOPPED. 
* 
*         JOINTED AT POP.RP5  BY LEFT PAREN POPPER IF NOT BEING POPPED
*         BY RIGHT PAREN -- ERROR = TOO FEW RIGHT PARENS. 
* 
*         EXIT   TO C=ERR.
  
  
 POP.RP   BSS    0
          =A1    B5+1 
          AX1    TB.IOSPP    TEST FOR SPECIAL RIGHT PAREN 
          ZR     X1,POP.RP1  IF NOT SPECIAL RP, THEN ERROR
          EQ     PAR.EOS3    CONTINUE PROCESSING IO LIST
 POP.RP1  =B4    B4-3        SET FOR ERROR PROCESSING 
          SB7    E.LP2
 POP.RP5  FATAL  B7 
          EQ     PAR.STOP    CATASTROPHIC ERROR, START ANEW 
 POP.PN   EJECT  4,30 
**        POP.PN - RIGHT PARENTHESIS POPPING LEFT PARENTHESIS.
* 
*         A=XXX PROCESSING SECTION. 
* 
*         GENERAL FLOW. 
*         UPON ENTRY ARGMODE AND ARGCOMA ARE SET TO THE CURRENT MODE
*         OF THE SUB-EXPRESSION DEFINED IN PARENTHESIS AS SET WHEN
*         THE OPEN PAREN WAS FOUND. 
* 
*         THE NEW VALUES TO BE SET FOR CELLS ARGMODE,ARGCOMA AND ARGMIS 
*         WERE PREVIOUSLY SET BY *SPS* TO BE IN THE OPERATOR STACK IN 
*         FRONT OF THE CURRENT LEFT PAREN THAT IS CURRENTLY BEING POPPED
*         THUS WE RESET ALL THREE OF THESE CELLS AS DEFINED BELOW.
* 
*         AFTER THIS WE EXIT TO THE APPROPRIATE A=XXX PROCESSOR DEFINED 
*         BY THE A= FIELD OF THE ENTRY ARGMODE. 
* 
*         NOTE -
*         IF LEFT PAREN NOT BEING POPPED BY RIGHT PAREN - NEXT ENTRY
*         IN *TB* IS REPLACED WITH AN *EOS* AND EXIT IS MADE TO C=CERR
*         TO OUTPUT ERROR INDICATING TOO MANY LEFT PARENS, AND TO ADD 
*         ERROR TURPLE TO PARSED FILE.
* 
*         PARSER CONTEXT STACK
* 
*                N - 2       ARGMODE. 
*                N - 1       ARGCOMA. 
*                N           ARGMIS 
* 
*         ARGMODE FORMAT. 
*         +-----------+-----------+-----------------+-----------------+ 
*         +           +           +                 +                 + 
*         +  REFVAR   +ATTRIBUTES +      C=XXX      +       A=XXX     + 
*         +           +           +                 +                 + 
*         +-----------+-----------+-----------------+-----------------+ 
*              12         12               18               18
* 
*         ARGCOMA FORMAT. 
*         +-----------------------+-----------------+-----------------+ 
*         +///////////////////////+  MODE  OF  PARM + CURRENT ARGUMENT+ 
*         +///////////////////////+ ( MAY BE OTHER )+    -  1         + 
*         +///////////////////////+                 +                 + 
*         +-----------------------+-----------------+-----------------+ 
*                    24                   18               18 
* 
* 
*         ENTRY  (X3) = CURRENT *(* OPERATOR TO BE PROCESSED. 
*                (B3) = CURRENT VALUE OF ARGMODE. 
*                (B4) -> RIGHT PARENTHESIS IN TOKEN BUFFER. 
*                (POPPER) = TABBED VALUE FOR RIGHT PAREN OPERATOR.
* 
*         EXIT   DEPENDING ON THE PARTICULAR VALUE FOR A=, EXIT IS THRU 
*                A.  POP.STD - TO PROCESS OPERATOR, OR, 
*                B.  POPX    - IGNORE OPERATOR. 
*                              (NOTE - IN CERTAIN *POPPER* IS SET TO
*                                      INDICATE BYPASSING OF PAREN.)
* 
*         USES   A2-4,A6   X5   B3. 
  
  
 POP.PN   BSS    0
          SA4    ARGMODE
          SA3    POPDPC 
          SA5    ARGCOMA
          MX0    -SP.TBPRL
          LX3    -SP.TBPRP
          BX7    -X0*X3      EXTRACT (X7) = TOKEN TYPE FOR POP-ING OP 
          SB2    X7-O.RP
          LX4    -AM.PADP 
          SB3    X4 
          ERRNZ  18-AM.PADL 
          LX4    AM.PADP
          SA3    ARGMIS 
          SB7    E.LP1       IN CASE OF PARENTHESIS MISMATCH
          NZ     B2,POP.RP5  IF *(* NOT BEING POPPED BY *)* 
          BX7    X4 
          LX5    -AC.CNTP 
          SB2    X5 
          ERRNZ  18-AC.CNTL 
          SA7    SCR         SAVE CURRENT *ARGMODE* 
          LX6    X5 
          BX7    X3 
          SA2    T.PCS
          SA4    T=PCS
          IX0    X2+X4
          SA2    X0-Z=PSTACK+AM.W 
          =A6    A7+1        SAVE CURRENT *ARGCOMA* 
          =A4    A2-AM.W+AC.W 
          =A7    A6+1        SAVE CURRENT *ARGMIS*
          BX6    X2 
          SA2    T=PCS
          SX7    X2-Z=PSTACK
          SA7    A2 
          SA3    CMLFLG 
          =A5    A4-AC.W+AS.W 
          SX2    X3+B5
          SA6    ARGMODE     RESET ARGMODE
          NZ     X2,POP.PN1  IF NO NEED TO RESET FLAG 
          =X7    1
          SA7    A3 
 POP.PN1  AX6    AM.REFP
          SA2    ARGCOMA
          BX7    X4 
          SA6    REFVAR      RESET CROSS REFERENCE VALUE
          SA7    A2          RESET ARGCOMA
          BX6    X5 
          SA6    ARGMIS 
          SA4    B6-2        1ST OPERAND
          MX6    -1 
          =B4    B4+1        BYPASS RIGHT PARENTHESIS 
          =A5    B6-1        2ND OPERAND
          SA6    POPPER      INDICATE IGNORE FUTHER PROCESSING OF PAREN 
  
*         EXIT TO A=XXX PROCESSOR WITH THE FOLLOWING CONDITIONS SET --
*                (X2) = (ARGCOMA).
*                (X4) = (1OP).
*                (X5) = (2OP).
*                (B2) = NUMBER OF ARGUMENTS - 1 INSIDE PARENS.
*                (B4) -> NEXT ELEMENT PAST CLOSING RIGHT PAREN. 
* 
*                (SCR+AM.W) = (ARGMODE) FOR PAREN BEING CLOSED. 
*                (SCR+AC.W) = (ARGCOMA)  -    -     -      -
*                (SCR+AS.W) = (ARGMIS )  -    -     -      -
  
          JP     B3 
 A=IF     SPACE  4,10 
**        A=IF - PROCESS TERMINAL PARENTHESIS OF *IF* EXPRESSION. 
*         EXIT   TO PAREXIT.
*                (IFRESLT) = EXPRESSION RESULT OPERATOR.
*                (IFMOD) = MODE OF RESULT.
  
  
 A=IF     BSS    0
          EQ     AIF8        **** TEMP **** 
          SA1    LASTOP 
 RELOP    BITMIC (O.LT,O.GE,O.EQ,O.NE)
          SA2    ="RELOP" 
          SB7    X1 
          LX6    X2,B7
          PL     X6,AIF8     IF LAST OP NOT RELATION
          BX1    X5 
          RJ     COR         CHECK IF OPERAND IS REDUCIBLE INTERMEDIATE 
          NZ     X0,AIF8     IF RELATION-OP NOT INPUT TO IF-OP
 AIF8     SA1    B6-B1       FETCH TOP OF OPERAND STACK 
          MX0    -TP.MODEL
          LX7    X1 
          LX1    -TP.MODEP
          BX6    -X0*X1 
          SA7    IFRESLT
          SA6    IFMOD
          EQ     PAREXIT     FOUND TERMINAL *)* OF IF (EXP) - EXIT ...
 A=LIST   SPACE  4,10 
**        A=LIST - PROCESS CLOSING OF AN I/O LIST.
*         A=DVL - PROCESS CLOSING OF DATA VARIABLE LIST.
* 
*         NOTE THAT A=DVL SHOULD BE SAME AS A=LIST, BUT MUST HAVE 
*         A DIFFERENT ADDRESS SO 'SPECIAL' FLAG TESTS IN PAR WILL 
*         NOT DO IDIOTIC THINGS.
  
  
 A=LIST   EQU    POPX        EXIT...
  
 A=DVL    EQ     POPX        ME TOO.. 
          TITLE  POP/EMIT SIMPLE OPERATORS. 
POP=COM   SPACE  4,10 
**        POP=COM - POP GENERAL COMMUTATIVE OPERATOR. 
* 
*         PURPOSE - TO DISCOVER A "CLUSTER" OF ASSOCIATIVE/COMMUTATIVE
*                OPERATORS, AND TO COMBINE ALL CONSTANTS OCCURRING IN 
*                IT INTO A SINGLE CONSTANT.  IF ONLY ONE CONSTANT, IT 
*                WILL BE LAST.
* 
*         THE TERM 'CLUSTER' IS FROM AHO AND ULLMAN, 1973, THEORY OF
*         PARSING, TRANSLATION AND COMPILATION, VOL 2, CHAPTER 11.
* 
*         THE CURRENT OPERATOR IS IN THE MIDST OF A CLUSTER, IF:  
*         (A)  IT IS COMUTATIVE.  (THIS IS ASSUMED -- DO NOT ENTER THIS 
*              THIS ROUTINE WITH A NON-COMUTATIVE OPERATOR.)
*         (B)  IT IS ALSO ASSOCIATIVE.
*         (C)  IT IS BEING POPPED BY AN IDENTICAL OPERATOR, WHICH IS
*              STILL ASSOCIATIVE.  (ASSOCIATIVITY AND COMUTATIVITY CAN
*              BE WIPED OUT FOR A PARTICULAR INSTANCE OF AN OPERATOR
*              DURING THE PARSING PROCESS.) 
* 
*         METHOD - WHEN THE OPERATOR BEING POPPED IS WITHIN A CLUSTER,
*                AND IF EXACTLY ONE OPERAND IS CONSTANT, THEN:  
*                (A)  REVERSE OPERAND STACK ENTRIES, IF NECESSARY, TO 
*                     ENSURE THE CONSTANT OPERAND IS SECOND, AND
*                (B)  DELAY POPPING THE OPERATOR. 
* 
*         THUS, CONSTANT OPERANDS IN A CLUSTER BUBBLE TOWARD THE END. 
*         WHENEVER TWO CONSTANTS MEET, LET THE OPERAND POP NORMALLY, SO 
*         THAT CONRED CAN COMBINE THEM.  THE RESULTANT SINGLE CONSTANT
*         WILL RESUME BUBBLING ON THE NEXT TRIP THRU HERE.  IF NEITHER
*         OPERAND IS CONSTANT, ALSO POP NORMALLY. 
* 
*         THE MECHANICS OF DELAYING THE POP IS SORT OF DIRTY -- 
*         THE OPERATOR IS PUT BACK ON (OSTACK), AND WE EXIT DIRECTLY
*         TO PAR.ADOP,   N O T   THRU THE POP ENTRY POINT.
* 
*         ENTRY  (X3) = COMMUTATIVE OPERATOR. 
  
  
 POP=COM  SA1    POPDPC      ENTRY... 
          MX0    -SP.TBPRL
          LX3    -SP.TBPRP
          BX7    -X0*X3      (X7) = TOKEN TYPE OF OP BEING POPPED 
          IX1    X1-X7
          LX3    SP.TBPRP 
          NZ     X1,POP.STD  IF NOT BEING POPPED BY LIKE OPERATOR 
          BX6    X3 
          HX6    SP.AS
          PL     X6,POP.STD  IF OPERATOR NOT ASSOCIATIVE
          SA1    SDIV 
          MX2    -SP.STPRL
          BX1    X1-X3
          LX1    -SP.STPRP
          BX2    -X2*X1 
          ZR     X2,POP.STD  IF * POPPING SPECIAL DIVIDE
  
**        CHECK IF OPERANDS ARE CONSTANTS.
*         JOINED HERE TO POP A SPECIAL DIVIDE.
  
  
 POP.SDIV BSS 
 .T       IFEQ   TEST,ON
          SA2    B6-B1       TOP-1
          SA1    A2-B1       TOP-2
          BX7    X2-X5
          BX6    X1-X4
          BX1    X1-X5
          BX2    X2-X4
          ZR     X6,POPCOM2  IF (1OP) = TOP-2 
          NZ     X2,"BLOWUP" IF (1OP) NOT FROM STACK
          NZ     X1,"BLOWUP" IF (2OP) <> TOP-2
          EQ     POPCOM8
  
 POPCOM2  NZ     X7,"BLOWUP" IF (2OP) <> TOP-1
 POPCOM8  BSS                OK.. 
 .T       ENDIF 
  
          BX1    X4 
          CALL   LCT         LOAD CONSTANT (1OP)
          SX3    -B1
          BX1    X5 
          ZR     B2,COM3     IF FIRST IS NOT CONSTANT 
          BX6    X4 
          LX7    X5          ROTATE OPERANDS
          SX3    B0          INDICATE 1 CONSTANT SO FAR 
          SA6    B6-B1
          BX5    X6 
          LX4    X7 
          SA7    A6-B1
  
 COM3     CALL   LCT         LOAD CONSTANT (2OP)
          SB7    X3 
          ZR     B2,COM4     IF (2OP) IS NOT CONSTANT 
          SB7    X3+B1
  
*         (B7) = -1, NEITHER IS CONSTANT. 
*              =  0, ONLY 1 OPERAND IS CONSTANT.
*              = +1, BOTH ARE CONSTANT. 
  
 COM4     SA3    SOPR        RELOAD POPPED OPERATOR 
          NZ     B7,POP.STD  IF BOTH OR NONE ARE CONSTANTS
          SA2    POPPER 
          =B5    B5+1        RETAIN OPERATOR ON OSTACK
          =A1    A2-POPPER+POPDPC 
          =B4    B4+1        ADVANCE TO NEXT TOKEN
          EQ     PAR.ADOP    RESET OPERATOR STACK 
 POP.DIV  SPACE  4,30 
**        POP.DIV - DIVIDE BEING POPPED.
* 
*         PURPOSE 
*         TO CHANGE SEQUENCE - A  =  B / C / D / E / F
*                          TO  A  =  B /(C * D * E * F )
* 
*         GENERAL FLOW. 
* 
*         1. IF DIVIDE BEING POPPED IS COMMUTATIVE - DIVIDE WAS 
*            PREVIOUSLY CHANGED TO SPECIAL MULTIPLY.
*                A.  CHANGE DPC FOR OPERATOR TO MULTIPLY, THUS MAKING 
*                    DIVIDE LOOK LIKE A TRUE MULTIPLY.
*                B.  RESET POPPER TO SPECIAL DIVIDE.
*                C.  RESET OPERATOR STACK FOR CURRENT DIVIDE TO (A).
* 
*         2. IF DIVIDE BEING POPPED IS NOT COMMUTATIVE - DIVIDE IS 1ST
*            IN SEQUENCE. 
*                B.  IF BOTH OPERANDS ARE CONSTANTS LET DIVIDE BE 
*                    POPPED.  IF NOT, GO TO (C).
*                C.  CHANGE POPPER TO SPECIAL DIVIDE. 
*                D.  RESET *B5* INDICATING DIVIDE NOT POPPED. 
*                E.  EXIT TO PAR.ADOP TO ADD SECOND DIVIDE AS SPECIAL 
*                    DIVIDE.
* 
*         3. IF DIVIDE NOT BEING POPPED BY DIVIDE 
*                A.  CHECK IF DIVIDE BEING POPPED IS A SPECIAL DIVIDE 
*                    THAT HAS NOT BEEN COMFIRMED. 
*                B.  IF (A) IS TRUE, CHANGE DIVIDE TO TRUE MULTIPLY 
*                    AND EXIT TO POP.STD, POPPING AS MULTIPLY.
*                C.  IF (A) IS FALSE, EXIT TO POP.STD TO POP DIVIDE.
  
  
 POP.DIV  BSS    0
          BX1    X5 
          CALL   LCT         LOAD CONSTANT TEST 
          ZR     B2,POP.DV2  IF DENOMINATOR NOT CONSTANT
          NZ     X6,POP.DV2  IF DENOMINATOR NOT ZERO
          SX0    X0-M.CPLX
          NZ     X0,POP.DV1  IF DENOM. NOT COMPLEX
          NZ     X7,POP.DV2  IF AIMAG(DENOM.) NZ
  
 POP.DV1  FATAL  E.DC4       ** DIVIDE BY ZERO
  
 POP.DV2  SA1    CO.RNDM
          SA2    CO.RNDD
          BX1    X1-X2
          LX2    X3 
          NZ     X1,POP.DV10 IF DIFFERENT ARITHMETIC SELECTED 
          SA1    POPDPC 
          MX0    -SP.TBPRL
          LX3    -SP.TBPRP
          BX2    -X0*X3      (X2) = TOKEN BEING POPPED
          IX0    X1-X2
          BX2    X3 
          NZ     X0,POP.DV10 IF NOT DIVIDE POPPING DIVIDE 
          SBIT   X2,SP.COMP 
          PL     X2,POP.DV5  IF NOT POPPING SPECIAL DIVIDE
          SA1    SDIV 
          =X2    O.DIV&O.MULT 
          LX2    SP.TBPRP 
          BX6    X3-X2
          LX7    X1 
          SA6    SOPR        SET CONFIRMED MULTIPLY 
          BX3    X6 
          SA7    POPPER      CHANGE TO SPECIAL DIVIDE 
          =A6    B5+1        CHANGE IN STACK ALSO (INCASE MULT NO POP)
          EQ     POP.SDIV    HANDLE AS MULTIPLY 
  
*         HERE FOR FIRST DIVIDE IN SEQUENCE.
  
 POP.DV5  BX1    X4+X5
          MX0    -TP.MODEL
          LX1    -TP.MODEP
          BX2    -X0*X1 
          SX0    X2-M.REAL
          ERRNZ  M.INT-2
          ERRNZ  M.BOOL 
          MI     X0,POP.DV10 IF INTEGER DIVIDE
          SA2    SDIV        CHANGE TO SPECIAL DIVIDE 
          =B4    B4+1        NEXT 
          =X1    O.DIV
          =B5    B5+1        REACTIVATE 1ST DIVIDE
          EQ     PAR.ADOP    IGNORE- SET INTO OPERATOR STACK
  
 POP.DV10 SBIT   X2,SP.COMP 
          MI     X2,POP.DV25 IF POPPING SPECIAL DIVIDE
 .INV     IFEQ   NOINVERT,0 
          ZR     B2,POP.DV15 IF DENOMINATOR IS NOT CONSTANT 
          MX6    0
          SA6    POP.DVA
          CALL   PDC         PROCESS DIVIDE BY CONSTANT 
          SA1    POP.DVA
          NZ     X1,POP.DV20 IF DIVIDE CHANGED TO MULTIPLY
 .INV     ENDIF 
  
 POP.DV15 MX0    -TP.MODEL
          LX4    -TP.MODEP
          LX5    -TP.MODEP
          BX1    -X0*X4      X1 = MODE OF 1OP 
          BX2    -X0*X5      X2 = MODE OF 2OP 
          SX1    X1-M.CPLX
          SX2    X2-M.REAL
          LX4    TP.MODEP 
          LX5    TP.MODEP 
          NZ     X1,POP.DV25 IF NUMERATOR NOT COMPLEX 
          NZ     X2,POP.DV25 IF DENOMINATOR NOT REAL
          SA3    CRDIV       CHANGE OP TO SPECIAL CPLX/REAL DIVIDE
          EQ     POP.DV25 
  
 POP.DV20 SA3    F.PRIOR+O.MULT-O.SEP 
  
 POP.DV25 =X2    O.DIV&O.MULT 
          LX2    SP.TBPRP 
          BX6    X3-X2
          SA6    SOPR        SET CONFIRMED MULTIPLY 
          BX3    X6 
          EQ     POP.STD     POP AS TRUE MULTIPLY 
  
 POP.DVA  BSSENT 1           *CONVERT TO MULTIPLY* FLAG 
 POP.PL   SPACE  4,10 
**        POP.PL - PLUS BEING POPPED. 
* 
*         PURPOSE 
*         1.  TO CHANGE SEQUENCE   A = -B + C 
*                               TO A =  C - B 
*         2.  TO CHANGE SEQUENCE   A =  CONSTANT + VARIABLE 
*                               TO A =  VARIABLE + CONSTANT 
  
  
 POP.PL   BSS    0
          SA1    CURST
          SA2    T=PAR
          IX1    X1-X2
          ZR     X1,POP=COM  IF LAST TURPLE NOT TO BE SQUEEZED
          SA1    LASTOP 
          SB7    X1-O.UMIN
          SA2    LASTAD 
          NZ     B7,POP=COM  IF LAST OP NOT *UNARY-*
          BX1    X4 
          RJ     COR         CHECK IF OPERAND IS INPUT TO OPERATOR
          NZ     X0,POP=COM  IF *UNARY-* NOT INPUT INTO *PLUS*
          SA3    MINUSOP
          BX4    X5          (1OP) = OLD (2OP)
          =A5    X1+OR.1OP   (2OP) = (1OP) OF THE *UMIN* INTERMEDIATE 
          BX6    X3 
          SA1    INSTF
          NZ     X1,POP.PL4  IF IN ARITHMETIC STATEMENT FUNCTION
          SA7    A2          RESET LENGTH OF T.PAR
  
 POP.PL4  SA6    SOPR 
          EQ     POP.STD
 POP.MUL  SPACE  4,10 
**        POP.MUL - MULTIPLY BEING POPPED.
  
  
 POP.MUL  EQU    POP=COM
 POP.UM   SPACE  4,10 
**        POP.UM - PROCESS UNARY MINUS BEING POPPED.
* 
*         PURPOSE.
*         1.  TO CHANGE SEQUENCE    A = - CONSTANT
*                            TO     A =   CONSTANT
*         2.  TO CHANGE SEQENCE     A = - ( - B ) 
*                            TO     A =       B 
*         3.  TO CHANGE SEQUENCE    A = - (B - C) 
*                            TO     A =    C - B
  
  
 POP.UM   BSS    0
          SA1    LASTOP 
          SA2    LASTAD 
  
*         CHECK FOR -(A-B)
  
          SB2    X1-O.MIN 
          SB7    X1-O.UMIN
          SA1    INSTF       STATEMENT FUNCTION FLAG
          NZ     X1,POP=UNO  SKIP OPTIMIZATION IF IN STATEMENT FUNCTION 
          NZ     B2,POP=UNR  IF LAST NOT BINARY MINUS 
          BX1    X5 
          RJ     COR
          NZ     X0,POP=UNO  IF NOT INPUT INTO THIS OPERATOR
          =A3    X1-OR.OPR+OR.1OP 
          BX6    X3 
          =A4    A3-OR.1OP+OR.2OP 
          BX7    X4 
          SA6    A4          REVERSE THE ORDER OF THE SUBTRACT
          SA7    A3 
          EQ     POPX        EXIT.. 
 POP=UNR  SPACE  4,10 
**        POP=UNR - POP SELF-INVERSE UNARY OPERATOR.
* 
*         ENTRY  (B7) = 0 IF OPERAND IS RESULT OF SAME OPERATOR.
  
  
 POP=UNR  BSS    0           ENTRY... 
          NZ     B7,POP=UNO  IF OPERAND NOT RESULT OF SAME OPERATOR 
          BX1    X5 
          RJ     COR
          NZ     X0,POP=UNO  IF NOT INPUT INTO THIS OPERATOR
          =A3    X1+OR.1OP
          SA7    A2          RESET LENGTH OF T=PAR
          CLAS=  X1,TP,(EXPR) 
          BX6    X1+X3
          =A6    B6-1        PUT OPERAND BACK IN ELEMENT STACK
          EQ     POPX        EXIT.. 
  
  
**        POP=UNO - OUTPUT UNARY OPERATOR.
  
  
 POP=UNO  BSS 
          BX4    X5          (1OP) = (2OP) FOR SDM
          =B6    B6+1        ADJUST ELSTAK TO REMOVE ONLY 1 ELEMENT 
          EQ     POP.STD
 POP.NOT  SPACE  4,10 
**        CHECK IF .NOT. (.NOT. EXPRESSION) COMBINATION.
  
  
 POP.NOT  BSS    0
          SA1    LASTOP 
          SB7    X1-O.NOT 
          EQ     POP=UNR
 POP.LOG  SPACE  4,10 
**        POP.LOG - POPPING BINARY LOGICAL OPERATOR.
  
  
 POP.LOG  BSS    0
          BX6    X3 
          HX6    SP.COM 
          MI     X6,POP=COM  IF COMMUTATIVE OPERATOR
          EQ     POP.STD
 POP.REL  SPACE  4,10 
**        RELATIONALS BEING POPPED. 
* 
*         REVERSE OPERANDS AND CHANGE  .LE. INTO .GE. 
*                                 AND  .GT. INTO .LT. 
  
  
 POP.LE   =X1    O.LE&O.GE
          EQ     REL1 
  
 POP.GT   =X1    O.GT&O.LT
 REL1     BX0    X5          INTERCHANGE OPERANDS 
          LX1    SP.TBPRP 
          BX6    X3-X1       CHANGE OPERATOR
          LX5    X4 
          SA6    SOPR 
          BX3    X3-X1
          LX4    X0 
  
  
 POP.REL  BSS    0
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          BX6    X5          PRESERVE X5
          BX5    X4 
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          BX5    X6          RESTORE X5 
          LX6    X3 
          SA6    LASTREL     REMEMBER (TH.SKEL) OF RELATION 
          RJ     SDM         SELECT DOMINANT MODE 
          RJ     OMC         OUTPUT MODE CONVERSION 
          SA2    PARNOW 
          SX1    X2-PM=PARM 
          ZR     X1,REL3     IF PROCESSING *PARAMETER* STATEMENT
          SX2    X2-PM=CXP
          NZ     X2,REL5     IF NOT PARSING CONSTANT EXPRESSIONS
 REL3     SA1    SMOD 
          SX7    X1-M.CHAR
          NZ     X7,REL5     IF DOMINANT MODE NOT CHARACTER 
          BX7    X3 
          SA7    PCR.RO      SAVE RELOP 
          BX1    X4 
          CALL   LCH         LOAD POSSIBLE CONSTANT 1OP 
          SB2    B2+2 
          NZ     B2,REL5     IF 1OP NOT CHARACTER CONSTANT
          SA6    PCR.1OP     SAVE T.CON INDEX 
          =A7    A6+1        SAVE CHARACTER LENGTH
          BX1    X5 
          CALL   LCH         LOAD POSSIBLE CONSTANT 2OP 
          SB2    B2+2 
          NZ     B2,REL5     IF 2OP NOT CHARACTER CONSTANT
          SA6    PCR.2OP     SAVE T.CON INDEX 
          =A7    A6+1        SAVE CHARACTER LENGTH
          CALL   PCR         PROCESS CHARACTER RELATIONALS
          EQ     POPX 
  
 REL5     SA1    SMOD 
          SX7    M.LOG
          BX6    X1 
          SA7    A1          (SMOD) = M.LOG 
          SA6    RELA        SAVE OPERAND MODE
          RJ     ADT         ISSUE TURPLE 
          PL     B2,POPX     IF TURPLE NOT EMITTED (CONSTANT OR SQUEEZED
  
*         ASSUMING THAT THIS IS EXPRESSION IN SINGLE-RELATIONAL 
*         IF, SAVE ORDINAL OF SPECIAL SKELETON.  IF THIS IS NOT 
*         THE CASE IFREL2 WILL BE ZEROED IN ADT BY NEXT TURPLE ISSUED.
  
          SA1    LASTREL
          SA2    RELA 
          MX0    -SP.TBPRL
          BX6    -X0*X1 
          SB7    X6-O.EQ
          SX2    X2 
          LX2    1
          SX2    X2+B7
          LX2    -1 
          SA1    IFRELT+X2   IFRELT(2*MODE+OP-O.EQ) 
          MI     X2,REL10    IF WANT LOWER HALF 
          LX1    30 
  
 REL10    BX6    X1 
          SX1    X1 
          LT     B7,B0,POPX  IF NOT .EQ. OR .NE.
          GT     B7,B1,POPX  IF NOT .EQ. OR .NE.
          ERRNZ  O.NE-O.EQ-1
          SX1    X1 
          MI     X1,POPX     IF NO SPECIAL SKEL 
          SA6    IFREL2      SAVE (OPPOSITE,THIS) SPECIAL PAIR
          EQ     POPX 
  
 IFRELT   BSS    0
          ECHO   ,MODE=(B,L,I,R,D,C,H)
          ECHO   ,OP=(EQ,NE) LT,GE) 
          VFD    12/0,18/=YV=I_OP.MODE
          ENDD
 POP.CAT  SPACE  4,10 
**        POP.CAT - CATENATION OF CHARACTER EXPRESSIONS.
* 
*         NOTE THAT THE CATENATION PRIOP IS MARKED (TH.MDLS), WHICH 
*         IS WHY THE OPERAND MODES MUST BE CHECKED HERE.  THIS WOULD
*         NOT BE NECESSARY IF (OM=CAT) WERE INVENTED AND (TH.MDLS)
*         REMOVED (SDM WOULD CHECK MODES).  THE PRESENT CODE HOWEVER, 
*         CAN GIVE A MORE SPECIFIC ERROR MESSAGE, ALBEIT AT THE COST
*         OF A WORD OR TWO OF CORE. 
  
  
 POP.CAT  BSS    0
          MX0    -TP.MODEL
          ERRNZ  TP.MODEP 
          BX1    -X0*X4      (X1) = MODE (1OP)
          BX2    -X0*X5      (X2) = MODE (2OP)
          SX1    X1-M.CHAR
          SX2    X2-M.CHAR
          NZ     X1,CAT2     IF (1OP) NOT TYPE CHARACTER
          NZ     X2,CAT2     IF (2OP) NOT TYPE CHARACTER
          BX6    X3 
          BX1    X4 
          SA6    CATA        SAVE (CATA) = OPERATOR WORD
          CALL   LCH         CHECK IF (1OP) IS CHAR CONSTANT
          SB7    B2+2 
          SB3    X6          SAVE (B3) = INDEX OF (1OP) 
          BX1    X5 
          NZ     B7,CAT1     IF (1OP) NOT CHAR CONSTANT 
          SA7    CATB        SAVE (CATB) = CHAR LEN OF (1OP)
          CALL   LCH         CHECK IF (2OP) IS CHAR CONSTANT
          SB7    B2+2 
          SA3    CATB        (X3) = LEN OF (1OP)
          NZ     B7,CAT1     IF (2OP) NOT CHAR CONSTANT 
          SB2    X6          (B2) = INDEX OF (2OP)
          CALL   PCC         PERFORM CHARACTER CONCATENATION
          =B6    B6-2        POP TWO OPERANDS 
          RJ     ECC         EMIT CHAR CONSTANTS
          EQ     POPX 
  
 CAT1     BX7    X5 
          SA7    CATC        SAVE 2OP 
          BX1    X4 
          RJ     GOL         SEE IF 1OP IS FIXED LENGTH 
          SA6    CATB        SAVE FIXED/PASSED FLAG 
          SA1    CATC 
          RJ     GOL         SEE IF 2OP IS FIXED LENGTH 
          SA1    CATB 
          MX0    1
          BX6    X1+X6
          BX0    X0*X6       MI IFF EITHER OPERAND NOT FIXED-LENGTH 
          LX0    1+TH.PLCP
          SA5    CATC        RESTORE 2OP
          SA3    CATA        RESTORE OPERATOR 
          BX3    X0+X3       MARK OPERATOR PASSED LENGTH
          LX0    TP.LCFP-TH.PLCP
          CLAS=  X7,TP,(CAT)
          BX7    X0+X7       MARK OPERAND AS PASSED LENGTH (LCF)
          SA7    ATTR        MARK RESULT OPERAND AS CAT 
          EQ     POP.STD
  
 CAT2     FATAL  E.AT15      ** OPERANDS OF // MUST BE CHARACTER
          EQ     POP.ERR
  
 CATC     BSS    1
 POP.EQL  SPACE  4,20 
**        POP.EQL - VALIDATE ASSIGNMENT.
* 
*         A.  CHECKS LEFT SIDE FOR LEGALITY -- CANNOT BE A
*                CONSTANT.  IF EXPRESSION, MUST BE ARRAY LOAD.
*         B.  VALIDATES NOT RESETTING AN ACTIVE DO-CONTROL
*                INDEX. 
*         C.  SET DOMINANT MODE BY COERECING R.H.S. 
*         D.  SET (WB.DEF) TO INDICATE VARIABLE DEFINED.
*         E.  IF CHARACTER ASSIGNMENT, CHECKS FOR OVERLAP BETWEEN 
*                THE TARGET VARIABLE AND ANY OF THE ELEMENTS IN THE 
*                SOURCE EXPRESSION. 
  
  
 POP.EQL  BSS    0
          BX7    X3 
          SA7    EQLA 
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX6    -X0*X5      DM = MODE OF L.H.S.
          LX5    X4 
          RJ     CMR         COERCE MODE OF R.H.S.
          BX4    X5          (1OP) = CONVERTED R.H.S. 
          ZR     B7,EQL30    IF CONVERSION OK 
          SA4    B6-B1       (1OP) = L.H.S.          /* FAKE LHS=LHS
          FATAL  B7 
 EQL30    SA5    B6-B1       (2OP) = L.H.S. 
          SA3    T=BLST 
          BX6    X3 
          CALL   MDD         MARK DO PARAMETERS DEFINED 
          SA5    B6-B1       (2OP) = L.H.S
          CALL   DOA         DETERMINE OPERAND ADDRESSIBILITY 
          NZ     X6,EQL48    IF L.H.S. IS CONSTANT OR EXPRESSION
  
*         L.H.S. IN SYMTAB, 
*         CHECK FOR REDEFINING ACTIVE DO CONTROL INDEX. 
  
          BX1    X2 
          HX1    WB.VAR 
          PL     X1,EQL48    IF SYMBOL NOT A VAR
          CLAS=  X1,WB,(DEF)
          BX6    X2+X1       MARK VARIABLE AS DEFINED 
          SA6    A2 
          SB3    0           INDICATE NOT DO CONTROL INDEX
          CALL   DDR         DIAGNOSE DO REDEFINITION 
          EQ     EQL50
  
 EQL48    FATAL  E.VA11      ILLEGAL LEFT MEMBER
          EQ     EQL99.1     X5 MAY HAVE A BLOWUP OPERAND FROM DOA, EXIT
  
*         TEST FOR IDENTICAL L.H.S. AND R.H.S. -- ELIMINATE 
*                ENTIRE OPERATION IF SO.
  
 EQL50    BX0    X4-X5
          =B6    B6-1        ELIMINATE ONE OPERAND
          ZR     X0,POPX     IF LEFT MEMBER = RIGHT MEMBER
          SA2    T=PAR
          SX7    X2+Z=TURP   SQZ NOT SMART ENUF TO CROSS STORES 
          SA7    CURST
          =B6    B6+1 
  
*         IF CHARACTER ASSIGNMENT, CHECK FOR TARGET/SOURCE OVERLAP. 
  
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX0    -X0*X5      ISOLATE TARGET MODE
          LX5    TP.MODEP    RESET X5 
          SX0    X0-M.CHAR
          NZ     X0,EQL99.1  IF NOT TYPE CHARACTER
          LX7    X4 
          BX6    X5 
          SA7    EQLB        SAVE X4 (SOURCE OPERAND) 
          SA6    EQLC        SAVE X5 (TARGET VARIABLE)
          SX4    B0          INDICATE TARGET CHARACTERISTICS
          RJ     SCB         SET CHARACTER BOUNDS 
          SA5    EQLB        SOURCE OPERAND 
          BX2    X5 
          SBIT   X2,TP.CATP 
          MI     X2,EQL60    IF SOURCE IS CONCATENATION EXPRESSION
          RJ     CDI         CHECK DATA INTERFERENCE
          EQ     EQL99       EXIT 
  
 EQL60    BX1    X5 
          LX5    -TP.ORDP 
          MX0    -TP.ORDL 
          BX5    -X0*X5      GET ORDINAL OF CONCAT TURPLE 
          SB3    X5+B1       SET CURRENT NODE 
          SB2    B0          SET LAST NODE = LAMDA
  
 EQL65    SB7    B3          B7=CURRENT NODE,LEFT BRANCH
          GE     B3,B0,EQL70 IF WE WANT LEFT BRANCH 
          SB7    B1-B3       B7=CURRENT NODE,RIGHT BRANCH 
  
 EQL70    SA5    T.PAR
          SA5    X5+B7       GET LEFT/RIGHT BRANCH
          SBIT   X5,TP.CATP 
          MI     X5,EQL90    IF BRANCH IS CONCAT EXPRESSION 
          LX5    1+TP.CATP   SHIFT RESTORE
          RJ     CDI         CHECK DATA INTERFERENCE
  
 EQL75    LT     B3,B0,EQL80 IF CURRENT NODE, RIGHT BRANCH
          SB3    B0-B3       SET CURRENT NODE, RIGHT BRANCH 
          EQ     EQL65       GO PROCESS RIGHT BRANCH
  
 EQL80    EQ     B2,B0,EQL99 IF LAST NODE = LAMDA 
          SB7    B2          B7=LAST NODE,LEFT BRANCH 
          GE     B2,B0,EQL85 IF LAST NODE=LEFT BRANCH 
          SB7    B1-B2       B7=LAST NODE,RIGHT BRANCH
  
 EQL85    SA5    T.PAR
          SA5    X5+B7       GET LEFT/RIGHT BRANCH
          SB7    B0-B3
          SX7    B7-B1       X7=ORD OF CURRENT NODE 
          LX7    TP.ORDP
          SX6    M.CHAR+TP.INTRM+TP.CATM  SET ATTRIBUTE BITS
          BX7    X6+X7
          SA7    A5          RESTORE LEFT/RIGHT BRANCH
          SB3    B2          SET CURRENT=LAST NODE
          SB2    X5          SET LAST NODE=STORED THREAD
          EQ     EQL75
  
 EQL90    SX7    B2          X7=LAST NODE 
          SA7    A5          STORE THREAD IN TREE 
          SB2    B3          SET LAST=CURRENT NODE
          LX5    1-TP.ORDP+TP.CATP
          MX0    -TP.ORDL 
          BX5    -X0*X5      GET ORDINAL OF CURRENT NODE
          SB3    X5+B1       SET CURRENT
          EQ     EQL65
  
 EQL99    SA5    EQLC        RESTORE X5 
          SA4    EQLB        RESTORE X4 
  
 EQL99.1  SA3    EQLA        RESTORE X3 
          EQ     POP.STD     EXIT 
          TITLE  POP/EMIT SUBSTRING.
 C=SBS    SPACE  4,10 
**        C=SBS - SUBSTRING COLON.
* 
*         ENTRY  (X5) = FIRST SUBSTRING OPERAND.
* 
*         WHEN THE COLON IS IMMEDIATELY FOLLOWED BY A RIGHT PAREN,
*         A DEFAULT SUBSTRING-LAST IS INVENTED AND STACKED. 
  
  
 C=SBS    BSS    0           ENTRY... 
          RJ     CSM         CHECK SUBSTRING MODE 
          SA1    B4+B1       PEEK AHEAD 
          LX1    -TB.TOTP 
          SB2    X1-O.RP
          NZ     B2,POPX     IF COLON NOT IMMEDIATELY FOLLOWED BY RPAREN
          SA5    ARGMIS 
** MQ            IS (ESTACK-2) ALSO SAME ???
          RJ     DOA         DETERMINE OPERAND ATTRIBUTES 
          NZ     X6,"BLOWUP" IF EXPRESSION OR CONSTANT
          =A4    A2-WB.W+WC.W 
          MX0    -WC.CLENL
          LX4    -WC.CLENP
          BX6    -X0*X4      (X6) = CHAR LENGTH 
          LX4    WC.CLENP-1-WC.CTYPP
          =X7    M.INT
          MI     X4,CSBS4    IF ADAPTABLE LENGTH
          CALL   NCS         ENTER CONSTANT 
          EQ     CSBS8
  
 CSBS4    SA1    S=VD 
          LX1    TP.ORDP
          LX6    TP.BIASP 
          LX7    TP.MODEP 
          BX2    X1+X7
          BX6    X6+X2       CONSTRUCT OPERAND = VD.+(CLEN) 
 CSBS8    SA6    B6 
          SB6    B6+B1       STACK DEFAULT-LAST OPERAND 
          EQ     POPX        EXIT.. 
 A=SBS    SPACE  4,10 
**        A=SBS - SUBSTRING RIGHT PAREN.
* 
*         ENTRY  (X4) = OPERAND FOR FIRST.
*                (X5) = OPERAND FOR LAST. 
  
  
 A=SBS    BSS    0           ENTRY... 
          RJ     CSM         CHECK SUBSTRING MODE 
          SA4    B6-2        RESTORE *FIRST*
          BX1    X4 
          CALL   LCH         LOAD POSSIBLE CONSTANT FIRST 
          SA6    ASBSA       SAVE VALUE OF FIRST
          SB3    B2          SAVE FLAG
          BX1    X5 
          CALL   LCH         LOAD POSSIBLE CONSTANT LAST
          SA0    B2          SAVE *LAST* FLAG 
          SA6    ASBSB       SAVE VALUE OF SECOND 
          SA5    B6-3        SUBSTRING SYMBOL/ARRAY INTER.
          RJ     DOA         GET SYMBOL 
          SB2    A0 
          SA5    ASBSB
          BX6    X5 
          =A5    B6-1        RELOAD *LAST*
          =A1    A2+WA.W-WB.W 
          MX0    WA.SYML
          LX0    WA.SYML+WA.SYMP
          BX7    X0*X1       ISOLATE SYMBOL 
          SA7    FILL.       SET CELL FOR ERROR MESSAGES
          =A1    A2+WC.W-WB.W 
          MX0    -WC.CLIFL
          LX1    -WC.CLIFP
          BX1    -X0*X1      ISOLATE LENGTH INFO
          LX1    WC.CLIFP+59-WC.CTYPP 
          SX2    X1 
          PL     X1,ASBS10   IF LENGTH CONSTANT 
          =X2    1
          LX2    18          X2 = POSITIVE LARGE NUMBER 
  
 ASBS10   SA3    ASBSA       X3 = FIRST 
          NZ     B3,ASBS20   IF FIRST CONSTANT
          =X3    1
  
 ASBS20   NZ     B2,ASBS30   IF LAST IS CONSTANT
          BX6    X2 
  
 ASBS30   =X0    1
          IX1    X3-X0
          IX7    X6-X0
          BX7    X1+X7       MI IFF FIRST OR LAST NOT POSITIVE
          IX0    X6-X3       MI IFF FIRST GT LAST 
          BX0    X0+X7
          IX1    X2-X6       MI IF LAST GT LENGTH 
          BX0    X0+X1
          PL     X0,ASBS40   IF NO ERROR
          FATAL  E.AT16      INVALID SUBSTRING
  
 ASBS40   SA3    COLOP
          RJ     SDM         SET UP (SMOD) AND (SOPR) 
          RJ     ADT         T1 = (COLON, FIRST, LAST)
  
          SA4    SCR+AS.W    (1OP) = (ARGMIS) 
          SA3    SUBST
          SA5    B6-B1       (2OP) = T1 
          RJ     SDM         SET UP (SMOD) AND (SOPR) 
          RJ     ADT         T2 = (SUBST, SYMORD, T1) 
          EQ     POPX        EXIT.. 
  
 ASBSA    BSS    1           PRESERVE VALUE OF FIRST HERE 
 ASBSB    BSS    1           PRESERVE VALUE OF LAST HERE
 CSM      SPACE  4,10 
**        CSM - CHECK SUBSTRING MODE. 
* 
* 
*         ENTRY  (X5) = SUBSTRING OPERAND.
*                (B6)-1 -> STACK ENTRY FOR OPERAND. 
* 
*         EXIT   (X5) = LEGAL SUBSTRING OPERAND.
*                STACK ENTRY ALSO LEGAL.
* 
*         USES   X0,X2,X3,X6  B7  A5,A6.
* 
*         CALLS  CMR
  
  
 CSM      SUBR   0           ENTRY/EXIT...
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX2    -X0*X5 
          LX5    TP.MODEP 
          SX3    X2-M.INT 
          =X2    X2-M.BOOL
          ZR     X2,EXIT.    IF TYPE = BOOLEAN
          ZR     X3,EXIT.    IF TYPE = INTEGER
          ANSI   E.AT17      ** NON-INTEGER EXPRESSION
          SX6    M.INT
          RJ     CMR         COERCE MODE OF RESULT
          ZR     B7,CSM1     IF NO CONVERSION ERROR 
          FATAL  B7 
          SA5    CONONE 
          SB6    B6+1        CODE ASSUMES CONSTANT NOT IN ESTACK
  
 CSM1     BX6    X5 
          SA6    B6-B1
          EQ     EXIT.
          TITLE  POP/EMIT DO LOOP INDICIES. 
 A=DO     SPACE  4,10 
**        A=DO - PROCESS CLOSING OF *DO*. 
  
  
 A=DO     BSS    0
          SA1    SCR+1       FETCH PRIOR ARGCOMA
          LX1    -AC.CNTP 
          SX1    X1-3        MUST HAVE AT LEAST TWO INDICES 
          ERRNZ  18-AC.CNTL 
          PL     X1,PAREXIT  IF SUFFICIENT DO INDEX PARAMETERS
          FATAL  E.DO00 
  
 A=DO5    SA2    T=BLST 
          SX6    X2-Z=BLST-1
          SHRINK A2,X6
  
          SA1    T.BLST 
          SA2    T=BLST 
          SB2    X2-1 
          ZR     X2,A=DO9    IF NO NESTED BLOCK STRUCTURE 
  
          SA3    X1+B2       FETCH LC. WORD FOR BLOCK 
          LX3    -LC.CNTP 
          SB7    X3          NUMBER OF WORDS IN THIS T.BLST ENTRY 
          ERRNZ  18-LC.CNTL 
          HX3    LC.DO
          AX3    -LC.DOL     EXTRACT DO LOOP HEADER LABEL INDEX 
          ZR     X3,A=DO9    IF NOT DO LOOP 
  
          SB2    B2-B7
          SB2    X1+B2       TOP OF T.BLST ENTRY
          SA3    B2+DO.W+1
          HX3    DO.IOD 
          AX3    -DO.IODL    EXTRACT IMPLIED IO DO FLAG 
          NZ     X3,A=DO5    IF IMPLIED IO DO THEN SHRINK 
  
 A=DO9    =X6    0
          SA6    CDIFLG      CLEAR TO AVOID SECOND SCRATCH
          EQ     PSL
 C=DO     SPACE  4,10 
**        C=DO - DIGEST DO LOOP INDICIES. 
* 
*         ENTRY  (X5) = OPERAND FOR THIS INDEX. 
*                (X6) = (ARGCOMA).
*                (AC.CNT) = 1 + INDEX NUMBER, SEE (B3) BELOW. 
* 
*         JUMPS TO INDIVIDUAL INDEX PROCESSORS, WITH -- 
*                (B3) = CURRENT INDEX NUMBER. 
*                     = 0, CONTROL
*                     = 1, INITIAL
*                     = 2, LIMIT
*                     = 3, INCREMENT
*                     = 4, ERROR
*                (FILL.2) = ERROR LITERAL FOR NAME OF THIS PARAMETER. 
* 
*         EXIT   POPX 
  
 C=DO     BSS                ENTRY... 
          LX6    -AC.CNTP 
          SB3    X6-1        SET (B3) = CURRENT INDEX NUMBER
          ERRNZ  18-AC.CNTL 
          SA1    T=PAR
          SA2    B3+DO.DPC
          LX6    X1 
          BX7    X2          PREPARE (FILL.2) FOR ERROR MESSAGE 
          SA6    CURST
          SA7    FILL.2 
          JP     B3+DOXA     ENTER INDEX PROCESSOR
  
 DOXA     BSS 
          LOC    0
          EQ     DOC         CONTROL INDEX
          EQ     DOS         START (INITIAL) INDEX
          EQ     DOL         LIMIT INDEX
          EQ     DOI         INCREMENT INDEX
          LOC    *O 
 DO.ERR1  BSS    0           TOO MANY INDICES 
  
*         RETURN FOR ALL *DO* DEFINITION ERRORS.
  
 DO.ERR1  FATAL  E.DO00 
          EQ     PARX        EXIT PAR ENTIRELY
 DOS      SPACE  4,10 
**        DOS - DO START INDEX. 
* 
*         THE EQUAL SIGN ON OSTACK IS CHANGED INTO A COMMA, SO
*         THAT FURTHER COMMAS WILL POP CORRECTLY.  THIS ALSO
*         AVOIDS COMPLICATIONS IN THE EQUAL-CHAINING MECHANISM, 
*         AND WITH REPLACEMENT STATEMENT DIAGNOSES. 
  
  
 DOS      =X0    PR.SLP 
          =X3    O.COMMA
          LX0    SP.STPRP 
          LX3    SP.TBPRP 
          BX7    X0+X3
          SA7    B5          REPLACE *=* WITH SPECIAL *COMMA* 
          RJ     CDP         CONVERT DO PARAMETER 
          =A6    B2+DOSI.W   SET (DO-START INDEX) IN DO TABLE 
          EQ     POPX        EXIT.. 
 DOL      SPACE  4,10 
**        DOL - DO LIMIT INDEX. 
* 
*         EXIT   DOI - PRESET DEFAULT INCREMENT.
  
  
 DOL      RJ     CDP         CONVERT DO PARAMETER 
          =A6    B2+DOLI.W   SET (LIMIT) IN DO TABLE
          SA5    CONONE      PRESET (INCREMENT) = 1 
*         EQ     DOI         ...
 DOI      SPACE  4,10 
**        DOI - DO INCREMENT INDEX. 
* 
** FV     NOTE THAT DOI USED TO ATTEMPT TO CHECK FOR ZERO INCREMENT.
*         IT DID NOT CATCH TYPE REAL OR DOUBLE, HOWEVER.  THIS CODE 
*         LETS A ZERO INCREMENT GO THRU.  IT WILL BE PROPERLY DIAGNOSED 
*         IN *DTC*.  OTHER CHOICES ARE TO DIAGNOSE IN CONSTANT REDUCER, 
*         OR PUT OUT THE DIVIDE, AND LET AN OBJECT TIME INFINITY KILL 
*         THE PROGRAM.
  
  
 DOI      RJ     CDP         CONVERT DO PARAMETER 
          =A6    B2+DOII.W   SET (INCREMENT) IN DO TABLE
          EQ     POPX        EXIT.. 
 DOC      SPACE  4,10 
**        DOC - DO CONTROL INDEX. 
* 
*         EXIT   C=DO - CYCLE AGAIN, FOR INITIAL INDEX. 
  
  
 DOC      BX1    X4 
          LX5    X4          REMEMBER (X5) = CONTROL-INDEX OPERAND
          RJ     DOA         DETERMINE OPERAND ADDRESSIBILITY 
          SB7    E.DO15      ** CONTROL INDEX CANNOT BE CONST/EXPR
          NZ     X6,DOC4     IF OPERAND NOT ADDRESSABLE 
          =A3    A2-WB.W+WA.W 
          MX7    WA.SYML
          SB7    E.DO04      ** CONTROL INDEX MUST BE SIMPLE VARIABLE 
          HX3    WA.SYM 
          BX6    X7*X3       (FILL.) = NAME OF SYMBOL 
          SA6    FILL.
          PL     X1,DOC4     IF OPERAND SYMBOL IS NOT *WB.VAR*
          SBIT   X1,WB.ARYP/WB.VARP 
          MI     X1,DOC4     IF SYMBOL IS ARRAY 
          CLAS=  X1,WB,(DEF)
          CLAS=  X7,WB,(1REF) 
          BX7    -X7*X2      CLEAR STRAY FLAG 
          SA7    A2 
          SA3    DATFLG 
          SX3    X3-PM=DATA 
          ZR     X3,DOC2     IF IN *DATA* PROCESSING
          BX7    X7+X1       MARK VARIABLE AS DEFINED 
          SA7    A2 
          SA1    T.BLST 
          SA2    T=BLST 
          SB7    X2-Z=BLST-1+DOCI.W 
          =X7    0
          SA7    X1+B7       CLEAR DOCI.W TO AVOID NOISE
          SB3    -1          INDICATE DO CONTROL INDEX
          CALL   DDR         DIAGNOSE DO REDEFINITION 
  
 DOC2     SA4    ="M.OKDOC" 
          SB2    X0 
          LX4    B2 
          MI     X4,DOC7     IF THIS TYPE PERMITTED 
          SA3    X0+MOD.DPC 
          BX6    X3 
          SB7    E.DO15      ** DO INDEX CANNOT BE <TYPE> 
          SA6    FILL.3 
 DOC4     FATAL  B7 
  
*         DETERMINE CONTROL INDEX MODE.  SELECT CONCLUSION TURPLE.
  
 DOC7     SA3    DO.END 
          BX4    X5          (1OP) = (2OP)    /* INHIBIT MODE CONVERSION
          SA1    WO.DOLG     FETCH DO LOOP LENGTH INDICATOR 
          LX1    SP.SKELP 
          IX3    X1+X3       SELECT SKELETON (LONG OR SHORT)
          RJ     SDM         SELECT DOMINANT MODE 
          SA1    SMOD 
          SA2    T=BLST 
          SX6    X1 
          SA6    DOMODE 
          MX0    SP.SKELL 
          SB7    X2-Z=BLST-1+DP.W 
          SA1    T.BLST 
          HX3    SP.SKEL
          BX7    X0*X3       (DP.TURC)[T.DO] = CONCLUSION SKELETON
          LX7    -SP.SKELP+DP.TURCP 
          SA7    X1+B7
          SX1    B1 
          SA2    ARGCOMA
          SA5    B6-B1       RETURN (X5) = (START-INDEX) OPERAND
          BX7    X4 
          LX1    AC.CNTP
          IX6    X2+X1       INCREMENT COMMA COUNT
          =A7    A7-DP.W+DOCI.W    SET (CONTROL-INDEX) IN DO TABLE
          SA6    A2 
          LX6    -AC.CNTP    RETURN (X6) = COMMA COUNT
          LX7    -TP.ORDP 
          MX1    -TP.ORDL 
          BX7    -X1*X7      EXTRACT SYMORD OF CONTROL INDEX
          LX7    WB.DIP 
          SA2    A7-DOCI.W+DORT.W  X2 = OPERAND OF DO-TOP LABEL 
          LX2    -TP.ORDP 
          BX2    -X1*X2      EXTRACT SYMORD 
          SA1    T.SYM
          SB7    X2 
          LX2    1
          SB7    X2+B7
          =B7    B7+WB.W     CONVERT TO *WB* INDEX
          SA1    X1+B7       X1 = *WB* OF DO-TOP
          BX7    X7+X1       MERGE WITH INDEX OF CONTROL VARIABLE 
          SA7    A1          UPDATE *WB*
          EQ     C=DO        CYCLE FOR (START-INDEX)
 CDP      SPACE  4,10 
**        CDP - CONVERT DO PARAMETER. 
* 
*         ENTRY  (X5) = INDEX OPERAND.
* 
*         EXIT   (B2) = FWA ENTRY FOR THIS LOOP.
*                (B6)  DECREMENTED. 
*                (X6) = OPERAND IN DESIRED MODE.
* 
*         CALLS  CMR, FATAL, LCH. 
  
  
 CDP      SUBR   0           ENTRY/EXIT...
          BX1    X5 
          CALL   LCH         LOAD/CHECK CONSTANT
          SA3    ="M.OKDO"
          SA1    DOMODE 
          SB2    X0 
          LX3    B2 
          MI     X3,CDP2     IF THIS TYPE PERMITTED 
          SA2    X0+MOD.DPC 
          BX7    X2 
          SA7    FILL.3 
          FATAL  E.DO16      ** DO <INDEX> PARAMETER CANNOT BE <TYPE> 
          SA5    S=BU 
          LX1    TP.MODEP 
          BX5    X5+X1       INVENT INNOCOUS OPERAND
          LX1    -TP.MODEP
  
 CDP2     BX6    X1 
          RJ     CMR         COERCE MODE OF PARAMETER 
  
          SA1    T.BLST 
          SA2    T=BLST 
          BX6    X5          RETURN (X6) = CONVERTED OPERAND
          IX3    X1+X2
          SB6    B6-B1       DECREMENT ESTACK TOP 
          SB2    X3-Z=BLST-1
          EQ     EXIT.
 DTC      SPACE  4,10 
**        DTC - DETERMINE TRIP COUNT. 
* 
*         ENTRY  FROM LABEL/CDI AFTER DO PARAMETERS ARE PARSED. 
*                TOP ENTRY ON (T.BLST) SETUP. 
* 
*         EXIT   (X5) = TRIP COUNT OPERAND (INTEGER MODE).
* 
*         USES   CANNOT DESTROY B4. 
* 
*         CALLS  ACT, CMR 
  
  
 DTC      SUBR   =           ...ENTRY/EXIT... 
          SA1    T.BLST 
          SA2    T=BLST 
          IX1    X1+X2
          SB2    X1-Z=BLST-1
          =A5    B2+DOSI.W          (2OP) = M1
          =A4    A5-DOSI.W+DOLI.W   (1OP) = M2
          BX6    X4-X5
          SA6    DTCA        SAVE FOR LATER REFERENCE 
          =A1    A4-DOLI.W+DOII.W           M3
          BX6    X1 
          =A6    B6+1        ESTACK[TOP+1] = M3 
          =A6    B6+0        ESTACK[TOP+0] = M3 
          SB6    B6+4        TOP = TOP + 4
          SX1    O.MIN
          RJ     ACT         T1 = (MINUS, M2, M1) 
  
          SA5    B6-B1
          SX1    O.PL 
          SA4    A5-B1
          RJ     ACT         T2 = (PLUS, T1, M3)
  
          SA2    CONONE 
          SA4    B6-B1
          SA5    A4-B1
          BX0    X2-X5
          BX1    X5 
          ZR     X0,DTC15    IF M3 = 1
          CALL   LCT         LOAD CONSTANT TEST 
          ZR     B2,DTC10    IF INCR. NOT CONSTANT
          NZ     X6,DTC10    IF INCR. NZ
          FATAL  E.DO02      INCR. MUST NOT BE ZERO 
  
 DTC10    SX1    O.DIV
          RJ     ACT         T3 = (DIV, T2, M3) 
  
 DTC15    SA5    B6-1        FETCH T3 
          SA2    DATFLG 
          ZR     X2,DTC20    IF NOT IN DATA STATEMENT 
          BX2    X5 
          MX0    -TP.MODEL
          LX2    -TP.MODEP
          BX0    -X0*X2 
          SB2    X0-M.INT 
          ZR     X0,DTC20    IF TC IS BOOLEAN 
          ERRNZ  M.BOOL 
          ZR     B2,DTC20    IF TC IS INTEGER 
          FATAL  E.DO17      MUST BE INTEGER IN DATA
  
 DTC20    =X6    M.INT
          SB6    B6-B1       TOP = TOP - 1     /* RESTORE (B6)
          RJ     CMR         COERCE MODE:  TC = INT (T3)
          SA1    DTCA 
          NZ     X1,EXIT.    IF M1 .NE. M2
          SA5    CONONE 
          EQ     EXIT.
  
 DTCA     BSS    1
          TITLE  POP/EMIT EXPONENTIATION. 
 POP.EXP  EJECT 
**        POP.EXP - SYNTHESIZE RESULT OF EXPONENTIATION.
* 
*         POP.EXP EVALUATES CURRENT EXPONENTIAL BEING POPPED FOR
*         SIMPLE COMPILE TIME REDUCTION, TRANSFORMATIONS ON OPERATOR AND
*         CONVERSION NECESSARY TO PROCESS BOTH EXTERNAL AND INTERNAL
*         PROCESSING. 
* 
*         TRANSFORMATIONS POSSIBLE. 
* 
*         1.  INTEGER TO REAL (CONSTANT). 
*             IF POWER HAS AN INTEGRAL VALUE, CHANGE FORM TO
*             FLOAT(INTEGER) TO IFIX(REAL). 
* 
*         2.  INTEGER TO INTEGER (CONSTANT).
*             IF CONSTANT IS .LE. EXP.IL, PROCESS USING DEFINED MACROS
*             INLINE. 
* 
*         3.  REAL TO INTEGER (CONSTANT). 
*             IF CONSTANT IS .LE. EXP.IL, PROCESS USING DEFINED MACROS
*             INLINE. 
* 
* 
*         ENTRY  (X3) = O.EXP OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
  
  
 EXP.IL   EQU    16          UPPER LIMIT FOR COMPUTING ** INLINE
 TOIL.I   EQU    EXP.IL      INTEGER
 TOIL.R   EQU    EXP.IL      REAL 
 TOIL.D   EQU    2           DOUBLE 
 TOIL.Z   EQU    4           COMPLEX
  
  
 POP.EXP  BSS    0
          SA1    =XDATFLG 
          SA3    EXPOP
          NZ     X1,POP.STD  IF COMPILING DATA STATEMENT
  
 EXP10    MX0    -TP.MODEL
          BX6    -X0*X4      MODE OF BASE 
          SA1    X6+OM=EXP
          ERRNZ  M.BOOL 
          NZ     X6,EXP11    IF MODE OF BASE NOT BOOLEAN
          =X6    M.INT
  
 EXP11    BX3    -X0*X5      (X3) = MODE OF POWER 
          SA6    SMOD        (SMOD) = EFFECTIVE MODE OF BASE
          LX3    3
          SB2    X3          SHIFT COUNT = 8 * (MODE OF POWER)
          MX0    -8 
          AX1    B2,X1
          BX6    -X0*X1      (X6) = OFFSET TO CONTROL WORD
          SA3    X6+EXP.BASE
          BX7    X3 
          HX3    IT.DPC 
          AX3    -IT.DPCL 
          ZR     X3,EXP90    IF ILLEGAL MODE COMBO
          RJ     DDC         DIAGNOSE DOUBLE AND COMPLEX EXPRESSION 
  
          SA7    /CF/IE      SAVE INTRINSIC TABLE ENTRY 
          SX6    A3 
          BX1    X5 
          SA6    EXPA        REMEMBER (EXPA) = ADDRESS OF CONTROL WORD
          CALL   LCT         CHECK IF POWER IS CONSTANT 
          SA6    TER2        SAVE POWER 
          ZR     B2,EXP60    IF POWER NOT CONSTANT
          SB7    X0-M.REAL
          NZ     B7,EXP30    IF POWER NOT MODE REAL 
  
*         POWER IS REAL CONSTANT.  IF IT IS AN EXACT INTEGER, CHANGE
*         THE OPERAND SO THAT THE EQUIVALENT (REAL ** INT) OPERATION
*         IS EVALUATED.  SUPPRESS THIS ACTION WHEN PARSING A REQUIRED 
*         CONSTANT EXPRESSION (E.G., PARAMETER).
* 
*         IF NOT PARAMETER STMT THEN
*             IF LIR(POWER) THEN
*                 IF MODE.BASE IN [INTEGER, BOOL] THEN
*                     BASE := FLOAT(BASE) 
*                 ENDIF 
*                 POWER := IFIX(POWER)
*                 STARTOVER 
** FV         ELSIF POWER = 0.5 THEN
*                 CHANGE TO SQRT CALL      /* HOW ??? 
*             ENDIF 
*         ENDIF 
  
  
          SA1    PARNOW 
          SB7    X1-PM=PARM 
          NZ     B7,EXP20    IF NOT 'PARAMETER' PROCESSING
          FATAL  E.PX7       REAL POWER ILLEGAL ON 'PARAMETER'
          SA5    CONONE 
          EQ     PARX 
  
 EXP20    BX2    X6 
          CALL   LIR         LOAD INTEGRAL REAL 
          NZ     X6,EXP40    IF POWER NOT INTEGRAL VALUE
          BX5    X7 
          SA7    B6-B1       POWER := IFIX (POWER)
          MX0    -TP.MODEL
          LX4    -TP.MODEP
          BX3    -X0*X4      (X3) = MODE OF BASE
          LX4    TP.MODEP 
          BX6    X2 
          SA6    TER2 
          =X6    M.REAL 
          IX3    X3-X6
          PL     X3,EXP10    IF MODE.BASE .GE. REAL 
          BX5    X4 
          CALL   CMR         FLOAT (BASE) 
          IFEQ   TEST,ON,1
          NZ     B7,"BLOWUP" IF BASE MODE NFG 
          BX7    X5 
          SA5    B6-B1
          LX4    X7 
          SA7    A5-B1
          EQ     EXP10       STARTOVER..
  
  
*         IF POWER IS INTEGER CONSTANT, HANDLE END CASE VALUES. 
*         (NOTE THAT POWER = 0 CANNOT BE CHANGED INTO CONSTANT 1 UNLESS 
*         BASE IS CONSTANT.  OTHERWISE, MIGHT LOOSE AN EXECUTION ERROR
*         OF VARIABLE ZERO ** ZERO.)
  
*         IF BOOL DO WHAT ????
  
 EXP30    =B7    B7+M.REAL-M.INT
          NZ     B7,EXP40    IF POWER NOT MODE INTEGER
          NZ     X6,EXP35    IF POWER VALUE NOT ZERO
          BX1    X4 
          CALL   LCT         LOAD CONSTANT TEST (BASE)
          SB7    =XE.XP7     ** VARIABLE TO 0 RESULTS = 0 
          ZR     B2,EXP32    IF BASE NOT CONSTANT 
          NZ     X6,EXP34    IF BASE NOT ZERO 
          TRIV   E.XP3       ** 0 TO 0 IS INDEFINITE
          EQ     EXP60
  
 EXP32    TRIV   B7 
 EXP34    SA2    SMOD 
          SA5    CONONE 
          BX6    X2 
          CALL   CMR         CONVERT MODE OF (CONSTANT ONE) 
          =B6    B6-1 
          BX6    X5 
          SA6    B6-B1
          EQ     POPX        EXIT.. 
  
*         CHECK IF POWER IS *1*.  IF SO, REMOVE CONSTANT *1*
*         FROM *ESTACK* AND EXIT, POPPING NOTHING.
  
 EXP35    MX2    -1 
          IX0    X6+X2
          NZ     X0,EXP40    IF POWER NE 1
          CLAS=  X3,TP,(EXPR) 
          =B6    B6-1 
          BX6    X4+X3
          =A6    B6-1        RESTORE BASE (IN CASE CHANGED) 
          EQ     POPX        EXIT.. 
  
*         GENERAL TRANSFORMS NOW EXHAUSTED.  GOTO SPECIFIC PROCESSOR, 
*         WHEN ONE EXISTS.
  
 EXP40    SA1    EXPA 
          SA3    X1 
          SB3    X1          (B3) = ADDRESS OF CONTROL WORD 
          HX3    IT.PAR 
          PL     X3,EXP60    IF NO SPECIAL PROCESSING 
          SA2    TER2        (X2) = VALUE OF CONSTANT POWER 
          JP     B3+1 
  
  
*         NO REDUCTION POSSIBLE.  ISSUE TURPLES LIKE FUNCTION CALL. 
  
 EXP60    SA1    /CF/IE 
          MX0    -IT.ARGML
          LX1    -IT.ARGMP
          BX6    -X0*X1      (SMOD) = MODE OF RESULT
          SA6    SMOD 
          SA5    B6-B1
          SA4    A5-B1
          LX7    X5 
          SB6    B6+B1       ADJUST ESTACK, FUNCTION NAME NOT THERE 
          BX6    X4 
          SA7    B6-B1       STACK BASE AND POWER 
          SA6    A7-B1
          LX1    IT.ARGMP 
          =X7    2           INDICATE TWO ARGUMENTS 
          SA2    FUNCALL+2
          MX6    0           FAKE (WB.JPF) = 0
          SA7    /CF/AC 
          SA6    /CF/IT 
          EQ     ABEF 
 EMODE    SPACE  4,20 
**        EMODE - MODE SELECTION MATRIX FOR EXPONENTIATION. 
  
  
 EMODE    MACRO  MU,MI,MR,MD,MZ 
 C        MICRO  1,,$4/0$ 
.1        ECHO   ,FORMS=(HE,MZ,MD,MR,MI,LE,MU)
 C        MICRO  1,,$"C",8/TO.FORMS-EXP.BASE$ 
.1        ENDD
          VFD    "C"
 EMODE    ENDM
  
  
 OM=EXP   BSS    0
          LOC    0
 M.BOOL   EMODE  II,II,IR,ID,IZ 
 M.LOG    EMODE  LE,LE,LE,LE,LE 
 M.INT    EMODE  II,II,IR,ID,IZ 
 M.REAL   EMODE  RI,RI,RR,RD,RZ 
 M.DBL    EMODE  DI,DI,DR,DD,DZ 
 M.CPLX   EMODE  ZI,ZI,ZR,ZD,ZZ 
 M.CHAR   EMODE  HE,HE,HE,HE,HE 
          LOC    *O 
          PURGMAC EMODE 
 TO.**    SPACE  4,10 
**        EXPONENTATION CONTROL WORDS.
* 
*         EACH MODE COMBINATION IN (OM=EXP) POINTS TO ONE OF THE
*         FOLLOWING CONTROL WORDS.  EACH WORD IS EITHER (A) AN ERROR
*         INDICATION, OR (B) AN INTRINSIC FUNCTION SPECIFIER. 
* 
*         THE WORDS ARE NOMINALLY IN (IT.) FORMAT.  AN ERROR WORD HAS 
*                (IT.DPC) = 0 
*                (BITS 17-00) = DIAGNOSTIC ADDRESS. 
* 
*         IF (IT.PAR) IS SET THEN THE WORD FOLLOWING THE (IT.) ENTRY
*         IS EXECUTABLE CODE, BEGINNING A SPECIAL ANALYSIS ROUTINE, 
*         CALLED FOR CONSTANT OPERANDS ONLY.
  
  
 EXP.BASE BSS    0           FWA OF CONTROL WORDS 
  
  
*         ILLEGAL COMBINATIONS. 
  
 TO.LE    CON    E.XP1       LOGICAL BASE OR POWER
 TO.HE    CON    E.XP6       CHARACTER BASE OR POWER
  
 EXP90    FATAL  X7 
          SB6    B6-B1       SET RESULT = BASE
          EQ     POPX        EXIT.. 
 EXPEX    SPACE  4,20 
**        OBJECT LIBRARY EXPONENTIAL ROUTINES.
  
  
 EXPEX    MACRO  NAME,ARGTYP,FUNTYP,PAR,FLAGS,BRP 
 Y        MICRO  1,, NAME 
 Z        MICCNT Y
          ERRNZ  4-Z         ASSUMED LENGTH IS 4
* 
 C        SET 
          IRP    BRP
 C        SET    C+1S_BRP 
          IRP 
 .D       DECMIC C
* 
 .A       SET    6+PAR
 .C       MICRO  1,,$NAME$
          VFD    IT.DPCL/0L".C",IT.ATTRL/.A,IT.ARGCL/2_,IT.JPADL/".D",__
,IT.ARGML/M.ARGTYP,IT.MODEL/M.FUNTYP
 EXPEX    ENDM
 =XLIB    SPACE  4,10 
**        GENERAL COMBINATIONS - NO SPECIAL ANALYSIS. 
** FV     DO ANY EXPONENT ROUTINE PRESERVE ANY B-REGISTERS ???
  
  
 TO.IR    EXPEX  ITOX,INT,REAL
 TO.ID    EXPEX  ITOD,INT,DBL 
 TO.IZ    EXPEX  ITOZ,INT,CPLX
 TO.RR    EXPEX  XTOY,REAL,REAL 
 TO.RD    EXPEX  XTOD,REAL,DBL
 TO.RZ    EXPEX  XTOZ,REAL,CPLX 
 TO.DR    EXPEX  DTOX,DBL,DBL 
 TO.DD    EXPEX  DTOD,DBL,DBL 
 TO.DZ    EXPEX  DTOZ,DBL,CPLX
 TO.ZR    EXPEX  ZTOX,CPLX,CPLX 
 TO.ZD    EXPEX  ZTOD,CPLX,CPLX 
 TO.ZZ    EXPEX  ZTOZ,CPLX,CPLX 
 TO.INT   SPACE  4,10 
**        TO.INT - EXPAND SMALL POWERS BY INLINE MULTIPLIES.
*                (X2) = VALUE OF POWER. 
*                POWER IS NONZERO INTEGER CONSTANT, .NE. 1
  
  
 TO.II    EXPEX  ITOJ,INT,INT,1 
          PL     X2,TO.II5   IF POWER IS POSITIVE 
          TRIV   E.XP4       (INTEGER TO NEGATIVE CONST, RESULT ZERO) 
 TO.II5   SB7    TOIL.I 
          SX5    V=MUL.I
          EQ     EXM
  
  
 TO.RI    EXPEX  XTOI,REAL,REAL,1 
          SX5    V=MUL.R
          SB7    TOIL.R 
          EQ     EXM
  
  
 TO.DI    EXPEX  DTOI,DBL,DBL,1 
          SB7    TOIL.D 
          SX5    V=MUL.D
          EQ     EXM
  
  
 TO.ZI    EXPEX  ZTOI,CPLX,CPLX,1 
          SX5    V=MUL.C
          SB7    TOIL.Z 
          EQ     EXM
  
          PURGMAC EXPEX 
 EXD      SPACE  4,10 
**        EXD - EVALUATE INTEGER EXPONENTIAL, FROM CONRED/*SED*.
* 
*         ENTRY  (X1) = VALUE OF INTEGER BASE.
*                (X6) = VALUE OF INTEGER EXPONENT.
* 
*         EXIT   (X6) = RESULT OPERAND (M.INT). 
  
  
 EXD      SUBR   =           ENTRY/EXIT...
          BX7    X1 
          SA7    TER2 
          SA5    INTEG+/OP/MULT 
          =X7    M.INT
          SA7    SMOD 
          CALL   NCS         ENTER CONSTANT FOR BASE OPERAND
          SA6    EXOPDS 
          RJ     EXV         EVALUATE EXPONENTIAL 
          ZR     X6,"BLOWUP" IF SUBSUMPTION FAILED
          EQ     EXIT.
 EXM      SPACE  4,10 
**        EXM - EXPAND EXPONENTATION INTO MULTIPLIES. 
* 
*         ENTRY  (B7) = LIMIT TO EXPAND.
*                (X5) = MULTIPLY SKELETON NAME, FOR BASE MODE.
*                (X4) = OPERAND FOR BASE. 
*                (X2) = VALUE OF POWER. 
*                (TER2) = VALUE OF POWER. 
*                (SMOD) = MODE OF BASE. 
*                POWER IS NONZERO INTEGER CONSTANT. 
*         EMIT SERIES OF MULTIPLIES TO EVALUATE ** INLINE.
  
  
 EXM      BSS 
          SA1    IN.EXP      OPERATOR SKELETON
          LX5    SP.SKELP 
          BX7    X1+X5       (SOPR) = COMPLETE MULTIPLY SKELETON
          SA7    SOPR 
          BX6    X4 
          LX1    X4 
          SA6    EXOPDS      EXOPDS(0) = BASE OPERAND 
          SX4    B7+B1
          CALL   LCT         LOAD CONSTANT TEST (BASE)
          ZR     B2,EXM2     IF BASE NOT CONSTANT 
          SA7    A6+B1
          RJ     EXV         EVALUATE CONSTANT EXPONENTIAL
          ZR     X6,EXP60    IF NOT REDUCED 
          SB6    B6-B1
          SA6    B6-B1
          EQ     POPX        EXIT.. 
  
 EXM2     SA2    TER2 
          IX1    X2-X4
          PL     X1,EXP60    IF POWER .GE. (LIM+1)
          MI     X2,EXP60    IF POWER IS NEGATIVE, CAN-T BE EXPANDED
 .T       IFEQ   TEST,ON
          SX7    X2-2 
          MI     X7,"BLOWUP" IF POWER = 0, OR = 1 
 .T       ENDIF 
  
          SB6    B6-B1       COMPENSATE FOR (B6) ADJUSTMENT IN EXM4 LOOP
          =X7    1           N=1
          SA7    EXPA 
          SA1    EXMB-2+X2   ECW = EXMB(POWER)
  
 EXM4     MX0    -3 
          LX1    3           ECW = SHIFT (ECW , 3)
          BX6    -X0*X1      J = FIELDN[ECW]
          ZR     X6,POPX     IF J EQ 0
          SB3    X7+EXOPDS
          BX7    X1 
          SB6    B6+B1       DONT REDUCE STACK SIZE 
          SA7    EXPB 
          SA3    EXMA-1+X6   OCW = EXMA(J)
          SA4    X3+B3       OP1 = EXOPDS(N-IND1(OCW))
          AX3    18 
          SA5    X3+B3       OP2 = EXOPDS(N-IND2(OCW))
          SA3    SOPR 
          RJ     ADT         OUTPUT MULTIPLY
          SA1    B6-B1
          SA2    EXPA 
          BX6    X1 
          SA6    EXOPDS+X2   EXOPDS(N) = TOP OF ESTACK
          =X7    X2+1        N = N + 1
          SA1    EXPB 
          SA7    A2 
          EQ     EXM4        LOOP.. 
  
  
 EXORN    MACRO  RJ,RK
          VFD    24/,18/-RJ,18/-RK
          ENDM
  
 EXMA     BSS    0
          LOC    1
          EXORN  1,1         (N-1)*(N-1)
          EXORN  1,2         (N-1)*(N-2)
          EXORN  1,3         (N-1)*(N-3)
          EXORN  1,4         (N-1)*(N-4)
          EXORN  1,5         (N-1)*(N-5)
          EXORN  2,3         (N-2)*(N-3)
          EXORN  3,4         (N-3)*(N-4)
          LOC    *O 
  
 MAXMUL   SET    0
 EXOC     MACRO  A
 .M       SET    0
 .N       SET    0
 .S       SET    A_B
          DUP    14,5        COUNT NUMBER OF OGITS IN STRING
 .S       SET    .S/8 
 .N       SET    .N+3 
 .M       SET    .M+1 
          IFEQ   .S,0,1 
          STOPDUP 
          VFD    .N/A_B,*P/.N/3 
 MAXMUL   MAX    MAXMUL,.M
          ENDM
          NOREF  .N,.S,.M 
  
**        EXMB - EXPONENTIAL MACRO EXPANSION SKELETON CONTROL TABLE.
* 
*         FORMAT - 42/DDDD0, 18/N.INST ( IN MACRO EXPANSION ).
*                D = DIGIT INDICATING OPERANDS OF MULTIPLY OPERATOR.
*                I.E. AN INDEX INTO *EXMA*. 
  
 EXMB     BSS    0
          LOC    2
          EXOC   1           X**2 
          EXOC   12          X**2 * X 
          EXOC   11          (X**2)**2
          EXOC   113         (X**2)**2 * X
          EXOC   112         (X**2)**2) * X**2
          EXOC   1162        (X**2)**2 * (X**2 * X) 
          EXOC   111         ((X**2)**2)**2 
          EXOC   1114 
          EXOC   1131 
          EXOC   11623
          EXOC   1112 
          EXOC   11125
          EXOC   11124
          EXOC   12113
          EXOC   1111        (((X**2)**2)**2)**2
          LOC    *O 
  
 EXOPDS   BSS    MAXMUL+1 
 EXV      SPACE  4,10 
**        EXV - EVALUATE CONSTANT EXPONENTIAL.
* 
*         ENTRY  (X5) = MULTIPLY SKELETON INDEX (FOR MODE OF BASE). 
*                (SOPR) = MULTIPLY OPERATOR (FOR MODE OF BASE). 
*                (SMOD) = MODE OF BASE. 
*                (EXOPDS+0) = OPERAND FOR BASE. 
*                (TER2) = VALUE OF POWER (INTEGER ONLY).
* 
*         EXIT   (X6) .NZ. = OPERAND FOR RESULT.
*                     .ZR. = EVALUATION FAILED. 
* 
*         USES   ALL BUT A0, B4-6.
*         CELLS  EXPA, EXPB, TER1, TER2.
*         CALLS  ACT, CCR.
  
  
 EXV9     TRIV   E.XP5       ** CONSTANT TO CONSTANT WON'T EVALUATE 
  
 EXV      SUBR   0           ENTRY/EXIT...
          LX5    -SP.SKELP
          SA1    X5+=XF.SKCR
          LX1    -VS.CRAP 
          SX7    X1          (EXPB) = ADDRESS OF CONSTANT REDUCER 
          ERRNZ  18-VS.CRAL 
          SA7    EXPB 
          SA3    SMOD 
          SA5    CONONE 
          BX6    X3 
          CALL   CMR         (EXVG) = OPERAND FOR CONSTANT ONE
 .T       IFEQ   TEST,ON,1
          NZ     B7,"BLOWUP" IF CAN'T CONVERT ONE 
          SA2    TER2 
          BX6    X5 
          SA6    EXVG 
          SA6    A6+B1       (EXVG+1) ALSO = ONE
          BX1    X2 
          AX2    -1 
          BX7    X2-X1       SCALE = ABS(POWER) 
          SA7    EXPA 
  
 EXV4     MX0    -1 
          BX2    -X0*X7      (X2) = ODD(SCALE)
          ZR     X2,EXV6     IF SCALE NOT ODD 
          SA4    EXVF        FAC
          SA3    EXPB 
          SA5    A4+B1       G
          BX7    X3 
          CALL   CCR         G = G * FAC
          ZR     X6,EXV9     IF BAD MULTIPLY
          SA6    EXVG 
 EXV6     SA4    EXVF 
          SA3    EXPB 
          SA5    EXPA 
          AX7    X5,B1       SCALE = SCALE/2
          SA7    A5 
          ZR     X7,EXV7     IF SCALE = 0 
          BX5    X4 
          LX7    X3 
          CALL   CCR         FAC = FAC * FAC
          ZR     X6,EXV9     IF BAD MULTIPLY
          SA6    EXVF 
          SA5    EXPA 
          BX7    X5 
          EQ     EXV4 
  
*         IF POWER WAS NEGATIVE, RESULT = RECIPROCAL. 
  
 EXV7     SA1    TER2 
          SA5    EXVG 
          PL     X1,EXV8     IF POWER WAS POSITIVE
          SA4    A5+B1       (1OP) = CONSTANT ONE 
          SX1    O.DIV
          SB6    B6+B1       COMPENSATE FOR DECREMENT IN ACT
          RJ     ACT         ADD CONVERTED TURPLE 
          SA5    B6-B1
  
 EXV8     BX6    X5          RETURN (X6) = RESULT 
          EQ     EXIT.
  
 EXVF     EQU    EXOPDS      HOLDS CURRENT FACTOR = BASE ** (2**N)
 EXVG     EQU    EXVF+1      HOLDS PARTIAL RESULT 
          TITLE  POP/EMIT APLIST AND FUNCTION REFERENCE.
**        POP/EMIT APLIST AND FUNCTION REFERENCE. 
  
  
          QUAL   CF          CALL FUNCTION CELLS
 AC       BSS    1           ACTUAL ARGUMENT COUNT
 APL      BSS    1           APLIST OPERATOR
 IE       BSS    1           INTRINSIC TABLE ENTRY
 IT       BSS    1           INTRINSIC TABLE INDEX
 MA       BSS    1           .NZ. IF POST-COERCION NEEDED 
 RJ       BSS    1           FUNCTION CALL OPERATOR 
 TP       BSS    1           TAG FOR ROUTINE
          QUAL   *
 CF=AC    EQUENT /CF/AC      ACTUAL ARGUMENT COUNT FOR KEY/CALL 
 C=CALL   SPACE  4,10 
**        C=CALL - PROCESS ARGUMENT FROM CALL STATEMENT 
* 
*         ENTRY  (X5) = OPERAND FOR ARGUMENT. 
  
  
 C=CALL   BSS    0
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          RJ     SSA         STACK SUBROUTINE ARGUMENT
          EQ     POPX 
 A=CALL   SPACE  4,10 
**        A=CALL - SUBROUTINE CALL RIGHT PAREN. 
* 
*         ENTRY  (X5) = FINAL OPERAND.
*                (SCR+AC.W) = ARGCOMA.
*                (CALLTAG) = OPERAND FOR SUBROUTINE.
* 
*         WE FIRST CALL SSA TO STACK THE FINAL ARGUMENT.  AFTER THAT, 
*         THE ARGUMENTS ARE SITTING AS FOLLOWS -- 
*         ESTACK = NORMAL ARGS ARE ON THE ELEMENT STACK.
*                (B6) -> TOP (EMPTY) POSITION, AS USUAL.
*         (T.ARG) = LABEL ARGUMENTS HAVE BEEN COLLECTED IN THIS TABLE.
*         (AC.CNT) = TOTAL ARG COUNT (NORMS + LABELS).
*         IF THERE WERE NO LABEL ARGS, (T=ARG) = ZERO.
* 
*         CRL IS CALLED TO MOVE ANY LABEL ARGS ONTO THE TOP OF ESTACK,
*         AFTER ALL THE NORMAL ONES.  SO THE STACK THEN LOOKS 
*         LIKE IT ALWAYS DOES, AND WE CAN EMIT THE ENTIRE ARGUMENT
*         LIST NORMALLY.  (ACTUALLY, CRL INSERTS AN INVENTED LABEL
*         BETWEEN THE TWO GROUPS, BUT AS HE ADJUSTS THE ARG COUNTS
*         APPROPRIATELY IT IS NONE OF OUR BUSINESS.)
* 
*         NOTE THAT WE ONLY GET HERE IF THERE WERE ARGUMENTS. 
*         OMITTED ARGLIST CASE IS HANDLED IN KEY/CLL. 
*         EMPTY ARGLIST WILL BE DIAGNOSED EARLY IN PAR. 
* 
*         EXIT   TO POPX. 
*                RJ TURPLE NOT YET OUT. 
* 
*         CALLS  CRL, EAL, IAC, SSA, TPC, VEL 
  
  
 A=CALL   BSS    0
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          RJ     SSA         STACK SUBROUTINE ARGUMENT
          RJ     IAC         INCREMENT ARGUMENT COUNT 
          SA4    CALLTAG
          RJ     VEL         VALIDATE ARGUMENT LIST 
          SA2    T=SLARG
          ZR     X2,ACALL3   IF NO STATEMENT LABEL PARAMETERS 
          CALL   CRL         PROCESS CALL RETURN LABELS 
  
 ACALL3   SA1    B4 
          ZR     X1,ACALL5   IF *EOS* 
          FATAL  E.SU10 
          ERRNZ  O.EOS
          =X6    O.EOS
          SA6    B4          RESET CURRENT T.TB TO *EOS*
  
 ACALL5   SA3    /CF/APL
          RJ     EAL         EMIT AP LIST 
          EQ     POPX        EXIT.
 C=FUN    SPACE  4,20 
**        C=FUN - USER FUNCTION COMMA.
* 
*         ARGUMENT MOVED TO T.ARG OR T.SLARG. 
* 
*         NOTE EXTREMELY DIRTY KLUDGE FOR STATEMENT LABEL PARAMETER --
*         PAR.MULT SET IT'S MODE = 7 SO WE COULD RECOGNIZE IT.
  
  
 C=FUN    BSS    0           ENTRY... 
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          MX0    -TP.MODEL
          LX0    TP.MODEP 
          BX1    -X0*X5      X1 = MODE OF ARG 
          BX1    X0+X1
          ERRNZ  N.TYPE-7 
          ERRNZ  TP.MODEL-3 
          NZ     X1,CFUN5    IF NOT STATEMENT LABEL PARAMETER 
          FATAL  E.SU11 
          EQ     POPX 
  
 CFUN5    RJ     SSA         STACK SUBPROGRAM ARGUMENT
          EQ     POPX        EXIT.. 
 A=FUN    SPACE  4,10 
**        A=FUN - USER FUNCTION RIGHT PAREN.
* 
*         ENTRY  (SCR+AS.W) = OPERAND FOR ROUTINE (SET BY PAR.FUN). 
*         ARGUMENTS ARE ON T.ARG AND T.SLARG .
* 
*         EXIT   TO GFR.
* 
*         CALLS  IAC,SSA,TPC,VEL
  
  
 A=FUN    BSS    0
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          SA2    FUNOP
          BX6    X2          SET RJ TYPE = USER FUNCTION
          SA6    /CF/RJ 
          RJ     IAC         INCREMENT ARGUMENT COUNT 
          ZR     X7,AFUN4    IF NO ARGS 
          RJ     SSA         STACK SUBPROGRAM ARGUMENT
          SA1    /CF/AC 
          BX7    X1          RESTORE (X7) = ARG COUNT 
  
 AFUN4    SA4    SCR+AS.W    FETCH (ARGMIS) 
          RJ     VEL         VALIDATE EXTERNAL LIST 
          EQ     GFR         GO GENERATE FUNCTION REFERENCE 
 C=INF    SPACE  4,10 
**        C=INF - INTRINSIC FUNCTION COMMA. 
* 
*         ARGUMENT IS LEFT ON (ESTACK). 
  
  
 C=INF    BSS                ENTRY... 
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          SA2    ARGCOMA
          RJ     VAM         VALIDATE ARGUMENT MODE 
          EQ     POPX 
 A=INF    SPACE  4,10 
**        A=INF - INTRINSIC FUNCTION RIGHT PAREN. 
  
  
 A=INF    BSS                ENTRY... 
          RJ     TPC         TEST FOR PASSED LENGTH CONCATENATION 
          RJ     IAC         INCREMENT ARG COUNT
          RJ     VAM         VALIDATE FINAL ARGUMENT MODE 
          SA7    SMOD 
          RJ     VIL         VALIDATE INTRISIC ARG LIST 
          BX1    X2 
          HX2    IT.XTER
          PL     X2,ABIF     IF INLINE INTRINSIC
          SA2    FUNCALL
*         EQ     ABEF 
 ABEF     SPACE  4,10 
**        ABEF - CALL EXTERNAL INTRINSIC FUNCTION.
* 
*         ENTRY  (X1) = INTRINSIC TABLE ENTRY.
*                (CF/IE) = INTRINSIC TABLE ENTRY. 
*                (CF/IT) = INTRINSIC TABLE INDEX. 
*                (X2) = (FUNI) FOR CALL BY NAME.
*               (CF/AC) = NUMBER OF ARGS IN CALL. 
  
  
 ABEF     BSS 
          SA3    CO.DBTB
          HX1    IT.BYN 
          BX4    X3+X1
          LX1    IT.BYNP+1
          MI     X4,ABEF2    IF (TRACEBACK) OR (BY-NAME FUNC) 
          SA2    FUNCALL+1
  
 ABEF2    BX6    X2          SET CALLING SEQUENCE STYLE 
          SA6    FUNCALL-1
          RJ     TXI         TAG EXTERNAL INTRINSIC 
          SA5    /CF/AC      X5 = NO. OF ARGS (NO. WORDS FOR ALLOC,MOVE)
          SA4    T=ARG       SAVE OLD T.ARG LENGTH IN X4
          ALLOC  T.ARG,X5 
          IX3    X1+X4       X3 = DESTINATION OF MOVE 
          SB2    X5 
          SB6    B6-B2       REMOVE ARGS FROM ESTACK
          MOVE   X5,B6,X3    ARGS MOVED TO T.ARG
          EQ     GFR         GO GENERATE FUNCTION REFERENCE 
 ABIF     SPACE  4,10 
**        ABIF - CALL INLINE INTRINSIC FUNCTION.
* 
*         ENTRY  (X1) = INTRINSIC TABLE ENTRY 
  
  
 ABIF     BSS 
          SA2    PARNOW 
          SX2    X2-PM=DATA 
          NZ     X2,ABIF0    IF NOT PROCESSING DATA VARIABLE LIST 
          ANSI   E.ANS5 
  
 ABIF0    BSS    0
          SA2    PARNOW 
          SX2    X2-PM=PARM 
          NZ     X2,ABIF1    IF NOT *PARAMETER* PROCESSING
          ANSI   E.ANS5      ** FUNCTION REF. IN CONSTANT EXPRESSION
  
 ABIF1    RJ     ESF         EVALUATE SPECIAL FUNCTION
          MI     X2,POPX     IF FUNCTION REDUCED
          SA1    /CF/AC 
          SB7    X1 
          GT     B7,B1,ABIF2       IF MULTIPLE ARGUMENTS
          LDBIT  X6,SP.UNARP
  
 .T       IFEQ   TEST,ON,1
          ZR     B7,"BLOWUP" IF INLINE WITH ZERO ARGUMENTS
  
          BX3    X3+X6       INDICATE UNARY TURPLE
          SA5    B6-1        FETCH ARGUMENT 
          EQ     POP.ST1     EXIT.. 
  
 ABIF2    BX6    X3          SET (SOPR) = OPERATOR PER ESF
          SX7    B7-B1       INITIAL (TC) = (ARG COUNT) - 1 
          SA6    SOPR 
          SA7    A1 
  
 ABIF4    SA3    SOPR              REPEAT ... 
          SA5    B6-B1       (2OP) = ESTACK [TOP] 
          SA4    A5-B1       (1OP) = ESTACK [TOP-1] 
          RJ     ADT         ADD TURPLE 
          SA1    /CF/AC 
          SX7    X1-1        (TC) = (TC) - 1
          SA7    A1                UNTIL (TC) = 0 
          NZ     X7,ABIF4    IF MORE ARGS TO ISSUE
  
          SA5    B6-B1
          BX7    X5          REMOVE FUNCTION NAME FROM STACK
          SB6    B6-B1
          SA7    A5-B1
  
*         IF THIS FUNCTION REQUIRES POST-CONVERSION, DO IT NOW. 
*                (CF/MA) = TARGET RESULT MODE.
  
          SA2    /CF/MA 
          ZR     X2,POPX     IF MODE ALREADY CORRECT
          SX6    X2          (SMOD) = TARGET RESULT MODE
          SA3    MCVOP
          AX2    18 
          SA6    SMOD 
          SX1    X2 
          LX1    SP.SKELP 
          SA5    B6-B1       (2OP) = RESULT (ADT WILL FIX UNAR) 
          IX7    X3+X1       FORM TURPLE HEADER FOR CONVERSION OPERATOR 
          SB6    B6+B1       ADJUST ELSTAK FOR UNARY
          SA7    SOPR 
          RJ     ADT         ADD CONVERSION TURPLE
          EQ     POPX        EXIT.. 
 C=STFA   SPACE  4,10 
**        C=STFA - STATEMENT FUNCTION ACTUAL ARGUMENT COMMA.
  
 C=STFA   EQ     POPX 
 A=STFA   SPACE  4,10 
**        A=STFA - STATEMENT FUNCTION ACTUAL ARGUMENT RIGHT PAREN.
  
 A=STFA   SA1    DATFLG 
          ZR     X1,STFA1    IF NOT PROCESSING DATA STATEMENT 
          FATAL  E.DVR5 
  
 STFA1    SA4    SCR+AS.W    ARGMIS IS FUNCTION ORD 
          LX4    -TP.ORDP 
          MX0    -TP.ORDL 
          SA1    T.SYM
          BX3    -X0*X4 
          LX7    B1,X3
          =B3    X1+WB.W
          IX0    X3+X7
          SA3    B3+X0
          MX0    1
          LX0    1+WB.SFXP
          BX6    X3+X0
          =A4    A3+WC.W-WB.W 
          =A3    A3+WA.W-WB.W 
          MX0    WA.SYML
          BX7    X0*X3
          SA7    FILL.
          LX4    -WC.ARGCP
          MX0    -WC.ARGCL
          BX7    -X0*X4 
          SB3    X7-1 
          EQ     B2,B3,STFA10      IF ARG COUNT OK
          FATAL  E.SF09 
          =B3    B2+1 
          SB6    B6-B3       UNSTACK ARGS 
          EQ     PAR.STOP 
  
 STFA10   SA6    A3+WB.W-WA.W      MARK SF *EXPANDING*
          MX0    -WB.STFPL
          LX6    -WB.STFPP
          LX2    -AC.EARGP
          BX6    -X0*X6 
          SA1    T.STF
          IX0    X1+X6
          SX7    B4          ARGCOMA = *TB* POINTER RESTORE 
          SA3    INSTF
          ZR     X3,STFA15   IF NOT PARSING FROM STATEMENT FUNCTION 
          IX7    X7-X1       RELATIVIZE TOKEN POINTER 
  
 STFA15   LX7    AC.TBRP
          SB4    X0          POINT TO WORD BEFORE SKEL (SPS ADVANCES) 
          SA3    X0          FIRST DUMMY ARG REFERENCE
          SA1    ALC.STF
          BX6    X1 
          SA6    ALC.REG     LOCK B4 TO T.STF 
          SX2    X2 
          ERRNZ  AC.EARGL-18
          LX3    -SF.DACPP
          SX0    X3 
          ERRNZ  SF.DACPL-18
          LX3    SF.DACPP-SF.PEARP
          SX3    X3 
          ERRNZ  SF.PEARL-18
          LX3    TB.ACTEP 
          LX2    SF.PEARP 
          LX0    SF.DACPP 
          BX6    X0+X2
          LX0    -SF.DACPP
          LX2    TB.ACTEP-SF.PEARP
          SA6    A3 
          MX4    -TB.DACL 
          ZR     X0,STFA30   IF NO PARAMETERS USED
  
 STFA20   SA1    X0+B4       NEXT ARG REF IN SKELETON 
          IX5    X1+X2       ADD IN NEW ESTACK BASE 
          IX6    X5-X3       SUBTRACT PREVIOUS BASE 
          LX1    -TB.DACP 
          SA6    A1 
          BX0    -X4*X1 
          NZ     X0,STFA20   IF NOT END OF DUMMY ARG REF
  
 STFA30   SA4    SCR+AS.W    PROPOGATE ARGMIS 
          SA1    INSTF
          =X6    X1+1 
          SA6    A1          INSTF = INSTF + 1 */ SF EXPANSION DEPTH
          SA1    ESFARM 
          BX6    X1          ARGMODE = ESFARM  */ BEGIN EXPANSION 
          SB3    O.SLP
          EQ     PAR.SPS
 A=STFE   SPACE  4,10 
**        A=STFE - POP RIGHT PAREN AFTER EXPANDING ST. FUNCT. BODY. 
  
 A=STFE   SA2    SCR+AS.W 
          SA1    INSTF
          LX2    -TP.ORDP 
          MX0    -TP.ORDL 
          BX0    -X0*X2 
          LX4    B1,X0
          IX4    X4+X0
          SX6    X1-1 
          SA6    A1          POP ONE LEVEL OF SF EXPANSION
          NZ     X6,STFE10   IF STILL IN SF EXPANSION 
          SA1    ALC.00 
          BX6    X1 
          SA6    ALC.REG     UNLOCK B4
          EQ     STFE20 
  
 STFE10   SA1    T.STF
          SB2    X1+B2       ABSOLUTIZE STATEMENT FUNCTION TOKEN POINTER
  
 STFE20   SA1    T.SYM
          =B3    X1+WB.W
          MX0    -1 
          SA1    X4+B3
          LX0    WB.SFXP
          BX6    X0*X1       CLEAR *EXPANDING* FLAG 
          SA6    A1 
          =A5    A1-WB.W+WA.W 
          MX6    WA.SYML
          BX6    X6*X5       SYMBOL ONLY
          SB4    B2          RESTORE TOKEN BUFFER POINTER 
          SA6    FILL.       FOR POSSIBLE DIAGNOSTIC
          =A4    A1+WC.W-WB.W 
          MX0    -WC.ARGCL
          LX4    -WC.ARGCP
          BX1    -X0*X4 
          =A5    B6-1 
          BX6    X5 
          SB3    X1 
          SB6    A5-B3       REPLACE ARG1 ON ESTACK WITH EXPANSION
          MX0    -TP.MODEL
          LX2    TP.ORDP-TP.MODEP 
          BX6    -X0*X2 
          LX4    WC.ARGCP-WC.CLENP
          MX0    -WC.CLENL
          BX1    -X0*X4 
          RJ     CLM         COERCE MODE AND CHAR LEN TO S.F. 
          BX6    X5 
          SA6    B6          REPLACE EXP WITH CONVERSION
          =B6    B6+1 
          ZR     B7,PAR.NX   IF NO CONVERSION ERROR 
          FATAL  E.SF15 
          EQ     PAR.NX 
 GFR      SPACE  4,10 
**        GFR - GENERATE FUNCTION REFERENCE.
* 
*         EMITS FUNCTION AP-BEGIN TURPLE (V=FAP), EMITS AP LIST, AND
*         THEN SET UP FOR THE RJ, AND RETURN TO POP MAIN. 
* 
*         ENTRY  (/CF/) SET UP. 
*                (SMOD) = RESULT MODE OF FUNCTION.
* 
*         EXIT   TO POP.ST1 --
*                (X3) = OPR        = (CF/RJ)
*                (X4) = 1OP        = (CF/TP)
*                (X5) = 2OP        = (CF/AC)
*                (CURST) = SQUEEZE BOUNDARY RESET.
* 
*         CALLS  EAL, EMIT. 
  
  
 GFR      BSS                ENTRY... 
          SA2    SMOD 
          SA3    FAPOP
          LX2    SP.MODEP 
          SA5    /CF/AC      (2OP) = NUMBER OF ARGS IN CALL 
          BX6    X2+X3       SET MODE IN TURPLE HEADER
          SA4    /CF/TP      (1OP) = TAG OF ROUTINE 
          LX5    TP.BIASP 
          SA6    SOPR 
          EMIT   A6,* 
          SA3    /CF/APL
          RJ     EAL         EMIT AP LIST 
  
*         EMIT RJ TO ROUTINE, AND RESET SQUEEZE BOUNDARY. 
  
          SA4    /CF/TP      (1OP) = TAG OF ROUTINE 
          SA1    T=PAR
          SA3    /CF/RJ      (OPR) = JUMP TYPE
          SA5    /CF/AC      (2OP) = NUMBER OF ARGS IN THIS CALL
          SX7    X1+Z=TURP
          SB6    B6+B1       ADJUST ESTACK FOR SINGLE ELEMENT 
          SA7    CURST       RESET SQUEEZE BOUNDARY 
          LX5    TP.BIASP 
          EQ     POP.ST1     EXIT.. 
 EAL      SPACE  4,10 
**        EAL - EMIT ACTUAL-PARAMETER LIST. 
* 
*         EMIT THE ACTUAL PARAMETER LIST, ONE TURPLE PER ARGUMENT.
* 
*         NOTE - CALLERS OUTSIDE OF PAR SHOULD BE PARTICULARLY CAREFUL
*                ABOUT (B6) AND ESTACK UPON ENTRY AND RETURN. 
* 
*         ENTRY  (CF/AC) = NUMBER OF ARGS.
*                (X3) = APLIST OPERATOR.
*                ARGS ON T.ARG. 
* 
*         EXIT   (CF/APL) = APLIST OPERATOR = SAVED (X3). 
*                (T=ARG) = 0. 
* 
*         USES   ALL BUT  A0, B4, B5. 
*         CALLS  EMT
  
  
 EAL      SUBR   =           ENTRY/EXIT...
          BX6    X3 
          SA2    /CF/AC 
          MX5    0           (2OP) = NIL
          SA6    /CF/APL
          ZR     X2,EXIT.    IF NO ARGUMENTS
          SA1    T.ARG
          SA3    T=ARG
          IX1    X1+X3
          IX1    X1-X2       FWA OF ARGUMENT LIST 
          =B2    0
  
 EAL10    SA4    X1+B2       X4 = NEXT ARGUMENT 
          =X6    B2+1 
          SA6    EALA        UPDATE AND SAVE INDEX
          MX0    -TP.MODEL
          SA2    /CF/APL     FETCH APLIST OPERATOR
          LX4    -TP.MODEP
          BX7    -X0*X4      ISOLATE MODE OF THIS ARG 
          LX7    SP.MODEP 
          BX6    X7+X2       SET TURPLE MODE PER ARG
          LX4    TP.MODEP    (1OP) = ARG
          SA6    SOPR 
          EMIT   A6,* 
          SA1    T.ARG
          SA2    T=ARG
          IX1    X1+X2
          SA3    /CF/AC 
          IX1    X1-X3       REFRESH FWA OF ARGLIST 
          SA2    EALA 
          SB2    X2 
          IX4    X3-X2
          NZ     X4,EAL10    IF MORE ARGUMENTS
          SA1    T=ARG
          IX6    X1-X3       X6 = NEW LENGTH OF T.ARG 
          SHRINK T=ARG,X6 
          EQ     EXIT.
  
 EALA     BSS    1
 ESF      SPACE  4,10 
**        ESF - EVALUATE SPECIAL INTRINSIC FUNCTION.
* 
*         ENTRY  (X1) = INTRINSIC TABLE ENTRY.
*                ARGUMENTS ON TOP OF ESTACK.
* 
*         EXIT   (X2) .MI. = FUNCTION COMPLETELY REDUCED -- 
*                RESULT ON ESTACK.
* 
*         ELSE   (X2) .PL. = ISSUE INLINE FUNCTION -- 
*                (X3) = TURPLE HEADER FOR FUNC. 
*                (ESTACK) = ARGUMENTS POSSIBLY ALTERED. 
*                (SMOD) POSSIBLY ALTERED. 
* 
*         USES   ALL BUT A0,  B4-6. 
*         CALLS  ADT, CMR, ESA, FATAL, LCH, LCT, NCS, TAGSEX. 
  
  
 ESF9     SA1    BIFFUN 
          LX2    SP.SKELP 
          BX3    X1+X2       FORM TURPLE HEADER 
  
 ESF      SUBR   -           ENTRY/EXIT...
          MX0    -IT.JPADL
          LX1    -IT.JPADP
          BX6    -X0*X1      ISOLATE (X6) = POINTER TO SKEL OR PARSER 
          LX1    IT.JPADP-1-IT.PARP 
          SX2    X6+OM=INL   (X2) = (POSSIBLE) SKELETON INDEX 
          PL     X1,ESF9     IF NO PARSER PROCESSING
          SA5    B6-B1
          SB7    X6 
          JP     B7+ESFBASE 
  
  
          MACRO  ESINL,NAM
          BSS 
 D        MICRO  1,7, ES=NAM
 "D"      EQUENT *-ESFBASE
          ENDM
  
 ESFBASE  BSS    0           BASE ADDRESS 
 ES.CMP   SPACE  4,10 
**        ES.CMP - COERCE OPERANDS OF DYADIC 'CMPLX'. 
* 
*         BOTH OPERANDS MUST BE COERCED TO TYPE REAL BEFORE THE 
*         FUNCTION CAN BE ISSUED. 
  
  
 CMPL     ESINL 
          =X6    M.REAL 
          CALL   CMR         COERCE (2OP) MODE
 .T       IFEQ   TEST,ON,1
          NZ     B7,"BLOWUP" IF VIL LET BAD MODE THRU 
          BX7    X5 
          SA7    B6-B1
  
          =X6    M.REAL 
          SA5    A7-B1
          CALL   CMR         COERCE (1OP) MODE
 .T       IFEQ   TEST,ON,1
          NZ     B7,"BLOWUP" IF VIL LET BAD MODE THRU 
          SX2    V=CMPLX
          =X6    M.CPLX      RESTORE (SMOD)  (CMR DESTROYED IT) 
          BX7    X5 
          SA6    SMOD 
          SA7    B6-2 
          EQ     ESF9 
 ES.LEN   SPACE  4,10 
**        ES.LEN - CHARACTER LENGTH INTRINSIC.
* 
*         IF OPERAND IS CONSTANT, REDUCE FUNCTION.
*         ELSE, SET UP TO ISSUE AS EXTERNAL.
  
  
 LEN      ESINL 
          SA1    PARNOW 
          SX1    X1-PM=PARM 
          NZ     X1,ES.LEN1  IF NOT PARAMETER CONSTANT EXPRESSION 
          FATAL  E.INF3 
  
 ES.LEN1  BX1    X5 
          LX5    -TP.MODEP
          BX6    0           PRESET ERROR INTRINSIC 
          MX0    -TP.MODEL
          BX0    -X0*X5 
          SB7    X0-M.CHAR
          NZ     B7,ES.LEN4  IF NOT CHAR, ERROR 
          RJ     GOL         GET OPERAND LENGTH 
          PL     X7,ES.LEN6  IF CONSTANT LENGTH 
          SX6    OMI=LEN
  
 ES.LEN4  SA1    X6+F.INTF
          SA2    FUNCALL     FORCE CALL-BY-NAME 
          SA6    /CF/IT 
          EQ     ABEF        GO TREAT AS EXTERNAL ... 
  
 ES.LEN6  BX6    X7          RESULT VALUE = LENGTH OF CONSTANT STRING 
          =X7    M.INT
          EQ     ES.MSK8
 ES.LXX   SPACE  4,8
**        ES.XXX - TRANSFORM LGE(C1,C2) ETC. INTO C1.LGE.C2  .
  
 LGE      ESINL 
          SA4    B6-2 
          SA3    LGEOP
  
 LXX10    BX7    X3 
          SA7    SOPR 
          =B6    B6-1        EAT FUNCTION NAME
          RJ     ADT
          =X2    -1 
          EQ     EXIT.
  
 LGT      ESINL 
          SA3    LLTOP
  
*         INVERT OPERANDS FOR INVERTED OPERATOR.
  
 LXX20    BX4    X5 
          SA5    B6-2 
          EQ     LXX10
  
 LLE      ESINL 
          SA3    LGEOP
          EQ     LXX20
  
 LLT      ESINL 
          SA4    B6-2 
          SA3    LLTOP
          EQ     LXX10
 ES.MSK   SPACE  4,10 
**        ES.MSK - ATTEMPT REDUCTION OF 'MASK'. 
  
  
 MASK     ESINL 
          BX1    X5 
          CALL   LCH         LOAD CONSTANT TEST 
          SX2    V=MASK 
          MI     B2,ES.MSK9  IF LONG CONSTANT 
          NE     B2,B1,ESF9  IF NOT SHORT INTEGER CONSTANT
          ZR     X6,ES.MSK5  IF MASK(-0)
          MI     X6,ES.MSK9  IF NEGATIVE ARG. 
  
 ES.MSK5  SX1    X6-61
          PL     X1,ES.MSK9  IF ARG GT 60 
          MX1    1
          SB7    X6-1 
          =X7    M.BOOL      SET MODE OF NEW CONSTANT 
          AX6    B7,X1
          BX1    X6 
          AX1    59 
          BX6    X1*X6
 ES.MSK8  SB6    B6-B1       DECREMENT STACK FOR FUNCTION NAME
          CALL   NCS         ENTER NEW CONSTANT 
          =X2    -1          INDICATE REDUCED 
          =A6    B6-1        REPLACE *MASK(CON)* WITH CON 
          EQ     EXIT.
  
 ES.MSK9  WARN   E.INF1 
          EQ     ESF9 
 ES.SHF   SPACE  4,10 
**        ES.SHF - ATTEMPT REDUCTION OF 'SHIFT'.
  
  
 SHIFT    ESINL 
          BX1    X5 
          CALL   LCH         LOAD CONSTANT TEST 
          SX2    V=SHIFT
          MI     B2,ES.SHF5  IF LONG CONSTANT 
          NE     B2,B1,ESF9  IF NOT SHORT INTEGER CONSTANT
          BX2    X6 
          AX2    59 
          BX2    X2-X6
          SX2    X2-61
          PL     X2,ES.SHF5  IF ABS(ARG) .GT. 60
          SB7    X6-60
          SX2    V=SHIFT
          ZR     X6,ES.SHF4  IF NULL SHIFT (0)
          ZR     B7,ES.SHF4  IF NULL SHIFT (60) 
          EQ     ESF9        EXIT, NOT REDUCED
  
 ES.SHF4  SA1    B6-2        SHIFT VALUE ARGUMENT 
          =X2    -1          INDICATE REDUCTION 
          SB6    A1          RESET ESTACK POINTER 
          MX0    -TP.MODEL
          BX6    X0*X1       CLEAR SHIFT VALUE MODE 
          =X1    M.BOOL 
          BX6    X6+X1       RESULT MODE IS BOOLEAN 
          SA6    A1-1        REPLACE SHIFT WITH VALUE OPERAND 
          EQ     EXIT.
  
 ES.SHF5  WARN   E.INF2      SHIFT ARG OUT OF RANGE 
          SX2    V=SHIFT
          EQ     ESF9 
 ES.LOC   SPACE  4,10 
**        ES.LOC - EVALUATE 'LOCF' INTRINSIC. 
* 
*         IF THE ARGUMENT IS TYPE CHARACTER, EMIT LIBRARY CALL. 
*         IF NOT, THE FUNCTION IS ELIMINATED. 
*         RESULT IS THE OPERAND, WITH (TP.ADDR) SET.
  
  
 LOCF     ESINL 
          RJ     DOA         DETERMINE OPERAND ADDRESSIBILITY 
          ZR     X6,ES.LOC2  IF OPERAND OKAY
          FATAL  E.INF
  
 ES.LOC2  SB7    X0-M.CHAR
          CLAS=  X6,WB,LOCF 
          BX6    X6+X2       LOCF[WB(ARG)] = 1
          SA6    A2 
          SX6    OMI=LCF
          ZR     B7,ES.LEN4  IF CHARACTER ARGUMENT, DO IT EXTERNAL
          CLAS=  X0,TP,(ADDR,LCF,EXPR)
          MX2    -TP.MODEL
          LX2    TP.MODEP 
          BX5    X2*X5       SET RESULT MODE = M.BOOL 
 .MODE    IFNE   M.BOOL,0 
          =X2    M.BOOL 
          LX2    TP.MODEP 
          BX5    X5+X2
 .MODE    ENDIF 
          BX6    X5+X0
          =X2    -1 
          =B6    B6-1        REPLACE LOCF(ARG) WITH ADDR(ARG) 
          =A6    B6-1 
          EQ     EXIT.
 ES.RAN   SPACE  4,10 
**        ES.RAN - GENERATE 'RANF' REFERENCE. 
* 
*         INVENT OPERAND (RANDOM.), AND PUT IT'S NAME IN SYMTAB.
  
  
 RANF     ESINL 
          TAGSEX S.RANDOM    TAG SYSTEM EXTERNAL
          SA3    RANOP
          BX4    X6          (1OP) = SYMORD (RANDOM.) 
          LX6    X3 
          BX5    X4          (2OP) = (1OP)
          SB6    B6+B1       COMPENSATE FOR ADT STACK DECREMENT 
 .T       IFEQ   TEST,ON
          SA2    SMOD 
          SX7    X2-M.REAL
          NZ     X7,"BLOWUP" IF (SMOD) INCORRECT
 .T       ENDIF 
          SA6    SOPR 
          RJ     ADT
          =X2    -1 
          EQ     EXIT.
  
 S.RANDOM =XLIB  RANDOM 
 IAC      SPACE  4,10 
**        IAC - INCREMENT ARG COUNT.
* 
*         THIS WOULD PERHAPS NOT NEED TO BE A SUBROUTINE, EXCEPT
*         FOR THE NECESSITY TO DO PART-WORD SIGNED ARITHMETIC.
*         ON ENTRY, (AC.CNT) MAY BE = -1, IF THERE WERE ZERO
*         ACTUAL ARGUMENTS. 
* 
*         ENTRY  (SCR+AC.W) = ARGCOMA.
* 
*         EXIT   (X7) = FINAL ARGUMENT COUNT. 
*                (CF/AC) = (X7).
*                ARGCOMA UPDATED, (AC.CNT) = (X7).
*                (A2, X2) = UPDATED ARGCOMA.
* 
*         USES   X0,X3,X6,X7  A7
  
  
 IAC      SUBR   0           ENTRY/EXIT.. 
          SA2    SCR+AC.W 
          LX2    -AC.CNTP 
          MX0    -AC.CNTL 
          SX7    X2+B1
          ERRNZ  18-AC.CNTL 
          BX3    X0*X2       CLEAR PREVIOUS ARG COUNT 
          IX6    X3+X7       MERGE INCREMENTED COUNT
          SA7    /CF/AC 
          LX6    AC.CNTP
          BX2    X6 
          SA6    A2 
          EQ     EXIT.
 MAD      SPACE  4,10 
**        MAD - MARK ARGUMENT DEFINED.
* 
*         WHEN AN ACTUAL ARGUMENT IS ADDRESSABLE, IT MAY BE REDEFINED BY
*         THE CALLED ROUTINE.  *MAD* SETS (WB.DEF) FOR SUCH ARGUMENTS,
*         UNLESS THEY ARE (WB.NVAR).
* 
*         ENTRY  (X5) = OPERAND TO BE MARKED. 
* 
*         EXIT   (X7, A7) = SYMTAB ENTRY FOR OPERAND. 
* 
*         USES   ...
  
  
 MAD      SUBR   0           ENTRY/EXIT...
          RJ     DOA         DETERMINE OPERAND ADDRESSIBILITY 
          NZ     X6,EXIT.    IF NOT CALL-BY-REFERENCE ARGUMENT
          CLAS=  X3,WB,(DEF)
          BX7    X3+X2
 .T       IFEQ   TEST,ON
          HX2    WB.NVAR
          BX3    X1-X2
          PL     X3,"BLOWUP" IF (VAR .EQV. NVAR)
 .T       ENDIF 
          PL     X1,EXIT.    IF ARG IS NOT KNOWN AS VARIABLE
          SA7    A2 
          EQ     EXIT.
 SSA      SPACE  4,20 
**        SSA -  STACK SUBPROGRAM ARGUMENT. 
* 
*         NOTE EXTREMELY DIRTY KLUDGE FOR STATEMENT LABEL PARAMETER --
*         PAR.MULT SET IT'S MODE = 7, SO WE COULD RECOGNIZE IT. 
* 
*         ENTRY  (X5) = OPERAND FOR THIS ARGUMENT.
  
  
 SSA      SUBR   0           ENTRY/EXIT...
          MX0    -TP.MODEL
          LX0    TP.MODEP 
          BX2    -X0*X5      (X2) = MODE OF ARG 
          BX1    X0+X2
          ERRNZ  7-N.TYPE 
          ERRNZ  TP.MODEL-3 
          =B6    B6-1        REMOVE ARG FROM ESTACK 
          ZR     X1,SSA2     IF MODE = ALL BITS, ARG IS LABEL 
          BX6    X5 
          ADDWD  T.ARG
          RJ     MAD         MARK ARGUMENT DEFINED
          EQ     EXIT.
  
 SSA2     BX6    X0*X5       REMOVE WEIRD MODE
          ADDWD  T.SLARG
          EQ     EXIT.
 TXI      SPACE  4,10 
**        TXI - TAG EXTERNAL INTRINSIC. 
* 
*         ENTRY  (X1) = INTRINSIC TABLE ENTRY.
*                (X2) = CALLING SEQUENCE (SEE FUNI MACRO).
*                (/CF/IT) = INTRINSIC TABLE INDEX.
* 
*         EXIT   (/CF/TP) = ROUTINE TAG (OPERAND).
*                (/CF/IE) = INTRINSIC TABLE ENTRY.
*                (SMOD) = RESULT MODE OF FUNCTION.
*                NAME ENTERED IN SYMTAB.
* 
*         IF TRACEBACK IS NOT SELECTED, SUBSTITUTE THE CALL-BY-VALUE
*         FUNCTION NAME.
  
  
 TXI      SUBR   0           ENTRY/EXIT...
          SA3    X2 
          BX7    X1          (CF/IE) = TABLE ENTRY
          MX0    IT.DPCL
          HX1    IT.DPC 
          BX6    X3          (CF/APL) = APLIST OPERATOR 
          UX2,B2             (B2) = FUNCTION TYPE FOR (WC.FUNT) 
          SA7    /CF/IE 
          BX4    X0*X1       EXTRACT (X4) = SPECIFIC NAME 
          SA6    /CF/APL
          LX2    30 
          SA3    X2 
          SX5    B2 
          BX7    X3          (CF/RJ) = FUNCTION CALL OPERATOR 
          UX2,B7             (B7) = SUFFIX CHARACTER
          MX0    -6 
          SA7    /CF/RJ 
          SB2    IT.DPCP
 TXI2     LX6    X0,B2       POSITION CHARACTER MASK
          BX2    -X6*X4 
          SB2    B2+6 
          ZR     X2,TXI2     IF NO SIGNIFICANT CHARACTER YET
          SB2    B2-2*6 
          SA3    WO.CS       COLLATE FIXED/USER FLAG
          =X0    1
          BX3    X0-X3       FIXED = 1, USER = ZERO 
          LX3    IT.CHARP 
          BX0    X3*X1
          ZR     X0,TXI1     IF NOT COLLATE = FIXED AND CHAR OR ICHAR RE
          SB7    B7+0600B    2RF: 
          SB2    B2-6 
  
 TXI1     SX2    B7 
          LX2    B2          MOVE SUFFIX TO LAST EMPTY CHAR SLOT
          BX1    X2+X4       APPEND SUFFIX TO NAME
          TAGSEX A1          TAG SYSTEM EXTERNAL
          CLAS=  X1,WB,(NVAR,EXT,CGS,FUN,DEF) 
          SA6    /CF/TP 
          SA3    /CF/IT 
          BX7    X1+X2       MERGE FUNC ATTRIBUTES ONTO NEW SYMBOL (WB) 
          SA4    /CF/IE 
          MX6    -IT.MODEL
          LX3    WB.JPFP
          BX7    X7+X3       SET (WB.JPF) = INTRINSIC TABLE INDEX 
          LX4    -IT.MODEP
          BX6    -X6*X4 
          SA6    SMOD        SET (SMOD) = RESULT MODE 
          LX6    WB.MODEP 
          BX7    X7+X6       SET (WB.MODE) = RESULT MODE
          ERRMI  IT.MODEL-WB.MODEL
          SA7    A2          UPDATE SYMTAB (WB) 
  
          SB2    X5-MF.BEF
          LX5    WC.FUNTP-WC.BRPP 
          MX1    -IT.JPADL
          BX6    0           CLEN = 0 
          LX4    IT.MODEP-IT.JPADP
          NZ     B2,TXI6     IF NOT A CALL-BY-VALUE FUNC
          BX2    -X1*X4      EXTRACT (X2) = B-REGISTERS PRESERVED 
          BX5    X2+X5
 TXI6     LX5    WC.BRPP     (X5) = SYMTAB (WC.)[FUNT, BRP] 
          SA3    SMOD 
          SB2    X3-M.CHAR
          NZ     B2,TXI7     IF RESULT MODE NOT CHARACTER 
          SX6    B1          CLEN = 1 
          LX6    WC.CLENP 
  
 TXI7     BX6    X5+X6
          =A6    A2-WB.W+WC.W 
          EQ     EXIT.
 VAM      SPACE  4,10 
**        VAM -  VALIDATE ARGUMENT MODE AGREEMENT FOR INTRINSICS. 
* 
*         ENTRY  (X5) = ARGUMENT TO CHECK.
*                (A2,X2) = LOGICAL (ARGCOMA). 
*                (A2)-AC.W+AS.W -> LOGICAL (ARGMIS).
* 
*         EXIT   (X7) = MODE OF ARGUMENT. 
*                (A2) -> LOGICAL (ARGCOMA) UPDATED IF FIRST ARG.
*                (FILL.) = FUNCTION NAME. 
* 
*         USES   A3,6   X0-3,X6-7   B7. 
  
  
 VAM      SUBR               ENTRY/EXIT...
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX3    -X0*X5      EXTRACT ARGUMENT MODE
          LX5    TP.MODEP 
          CLAS=  X6,AC,(BOOL) 
          NZ     X3,VAM0     IF ARGUMENT NOT BOOLEAN
          ERRNZ  M.BOOL 
          BX2    X6+X2       INDICATE BOOLEAN ARGUMENT
  
 VAM0     LX2    -AC.MAXMP
          BX6    -X0*X2      EXTRACT MAXIMUM ARGUMENT 
          BX2    X0*X2       CLEAR MAXIMUM ARGUMENT 
          MX0    X6+X3
          BX6    X2+X0       INSERT MAXIMUM MODE [THUS FAR] 
          LX6    AC.MAXMP 
          SA6    A2          UPDATE ARGCOMA 
          BX2    X6 
          SA3    T.SYM
          SB7    X3+WB.W
          =A3    A2-AC.W+AS.W 
          MX7    -AS.ORDL 
          BX6    X3 
          LX6    -AS.ORDP 
          BX7    -X7*X6      ORD[ARGMIS] = TAG(FUNCTION)
          LX6    B1,X7
          IX1    X6+X7
          MX7    AS.SYML
          HX3    AS.SYM 
          BX6    X7*X3       SET (FILL.) = FUNCTION NAME
          LX2    -AC.CNTP 
          SA6    FILL.
          SA3    B7+X1       WB(FUNCTION) 
          HX3    WB.GENF
          BX1    X5 
          LX1    -TP.MODEP
          MX0    -TP.MODEL
          BX7    -X0*X1      MODE OF ARGUMENT 
          MI     X3,VAM1     IF GENERIC FUNCTION
          MX0    -WB.JPFL 
          LX3    WB.GENFP+1-WB.JPFP 
          BX0    -X0*X3 
          SA3    F.INTF+X0
          MX0    -IT.ARGML
          LX3    -IT.ARGMP
          BX3    -X0*X3      ARGM[INTF(JPF[WB(FUNCTION)])]  REQUIRED MOD
          ZR     X3,VAM10    IF ARGM = M.BOOL 
          ERRNZ  M.BOOL 
  
 VAM1     SB7    X2 
          ERRNZ  18-AC.CNTL 
          GT     B7,B1,VAM2  IF NOT FIRST ARG 
          LX2    AC.CNTP-AC.MODEP 
          BX6    X7+X2       SET (AC.MODE) = MODE OF FIRST ARG
          LX6    AC.MODEP 
          SA6    A2 
          EQ     EXIT.
  
 VAM2     LX2    AC.CNTP-AC.MODEP 
          SX2    X2          (X2) = REQUIRED MODE OF ARG
          ERRNZ  18-AC.MODEL
          BX0    X7-X2
          ZR     X0,EXIT.    IF MODE AGREEMENT
          =X0    0
          ZR     X2,VAM10    IF REQUIRED MODE TYPELESS
          NZ     X7,VAM4     IF ACTUAL ARG NOT BOOLEAN
          SX2    X2-M.CHAR
          NZ     X2,EXIT.    IF DEFINED MODE NOT CHARACTER
  
 VAM4     FATAL  E.SU03      WRONG ARGUMENT MODE
          SX7    M.BOOL      MODE BITS = BOOLEAN
          EQ     EXIT.
  
 VAM10    SX0    X7-M.CHAR
          ZR     X0,VAM4     IF THIS ARGUMENT MODE IS CHARACTER 
          EQ     EXIT.
 VEL      SPACE  4,20 
**        VEL -  VALIDATE ARGUMENT LIST FOR EXTERNAL. 
* 
*         ENTRY  (X7) = NUMBER OF ARGUMENTS.
*                (X4) = CURRENT ROUTINE TAG.
* 
*         EXIT   IF 1ST REFERENCE,
** FV - RE-WRITE THIS MESS. 
*                   SYMTAB (WC.ARGC, WB.DEF) SET. 
*                   ARGUMENT COUNT CHECKED AGAINST *MAX.SARG*.
*                IF NOT 1ST REFERENCE,
*                   ARGUMENT COUNT CHECKED AGAINST *MAX.SARG*.
*                   ARGUMENT COUNT CHECKED AGAINST (WC.ARGC). 
*                (CF/APL) = OPERATOR FOR USER AP LIST.
*                (SMOD) = MODE OF ROUTINE.
*                (X3) = PRESERVED.
*                (A4) = ADDRESS OF SYMTAB (WB) OF ROUTINE.
* 
*         USES   X0-4,X6-7    A1-4,A6-7    B2-3,B7. 
*                (FILL.)
*         CALLS  FATAL, FSA.
  
  
 VEL      SUBR   =           ENTRY/EXIT...
          BX6    X4          SET (CF/TP) = OPERAND FOR ROUTINE
          SA3    GAPOP
          MX0    -TP.MODEL
          BX1    X6 
          SA6    /CF/TP 
          BX4    X7          (X4) = NUMBER OF ARGS
          LX6    -TP.MODEP
          BX7    -X0*X6      SET (SMOD) = RESULT MODE 
          LX6    X3          SET (CF/APL) FOR USER ARGLIST
          SA7    SMOD 
          SA6    /CF/APL
          RJ     FSA         FIND SYMBOL ATTRIBUTES 
 .T       IFEQ   TEST,ON
          MI     B7,"BLOWUP"       IF NOT IN SYMTAB 
          MI     X1,"BLOWUP"       IF SYMTAB HAS *VAR* SET
          LX1    WB.VARP-WB.NVARP 
          PL     X1,"BLOWUP"       IF *NVAR* NOT SET
          CLAS=  X1,WB,(FUN,SUB)
          BX1    X1*X2
          ZR     X1,"BLOWUP"       IF NEITHER *FUN* NOR *SUB* 
 .T       ENDIF 
          SX2    X4 
          CLAS=  X0,WB,(DEF)
          SA4    A2          FETCH (X4) = SYMTAB WORD (WB)
          =A1    A2-WB.W+WC.W 
          BX6    X0*X4
          SB2    X2-MAX.SARG
          NZ     X6,VEL30    IF ALREADY DEFINED 
          LX2    WC.ARGCP 
          BX7    X4+X0       SET DEFINED BIT
          IX6    X2+X1       SET ARGUMENT COUNT 
          SB7    E.SU08      TOO MANY ARGUMENTS 
          GT     B2,VEL50    IF NARGS .GT. MAX
          SA6    A1 
          SA7    A4          UPDATE SYMTAB ENTRY (WC + WB)
          EQ     EXIT.
  
  
*         HERE IF NOT 1ST REFERENCE TO EXTERNAL.
*                (X2) = ARGUMENT COUNT. 
  
 VEL30    MX0    -WC.ARGCL
          LX1    -WC.ARGCP
          BX0    -X0*X1      ISOLATE (X1) = PREVIOUS ARGUMENT COUNT 
          SB7    E.SU02      ARGUMENT COUNT INCONSISTENT
          IX6    X0-X2
          NZ     X6,VEL50    IF ARGUMENT COUNT NON-AGREEMENT
          SB7    E.SU08      TOO MANY ARGUMENTS 
          LE     B2,EXIT.    IF DOES NOT EXCEED COMPILER DEFINED LIMITS 
  
*         ARGUMENT COUNT DOES NOT AGREE WITH FIRST USAGE. 
  
  
 VEL50    =A2    A4-WB.W+WA.W      LOAD SYMBOL WORD 
          MX1    WA.SYML
          BX6    X1*X2
          SA6    FILL.
          FATAL  B7 
          EQ     EXIT.
 VIL      SPACE  4,20 
**        VIL - VALIDATE INTRINSIC LIST.
* 
*         CHECKS FOR CORRECT ARGUMENT COUNT:  REQUIRED ARG COUNT MUST BE
*         EXACTLY EQUAL TO ACTUAL ARG COUNT, EXCEPT WHEN -- 
*         (A)  IF FUNCTION PERMITS AN INDEFINITE NUMBER OF ARGUMENTS, 
*                THE ACTUAL COUNT MUST BE >= TWO. 
*         (B)  IF FUNCTION NAME IS 'CMPLX' (WHOSE REQUIRED ARG COUNT IS 
*                SPECIFIED IN PARSKEL/F.INTF AS TWO), THEN ACTUAL COUNT 
*                CAN BE = ONE.  IF SO, CHANGE THE INTRINSIC INDEX TO
*                REFER TO 'CPLX$', WHICH IS ASSUMED TO BE THE IMMEDIA-
*                TELY PRECEEDING ENTRY. 
* 
*         IF THIS INTRINSIC IS MARKED AS GENERIC, VIL IS RESPONSIBLE FOR
*         SELECTING A SPECIFIC FUNCTION BASED ON ACTUAL ARGUMENT MODE.
*         ALL DOWN-STREAM PROCESSORS WORK SOLELY WITH MODE-SPECIFIC 
*         INTRINSICS (EXCEPT 'CMPLX', SEE ESF). 
* 
*         CHECK VALIDITY OF ARGUMENT MODE.  ACTUAL AND REQUIRED MUST
*         MATCH EXACTLY, EXCEPT WHEN -- 
*         (A)  REQUIRED = BOOLEAN.  ACTUAL CAN BE ANYTHING EXECPT 
*                DOUBLE, COMPLEX, OR CHARACTER. 
*         (B)  REQUIRED = INTEGER.  ACTUAL CAN BE BOOLEAN, WHICH IS 
*                TREATED AS AN INTEGER. 
*         (C)  INTRINSIC IS GENERIC.
* 
*         FOR SOME INDEFINITE ARG COUNT INTRINSICS, THE COMPUTATION IS
*         PERFORMED IN THE MODE OF THE ARGUMENTS, AND THEN POST-COERCED 
*         TO THE RESULT MODE.  VIL SEARCHES THE LIST AT (SKEL/F.IMCV) TO
*         DETERMINE IF THIS IS SUCH A FUNCTION.  IF SO, LEAVE (SMOD) SET
*         TO ARGUMENT MODE, AND SET (CF/MA) FLAG. 
* 
*         IF BOOLEAN ARGUMENTS OCCUR, TREAT AS FOLLOWS: 
* 
*              1.  IF INTRINSIC TYPE IS BOOLEAN, ARGUMENTS ARE UNCHANGED. 
* 
*              2.  IF ONLY ONE ARGUMENT [BOOLEAN]:  
*                  A. IF GENERIC INTRINSIC: 
*                     (1) IF INTEGER IS LEGAL, TREAT AS INTEGER [EXCEPT 
*                         INTRINSIC FUNCTIONS DBLE, REAL, CMPLX]. 
*                     (2) OTHERWISE, TREAT AS REAL. 
*                  B. IF SPECIFIC INTRINSIC, TREAT AS REQUIRED MODE.
* 
*              3.  IF MORE THAN ONE ARGUMENT [AT LEAST ONE ARGUMENT IS
*                  BOOLEAN]:  
*                  A. IF GENERIC INTRINSIC: 
*                     (1) IF ALL ARGUMENTS BOOLEAN, TREAT AS INTEGER
*                         [EXCEPT CMPLX]. 
*                     (2) OTHERWISE, CONVERT BOOLEAN ARGUMENTS TO HIGHEST 
*                         ARGUMENT MODE.
*                  B. IF SPECIFIC INTRINSIC, TREAT BOOLEAN ARGUMENTS AS 
*                     REQUIRED MODE.
* 
*         ENTRY  (X5) = OPERAND FOR LAST ARG. 
*                (CF/AC) = NUMBER OF ARGUMENTS IN THIS CALL.
*                (SMOD) = MODE OF ARGUMENTS.
*                (SCR .. SCR+2) = (ARGMODE, ARGCNT, ARGMISC). 
*                (FILL.) = FUNCTION NAME. 
* 
*         EXIT   IF FUNCTION NOT REDUCED -- 
*                (X2) = INTRINSIC TABLE ENTRY OF SPECIFIC NAME. 
*                (CF/IT) = INTRINSIC TABLE INDEX OF SPECIFIC NAME.
*                (CF/MA) .ZR. = NO POST-EVALUATION CONVERSION REQUIRED. 
*                        .NZ. = (F.IMCV) ENTRY FOR THIS FUNCTION. 
*                (SMOD) = MODE FOR ISSUING FUNCTION TURPLES.
*                (AC.MODE) = RESULT MODE. 
* 
*         ELSE   TO *POPX* -- 
*                FUNCTION REDUCED.
*                (ESTACK.TOP) = RESULT OPERAND. 
* 
*         USES   ALL BUT A0, B4,B5,B6.
* 
*         CALLS  CMR, CT1 
  
  
 VIL      SUBR               ENTRY/EXIT...
          SA4    SCR+AS.W 
          BX7    0           (CF/MA) = 0
          LX4    -AS.ORDP 
          SX0    X4          EXTRACT (X0) = SYMORD OF FUNCTION
          ERRNZ  18-AS.ORDL 
          SA7    /CF/MA 
          CALL   CT1         LOAD SYMTAB (WB) 
  
 .T       IFEQ   TEST,ON
          CLAS=  X1,WB,(LAB,VAR)
          BX3    X1*X2
          NZ     X3,"BLOWUP"       IF SYMTAB ENTRY IS ILL 
          BX1    X2 
          HX1    WB.FUN 
          PL     X1,"BLOWUP"       IF SYMTAB ENTRY IS ILL 
 .T       ENDIF 
  
          MX0    -WB.JPFL 
          LX2    -WB.JPFP 
          SA4    A2          REMEMBER (A4,X4) = SYMTAB (WB) 
          BX3    -X0*X2      EXTRACT (X3) = FJ = INTRINSIC TABLE INDEX
          SA1    X3+F.INTF
          SA2    /CF/AC 
          MX7    -IT.ARGCL
          LX1    -IT.ARGCP
          BX0    -X7*X1      EXTRACT (X0) = DEFINED ARGUMENT COUNT
          SB7    E.SU05      WRONG NUMBER OF ARGUMENTS
          SB2    X2 
          BX7    X7+X0
          SA7    VILA 
          NZ     X7,VIL05    IF INFINITE ARG COUNT NOT PERMITTED
          GT     B2,B1,VIL15 IF TWO OR MORE ARGUMENTS 
          SB7    E.SU09      NOT ENOUGH ARGUMENTS 
          EQ     VIL10       OUTPUT ERROR 
  
 VIL05    IX6    X0-X2
          ZR     X6,VIL15    IF ARGUMENT COUNT AGREEMENT
          SX2    B1+B1
          SX7    OMI=CPX
          IX6    X3-X7
          NZ     X6,VIL10    IF FUNCTION NAME NOT 'CMPLX' 
          IX3    X3-X2       FJ = FJ - 2
          EQ     B2,B1,VIL15 IF ACTUAL COUNT .EQ. 1 
  
*         ARGUMENT COUNT DOES NOT AGREE WITH ANSI SPEC. 
  
 VIL10    FATAL  B7 
          SA2    F.INTF      SUBSTITUTE ERROR INTRINSIC 
          BX7    0
          SA7    /CF/IT 
          EQ     EXIT.
  
*         SELECT SPECIFIC NAME, IF GENERIC. 
*                (X3) = FJ = INTRINSIC TABLE INDEX. 
*                (X4) = SYMTAB (WB).
  
 VIL15    BSS 
  
 .T       IFEQ   TEST,ON
          SX6    Z.INTF 
          IX6    X3-X6
          PL     X6,"BLOWUP"       IF FJ .GE. INTRIN TABLE LENGTH 
 .T       ENDIF 
  
          SA1    SCR+AC.W 
          HX1    AC.BOOL
          PL     X1,VIL60    IF NO BOOLEAN ARGUMENTS
          SA2    X3+F.INTF
          MX0    -IT.ARGML
          LX2    -IT.ARGMP
          BX2    -X0*X2      EXTRACT REQUIRED ARGUMENT MODE 
          ZR     X2,VIL60    IF BOOLEAN 
          ERRNZ  M.BOOL 
          LX1    AC.BOOLL+AC.BOOLP
          LX1    -AC.CNTP 
          SB2    X1          EXTRACT ARGUMENT COUNT 
          LX1    AC.CNTP-AC.MAXMP 
          SX5    X1          EXTRACT MAXIMUM MODE 
          ERRNZ  18-AC.MAXML
          NE     B2,B1,VIL21 IF MORE THAN ONE ARGUMENT
  
*         FIRST TEST FOR GENERIC FUNCTION, IF SO CONVERT APPROPRIATLY.
  
          LX1    X4 
          SBIT   X1,WB.GENFP
          PL     X1,VIL19    IF NOT GENERIC 
          SA1    FILL.       SAVED FUNCTION NAME
          SA2    =4LREAL
          IX2    X1-X2
          ZR     X2,VIL16    IF INTRINSIC REAL
          SA2    =4LDBLE
          IX2    X1-X2
          ZR     X2,VIL16    IF INTRINSIC DBLE
          SA2    =5LCMPLX 
          IX2    X1-X2
          NZ     X2,VIL17    IF NOT INTRINSIC CMPLX 
  
 VIL16    SA1    B6-1        FETCH ARGUMENT 
          SX6    M.REAL 
          EQ     VIL20
  
 VIL17    SA1    X3+1+F.INTF  GENERIC SELECTION VECTOR
          SB7    M.INT*8     SHIFT FOR INTEGER
          SX6    M.REAL 
          MX0    -8 
          BX0    -X0*X1      VECTOR FOR INTEGER 
          SA1    B6-1        FETCH ARGUMENT 
          SX0    X0-1S8+1 
          ZR     X0,VIL20    IF INTEGER NOT ALLOWED [TREAT AS REAL] 
          SX6    M.INT
          EQ     VIL20
  
*         ONE ARGUMENT, CONVERT TO REQUIRED MODE (NOT GENERIC)
  
 VIL19    =A1    B6-1        FETCH ARGUMENT 
          BX6    X2          REQUIRED MODE
          SX2    X2-M.DBL 
          MI     X2,VIL20    IF NOT DBL OR CMPLX
          LX5    X1          OPERAND
          RJ     CMR         COERCE MODE TO REQUIRED
          SA1    SCR+AS.W 
          LX1    -AS.ORDP 
          SX0    X1          EXTRACT INTRINSIC SYMTAB ORDINAL 
          ERRNZ  18-AS.ORDL 
          CALL   CT1         LOAD SYMTAB WB.
          SA4    A2          RESTORE (A4, X4) TO WB. OF INTRINSIC 
          =A1    B6-1        REFETCH ORIGINAL ARGUMENT
          MX6    -TP.MODEL
          LX5    -TP.MODEP
          BX6    -X6*X5      EXTRACT MODE 
  
 VIL20    BX7    X1+X6       MERGE IN PROPER MODE 
          ERRNZ  M.BOOL 
          SA7    A1+         UPDATE 
          LX5    X7          RESTORE ARGUMENT 
          SA1    SCR+AC.W 
          LX6    AC.MODEP 
          BX6    X1+X6       MERGE IN CONVERTED MODE
          ERRNZ  M.BOOL 
          SA6    A1+         UPDATE 
          EQ     VIL60
  
*         TWO OR MORE ARGUMENTS, CONVERT TO INTEGER OR MAXIMUM MODE 
*         (B2) = NUMBER OF ARGUMENTS
*         (X2) = REQUIRE MODE 
*         (X4) = SYMTAB WB. 
*         (X5) = MAXIMUM MODE 
  
 VIL21    SB3    X5-M.CHAR
          ZR     B3,VIL60    IF MAXMODE = CHAR, ERROR 
          SB3    X5-M.LOG 
          ZR     B3,VIL60    IF MAXMODE = LOGICAL, ERROR
          LX0    X2          PRESERVE REQUIRED MODE 
          SA1    FILL.
          SA2    =5LCMPLX 
          IX1    X1-X2
          BX2    X0          RESTORE REQUIRED MODE
          NZ     X1,VIL21.1  IF NOT INTRINSIC COMPLEX 
          SX5    M.REAL      BOOLEAN ARGUMENTS TREATED AS REAL
          EQ     VIL22
  
 VIL21.1  NZ     X5,VIL22    IF MAXMODE " BOOLEAN 
          =X5    M.INT
          BX1    X4 
          SBIT   X1,WB.GENFP
          MI     X1,VIL22    IF GENERIC FUNCTION
          BX5    X2          SET TO REQUIRED MODE 
  
 VIL22    SB3    X5-M.DBL 
          PL     B3,VIL30    IF MODE DOUBLE OR COMPLEX, EXPLICIT CONVERT
          =B3    B6-1        INITIAL FETCH REGISTER 
          MX0    -TP.MODEL
  
 VIL23    SA1    B3          FETCH NEXT ARGUMENT
          BX2    -X0*X1      EXTRACT ARGUMENT MODE
          NZ     X2,VIL24    IF ARGUMENT NOT BOOLEAN
          BX6    X1+X5       CONVERT TO PROPER MODE 
          ERRNZ  M.BOOL 
          SA6    A1          UPDATE 
  
 VIL24    SB2    B2-1 
          ZR     B2,VIL25    IF ALL ARGUMENTS PROCESSED 
          SB3    B3-1 
          EQ     VIL23       CONTINUE PROCESSING
  
 VIL25    SA1    SCR+AC.W 
          MX0    -AC.MODEL
          LX0    AC.MODEP 
          BX0    -X0*X1      EXTRACT MODE 
          NZ     X0,VIL60    IF MODE NOT BOOLEAN
          ERRNZ  M.BOOL 
          LX5    AC.MODEP 
          BX6    X1+X5       MERGE IN CONVERTED MODE
          SA6    A1          UPDATE 
          SA5    B6-1        RESTORE LAST ARGUMENT
          EQ     VIL60
  
*         DOUBLE/COMPLEX CONVERSION 
  
 VIL30    SB3    B6-1        INITIAL FETCH REGISTER 
  
 VIL31    SA1    B3+         FETCH NEXT ARGUMENT
          MX0    -TP.MODEL
          BX2    -X0*X1      EXTRACT ARGUMENT MODE
          NZ     X2,VIL32    IF ARGUMENT NOT BOOLEAN
          ERRNZ  M.BOOL 
          SX6    X5 
          LX6    18 
          SX5    B3 
          BX6    X6+X5
          LX6    18 
          SX5    B2 
          BX6    X6+X5
          SA6    VILB        SAVE (X5), (B3), (B2)
          AX6    18+18       COERSION MODE
          LX5    X1          OPERAND
          RJ     CMR         COERSE BOOLEAN OPERAND 
          SA1    VILB 
          SB2    X1          RESTORE (B2) 
          AX1    18 
          SB3    X1          RESTORE (B3) 
          AX1    18 
          BX6    X5 
          SA6    B3          UPDATE WITH THE COERCED OPERAND
          LX5    X1          RESTORE (X5) 
  
 VIL32    SB2    B2-1 
          ZR     B2,VIL33    IF ALL ARGUMENTS PROCESSED 
          SB3    B3-1 
          EQ     VIL31       CONTINUE PROCESSING
  
 VIL33    SA1    SCR+AS.W 
          LX1    -AS.ORDP 
          SX0    X1          EXTRACT INTRINSIC SYMTAB ORDINAL 
          ERRNZ  18-AS.ORDL 
          CALL   CT1         LOAD SYMTAB (WB) 
          SA4    A2          RESTORE (A4, X4) TO WB. OF INTRINSIC 
          MX0    -WB.JPFL 
          LX4    -WB.JPFP 
          BX3    -X0*X4      RESTORE X3 TO INTRINSIC TABLE INDEX
          LX4    WB.JPFP
          SA1    SCR+AC.W 
          MX0    -AC.MODEL
          LX0    AC.MODEP 
          BX0    -X0*X1      EXTRACT MODE 
          NZ     X0,VIL35    IF MODE NOT BOOLEAN
          ERRNZ  M.BOOL 
          LX5    AC.MODEP 
          BX6    X1+X5       MERGE IN CONVERTED MODE
          SA6    A1+         UPDATE 
  
 VIL35    SA5    B6-1        RESTORE LAST ARGUMENT
  
 VIL60    SA1    SCR+AC.W 
          LX1    -AC.MODEP
          SX7    X1          (X7) = ACTUAL MODE OF ARGS 
          ERRNZ  18-AC.MODEL
          HX4    WB.GENF
          PL     X4,VIL70    IF NOT GENERIC FUNCTION
          LX7    3
          SB7    X7          (B7) = 8 * ARGUMENT MODE 
          LX7    -3 
          SA2    X3+1+F.INTF       FETCH SELECTION VECTOR FOR GENERIC 
          MX0    -8 
          AX2    B7 
          BX3    -X0*X2      EXTRACT (X3) = NEW FJ
          NZ     X3,VIL66    IF NOT NULL CONVERSION 
          SA2    A2-B1       FETCH INTRINSIC ENTRY OF THE GENERIC NAME
          MX0    -IT.MODEL
          LX2    -IT.MODEP
          LX5    -TP.MODEP
          BX3    -X0*X2      (X3) = RESULT MODE OF GENERIC
          IFNE   IT.MODEL,TP.MODEL,1
          MX0    -TP.MODEL
          BX1    X0*X5
          BX7    X1+X3       RESULT OPERAND = ORIGINAL WITH NEW MODE
          CLAS=  X3,TP,(EXPR) 
          LX7    TP.MODEP 
          BX6    X7+X3
          SB6    B6-1        EAT FUNCTION NAME
          LX5    X6          STACK AND RETURN RESULT
          SA6    B6-B1
          EQ     POPX        EXIT.. 
  
 VIL66    SB2    X3-1S8+1 
          SB7    E.SU07      INVALID ARGUMENT MODE
          ZR     B2,VIL10    IF MODE NOT PROVIDED 
  
*         CHECK IF MODE OF ARG LIST AGREES. 
*                (X1) = (SCR+AC.W) WITH (AC.MODE) SHIFTED TO BOTTOM.
*                (X3) = FJ = INTRINSIC TABLE INDEX. 
*                (X7) = (AC.MODE) = ACTUAL MODE OF ARGS.
  
 VIL70    SA2    X3+F.INTF
          BX6    X3 
          MX0    -IT.ARGML
          SA6    /CF/IT      RETURN (CF/IT) = INTRINSIC TABLE INDEX 
          LX2    -IT.ARGMP
          BX6    -X0*X2      (X6) = REQUIRED ARGUMENT MODE
          LX2    IT.ARGMP-IT.MODEP
          IFNE   IT.ARGML,IT.MODEL,1
          MX0    -IT.MODEL
          MI     X4,VIL78    IF GENERIC INTRINSIC 
          SB7    E.SU03      WRONG ARGUMENT MODE
          BX3    X6-X7
          ZR     X3,VIL78    IF ACTUAL .EQ. REQUIRED
          =X6    X6-M.BOOL
          NZ     X6,VIL74    IF REQUIRED MODE NOT BOOL
          SX3    X7-M.CHAR
          NZ     X3,VIL78    IF ACTUAL MODE NOT CHARACTER 
          EQ     VIL10
  
 VIL74    NZ     X7,VIL10    IF ACTUAL MODE NOT BOOLEAN 
          =X6    X6+M.BOOL-M.INT
          NZ     X6,VIL10    IF REQUIRED MODE NOT BOOL/INT AND ACTUAL IS
  
 VIL78    BX7    X1-X7       CLEAR PREVIOUS (AC.MODE) 
          SA3    VILA 
          BX6    -X0*X2 
          BX7    X6+X7       SET (AC.MODE) = RESULT MODE
          LX7    AC.MODEP 
          LX2    IT.MODEP    RETURN (X2) = INTRINSIC TABLE ENTRY
          SA7    A1 
          NZ     X3,VIL84    IF INDEFINITE ARG COUNT NOT PERMITTED
          SA1    /CF/IT      (X1) = INDEX OF THIS INTRINSIC 
          SA3    F.IMCV 
          SB7    Z.IMCV 
          SB2    2*18 
  
 VIL82    AX7    X3,B2
          IX0    X7-X1
          ZR     X0,VIL86    IF FUNCTION REQUIRES POST-COERCION 
          SB7    B7-B1
          SA3    A3+B1
          PL     B7,VIL82    IF MORE TO CHECK 
  
 VIL84    SA6    SMOD 
          EQ     EXIT.
  
 VIL86    BX6    X3          INDICATE POST-EVALUATION COERCION REQUIRED 
          SA6    /CF/MA 
          EQ     EXIT.
          TITLE  POP/EMIT ARRAY SUBSCRIPTS. 
**        POP/EMIT ARRAY SUBSCRIPTS.
  
  
          QUAL   AR 
 BIAS     BSS    1           CONSTANT SUBSCRIPT BIAS ACCUMULATOR
 DIMI     BSS    1           INDEX OF ARRAY IN T.DIM
 NSUB     BSS    1           COUNT OF SUBSCRIPTS (IN ARRAY REF) 
 VDSK     BSS    1           SKELETON  *VD.*  OPERAND 
          QUAL   *
  
 S.CES    =XLIB  CES         DEFINE NAME OF RUN-TIME SUBSCRIPT FUNCTION 
 INTLCT   SPACE  4,10 
**        INTLCT  - CALL *LCT*, INTEGER/BOOLEAN RESULT EXPECTED.
* 
*         CALLS *LCT*.  IN TEST MODE ONLY, ABORTS IF THE OPERAND MODE 
*         IS NOT INTEGER OR BOOLEAN  ( *SSR* BUG ). 
* 
* 
*         INTLCT    (NO PARAMETERS.)
* 
*         ENTRY/EXIT -- SEE *LCT*.
* 
*         USES   X2.    A2.    B7.
* 
*         CALLS  LCT. 
  
  
 INTLCT   MACRO 
          CALL   LCT
 .T       IFEQ   TEST,ON
          SA2    ="BOOLINT" 
          SB7    X0          MODE 
          LX2    B7 
          PL     X2,"BLOWUP" IF RESULT NOT INTEGER OR BOOLEAN 
 .T       ENDIF 
 INTLCT   ENDM
 SUBERR   SPACE  4,10 
**        SUBERR - ISSUE SUBSCRIPT ERROR MESSAGE. 
* 
*         SUBERR ERRADDR
* 
*         ERRADDR = ERROR SKELETON ADDRESS (B7).
  
  
 SUBERR   MACRO  ERRADDR
          =B7    ERRADDR
          CALL   OSE
 SUBERR   ENDM
 ARYMIC   SPACE  4,10 
**        MICROS USED THROUGHOUT SUBSCRIPT PROCESSOR. 
  
  
 ALLNUM   BITMIC (M.BOOL,M.INT,M.REAL,M.DBL,M.CPLX) 
 BOOLINT  BITMIC (M.BOOL,M.INT) 
 CPLX     DECMIC M.CPLX 
 DBL      DECMIC M.DBL
  
 WD2MASK  =      1S"DBL"+1S"CPLX" 
 C=ARRAY  SPACE  4,20 
**        C=ARRAY -  RESET DIMENSION MULTIPLIER FOR SUBSCRIPT OPERATION.
* 
* 
*         ENTRY  (X5) = CURRENT SUBSCRIPT EXPRESSION RESULT.
* 
*         EXIT   (B4) UPDATED BY 1. 
* 
*         USES   X4,X6.    A4,A6.    B4.
* 
*         CALLS  SSR. 
  
  
 C=ARRAY  BSS    0
          SA1    ARGMIS 
          =A4    A1+AC.W-AS.W      *ARGCOMA*
          BX6    X1 
          SA6    SCR+AS.W    POP ARRAY NAME EARLY FOR *FERRS* 
          RJ     SSR         STANDARDIZE SUBSCRIPT RESULT 
          BX6    X4 
          =B4    B4+1        (B4) = ADVANCE TO NEXT TOKEN 
          SA6    ARGCOMA
          EQ     PAR.NX      CONTINUE ... 
 A=ARRAY  SPACE  4,20 
**        A=ARRAY - PROCESS CLOSING PAREN FOR CURRENT SUBSCRIPT.
* 
*         POP HOLDING STACK FOR SUBSCRIPT.
* 
*         ENTRY  (X2) = (ARGCOMA) = (SCR+1).
*                (X5) = RESULT FOR LAST SUBSCRIPT IN THIS REFERENCE.
* 
*         USES   ALL BUT    A0, B4. 
* 
*         CALLS  ADU/ADT, ASE, EMIT(EMT), GDI, MFP, MSP, NCS, 
*                SLB, SSR, SUBERR(OSE), TAGSEX(TSX).
  
  
 A=ARRAY  BSS    0           ENTRY... 
          =X0    1
          LX0    AC.CNTP
          IX4    X2+X0       INCREMENT COUNT OF SUBSCRIPTS
          RJ     SSR         STANDARDIZE LAST SUBSCRIPT 
          BX6    0
          SA6    /AR/BIAS    INITIALIZE SUBSCRIPT BIAS = 0
  
*         CHECK THAT SUBSCRIPT COUNT MATCHES DIMENSION COUNT. 
  
          LX4    -AC.CNTP 
          SB2    X4          (B2) = COUNT OF SUBSCRIPTS 
          ERRNZ  AC.CNTL-18 
          LX4    AC.CNTP
          RJ     GDI         GET DIMENSION INFORMATION
          EQ     B2,B3,A=AR8 IF SUBSCRIPT COUNT .EQ. DIMENSION COUNT
          SUBERR E.SB7       ISSUE MSG *SUBSCRIPT/DIMEN COUNT MISMATCH* 
          GT     B2,B3,A=AR6 IF SUBSCRIPT COUNT .GT. DIMENSION COUNT
  
*         HERE IF SUBSCRIPT COUNT .LT. DIMENSION COUNT
  
          SA2    CONONE 
          LX7    X2 
          SA1    /AR/DIMI 
          SA3    T.DIM
          IX1    X1+X3
          SA3    X1          (A3) -> DIM HEADER 
          SB7    B2+B2
          SA1    A3+B7       (A1) -> LB , UB
          SB7    B3-B2       (B7) = DIMENSION COUNT - SUBSCRIPT COUNT 
          MI     X1,A=AR4    IF ADJUSTABLE LOWER BOUND
          CLAS=  X2,TP,(BIAS) 
          LX1    -D2.LBP-DM.INFP-DM.INFL
          AX1    TP.ORDL
          BX7    X2*X1       X7 = LOWER BOUND OF SUBSCRIPT
          SA2    CONZERI
          BX7    X7+X2
  
 A=AR4    SA7    B6          B6 -> TOP OF ESTACK + 1
          SB6    B6+B1
          SB7    B7-B1
          GT     B7,A=AR4    IF NOT DONE PADDING ESTACK 
          EQ     A=AR7
  
*         HERE IF SUBSCRIPT COUNT .GT. DIMENSION COUNT
  
 A=AR6    SB7    B2-B3       (B7) = SUBSCRIPT COUNT - DIMENSION COUNT 
          SB6    B6-B7       ADJUST ESTACK
  
 A=AR7    SX6    B3 
          SA6    /AR/NSUB    UPDATE TO ACTUAL SUBSCRIPT COUNT 
  
*         SELECT IN-LINE OR OUT-OF-LINE SUBSCRIPT EVALUATION. 
*         EVALUATE IN-LINE IF ALL SUBSCRIPT EXPRESSIONS ARE CONSTANT
*         AND THE ARRAY IS NOT ADJUSTABLE, EVEN IF THE DEBUGGING OPTION 
*         WAS SELECTED ON THE *FTN* CONTROL STATEMENT.
  
 A=AR8    SA1    DATFLG 
          SA2    CO.DBSB
          SBIT   X3,DH.VDP
          SBIT   X4,AC.VSUBP
          BX6    X3+X4       VARDIM .OR. VARSUB 
          LX3    DH.VDP+1    (X3) = RESTORE *DH.W* NATURAL POSITION 
          LX4    AC.VSUBP+1  (X4) = RESTORE *ARGCOMA* NATURAL POSITION
          BX7    X2*X6       C.C. OPT .AND. VAR---
          NZ     X1,A=AR10   IF PROCESSING DATA ITEM
          MI     X7,A=AR20   IF SUBSCRIPT TO BE EVALUATED OUT-OF-LINE 
  
*         HERE IF SUBSCRIPT TO BE EVALUATED IN-LINE.
  
 A=AR10   BSS    0
          SA1    S=VD        INITIALIZE SKELETON VD. OPERAND
          =X2    M.INT
          BX7    0
          LX1    TP.ORDP
          LX2    TP.MODEP 
          BX6    X1+X2
          SA6    /AR/VDSK 
          =A7    B6          CREATE EMPTY SUBSCRIPT VALUE 
          =B6    B6+1 
          EQ     A=AR14 
  
*         PROCESS SUBSCRIPT EXPRESSION RESULTS FROM RIGHT TO LEFT.
  
 A=AR12   SA1    /AR/NSUB 
          RJ     MSP         MULTIPLY BY DIMENSION SPAN 
 A=AR14   RJ     ASE         ADD SUBSCRIPT EXPRESSION 
          SA1    /AR/NSUB 
          RJ     SLB         SUBTRACT LOWER BOUND 
          SA1    /AR/NSUB 
          =X2    1
          IX6    X1-X2       DECREMENT SUBSCRIPT COUNT
          SB7    X6 
          SA6    A1 
          GT     B7,B0,A=AR12      IF ANOTHER DIMENSION 
          EQ     A=AR30 
  
*         HERE IF SUBSCRIPT TO BE CHECKED AND EVALUATED OUT-OF-LINE.
  
 A=AR20   BSS    0
          CLAS=  X0,DH,(MAT)
          BX6    X3+X0
          SA6    A3          MARK *MATERIALIZE DIM INFO AT RUN-TIME*
  
*         EMIT APLIST TURPLE FOR RUN-TIME DIMTAB ADDRESS. 
  
          SA1    S=RD 
          SA2    /AR/DIMI 
          LX1    TP.ORDP
          =X5    0           (2OP)
          LX2    TP.BIASP 
          BX4    X1+X2       (1OP)
          EMIT   GAPOP,*
  
*         EMIT APLIST TURPLE FOR EACH SUBSCRIPT EXPRESSION RESULT.
  
          SA1    /AR/NSUB 
          SB7    X1          (B7) = COUNT OF SUBSCRIPTS 
  
 .T       IFEQ   TEST,ON
          LE     B7,B0,"BLOWUP"    IF SUBSCRIPT COUNT ERROR 
          SB2    MAX.DIM
          GT     B7,B2,"BLOWUP"    IF SUBSCRIPT COUNT ERROR 
 .T       ENDIF 
  
          BX5    0           (2OP)
          SA4    B6-B7       (1OP) = 1ST SUBSCRIPT (ELSTACK)
 A=AR22   SA1    GAPOP
          MX0    -TP.MODEL
          LX4    -TP.MODEP
          BX2    -X0*X4      EXTRACT MODE 
          LX4    TP.MODEP 
          LX2    SP.MODEP 
          BX6    X1+X2
          SA6    SOPR 
          EMIT   A6,*        SUBSCRIPT TURPLE 
          =B7    A4+1        ADVANCE TO NEXT SUBSCRIPT
          =A4    A4+1 
          LT     B7,B6,A=AR22      IF ANOTHER SUBSCRIPT 
          SA1    /AR/NSUB 
          SB7    X1          COUNT OF SUBSCRIPTS
          SB6    B6-B7       REMOVE SUBSCRIPTS FROM ELSTACK 
  
*         EMIT APLIST TURPLE FOR ARRAY NAME.
  
          SA1    SCR+AS.W    ARRAY NAME FROM *ARGMIS* 
          BX6    X1 
          =X7    M.BOOL      DUMMY MODE 
          CALL   NCS         NAME TO RUN-TIME CONTAB
          BX4    X6          (1OP)
          ERRNZ  M.BOOL 
          MX5    0           (2OP)
          EMIT   GAPOP,*
**        CALL   MFP         (WAS) MARK FIRST PARAMETERS
  
*         EMIT FUNCTION CALL TO LIBRARY BOUNDS CHECK ROUTINE. 
  
          TAGSEX S.CES
          SA1    /AR/NSUB 
          SA3    FUNOP
          BX4    X6          (1OP)
          SX5    X1+2        (2OP) = NR SUBS + 2 (DIM ADDR, ARRAY NAME) 
          LX5    TP.BIASP 
          =B6    B6+1        DUMMY ADVANCE
          RJ     ADU         EMIT CALL TO LIB FUNC  * CES. *
  
*         PREPARE TO ISSUE THE ARRAY REFERENCE. 
* 
*         ENTRY  (B6)-2  ->  ARRAY OPERAND. 
*                (B6)-1  ->  SUBSCRIPT VALUE. 
*                            NOTE THAT THE SUBSCRIPT VALUE IS NULL (=0) 
*                            IF ALL SUBSCRIPTS ARE CONSTANT AND 
*                            THE ARRAY IS NOT ADJUSTABLE. 
*                (B6)    ->  UNSPECIFIED. 
  
  
 A=AR30   BSS    0
  
*         ADD ACCUMULATED CONSTANT BIAS TO ARRAY OPERAND IN ELSTACK.
*         IF DOUBLE OR COMPLEX ARRAY, DOUBLE BOTH THE BIAS AND THE
*         VARIABLE SUBSCRIPT VALUE (IF ANY).
  
          =B6    B6-1        ASSUME CONSTANT SUBSCRIPT (NO SUBSCR VALUE)
          =A4    B6-1        (X4) = ARRAY NAME IN ELSTACK 
          SX1    WD2MASK
          MX0    -TP.MODEL
          LX4    -TP.MODEP
          BX6    -X0*X4      EXTRACT MODE 
          LX4    TP.MODEP 
          SB2    X6 
          AX1    B2          MODE BIT TO POS 0
          MX0    -1 
          BX2    -X0*X1      =1 IF DOUBLE OR COMPLEX, =0 IF ELSE
          SA1    /AR/BIAS 
          MX0    -TP.BIASL
          SB3    X2+TP.BIASP
          LX0    TP.BIASP 
          BX6    X0*X4       CLEAR BIAS FIELD 
          LX1    B3          DOUBLES THE BIAS IF DBL OR CPLX ARRAY
          BX7    -X0*X1 
          =A4    B6 
          BX6    X6+X7       INSERT BIAS IN ARRAY OPERAND 
          =A6    B6-1        UPDATE ARRAY OPERAND 
          ZR     X4,POPX     IF NULL SUBSCRIPT VALUE
  
*         HERE IF ANY SUBSCRIPT EXPRESSION WAS VARIABLE OR ANY BOUND
*         WAS ADJUSTABLE.  PREPARE TO ISSUE  *ARYOP*  ARRAY REFERENCE.
  
          =B6    B6+1        NOTE THAT SUBSCRIPT VALUE EXISTS 
          BX5    X4          (2OP) = SUBSCRIPT VALUE
          ZR     X2,A=AR32   IF NOT DOUBLE OR COMPLEX ARRAY 
          SA3    INTEG+/OP/PLUS 
          RJ     ADU         ISSUE *ADD* TO DOUBLE THE SUBSCRIPT VALUE
  
 A=AR32   =A4    B6-1        FETCH 2OP (SUBSCRIPT VALUE)
          CLAS=  X0,TP,(ARR,INTR) 
          BX1    X0*X4
          BX1    X0-X1
          NZ     X1,A=AR40   IF NOT SUBSCRIPTED SUBSCRIPT 
          MX5    0
          SA3    XMITOP 
          BX6    X3 
          =B6    B6+1        INCREMENT FOR XMIT TURPLE
          SA6    SOPR 
          RJ     ADT         ADD THE XMIT TURPLE
 A=AR40   SA3    ARYOP
          LX6    X3 
          SA6    SOPR 
          CLAS=  X0,TP,(ARR,ARS)
          SA1    ATTR 
          BX7    X0+X1       MERGE (ATTR) 
          SA7    A1          UPDATE (ATTR) = ARRAY
          =A5    B6-1        (2OP) = SUBSCRIPT VALUE
          =A4    A5-1        (1OP) = ARRAY
          EQ     POP.STD
 ADU      SPACE  4,20 
**        ADU - FANCY *ADT* LINKAGE SUBROUTINE. 
* 
*         DOES THE FOLLOWING AND THEN CALLS *ADT* ... 
*                1.  INCREMENTS (B6) BY ONE, TO FAKE (2OP) ON ELSTACK.
*                2.  STORES (X3)=(OPR) IN (SOPR). 
*                3.  STORES  *INTEGER RESULT MODE*  IN (SMOD).
* 
*         ENTRY  (X3) = OPERATOR. 
*                (X4) = FIRST OPERAND.
*                (X5) = SECOND OPERAND. 
*                (B6)-1  ->  NOMINAL FIRST OPERAND IN ELSTACK.
* 
*         EXIT   *ADT* HAS BEEN CALLED. 
*                (B6) = UNCHANGED.
* 
*         USES   X6-7.    A6-7.    B6.
* 
*         CALLS  ADT. 
  
  
 ADU      SUBR   0           **  ENTRY/EXIT  ** 
          BX6    X3 
          =X7    M.INT
          SA6    SOPR 
          =B6    B6+1 
          NO
          SA7    SMOD 
          RJ     ADT
          EQ     EXIT.
 ASE      SPACE  4,20 
**        ASE - ADD SUBSCRIPT EXPRESSION. 
* 
*         ENTRY  (B6)-2  ->  SUBSCRIPT EXPRESSION RESULT OPERAND. 
*                (B6)-1  ->  SUBSCRIPT VALUE OPERAND. 
* 
*         USES   X0-7.    A1-7.    B2-3,B7. 
* 
*         CALLS  ADU/ADT, LCT.
* 
*         NOTE-- COMMENTING CONVENTION WITHIN *ASE* ... 
*                PREFIX LETTERS ARE AS FOLLOWS ...
* 
*                   K   CONSTANT BIAS TO BE ADDED TO /AR/BIAS.
*                   N   NEW SUBSCRIPT VALUE TURPLE BEING FORMED.
*                   V   SUBSCRIPT VALUE TURPLE IN ELSTACK.
*                   X   SUBSCRIPT EXPRESSION RESULT INTERMED TURPLE.
* 
*                E.G.,  (X-1OP) = FIRST OPERAND OF SUBSCR EXPR TURPLE.
  
  
 ASE      SUBR   0           **  ENTRY/EXIT  ** 
          =B6    B6-1        POP SUBSCR EXPR RESULT 
          =X3    /OP/PLUS                (N-OPR) = PLUS 
          =A1    B6-1 
          BX5    X1          SAVE (N-2OP) = SUBSCR EXPR RESULT OPERAND
          INTLCT             CHECK RESULT TYPE
          ZR     B2,ASE20    IF RESULT VARIABLE OR INTERMED 
  
*         HERE IF RESULT IS A CONSTANT. 
  
* ASE10   BSS    0
  
          SA1    /AR/BIAS 
          SA2    B6          (X2) = SUBSCR VALUE OPERAND
          IX6    X1+X6       BIAS = BIAS + CONSTANT SUBSCR EXPR 
          BX7    X2 
          SA6    A1 
          =A7    B6-1        BUBBLE SUBSCR VALUE OPD DOWN (LIKE *ADT*)
          EQ     EXIT.
  
*         HERE IF RESULT IS NOT A CONSTANT. 
*                (N-OPR) = (X3) = PLUS. 
*                (N-2OP) = (X5) = SUBSCR EXPR RESULT OPERAND. 
  
 ASE20    BSS    0
          BX7    X5 
          SBIT   X7,TP.INTRP
          PL     X7,ASE32    IF NOT INTERMEDIATE
  
*         HERE IF RESULT IS AN INTERMEDIATE.
  
          MX0    -TP.ORDL 
          LX7    -TP.ORDP+TP.INTRP+1
          SA1    T.PAR
          BX0    -X0*X7 
          SB2    X0 
          ERRMI  18-TP.ORDL 
          SA2    INTEG+/OP/UMIN 
          SA1    X1+B2       (X-OPR)  TH. WORD
          HX1    TH.SKEL
          AX1    -TH.SKELL
          HX2    SP.SKEL
          AX2    -SP.SKELL
          IX2    X1-X2
          SA4    B6 
          NZ     X2,ASE22    IF OPERATOR NOT *UMIN* 
          ZR     X4,EXIT.    IF NO SUBSCR VALUE, (X-OPD) BECOMES (V-OPD)
          =X3    /OP/MINUS               (N-OPR) = MINUS
          =A5    A1+OR.1OP-OR.OPR        (N-2OP) = (X-1OP)
          EQ     ASE34
  
 ASE22    =A2    A2-/OP/UMIN+/OP/MINUS
          =B3    -1          NOTE (X-OPR) *MINUS* 
          HX2    SP.SKEL
          AX2    -SP.SKELL
          IX2    X1-X2
          ZR     X2,ASE24    IF (X-OPR) *MINUS* 
          =A2    A2-/OP/MINUS+/OP/PLUS
          =B3    0           NOTE (X-OPR) *PLUS*
          HX2    SP.SKEL
          AX2    -SP.SKELL
          IX2    X1-X2
          NZ     X2,ASE32    IF (X-OPR) NOT *PLUS* (AND NOT *MINUS*)
  
 ASE24    =A4    A1+OR.1OP-OR.OPR 
          BX1    X4 
          INTLCT             CHECK (X-1OP) TYPE 
          =A1    A4+OR.2OP-OR.1OP 
          BX4    X6          SAVE POSSIBLE (N-K) = CONVERTED (X-1OP)
          NZ     B2,ASE26    IF (X-1OP) CONSTANT
          INTLCT             CHECK (X-2OP) TYPE 
          ZR     B2,ASE32    IF (X-2OP) (AND X-1OP) NOT CONST, CAN-T OPT
          SX0    B3 
          =A5    A4+OR.1OP-OR.1OP        (N-2OP) = (X-1OP)
          AX0    1           = +0 IF (X-OPR) *PLUS*, = -0 IF *MINUS*
          BX4    X6-X0       (N-K), COMPLEMENTED IF *MINUS* NOTED 
          EQ     ASE30
  
*         HERE IF (X-1OP) IS CONSTANT.
  
 ASE26    INTLCT             CHECK (X-2OP) TYPE 
  
 .T       IFEQ   TEST,ON
          NZ     B2,"BLOWUP" IF BOTH (X-OPS) CONST, *CONRED* BUG LIKELY 
 .T       ELSE
          NZ     B2,ASE32    IF (X-2OP) (AND X-1OP) ARE CONST, CAN-T OPT
 .T       ENDIF 
  
          =A5    A4+OR.2OP-OR.1OP        (N-2OP) = (X-2OP)
          ZR     B3,ASE30    IF (X-OPR) IS *PLUS* 
          =X3    /OP/MINUS               (N-OPR) = MINUS
  
*         HERE TO *ADD*  (X4)=(N-K)  CONSTANT TO ACCUMULATED BIAS.
  
 ASE30    BSS    0
          SA1    /AR/BIAS 
          IX6    X1+X4
          SA6    A1 
  
*         HERE TO *ADD* SUBSCRIPT EXPRESSION RESULT (HOWEVER OPTIMIZED) 
*         TO PREVIOUS SUBSCRIPT VALUE.
  
 ASE32    SA4    B6                      (N-1OP) = SUBSCR VALUE OPERAND 
          =B2    /OP/MINUS
          NZ     X4,ASE34    IF ANY PREVIOUS SUBSCRIPT VALUE
          SB3    X3 
          =X3    /OP/UMIN                (N-OPR) = UNARY MINUS
          EQ     B3,B2,ASE34 IF (N-OPR) *MINUS*, ISSUE *UMIN* 
          BX6    X5 
          =A6    B6-1        (N-2OP) TO ELSTACK AS NEW SUBSCR VALUE 
          EQ     EXIT.
  
 ASE34    SA3    X3+INTEG    (X3) = SELECTED (TH.)
          RJ     ADU         ISSUE NEW TURPLE 
          EQ     EXIT.
 GDI      SPACE  4,20 
**        GDI - GET DIMENSION DECLARATOR INFORMATION. 
* 
* 
*         ENTRY  (B2) = NUMBER OF SUBSCRIPT FOR WHICH INFO REQUESTED. 
*                (/AR/DIMI) = INDEX OF ARRAY IN T.DIM.
* 
*         EXIT   (B2) = UNCHANGED.
*                (B3) = COUNT OF DIMENSIONS.
*                (A3,X3) = DIM HEADER (DH.W) FOR ARRAY IN T.DIM.
*            IF SUBSCRIPT NUMBER VALID, (B2 .LE. B3), ALSO RETURNS ...
*                (X1) = LOWER BOUND (SIGN-EXT IF CON, VD. ORD IF ADJ).
*                (X2) = UPPER BOUND (SIGN-EXT IF CON, VD. ORD IF ADJ).
*                (X6) = ADJUSTABLE LOWER BOUND FLAG (DI.TDP), 
*                       EXTENDED FROM B59 THROUGH B0. 
*                (X7) = ADJUSTABLE UPPER BOUND FLAG (DI.TDP), POS B59.
*                (A1) -> LB,UB (D2.W) FOR SUBSCRIPT IN T.DIM. 
* 
*         USES   X1-3,X6-7.    A1-3.    B3,B7.
* 
*         CALLS  NONE.
  
  
 GDI      SUBR   0           **  ENTRY/EXIT  ** 
          SA1    /AR/DIMI    ARRAY INDEX IN T.DIM 
  
 .T       IFEQ   TEST,ON
          MI     X1,"BLOWUP" IF INDEX BELOW T.DIM 
          SA2    T=DIM
          IX2    X2-X1
          MI     X2,"BLOWUP" IF INDEX ABOVE T.DIM 
 .T       ENDIF 
  
          SA2    T.DIM
          IX1    X1+X2
          SA3    X1          *(A3,X3) = DIM HEADER
          MX7    -DH.DIML 
          LX3    -DH.DIMP 
          BX6    -X7*X3 
          LX3    DH.DIMP
          SB3    X6          *(B3) = COUNT OF DIMS
          GT     B2,B3,EXIT. IF SUBSCR NUMBER .GT. DIM COUNT  (ERROR) 
          SB7    B2+B2
          ERRNZ  Z=DD-2 
          SA1    A3+B7       *(A1) -> LB, UB
          BX6    X1 
          LX6    59-D2.LBP-DM.TDP 
          AX6    59-0        *(X6) = SIGN-EXT ADJUST. LOWER BOUND FLAG
          BX7    X1 
          LX7    59-D2.UBP-DM.TDP  *(X7) = ADJUSTABLE UPPER BOUND FLAG
          BX2    X1 
          LX1    -D2.LBP-DM.INFP-DM.INFL
          AX1    -DM.INFL    *(X1) = SIGN EXTENDED LOWER BOUND
          LX2    -D2.UBP-DM.INFP-DM.INFL
          AX2    -DM.INFL    *(X2) = SIGN EXTENDED UPPER BOUND
          EQ     EXIT.
 MSP      SPACE  4,20 
**        MSP - MULTIPLY BY DIMENSION SPAN. 
* 
*         ENTRY  (X1) = NUMBER OF CURRENT SUBSCRIPT.
* 
*         USES   X0-7.    A1-6.    B2.
* 
*         CALLS  ADU/ADT, GDI, LCT, NCS.
  
  
 MSP      SUBR   0           **  ENTRY/EXIT  ** 
          SB2    X1 
          RJ     GDI         GET DIMENSION INFORMATION
          =A1    A1+D1.W-D2.W      (X1) = DIM SPAN WORD FROM T.DIM
          BX5    X1 
          LX1    59-D1.SPANP-DM.TDP 
          LX5    -D1.SPANP-DM.INFP-DM.INFL
          SA3    /AR/BIAS    (X3) = ACCUMULATED BIAS
          =A4    B6-1        (1OP) = SUBSCRIPT VALUE
          AX5    -DM.INFL    (X5) = SPAN
          MI     X1,MSP20    IF ADJUSTABLE SPAN 
  
*         HERE IF FIXED SPAN. 
* 
*                (X3) = BIAS. 
*                (X4) = SUBSCRIPT VALUE.
*                (X5) = SPAN. 
  
* MSP10   BSS    0
          IX6    X3*X5       BIAS = BIAS * SPAN 
 .FIX     SET    --  IN TROUBLE IF PARTIAL PRODUCT EXCEEDS 2**24. 
          SA6    A3 
          ZR     X4,EXIT.    IF NULL SUBSCRIPT VALUE
  
*         HERE IF FIXED SPAN AND SUBSCR VALUE EXISTS.  ISSUE MULTIPLY.
  
          BX2    X4 
          SBIT   X2,TP.INTRP
          PL     X2,MSP16    IF SUBSCRIPT VALUE NOT AN INTERMEDIATE 
          SA1    T.PAR
          MX0    -TP.ORDL 
          LX2    -TP.ORDP+TP.INTRP+1
          BX3    -X0*X2      EXTRACT ORD
          SB2    X3 
          ERRMI  18-TP.ORDL 
          SA2    INTEG+/OP/MULT 
          SA1    X1+B2       TH. OF LAST SUBSCR TURPLE
          HX1    TH.SKEL
          AX1    -TH.SKELL
          HX2    SP.SKEL
          AX2    -SP.SKELL
          IX1    X1-X2
          NZ     X1,MSP16    IF LAST OPERATOR NOT A MULTIPLY
  
*         HERE IF LAST SUBSCRIPT EXPR OPERATOR WAS A MULTIPLY.
  
          =A4    A1+OR.1OP-OR.OPR  SUBSCRIPT RESULT (1OP) 
          BX1    X4 
          CALL   LCT         CHECK (1OP) TYPE 
          ZR     B2,MSP12    IF (1OP) NOT A CONSTANT
  
 .T       IFEQ   TEST,ON
          SA2    ="BOOLINT" 
          SB2    X0          MODE 
          LX2    B2 
          PL     X2,"BLOWUP" IF NOT BOOL OR INT  ( *SSR* ERROR )
 .T       ENDIF 
  
          IX5    X6*X5       NEW (2OP) = K-OPD * CONST SPAN 
 .FIX     SET    --  IN TROUBLE IF PARTIAL PRODUCT EXCEEDS 2**24. 
          =A4    A4-OR.1OP+OR.2OP  NEW (1OP)
          EQ     MSP18       ISSUE NEW MULTIPLY TURPLE (OLD MAY DANGLE) 
  
 MSP12    =A4    A4+OR.2OP-OR.1OP  SUBSCRIPT RESULT (2OP) 
          BX1    X4 
          CALL   LCT         CHECK (2OP) TYPE 
          ZR     B2,MSP16    IF (2OP) NOT A CONSTANT
  
 .T       IFEQ   TEST,ON
          SA2    ="BOOLINT" 
          SB2    X0          MODE 
          LX2    B2 
          PL     X2,"BLOWUP" IF NOT BOOL OR INT  ( *SSR* ERROR )
 .T       ENDIF 
  
          IX5    X6*X5       NEW (2OP) = K-OPD * CONST SPAN 
 .FIX     SET    --  IN TROUBLE IF PARTIAL PRODUCT EXCEEDS 2**24. 
          =A4    A4-OR.2OP+OR.1OP  NEW (1OP)
          EQ     MSP18       ISSUE NEW MULTIPLY TURPLE (OLD MAY DANGLE) 
  
*         HERE TO ISSUE (SUBSCRIPT VALUE / PRED OPD) * (CONSTANT SPAN). 
*                (X4) = (1OP).
*                (X5) = CONSTANT FOR (2OP). 
  
 MSP16    SA4    B6-1        (1OP) = PREVIOUS RESULT
 MSP18    BX6    X5 
          =X7    M.INT
          CALL   NCS
          BX5    X6          (2OP) = SPAN 
          EQ     MSP30
  
*         HERE TO PROCESS ADJUSTABLE DIMENSION SPAN.
*                (A3,X3) = /AR/BIAS, BIAS ACCUMULATOR.
*                (X4) = (1OP) = SUBSCRIPT VALUE.
*                (X5) = VD. ORDINAL OF SPAN.
  
 MSP20    BX6    X5 
          MX7    0
          SA6    MSPA        TEMP SAVE VD. ORD
          SA7    A3          CLEAR BIAS ACCUMULATOR 
          BX5    X4          PRESET (2OP) = SUBSCRIPT VALUE 
          NZ     X3,MSP22    IF BIAS .NZ., GO ADD IT IN 
          ZR     X4,EXIT.    IF NULL SUBSCRIPT VALUE
          EQ     MSP28
  
 MSP22    BX6    X3 
          =X7    M.INT
          CALL   NCS
          SA3    INTEG+/OP/PLUS    (OPR) = INTEGER ADD
          BX5    X6          (2OP) = BIAS 
          ZR     X4,MSP28    IF NULL SUBSCRIPT VALUE
          RJ     ADU         ISSUE ADD
          =A5    B6-1        (2OP) = NEW SUBSCRIPT VALUE
  
 MSP28    SA1    MSPA        SAVED VD. ORDINAL
          SA2    /AR/VDSK    VD. OPERAND SKELETON, PRESET WITH (S=VD) 
          LX1    TP.BIASP 
          BX4    X1+X2       (1OP) = ADJUSTABLE SPAN
  
 MSP30    SA3    INTEG+/OP/MULT 
          RJ     ADU
          EQ     EXIT.
 SLB      SPACE  4,20 
**        SLB - SUBTRACT LOWER BOUND. 
* 
* 
*         ENTRY  (X1) = CURRENT SUBSCRIPT NUMBER. 
* 
*         USES   X2-6.    A2-4,A6.    B2. 
* 
*         CALLS  ADU/ADT, GDI.
  
  
 SLB      SUBR   0           **  ENTRY/EXIT  ** 
          SB2    X1          (B2) = CURRENT SUBSCRIPT NUMBER
          RJ     GDI         GET DIMENSION INFORMATION
          MI     X6,SLB2     IF LOWER BOUND IS ADJUSTABLE 
          SA2    /AR/BIAS 
          IX6    X2-X1       BIAS = BIAS - LOWER BOUND (CONSTANT) 
          SA6    A2 
          EQ     EXIT.
  
*         HERE IF LOWER BOUND IS ADJUSTABLE.
  
 SLB2     SA2    /AR/VDSK 
          =A4    B6-1        (1OP) = SUBSCRIPT VALUE
          LX1    TP.BIASP 
          BX5    X2+X1       (2OP) = ADJUSTABLE LOWER BOUND 
          SA3    INTEG+/OP/MINUS   (OPR) = INTEGER SUBTRACT 
          NZ     X4,SLB3     IF SUBSCRIPT VALUE NOT NULL
          =A3    A3-/OP/MINUS+/OP/UMIN
 SLB3     RJ     ADU         ISSUE SUBTRACT OR UNARY MINUS
          EQ     EXIT.
 SSO      SPACE  4,30 
**        SSO -  SET UP SUBSCRIPT OPERATIONS. 
* 
*         CALLED WHEN PARSER HAS ENCOUNTED AN ARRAY NAME FOLLOWED 
*         BY A LEFT PAREN.  SETS CONDITIONS FOR PARSER TO INDICATE
*         WE ARE NOW IN SUBSCRIPT MODE. 
* 
*         ENTRY  (CSYTAG) = PASS 1 TAG-FORM OF ARRAY. 
*                (CSYWB) = T.SYM WORD B FOR ARRAY.
* 
*         EXIT   (X4) = NEW *ARGMIS*. 
*                (X7) = NEW *ARGCOMA*.
* 
*         USES   X0-4,X7.    A1-3.    B2-3. 
* 
*         CALLS  NONE.
  
  
 SSO      SUBR   0           **  ENTRY/EXIT  ** 
          SA1    CSYTAG 
          SA2    T.SYM
          MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX7    -X0*X1       EXTRACT T.SYM ORDINAL OF ARRAY
          =B2    X7+WA.W
          ERRMI  18-TP.ORDL 
  
 .T       IFEQ   TEST,ON
          MI     B2,"BLOWUP"       IF INDEX BELOW T.SYM 
          SA3    T=SYM
          SB3    X3 
          GT     B2,B3,"BLOWUP"    IF INDEX ABOVE T.SYM 
 .T       ENDIF 
  
          LX0    X7,B1
          SB2    X0+B2
          ERRNZ  Z=SYM-3
          SA2    X2+B2
          MX0    WA.NAMEL 
          HX2    WA.NAME
          SA1    CSYWB
          BX4    X0*X2       *(X4) = ARGMIS [NAME=ARRAY NAME] 
          ERRNZ  WA.NAMEP-AS.NAMEP
          MX0    -WB.PNTL 
          LX1    -WB.PNTP 
          BX0    -X0*X1       EXTRACT T.DIM INDEX OF ARRAY
  
 .T       IFEQ   TEST,ON
          MI     X0,"BLOWUP"       IF INDEX BELOW T.DIM 
          SA2    T=DIM
          IX2    X2-X0
          MI     X2,"BLOWUP"       IF INDEX ABOVE T.DIM 
 .T       ENDIF 
  
          LX7    AC.SYMP
          LX0    AC.DIMIP 
          BX7    X7+X0       *(X7) = ARGCOMA[VSUB=0,SYM=*,DIMI=**,CNT=0]
          EQ     EXIT.
 SSR      EJECT 
**        SSR - STANDARDIZE SUBSCRIPT RESULT. 
* 
*         ENTRY  (X4) = ARGCOMA.
*                (X5) = SUBSCRIPT EXPRESSION RESULT.
*                (B6)-1  ->  SUBSCRIPT EXPR RESULT. 
* 
*         EXIT   (X4) = ARGCOMA.
* 
*         USES   X0-7.    A1-4,A6-7.    B2-3,B6-7.
* 
*         CALLS  ADU/ADT, GDI, LCT, NCS, SUBERR(OSE). 
  
  
 SSR      SUBR   0           **  ENTRY/EXIT  ** 
          LX4    -AC.CNTP 
          SX6    X4 
          SB2    X4          (B2) = CURRENT SUBSCRIPT COUNT 
          ERRNZ  AC.CNTL-18 
          SA6    /AR/NSUB    SAVE CURRENT SUBSCRIPT COUNT 
          LX4    -AC.DIMIP+AC.CNTP
          SX7    X4 
          ERRNZ  AC.DIMIL-18
          LX4    AC.DIMIP    (X4) = RESTORE *ARGCOMA* NATURAL POSITION
          SA7    /AR/DIMI    SAVE INDEX OF ARRAY IN T.DIM 
          RJ     GDI         GET DIMENSION INFORMATION
          GT     B2,B3,EXIT. IF TOO MANY SUBSCRIPTS (DIAGNOSED LATER) 
          BX1    X5 
          CALL   LCT
          SA2    ="ALLNUM"
          SB7    E.SB2       PRESET MSG  *NOT NUMERIC TYPE* 
          SB3    X0          (B3) = MODE
          LX2    B3 
          PL     X2,SSR30    IF SUBSCRIPT NOT NUMERIC 
          BX0    X6          (X0) = CONSTANT SUBSCRIPT VALUE (=0 IF VAR)
          =B7    M.INT
          EQ     B3,B7,SSR2  IF SUBSCRIPT INTEGER 
          SUBERR E.SB3       ISSUE MSG *(NON-ANS) NOT INTEGER*
 SSR2     SA2    ="BOOLINT" 
          =X7    M.INT
          LX2    B3 
          NZ     B2,SSR20    IF SUBSCRIPT CONSTANT
  
*         HERE IF SUBSCRIPT IS VARIABLE.
*         FORCE INTEGER MODE IF NOT BOOLEAN OR INTEGER. 
  
* SSR10   BSS    0
          CLAS=  X0,AC,(VSUB) 
          BX4    X4+X0       FLAG VARIABLE SUBSCRIPT
          MI     X2,EXIT.    IF SUBSCRIPT IS BOOLEAN OR INTEGER 
          LX6    X4 
          BX4    0           (1OP) = DUMMY
          SA6    SSRA        TEMP SAVE ARGCOMA
          SA3    INTMAC      (X3) = *INT* OPERATOR
          RJ     ADU         *INT* CONVERSION TURPLE TO T.PAR 
          SA4    SSRA        RESTORE (X4) = ARGCOMA 
          EQ     EXIT.
  
*         HERE IF SUBSCRIPT IS CONSTANT.
  
 SSR20    BX5    X0          (X5) = CONSTANT SUBSCRIPT VALUE
          MI     X2,SSR22    IF SUBSCRIPT IS BOOLEAN OR INTEGER CONSTANT
          UX0,B7 X5          INTEGERIZE CONSTANT
          LX6    X0,B7
          BX5    X6          (X5) = SAVE INTEGERIZED CONSTANT 
          CALL   NCS
          =A6    B6-1        INTEGERIZED SUBSCRIPT TO ELSTACK 
          BX0    X5 
  
*         HERE WITH (X0)=(X5) = INTEGER (OR BOOLEAN) CONSTANT SUBSCRIPT.
*         CHECK ... 
*                1.  IS SUBSCRIPT MAGNITUDE .LT. 2**23-1  (IF TOO BIG,
*                    WE RUN INTO FIELD OVERFLOWS IN *A=ARRAY*.) 
*                2.  IS NUMBER OF SUBSCRIPT  .LE.  NUMBER OF DIMENSIONS.
*                3.  IS SUBSCRIPT .LE. UPPER BOUND AND .GE. LOWER BOUND.
  
 SSR22    AX0    DM.INFL-1   DISCARD VALID SUBSCRIPT BITS 
          SB7    E.SB4       PRESET MSG *MAGNITUDE .GT. 2**23-1 * 
          LX4    -AC.CNTP 
          SB2    X4          (B2) = CURRENT SUBSCRIPT COUNT 
          ERRNZ  AC.CNTL-18 
          LX4    AC.CNTP
          NZ     X0,SSR30    IF ABS(SUBSCRIPT) TOO LARGE
          RJ     GDI         GET DIMENSION INFORMATION
          MI     X6,SSR24    IF LOWER BOUND ADJUSTABLE
          IX0    X5-X1
          SB7    E.SB5       PRESET MSG *SUBSCRIPT .LT. LOWER BOUND*
          MI     X0,SSR28    IF SUBSCRIPT .LT. LOWER BOUND
 SSR24    MI     X7,EXIT.    IF UPPER BOUND ADJUSTABLE
          IX0    X2-X5
          SB7    E.SB6       PRESET MSG *SUBSCRIPT .GT. UPPER BOUND*
          PL     X0,EXIT.    IF SUBSCRIPT .LE. UPPER BOUND
 SSR28    SUBERR B7 
          EQ     EXIT.
  
*         HERE IF SUBSCRIPT MAGNITUDE OR MODE ERROR.
*         SUBSTITUTE LEGAL SUBSCRIPT VALUE. 
*                (B7) -> ERROR MESSAGE TO BE ISSUED.
  
 SSR30    SUBERR B7          ISSUE ERROR MESSAGE
          LX4    -AC.CNTP 
          SB2    X4          (B2) = CURRENT SUBSCRIPT COUNT 
          ERRNZ  AC.CNTL-18 
          LX4    AC.CNTP
          RJ     GDI         GET DIMENSION INFORMATION
          BX6    -X6*X1      (X6) = LB IF LB CONST, = 0 IF LB ADJUST
          =X7    M.INT
          CALL   NCS
          =A6    B6-1         *SAFE* SUBSCRIPT TO ELSTACK 
          EQ     EXIT.
          TITLE  SUBROUTINES. 
 ACT      SPACE  4,10 
**        ACT -  ADD CONVERTED TURPLE.
* 
*         ENTRY  (X1) = TOKEN TYPE OF OPERATOR. 
*                (X4) = 1OP 
*                (X5) = 2OP 
* 
*         EXIT   (B6) = DECREMENTED BY ONE. 
*                ((B6)-1) -> RESULT OPERAND.
*                SPECIFIC-MODE TURPLE PUT OUT.
* 
*         USES   CANNOT DESTROY A0, B4,B5 
*         CALLS  ADT, OMC, SDM. 
  
  
 ACT      SUBR   =           ...ENTRY/EXIT... 
          SA2    X1-O.SEP+F.PRIOR 
          MX0    -SP.TBPRL
          LX2    -SP.TBPRP
          BX7    X0*X2       CLEAR STACK PRIORITY 
          BX3    X7+X1       SET (TH.TBPR) = TOKEN TYPE 
          LX3    SP.TBPRP 
          RJ     SDM         SELECT DOMINANT MODE 
          RJ     OMC         OUTPUT MODE CONVERSION (IF NECESSARY)
          RJ     ADT         ADD TURPLE 
          EQ     EXIT.
 ADT      SPACE  4,20 
**        ADT - ADD TURPLE TO PARSED FILE.
* 
*         GENERAL FLOW
* 
*         A. CBB - CONVERTS 1OP AND 2OP TO BASE/BIAS FORMAT, AS NEEDED. 
* 
*         B. CCR - CHECKS IF CURRENT TURPLE CAN BE PERFORMED AT COMPILE 
*                  TIME, IF OPERATION IS DEFINED, IF TURPLE CAN BE
*                  MODIFIED TO A FASTER DEFINED OPERATION, ETC. 
* 
*         C. SQZ - CHECKS IF CURRENT TURPLE CAN BE SQUEEZED OUT BECAUSE 
*                  OF A PREVIOUS ALIKE TURPLE.
* 
*         D. ALC - ALLOCATES ROOM FOR CURRENT TURPLE. 
* 
* 
*         ENTRY  (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
*                (SOPR) = (X3). 
*                (SMOD) = RESULTANT MODE OF TURPLE. 
*                         (SEE DEFINITION IN *SDM*.)
*                (ATTR) = EXTRA BITS TO MERGE INTO RESULT OPERAND.
* 
*         EXIT   T.PAR UPDATED BY Z=TURP, IF TURPLE NOT SQUEEZED OR 
*                REDUCED. 
*                (B2) = MI IFF TURPLE EMITTED 
*                (B6) = UPDATED BY -1.
*                ESTACK (B6) = INTERMEDIATE GENERATED BY CURRENT TURPLE.
*                (ATTR) = 0.
* 
*         USES   X0-3,X6-7.    A1-3,A6-7.    B2-3,B6-7. 
* 
*         CALLS  ALC, CBB, CCR, DBE, EMT, SQZ 
* 
*         NOTE   THIS ROUTINE DEPENDS ON THE ORDER..... 
*                ...OSTACK FOLLOWED BY ESTACK.
  
  
 ADT      SUBR   =           ENTRY/EXIT...
          SA1    DATFLG 
          SX1    X1-PM=DATA 
          ZR     X1,ADT1     IF PARSING *DATA*
          RJ     CBB         CONVERT 2OP TO BASE/BIAS FORMAT
          BX0    X5 
          LX5    X4 
          BX4    X0          SWAP 1OP/2OP FOR CBB 
          RJ     CBB         CONVERT 2OP TO BASE/BIAS FORMAT
          LX0    X5 
          BX5    X4 
          LX4    X0          RESTORE
  
 ADT1     SA1    PARNOW 
          MX6    0
          SA6    IFREL2      INDICATE LAST TURPLE NOT RELATIONAL
          SX1    X1-PM=DIM
          NZ     X1,ADT2     IF NOT 'DIM BOUND' PARSING 
          CLAS=  X0,SP,(NSQZ) 
          BX6    X0+X3       DONT SQUEEZE DIMENSION BOUNDS EXPRESSION 
          LX3    X6 
          SA6    SOPR 
          HX6    SP.BND 
          MI     X6,ADT2     IF LEGAL OPERATION 
          SB7    E.DM11 
          RJ     DBE         OUTPUT DIMENSION BOUND ERROR 
  
 ADT2     BX0    X3 
          HX0    SP.UNAR
          PL     X0,ADT3     IF NOT UNARY TURPLE
          BX4    X5          (P1) = ONLY OPERAND (1OP)
          MX5    0           (P2) = NIL 
  
 ADT3     MX6    -SP.SKELL
          BX7    X0 
          LX0    SP.UNARP+1-SP.SKELP
          BX2    -X6*X0 
          SA1    X2+=XF.SKCR
          LX1    -VS.CRAP 
          BX0    X7 
          SX7    X1          (X7) = ADDRESS OF CONSTANT REDUCER 
          ERRNZ  18-VS.CRAL 
          ZR     X7,ADT5     IF THIS SKEL NOT REDUCIBLE 
          PL     X0,ADT4     IF NOT UNARY TURPLE
          SA1    CO.DOLG
          ZR     X1,ADT4     IF NOT LONG DO 
          SA1    ARGMODE
          SB7    X1-A=DO
          ZR     B7,ADT5     IF DO INDUCTION VARIABLE 
  
 ADT4     CALL   CCR         CHECK CONSTANT REDUCTION 
          SA3    SOPR 
          ZR     X6,ADT5     IF TURPLE NOT REDUCED
          SB6    B6-B1       POP ELEMENT STACK
          SA6    B6-B1       ESTACK.TOP = RESULT OF REDUCTION 
          SB2    1
          EQ     EXIT.
  
 ADT5     BX0    X3 
          HX0    SP.NSQZ
          SX6    B5 
          SB2    -B1         INDICATE NO SQUEEZE PERFORMED
          MI     X0,ADT7     IF SQZ INHIBITED FOR THIS TURPLE 
          SA6    ADTA        SAVE B5
          RJ     SQZ         CHECK IF CURRENT TURPLE CAN BE ELIMINATED
          SA1    ADTA        RESTORE B5 
          SB5    X1          RESTORE *B5* 
          PL     B2,ADTX     IF OPERATION SQUEEZED
  
*         SET UP INTERMEDIATE RESULT OPERAND ON ESTACK. 
*                (X4) = (1OP).
*                (X5) = (2OP).
  
 ADT7     SA3    SOPR 
          MX0    -SP.TBPRL
          LX3    -SP.TBPRP
          BX7    -X0*X3      ISOLATE (X7) = TOKEN TYPE OF OPERATOR
          SB7    X7-O.= 
          BX6    X5          FIRST GUESS RESULT = STORE TARGET
          MX7    0
          ZR     B7,ADT8     IF STORE TURPLE
          SA3    SMOD 
          SA1    ATTR        ATTRIBUTES FOR RESULT
          SA2    T=PAR
          SX0    TP.INTRM 
          IX1    X1+X3       MERGE ATTRIBUTE + RESULT MODE
          LX2    TP.ORDP
          BX3    X0+X2       ORD + INTR 
          BX6    X3+X1       + (ATTR) + (SMOD)
  
 ADT8     SB6    B6-B1       POP ELEMENT STACK
          SA7    ATTR 
          SA6    B6-B1       ESTACK.TOP = NEW INTERMEDIATE
  
*         REFORM. 
*         SET RESULTANT MODE IN OPERATOR WORD THE SAME AS THE 
*         INTERMEDIATE JUST PUT INTO ELEMENT STACK FOR RESULTS OF THIS
*         TURPLE. 
*         EMIT TURPLE TO PARSED FILE. 
  
          SA2    SMOD 
          SA3    SOPR 
          SX2    X2          EXTRACT (X2) = DOMINANT MODE 
          LX2    SP.MODEP 
          BX6    X2+X3       (ADTA) = TURPLE HEADER 
          SA6    ADTA 
          EMIT   ADTA,*      EMIT TURPLE TO IL
          =B2    -1 
          EQ     EXIT.       EXIT...
  
 ADTA     BSS    1           SAVE REGISTER VALUE
 CBB      SPACE  4,10 
**        CBB -  CONVERT TO BASE/BIAS 
* 
*         ENTRY  (X5) = OPERAND (TP.FORMAT) 
* 
*         EXIT   (X5) = OPERAND (BASE/BIAS FORMAT)
* 
*         CALLS BBC 
* 
*         USES   X0 
  
  
 CBB      SUBR               ...ENTRY/EXIT... 
          LX0    X5 
          SBIT   X0,TP.EQVP 
          PL     X0,EXIT.    IF NOT EQUIVALENCED
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX0    -X0*X5      EXTRACT MODE 
          LX5    TP.MODEP 
          SX0    X0-M.CHAR
          ZR     X0,EXIT.    IF TYPE CHARACTER
          CALL   BBC         CONVERT TO BASE/BIAS 
          EQ     EXIT.
 CDI      SPACE  4,10 
**        CDI - CHECK DATA INTERFERENCE.
* 
*         CHECKS ONE ELEMENT IN A CHARACTER EXPRESSION TO DETERMINE 
*         IF IT OVERLAPS THE TARGET VARIABLE BEING STORED TO. 
* 
*         ENTRY  (X5) = SOURCE CHARACTER OPERAND. 
* 
*         EXIT   WARNING DIAGNOSTIC ISSUED IF OVERLAP DETECTED. 
* 
*         USES   X-ALL, B-NONE, A-1,2,6,7.
* 
*         CALLS  SCB. 
  
  
 CDI00    WARN   E.AT11      ISSUE WARNING
  
 CDIX     BSS    0           ... EXIT ... 
          SA1    CDIA        RESTORE B2 
          SA2    A1+B1       RESTORE B7 
          SB2    X1 
          SB7    X2 
  
 CDI      SUBR   -           ... ENTRY ...
          SX6    B2          SAVE B2  (USED BY BBC) 
          SX7    B7          SAVE B7
          SA6    CDIA 
          SA7    A6+B1
          SX4    B1          INDICATE SOURCE OPERAND
          CALL   SCB         SET CHARACTER BOUNDS 
          SA1    SCBB        GET TARGET LOWER BOUND 
          SA2    SCBC        GET TARGET UPPER BOUND 
          ZR     X6,CDI50    IF VARIABLE L.B. 
          ZR     X7,CDI60    IF VARIABLE U.B. 
          IX0    X1-X6
          PL     X0,CDI40    IF TARGET L.B. >= L.B. 
          IX2    X2-X6
          PL     X2,CDI00    IF TARGET U.B. >= L.B. 
          EQ     CDIX        EXIT 
  
 CDI40    ZR     X0,CDI00    IF TARGET L.B. = L.B.
          IX0    X7-X1
          PL     X0,CDI00    IF U.B. >= TARGET L.B. 
          EQ     CDIX        EXIT 
  
 CDI50    IX0    X7-X1
          MI     X0,CDIX     IF U.B. < TARGET L.B.
          IX0    X2-X7
          MI     X0,CDIX     IF TARGET U.B. < U.B.
          EQ     CDI00       GO ISSUE WARNING 
  
 CDI60    BX7    X6 
          EQ     CDI50       SET U.B. = L.B.
  
 CDIA     BSS    2           REGISTER SAVE AREA 
 CIL      SPACE  4,10 
**        CIL - CHECK ILLEGAL USE OF LEVEL 3 NAME.
* 
*         ENTRY  (X3) = SYMTAB (WB) SHIFTED TO WB.ARY IN SIGN.
* 
*         EXIT   DIAGNOSTIC OUTPUT FOR ILLEGAL USAGE. 
* 
*         USES   A1   X2-3   B3.
  
  
 CIL      SUBR               ...ENTRY/EXIT... 
          SBIT   X3,WB.LEVP/WB.ARYP 
          PL     X3,EXIT.    IF NOT LEVEL NAME
          LX3    WB.LEVP+1-WB.LEVNP    RIGHT-JUSTIFY LEVEL NUMBER 
          MX2    -WB.LEVNL
          BX2    -X2*X3      (X2) = LEVEL NUMBER
          SX2    X2-3 
          NZ     X2,EXIT.    IF NOT LEVEL 3 
  
*         HERE IF LEVEL 3 TAG.
  
          SA3    ARGMODE
          HX3    AM.LEV3
          MI     X3,EXIT.    IF LEVEL 3 PERMITTED 
          SA3    DATFLG 
          NZ     X3,EXIT.    IF IN DATA STATEMENT 
  
*         HERE IF ILLEGAL USE OF LEVEL 3. 
  
          FATAL  E.LV11 
          EQ     EXIT.
 CLC      SPACE  4,10 
**        CLC - COERCE LENGTH OF CHARACTER RESULT.
* 
*         ENTRY  (X1) = DLEN, DESIRED LENGTH. 
*                (X5) = OI, OPERAND TO BE COERCED.
*         METHOD -- 
*           IF LEN(OI) IS KNOWN, AND = DLEN  THEN 
*                RETURN (OI)
*           ELSE  (* MUST TRUNCATE OR PAD *)
*                WINC = (DLEN+9) / 10 
*                FCA = 10 * (N.CT)
*                (N.CT) = (N.CT) + WINC 
*                PUSH  OI 
*                CALL  ECS (S=CT, NDX, DL)
*                RO = ADT (STR.H, OI, T2) 
*           ENDIF 
* 
*         EXIT   (X5) = CONVERTED OPERAND.
* 
*         USES   ALL BUT:  A0.  B4-6. 
*                (SOPR), (SMOD) 
*         CALLS  ADT, ECS.
  
  
 CLC      SUBR   0           ENTRY/EXIT...
          BX7    X5 
          SA7    B6          PUSH  OI 
          SB6    B6+B1
          BX4    X1 
          BX1    X5 
          RJ     GOL         GET OPERAND LENGTH 
          BX1    X4 
          MI     X7,CLC10    IF OPERAND LENGTH NOT DETERMINABLE 
          IX0    X4-X7
          ZR     X0,CLC80    IF OPERAND LENGTH = DLEN 
  
 CLC10    SA2    N.CT        NDX = N.CT 
          BX7    X1 
          CW     X3,X7       WINC = (DLEN+9) / 10 
          IX6    X2+X3       (N.CT) = (N.CT) + WINC 
          SA6    A2 
*                            T2 = ECS (DLEN, NDX, S=CT) 
          SA3    S=CT 
          RJ     ECS         EMIT CHARACTER SUBSTRING 
          SA3    STRHOP 
          SA5    B6-B1       (2OP) = T2 
          BX6    X3 
          SA4    A5-B1       (1OP) = OI 
          SA6    SOPR 
          RJ     ADT         PUSH   ADT (V=STR.H, OI, T2) 
  
 CLC80    SA5    B6-B1
          SB6    B6-B1       POP  RO
**FV             NEED TO RETURN INDICATION OF (TRUNC, EQ, PAD)
          EQ     EXIT.
 CLM      SPACE  4,10 
**        CLM - COERCE MODE AND CHARACTER LENGTH. 
* 
*         ENTRY  (X1) = CHARACTER LENGTH (IMMATERIAL UNLESS 
*                            (X6) = M.CHAR).
*                (X5) = OPERAND TO BE COERCED.
*                (X6) = DM, DESIRED MODE. 
* 
*         EXIT   SAME AS CMR. 
* 
*         USES   ALL BUT:  A0.  B4-6. 
*                (SOPR) 
*         CALLS  CLC, CMR.
  
  
 CLM      SUBR   0           ENTRY/EXIT...
          BX7    X1 
          SA7    CLMA 
          RJ     CMR         COERCE MODE OF RESULT
          SA1    SMOD 
          NZ     B7,EXIT.    IF ERROR IN CONVERSION 
          SX6    X1-M.CHAR
          NZ     X6,EXIT.    IF DOMINANT MODE NOT CHARACTER 
          SA1    CLMA 
          RJ     CLC         COERCE CHARACTER LENGTH
          SB7    B0          (**** TEMP ****)  INDICATE NO ERROR
**FV             NEED ERROR FOR CONTEXTS WHERE PADDING IS ILLEGAL.
          EQ     EXIT.
  
 CLMA     BSS    1
 CMR      SPACE  4,10 
**        CMR - COERCE MODE OF RESULT.
* 
*         VERIFY LEGALITY OF RESULT MODE, AND SELECT CONVERSION.
* 
*         ENTRY  (X5) = OPERAND TO BE COERCED.
*                (X6) = DM, DESIRED MODE. 
* 
*         EXIT   (X5) = CONVERTED OPERAND.
*                (B7) .NZ. = ADDRESS OF ERROR MESSAGE, WHEN CONVERSION
*                            IS ILLEGAL.  (X5) = ORIGINAL OPERAND.
*                (B7) .ZR. = CONVERSION OKAY. 
*                (SMOD) = DM. 
*                (SOPR)  DESTROYED. 
* 
*         USES   ALL BUT A0, B4, B5, B6.
* 
*         CALLS  ADT, KCV, LCT, NBC 
  
  
 CMR      SUBR   =           ...ENTRY/EXIT... 
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX4    -X0*X5      (X4) = AM = ACTUAL MODE OF OPERAND 
          SA2    X4+F.MODC   FETCH ROW (AM) OF MODE CONVERSION MATRIX 
          BX1    X0*X5
          IX7    X1+X6       RMO = SAME OPERAND WITH DESIRED MODE 
          SA6    SMOD 
          LX5    TP.MODEP 
          LX7    TP.MODEP 
          SA7    B6          ESTACK(TOP) = RMO
          SX7    X6 
          LX7    3           (B2) = 8 * DM
          SB2    X7 
          MX0    -8 
          AX1    B2,X2       SLIDE ROW TO DOMINANT COLUMN 
          BX3    -X0*X1      SKO = MODC (X7, DM)
          ZR     X3,CMR60    IF NO CONVERSION NECESSARY 
          SX1    X3-1S8+1 
          ZR     X1,CMR90    IF MODE CONVERSION ERROR 
          BX1    X5 
          CALL   LCT         LOAD BINARY OF CONSTANT
          ZR     B2,CMR30    IF NOT CONSTANT
          SA1    SMOD 
          CALL   KCV         CONVERT CONSTANT VALUE 
 .T       IFEQ   TEST,ON,1
          MI     B2,"BLOWUP" IF ILLEGAL CONVERSION (WE ALREADY CHECKED) 
          LE     B2,CMR60    IF OLD VALUE IS CORRECT
          CALL   NBC         ENTER BINARY OF CONSTANT 
          BX5    X6 
          SB7    B0 
          EQ     EXIT.
  
*         LEGAL NON-NULL CONVERSION, OPERAND NOT CONSTANT.
*         EMIT TURPLE.
*                (X3) = SKO = SKELETON OFFSET.
  
 CMR30    SA2    MCVOP
          LX3    SP.SKELP 
          IX6    X2+X3       (TH.SKEL) = BASE + OFFSET
          SB6    B6+2        ADVANCE ESTACK FOR ADT 
          SA6    SOPR 
          IX3    X2+X3       (X3) = (SOPR)
          RJ     ADT         ADD CONVERSION TURPLE
          SB6    B6-1        REMOVE RESULT FROM ESTACK
  
 CMR60    SA5    B6          RETURN (X5) = COERCED RESULT 
          SB7    B0 
          EQ     EXIT.
  
 CMR90    SA1    X6+MOD.DPC 
          SA2    X4+MOD.DPC 
          BX7    X1          SET (FILL.3) = DM       /* DESIRED 
          LX6    X2          SET (FILL.2) = AM       /* ACTUAL
          SA7    FILL.3 
          SB7    E.AT19      ** <AM> CANNOT BE CONVERTED TO <DM>
          SA6    A7-B1
          EQ     EXIT.
 COR      SPACE  4,10 
**        COR - CHECK IF INPUT OPERAND IS REDUCIBLE.
* 
*         IF THE INPUT OPERAND IS THE RESULT INTERMEDIATE OF THE VERY 
*         LAST TURPLE EMITTED, THEN IT IS POTENTIALLY REDUCIBLE.
* 
*         ENTRY  (X1) = INPUT OPERAND.
* 
*         EXIT   (X0) = 0, OPERAND IS INPUT.
*                (X7) = (T=PAR) - Z=TURP
*                (X1) = (LASTAD). 
*                (A2) -> T=PAR. 
* 
*         USES   A1,A2  X0
  
  
 COR      SUBR               ENTRY/EXIT...
          BX0    X1 
          SBIT   X0,TP.INTRP
          PL     X0,EXIT.    IF NOT INTERMEDIATE
          SA2    T=PAR
          HX1    TP.ORD 
          AX1    TP.ORDP
          SX7    X2-Z=TURP
          IX0    X1-X7
          SA1    LASTAD 
          EQ     EXIT.
 DBE      SPACE  4,10 
**        DBE -  DIMENSION BOUND ERROR OUTPUT 
* 
*         ENTRY  (B7) = ERROR ADDRESS 
* 
*         USES   A1,A2,A6,A7  X1,X2,X6,X7  B7 
* 
*         CALLS  PDM
  
  
 DBE      SUBR               ...ENTRY/EXIT... 
          SA1    CDBB 
          =A2    A1+1 
          LX7    X1 
          LX6    X2 
          SA7    FILL.
          =A6    A7+1 
          FATAL  B7 
          EQ     EXIT.
 DDC      SPACE  4,10 
**        DDC - DIAGNOSE DOUBLE AND COMPLEX OPERANDS IN AN EXPRESSION.
* 
*         CALLED TO ISSUE AN ANSI DIAGNOSTIC IF DOUBLE PRECISION
*         AND COMPLEX OPERANDS ARE MIXED IN AN EXPRESSION.
* 
*         ENTRY  (X4) = 1OP 
*                (X5) = 2OP 
* 
*         EXIT   ANSI DIAGNOSTIC ISSUED IF NECESSARY. 
* 
*         CALLS  ANSI= .
* 
*         USES   X - 0,1,6  B - 7.
  
  
 DDC      SUBR               ENTRY/EXIT...
          MX0    -TP.MODEL
          BX6    X4+X5
          BX1    X4*X5
          LX6    -TP.MODEP
          LX1    -TP.MODEP
          BX6    -X0*X6 
          BX1    -X0*X1 
          ERRNZ  M.DBL-4
          ERRNZ  M.CPLX-M.DBL-1 
          SB7    X6-M.CPLX
          NZ     B7,EXIT.    IF NEITHER 1OP NOR 2OP IS COMPLEX
          SB7    X1-M.DBL 
          NZ     B7,EXIT.    IF NEITHER 1OP NOR 2OP IS DOUBLE 
          ANSI   E.ANS4      ** MIXTURE OF DOUBLE AND COMPLEX OPNDS 
          EQ     EXIT.
 DOA      SPACE  4,20 
**        DOA - DETERMINE OPERAND ADDRESSABILITY. 
* 
*         THERE ARE CONTEXTS IN WHICH AN OPERAND IS REQUIRED TO BE
*         CAPABLE OF BEING A STORE TARGET -- I.E., IT MUST POSESS AN
*         ADDRESS.  FROM A FORTRAN LANGUAGE STANDPOINT, THIS MEANS THAT 
*         IT CANNOT BE AN EXPRESSION NOR A CONSTANT.  ALSO, IN AN ACTUAL
*         ARGUMENT LIST, WHILE OPERANDS DO NOT HAVE TO BE ADDRESSABLE,
*         WE WANT TO KNOW WHEN THEY ARE, SO THAT POTENTIAL DEFINITION 
*         CAN BE NOTED. 
* 
*         SINCE ARRAY ELEMENT AND SUBSTRING REFERENCES ARE REPRESENTED
*         BY COMBINATIONS OF TURPLES, DETECTING ADDRESSABLE OPERANDS
*         IS COMPLEX ENOUGH TO WARRANT THIS SUBROUTINE. 
* 
*         ENTRY  (X5) = OPERAND.
* 
*         EXIT   (X6) .NZ. = OPERAND IS NOT ADDRESSABLE.
*                (FILL.3) = ERRLIT FOR WHY NOT -- 
*                         = 'CONSTANT' OR 'EXPRESSION'. 
*                (X5) = BLOWUP OPERAND, WITH MODE OF ORIGINAL.
* 
*         ELSE   (X6) .ZR. = OPERAND IS IN SYMTAB, AND IS NOT A LABEL.
*                (X0) = MODE. 
*                (X5) = PRESERVED.
*                (A2,X2) = SYMTAB (WB) FOR REFERENCED SYMBOL. 
*                (X1) = SYMTAB (WB), WITH (WB.VAR) EXPOSED. 
*                IF (WB.VAR) IS SET, THEN OPERAND IS IN FACT A VALID
*                            STORE-TARGET.
* 
*         USES   A1-3,6-7.  X0-3,5-7.  B2,7.
*         CALLS  LCH. 
  
  
 DOA      SUBR   =           ENTRY/EXIT...
          BX1    X5 
          CALL   LCH         LOAD CONSTANT TEST 
          BX2    X5 
          SB7    ERL=CON
          NZ     B2,DOA8     IF CONSTANT
          SB7    ERL=XPR
          HX2    TP.EXPR
          MI     X2,DOA8     IF EXPRESSION
  
*         OPERAND IS NOT PRO FORMA EVIL.  NOW FIGURE OUT WHAT IT IS,
*         AND HOW TO GET TO IT'S SYMTAB ENTRY.
  
          LX1    X5 
          LX2    TP.EXPRP-TP.INTRP
          PL     X2,DOA6     IF NOT INTERMEDIATE
          HX1    TP.ORD 
          AX1    -TP.ORDL 
 .T       IFEQ   TEST,ON
          MI     X1,"BLOWUP" IF NEGATIVE ORDINAL
          SA3    T=PAR
          IX7    X1-X3
          PL     X7,"BLOWUP" IF ORDINAL .GE. TABLE LENGTH 
 .T       ENDIF 
          SA3    T.PAR
          IX7    X1+X3
          =A3    X7+OR.OPR
          =A1    A3-OR.OPR+OR.1OP 
          LX2    TP.INTRP-TP.ARRP 
          MI     X2,DOA6     IF ARRAY ELEMENT 
          HX3    TH.SKEL
          AX3    -TH.SKELL
          SX7    V=SUBST
          IX6    X3-X7
          NZ     X6,DOA8     IF NOT SUBSTRING INTERMEDIATE
          BX2    X1 
          HX2    TP.INTR
          PL     X2,DOA6     IF SUBSTRING (1OP) NOT FURTHER INTERMEDIATE
  
*         (X5) IS A INTERMEDIATE POINTING TO A SUBSTRING TURPLE.
*         (1OP) OF THE SUBSTRING IS AN INTERMEDIATE, SO WE MUST 
*         PENETRATE ONE LEVEL FURTHER INTO THE PARSED FILE.  IT 
*         MUST BE AN ARRAY ELEMENT BEING SUBSTRINGED. 
  
          HX1    TP.ORD 
          AX1    -TP.ORDL 
 .T       IFEQ   TEST,ON
          MI     X1,"BLOWUP" IF NEGATIVE ORDINAL
          SA3    =XT=PAR
          IX7    X1-X3
          PL     X7,"BLOWUP" IF ORDINAL .GE. TABLE LENGTH 
 .T       ENDIF 
          SA3    T.PAR
          IX7    X1+X3
          =A1    X7+OR.1OP
          LX2    TP.INTRP-TP.ARRP 
          PL     X2,DOA8     IF NOT ARRAY ELEMENT INTERMEDIATE
  
*         RETRIEVE SYMBOL TABLE INFO.  REJECT STATEMENT LABELS. 
*                (X1)[TP.ORD] = ORDINAL OF SYMBOL.
  
 DOA6     HX1    TP.ORD 
 .T       IFEQ   TEST,ON
          MI     X1,"BLOWUP" IF ILL ORDINAL 
          BX3    X1 
          LX3    TP.ORDL+TP.ORDP
          HX3    TP.ORD 
          AX3    -TP.ORDL    (X3) = SYMORD OF OPERAND 
          SA2    T=SYM
          LX7    X3,B1
          IX7    X3+X7
          ERRNZ  3-Z=SYM
          IX7    X7-X2
          PL     X7,"BLOWUP" IF ORDINAL .GE. SYMTAB LENGTH
 .T       ENDIF 
  
          AX1    -TP.ORDL 
          SA2    T.SYM
          LX7    X1,B1
          =B7    X2+WB.W
          IX3    X7+X1       (X3) = SYMTAB INDEX
          ERRNZ  3-Z=SYM
          SX6    B0 
          SA2    X3+B7       FETCH (A2,X2) = SYMTAB (WB)
          BX1    X2 
 .T       IFEQ   TEST,ON
          HX1    WB.LAB 
          MI     X1,"BLOWUP" IF STATEMENT LABEL 
          LX1    WB.LABP+1
 .T       ENDIF 
          HX1    WB.VAR 
          EQ     EXIT.
  
*         OPERAND IS EXPRESSION OR CONSTANT.  SET UP ERROR LITERAL, 
*         AND RETURN PARAMETERS.
  
 DOA8     SA1    B7 
          BX6    X1          (FILL.3) = WORD FOR DIAGNOSTIC 
          SA2    S=BU 
          BX5    X0 
          LX2    TP.ORDP
          LX5    TP.MODEP 
          BX5    X2+X5       INVENT BLOWUP OPERAND
          SA6    FILL.3 
          EQ     EXIT.
 ECC      SPACE  4,10 
**        ECC - EMIT CHARACTER CONSTANT.
* 
*         SINCE AN IL OPERAND DOES NOT HAVE ENOUGH FIELDS TO
*         COMPLETELY REPRESENT A CHARACTER CONSTANT (SYMORD, BIAS,
*         AND LENGTH), SUCH OPERANDS MUST BE EMITTED AS SUBSTRING 
*         REFERENCES.  SEE ECS FOR DETAILS. 
* 
*         NOTE - CALLERS OUTSIDE PAR SHOULD BE PARTICULARLY CAREFUL 
*                OF ESTACK AND (B6) ON ENTRY AND RETURN.
* 
*         ENTRY  (X1) = CHARACTER LENGTH
*                (X2) = CHARACTER INDEX 
*                (B6) -> TOP+1 OF ESTACK. 
* 
*         EXIT   RESULT ON TOP OF ESTACK. 
*                ((B6)-1) -> RESULT.           /* ON TOP OF ESTACK
*                ESTACK TOP HAS BEEN ADVANCED BY 1. 
* 
*         CALLS  ECS. 
  
  
 ECC      SUBR   =           ENTRY/EXIT...
          SA3    S=CON
          RJ     ECS         EMIT CHARACTER SUBSTRING 
          EQ     EXIT.
 ECS      SPACE  4,20 
**        ECS - EMIT CHARACTER SUBSTRING. 
* 
*         EMITS SUBSTRING REFERENCE TO A COMPILER INVENTED SYMBOL.
* 
*         ENTRY  (X1) = LENGTH, IN CHARACTERS.
*                (X2) = INDEX, IN WORDS INTO SYMBOL (SYO) 
*                (X3) = SYO = ORDINAL OF SYMBOL.
*                (B6) -> TOP+1 OF ESTACK. 
*         THE DETAILS ARE --
*                FIRST  = 10 * INDEX + 1
*                LAST   = FIRST + LENGTH - 1
*                PUSH   SYO 
*                PUSH   FIRST 
*                PUSH   LAST
*                T1 = ADT (V=COLON,  FIRST, LAST) 
*                T2 = ADT (V=SUBST,  SYO,   T1) 
*                ESTACK[TOP] = T2                     /* PER ADT
* 
*         EXIT   RESULT ON TOP OF ESTACK. 
*                ((B6)-1) -> RESULT.           /* ON TOP OF ESTACK
*                ESTACK TOP HAS BEEN ADVANCED BY 1. 
*                (SMOD) = M.CHAR
* 
*         NOTE - CALLERS OUTSIDE PAR SHOULD BE PARTICULARLY CAREFUL 
*                OF ESTACK AND (B6) ON ENTRY AND RETURN.
* 
*         CALLS  ADT. 
  
  
 ECS      SUBR   0           ENTRY/EXIT...
          =X6    M.CHAR 
          SX5    B1 
          LX3    TP.ORDP
          SA6    SMOD 
          WC     X4,X2       FCA = 10 * INDEX 
          LX6    TP.MODEP 
          BX7    X3+X6       FORM (3OP) = [TP]SYO 
          IX5    X4+X5       FIRST = FCA + 1
          CLAS=  X0,TP,(SHRT),INT 
          SA3    COLOP
          IX6    X4+X1       LAST = FCA + LENGTH
          LX5    TP.BIASP 
          SA7    B6          PUSH (SYO) 
          BX4    X0+X5       FORM (1OP) = FIRST 
          LX6    TP.BIASP 
          BX7    X3          (SOPR) = (COLOP) 
          SB6    B6+3        ADVANCE FOR PUSH (SYO, FIRST, LAST)
          SA7    SOPR 
          BX5    X6+X0       FORM (2OP) = LAST
          RJ     ADT         EMIT COLON TURPLE
  
          SA3    SUBST
          SA5    B6-B1       (4OP) = RESULT OF COLON TURPLE 
          BX7    X3 
          SA7    SOPR 
          SA4    A5-B1       (3OP) = SYMORD (SYO) 
          RJ     ADT         FINISH SUBSTRING TURPLE
          EQ     EXIT.
 EMT      SPACE  4,10 
**        EMT - EMIT TURPLE TO TABLE. 
* 
*         THIS ROUTINE IS TO BE USED TO OUTPUT ALL TURPLES. 
*         TAKES CARE OF SETTING LINE NUMBER, ETC. 
* 
*         ENTRY  (B3) = OPERATOR SELECTOR.  IS EITHER --
*                     =  1/ 1,  1/ T,  16/ ADDRESS OF SETOP WORD,  OR --
*                     =  1/ 0,  1/ T,  2/ 0,  2/DD,  12/ SKELETON.
*                (T) = 0 :  EMIT TO (T.PAR),
*                    = 1 :  EMIT TO TABLE IN (A1).
*                (DD) = DUCABILITY,  0 = NONE,
*                                    1 = FIRST, 
*                                    2 = SECOND,
*                                    3 = BOTH.
*                (A1,X1) = TABLE *TURPLE* IS TO BE ADDED TO, IF (T) = 1.
*                (X4) = (1OP).
*                (X5) = (2OP).
* 
*         EXIT   (A1,X1) = TABLE *TURPLE* WAS ADDED TO. 
* 
*         USES   A2-3,A6-7   B2-3,B7   X0-3,X6-7. 
*         CALLS  ALLOC, SN.EMT .
  
  
 EMT      SUBR   =           ENTRY/EXIT...
          SB2    B3+B3
          MI     B2,EMT2     IF TABLE PRESET IN (A1)
          SA1    T.PAR
 EMT2     ALLOC  A1,Z=TURP   RESERVE ROOM FOR TURPLE
          SX2    B3 
          MX0    -16
          LX7    X5 
          BX3    -X0*X2      ISOLATE (POSSIBLE) SETOP ADDRESS 
          =A7    B7-Z=TURP+OR.2OP 
          LX6    X4 
          =A6    A7-OR.2OP+OR.1OP 
          MI     B3,EMT4     IF SETOP ADDRESS GIVEN 
          MX0    -12
          BX2    -X0*X2      ISOLATE SKELETON ORDINAL 
          AX3    12 
          SA3    X3+OPDUM 
          LX2    SP.SKELP 
          BX3    X3+X2
          EQ     EMT5 
  
 EMT4     SA3    X3+         FETCH OPERATOR WORD
 EMT5     CLAS=  X2,SP,(SKEL,1ATR,MODC) 
          BX6    -X2*X3      CLEAR PASS 1 FIELDS FROM OPERATOR
          MX2    -SP.SKELL
          LX3    -SP.SKELP
          BX2    -X2*X3      EXTRACT SKELETON INDEX 
          LX2    TH.SKELP 
          BX6    X2+X6       REPOSITION SKELETON INDEX
          =A6    A6-OR.1OP+OR.OPR 
          LX3    X6          TH. FORMAT OF HEADER 
  
 .T       IFEQ   TEST,ON     DUMP EMITTED TURPLE
          SA2    CO.SNAP
          HX6    TH.SKEL
          SX7    =XZ.SKCR 
          AX6    -TH.SKELL
          IX7    X6-X7
          LX2    1RQ
          BX7    -X7+X6      .MI. IFF NOT (0 .LE. SKEL .LT. MAX)
          PL     X7,EMT8     IF SKEL OKAY 
          FATAL  E.ZEMT      ** SKEL ILL
 EMT8     BX2    X2+X7
          PL     X2,EMT9     IF NOT ((SNAP=Q) OR (SKEL ILL))
          SX0    EMT
          CALL   SN.EMT 
 EMT9     MI     X7,"BLOWUP" IF SKEL ILL
 .T       ENDIF 
          EQ     EXIT.
 FAT      SPACE  4,10 
**        FAT -  FLUSH ARGUMENT TURPLES.
* 
*         ENTRY  (X4) = LENGTH OF TURPLES TO BE KEPT. 
*                (T.IOARG) = FLUSHED TURPLES AT THE END.
* 
*                (T=IOARG) = DECREMENTED TO ACCOUNT FOR FLUSHED TURPLES.
*                        = SAME AS (X4) ON ENTRY. 
*                *TURPLES* MOVED TO PARSED TABLE. 
* 
*         USES   A1-4,A6-7   X0-4,X6-7   B2-3,B7. 
* 
*         CALLS  ALC, MVE=. 
  
  
 FAT      SUBR   =           ENTRY/EXIT...
          SA2    T=IOARG
          IX0    X2-X4       (X0) = WORD COUNT OF TURPLES TO BE MOVED 
          ZR     X0,EXIT.    IF NO TURPLES TO MOVE
 .T       IFEQ   TEST,ON,1
          MI     X0,"BLOWUP"       IF FLUSH REQUEST EXCEEDS TABLE LENGTH
          ALLOC  T.PAR,X0 
          SA2    T.IOARG
          SA1    T=IOARG
          BX6    X4 
          IX2    X4+X2       (X2) = SOURCE ADDRESS
          IX1    X1-X4       (X1) = WORD COUNT OF TURPLES TO BE MOVED 
          SHRINK A1,X6       REDUCE ARGUMENT TABLE SIZE 
          SX0    B7 
          IX3    X0-X1       (X3) = DESTINATION ADDRESS 
          MOVE   X1,X2,X3    MOVE TURPLES TO PARSED TABLE 
          EQ     EXIT.
 FSA      SPACE  4,10 
**        FSA - FIND SYMBOL ATTRIBUTES. 
* 
*         ENTRY  (X1) = OPERAND (TP. FORMAT). 
* 
*         EXIT   (B7) .LT. 0 IF OPERAND NOT IN SYMTAB.
*                "BLOWUP" IF STATEMENT LABEL. 
*                (X0) = ORDINAL OF SYMBOL.
*                (X1) = SYMTAB (WB) WITH *VAR* BIT EXPOSED. 
*                (A2, X2) = SYMTAB ATTRIBUTE WORD (WB). 
*                (B7) = SYMTAB (WB) INDEX.
* 
*         USES   A1-2   X0-2. 
  
  
 FSA      SUBR               ENTRY/EXIT...
          CLAS=  X2,TP,(INTR,SHRT,GL) 
          BX0    X2*X1
          SB7    -B1
          NZ     X0,EXIT.    IF OPERAND NOT A SYMBOL
          MX2    -TP.ORDL 
          LX1    -TP.ORDP 
          BX0    -X2*X1      EXTRACT (X0) = SYMTAB ORDINAL
          LX2    X0,B1
          IX1    X2+X0       (X1) = INDEX = SYMORD * Z=SYM
          ERRNZ  3-Z=SYM
          =B7    X1+WB.W     RETURN (B7) = SYMTAB (WB) INDEX
 .T       IFEQ   TEST,ON
          SA2    T=SYM
          IX2    X1-X2
          PL     X2,"BLOWUP"       IF (INDEX) .GE. (SYMTAB LENGTH)
 .T       ENDIF 
          SA1    T.SYM
          SA2    X1+B7       FETCH SYMTAB (WB)
          BX1    X2 
 .T       IFEQ   TEST,ON
          HX1    WB.LAB 
          MI     X1,"BLOWUP"       IF STATEMENT LABEL 
          LX1    WB.LABP-WB.VARP
 .T       ELSE
          HX1    WB.VAR 
 .T       ENDIF 
          EQ     EXIT.
 GOL      EJECT 
**        GOL - GET CHARACTER OPERAND LENGTH. 
* 
*         ENTRY  (X1) = OPD, CHARACTER OPERAND
* 
*         EXIT   (X6) = MI IFF OPERAND PASSED LENGTH, ELSE PL 
*                (X7) = MI IFF OPERAND LENGTH NOT EXACTLY KNOWN,
*                       ELSE = LENGTH IN CHARACTERS 
* 
*         PRESERVES A4,X4 
  
 GOL      SUBR   =           ENTRY/EXIT...
 .T       IFEQ   TEST,ON
          BX5    X1 
          HX5    TP.SHRT
          MI     X5,"BLOWUP" IF SHORT CON 
          LX5    TP.SHRTP+1-TP.MODEP
          MX0    -TP.MODEL
          BX0    -X0*X5 
          SB7    X0-M.CHAR
          NZ     B7,"BLOWUP" IF NOT CHARACTER OPERAND 
 .T       ENDIF 
  
          SX6    0
          SA6    GOLA        FLAG NOT SUBSTRING 
  
 GOL10    BX5    X1 
          HX5    TP.INTR
  
 GOL20    MX0    -TP.ORDL 
          LX1    -TP.ORDP 
          BX1    -X0*X1 
          MI     X5,GOL30    IF OPERAND IS INTERMEDIATE 
          CALL   GCL         GET CHARACTER LENGTH 
          BX6    X1+X2       CHAR LENGTH OR -0
          SA1    GOLA 
          BX7    X1+X6       IF SUBSTRING, NOT EXACT LENGTH 
          EQ     EXIT.
  
*         OPERAND IS INTERMEDIATE.  MAY BE SUBSTRING, ARRAY, FUNCTION 
*         OR CONCATANATION. 
  
 GOL30    SA2    T.PAR
          =B2    X2+OR.OPR
          SA3    B2+X1       OPERATOR WORD
          BX6    -X3
          HX6    TH.SKEL
          AX6    -TH.SKELL   EXTRACT (SIGN EXTEND) NEGATIVE SKEL ORDINAL
          SB7    X6 
          =A1    A3+OR.1OP-OR.OPR 
          MX5    0
          SX2    B7+V=CAT 
          SX0    B7+V=SUBST 
          ZR     X2,GOL50    IF CONCAT
          NZ     X0,GOL20    IF NOT SUBST. (MUST BE ARRAY OR FUNCTION)
  
*         PROCESS SUBSTRING.
*         IF SUBSTRING IS OF CONSTANT LENGTH, FINE. OTHERWISE 
*         WE STILL NEED TO KNOW IF BASE VARIABLE (OR ARRAY) IS FIXED
*         OR PASSED-LENGTH. 
  
          BX6    X1 
          SA6    GOLB        SAVE SUBSTRING 1OP 
          =A3    A1+OR.2OP-OR.1OP 
          MX0    -TP.ORDL 
          =B2    B2+OR.1OP-OR.OPR 
          LX3    -TP.ORDP 
          BX6    -X0*X3 
          SA1    B2+X6       1OP OF COLON 
          =A3    A1+OR.2OP-OR.1OP  2OP OF COLON 
          CALL   LCT         EVALUATE 1OP 
          NE     B2,B1,GOL40 IF NOT CONSTANT
          BX1    X3 
          SX3    X6-1        FIRST - 1
          CALL   LCT         EVALUATE 2OP 
          IX7    X6-X3       SUBSTRING LENGTH 
          BX6    X7 
          EQ     B2,B1,EXIT. IF CONSTANT
  
 GOL40    SA1    GOLB        RESET OPERAND TO SUBSTRING SYMBOL
          MX6    60 
          SA6    GOLA        FLAG SUBSTRING 
          EQ     GOL10       REEVALUATE 
  
*         CONCATANATION.  FOR NOW, WE DETERMINE FIXED/PASSED LENGTH 
*         ONLY.  EVENTUALLY WE WANT TO RETURN LENGTH[TH] ALSO.
  
 GOL50    SBIT   X3,TH.PLCP 
          MX7    60          EXACT LENGTH NOT KNOWN 
          BX6    X3          FIXED/PASSED LENGTH FLAG 
          EQ     EXIT.
  
 GOLA     BSS    1
 GOLB     BSS    1
 OMC      SPACE  4,30 
**        OMC - OUTPUT MODE CONVERSION. 
* 
*         ENTRY  (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
*                (SMOD) = 24/ 0,  18/ DOP,  18/ DM
* 
*         EXIT   (X3) = PRESERVED.
*                (X4) = MODE CONVERSION INTERMEDIATE IF DOMINANT MODE 
*                            OPERAND =2, OTHERWISE PRESERVED. 
*                (X5) = MODE CONVERSION INTERMEDIATE IF DOMINANT MODE 
*                            OPERAND=1, OTHERWISE PRESERVED.
*                (SMOD) = 42/ 0,  18/ DM
* 
*         USES   CANNOT DESTROY   B4-6   X3-5.
*                X4,X5 MAY BE REPLACED BY MODE CONV. INTERMEDIATE.
* 
* 
*                DOP = DOMINANT OPERAND --
*                               = 0  NO CONVERSION. 
*                               = 1  CONVERT ARG IN X5 TO DOMINANT MODE.
*                               = 2  CONVERT ARG IN X4 TO DOMINANT MODE.
*                DM = DOMINANT MODE.
  
  
 OMC      SUBR   =           ENTRY/EXIT...
          SA1    SMOD 
          SX6    X1          (X6) = DOMINANT MODE 
          AX1    18 
          ZR     X1,EXIT.    IF NO CONVERSION REQUIRED
  
          BX7    X3 
          SA7    OMCA        SAVE (X3)
          BX7    X5 
          SA7    A7+B1       SAVE (2OP) = (X5)
          BX7    X4 
          SA7    A7+B1       SAVE (1OP) = (X4)
          SA2    X1+OMC.RC
          SA5    X1+OMCA     (X5) = OPERAND TO CONVERT
          BX7    X2          PLUG RESTORE CODE
          SA7    OMC.RR 
          RJ     CMR         COERCE MODE OF RESULT
          NZ     B7,"BLOWUP"       IF CONVERSION NOT POSSIBLE 
          SA3    OMCA 
          BX6    X5 
          LX7    X3 
          SA6    B6-B1       SET ESTACK[TOP] = NEW RESULT 
          SA7    SOPR        RESTORE (SOPR) = OPERATOR
  
 OMC.RR   BSS    1           ** FILLED ** 
          EQ     EXIT.
  
**        SKELETON RESTORE REGISTER WORDS.
  
 OMC.X5   =A4    OMCA+2      RESTORE *X4* 
          SA5    B6-1        RESET *X5* TO CONVERSION INTERMEDIATE
 OMC.X4   SA4    B6-1        RESET *X4* TO CONVERSION INTERMEDIATE
          =A5    OMCA+1      RESTORE *X5* 
  
 OMC.RC   EQU    OMC.X5-1 
  
 OMCA     BSS    3
 SCB      SPACE  4,10 
**        SCB - SET CHARACTER BOUNDS. 
* 
*         ENTRY  (X4) = ZR IF TARGET TP.
*                       NZ IF SOURCE ELEMENT TP.
*                (X5) = TP. ENTRY.
* 
*         EXIT   IF CALLED WITH (X4) ZR:  
*                  (SCBA) = BASE MEMBER ORDINAL.
*                  (SCBB) = LOWER CHARACTER BOUND.
*                  (SCBC) = UPPER CHARACTER BOUND.
*                IF CALLED WITH (X4) NZ:  
*                  EXIT TO *CDIX* IF BASE ORDINAL .NE. (SCBA).
*                  ELSE (X6) = LOWER CHARACTER BOUND. 
*                       (X7) = UPPER CHARACTER BOUND. 
* 
*         USES   X-ALL, B-2,7, A-1,2,6,7. 
  
  
 SCB      SUBR   0           ... ENTRY/EXIT ... 
          BX6    X5 
          SBIT   X6,TP.INTRP
          SB7    B0          (B7) = 0 IF SUBSTRING NOT PRESENT
          PL     X6,SCB20    IF NOT TURPLE POINTER
          LX5    -TP.ORDP 
          MX0    -TP.ORDL 
          BX5    -X0*X5      ISOLATE TURPLE ORDINAL 
          SB7    X5 
          SA1    T.PAR
          SA1    X1+B7       TURPLE HEADER
          AX1    -TH.SKELL
          BX1    -X1
          SX1    X1+V=SUBST 
          NZ     X1,SCB10    IF NOT SUBSTRING 
          SA1    A1+B1       GET VARIABLE POINTER 
          SB7    A1+B1       (B7) = ADDRESS OF COLON POINTER
          BX5    X1          (X5) = VARIABLE POINTER
          SBIT   X1,TP.INTRP
          PL     X1,SCB20    IF STATIC VARIABLE 
  
 SCB10    ZR     X4,EQL99    IF TARGET - NO CHECKING
          EQ     CDIX        IF SOURCE - NO CHECKING THIS ELEMENT 
  
 SCB20    BX6    X5 
          MX7    -TP.ORDL 
          LX6    -TP.ORDP 
          BX7    -X7*X6      (X7) = SYM TAB ORDINAL 
          SA2    T.SYM       GET SYM TAB *WB* WORD
          SB2    X7 
          LX6    X7,B1
          SB2    B2+X6
          =B2    B2+WB.W     CONVERT TO *WB* INDEX
          SA3    X2+B2       *WB* 
          BX6    X5 
          HX6    TP.EQV 
          PL     X6,SCB30    IF NOT EQUIVALENCED
          MX7    -WB.BASEL
          LX3    -WB.BASEP
          BX7    -X7*X3      (X7) = SYM ORD OF BASE ENTRY 
  
 SCB30    NZ     X4,SCB40    IF SOURCE ELEMENT
          SA7    SCBA        SAVE TARGET BASE ORD 
          EQ     SCB50
  
 SCB40    SA2    SCBA        COMPARE TARGET/SOURCE BASE ORDS
          IX0    X2-X7
          NZ     X0,CDIX     IF BASES DIFFER - OK 
  
*         IF SUBSRING NOT PRESENT, COMPUTE: 
*           LOWER BOUND = RA*10 + BCP + BIAS*CLEN + 1 
*           UPPER BOUND = (LOWER BOUND) + CLEN - 1
  
 SCB50    =A1    A3+WC.W-WB.W  *WC* 
          MX0    -WC.RAL
          LX1    -WC.RAP
          BX6    -X0*X1      RA 
          SX7    10 
          IX6    X6*X7       RA*10
          MX0    -WC.BCPL 
          LX1    WC.RAP-WC.BCPP 
          BX2    -X0*X1      BCP
          IX6    X6+X2       RA*10 + BCP
          BX7    X5 
          HX7    TP.BIAS
          AX7    -TP.BIASL   BIAS 
          MX0    -WC.CLENL
          LX1    WC.BCPP-WC.CLENP 
          BX2    -X0*X1      CLEN 
          IX7    X2*X7       BIAS*CLEN
          IX6    X6+X7       RA*10 + BCP + BIAS*CLEN
          SX0    B1 
          IX6    X6+X0       RA*10 + BCP + BIAS*CLEN + 1
          NZ     B7,SCB60    IF SUBSTRING PRESENT 
          IX7    X6+X2       UPPER BOUND = (LOWER BOUND) + CLEN - 1 
          IX7    X7-X0
          EQ     SCB70
  
*         IF SUBSTRING PRESENT, COMPUTE AS FOLLOWS: 
*           IF VARIABLE LOWER SUBSTRING VALUE, THEN LOWER BOUND = 0;
*             ELSE L.B. = RA*10 + BCP + BIAS*CLEN + (LOWER SUBSTR)
*           IF VARIABLE UPPER SUBSTRING VALUE, THEN UPPER BOUND = 0;
*             ELSE U.B. = (L.B.) + (UPPER SUBSTR) - (LOWER SUBSTR)
  
 SCB60    SA1    B7          GET COLON POINTER
          LX1    -TP.ORDP 
          MX0    -TP.ORDL 
          BX1    -X0*X1      COLON ORDINAL
          MX7    0           SET FOR VARIABLE UPPER BOUND 
          SX0    B1 
          IX5    X6-X0       (X5) = VALUE FOR COMPUTING UPPER BOUND 
          BX6    X5          (X6) = VALUE FOR COMPUTING LOWER BOUND 
          SB7    X1+B1
          SA1    T.PAR
          SA1    X1+B7       FETCH LOWER SUBSTRING BOUND
          LX2    X1 
          SBIT   X1,TP.SHRTP
          MI     X1,SCB62    IF SHORT CONSTANT
          MX6    0           SET VARIABLE LOWER BOUND 
          EQ     SCB64
  
 SCB62    HX2    TP.BIAS
          AX2    -TP.BIASL   LOWER SUBSTRING BOUND
          IX6    X6+X2       FINAL LOWER BOUND VALUE
  
 SCB64    SA1    A1+B1       FETCH UPPER SUBSTRING BOUND
          LX2    X1 
          SBIT   X1,TP.SHRTP
          PL     X1,SCB67    IF NOT SHORT CONSTANT
          HX2    TP.BIAS
          AX2    -TP.BIASL   UPPER SUBSTRING BOUND
          IX7    X5+X2       FINAL UPPER BOUND VALUE
          EQ     SCB70
  
 SCB67    SX7    77777B      SET SOURCE U.B. TO MAX LENGTH
  
 SCB70    NZ     X4,EXIT.    IF CALLED FOR SOURCE ELEMENT 
          SA6    SCBB        STORE LOWER BOUND
          NZ     X6,SCB80    IF LOWER BOUND NOT VARIABLE
          ZR     X7,EQL99    IF BOTH VARIABLE - NO CHECKING 
          SA7    SCBB        STORE UPPER BOUND FOR BOTH 
  
 SCB80    SA7    SCBC        STORE UPPER BOUND
          NZ     X7,EXIT.    IF UPPER BOUND NOT VARIABLE
          SX7    77777B      SET TARGET U.B. TO MAX LENGTH
          SA7    SCBC        STORE UPPER BOUND
          EQ     EXIT.       RETURN 
  
 SCBA     BSS    1           BASE ORDINAL 
 SCBB     BSS    1           LOWER CHARACTER BOUND
 SCBC     BSS    1           UPPER CHARACTER BOUND
 SDM      SPACE  4,30 
**        SDM - SELECT DOMINANT MODE. 
* 
*         ENTRY  (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
* 
*         EXIT   (X3) = OPERATOR, WITH -- 
*                       (TH.SMD) = TRUE (SPECIFIC MODE DETERMINED). 
*                       (TH.SKEL) = SPECIFIC SKELETON.
*                       (TH.STPR) = 0.
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
*                (X6) = (X3). 
*                (SOPR) = (X3). 
*                (SMOD) =  24/ 0,  18/ POINT,  18/ DM 
*                        (POINT) = 0, IF NO CONVERSION REQUIRED,
*                                = 1, IF 1ST  OPERAND IS DOMINANT MODE, 
*                                = 2, IF 2ND  OPERAND IS DOMINANT MODE. 
*                        (DM) = DOMINANT (AND RESULT) MODE. 
* 
*         USES   A1,A2,A3  X0,X7  B2,B3,B7
  
  
 SDM90    BX6    X3 
          NO
          SA6    SOPR        UPDATE OPERATOR
  
 SDM      SUBR   =           ENTRY/EXIT...
          SA1    CO.ANSI
          ZR     X1,SDM5     IF ANSI NOT ON CONTROL CARD
          RJ     DDC         DIAGNOSE DBL PREC. AND CPLX. EXPRESSION
  
 SDM5     CLAS=  X0,SP,(SMD)
          BX2    X0*X3
          LX6    X3 
          NZ     X2,EXIT.    IF (TH.SMD) SET ON ENTRY 
          MX7    -SP.STPRL
          BX3    X0+X3       INDICATE SPECIFIC MODE DETERMINED
          LX7    SP.STPRP 
          BX3    X7*X3       CLEAR (TH.STPR)
          MX0    -TP.MODEL
          LX4    -TP.MODEP
          BX7    -X0*X4      DM = MODE1 = MODE OF (1OP) 
          HX6    SP.MDLS
          SA7    SMOD        INITIALIZE (SMOD) = MODE1
          LX4    TP.MODEP 
          MI     X6,SDM90    IF MODE CONVERSION INHIBITED FOR THIS OP 
          MX1    -SP.TBPRL
          BX2    -X1*X3      EXTRACT (X2) = TOKEN TYPE OF OPERATOR
          ERRNZ  SP.TBPRP 
          SB7    X2-O.SLP 
          ZR     B7,SDM90    IF SPECIAL LEFT PAREN, ALWAYS MODELESS 
  
*         IF UNARY OPERATOR, INHIBIT CONVERSION.
  
          LX5    -TP.MODEP
          LX1    X3 
          BX6    -X0*X5      MODE2 = MODE OF (2OP)
          HX1    SP.UNAR
          PL     X1,SDM16    IF BINARY OPERATOR 
          BX7    X6          MODE1 = MODE2
  
*         FIND DOMINANT MODE. 
*                (X6) = MODE2 
*                (X7) = MODE1 
  
 SDM16    SB3    B0          TRY POINT = 0
          IX1    X7-X6
          ZR     X1,SDM20    IF MODE1 .EQ. MODE2
          =B3    2
          MI     X1,SDM20    IF MODE1 .LT. MODE2
          LX6    X7          SET (X6) = DM = MODE1
          BX7    -X0*X5      SET (X7) = MODE2 
          SB3    B1          POINT = 1
  
*         CHECK FOR ILLEGAL USE OF TYPE CHARACTER OPERANDS. 
  
 SDM20    SX1    X6-M.CHAR
          LX5    TP.MODEP 
          NZ     X1,SDM30    IF DM .NE. CHARACTER 
          ERRNZ  M.CHAR+1-N.TYPE   ASSUMES CHAR IS LARGEST TYPE 
          ZR     B3,SDM24    IF POINT .ZR.   /* BOTH ARE CHAR 
          SB7    E.AT13      ** CHARACTER AND OTHER TYPE MIXED
 SDM22    FATAL  B7 
          SB3    B0          POINT = 0    /* INHIBIT CONVERSION 
          =X6    M.CHAR 
          BX7    X6 
          EQ     SDM40
  
 SDM24    BX1    X3 
          HX1    SP.CHAR
          SB7    E.AT14      ** ILLEGAL USE OF TYPE CHARACTER OPERAND 
          PL     X1,SDM22    IF THIS OPERATOR ILL FOR CHAR
          MX0    -SP.SKELL
          LX3    -SP.SKELP
          BX7    -X0*X3      (X7) = ADDRESS OF MODE SELECTION WORDS 
          SA2    X7+B1
          BX1    X0*X3
          BX3    X1+X2       SET (TH.SKEL) = CHARACTER-SPECIFIC SKELETON
          SA6    SMOD 
          LX3    SP.SKELP 
          EQ     SDM90       EXIT.. 
  
*         IF MASKING OPERATOR, DETERMINE RESULT MODE. 
  
 SDM30    BX1    X3 
          HX1    SP.MASK
          PL     X1,SDM37    IF NOT LOGICAL/MASKING 
          SX1    X6-M.LOG 
          SX2    X7-M.LOG 
          ZR     X1,SDM32    IF DM = LOGICAL
          NZ     X2,SDM36    IF NEITHER (MODE1 NOR MODE2) IS LOGICAL
 SDM32    ZR     B3,SDM40    IF POINT .ZR., BOTH ARE LOGICAL
          FATAL  E.AT01      LOGICAL AND OTHER TYPE CANNOT BE MIXED 
          SB3    B0 
          =X6    M.LOG
          EQ     SDM40
  
 SDM36    =X6    M.BOOL      SET RESULT MODE = BOOLEAN
          SB3    B0          POINT = 0      /* INHIBIT ANY CONVERSION 
          ANSI   E.AT07      MASKING OPERATION IS NON ANSI
          EQ     SDM40
  
 SDM37    NZ     X6,SDM40    IF DOMINANT MODE NOT BOOLEAN 
          ERRNZ  M.BOOL 
          =X6    M.INT
  
*         VERIFY LEGALITY OF DOMINANT MODE, AND SELECT CONVERSION.
*                (B3) = POINT 
*                (X6) = DM, DOMINANT MODE (ASSUME RESULT MODE SAME).
*                (X7) = MODE OF NON-DOMINANT OPERAND. 
  
 SDM40    SA2    X7+F.MODC   FETCH ROW OF MODE CONVERSION MATRIX
          SX1    B3 
          SX7    X6 
          LX1    18 
          LX7    3           (B2) = 8 * DM
          BX6    X1+X6       (SMOD) =  0 / POINT / DM 
          SB2    X7 
          MX0    -8 
          AX1    B2,X2       SLIDE ROW TO DOMINANT COLUMN 
          BX2    -X0*X1      (X2) = MODC (X7, DM) 
          NZ     X2,SDM44    IF MODE CONVERSION NECESSARY 
          SX6    X6+         POINT = 0
 SDM44    SA6    SMOD 
          SX1    X2-1S8+1 
          SB7    E.AT01      LOGICAL AND OTHER TYPE OPERANDS MIXED
          ZR     X1,SDM80    IF MODE CONVERSION ERROR 
  
*         SELECT SPECIFIC SKELETON. 
*                (B2) = 8 * DM
  
          MX7    -SP.SKELL
          LX3    -SP.SKELP
          BX2    -X7*X3      AD = (TH.SKEL)  /* MODE SELECTOR ADDRESS 
          SA1    X2 
          BX6    X7*X3       CLEAR PREVIOUS (TH.SKEL) 
          AX3    B2,X1       SLIDE VECTOR TO DOMINANT MODE
          AX1    6*8         BASE = MIN SKEL INDEX OF THIS OPERATOR 
          BX0    -X0*X3      DOMOFF = OFFSET TO DOMINANT SKELETON 
          BX6    X6+X1
          SB7    X0-1S8+1 
          IX3    X6+X0       (TH.SKEL) = BASE + DOMOFF
          LX3    SP.SKELP 
          MI     B7,SDM90    IF OPERATION DEFINED FOR THIS MODE 
          SB7    E.AT01 
  
*         ON ERROR, INHIBIT CONVERSION. 
*                (B7) = ERROR MESSAGE ADDRESS.
  
 SDM80    SA3    ERROP
          FATAL  B7 
          SA1    SMOD 
          MX0    1
          SX7    X1          POINT = 0
          LX0    1+SP.MDLSP 
          BX3    X0+X3       RESET OPERATOR MODELESS WHEN ERROR 
          SA7    A1 
          EQ     SDM90       EXIT.. 
 SPE      SPACE  4,10 
**        SPE -  SKIP PARENTHESIZED EXPRESSION. 
* 
*         ENTRY  (B4) _ LEFT PAREN OF AN EXPRESSION.
* 
*         EXIT   (B4) _ MATCHING *)* OR *EOS* AS INDICATED BY B2 BELOW. 
* 
*                (B2) = PL IF *EOS* ENCOUNTERED.
*                     = MI IF MATCHING *)* FOUND. 
* 
*         USES   X - 1  A - 1  B - 2,3,4,7. 
  
 SPE      SUBR               ENTRY/EXIT...
          =B3    1           INITIALIZE *LP* COUNTER
          =B2    0           INITIALIZE *RP* COUNTER
  
 SPE10    =B4    B4+1 
          SA1    B4 
          ZR     X1,EXIT.    IF *EOS* 
          SB7    X1-O.LP
          ZR     B7,SPE20    IF *(* 
          SB7    X1-O.RP
          ZR     B7,SPE30    IF *)* 
          EQ     SPE10
  
 SPE20    =B3    B3+1 
          EQ     SPE10
  
 SPE30    =B2    B2+1 
          NE     B2,B3,SPE10
          =B2    -1          INDICATE MATCHING *)* FOUND
          EQ     EXIT.
 SQZ      SPACE  4,30 
**        SQZ -  SQUEEZE OPERATION IF POSSIBLE. 
* 
*         CHECK TO SEE IF CURRENT TURPLE HAS ALREADY BEEN POPPED. 
*         NOTE THAT THE PRESENT ROUTINE DOES NOT ATTEMPT TO SQUEEZE 
*         ACROSS STORES.  TO DO SO REQUIRES LOOKING AT EQUIVALANCE- 
*         CLASS BASES.  TEACHING SQZ TO DO THAT TRICK PROPERLY WOULD
*         IMPROVE QCG CODE FOR CASES LIKE:  ARY(I,J,K) = ARY(I,J,K)+1.
*         POP.EQL RESETS (CURST) DUE TO THIS PROPERTY.
* 
*         IF FOUND, 
*                SET *ESTACK* ENTRY = TO INTERMEDIATE ORDINAL OF
*                TURPLE THAT MATCHED AND EXIT SETTING B2 \ 0. 
* 
*         IF NOT FOUND, 
*                SET B2 < 0 AND EXIT. 
* 
*         ENTRY  (X3) = CURRENT OPERATOR. 
*                (X4) = 1ST OPERAND.
*                (X5) = 2ND OPERAND.
*                (B2) = .MI. (INDICATES NO SQUEEZE) 
* 
*         EXIT   (B2) > 0 SQUEEZE PERFORMED.
* 
*         USES   X0-4,X6-7.    A1-2,A6.    B2-3,B5-7. 
* 
*         CALLS  SN.SQZ.
  
  
 SQZ      SUBR               ENTRY/EXIT...
          SA1    T.PAR
          MX0    -SP.TBPRL
          LX3    -SP.TBPRP
          BX0    -X0*X3      EXTRACT OPERATOR VALUE INDEX 
          SB7    X0-O.= 
          ZR     B7,EXIT.    CAN NOT SQUEEZE STORES 
          LX3    SP.TBPRP 
          SA2    T=PAR
          ZR     X2,SQZ      IF T.PAR EMPTY 
          IX0    X1+X2       LWA+1
          SA2    CURST
          =B3    X0-Z=TURP   LAST OPERATOR
          IX0    X1+X2
          =B5    X0+OR.OPR   FWA
          CLAS=  X2,SP,(1ATR,MODC,MODE) 
          BX3    -X2*X3      CLEAR PASS 1 FIELDS
          LX0    X3 
          HX0    SP.SKEL
          AX0    -SP.SKELL   EXTRACT SKELETON ORDINAL 
          MX2    SP.SKELL 
          HX3    SP.SKEL
          BX3    -X2*X3      CLEAR SP.SKEL
          LX3    SP.SKELL+SP.SKELP
          LX0    TH.SKELP 
          BX3    X0+X3       CONVERT TO TH. FORMAT
          SA2    =XCO.OPT 
          ZR     X2,SQZ5     IF OPT .EQ. 0
          EQ     SQZ12       CHECK FOR INTEGER ADD OR SUB TURPLE SQUEEZE
  
*         SCAN PARSED FILE BACKWARDS FOR MATCHING TURPLE. 
  
 SQZ4     SB2    -1 
  
 SQZ5     SA1    B3+
          CLAS=  X2,TH,(SKEL,OVAL)
          LT     B3,B5,EXIT. IF FINISHED
          =B3    B3-Z=TURP
          BX6    X2*X1       CLEAR IRRELEVANT FIELDS
          BX6    X6-X3
          NZ     X6,SQZ5     IF DIFFERENT SKEL
  
*         OPERATOR IS THE SAME,  CHECK 2ND OPERAND. 
  
          =A2    A1+OR.2OP   2ND OPERAND
          IX7    X2-X5
          BX6    X1          SAVE OPERATOR
          NZ     X7,SQZ5     IF 2ND OPERAND NOT THE SAME
  
*         2ND OPERAND IS A MATCH,  CHECK 1ST OPERAND. 
  
          =A1    A2+OR.1OP-OR.2OP 
          IX2    X1-X4
          NZ     X2,SQZ5     IF (1OP) DIFFERENT 
  
*         ELIMINATE TURPLE,  SQUEEZE PERFORMED. 
  
 SQZ6     SX1    V=ARY
          MX0    -TH.SKELL
          LX6    -TH.SKELP
          BX2    -X0*X6      EXTRACT SKELETON ORDINAL 
          IX2    X2-X1
          CLAS=  X3,TP,(ARR,INTR) 
          ZR     X2,SQZ7     IF SQUEEZED TURPLE WAS ARRAY LOAD
          CLAS=  X3,TP,(INTR) 
  
 SQZ7     MX0    -TH.MODEL
          SA1    T.PAR
          LX6    TH.SKELP-TH.MODEP
          BX5    -X0*X6      DOMINANT MODE
          =B2    X1-Z=TURP
          SX4    B3-B2       ORDINAL
          IX6    X3+X5       ATTRIBUTES + MODE
          LX4    TP.ORDP
          IX6    X4+X6       ORDINAL + ATTRIBUTES + MODE
          =B6    B6-1 
          SA2    ATTR 
          CLAS=  X3,TP,(CAT,LCF)
          BX2    X3*X2       EXTRACT NECESSARY ATTRIBUTES 
          BX6    X2+X6       MERGE INTO INTERMEDIATE TURPLE 
          SA6    B6-B1       PUT THE EQUIVALENT INTERMEDIATE ON ESTACK
  
 SNAP=Q   IFEQ   TEST,ON     DUMP SQUEEZED TURPLE 
          SA1    CO.SNAP
          BX2    X1 
          LX1    1RQ
          LX2    1RO
          BX1    X1+X2
          PL     X1,SQZ9     IF NEITHER SNAP=(O NOR Q) SELECTED 
          RJ     SN.SQZ 
 SQZ9     BSS 
 SNAP=Q   ENDIF 
          EQ     EXIT.
  
**        CHECK IF AN INTEGER ADD TURPLE FOLLOWING AN INTEGER 
*         MULTPLY TURPLE CAN BE SUBSUMED AND SQUEEZED.
* 
* 
  
 SQZ12    BX1    X3          CURRENT OPERATOR 
          LX1    -TH.SKELP
          MX0    -TH.SKELL
          BX2    -X0*X1 
          SX0    V=ADD.I
          IX1    X2-X0
          SB7    1
          NZ     X1,SQZ4     IF NOT V=ADD.I 
          SA1    B3          OPERATOR OF LAST TURPLE ENTERED TO T.PAR 
          LX1    -TH.SKELP
          MX0    -TH.SKELL
          BX2    -X0*X1 
          SX0    V=MUL.I
          IX1    X2-X0
          NZ     X1,SQZ4     IF LAST ENTERED TURPLE IS NOT V=MUL.I
          SA1    A1+OR.1OP   FIRST OPERAND OF LAST ENTERED
          SA2    A1+OR.2OP-OR.1OP  SECOND OPERAND OF LAST ENTERED 
          SA0    A2 
          BX0    X1 
          LX0    59-TP.SHRTP
          MI     X0,SQZ4     IF SHORT CONSTANT
          LX0    TP.SHRTP-TP.INTRP
          MI     X0,SQZ4     IF INTERMEDATE 
          BX0    X2 
          LX0    59-TP.SHRTP
          PL     X0,SQZ4     IF NOT SHORT CONSTANT
          BX1    X4          FIRST OPERAND OF TURPLE TO BE ADDED
          LX2    X5          SECOND OPERAND OF TURPLE TO BE ADDED 
          LX1    59-TP.INTRP
          LX2    59-TP.INTRP
          BX0    X1-X2
          PL     X0,SQZ4     IF NEITHER OR BOTH INTERMEDATE 
          LX6    X4          POSSIBLE INTERMEDATE 
          BX7    X5          POSSIBLE NON INTERMEDATE 
          MI     X1,SQZ14    IF FIRST INTERMEDATE 
          LX6    X5          INTERMEDATE
          BX7    X4          NON INTERMEDATE
  
SQZ14     MX0    TP.ORDL
          BX1    X0*X6
          LX1    TP.ORDL
          SA2    T.PAR
          SB2    X2 
          SB2    B2+X1
          NE     B2,B3,SQZ4  IF NOT LAST TURPLE 
          SA2    A1 
          BX0    X2-X7
          NZ     X0,SQZ4     IF OPERANDS NOT EQUAL
          SB3    B3-Z=TURP   UPDATE FOR PROPER INTR POINTER 
          MX0    -TP.BIASL
          SA1    A0          SECOND OPERAND OF LAST TURPLE(CONSTANT)
          LX0    TP.BIASP 
          BX2    -X0*X1      X2 -> BIAS 
          BX1    X0*X1       X1 -> CLEARED BIAS 
          LX2    TP.ORDL
          AX2    -TP.BIASL
          SX6    B7 
          IX7    X6+X2       ADD OR SUB 
          LX7    TP.BIASP 
          BX6    -X0*X7 
          IX7     X6+X1 
          SA7    A0          2ND OPERAND OF LAST TURPLE (CONSTANT)
  
 .T       IFEQ   TEST,ON
          SA1    CO.SNAP
          BX2    X1 
          LX1    1RQ
          LX2    1RO
          BX1    X1+X2
          PL     X1,SQZ17    IF NEITHER SNAP=(O NOR Q) SELECTED 
          PL     B7,SQZ15    IF V=ADD.I SQUEEZED
          EQ     SQZ17
 SQZ15    BSS 
          SA2    SQZE 
          BX6    X2 
          SA6    SQZB        SET V=ADD.I MSG
 SQZ17    BSS 
 .T       ENDIF 
  
          SA2    A0-OR.2OP
          BX6    X2          OPERATOR OF LAST TURPLE IN T.PAR 
          EQ     SQZ6 
 SN.SQZ   SPACE  4,20 
**        SN.SQZ - NOTIFY OF SQUEEZE OPERATION PERFORMED. 
* 
*         ENTRY  (B3)+Z=TURP -> OPERATOR THAT WAS SQUEEZED. 
* 
*         EXIT   (A1) DESTROYED.
* 
*         USES   DESTROYS *A1* ONLY...
*         CALLS  COD, PLINE, SFN, SVR=, RSR=. 
  
  
 .T       IFEQ   TEST,ON     IF TEST MODE 
  
 SN.SQZ   SUBR   0
          CALL   SVR=        SAVE ALL REGISTERS 
          SA3    SV=B+3      FETCH [B3] 
          SA2    T.PAR
          IX0    X3-X2
          SX1    X0+Z=TURP
          CALL   COD         CONVERT TO OCTAL 
          LX4    -6 
          MX0    5*6
          SA1    T=PAR
          BX5    X0*X4
          CALL   COD         CONVERT TO OCTAL 
          MX0    -5*6 
          BX4    -X0*X6 
          BX6    X5+X4
          SA6    SQZBO
          SA1    SOPR 
          MX0    -SP.SKELL
          LX1    -SP.SKELP
          BX1    -X0*X1      ISOLATE (X1) = SKELETON NUMBER 
          SA2    X1+=XF.SKNAM 
          BX6    X2 
          SA6    SQZBN
          PLINE  SQZB,SQZBL 
          SA1    SQZG 
          BX6    X1 
          SA6    SQZB        RESTORE OPERATOR SQUEEZ MSG
          CALL   RSR=        RESTORE ALL REGISTERS
          EQ     EXIT.
  
 SQZB     DIS    2,**OPERATOR SQUEEZ AT 
 SQZBO    DIS    1, 1234 1234 
          DIS    1, IS SKEL 
 SQZBN    DIS    1,V=SKEL 
 SQZBL    =      *-SQZB 
 SQZE     DIS    1,** V=ADD.I 
 SQZG     DIS    1,**OPERATOR 
 .T       ENDIF 
 TPC      SPACE  4,10 
**        TPC -  TEST FOR PASSED LENGTH CHARACTER CONCATENATION 
* 
*         THIS ROUTINE IS CALLED BY ARGUMENT PROCESSORS TO TEST FOR 
*         ARGUMENTS INVOLVING CONCATENATION OF A PASSED LENGTH VARIABLE.
* 
*         ENTRY  (X5) = OPERAND TO BE TESTED
* 
*         EXIT   (X5) = UNCHANGED 
* 
*         USES   X1   B7
  
  
 TPC      SUBR   =           ...ENTRY/EXIT... 
          BX1    X5 
          SBIT   X1,TP.CATP 
          PL     X1,EXIT.    IF NOT CONCATENATION 
          SBIT   X1,TP.LCFP/TP.CATP 
          PL     X1,EXIT.    IF NOT PASSED LENGTH CHARACTER 
          FATAL  E.SU01 
          EQ     EXIT.
          SPACE  4,10 
          LIST   D
          END 
