*DECK     PAR 
          IDENT  PAR
 PAR      SECT   (P A R S E),1
  
          SST    A,B,C,D,E,F,Z
          NOREF  A,B,C,D,E,F,Z
  
 B=PAR    RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  PAR.EOS,PAR.HOL,PAR.TNK,PAR.VAR,PAR.PL,PAR.MIN,PAR.STD 
          ENTRY  PAR.LP,PAR.EQL,PAR.CM,PAR.TRU,PAR.FAL,PAR.DLP
          ENTRY  POP.MUL,POP.DIV,POP.PN,POP.RP,POP.REQ,POP.NOT,POP.EXP
          ENTRY  POP.STD,POP.PL,POP.CM,POP.REL,POP.UM,POP.LOG 
          ENTRY  PAREXIT,POP.ST1,SOPR,SMOD,IXLASTV,PAR,ADT,POPX 
          ENTRY  PAR.NX,C=CERR,C=BEF,C=BIF,C=CALL,C=DEC,C=ERR,DO.ERR
          ENTRY  C=DO,C=FUN,C=GOT,A=ASF,A=BEF,A=BIF,A=CALL,A=DEC
          ENTRY  A=LIST,A=DO,A=FUN,A=IF,CURST,CT2,SDM,CNF,FAL 
  
*         IN FTN
          EXT    CO.SNAP,CO.TBK,LOP=R 
  
*         IN TABLES 
          EXT    ACONS,ARGMIS,ANDNOT,ARGCOMA,ARGMODE,ATTR,ARRARM,ASFARM 
          EXT    ASFLEN,BEFXARM,BIFFUN,BIFARM,BINOUT,BEFFUN,COD,CALLOP
          EXT    CNFARM,CONOTBL,CSYMBOL,COMMA,CHARMAP,CONONE,CLPARM 
          EXT    CCONONE,DOORD,DOIX,ENTRY.,EXTFUN,EXTFARM,ERROP,EQUAL 
          EXT    FLOW,INAFR,IN.EXP,INTMAC,LASTAD,LASTOP,LDEAD,LPARM,LPAR
          EXT    MOD,POPTBL,PSTACK,PR.SLP,REGARG,REGARG2
          EXT    REFVAR,ROUTNAM,REVMIN,SDIV,TT=PAR,TT.PAR,TS.CON,TS.SYM 
          EXT    TS.STN,TP.DO,TP=DO,TG.PRO,TT=ASF,TT.SCR,TT=SCR,UMINUS
          EXT    VALUE.,VTRUE,ZLE,ZLEQUAL 
  
*         IN ERRORS 
          EXT    DO.DPC,E.AT1,E.AT1A,E.AT2,E.AT3,E.AT5
          EXT    E.DO,E.DO1,E.DO2,E.DO3,E.DO4,E.DO5,E.DO8,E.DO11,E.DO16 
          EXT    E.DO17,E.DO23,E.GO9,E.GO10,E.GO11,E.LP3,E.LP4
          EXT    E.MRA,E.TE1,E.TE2,E.TE2A,E.TE3,E.TE4,E.TE7,E.TE8,E.XP1 
          EXT    E.XP2,E.XP3,E.XP4,FILL.
          EXT    E.AT11,E.AT12
          EXT    E.ANS3 
          EXT    E.CL3
  
*         IN ALLOC
          EXT    ALC.REG,ALC.00,ERT,ESY,ESC,NCM,NCS,SSY 
  
*         IN MAIN 
          EXT    WOF
  
*         IN LEX
          EXT    DEC,STY,SLT,TSF
  
*         IN KEY
          EXT    GOTA,EMT,CRL 
  
*         IN IF 
          EXT    IFRESLT,IFMOD
  
*         IN TSDATA 
          EXT    CFC
  
*         IN IO 
          EXT    R.W,IODIR,CML
  
*         IN NUM
          EXT    PSN
  
*         IN CONRED 
          EXT    TER1,TER2,CCC,CCR,CMC,CMO,LCT
  
*         IN GEN
          EXT    A=ARRAY,ESF,MXP,PSO,SSO,VAM,VEL,VIL
          EXT    INLBASE,I..2,I..3,I..4,I..5
          EXT    I..6,I..7,I..8,I..9,I..10,MODTBL,O=GOC 
          EXT    R..2,R..3,R..4,R..5,R..6,R..7,R..8,R..9,R..10
          EXT    MODECON,O=RAGDD,O=RAGDS,O=RAGSD,O=RAGSS
  
*         IN ASF
          EXT    AFR
  
*         IN INIT 
          EXT    CALLTAG,OSTACK,ESTACK,SCR,SCR2,TRVA,CST.BOS
  
  
  
**        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,8
          MACRO  PARSNAP,NAME 
 NAME     REG 
 OPSTACK  CORE   OSTACK,8 
 ELSTACK  CORE   ESTACK,8 
 ARGCMOM  CORE   ARGCOMA,3
          ENDM
          SPACE  4,8
**        MISCELLANEOUS CELLS USED BY PARSER
  
 SMOD     DATA   0           SUB-EXPRESSION DOMINANT MODE.
 SMOD1    BSS    1           MODE CONVERSION OFFSET TO MODECON
 SOPR     DATA   0            -     -       OPERATOR. 
 CURST    DATA   0            -     -       START.
 SOPR1    DATA   0
 SOPR2    DATA   0
 POPDPC   BSS    2           DPC FOR OPERATOR CAUSING AN OPERATOR TO BE 
                             POPPED.
 POPPER   EQU    POPDPC+1    OPERATOR (SETOP) WORD FOR *POPDPC* 
 CMLFLG   BSS    1           I/O RESTART CALLS INDICATOR
 CNF      EJECT  4,20 
**        CNF -  COMPILE NORMAL FORMULA 
  
  
 CNF      SA1    ZLEQUAL
          =B4    X1+1        START AT RIGHT SIDE OF LAST *=*
          BX6    X1 
          SA6    ZLE         SET
          SA1    X1 
          AX1    P.SYM
          ZR     X1,CNF1     IF NO MULTIPLE ASSIGNMENT
          ANSI   =XE.AT9
  
**        PARSE STATEMENT.
  
 CNF1     SA3    CNFARM 
          =X7    0
          LX6    X3 
          SA7    ARGCOMA
          SA6    ARGMODE
          RJ     MXP         MARK EXTERNAL PROCESS START
          RJ     PAR         PARSE STATEMENT. 
  
          EQ     PSN         CONTINUE WITH PARSED BLOCK INTACT. 
  
 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 _ POINTS TO WHERE PAR IS TO START PROCESSING. 
* 
*                (ARGMODE) = PRESET TO INDICATE CURRENT MODE OF 
*                            EXPRESSION *PARSE* WILL HANDLE.
* 
*                (ARGCOMA) = PRESET TO CURRENT ARGUMENT COUNT.
* 
*                (CURST) = ORDINAL, RELATIVE TO TT.PAR, POINTING TO 
*                          BREAK FOR SQUEEZING PROCESS. 
* 
*         EXIT   (B4) _ LAST ELEMENT PROCESSED. 
* 
* 
*         --------------- L O C K  -  R E G I S T E R S --------------
*                       B4 _ POINTS TO CURRENT *SB* ENTRY 
*                       B5 _ CURRENT OP-STACK ENTRY 
*                       B6 _ CURRENT ELEMENT ENTRY
*         NO ROUTINE CALLED BY *PAR* MAY DESTROY ANY OF THE ABOVE REGS. 
*         ------------------------------------------------------------
* 
*         USES   ALL REGISTERS. 
  
  
  
 PAR      SUBR   0
          SA1    TT=PAR 
          SA2    ARGMODE
          SB6    ESTACK      SET UP *B6* _ ELEMENT STACK. 
          BX6    X1 
          MX7    0
          SX0    X2-A=LIST
          SA7    CMLFLG      INITIALIZE 
          NZ     X0,PAR1     IF NOT I/O LIST ITEM 
          SA1    IODIR
          NZ     X1,PAR1     IF NOT INPUT 
          =X7    1
          SA7    A7          FLAG FOR I/O LIST ITEMS IN INPUT 
 PAR1     SB5    OSTACK      SET UPT *B5* _ OPERATOR STACK
          AX2    P.AMR
          BX7    0
          SA6    LDEAD       SET = LENGTH + 1 OF TT.PAR ON ENTRY
          SA7    INAFR       INDICATE NO STATEMENT FUNCTION EXPANSION 
          SX6    X2 
          SX7    O.EOS
          SA6    REFVAR      RESET CURRENT REFERNCE VALUE.
          SA7    OSTACK      EOS TO OPERATOR STACK. 
          SA5    B4 
          SB3    X5 
          SA3    =XFEXPR
          LX4    B3,X3
          MI     X4,PAR.NX   IF FIRST ELEMENT LEGAL 
          MX0    L.CDPC 
          SA1    X5+CHARMAP 
          BX6    X0*X1
          SA6    FILL.
          FATAL  =XE.AT10 
          ZR     X5,PAR.EOS  IF *EOS* FIRST ELEMENT 
          EQ     PAREX11
 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 *SB* ENTRY.
*         (X3) = LAST OPERATOR STACK ENTRY. 
*         (X5) = NEXT    *SB* ENTRY.
  
 PAR.NX   SA1    B4          NEXT ENTRY 
          SA5    B4+B1
          ZR     X1,PAR.EOS  IF END OF STATEMENT. (*EOS*) 
          SB3    X5 
          SA3    X1+CONOTBL-O.DEF 
          SB2    B3-O.PERIOD
          LX4    B3,X3
          SA2    X1+PSTACK-O.PL 
          SB7    X3          JUMP ADDRESS 
          SA3    B5 
  
 SNAP=Z   IFNE   TEST        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 
  
          LE     B2,PAR.NX1  IF NORMAL OPERATOR/OPERAND 
*         TEST FOR I/O DO BEGIN 
  
  
          SB2    B3-IO.DOB   IO.DOB ALLOWED TO FOLLOW COMMA 
          SB3    X1-O.COMMA 
          NZ     B2,PAREX 
          NZ     B3,PAREX 
          JP     B7 
  
 PAR.NX1  PL     X4,PAREX    IF ILLEGAL OPERATOR COMBINATION
  
          JP     B7          JUMP TO PROCESS CURRENT ELEMENT. 
 PAR.TNK  EJECT  4,20 
**        TNK -  TRANSLATE CONSTANT 
* 
*         ENTRY  B4 _ TO CONSTANT TO BE TRANSLATED. 
* 
*         EXIT   (X6) = TAG FOR CONSTANT. 
*                (B7) = ORDINAL OF TAG. 
* 
*         USES   CANNOT DESTROY - B4,B5,B6
* 
*         CALLS  DEC, NCM, NCS
  
  
**        TRANSLATE CONSTANT TO INTERNAL BINARY USING *DEC* 
*         RETURN WITH 
*                (X1) = MODE OF CONSTANT. 
*                (X6) = UPPER HALF OF CONSTANT. 
*                (X2) = LOWER HALF OF CONSTANT. (IF *DBL*)
  
 PAR.TNK  RJ     DEC         TRANSLATE TO INTERNAL BINARY 
          =B2    X1-M.DBL 
          BX7    X1          MODE 
          NZ     B2,TNK.ENT  IF NOT *DOUBLE*
  
**        HERE IF CONSTANT = DOUBLE 
*         (X2) = LOWER HALF OF CONSTANT 
*         (X6) = REAL PART. 
*         (X7) = MODE.
  
 TNK.DBL  SA6    SCR         1ST WORD OF CONSTANT 
          BX6    X2 
          =A6    A6+1        2ND WORD 
          =A7    A6+1        MODE 
          SB2    SCR         FWA
          SA1    TS.CON 
          SB3    B2+2        LWA+1
          RJ     NCM         SCAN/ENTER INTO CONSTANT TABLE.
          SA3    SCR+2       MODE 
          SX6    B7+C.CON    FORM TAG 
          LX6    P.TAG
          BX6    X6+X3       ADD IN MODE BITS.
          EQ     TNK40       CONTINUE 
  
**        ENTRY SINGLE WORD CONSTANT. 
*         (X6) = CONSTANT. (IN BINARY)
*         (X7) = MODE.
  
 TNK.ENT  RJ     NCS         SCAN/ENTRY CONSTANT
 TNK40    =A2    B4+1 
          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        SET TOKEN FOR ERROR MESSAGE
          SA5    B4          SET TOKEN FOR ERROR MESSAGE
          SB4    B4-1        RESET TOKEN POINTER
          EQ     PAREX
          EJECT 
**        HERE IF *ELEMENT* IS A *HOLLERITH CONSTANT* 
  
 PAR.HOL  BX0    X1 
          AX0    P.LCON 
          MX2    -L.LCON
          BX7    -X2*X0 
          SB7    X7 
          EQ     B7,B1,PAR.HOL5 IF LENGTH=1,OK ANYWHERE 
          SA3    ARGMODE
          BX4    X1 
          IFBIT  X3,AMWHOL,PAR.HOL3 
 PAR.HOL2 NOTE   E.AT3       HOLLERITH MORE THAN ONE WORD - TRUNCATED 
          BX1    X4 
          =X7    0
          EQ     PAR.HOL5 
  
 PAR.HOL3 =A2    B4+1 
          SB7    X2-O.COMMA 
          ZR     X2,PAR.HOL4 IF NEXT *EOS*
          SB2    X2-O.RP
          ZR     B7,PAR.HOL4 IF NEXT *,*
          NZ     B2,PAR.HOL2 IF NEXT NOT *)* - NOT ARGUMENT 
 PAR.HOL4 BSS    0
  
 PAR.HOL5 MX0    L.2TAG 
          SA3    ARGMODE
          BX6    X0*X1       TAG
          SB7    X3-A=LIST
          NZ     B7,PAR.HOL7 IF NOT IN LIST PROCESSING
          SX3    M.INT       DEFAULT TYPE FOR HOLL CONSTANTS IN APLIST
          SA2    R.W
          BX6    X6+X3       TAG + LENGTH 
          ZR     X2,PAR.HOL6 IF NOT LIST-DIRECTED I/O 
          AX1    P.CLCON
          MX0    -L.CLCON 
          BX3    -X0*X1 
          ZR     X3,PAR.HOL6 IF NOT A CHAR STRING 
          MX7    1
          SA7    R.W         SET FLAG FOR CHAR STRING 
          SX7    X3 
 PAR.HOL6 LX7    P.2BIAS+L.MSHORT 
          BX6    X6+X7       TAG + LENGTH + MODE
 PAR.HOL7 SA3    ARGMODE
          SB7    X3-A=CALL
          ZR     B7,PAR.HOL8 IF HOLLERITH IN CALL ARGUMENT LIST 
          ANSI   =XE.AT8
 PAR.HOL8 =B4    B4+1 
          SA6    B6 
          SB6    B6+B1
          EQ     PAR.NX      CONTINUE 
 TRE      EJECT  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.
*         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) _ ELEMENT TO TRANSLATE. 
*                      (MUST CONTAIN O.VAR BITS IN LOW ORDER.)
* 
*         EXIT   (X6) = SYMBOL TABLE ENTRY. 
*                (B2) = 
*                            IF VARIABLE   PAR.NX 
*                            IF ARRAY      PAR.SUB
*                            IF FUNCTION   PAR.FUN  (IF ALREADY IN TABLE
*                                          PAR.FUN  (IF 1ST REFERENCE)
* 
*         USES   CANNOT DESTROY  A4,A5,A7  B4,B5,B6 
* 
*         CALLS  SCAN, TRV, TSF.
  
  
 PAR.VAR  SA1    B4 
          MX0    L.SYM
          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
          RJ     =XTLV       TRUNCATE NAME -- SORT OF 
 PAR.VAR2 SCAN   TS.SYM,SSY 
          SA3    REFVAR 
          =X7    M.VAR
          SB2    X3-CR.STR
          NZ     B2,TRE6     IF NOT PROCESSING A *SET*
          =X7    M.VAR+M.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 CLASS = ARRAY.
*                YES - CHECK IF FOLLOWED BY *(* 
*                   IF NOT OUTPUT ANSI MESSAGE NOTING REFERENCE TO
*                   AN ARRAY WITHOUT SUBSCRIPT. 
* 
*                NOT - GO TO 2. 
*         2. CHECK IF IT IS A VARIABLE. 
*                YES - CHECK IF FOLLOWED BY *(* 
*                   IF SO OUTPUT ILLEGAL USE OF VARIABLE. 
*                NO  - GO TO 3. 
* 
*         3. CHECK IF IT IS A FUNCTION. 
  
          =A1    B4+1 
          BX3    X6 
          SX0    X1-O.( 
          IFBIT  X3,-RP,TRE7 IF NOT RETURNS-ARG 
          FATAL  E.MRA       RETURNS-ARG NOT ALLOWED
          =B2    PAR.NX 
          EQ     TREX        EXIT.. 
 TRE7     IFBIT  X3,-VAR/RP,TRE30  IF NOT VARIABLE
          IFBIT  X3,-ARY/VAR,TRE22 IF NOT ARRAY 
          BX6    X6+X7
          SX7    M.2ARY 
          SB2    PAR.SUB
          SA6    A2          RESET TAG WITH APPROPIATE CLASS BITS.
          SA7    ATTR 
          RJ     CIL         CHECK IF ILLEGAL LEVEL 
          ZR     X0,TREX     IF ARRAY FOLLOWED BY *(* 
          SA3    ARGMODE
          SB7    E.TE4
          SB3    X3-A=LIST
          ZR     B3,TRE8     IF IN I/O LIST PROCESSING
          SB3    X3-A=CALL
          ZR     B3,TRE10    IF IN CALL PROCESSING
          SB3    X3-A=FUN 
          ZR     B3,TRE10    IF IN EXTERNAL FUNCTION PROCESSING 
          SB2    =XA=FMT
          SB3    X3 
          SB3    B3-B2
          ZR     B3,TRE8     IF FORMAT INDICATOR
          ANSI   B7 
          EQ     TRE10
  
 TRE8     =X7    X7+M.ADDR+M.ARE   INDICATE NOT SINGLE ELEMENT
          SA7    A7 
  
 TRE10    SB2    PAR.NX 
          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 APPROPIATE CLASS BITS.
          RJ     CIL         CHECK IF ILLEGAL LEVEL 
          NZ     X0,TREX     IF NOT FOLLOWED BY *(* 
          FATAL  E.TE1       ILLEGAL *(* FOLLOWING VARIABLE NAME. 
  
*         SKIP OVER BAD PARENTHESIZED EXPRESSION
  
          =B4    B4+1 
 TRE22A   =B3    1           INITIALIZE *LP* COUNTER
          =B2    0           INITIALIZE *RP* COUNTER
 TRE23    =B4    B4+1 
          SA1    B4 
          ZR     X1,PSN      IF *EOS* - EXIT... 
          SB7    X1-O.( 
          ZR     B7,TRE24    IF *(* 
          SB7    X1-O.) 
          ZR     B7,TRE25    IF *)* 
          EQ     TRE23
 TRE24    =B3    B3+1 
          EQ     TRE23
 TRE25    =B2    B2+1 
          NE     B2,B3,TRE23
          SB2    PAR.NX 
          EQ     TREX        EXIT.. 
  
*         HERE IF POSSIBLE FUNCTION/SUBROUTINE. 
  
 TRE30    SB2    PAR.FUN     INDICATE EXTERNAL. 
          IFBIT  X3,-NVAR/VAR,TRE70 
          IFBIT  X3,-FUN/NVAR,TRE40 IF NOT A FUNCTION.
          ZR     X0,TREX     IF FOLLOWED BY *(* - OK. 
  
**        REFERENCE TO AN FUNCTION/SUBROUTINE WITHOUT A LEFT PAREN
*         VALIDATE LEGAL FOR CURRENT MODE OF EXPRESSION 
*         (X3) = TAG SHIFTED BY P.FUN 
  
 TRE32    SA2    ARGMODE
          =B2    PAR.NX            RETURN ADDRESS 
          =B3    E.TE2A 
          IFBIT  X3,INLINE/FUN,TRE33 IF REFERENCE TO INTRINSIC
          =B3    =XE.TE2B 
          IFBIT  X3,BEF/INLINE,TRE33  IF REFERENCE TO BEF 
          =B3    E.TE2
          IFBIT  X2,AMFUN,TREX     IF FUNCTION WITHOUT LIST ALLOWED 
 TRE33    FATAL  B3 
          EQ     TREX 
  
*         HERE IF POSSIBLE SUBROUTINE.
  
 TRE40    IFBIT  X3,-SUB/FUN,TRE60 IF NOT SUBROUTINE. 
          SA3    ARGMODE
          =B2    PAR.NX 
          IFBIT  X3,AMFUN,TRE41  IF STAND ALONE REFERENCE MANDATORY 
          SB2    PAR.FUN
          ZR     X0,TREX     IF FOLLOWED BY *(* - OK
          EQ     TRE42
 TRE41    NZ     X0,TRE41.5  MUST BE STAND ALONE
          FATAL  E.TE3
          EQ     TRE22A 
  
 TRE41.5  BX3    X6          SYMBOL TABLE ENTRY 
          IFBIT  X3,EST,TREX  APPEARS IN EXTERNAL STMT
          FATAL  =XE.SU6     EXT IN CALL SHOULD BE IN EXTERNAL STMT 
          EQ     TRE42.5
 TRE42    FATAL  E.TE3       SUBROUTINE WITH NO *(* FOLLOWING.
 TRE42.5  =B2    PAR.NX 
          EQ     TREX        EXIT.. 
  
*         HERE IF DEFINED AS NOT-VAR BUT NOT A SUBROUTINE/FUNCTION. 
  
 TRE60    IFBIT  X3,-ENT/SUB,TRE70  IF NOT ENTRY POINT
          SA1    ENTRY. 
          SBIT   X3,TAG/ENT+1 
          SB3    X1+C.VAR 
          SB7    X3 
          NE     B3,B7,=XE.VA3  IF NOT MAIN ENTRY POINT 
          SA1    MOD
          IFBIT  X1,-PFNC,=XE.VA3  IF NOT IN FUNCTION SUBPROGRAM
          SA3    VALUE. 
          SA1    TS.SYM 
          IX3    X1+X3
          SA2    X3          SWITCH REFERENCE TO *VALUE.* 
          BX6    X2 
          EQ     TRE22       PROCESS AS VARIABLE
 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 DEFINED *BEF* OR 
*         *INTRINSIC*, IF NOT ITS DEFAULT IS SET TO A VARIABLE OR 
*         EXTERNAL FUNCTION DEPENDING ON THE CONTEXT. 
* 
* 
*         ENTRY  (X0) = 0, IF FOLLOWED BY *(* 
*                (X6) = TAG CURRENTLY PROCESSING
*                (A2) = ADDRESS OF TAG IN SYMBOL TABLE. 
*                (X7) = CLASS BITS (ONLY IF FOUND TO BE A VARIABLE) 
* 
*         EXIT   (X6) = UPDATED TAG 
*                       ALSO UPDATED IN TABLE OFF OF *A2* 
* 
*                (B2) = PAR.XX PROCESSING ADDRESS FOR PARSER. 
*                       TO. 
*         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 FORMAL PARAMETER OR EXTERNAL SET CLASS AS EXTERNAL FUNCTION
  
          =X0    M.FP+M.EXT 
          =X2    M.NVAR+M.FUN+M.EXT 
          BX1    X0*X6
          =B2    PAR.FUN
          NZ     X1,TRE78    MUST BE EXTERNAL FUNCTION. 
  
**        NOT FORMAL PARAMETER CHECK IF ENTITY APPEARED IN TYPE 
*         STATEMENT AND TYPE AND NAME SAME AS A *BEF* OR *INTRINSIC*
  
          MX0    L.SYM
          =A3    A2-1        LOAD SYMBOL FROM *SYMBOL* TABLE
          BX1    X0*X3       SYMBOL ONLY
          RJ     SLT         SCAN LIBRARY TABLE.
          =B2    PAR.FUN
          =X2    M.NVAR+M.EXT+M.FUN 
          MI     B7,TRE78    IF NOT IN TABLE - EXTERNAL FUNCTION
          MX0    -L.MODE
          BX1    X6-X3
          BX0    -X0*X1 
          NZ     X0,TRE78    IF NOT SAME MODE 
          MX0    -L.CLASS-L.MODE
          BX1    X0*X6       ELIMINATE ALL OLD CLASS+MODE BITS. 
          BX6    X3+X1       CHANGE CLASS BITS TO TABLE ENTRY.
          SA6    A2 
          EQ     TREX        EXIT.. 
  
**        ELEMENT 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    IFBIT  X1,EXT,TREX IF EXTERNAL SET, DO NOTHING TO CLASS 
  
**        (X2) = CLASS BITS FOR TAG 
*         (B2) = ADDRESS FOR PROCESSING TAG 
  
 TRE78    BX6    X2+X6
          SA6    A2 
          EQ     TREX        CLASSIFIED.
  
**        HERE IF ELEMENT NOT IN SYMBOL TABLE.
*         CHECK IF FOLLOWED BY *(*
*         IF YES, MUST BE A FUNCTION REFERENCE -- CALL *TSF*
* 
*         IF NO,  MUST BE A SIMPLE VARIABLE -- ADD TO TABLE AND EXIT. 
  
 TRE80    =A1    B4+1 
          SX2    X1-O.( 
          ZR     X2,TRE90    IF ELEMENT FOLLOWED BY *(* 
          RJ     STY         SET MODE 
          IX7    X7+X1       ADD IN CLASS FIELD.
          ADSYM  TS.SYM      ADD SYMBOL, TAG TO TABLE.
          =B2    PAR.NX 
          EQ     TREX        EXIT.. 
  
**        HERE IF NOT IN TABLE AND FOLLOWED BY *(*
*         EXIT   (NEXT) = 0, SYMBOL ALREADY USED, ARGUMENT COUNT SET. 
  
 TRE90    BX6    0
          RJ     TSF         TRANSLATE FUNCTION REFERENCE 
          SB2    PAR.FUN     INDICATE EXTERNAL. 
          EQ     PAR.VARX 
  
**        EXIT ROUTINE, BUT CHECK IF CROSS REFERENCE HAS BEEN REQUESTED 
*         FIRST.... 
*         (X6) = TAG
*         (B2) = SPECIAL FLAG.
  
 TREX     SA1    LOP=R
          PL     X1,PAR.VARX IF NO CROSS-REFERENCE SELECTED.
          LX2    X6 
          SA6    TRVA        SAVE TAG.
          SX6    B2 
          =A6    A6+1        SAVE FLAG. 
          SA1    REFVAR      TYPE OF REFERENCE
          LX6    X2 
          ADDREF X6,X1
          SA1    TRVA 
          =A2    A1+1 
          BX6    X1          TAG. 
          SB2    X2          FLAG.
 VARX     EJECT  4,8
**        VARX - TRANSLATION OF SYMBOL COMPLETE.
* 
*         (B2) = PROCESSOR ADDRESS
*         (ATTR)= ATTRIBUTE BITS TO BE SET FOR PASS *2* 
  
 PAR.VARX LX5    X6          PASS *1* TAG.
          BX1    X6 
          =B4    B4+1 
          MX0    -L.FPNO
          AX1    P.FPNO 
          =X7    M.EQUIV
          MX3    L.TAG+L.MODE 
          BX2    -X0*X1 
          LX3    L.MODE 
          BX7    X7*X6
          SA4    ATTR 
          =B6    B6+1        UPDATE ELEMENT STACK POINTER.
          LX2    P.2FPNO
          BX1    X3*X6       TAG + MODE  (SAME FOR PASS *1* AND *2*)
          IX6    X1+X2       TAG + PARM + MODE. (PASS *2* TAG.) 
          LX7    P.2EQUIV-P.EQUIV 
          BX6    X6+X4       ADD IN ATTRIBUTE BITS
          BX6    X6+X7
          =A6    B6-1        TO ELEMENT STACK.
          SA2    CMLFLG 
          ZR     X2,PAR.VAR7 IF NOT INPUT I/O LIST ITEMS
          MI     X2,PAR.VAR6 IF ARRAY SUBSCRIPT 
          SX4    B2          SAVE B2
          ADDWD  =XTP.ILI    ADD INPUT LIST ITEM TO TABLE 
          SB2    X4 
          EQ     PAR.VAR7 
 PAR.VAR6 RJ     CML         CHECK FOR MATCH IN LIST TABLE
  
**        (X6) = PASS *2* TAG, (X5) = PASS *1* TAG. 
  
 PAR.VAR7 JP     B2          JUMP TO PROCESS TRANSLATED SYMBOL. 
 PAR.SUB  EJECT  4
  
**        HERE IF ELEMENT IS A *ARRAY(* 
  
 PAR.SUB  SA2    ARGMODE
          RJ     SSO         SET-UP SUBSCRIPT OPERATOR. 
  
**        RETURN FROM *SSO* WITH (X7) = DIMENSIONALITY. 
  
          SA1    CMLFLG 
          ZR     X1,PAR.SUB1 IF NOT I/O LIST ITEM OR FLAG ALREADY SET 
          MI     X1,PAR.SUB1 IF FLAG ALREADY SET FOR A *(*
          =X6    -B5         FLAG SET TO ADDR OF *(*
          SA6    A1 
 PAR.SUB1 SA3    ARRARM 
          =X4    0
          BX6    X3 
          LX7    P.ACM
          =B3    O.SLP
          EQ     PAR.SPS     ENTER PAREN STACK
  
**        HERE IF *TRUE* OR *FALSE* 
  
 PAR.TRU  BSS    0
 PAR.FAL  SB7    X1-O.TRUE
          SA1    B7+VTRUE 
          =B4    B4+1 
          BX6    X1 
          =B6    B6+1 
          SA6    B6-1 
          EQ     PAR.NX      CONTINUE.
 PAR.FUN  EJECT  4,8
**        HERE IF ELEMENT IS A *FUNCTION* OF SOME KIND .... 
  
 PAR.FUN  BX7    X5 
          IFBIT  X5,-SUB,JOE
          ANSI   E.CL3       SAME NAME USED AS A FUNCTION AND SUB 
 JOE      BX5    X7 
          IFBIT  X5,EXT,PAR.XF     IF EXTERNAL
          IFBIT  X5,-ASF/EXT,PAR.BF 
  
**        HERE IF REFERENCE TO AN ASF FUNCTION. 
  
          RJ     AFR         PROCESS *ASF* REFERENCE. 
  
**        (B4) RESET TO SKELETON
*         (B6) RESET ABOVE ASF ESTACK ENTRY 
*         (INAFR)   RESET 
*         (ALC.REG) RESET 
  
          SA3    ASFARM 
          SX5    B3 
          MX0    -L.MODE
          SA4    B6          THE ASF ENTRY IS NEEDED FOR MODE 
          BX4    -X0*X4      NEW *ARGMIS* 
          BX6    X3          NEW *ARGMODE*
          =B3    O.SLP
          LX7    X5 
          EQ     PAR.SPS     SET PAREN STACK
  
**        HERE IF INTRINSIC FUNCTION REFERENCE
  
 PAR.BF   SA5    CSYMBOL     DPC FOR INTRINSIC
          MX2    -L.ARGMF 
          AX6    P.2TAG 
          SA3    BIFARM 
          AX7    P.ARGMF
          =B3    O.ILP
          IX4    X6+X5       (X4) = ARGMIS = 42/ SYMBOL, 18/ TAG
          BX7    -X2*X7      ARGCOMA, ARGUMENT MODE 
          SA2    =4LLOCF
          IX5    X5-X2
          NZ     X5,PAR.BF1  IF NOT *LOCF*
          MX6    1
          LX6    P.AMFUN+1
          IX3    X6+X3       SPECIAL CASE FOR *LOCF*
 PAR.BF1  LX6    X3          (X6) = ARGMODE 
          LX7    P.ACM       SET DEFINED ARGUMENT MODE
          EQ     PAR.SPS     ENTER PAREN STACK
  
**        HERE IF REFERENCE TO AN EXTERNAL FUNCTION.
  
 PAR.XF   SA3    EXTFARM
          BX4    X7 
          IFBIT  X5,-BEF/EXT,PAR.XF5
          SA1    CSYMBOL     DPC FOR *BEF*
          AX6    P.2TAG 
          SA3    BEFXARM     IF BASIC EXTERNAL FUNCTION 
          IX4    X1+X6       42/ DPC FOR BEF, 18/ TAG FOR BEF 
          AX7    P.ARGMF     SET ARGUMENT MODE TYPE 
  
 PAR.XF5  MX0    -L.MODE
          SA2    TT=SCR 
          BX7    -X0*X7      MODE OF ARGUMENTS FOR FUNCTION 
          LX2    36 
          BX6    X3 
          LX7    P.ACM
          =B3    O.SLP
          IX7    X2+X7       18/FWA OF FUNCTION,18/ACM,18/0 
          SA3    DOORD
          ZR     X3,PAR.SPS  IF NOT INSIDE *DO* 
          SB7    X3 
          SA2    TS.STN 
          BX5    X7 
          SA1    X2+B7       LOAD STATEMENT TAG FOR *DO*
          =X0    M.SNEX 
          BX7    X0+X1       INDICATE EXTERNAL IN *DO*
          SA7    A1 
          BX7    X5 
          EQ     PAR.SPS
 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) = OPERATOR *DPC* TO BE ENTERED. 
*                (B4) _ LEFT PAREN IN *SB*
* 
*         EXIT   WITH *ADDOP* ENTRY CONDITIONS SET. 
* 
*                (X1) = DPC FOR CURRENT OP. 
*                (X2) = OPERATOR STACK ENTRY. 
*                (B4) _ NEXT *SB* ENTRY.
*                (B5) = UPDATED BY *4*
*         RESET - 
*                (ARGMODE,ARGCOMA,ARGMIS) 
*                (REFVAR) 
* 
*         OPERATOR STACK UPON EXIT. (B5 UPDATED BY L.PSTACK)
*                N   = OLD *ARGMODE*
*                N+1 = OLD *ARGCOMA*
*                N+2 = OLD *ARGMIS* 
*                N+3 = LEFT PAREN OPERATOR. 
  
  
 PAR.SPS  BX0    X6 
          SA2    ARGMODE
          SA6    A2          RESET NEW *ARGMODE*
          BX6    X2 
          =A6    B5+1        SAVE OLD VALUE FOR ARGMODE TO *OSTACK* 
          SA5    ARGCOMA
          SB5    B5+L.PSTACK
          BX6    X5 
          SA3    ARGMIS 
          SA7    A5          RESET NEW *ARGCOMA*
          =A6    A6+1        SAVE OLD VALUE FOR ARGCOMA TO *OSTACK* 
          LX7    X3 
          BX6    X4 
          SX1    B3          DPC FOR *(*
          =A7    A6+1        SAVE OLD VALUE FOR ARGMIS TO *OSTACK*
          SA2    LPAR 
          AX0    P.AMR
          =B4    B4+1        UPDATE TO NEXT ELEMENT 
          BX7    X0 
          SA6    A3          RESET NEW *ARGMIS* 
          SA7    REFVAR      SET REFERENCE CELL TO NEW VALUE
          MX0    -L.SBPR
          SB5    B5+B1
          BX3    X0*X2
          IX6    X3+X1
          SA6    B5 
          =A5    B4 
          SB3    X5 
          SA3    X1+CONOTBL-O.DEF 
          LX4    B3,X3
          PL     X4,PAREX 
          EQ     PAR.NX 
 PAR.CM   EJECT  4,8
**        PROCESS COMMA OPERATOR. 
  
 PAR.CM   SA4    ARGMODE
          SB2    X4-A=BIF 
          ZR     X5,PAR.CM8  IF *,* FOLLOWED BY *EOS* 
          ZR     B2,PAR.STD  IF INSIDE AN *INTRINSIC* 
  
**        POP HOLDING STACK FOR ARGUMENT. 
  
 PAR.CM5  AX3    L.SBPR 
          MX4    -L.STPR
          BX3    -X4*X3 
          SB7    PR.SLP+1 
          SB7    -B7
          SB7    X3+B7
          MI     B7,PAR.CM7  IF NOT ARITHMETIC OPERATOR 
          =X6    O.COMMA
          SA3    B5          OPERATOR POPPING.
          =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 
          SA2    COMMA       RELOAD COMMA OPERATOR
          MX0    -L.SBPR
          BX3    X0*X2
          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
          SB7    X3-A=LIST
          ZR     B7,PAREXIT  IF IN I/O LIST 
          =B4    B4+1        NEXT 
          EQ     PAR.NX      CONTINUE TO NEXT.
  
**        COMMA FOLLOWED BY *EOS*. ONLY ALLOWED IN I/O LIST.
  
 PAR.CM8  SB2    X4-A=LIST
          NZ     B2,PAREX    IF NOT I/O LIST PROCESSING 
          =B4    B4+1 
          EQ     PAR.NX      CONTINUE TO NEXT 
 PAR.LP   EJECT  4,8
**        FOUND UNQUALIFIED PARENTHESIS IN *SB* 
*         IF IT IS NOT PART OF A COMPLEX CONSTANT, THEN IT ENCLOSES 
*         SOME EXPRESSION.
* 
*         ENTRY  PAR.NX EXIT CONDITIONS 
* 
 PAR.LP   SA4    B4 
          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 
          =X7    M.CPLX 
          =B4    B4-1 
          EQ     TNK.DBL
 PAR.DLP  SPACE  4,8
**        DUMMY LEFT PAREN AT BEGINNING OF *SB* FOUND,
* 
*         PROCESS BY SETTING PAREN STACK TO PROPER MODE FOR OPERATING 
*         WITHIN CURRENT STATEMENT, THEN ADD SPECIAL PAREN TO OPERATOR
*         STACK.
  
 PAR.DLP  SA3    ARGMODE
          SA2    ARGCOMA
          SB3    X1          OPERATOR 
          BX6    X3 
          LX7    X2 
          EQ     PAR.SPS     SET PAREN STACK
 MISOPS   EJECT  4,20 
**        PROCESS MISCELLANEOUS OPERATORS CHECKING SYNTAX USAGE AND 
*         MISCELLANEOUS ERRORS. 
  
  
**        PROCESS *=*S, CHECKING FOR LAST/ NOT LAST *=*S. 
  
 PAR.EQL  SA4    ARGMODE
          MX0    1
          LX0    P.AMEQ+1 
          BX0    X0*X4
          NZ     X0,PAR.EQL2 IF *=* ALLOWED 
          FATAL  =XE.AT6     *ILLEGAL USE OF ASSIGNMENT OPERATOR* 
          =B4    B4+1        BYPASS BAD *=* 
          EQ     PAR.NX 
 PAR.EQL2 SA4    ZLE
          ZR     X4,PAR.STD  IF IN ZERO LEVEL.
          =B4    B4+1        IGNORE ( SEE *EOS* PROCESS.) 
          EQ     PAR.NX      CONTINUE. (IGNORING *=*) 
 COMPARE  EJECT  4,8
 PAR.PL   SPACE  4
**        CHECK IF PLUS IS UNARY
  
  
 PAR.PL   =A4    B4-1        LOAD LAST OPERATOR 
          SA5    ="PREUNAR" 
          SB7    X4 
          LX0    B7,X5
          PL     X0,PAR.STD  IF NOT UNARY PLUS
          SA4    ARGMODE
          SB7    X4-A=DO
          NZ     B7,PAR.PL1  NOT PROCESSING DO
          SA1    =XARGCOMA  DO INDEX NUMBER 
          SB3    X1 
          SA4    B3+=XDO.DPC   DPC FOR CURRENT INDEX
          BX6    X4 
          SA1    FILL.
          IX4    X6-X1
          ZR     X4,PAR.PL1  IF MESSAGE JUST GIVEN
          SA6    A1 
          ANSI   E.DO16      DO INDEX MUST BE SIMPLE INTEGER
 PAR.PL1  =B4    B4+1 
          EQ     PAR.NX      IGNORE UNARY PLUS
 PAR.MI   SPACE  4
**        CHECK IF MINUS IS UNARY 
  
  
 PAR.MIN  =A4    B4-1        LOAD LAST OPERATOR 
          SA5    ="PREUNAR" 
          SB7    X4 
          LX0    B7,X5
          PL     X0,PAR.STD  IF NOT UNARY MINUS 
          SA2    UMINUS 
          =X1    O.UMIN 
          EQ     PAR.STD     PROCESS AS UNARY MINUS 
 COMPARE  EJECT 
**        COMPARE CURRENT OPERATOR (COP) TO LAST OPERATOR (LOP).
* 
*         (X1) = DPC FOR CURRENT OPERATOR. (COP)
*         (X2) = COP *SETOP* WORD.
*         (X3) = LOP INSTACK *SETOP* WORD.
* 
*         IF COP .GT. LOP - ADD COP TO OPERATOR STACK.
* 
*         IF COP .LT. LOP - POP LOP AND CONTINUE TO POP UNTIL 
*                           COP .GT. LOP. 
  
  
 PAR.STD  LX3    -L.SBPR
          SB4    B4+B1
          MX4    -L.STPR
          SX0    X2          *SB* PRIORITY BITS ONLY
          BX5    -X4*X3 
          IX0    X0-X5
          LX3    L.SBPR      RESTORE *X3* 
          PL     X0,PAR.ADOP IF COP .GT. 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 ( IE. 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    -L.SBPR
          SB5    B5+B1       UPDATE POINTER 
          BX3    X0*X2
          IX6    X3+X1       PRIORITY + ORGINAL ENTRY 
          SA6    B5          ADD TO STACK 
          EQ     PAR.NX      CONTINUE.
 ERR      EJECT  4,8
**        HERE IF ILLEGAL COMBINATION OF OPERATOR/OPERANDS
  
 PAREX    SA4    ARGMODE
          BX0    X4 
          IFBIT  X0,-AMRP,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=DO
          ZR     B2,PAREX1   IF IN *DO* PROCESSING. (MUST BE I/O TYPE)
          SB2    X4-A=IF
          ZR     B2,PAREX1   IF IN *IF* PROCESSING. 
  
 PAREX3   MX0    L.CDPC 
          SA2    X1+CHARMAP 
          NZ     X2,PAREX5   IF NOT *SYMBOL*
          BX2    X1          USE *SB* SYMBOL. 
 PAREX5   BX6    X0*X2
          SA1    =4LNSTD
          BX4    X1-X6
          NZ     X4,PARX6    IF NOT *NON-STANDARD* PAREN
          SX6    1R(         GET LEFT  PAREN FOR ERROR MESSAGE
          LX6    54 
 PARX6    SA2    X5+CHARMAP 
          SA6    FILL.       SET FILLER.
          NZ     X2,PAREX10  IF NOT *SYMBOL*
          BX2    X5 
 PAREX10  BX6    X0*X2
          SB7    E.AT2
          SA6    A6+B1       SET FILLER.
          FATAL  B7          OUTPUT ERROR.
          SA1    B4 
          ZR     X1,PAR.EOS  IF END OF STATEMENT(*EOS*) 
 PAREX11  =B4    B4+1 
          SA1    TT.PAR 
          BX4    0
          =X5    0
          SB3    ERROP       EMIT *ERROR* OPERATOR
          SB3    -B3
          RJ     EMT
          EQ     PAR.NX      CONTINUE..  (IGNORING NASTY CHARACTER) 
 PAR.EOS  EJECT  4,8
  
**        END OF STATEMENT (*EOS*) FOUND IN *SB*
* 
*         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 *SB* 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 *SB* 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  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    P.SYM
          SA6    A2          REPLACE *=* WITH *EOS*.
          SB4    X2          RESET *B4* TO *=*
          SA1    "SB.BOS" 
          =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 
          SA2    EQUAL
          SA6    REFVAR      SET UP FOR *STORE* 
          ZR     B7,PAR.ADOP IF LEFT MEMBER IS A SYMBOL 
          FATAL  E.TE8       ILLEGAL LEFT MEMBER
  
**        HERE IF LAST *=* PROCESSED. 
  
 PAR.EOS3 SA1    ARGMODE
          =X3    O.COMMA
          IFBIT  X1,-AMEOS,PAREXIT
          BX6    X3 
          =X1    O.EOS
          =A6    B5+1 
          RJ     POP         POP LAST ARGUMENT
  
**        PAREXIT - EXIT PARSER.
* 
*         ENTRY  (B4) _ LAST ELEMENT PROCESSED IN *SB*. 
* 
*         EXIT   (B4) _ LAST ENTRY PROCESSED BY PARSER. 
  
  
 PAREXIT  SA2    FLOW        DEAD CODE FLAG 
  
 TEST     IFNE   TEST        DUMP PARSED FILE (IF IN TEST MODE) 
          SA1    CO.SNAP
          LX1    1RP
          PL     X1,PAR.EOSA IF SNAP NOT REQUESTED. 
          RJ     =XSN.PAR 
 PAR.EOSA BSS    0
 TEST     ENDIF  TEST 
  
 SNAP=Z   IFNE   TEST        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
          ZR     X2,PARX     EXIT.. (NOT DEAD CODE JUST PROCESSED)
          SA1    LDEAD
          SHRINK TT=PAR,X1   TRASH DEAD CODE JUST ADDED 
          EQ     PARX        EXIT.. 
  
**        FLUSH REMAINING OP STACKS.
  
 PAR.EOS6 SA3    B5          OPERATOR TO POP
          =B5    B5-1 
          SB2    X3-O.SLP 
          SB3    X3-O.LP
          ZR     B2,PAR.EOS8 IF *(* BEING POPPED
          NZ     B3,PAR.EOS7 IF NOT POPPING *LP*
          SB7    E.LP3
          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
          SB2    =XA=FMT
          SB3    X5 
          SB3    B3-B2
          NZ     B3,PAR.EOS9 IF NOT FORMAT INDICATOR
          SX1    O.)
          =X7    -1 
          SA7    POPPER 
 PAR.EOS9 BX6    X1 
          SA6    POPDPC      UPDATE   DPC   FOR OPERATOR
          =X1    O.EOS       INDICATE *(* BEING POPPED BY  *EOS*
          RJ     POP
 PAR.STOP SPACE  4,8
**        PAR.STOP - CATASTROPIC ERROR ENCOUNTERED IN CURRENT STATEMENT 
*                OUTPUT ERROR TURPLE AND EXIT BACK TO MASTER LOOP,
*                IGNORING RETURN TO CALLER OF PAR.
* 
*         ENTRY  N/A
* 
*         EXIT   TO *PSN* TO START ANEW 
* 
*         CALLS  ADT
  
  
 PAR.STOP SA3    ERROP
          =X7    0
          BX4    0
          LX6    X3 
          =X5    0
          SA7    SMOD 
          =A6    A7-SMOD+SOPR 
          RJ     ADT         ADD ERROR TURPLE 
          EQ     PSN         START ANEW.. 
 POP      EJECT  4,20 
**        POP -  POP INSTRUCTIONS IN TURPLE FORM FOR -*PASS TWO*
*                PROCESSING.
* 
*         ENTRY  (X1) = OPERATOR CAUSING (X3) TO BE POPPED. 
*                (X3) = CURRENT OPERATOR BEING POPPED.
* 
*                (B5) _ OPERATOR IN FRONT OF OPERATOR BEING POPPED. 
*                IE. IF .AND. BEING POPPED BY .NOT. THE OPSTACK 
*                    WOULD LOOK LIKE BELOW,  WITH B5 POINTING TO *EOS*. 
*                      OPSTACK =    0     1     2 
*                                 EOS .AND. .NOT. 
*                            B5     ' 
* 
*                (B6) _ LAST OPERAND IN STACK.
*                (A7) _ LAST POPPED TURPLE. 
* 
*         EXIT   (B6) _ INTERMEDIATE RESULTS OF TURPLE PROCESSED. 
* 
*                NOTE- NOT ALL SUB-PROCESSORS RELATED TO *POP* EXIT THRU
*                      POPX.
*                    A.  PARENTHESIS PROCESSORS EXIT DIRECTLY TO PAR.NX.
* 
*         USES   CANNOT DESTORY  B4,B5,B6 
  
  
 POP      SUBR   0
          =X6 
          SA5    TT.PAR 
          SA6    SMOD        CLEAR RESULTANT MODE 
          =X7    0
          BX6    X3 
          SA4    TT=PAR 
          SB3    X1 
          SA7    ATTR        CLEAR ATTRITBUTE CELL
          IX0    X4+X5
          SA6    SOPR        SAVE OPERATOR. 
          SX7    X0-L.TURP+OR.OPR 
          SA7    LASTAD      LAST TURPLE OPERATOR ADDRESS 
          SA4    B6-2        1ST OPERAND INTO (X4)
          SA5    X7 
          SA2    X3+POPTBL   RELATIVE TO OPERATOR BEING POPPED. 
          BX6    X5 
          =X7    0
          SA6    LASTOP      SET LAST OPERATOR
          =B2    0           ALWAYS A *0* UPON EXIT 
          LX0    B3,X2
          =A5    A4+1        2ND OPERAND INTO (X5)
  
 SNAP=Z   IFNE   TEST        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 
          IFBIT  X6,-COM,POP.JP    IF NOT COMMUNIATIVE OPERATOR 
  
**        FIX ORDER OF COMMUTATIVE OPERATORS IN TAG NUMERIC ORDER 
  
          IX7    X4-X5
          BX1    X4 
          PL     X7,POP.JP   IF IN NUMERIC ORDER
          BX4    X5 
          LX5    X1 
  
**        CHECK IF SPECIAL PROCESSING NECESSARY FOR OPERATOR. 
* 
*         IF (B7) = 0 
*                NO SPECIAL PROCESSING NECESSARY, EXIT TO POP.STD 
*         IF (B7) = 0 
*                SPECIAL PROCESSING REQUESTED FOR THIS COMBINATION OF 
*                OPERATORS. 
* 
*         IN ALL CASES THE FOLLOWING REGISTERS ARE SET = TO.
* 
*         (B2) = ALWAYS A *0* UPON EXIT 
*         (B3) = DPC FOR OPERATOR CAUSING POP 
* 
*         (X3) = OPERATOR.
*         (X4) = 1ST OPERAND
*         (X5) = 2ND OPERAND
*         (X7) = 0, IF OPERANDS NOT REVERSED
  
 POP.JP   PL     X0,POP.STD  IF NO SPECIAL PROCESSING 
          JP     B7          JUMP TO SPECIAL CHECK
 C=OPER   EJECT  4,20 
**        POP.CM - PROCESSING OF A COMMA. 
* 
*         C=XXX PROCESSING SECTION. 
* 
*         ENTRY  (ARGMODE) = CURRENT VALUE FOR C= IN DEFINED FIELD. 
*                IF C= FIELD IS ZERO, COMMA IS NOT-DEFINED. 
* 
*                (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.CM   SA1    ARGCOMA
          =X0    1
          SA2    ARGMODE
          IX6    X1+X0       UPDATE NUMBER OF ARGUMENTS 
          MX0    -L.AMC 
          BX7    X2 
          AX2    P.AMC
          BX0    -X0*X2      C=XXX ADDRESS
          SA6    A1 
          SB2    X0 
          ZR     B2,*+400000B 
  
**        EXIT CONDITIONS 
*         (B2) = C=XXX ADDRESS
*         (X2) = (ARGMODE) SHIFTED BY P.AMC 
*         (X6) = CURRENT VALUE OF *ARGCOMA* 
          JP     B2          JUMP TO INDIVIDUAL PROCESSORS. 
 C=ERR    SPACE  4,8
**        C=CERR - IF COMMA NOT ALLOWED FOR PAREN LEVEL CURRENTLY IN. 
  
  
 C=CERR   FATAL  E.AT5
 C=ERR    SA3    ERROP
          =X7    0
          BX4    0
          =X5    0
          SA7    SOPR 
          EQ     POP.ST1     ADD ERROR TURPLE 
 C=CALL   SPACE  4,8
**        C=CALL - PROCESS ARGUMENT FROM CALL STATEMENT 
*         (X5) = ARGUMENT.
  
 C=FUN    BSS    0           EQUIVALENT TO C=CALL 
 C=CALL   RJ     ESC         EXPAND SHORT CONSTANT
          RJ     SDB         SET DEFINED BIT IF VARIABLE
          SB3    CALLOP 
          SB3    -B3
          =X4    0           1ST OPERAND = DUMMY
          =B6    B6-1        REMOVE ARGUMENT FROM STACK 
          SA1    TT.SCR 
          RJ     EMT         EMIT ARGUMENT LOAD TO SCRATCH TABLE
          EQ     POPX 
 C=GOT    SPACE  4,8
**        C=GOT - PROCESS *EOS* OF COMPUTED *GOTO*. 
*                IF NOT AT *EOS* - COMMA IS ILLEGAL 
*                OTHERWISE PROCESS RESULTS FOR *GO TO* PROCESSOR
  
  
 C=GOT    SA2    B4 
          BX1    X5 
          NZ     X2,C=CERR   IF NOT AT *EOS*
          IFBIT  X1,-INTR,C=GT5    IF NOT INTERMEDIATE
          ANSI   E.GO9       MUST BE SIMPLE INTEGER VARIABLE
  
**        CHECK MODE OF RESULTS OF *GO TO* EXPRESSION 
  
 C=GT5    MX0    -L.MODE
          BX2    -X0*X5 
          SB7    X2-M.LOG 
          NZ     B7,C=GT7    IF NOT LOGICAL RESULTS 
          FATAL  E.GO10 
          EQ     C=ERR
  
 C=GT7    =B7    B7+M.LOG-M.INT 
          BX4    X5          EXPRESSION RESULTS = OR.1OP
          ZR     B7,C=GT10   IF INTEGER RESULTS 
          ANSI   E.GO11      MUST BE INTEGER
          SA3    INTMAC 
          BX5    X4 
          =X4    0
          BX6    X3 
          =B6    B6+1 
          SA6    SOPR 
          RJ     ADT         OUTPUT *INT* TURPLE
          =A4    B6-1        RESULTS OF *INT* 
 C=GT10   =X3    O=GOC
          SA5    =XTRLINE 
          SA1    GOTA        NUMBER OF BRANCHES 
          SX5    X5-7777B 
          MI     X5,C=GT12
          =X3    =XO=GOCL 
          =X1    X1+1        CHANGE TEST TO 2 .LE. ARG .LE. N+1 
 C=GT12   LX3    P.JPAD 
          SX6    O.GOTC 
          BX6    X6+X3
          BX5    -X1         COMPLEMENT 
          BX3    X6 
          LX5    P.PTAGL
          SA6    SOPR        SET OPERATOR 
          EQ     POP.ST1     POPIT. 
 C=BEF    SPACE  4,8
**        C=BEF - PROCESS BASIC EXTERNAL FUNCTION ARGUMENT, CHECKING
*         IF MODE OF ARGUMENT AGREES WITH DEFINED TYPE, AND OUTPUTING 
*         TURPLE FOR ARGUMENT 
*         (ARGMIS) = 42/ DPC FOR BEF, 18/TAG FOR BEF
  
  
 C=BEF    SA2    ARGCOMA
          SA3    ARGMIS 
          BX1    X5 
          AX2    P.ACM
          RJ     VAM         VALIDATE AGRUMENT MODE ARGEEMENT 
          RJ     ESC         EXPAND SHORT CONSTANT
          SA1    CO.TBK 
          SB3    CALLOP 
          SB3    -B3
          MI     X1,C=BEF4   IF TRACKBACK SELECTED
          SA3    REGARG 
          SA7    SMOD 
          ALLOC  TT.SCR,1 
          BX7    X5 
          SA7    B7-B1
          =B6    B6-1        REMOVE ARGUMENT FROM STACK 
          EQ     POPX 
  
 C=BEF4   =X4    0           1ST OPERAND = DUMMY
          SA1    TT.SCR 
          =B6    B6-1        REMOVE ARGUMENT FROM STACK 
          RJ     EMT         EMIT ARGUMENT LOAD TO SCRATCH TABLE
          EQ     POPX 
 C=BIF    SPACE  4,8
**        C=BIF- PROCESS INTRINSIC FUNCTION ARGUMENT CHECKING IF MODE 
*                OF ARGUMENT AGREES WITH DEFINED TYPE.
  
  
 C=BIF    SA2    ARGCOMA
          BX1    X4 
          SB7    X2 
          SA3    ARGMIS 
          AX2    P.ACM
          GT1    B7,C=BIF5   IF ALREADY VALIDATED MODE OF 1ST ARGUMENT
          RJ     VAM         VALIDATE 1ST ARGUMENT MODE 
 C=BIF5   SA1    =5LSHIFT 
          IX1    X3-X1
          AX1    24 
          NZ     X1,C=BIF7   IF NOT INTRINSIC *SHIFT* 
          =X2    M.INT
 C=BIF7   BX1    X5 
          RJ     VAM         VALIDATE 2ND ARGUMENT MODE 
          SA1    BIFFUN 
          SA2    TS.SYM 
          MX0    -L.JPADF 
          SB2    X3-C.SYM 
          MX7    -3 
          SA2    X2+B2       FETCH SYMBOL TABLE ENTRY 
          BX7    -X7*X2      ISOLATE MODE 
          AX2    P.JPADF
          BX6    -X0*X2      ISOLATE RELATIVE SKELETON ADDRESS
          SX2    X6+INLBASE 
          SB7    X6-1S8 
          SA7    SMOD 
          MI     B7,C=BIF10  IF NOT SPECIAL FUNCTION
          RJ     ESF         EVUALATE SPECIAL FUNCTION
          MI     X2,POPX     IF FUNCTION REDUCED
  
 C=BIF10  LX2    P.JPAD      ACTUAL MACRO ADDRESS 
          IX3    X1+X2
          SA1    ARGMIS 
          MX0    L.SYM
          BX1    X0*X1
          =B7    1
 C=BIF11  SA2    B7+DMINMAXT
          IX2    X1-X2
          ZR     X2,POP.STD  IF *DMAX1* OR *DMIN1*
          =B7    B7-1 
          MI     B7,POP.ST1  IF NOT 
          EQ     C=BIF11
  
 DMINMAXT BSS    0
          CON    5LDMAX1
          CON    5LDMIN1
 C=DEC    SPACE  4,8
**        C=DEC - PROCESS *,* FOR EXPRESSION IN DECLARATIVE 
* 
*         ENTRY  (X6) = RESULTS OF EXPRESSION.
* 
*         EXIT   PAR.EXIT 
  
  
 C=DEC    SB4    B4+1 
          EQ     PAREXIT     EXIT POINTING TO NEXT CHARACTER
 C=DO     SPACE  4,8
 C=DO     SPACE  4,8
**        C=DO-  CHECK INDICES OF *DO* LOOP 
* 
*         ENTRY- (X4) = INDEX VARIABLE. 
*         (X6) = INDEX NUMBER. (ARGCOMA)
  
  
 C=DO     MX0    -L.MODE
          SB3    X6-1 
          SA2    B3+DO.DPC   LOAD DPC FOR CURRENT INDEX PROCESSING
          ZR     B3,C=DO1    IF PROCESSING CONTROL INDEX
          BX4    X5 
 C=DO1    BX6    X2 
          LX1    X4 
          SA6    FILL.       DPC FOR CURRENT INDEX. 
          RJ     LCT         CHECK IF CONSTANT
          SA2    X0+DO=IX 
          BX3    X6 
          SB7    X2 
  
**        EXIT   (X0) = MODE OF INDEX 
*                (X3) = BINARY OF CONSTANT. 
*                (B2) = 0, IF INDEX NOT A CONSTANT
*                (B3) = INDEX TYPE. 
  
          JP     B7          JUMP RELATIVE TO MODE OF INDEX.
 DO=IX    SPACE  4,8
*         DO=IX - INDEX JUMP TABLE RELATIVE TO MODE OF INDEX. 
  
  
 DO=IX    BSS    0
          LOC    M.UNIV 
  
          CON    IX=UNIV     INDEX JUMP TABLE.
          CON    IX=LOG 
          CON    IX=INT 
          CON    IX=REAL
          CON    IX=DBL 
          CON    IX=CPLX
          LOC    *O 
 IX=UNIV  SPACE  4,8
*         IF INDEX IS CHAMELON
  
  
 IX=UNIV  ZR     B3,DOER17   IF CONTROL INDEX, ERROR
          ANSI   E.DO16      NON ANSI INDEX 
          EQ     IX=INT 
 IX=LOG   SPACE  4,8
*         IF INDEX IS LOGICAL, REAL, DOUBLE OR COMPLEX. 
  
  
 IX=REAL  BSS    0
 IX=DBL   BSS    0
 IX=CPLX  BSS    0
 IX=LOG   ZR     B3,DOER17   IF CONTROL INDEX, ERROR
          FATAL  E.DO1
          EQ     DO.ERR 
 IX=INT   SPACE  4,8
*         IF INDEX IS INTEGER.
  
  
 IX=INT   ZR     B2,C=DO10   IF NOT CONSTANT
          NZ     B3,C=DO6    IF NOT CONTROL INDEX 
  
 DOER17   FATAL  E.DO17      CONTROL INDEX NOT INTEGER
          EQ     DO.CON6
 IX=REAL  SPACE  4,8
*         CHECK CONSTANT INDEX USE. 
  
 C=DO6    BX0    X3 
          MI     X3,C=DO6A   IF INDEX IS NEGATIVE 
          NZ     X3,C=DO6B   IF INDEX IS NOT ZERO 
 C=DO6A   FATAL  E.DO5       INDEX NOT .GT. ZERO
          EQ     DO.ERR 
 C=DO6B   SX2    377776B     MAXIMUM VALUE OF DO INDEX
          IX2    X2-X0
          PL     X2,C=DO6C   IF INDEX IS NOT TOO LARGE
          FATAL  E.DO3       INDEX TOO LARGE
          EQ     DO.ERR 
 C=DO6C   SA2    IXLASTV     LAST VALUE OF INDEX
          BX6    X3 
          IX0    X3-X2
          SA6    A2          RESET INDEX
          PL     X0,C=DOX    IF NON-NEGATIVE DIFFERENCE, EXIT.. 
          SB2    B3-3 
          ZR     B2,C=DOX    IF PROCESSING INCREMENT, EXIT..
          WARN   E.DO2       ** ONE-TRIP ** 
          EQ     C=DOX       EXIT.. 
 IX=TAG   SPACE  4,8
**        PROCESS WHEN INDEX IS A TAG.
  
 C=DO10   BX0    X4 
          AX0    P.TAG
          BX1    X4 
          IFBIT  X1,-INTR,C=DO15   IF NOT INTERMEDIATE
          FATAL  E.DO4       NOT A SIMPLE VARIABLE
          EQ     DO.ERR 
 C=DO15   SA1    TS.SYM 
          SB7    X0-C.SYM 
          SA2    B7+X1
          NZ     B3,C=DO16         IF NOT CONTROL INDEX 
          =X3    M.DEF
          BX6    X2+X3             SET DEFINE BIT 
          SA6    A2 
          IFBIT  X2,-VAR,C=DO16A     IF NOT SIMPLE VARIABLE 
          IFBIT  X2,-FPS/VAR,C=DO16A IF NOT FP USED AS A SUBSCRIPT
          SA2    A2-B1               POINTS TO SYMBOL IN TS.SYM 
          MX6    L.SYM
          BX6    X2*X6               EXTRACT SYMBOL 
          SA6    FILL.
          ANSI   =XE.AT13            REDEFINITION OF FPS IS NON-ANSI
          SA2    A2+B1
          EQ     C=DO16 
 C=DO16A  SA2    A2                  RESTORE X2 
 C=DO16   IFBIT  X2,VAR,C=DO20     IF A VARIABLE
          FATAL  E.DO4       INDEX MUST BE SIMPLE VARIABLE
          EQ     DO.ERR 
 C=DO20   BX6    0
          SA6    IXLASTV
          EQ     C=DOX        EXIT..
 IX=INTR  SPACE  4,8
**        C=DOX - ADD INDEX TO *TP.DO* TABLE
* 
*         ENTRY  (X4) = CURRENT INDEX VALUE.
*                (B3) = CURRENT INDEX NUMBER. 
*                     = 0, CONTROL
*                     = 1, INITIAL
*                     = 2, LIMIT
*                     = 3, INCREMENT
*                     = 4, ERROR
* 
*         EXIT   POPX 
  
 C=DOX    SA1    B3+DO.INX
          SA3    TP.DO
          SA2    TP=DO
          SB7    X1          JUMP ADDRESS 
          IX0    X2+X3
          BX6    X4          INDEX TAG
          SB2    X0-L.DOE    FWA FOR CURRENT DO ENTRY 
          JP     B7 
  
 DO.INX   BSS    0
          CON    DO.CON 
          CON    DO.INIT
          CON    DO.LIM 
          CON    DO.INCR
          CON    DO.ERR1
  
**        RETURN FOR ALL *DO* DEFINITION ERRORS.
  
 DO.ERR1  FATAL  E.DO 
          EQ     PARX        EXIT PAR ENTIRELY
 DO.ERR   =B6    B6-1        ELIMINATE OPERAND
          EQ     POPX        EXIT.. 
  
**        PROCESS *INITIAL* INDEX 
  
 DO.INIT  =B6    B6-1        ELIMINATE OPERAND IN STACK 
          =X0    PR.SLP 
          =X3    O.COMMA
          LX0    P.STPR 
          SA6    B2+OR.DOSI  INITIAL TO DO TABLE
          BX7    X0+X3
          SA7    B5          REPLACE *=* WITH SPECIAL *COMMA* 
          EQ     POPX        CONTINUE - POPPING DO TURPLE 
  
**        PROCESS *LIMIT* INDEX 
  
 DO.LIM   =X0    M.SHORT
          SA1    CONONE 
          BX3    X0*X6
          ZR     X3,DO.LIM2  IF *LIMIT* NOT SHORT CONSTANT
          AX6    P.SHC
          MX0    -L.SHC 
          =X4    X6+1 
          BX2    -X4         COMPLEMENT FOR ADD IN
          SX3    M.SHORT+M.INT
          BX7    -X0*X2      EXTRACT *SHORT* LENGTH ONLY
          LX7    P.SHC
          BX6    X7+X3       ALWAYS *INTEGER* REGARDLESS OF ORGINAL MODE
 DO.LIM2  SA6    B2+OR.DOLI  SET *LIMIT* IN *DO* TABLE
          BX7    X1 
          SA2    B2+OR.DOSN 
          SA7    B2+OR.DOII  PRESET INCREMENT = 1 
          SX6    X2 
          NZ     X6,DO.LIM5  IF IN I/O LIST PROCESSING. 
          SA2    TG.PRO      GET GENERATED LABEL TO TAG START OF DO 
          =X6    X2+1 
          SA6    A2          UPDATE L-TAG 
 DO.LIM5  =B6    B6-1 
          SA6    B2+OR.DORT  RETURN TAG TO TABLE. 
          EQ     POPX        EXIT.. 
  
**        PROCESS *INCREMENT* INDEX 
  
 DO.INCR  SA6    B2+OR.DOII  SET INCREMENT
          =B6    B6-1 
          EQ     POPX        EXIT.. 
  
**        PROCESS *CONTROL* INDEX 
  
 DO.CON   BX1    X4          CONTROL INDEX
          SA2    TP.DO
          LX6    X1 
          SB7    B2+OR.DOCI 
          SA6    DOIX        ACTIVE *DO* INDEX
          SA6    B2+OR.DOCI  CONTROL INDEX TO TP.DO 
          SB3    X2+OR.DOCI 
          SA1    X2+OR.DOCI 
          EQ     DO.CON5     CHECK IF INDEX ALREADY IN USE. 
  
**        CHECK IF CURRENT *DO* CONTROL VALUE ACTIVE BY OTHER *DO*
  
 DO.CON1  BX3    X1-X6
          SB3    B3+L.DOE 
          AX3    P.TAG
          NZ     X3,DO.CON2  IF INDEX NOT REDEFINED 
          FATAL  E.DO11      INDEX OF OUTER DO REDEFINED
          EQ     DO.CON6
 DO.CON2  SA1    B3 
 DO.CON5  LT     B3,B7,DO.CON1     IF NOT END OF TABLE. 
  
 DO.CON6  =X1    1
          SA2    ARGCOMA
          IX6    X2+X1
          SA6    A2          UPDATE *ARGCOMA* 
          EQ     C=DO        CONTINUE, PROCESSING *INITIAL* 
  
**        (*IXLASTV*)  THE LAST INDEX VALUE, IF INDEX WAS A VARIABLE
*         *IXLASTV* WILL CONTAIN A ZERO.
  
 IXLASTV  DATA   0           LAST VALUE OF *DO* INDEX PROCESSED.
 POP.RP   SPACE  4,8
**        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
*         RIGHT PAREN - ERROR = TOO FEW RIGHT PARENS
* 
*         EXIT   C=ERR
  
  
 POP.RP   =A1    B5+1 
          AX1    18          TEST FOR SPECIAL RP
          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.LP4
 POP.RP5  FATAL  B7 
          EQ     PAR.STOP    CATASTROPIC ERROR, START ANEW
 POP.PN   EJECT  4,30 
**        POP.PN -  PROCESS 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 *SB* 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.
* 
*                B5-3   =   ARGMODE.
*                B5-2   =   ARGCOMA 
*                B5-1   =   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. 
*                (B2) = CURRENT VALUE OF ARGCOMA
*                (B3) = CURRENT VALUE OF ARGMODE. 
*                (B4) _ RIGHT PARENTHESIS IN *SB*.
*                (POPPER) = TABBED VALUE FOR RIGHT PAREN OPERATOR.
* 
*         EXIT   DEPENDING ON THE PARTICULAR VALUE FOR A=, EXIT IS THRU 
*                A.  POP.STD - TO PROCESS OPERATOR. 
*                B.  POPX    - IGNORE OPERATOR. 
*                              (NOTE - IN CERTAIN *POPPER* IS SET TO
*                                      INDICATE BY-PASSING OF PAREN.) 
* 
*         USES   A2,A3,A4,A6  X5  B3
  
  
 POP.PN   SA4    ARGMODE
          SA3    POPDPC 
          SA5    ARGCOMA
          SB2    X3-O.RP
          SB3    X4 
          SA3    ARGMIS 
          SB7    E.LP3       IN CASE OF PAREN MIS-MATCH 
          NZ     B2,POP.RP5  IF *(* NOT BEING POPPED BY *)* 
          BX7    X4 
          SB2    X5 
          SA7    SCR         SAVE CURRENT *ARGMODE* 
          LX6    X5 
          BX7    X3 
          SA2    B5-2        TO BE USED FOR RESETTING ARGMODE.
          =A6    A7+1        SAVE CURRENT *ARGCOMA* 
          =A4    A2+1        TO BE USED FOR RESETTING ARGCOMA.
          =A7    A6+1        SAVE CURRENT *ARGMIS*
          BX6    X2 
          SB5    B5-L.PSTACK RESET *OSTACK* POINTER 
          SA3    CMLFLG 
          =A5    A4+1        TO BE USED FOR RESETTING ARGMIS. 
          SX2    X3+B5
          SA6    ARGMODE     RESET ARGMODE
          NZ     X2,POP.PN1  IF NO NEED TO RESET FLAG 
          =X7    1
          SA7    A3 
 POP.PN1  AX6    P.AMR
          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        BY-PASS 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)
*         (X5) = 2ND OPERAND
*         (B2) = NUMBER OF ARGUMENTS -1 INSIDE PARENS.
*         (B4) _ NEXT ELEMENT PAST CLOSING RIGHT PAREN
* 
*         (SCR)  = (ARGMODE) FOR PAREN BEING CLOSED.
*         (SCR+1)= (ARGCOMA)  -    -     -      - 
*         (SCR+2)= (ARGMIS )  -    -     -      - 
  
          JP     B3 
 A=ASF    SPACE  4,8
**        A=ASF -ASF TERMINATION. 
* 
*         PARSER COMES HERE TO TERMINATE AN *ASF* EXPANSION.
* 
*         ENTRY  B4_ NEXT CHARACTER AFTER *ASF* *)*.
* 
*         EXIT   (INAFR)   CLEARED
*                (B4)      RESET TO *SB*
*                (ALC.REG) RESET TO *SB*
*                (TT=ASF)  RESET TO REAL LENGTH 
  
  
 A=ASF    =A4    B6-1        FETCH LAST ESTACK ENTRY
          MX0    -L.MODE
          SA2    SCR+2       ASF *ARGMIS* VALUE 
          BX1    -X0*X4 
          ZR     X1,A=ASF2   IF ASF EXPR TYPELESS 
          BX0    X1-X2
          ZR     X0,A=ASF1   IF NO MODE CONVERSION NEEDED 
          =X6    1           FIRST (ONLY) OPERAND TO BE CONVERTED 
          LX6    18 
          BX6    X2+X6
          SA6    SMOD        SET SMOD FOR OMC 
          LX2    3           8*MODE = SHIFT COUNT 
          SB2    X2 
          SA2    X1+MODTBL   MODE CONVERSION TABLE ENTRY
          MX0    -8 
          AX6    B2,X2
          BX6    -X0*X6      ONLY 8 BITS FOR EACH MODE
          ZR     X6,A=ASF1   IF NO CONVERSION NEEDED
          SB2    X6-377B
          NE     B2,A=ASF0   IF LEGAL CONVERSION
          FATAL  E.AT12 
          SA2    SCR+2
          EQ     A=ASF3 
  
 A=ASF0   =A6    A6-SMOD+SMOD1  SET SMOD1 FOR OMC 
          RJ     OMC         MODE CONVERSION
 A=ASF1   SA1    B4 
          NZ     X1,PAR.NX   IF NOT *EOS* 
          SA3    ALC.00 
          SA1    ASFLEN 
          SA2    INAFR
          BX7    X3 
          LX6    X1 
          SB4    X2          INPUT CURSOR BACK TO *SB*
          SA7    ALC.REG     UNLOCK *B4*
          SHRINK TT=ASF,X6   ERASE EXPANDED STATEMENT FUNCTION
          BX7    0
          SA7    A2          INDICATE NO STATEMENT FUNCTION IN PROGRESS 
          EQ     PAR.NX      CONTINUE TO PROCESS REST OF STATEMENT
 A=ASF2   SB2    X2-M.LOG    HERE IF ASF EXPR TYPELESS
          NE     B2,A=ASF3   IF ASF MODE NOT LOGICAL
          WARN   E.AT11 
 A=ASF3   BX4    X0*X4       CHANGE EXPR MODE TO ASF MODE 
          BX6    X4+X2
          SA6    A4 
          EQ     A=ASF1 
 A=BEF    SPACE  4,8
**        A=BEF  TERMINATE END OF ARGUMENT LIST FOR *BASIC EXTERNAL*
* 
**        VALIDATE ARGUMENT LIST AGREEMENT WITH THAT DEFINED FOR CURRENT
*         BASIC EXTERNAL, OUTPUT TURPLE FOR FINAL ARGUMENT
  
  
 A=BEF    SA4    SCR+2       RELOAD A= ARGMIS (ROUTINE NAME)
          LX4    P.2TAG 
          RJ     VIL         VALIDATE BEF ARGUMENT LIST AGREEMENT 
  
          SA3    SCR+2       RELOAD A= ARGMIS (ROUTINE NAME)
          =A2    A3-1        RELOAD A= ARGCOMA
          BX1    X5 
          AX2    P.ACM
          RJ     VAM         VALIDATE FINAL ARGUMENT MODE 
          SA4    A4 
          BX6    X4 
          SA6    SCR+3       SAVE ROUTINE TAG 
          SA1    CO.TBK 
          PL     X1,A=BEF2   IF TRACEBACK OFF 
          SA1    TS.SYM 
          SB7    X1 
          SA4    A4-B7       RELATIVIZE SYMTAB POINTER
          RJ     FAL         FLUSH ARGUMENT LOAD TURPLES
          SA1    TS.SYM 
          SB7    X1 
          SA4    A4+B7       RELOAD TAG 
  
          MX4    0
          EQ     A=BEF3 
  
 A=BEF2   MX4    0           INITIALIZE TO NO FIRST ARGUMENT
          SA1    SCR+1
          SA2    TT=SCR 
          AX1    36 
          IX3    X2-X1       NUMBER ENTRIES IN TT.SCR 
          ZR     X3,A=BEF3   IF NO SAVED ARGUMENTS
          SA2    TT.SCR 
          IX2    X2+X1       GET POINTER TO FIRST ARGUEMENT 
          SA2    X2 
          BX4    X2          SET UP FIRST ARGUMENT
          SHRINK TT=SCR,X1   COLLAPSE TABLE 
 A=BEF3   MX0    -L.MODE
          SA2    A4 
          SA1    CO.TBK 
          SA3    CALLOP 
          BX7    -X0*X2      RESULT MODE
          MI     X1,A=BEF4   IF TRACKBACK SELECTED
          AX2    P.ARGC 
          MX6    -L.ARGC
          BX6    -X6*X2      NUMBER OF ARGUMENTS
          AX6    1
          SB2    X6          NUMBER ARGUMENTS - 1  (0 OR 1) 
          SA3    =XREGARG+B2 REGARG OR REGARG2
          AX2    P.ARGMF-P.ARGC 
          BX2    -X0*X2      MODE OF ARGUMENTS
          SX0    M.LONG 
          BX2    X0*X2
          AX2    P.LONG      0 FOR SINGLE WORD, 1 FOR DOUBLE
          SA1    BEF.ARG+B2 
          BX6    X6*X2       1 IFF 2 DOUBLE-WORD ARGUMENTS
          SB2    X6 
          SA1    A1+B2       GET PROPER WORD OUT OF TABLE 
          LX2    4
          SB2    X2 
          MX0    -16
          AX1    B2          GET PROPER 16-BIT ENTRY OUT OF WORD
          BX1    -X0*X1 
          LX1    P.JPAD 
          BX3    X3+X1
 A=BEF4   BX6    X3 
          BX6    X3 
          SA6    SOPR 
          SA7    SMOD 
          RJ     ESC         EXPAND SHORT CONSTANT
          SA3    SOPR 
          RJ     ADT         ADD TURPLE FOR LAST ARGUMENT 
  
          SA1    CO.TBK 
          SA3    EXTFUN 
          MI     X1,A=BEF6   IF TRACKBACK SELECTED
          SA3    BEFFUN 
 A=BEF6   SA2    TT=PAR 
          SA1    SCR+3       RESTORE ROUTINE TAG
          =X7    X2+L.TURP
          SA7    CURST       RESET RELATIVE SQUEEZE START 
          LX5    X3          SAVE OPERATOR
          RJ     CT2         CONVERT TAG TO PASS *2* FORM 
          BX3    X5          OR.OPR 
          LX4    X6          OR.1OP = EXTERAL ROUTINE NAME
          =X5    0           OPERAND TWO = 0
          =B6    B6+1        DUMMY TO RESTORE ELEMENT STACK 
          EQ     POP.ST1     CONTINUE 
 A=BIF    SPACE  4,8
**        A=BIF - PROCESS CLOSING *)* FOR INTRINSICS
*         (X2) = ARGCOMA. 
  
  
 A=BIF    SA4    SCR+2       RELOAD A= ARGMIS (ROUTINE NAME + TAG)
          LX4    P.2TAG 
          ZR     B2,A=BIF5   IF ONE ARGUMENT, PAREN ACTS AS COMMA 
          RJ     VIL         VALIDATE INTRINSIC LIST
          MX0    -L.MODE
          SA1    B6-2        FUNCTION 
          BX2    X0*X5
          =B6    B6-1        ELIMINATE FUNCTION 
          BX3    -X0*X1 
          IX6    X2+X3       RESET RESULT MODE
          =A6    B6-1        RESET INTERMEDIATE 
          SA1    SCR+2       RELOAD *BIF* ARGMIS
          MX0    L.SYM
          BX1    X0*X1
          SB7    3
 A=BIF1   SA2    B7+MINMAXT 
          IX3    X2-X1
          ZR     X3,A=BIF2   IF *MAX1*, *MIN1*, *AMAX0* OR *AMIN0*
          =B7    B7-1 
          MI     B7,POPX     IF NONE OF THE ABOVE, EXIT.. (IGNORE)
          EQ     A=BIF1 
  
*         MODE CONVERSION NECESSARY 
  
 A=BIF2   MX0    -L.MODE
          BX1    -X0*X6      MODE OF FUNCTION 
          SB7    X1-M.INT 
          ZR     B7,A=BIF3   IF *MAX1* OR *MIN1*
          SX2    M.INT
          EQ     A=BIF4 
 A=BIF3   SX2    M.REAL 
 A=BIF4   BX6    X0*X6       REMOVE FUNCTION TYPE 
          IX6    X2+X6       AND RESET WITH ARGUMENT TYPE 
          SA6    A6 
          BX4    X6 
          =X6    1
          LX6    18 
          BX6    X1+X6
          SA6    SMOD        SET SMOD FOR OMC 
          LX1    3           8*MODE = SHIFT COUNT 
          SB2    X1 
          SA1    X2+MODTBL
          MX0    -8 
          AX6    B2,X1
          BX6    -X0*X6 
          =A6    A6-SMOD+SMOD1  SET SMOD1 FOR OMC 
          RJ     OMC         MODE CONVERSION
          EQ     POPX        EXIT.. (IGNORE)
  
*         TABLE OF FUNCTION NAMES WHICH REQUIRE MODE CONVERSION 
  
 MINMAXT  BSS    0
          CON    5LAMAX0
          CON    5LAMIN0
          CON    4LMAX1 
          CON    4LMIN1 
  
 A=BIF5   RJ     VIL         VALIDATE INTRINSIC LIST
          SA1    B6-2        FUNCTION 
          MX0    -L.MODE
          =A2    SCR+1       ARGCOMA
          BX6    -X0*X1      RESULT MODE
          =A5    B6-1        ARGUMENT 
          AX2    P.ACM
          SA6    SMOD        SET RESULT MODE
          =A3    A2+1 
          BX1    X5 
          RJ     VAM         VALIDATE ARGUMENT MODE 
          SA1    BIFFUN 
          =X4                DUMMY OR.1OP 
          MX0    -L.JPADF 
          SA2    A4          FETCH SYMBOL TABLE ENTRY (A4 SET IN VIL) 
          AX2    P.JPADF
          BX6    -X0*X2      ISOLATE RELATIVE SKELETON ADDRESS
          SX2    X6+INLBASE 
          SB7    X6-1S8 
          MI     B7,A=BIF10  IF NOT SPECIAL FUNCTION
          RJ     ESF         EVUALATE SPECIAL FUNCTION
          MI     X2,POPX     IF FUNCTION REDUCED
  
 A=BIF10  LX2    P.JPAD 
          IX3    X1+X2
          EQ     POP.ST1     POP LIKE COMMA, BY-PASS *SDM*
 A=DEC    SPACE  4,8
**        A=DEC - PROCESS *,* FOR EXPRESSION IN DECLARATIVE 
* 
*         ENTRY  (X6) = RESULTS OF EXPRESSION.
* 
*         EXIT   PAR.EXIT 
  
  
 A=DEC    EQ     PAREXIT
 A=CALL   SPACE  4,8
**        A=CALL - PROCESSING CLOSING OF CALL LIST. 
  
  
 A=CALL   SA4    CALLTAG     RELOAD TAG FOR EXTERNAL SET BY *CLL* 
          RJ     VEL         VALIDATE ARGUMENT LIST 
          RJ     FAL         FLUSH ARGUMENT LOAD TURPLES
          RJ     ESC         EXPAND SHORT CONSTANT
          RJ     SDB         SET DEFINED BIT IF VARIABLE
          SA3    CALLOP 
          BX4    0           1ST OPERAND = DUMMY
          LX6    X3 
          SA6    SOPR 
          RJ     ADT         ADD TURPLE 
          SA1    B4 
          ZR     X1,A=CALL5  IF *EOS* 
          SB7    X1-O.COMMA 
          ZR     B7,A=CALL4 
          SA3    X1+CHARMAP 
          NZ     X3,A=CALL3  IF NOT CONS OR VAR 
          LX3    X1 
 A=CALL3  MX0    L.CDPC 
          BX6    X0*X3
          SA6    FILL.
          EQ     =XE.TY      OUTPUT ERROR 
 A=CALL4  RJ     CRL         PROCESS CALL STATEMENT RETURNS LIST
          RJ     FAL         FLUSH
 A=CALL5  EQ     POPX 
 A=FUN    SPACE  4,8
**        A=FUN - PROCESS CLOSING OF EXTERNAL FUNCTION LIST.
*         (SCR+2) = ROUTINE TAG AS SET WHEN FUNCTION ENCOUNTERED. 
  
  
 A=FUN    SA4    SCR+2       RELOAD A=ARMIS, EXTERNAL TAG 
          RJ     VEL         VALIDATE ARGUMENT LIST 
          RJ     FAL         FLUSH ARGUMENT LOAD TURPLES
          MX0    -L.MODE
          SA4    SCR+2       RELOAD EXTERNAL TAG
          SA2    TS.SYM 
          AX4    P.2TAG 
          SB2    X4-C.SYM    ORDINAL INTO TS.SYM
          SA2    X2+B2       TAG FROM SYMBOL TABLE
          SA3    CALLOP 
          BX7    -X0*X2      RESULTANT MODE 
          BX6    X3 
          BX4    0           DUMMY OR.1OP FOR ARGUMENT TURPLE 
          SA6    SOPR 
          SA7    SMOD 
          RJ     ESC         EXPAND POSSIBLE SHORT CONSTANT 
          RJ     SDB         SET DEFINED BIT IF VARIABLE
          RJ     ADT         ADD TURPLE FOR LAST ARGUMENT 
          SA1    SCR+2
          RJ     CT2         CONVERT TAG TO PASS *2* FORM 
          LX4    X6 
          SA3    EXTFUN 
          SA2    TT=PAR 
          LX7    X2 
          =X5    0           OPERAND TWO = 0
          =B6    B6+1        DUMMY
          SA7    CURST       RESET RELATIVE SQUEEZE START 
          EQ     POP.ST1     CONTINUE 
 SDB      SPACE  4,8
**        SDB -  SET DEFINED BIT
*                FOR VARIABLES IN CALL AND EXTERNAL FUNCTION ARGUMENT 
*                LISTS. 
* 
*         ENTRY  (X5) = PARSE FILE OPERAND
* 
*         EXIT   SYMBOL TABLE ENTRY UPDATED IF VARIABLE 
* 
*         USES   A1 X0,X1 B3
  
  
 SDB      SUBR   0
          BX0    X5 
          IFBIT  X0,INTR,SDBX     IF INTERMEDIATE 
          LX1    X5 
          MX0    L.TGB
          BX0    X0*X1
          AX0    P.TAG
          SX0    X0-C.VAR 
          NZ     X0,SDBX     IF NOT SYMBOL TABLE ENTRY
          AX1    P.TAG
          SB3    X1-C.VAR    SYMBOL TABLE ORDINAL 
          SA1    TS.SYM 
          SA1    B3+X1
          LX0    X1 
          IFBIT  X0,-VAR,SDBX     IF NOT VARIABLE 
          SX0    M.DEF
          BX6    X0+X1       SET DEFINED BIT ON 
          SA6    A1 
          EQ     SDBX        EXIT.. 
 A=IF     SPACE  4,8
**        A=IF - PROCESS TERMINAL PARENTHESIS OF *IF* EXPRESSION. 
*         SET CELLS 
*                IFRESULT = TEST OPERAND FOR JUMPS
*                IFMOD    = RESULTANT MODE OF IF EXPRESSION.
*         EXIT TO PAR.EOS 
  
  
 A=IF     SA1    B6-1              TOP OF OPERAND STACK 
          MX0    -L.MODE
          LX7    X1 
          BX6    -X0*X1 
          SA7    IFRESLT
          SA6    IFMOD
          EQ     PAREXIT     FOUND TERMINAL *)* OF IF (EXP) - EXIT..
 A=LIST   SPACE  4,8
**        A=LIST - PROCESS CLOSING OF AN I/O LIST.
  
  
 A=LIST   EQ     POPX        EXIT.. 
 A=DO     SPACE  4,8
**        A=DO - PROCESS CLOSING OF *DO*
  
  
 A=DO     BSS    0
          SB2    B2-2 
          PL     B2,PAREXIT  IF SUFFICIENT DO INDEX PARAMETERS
          FATAL  E.DO        ILLEGAL DO FORMAT
          EQ     PAREXIT
 POP.EXP  EJECT 
**        POP.EXP -  PROCESS ** TURPLE FOR REDUCTION AND TYPE 
* 
*         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) = OPERATOR = ** 
*                (X4) = 1ST OPERAND 
*                (X5) = 2ND OPERAND 
  
 EXP.IL   EQU    11          UPPER LIMIT (+1) FOR COMPUTING IN-LINE (**)
  
  
 POP.EXP  BX0    X4 
          SA2    TT=PAR            CURRENT START OF ** OPERATION
          IFBIT  X0,-INTR,POP.EX10 IF NOT INTERMEDIATE
  
**        SCAN BACKWARDS TO FIND START OF LEFT MEMBER FOR ** OPERATOR 
  
          BX2    X4 
          SB7    P.JPAD 
          SA1    TT.PAR 
          AX2    P.JPAD 
          =B2    X1+1 
 POP.EX2  SA3    X2+B2
          BX0    X3 
          =A1    A3+1 
          IFBIT  X3,INTR,POP.EX4   IF INTERMEDIATE CONTINUE 
          BX0    X1 
          IFBIT  X1,-INTR,POP.EX10 IF NOT INTERMEDIATE - START FOUND
 POP.EX4  AX2    B7,X0
          EQ     POP.EX2           CONTINUE SCAN
  
 POP.EX10 MX0    -L.MODE
          BX1    -X0*X4 
          SA1    X1+MODTBL   RELATIVE TO BASE 
          BX6    -X0*X5 
          SB7    X6+6 
          LX1    B7,X1       SHIFT RELATIVE TO POWER
          PL     X1,POP.EX12 IF NO ANSI ERROR 
          SX1    3R **
          LX1    7*CHAR 
          MX0    3*CHAR 
          BX6    X0*X1
          SA6    FILL.
          ANSI   E.ANS3      THE TYPE COMBINATIONS ARE NON-ANSI 
 POP.EX12 BX6    X2          (X2) = START OF LEFT MEMBER RELATIVE TO
*                            PARSED FILE. 
          BX1    X4          POWER (RIGHT MEMBER) 
          SA6    SCR         SAVE LEFT MEMBER ADDRESS 
  
**        SET-UP CHECK CELLS FOR DETERMINING IF TERM CAN BE EITHER
*         REDUCED AT COMPILE TIME OR USE ONE OF THE TRANSFORMATIONS.
  
          RJ     LCT         CHECK IF BASE IS CONSTANT
          BX1    X5 
          SA6    TER1        SAVE BASE
          RJ     LCT         CHECK IF POWER IS CONSTANT 
  
*         FORM JUMP ADDRESS 
  
          MX0    -L.MODE
          SA6    TER2        SAVE POWER 
          BX2    -X0*X4      MODE OF BASE 
          =X7    B2          SAVE POWER FLAG, CONSTANT/NOT CONSTANT 
          BX3    -X0*X5      MODE OF POWER (-LONG BITS) 
          SA1    X2+EXP.TBL 
          SB7    X3          SAVE POWER MODE
          LX3    3           POWER * 8
          SB2    X3          SHIFT COUNT
          MX0    -8 
          AX1    B2,X1
          BX0    -X0*X1 
          SB2    X0          JUMP ADDRESS 
          LX0    59-7 
          PL     X0,POP.EX20 IF POSSIBLE TO REDUCE (**) 
  
**        HERE IF TERM MUST BE PROCESSED EXTERNALLY 
  
          SB3    B2+EXP.EXT-1S7 
          EQ     POP.EX60    TRANSLATE EXTERNAL 
  
**        HERE IF TERM CAN POSSIBLY BE REDUCED. 
*         (B2) = CHECK PROCESSOR ADDRESS. 
*         (B7) = MODE OF POWER. 
*         (X2) = POWER,( BINARY ) 
*         (X7) = 0, POWER NOT CONSTANT. 
  
 POP.EX20 SA1    TER1        BASE 
          SB3    B2-TO.II+EXP.BASE
          BX2    X6          POWER
          MI     B3,POP.EX30 IF UNDEFINED OPERATION 
          ZR     X7,POP.EX27 IF POWER NOT CONSTANT
  
**        CHECK IF POWER IS *0* OR *1*
  
          NZ     X2,POP.EX25 IF POWER NOT *0* 
          SX0    B7 
          =X1    M.SHORT
          SB7    B7-M.REAL
          =X2    1.0/1S42 
          IX6    X1+X0
          ZR     B7,POP.EX22 IF BASE = REAL 
          =X2    1
 POP.EX22 LX2    P.SHC
          BX7    X2+X6
          =A7    B6-2 
          =B6    B6-1 
          EQ     POPX        EXIT.. (REDUCTION TO SIMPLE CONSTANT)
  
**        CHECK IF POWER IS *1*, IF SO, REMOVE CONSTANT *1* FROM ESTACK 
*         AND EXIT, POPPING NOTHING.
  
 POP.EX25 SX0    X2-1 
          NZ     X0,POP.EX27 IF POWER NOT *1* 
          =B6    B6-1 
          LX6    X4 
          =A6    B6-1        RESTORE BASE (IN CASE CHANGED) 
          EQ     POPX        EXIT.. (REDUCTION TO LOAD OF BASE) 
  
**        CHECK IF COMBINATION CAN BE FORMED IN-LINE OR CAN BE
*         REDUCED TO A SIMPLE TERM. 
  
 POP.EX27 IX0    X1+X2
          ZR     X0,POP.EX50 IF NO CONSTANTS
          BX3    X1          BASE 
          ZR     X2,POP.EX50 IF POWER NOT CONSTANT
          BX6    0
 POP.EX30 JP     B2+EXP.BASE
  
  
**        UNTRANSLATABLE EXPRESSION, ILLEGAL USE OF LOGICAL.
  
 EXP.BASE BSS    0           BASE FOR DISCISION JUMP
 TO.LL    BSS    0           LOGICAL TO LOGICAL 
 TO.LI    BSS    0           LOGICAL TO INTEGER 
 TO.LR    BSS    0           LOCICAL TO REAL
 TO.LD    BSS    0           LOGICAL TO DOUBLE
 TO.LC    BSS    0           LOGICAL TO COMPLEX 
 TO.IL    BSS    0           INTEGER TO LOGICAL 
 TO.RL    BSS    0           REAL    TO LOGICAL 
 TO.DL    BSS    0           DOUBLE  TO LOGICAL 
 TO.CL    BSS    0
          FATAL  E.XP1       ERROR (**) NON-LOGICAL OPERATOR
          =B6    B6-1 
          EQ     POPX        EXIT.. 
  
**        UNTRANSLATABLE EXPRESSION, UNDEFINED USAGE OF COMPLEX.
  
 TO.CR    BSS    0           COMPLEX TO REAL
 TO.CD    BSS    0           COMPLEX TO DOUBLE
 TO.CC    FATAL  E.XP2       ERROR - COMPLEX BASE ONLY TO INTEGER 
          =B6    B6-1 
          EQ     POPX        EXIT.. 
  
**        REDUCABLE FORMS 
*         A.  INTEGER TO INTEGER. 
  
          CON    S.ITOI 
 TO.II    PX1 
          SB3    S.ITOI 
          NX1                REAL BASE
          =X7    M.INT       INDICATE INTEGER.
          BX3    X1 
          PL     X2,TO.RR5   IF POWER IS POSITIVE - CONTINUE
          NOTE   E.XP4       INTEGER TO NEGATIVE CONSTANTS RESULTS = 0
          EQ     POP.EX60 
  
**        B.  INTEGER TO REAL.
  
          CON    S.ITOR 
 TO.IR    UX0,B2 X2 
          SB3    S.ITOR      EXTERNAL PROCESSOR 
          LX0    B2,X0
          BX3    X1 
          PX1    X0 
          NX1 
          IX6    X1-X2       SAFETY 
          NZ     X6,POP.EX60 IF POWER NOT INTEGRAL VALUE
          BX6    X0 
          SA6    TO.IRA 
          =X1    M.REAL 
          =X2    M.INT
          =X6    2
          LX6    18 
          BX6    X1+X6
          SA6    SMOD        SET SMOD FOR OMC 
          LX1    3           8*MODE = SHIFT COUNT 
          SB2    X1 
          SA1    X2+MODTBL   MODE CONVERSION TABLE ENTRY
          MX0    -8 
          AX6    B2,X1
          BX6    -X0*X6      ONLY 8 BITS FOR EACH MODE
          =A6    A6-SMOD+SMOD1  SET SMOD1 FOR OMC 
          RJ     OMC
          SA2    TO.IRA 
          BX6    X2 
          LX5    X3          SAVE (X3)
          RJ     NCS
          BX3    X5          RESTORE (X3) 
          LX5    X6          RESET POWER OPERAND
          SB3    S.RTOI 
          PX1    X3 
          NX3    X1 
          =X7    M.REAL 
          SA2    TO.IRA 
          BX1    X3          BASE TO REAL 
          EQ     TO.RR5 
  
 TO.IRA   BSS    1           SAVE INTEGER VALUE OF POWER
  
**        C.  REAL TO INTEGER.
  
          CON    S.RTOI 
 TO.RI    =X7    M.REAL 
          SB3    S.RTOI 
          EQ     TO.RR5 
  
**        D.  REAL TO REAL
  
          CON    S.RTOR 
 TO.RR    =X7    M.REAL 
          UX0,B7 X2 
          BX6    X2 
          SB3    S.RTOR 
          LX2    B7,X0
          BX3    X1 
          PX0    X2 
          NX0    X0 
          IX0    X6-X0       SAFETY 
          NZ     X0,POP.EX60 IF POWER IS NOT INTEGRAL VALUE 
          SB7    X2-EXP.IL
          MI     B7,TO.RR5   IF CAN BE PROCESSED IN-LINE
          SB3    S.RTOI 
          BX6    X2 
          =X7    M.INT
          RJ     NCS         ENTER NEW CONSTANT 
          BX5    X6 
          EQ     POP.EX60 
  
**        EVALUATE EXPRESSION AT COMPILE TIME.
*         (X1) = (X3) = BASE IN FLOATING POINT BINARY 
*         (X2) = POWER IN INTEGER 
*         (B3) = EXTERNAL PROCESSOR ADDRESS 
*         (X7) = RESULTANT MODE.
  
 TO.RR5   SB2    X2          POWER
          SX0    EXP.IL 
          IX0    X2-X0
          PL     X0,POP.EX60  IF .GT. LIMIT TO PROCESS IN-LINE
          MI     X2,POP.EX60 IF POWER IS NEG., CANT BE REDUCED. 
          NZ     X1,TO.RED   IF BASE CONSTANT-COMPILE TIME REDUCE 
          EQ1    B2,POP.EX25 IF POWER = 1 
  
**        SET UP IN-LINE MACRO FOR EVALUATING ** EXPRESSION.
*         MULTIPLIES USING MACROS -  R..P OR I..P 
*         (B2) = POWER (INTEGER .GT. 1 .LT. 12) 
*         (X7) = RESULTANT MODE (CAN ONLY BE INTEGER OR REAL) 
  
          SX2    X7-M.INT    =0 IF INTEGER, =1 IF REAL
          SA1    B2+EXP.INL-2 
          LX2    4           *16
          MX0    -16
          SB2    X2 
          AX2    B2,X1
          BX1    -X0*X2      ADDRESS OF PROCESSING SKELETON.
          SA2    IN.EXP 
          LX1    P.JPAD 
          IX6    X1+X2       SET OPERATOR WORD
          SA6    SOPR        RESET OPERATOR 
          BX3    X6 
          EQ     POP.STD     CONTINUE 
  
 EXP.INL  BSS    0
          VFD    28/0,16/R..2,16/I..2 
          VFD    28/0,16/R..3,16/I..3 
          VFD    28/0,16/R..4,16/I..4 
          VFD    28/0,16/R..5,16/I..5 
          VFD    28/0,16/R..6,16/I..6 
          VFD    28/0,16/R..7,16/I..7 
          VFD    28/0,16/R..8,16/I..8 
          VFD    28/0,16/R..9,16/I..9 
          VFD    28/0,16/R..10,16/I..10 
 TO.RED   SPACE  4,8
**        PERFORM EXPRESSION REDUCTION AT COMPILE TIME. 
*         (B2) = POWER (INTEGER ) 
*         (X1) = BASE  (REAL) 
*         (X3) = (X1) 
*         (X6) = 0     (SUMMATION REGISTER) 
*         (X7) = RESULTANT MODE 
  
 TO.RED   IX0    X1+X2
          NZ     X0,TO.RED2  IF NOT 0 ** 0 CASE 
          NOTE   E.XP3       0**0 IS INDEFINITE 
 TO.RED2  EQ1    B2,TO.RED4  IF POWER IS 1
          GT     B2,B1,TO.RED3     IF POWER IS .GT. 1 
          =X0    1.0/1S42 
          LX0    42 
          NZ     B2,TO.RED2A       IF POWER IS NEGATIVE 
          BX1    X0          SET RESULT TO 1.0
          EQ     TO.RED4
  
 TO.RED2A FX1    X0/X1       1/BASE 
          BX3    X1 
          =B2    -B2         -(POWER) 
 TO.RED3  OR     X1,POP.EX52 IF CONSTANT OUT OF RANGE 
          ID     X1,POP.EX52 IF CONSTANT INDEFINITE 
          FX1    X1*X3       NEW BASE = BASE * POWER
          =B2    B2-1 
          NE1    B2,TO.RED3  IF NOT FINISHED
 TO.RED4  SB7    X7-M.INT 
          =B6    B6-1        UPDATE ESTACK
          BX6    X1          RESULTS
          NZ     B7,TO.RED5  IF NOT INTEGER 
          UX0,B3 X1 
          LX6    B3,X0
 TO.RED5  RJ     NCS         ENTER CONSTANT 
          =A6    B6-1 
          EQ     POPX        EXIT.. 
  
**        TERM NOT REDUCABLE, TRANSLATE EXTERNAL ROUTINE NAME, AND
*         PROCESS LIKE FUNCTION CALL. 
* 
*         (B3) _ EXTERNAL ROUTINE TO CALL.
*         (X4) = TAG FOR BASE 
*         (X5) = TAG FOR POWER
  
 POP.EX52 WARN   =XE.XP5
          EQ     POP.EX60 
 POP.EX50 SA1    B2+EXP.BASE-1
          SB3    X1          ADDRESS FOR EXTERNAL 
  
 POP.EX60 SX6    B4 
          SA6    SCR         SAVE *B4*
          MX2    L.FDPC 
          SA1    B3 
          MX0    -L.MODE
          BX6    X2*X1       EXTERNAL SYMBOL ONLY 
          BX7    -X0*X1      RESULTANT MODE 
          SA2    CO.TBK 
          SA7    SMOD 
          MX3    -L.FJPAD 
          =X0    1R$
          AX1    P.FJPAD
          MI     X2,POP.EX70 IF NOT IN CALL BY VALUE
          =X0    1R.
 POP.EX70 BX7    -X3*X1 
          SB2    X7          SHIFT COUNT FOR SUFFIX 
          LX3    B2,X0
          =B4    A6+1 
          BX6    X6+X3       ADD IN SPECIAL CHARACTER 
          =A6    A6+1 
          TAGSEX B4          TAG IT 
          LX1    X4 
          BX2    X5 
          AX1    P.LONG 
          =X0    1
          AX2    P.LONG 
          BX1    X0*X1
          MX7    -16
          BX2    X0*X2
          SA1    X1+EXP.ARG 
          LX2    4
          SB7    X2 
          SA6    ROUTNAM
          AX2    X1,B7
          BX6    -X7*X2 
          SA1    SCR
          LX6    P.JPAD 
          SA2    CO.TBK 
          SB4    X1 
          PL     X2,POP.EX80 IF CALL-BY-VALUE 
          BX6    X5 
          SA6    SCR         SAVE SECOND ARGUMENT 
          BX5    X4          SET SECOND ARG. TO BASE
          RJ     ESC         EXPAND SHORT CONSTANT (IF ANY) 
          SA3    CALLOP 
          =X4    0           DUMMY FIRST ARGUMENT 
          LX7    X3 
          SA7    SOPR 
          RJ     ADT         EMIT ARG. LOAD TURPLE FOR BASE 
          SA5    SCR         POWER
          RJ     ESC         EXPAND SHORT CONSTANT (IF ANY) 
          SA3    SOPR        RESET X3 
          =X4    0           DUMMY FIRST ARG. 
          =B6    B6+1        ADVANCE ESTACK POINTER (TWO TURPLES OUTPUT)
          RJ     ADT         EMIT ARG. LOAD TURPLE FOR POWER
          EQ     POP.EX85 
  
 POP.EX80 SA3    REGARG2
          BX3    X3+X6
          LX7    X3 
          SA7    SOPR 
          RJ     ADT         EMIT ARGUMENT LOAD TURPLE
 POP.EX85 SA2    CO.TBK 
          SA3    EXTFUN 
          MI     X2,POP.EX90 IF TRACEBACK ON
          SA3    BEFFUN 
 POP.EX90 SA2    TT=PAR 
          SA4    ROUTNAM
          =X7    X2+L.TURP
          SA7    CURST       RESET RELATIVE SQEEZE START
  
**        NEXT INSTRUCTION IS SETTING A DUMMY OPERAND THAT IS NEVER 
*         USED IN THE ACTUAL SKELETON EXPANSION BUT IS NECESSARY
*         TO STOP SQUEEZE FROM SQUEEZING OUT UNLIKE ** OPERATORS. 
  
          =X5    0           OPERAND TWO = 0
          SB6    B6+B1       ADVANCE ESTACK POINTER 
          EQ     POP.ST1     MODE ALREADY DEFINED - POP.ST1 
 EXPDIS   SPACE  4,8
**        EXPONENTIAL ROUTINES
  
 EXPEX    MACRO  NAME,ARGTYP,FUNTYP 
 Y        MICRO  1,, NAME 
 Z        MICCNT Y
 C        SET    54-Z*CHAR
 F.NAME   VFD    L.FDPC/0L_NAME,1/0,L.FBEF/0,1/0,L.FJPAD/C,L.FARGM/M.ARG
,TYP,L.FARGC/2,L.MODE/M.FUNTYP
 EXPEX    ENDM
  
  
 EXP.EXT  BSS    0           BASE CELL FOR EXPONTENTIAL ROUTINES
 S.ITOI   EXPEX  ITOJ,INT,INT 
 S.ITOR   EXPEX  ITOX,INT,REAL
 S.ITOD   EXPEX  ITOD,INT,DBL 
 S.ITOC   EXPEX  ITOZ,INT,CPLX
 S.RTOI   EXPEX  XTOI,REAL,REAL 
 S.RTOR   EXPEX  XTOY,REAL,REAL 
 S.RTOD   EXPEX  XTOD,REAL,DBL
 S.RTOC   EXPEX  XTOZ,REAL,CPLX 
 S.DTOI   EXPEX  DTOI,DBL,DBL 
 S.DTOR   EXPEX  DTOX,DBL,DBL 
 S.DTOD   EXPEX  DTOD,DBL,DBL 
 S.DTOC   EXPEX  DTOZ,DBL,CPLX
 S.CTOI   EXPEX  ZTOI,CPLX,CPLX 
  
          POPMAC EXPEX
 TSF      EJECT 
**        DESCISION TABLE FOR EXPONENTIALS. 
  
  
          MACRO  DICIDE,DUM,MU,ML,MI,MR,MD,MC 
 C        MICRO  1,,$12/0$
.1        ECHO   ,FORMS=(MC,MD,MR,MI,ML,MU) 
 A        MICRO  2,2,/FORMS/
 .2       IFC    EQ,/"A"/TO/
 C        MICRO  1,,$"C",8/S.FORMS-EXP.EXT+1S7$ 
 .2       ELSE
 C        MICRO  1,,$"C",8/TO.FORMS-EXP.BASE$ 
 .2       ENDIF 
.1        ENDD
          VFD    "C"
 DICIDE   ENDM
  
  
 EXP.TBL  BSS    0
 M=UNIV   DICIDE II,IL,II,IR,ITOD,ITOC
 M=LOG    DICIDE LI,LL,LI,LR,LD,LC
 M=INT    DICIDE II,IL,II,IR,ITOD,ITOC
 M=REAL   DICIDE RI,RL,RI,RR,RTOD,RTOC
 M=DBL    DICIDE DTOI,DL,DTOI,DTOR,DTOD,DTOC
 M=CPLX   DICIDE CTOI,CL,CTOI,CR,CD,CC
          POPMAC DICIDE 
  
**        TABLE FOR ARGUMENT LOAD SKELETONS.
 BEF.ARG  VFD    28/0,16/=XO=RAGD1,16/=XO=RAGS1 
  
 EXP.ARG  BSS    0
          VFD    28/0,16/O=RAGSD,16/O=RAGSS 
          VFD    28/0,16/O=RAGDD,16/O=RAGDS 
 POP.DIV  EJECT  4,8
**        POP.DIV - PROCESS DIVIDE POPPING DIVIDE.
* 
*         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 CHANGE 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
*                A.  CHECK IF BOTH OPERANDS ARE INTEGER, IF SO LET
*                    DIVIDE BE POPPED. IF NOT GO TO (B) 
*                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  SA1    POPDPC 
          IX0    X1-X3
          BX2    X3 
          SB2    X0 
          NZ     B2,POP.DV10 IF NOT DIVIDE POPPING DIVIDE 
          IFBIT  X2,-COM,POP.DV5   IF NOT POPPING SPECIAL DIVIDE
          SA1    SDIV 
          =X2    O.DIV-O.MULT 
          IX6    X3-X2
          BX7    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 IF DIVIDE 1ST IN SEQUENCE
  
 POP.DV5  MX0    -L.MODE
          BX1    -X0*X4 
          BX2    -X0*X5 
          LX1    L.MODE 
          IX0    X1+X2
          SA2    SDIV        CHANGE TO SPECIAL DIVIDE 
          SB7    X0-M.INT-M.INT*1S"A" 
          ZR     B7,POP.STD  IF INTEGER DIVIDE, POP AS DIVIDE 
          =B4    B4+1        NEXT 
          =X1    O.DIV
          =B5    B5+1        RE ACTIVATE 1ST DIVIDE 
          EQ     PAR.ADOP    IGNORE- SET INTO OPERATOR STACK
  
 POP.DV10 IFBIT  X2,-COM,POP.STD   IF NOT POPPING SPECIAL DIVIDE
          =X2    O.DIV-O.MULT 
          IX6    X3-X2
          SA6    SOPR        SET CONFIRMED MULTIPLY 
          BX3    X6 
          EQ     POP.STD     POP AS TRUE MULTIPLY 
 POP.PL   SPACE  4,8
**        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   SA1    LASTOP 
          SB7    X1-O.UMIN
          SA2    LASTAD 
          NZ     B7,POP.PL10 IF LAST OP NOT *UNARY-*
          BX1    X5 
          RJ     COR         CHECK IF OPERAND IS INPUT TO OPERATOR
          NZ     X0,POP.PL10 IF *UNARY* NOT INPUT INTO *PLUS* 
          SA3    REVMIN 
          =A5    X1-OR.OPR+OR.2OP 
          BX6    X3 
          SA7    A2          RESET LENGTH OF TT=PAR 
          SA6    SOPR 
          EQ     POP.STD
  
**        CHECK FOR COMMUTATIVE OPERATOR BEING POPPED BY SAME.
*         IF TRUE AND 1ST OPERAND IS A CONSTANT REVERSE ORDER AND DELAY 
*         PROCESSING. 
*         (JOINED HERE BY MULTIPLY POP PROCESSOR) 
  
  
 POP.MUL  BSS    0
 POP.PL10 SA1    POPDPC 
          IX0    X1-X3
          SB2    X0 
          NZ     B2,POP.STD  IF NOT BEING POPPED BY LIKE OPERATOR 
          SA1    SDIV 
          MX2    -L.STPR
          BX1    X1-X3
          LX1    -P.STPR
          BX2    -X2*X1 
          ZR     X2,POP.STD  IF * POPPING SPECIAL DIVIDE
  
**        JOINED HERE IF POPPING A SPECIAL DIVIDE 
  
 POP.SDIV SA1    B6-2 
          =A2    B6-1 
          =X0    M.SHORT
          LX6    X2 
          BX7    X1 
  
**        CHECK IF OPERANDS ARE CONSTANTS 
  
          BX3    X0*X1       BRING DOWN SHORT BIT 
          AX1    P.TGB
          BX0    X3-X0       WIPE OUT SHORT 
          SX3    X1-C.CON/1S13
          =B2    1           INDICATE 1 CONSTANT
          BX1    X3*X0       SHORT OR CONSTANT
          =X0    M.SHORT
          ZR     X1,POP.PL15 IF 1ST = CONSTANT
          BX3    X6 
          LX6    X7          ROTATE OPERANDS
          =B2    0           INDICATE NO CONSTANT SO FAR
          BX7    X3 
  
 POP.PL15 BX3    X0*X2
          AX2    P.TGB
          BX1    X3-X0
          SX0    X2-C.CON/1S13
          =B2    B2+1 
          BX2    X1*X0
          SA3    SOPR        RELOAD POPPED OPERATOR 
          ZR     X2,POP.PL20 IF 2ND = CONSTANT
          =B2    B2-1 
  
**        (B2) = 0 = NO CONSTANTS 
*                1 = 1 OPERAND IS CONSTANT
*                  > 1 BOTH ARE CONSTANT
  
 POP.PL20 NE1    B2,POP.STD  IF BOTH OR NONE ARE CONSTANTS
          MX3    -L.MODE
          BX0    -X3*X4      MODE 
          BX3    -X3*X5      MODE 
          BX0    X0*X3       0 IF AT LEAST 1 UNIVERSAL
          =B2    X0 
          SA3    SOPR        RELOAD POPPED OPERATOR 
          EQ     B2,POP.STD  IF AT LEAST 1 UNIVERSAL OPERAND
          SA6    A1          REVERSE ORDER, MAKING CONSTANT SECOND
          SA7    A2 
          =B5    B5+1        PUT OPERATOR BACK INTO TABLE 
          SA2    POPPER 
          =A1    A2-POPPER+POPDPC 
          =B4    B4+1        NEXT 
          EQ     PAR.ADOP    RESET OPERATOR STACK 
 POP.UM   SPACE  4,8
**        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
* 
*         ENTRY  (X5) = OPERAND 
  
  
 POP.UM   BX1    X5 
          RJ     LCT
          ZR     B2,POP.UM10 IF OPERAND NOT CONSTANT
  
**        (X6) = 1ST CONSTANT IN BINARY 
*         (X7) = 2ND CONSTANT IN BINARY, (ONLY VALID IF LONG BIT SET.)
  
 POP.UM1  BX3    X5 
          IFBIT  X3,LONG,POP.UM5
          SA2    TT.PAR 
          BX6    -X6
          LX7    X0          MODE 
          RJ     NCS         ENTER CONSTANT 
          =A6    B6-1        REPLACE STACK ENTRY
          EQ     POPX        EXIT.. 
  
**        HERE IF DOUBLE WORD CONSTANT
*         (X1) = (X6) = UPPER PART
*         (X2) = (X7) = LOWER PART
  
 POP.UM5  BX6    -X1
          BX7    -X2
          SA6    SCR
          =A7    A6+1 
          SB2    A6          FWA
          SB3    B2+2        LWA+1
          SCAN   TS.CON,NCM  SCAN/ENTER NEW CONSTANTS 
          SX0    B7+C.CON 
          MX6    -L.MODE
          BX1    -X6*X5 
          LX0    P.TAG
          IX6    X1+X0
          =A6    B6-1        REPLACE STACK ENTRY
          EQ     POPX        EXIT.. 
  
 POP.UM10 SA1    LASTOP 
          SA2    LASTAD 
          SB7    X1-O.UMIN
          SB2    X1-O.MIN 
          NZ     B7,POP.UM15 IF NOT RESULTS OF ANOTHER UNARY- 
          BX1    X5 
          RJ     COR
          NZ     X0,POP.UM20 IF NOT INPUT INTO THIS OPERATOR
          =A3    X1-OR.OPR+OR.2OP 
          SA7    A2          RESET LENGTH OF TT=PAR 
          BX6    X3 
          =A6    B6-1        PUT OPERAND BACK IN ELEMENT STACK
          EQ     POPX        EXIT.. 
  
**        CHECK FOR -(A-B)
  
 POP.UM15 NZ     B2,POP.UM20 IF  LAST NOT *-* 
          BX1    X5 
          RJ     COR
          NZ     X0,POP.UM20 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.. 
  
**        HERE IF UNARY- TO BE OUTPUT 
  
 POP.UM20 =X4    0           OR.1OP  = DUMMY
          =B6    B6+1        DUMMY FOR UNARY- 
          EQ     POP.STD
 POP.LOG  SPACE  4,8
**        CHECK IF ONE OPERAND IS A LONG CONSTANT AND CAN BE CONVERTED
*         TO MASK FORM. 
  
 POP.LOG  RJ     SMM         SET MODE FOR SPECIAL OPERATOR
          SX6    X3-O.AND 
          BX1    X4 
          SA6    TRVA 
          RJ     LCT
          GE     B2,POP.ST1  IF NOT LONG CONSTANT 
          BX1    X6 
          =X2    M.INT
          =B3    1
          RJ     CMO
          ZR     X6,POP.ST1  IF NOT MASK CONSTANT 
          LX7    X5 
          BX5    X6 
          SA2    TRVA 
          LX4    X7 
          SA3    X2+ANDNOT
          MX0    -L.SBPR
          SX2    X2+O.ANDN
          BX3    X0*X3
          IX3    X2+X3       REFORM .OP..NOT. OPERATOR
          BX6    X3 
          SA6    SOPR 
          EQ     POP.ST1     CONTINUE ..
 POP.NT   SPACE  4,10 
**        CHECK IF .NOT. (.NOT. EXPRESSION) COMBINATION.
  
  
 POP.NOT  BX1    X5 
          RJ     LCT         CHECK IF OPERAND IS CONSTANT 
          NZ     B2,POP.UM1  IF CONSTANT OPERAND
          BX4    X5          DUMMY 1ST OPERAND = 2ND
          RJ     SMM         SET MODE FOR SPECIAL OPERATOR
          =B6    B6+1        RESET FOR UNARY
          SA1    LASTOP 
          =X4    0           DUMMY 1ST OPERAND
          SB7    X1-O.NOT 
          NZ     B7,POP.ST1  IF LAST PROCESSED NOT .NOT.
          BX1    X5 
          RJ     COR
          NZ     X0,POP.ST1  IF NOT INPUT INTO THIS OPERATOR
          =A3    X1-OR.OPR+OR.2OP 
          SA7    A2          RESET LENGTH OF TT=PAR 
          BX6    X3 
          SA6    B6-2        PUT OPERAND BACK IN ELEMENT STACK
          =B6    B6-1 
          EQ     POPX        EXIT 
 POP.REL  EJECT  4,8
**        RELATIONALS BEING POPPED. 
  
  
 POP.REL  SB7    X3 
          SA1    ="LEGT"
          SB2    B3-O.RP
          LX6    B7,X1
          BX0    X5 
          PL     X6,POP.RL10 IF NOT .LE. OR .GT.
  
**        CHANGE RELATIONALS .LE. TO .GE. OR .GT. TO .LT. 
  
          BX5    X4 
          SB7    X6 
          LX4    X0 
          =X6    O.GE-O.LE
          ZR     B7,POP.RL3  IF PROCESSING .LE. 
          =X6    O.LT-O.GT
 POP.RL3  IX3    X3+X6       CHANGE TO NEW OPERATOR 
          BX6    X3 
          SA6    SOPR 
  
 POP.RL10 BX0    X4-X5
          MX2    -L.MODE
          BX1    -X2*X0 
          BX2    -X2*X4 
          NZ     X1,POP.RL15 IF MIXED MODE. 
          SB7    X2-M.LOG 
          NZ     B7,POP.RL15 IF DOMINANT MODE NOT LOGICAL.
          FATAL  E.AT1A      NON-LOGICAL OPERATOR ON LOGICAL OPERANDS 
          EQ     POPX        EXIT.. 
  
 POP.RL15 RJ     SDM         SET DOMINANT MODE AND OPERATOR 
          SA2    SMOD 
          MX0    -18
          =X7    M.LOG
          BX1    X0*X2       SAVE CONVERSION BITS 
          IX6    X7+X1
          SA6    A2          RESET SMOD INDICATING RESULTS = LOGICAL
          EQ     POP.ST1     CONTINUE 
 POP.REQ  SPACE  4,8
**        EQUAL - VALIDATE NOTHING ILLEGAL
* 
*                A. CHECKS LEFT SIDE FOR LEGALITY.
*                B. VALIDATES NOT RESETTING A *DO* PARAMETER. 
*                C. CHECKS MODE CONVERSION ON CONSTANTS.
  
 POP.REQ  RJ     SDM
          SA2    SMOD 
          AX2    18 
          SB7    E.LP3
          ZR     X2,POP.RQ5  IF NO MIXED MODE.
          RJ     LCT
          ZR     B2,POP.RQ5  IF RIGHT MEMBER NOT CONSTANT.
  
**        CHANGE CONSTANT TO DOMINANT MODE
  
          SA2    SMOD 
          SB3    0
          BX1    X6          CONSTANT TO CHECK (LCT RETURNED) 
          SX2    X2          INDICATE 1ST = CONSTANT
          RJ     CMC         CHECK IF CONSTANT CAN ACTUAL BE CONVERTED
  
**        CHECK IF REDEFINING *DO* INDEX
  
 POP.RQ5  SA2    TP=DO
          SA1    TP.DO
          ZR     X2,POP.RQ10 IF NOT IN *DO* 
          IX0    X1+X2
          SB2    X1 
          BX6    X5 
          SA2    X0-1        PRELOAD 1ST ENTRY
          =A6    B2-1        DUMMY FIND 
  
**        SCAN *DO* TABLE 
  
 POP.RQ6  BX0    X2-X5
          =A2    A2-1 
          NZ     X0,POP.RQ6  IF NO MATCH
          SB7    A2-B2
          MI     B7,POP.RQ10 IF DUMMY FIND
  
*         CHECK IF IT IS THE CONTROL INDEX THAT IS REDEFINED
  
          SA2    TP=DO
          IX0    X1+X2
          SB7    X0          (B7) = LWA+1 OF TABLE
          SB2    X1+OR.DOCI 
          SA1    B2          PREFETCH FIRST CONTROL INDEX 
          EQ     POP.RQ8
  
 POP.RQ7  BX0    X1-X5
          SB2    B2+L.DOE 
          AX0    P.TAG
          ZR     X0,POP.RQ9  IF CONTROL INDEX REDEFINED -- *FATAL*
          SA1    B2          FETCH NEXT CONTROL INDEX 
 POP.RQ8  LT     B2,B7,POP.RQ7     IF NOT END OF TABLE, LOOP
          EQ     POP.RQ9A 
  
 POP.RQ9  FATAL  E.DO8
          EQ     POP.RQ11 
  
 POP.RQ9A BSS    0
          NOTE   E.DO23      REDEFINING *DO* PARAMETER
          SA2    DOIX 
          BX6    -X2
          SA6    A2          INDICATE AN INDEX IS CHANGED IN ACTIVE LOOP
          EQ     POP.RQ11    BY-PASS NULL EXPRESSION CHECK
  
**        VALIDATE LEFT MEMBER LEGAL
  
 POP.RQ10 BX0    X4-X5
          =B6    B6-1        ELIMINATE ONE OPERAND
          ZR     X0,POPX     IF LEFT MEMBER = RIGHT MEMBER
          =B6    B6+1        PUT OPERAND BACK 
 POP.RQ11 LX0    X5 
          BX1    X5 
          IFBIT  X0,-INTR,POP.RQ12     IF NOT INTERMEDIATE
          IFBIT  X0,ARY/INTR,POP.ST1  IF ARRAY INTERMEDIATE - OK. 
          FATAL  E.TE8                 LEFT SIDE IS ILLEGAL 
          EQ     POP.ST1
  
 POP.RQ12 AX1    P.2TAG 
          SA2    TS.SYM 
          SB2    X1-C.SYM 
          SX0    C.SYM
          BX6    X0-X1
          AX6    L.PWF
          NZ     X6,POP.RQ14 IF NOT SYMBOL
          SA2    X2+B2
          IFBIT  X2,-VAR,POP.RQ14  IF NOT SIMPLE VARIABLE 
          IFBIT  X2,-FPS/VAR,POP.ST1   IF NOT FP USED AS A SUBSCRIPT
          SA2    A2-B1       POINTS TO SYMBOL IN TS.SYM 
          MX6    L.SYM
          BX6    X2*X6       EXTRACT SYMBOL 
          SA6    FILL.
          ANSI   =XE.AT13    REDEFINITION OF FPS IS NON-ANSI
          EQ     POP.ST1     ADD TURPLE TO PARSED FILE
 POP.RQ14 FATAL  E.TE8
          EQ     POP.ST1
 POP.STD  EJECT 
 POP.STD  SPACE  4,8
**        STD -  SET DOMINANT MODE / ADD TURPLE TO PARSED FILE
*         ENTRY  (X3) = OPERATOR
*                (X4) = 1ST OPERAND 
*                (X5) = 2ND OPERAND 
* 
*         CALLS  SDM,POP.ST1
  
  
 POP.STD  BX6    X3 
          SA6    SOPR1       SAVE OPERATOR
          RJ     SDM         SET DOMINANT MODE / RESULTANT MODE 
          BX6    X3 
          SA6    SOPR        SET OPERATOR CELL
          SA6    SOPR2       SAVE OPERATOR
          RJ     PSO         PROCESS SUBSCRIPT OPERATION IF IN ARRAY
          ZR     X3,POPX     IF SUBSCRIPT OPERATION REDUCED 
          SA1    SOPR2
          IX1    X1-X3
          NZ     X1,POP.ST5  IF OPERATOR CHANGED
          SA3    SOPR1       RELOAD ORIGINAL OPERATOR 
          BX6    X3 
          SA6    SOPR 
          RJ     SDM         RESET DOMINANT MODE / RESULTANT MODE 
          BX6    X3 
          SA6    SOPR        RESET OPERATOR CELL
          EQ     POP.ST5
 POP.STD1 SPACE  4,8
**        ST1 -  ADD TURPLE TO PARSED FILE
* 
*         ENTRY  (X3) = OPERATOR
*                (X4) = 1ST OPERAND 
*                (X5) = 2ND OPERAND 
* 
*         CALLS  PSO,OMC,ADT
  
  
 POP.ST1  BX6    X3 
          SA6    SOPR        SET OPERATOR CELL
          RJ     PSO         PROCESS SUBSCRIPT OPERATION IF IN ARRAY
          ZR     X3,POPX     IF SUBSCRIPT OPERATION REDUCED 
 POP.ST5  RJ     OMC         OUTPUT MODE CONVERSION IF REQUIRED 
          RJ     ADT         ADD TURPLE 
          EQ     POPX        EXIT.. 
 ADT      EJECT  4,20 
**        ADT  ADD TURPLE TO PARSED FILE. 
* 
*         GENERAL FLOW
*         A. 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. 
* 
*         B. SQZ - CHECKS IF CURRENT TURPLE CAN BE SQUEEZED OUT BECAUSE 
*                  OF A PREVIOUS ALIKE TURPLE.
* 
*         C. ALC - ALLOCATES ROOM FOR CURRENT TURPLE. 
* 
* 
*         ENTRY  (X3) = OPERATOR
*                (SOPR) = (X3)
*                (SMOD) = RESULTANT MODE OF TURPLE. 
*                         (SEE DEFINITION IN *SDM*.)
*                (X4) = 1ST OPERAND 
*                (X5) = 2ND OPERAND 
* 
*         EXIT   TT.PAR UPDATED BY L.TURP, IF TURPLE NOT SQUEEZED OR
*                REDUCED. 
*                (B6) = UPDATED BY -1.
*                ESTACK (B6) = INTERMEDIATE GENERATED BY CURRENT TURPLE.
  
  
 ADT      SUBR   0
          BX0    X3 
  
**        CONSTANT COMBINATION CHECK. 
*         CHECK IF CURRENT TURPLE IS A SIMPLE CONSTANT RESULT OR
*         WILL RESULT IN A MACHINE UNDEFINED OPERAND. 
*         (X0) = OPERATOR.
*         RETURN FROM *CCR* 
*                X6 = 0 - TURPLE NOT REDUCED. 
*                X6 " 0 - RESULTS OF REDUCTION. 
  
 ADT2     BX7    X3 
          IFBIT  X0,NONSTD/COM,ADT10
          RJ     CCR         CHECK CONSTANT REDUCTION.
          BX7    X3 
          ZR     X6,ADT10    IF NOT REDUCED 
          SA6    B6-2        RESULT OF REDUCTION BACK TO OP-STACK 
          =B6    B6-1 
          EQ     ADTX        EXIT.. (TERM REDUCED)
  
**        SQUEEZE TURPLE -- IF POSSIBLE.
*         CHECK IF CURRENT TURPLE IS ALREADY IN PARSED FILE.
*         (X7) = OPERATOR.
*         RETURN FROM *SQZ* 
*                B2 > 0 - TURPLE SQUEEZE
  
 ADT10    SX6    B5 
          IFBIT  X7,NSQEZ,ADT36 
          SA6    TRVA        SAVE *B5*
          RJ     SQZ         CHECK IF CURRENT TURPLE CAN BE ELIMINATED
          SA1    TRVA 
          SB5    X1          RESTORE *B5* 
          PL     B2,ADTX     IF SQUEEZE PERFORMED.
  
**        SET UP INTERMEDIATE RESULT OPERAND TO *ESTACK*
*         AND PUT CURRENT TURPLE IN *SB* FOR LATER PROCESSING BY *CAI*. 
*         (X4) = 1ST OPERAND TO ADT.
*         (X5) = 2ND OPERAND TO ADT.
  
 ADT36    SB7    X3-O.= 
          BX6    X5 
          ZR     B7,ADT40    IF ADDING *=* TURPLE 
          SA3    SMOD 
          SA1    ATTR        ATTRITBUTE CELL
  
**        SET-UP INTERMEDIATE FOR *ESTACK*
*         (X3) = SMOD 
  
          SA2    TT=PAR 
          SX0    M.INTR 
          IX1    X1+X3       ADD ATTRITBUTE + RESULTANT MODE
          LX2    P.TAG
          SX7    X1 
          BX3    X0+X2       INTERMEDIATE TAG 
          IX6    X3+X7       ADD IN ATTRIBUTE+MODE
 ADT40    SA1    TT.PAR 
          SA6    B6-2        INTERMEDIATE OPERAND TO ELEMENT STACK. 
  
**        REFORM
*         SET RESULTANT MODE IN OPERATOR WORD THE SAME AS THE 
*         INTERMEDIATE JUST PUT INTO ELEMENT STACK FOR RESULTS OF THIS
*         TURPLE
*         ALLOCATE ROOM FOR CURRENT TURPLE
*         SET TURPLE INTO PARSED FILE.
  
          ALLOC  A1,L.TURP
          SA1    SMOD 
          BX7    X5 
          SA3    SOPR 
          SX1    X1 
          =A7    B7-1        2ND OPERAND TO FILE. 
          LX1    P.DMOD 
          BX6    X1+X3
          LX7    X4 
          =B6    B6-1        RESET OPERAND STACK
          =A7    A7-1        1ST OPERAND TO STACK.
          =A6    A7-1        OPERATOR TO STACK. 
          EQ     ADTX        EXIT.. 
 CIL      SPACE  4,8
**        CIL -  CHECK IF ILLEGAL USE OF LEVEL 3 NAME 
* 
*         ENTRY  (X3) = TAG SHIFTED TO PUT *ARY* BIT IN SIGN POSITION 
* 
*         EXIT   DIAGNOSTIC OUTPUT FOR ILLEGAL USAGE
* 
*         USES   A1  X2,X3  B3
  
  
 CIL      SUBR   0
          IFBIT  X3,-LEV/ARY,CILX  IF NOT LEVEL NAME, EXIT..
          LX3    P.LEV+1-P.LEVN    RIGHT-JUSTIFY LEVEL NUMBER 
          MX2    -L.LEVN
          BX2    -X2*X3      (X2) = LEVEL NUMBER
          SX2    X2-3 
          NZ     X2,CILX     IF NOT LEVEL 3, EXIT.. 
  
*         HERE IF LEVEL 3 TAG 
  
          SA3    ARGMODE
          SB3    X3-A=CALL
          ZR     B3,CILX     IF IN CALL PROCESSING, EXIT..
          SB3    X3-A=FUN 
          ZR     B3,CILX     IF IN EXTERNAL FUNCTION PROCESSING, EXIT.. 
          SB3    X3-A=BIF 
          NZ     B3,CIL2     IF NOT IN INTRINSIC PROCESSING 
  
*         HERE IF IN INTRINSIC PROCESSING.
*         PERMIT LEVEL 3 IN *LOCF* ONLY.
  
          SA1    B4-2        GET FUNCTION NAME
          MX3    L.SYM
          BX2    X3*X1       (X2) = SYMBOL ONLY 
          SA1    CILA 
          BX3    X2-X1
          ZR     X3,CILX     IF PROCESSING *LOCF* 
  
*         HERE IF ILLEGAL USE OF LEVEL 3
  
 CIL2     FATAL  =XE.LV11 
          EQ     CILX        EXIT.. 
  
 CILA     DATA   0LLOCF 
 COR      SPACE  4,8
**        COR -  CHECK IF OPERAND IS INPUT TO REDUCABLE OPERATOR. 
* 
*         ENTRY  (X1) = INPUT OPERAND (INTERMEDIATE)
* 
*         EXIT   (X0) = 0, OPERAND IS INPUT.
*                (X7) = (TT=PAR) - L.TURP 
*                (A1) = LASTAD
*                (A2) _ TT=PAR
* 
*         USES   A1,A2  X0
  
 COR      SUBR               ENTRY/EXIT...
          BX0    X1 
          IFBIT  X0,-INTR,EXIT.    IF NOT INTERMEDIATE
          SA2    TT=PAR 
          AX1    P.JPAD 
          SX7    X2-L.TURP
          IX0    X1-X7
          SA1    LASTAD 
          EQ     EXIT.
 CT2      SPACE  4,8
**        CT2 -  CONVERT TAG TO PASS *2* FORM 
* 
*         ENTRY  (X1) = SYMBOL TABLE TAG ENTRY
* 
*         EXIT   (X6) = PASS *2* FORM OF TAG
* 
*         USES   X0,X1,X2,X3,X6 
  
  
 CT2      SUBR               ENTRY/EXIT...
          =X0    M.EQUIV
          SA3    PAS2MF 
          BX0    X0*X1
          LX2    X1 
          BX6    X3*X1
          LX0    P.2EQUIV-P.EQUIV 
          BX6    X6+X0
          IFBIT  X2,-FP,EXIT.      IF NOT *FP*
  
          MX0    -L.FPNO
          SBIT   X2,FPNO/FP+1 
          BX2    -X0*X2      EXTRACT SYMBOL TABLE *FP* FIELD
          LX2    P.2FPNO
          BX6    X6+X2       ADD IN *FP* FIELD
          EQ     EXIT.
  
 PAS2MF   SYMASK (TAG,MODE) 
 FAL      SPACE  4,8
**        FAL - FLUSH ARGUMENT LOAD TURPLES ACCUMULATED IN TT.SCR.
* 
*         ENTRY  (ARGCOMA) = 6/0,18/TT=SCR,18/ACM,18/0
*                            TT=SCR = TT.SCR LENGTH AT *(*. 
*                (TT=SCR) = CURRENT LENGTH OF TT.SCR. 
* 
*         EXIT   (TT=SCR) = COLLAPSED TO SIZE AT *(*. 
*                *TURPLES* MOVED TO PARSED TABLE. 
* 
*         USES   A1,A2,A6 X3,X4 
* 
*         CALLS  ALC, MVE.
  
  
 FAL      SUBR               ENTRY/EXIT...
          SA1    SCR+1
          SA2    TT=SCR 
          AX1    36 
          IX4    X2-X1       WC 
          ZR     X4,EXIT.    IF NO TURPLES TO MOVE
          ALLOC  TT.PAR,X4
          SA1    SCR+1
          SA2    TT.SCR 
          AX1    36 
          SX3    B7 
          IX2    X1+X2       SOURCE ADDRESS 
          IX3    X3-X4       DESTINATION ADDRESS
          SHRINK TT=SCR,X1   COLLAPSE SCRATCH TABLE 
          MVE    X4,X2,X3    MOVE *TURPLES* TO PARSED TABLE 
          EQ     EXIT.
 SDM      EJECT 
**        SDM -  SET DOMINANT MODE
* 
*         ENTRY  (X3) = OPERATOR. 
*                (X4) = 1ST OPERAND 
*                (X5) = 2ND OPERAND 
* 
*         EXIT   *SDM* SETS UP THE FOLLOWING CELLS/FIELDS.
*                1. *DMOD* FIELD IN OPERATOR. 
*                2. *MODC* FIELD IN OPERATOR. 
*                3. *SMOD* CELL.
* 
*         *SMOD* = 24/0,18/POINT,18/MODE. 
*                POINT = 0 IF BOTH OPERANDS ARE OF THE SAME MODE. 
*                      = 1 IF 1ST  OPERAND IS DOMINANT MODE.
*                      = 2 IF 2ND  OPERAND IS DOMINANT MODE.
* 
*         *SMOD1* = MODTBL ENTRY (IF CONVERSION NECESSARY)
  
*         SUBFIELD *MODC* =0
* 
*         (X3) = (X6) = (SOPR)= UPDATED OPERATOR. 
* 
*         USES   A1,A2,A3  X0,X7  B2,B3,B7
  
  
 SDMXA    SA6    SOPR        RESET OPERATOR WITH SKELETON MODE OFFSET 
          NO
          BX3    X6 
  
 SDM      SUBR               ENTRY/EXIT...
          LX0    X3 
          IFBIT  X0,-MODLS,SDM3 
  
**        HERE IF OPERATOR IS MODELESS. 
  
          MX0    -L.MODE
          BX6    -X0*X4      MODE BITS FROM 1ST OPERAND 
          MX1    L.MODC+L.DMOD
          SA6    SMOD 
          LX1    P.MODC+L.MODC
          BX6    -X1*X3      ZERO TO DMOD AND MODC FIELDS.
          EQ     SDMXA       EXIT.. 
  
**        FIND DOMINANT MODE. 
  
 SDM3     SB3    B0 
          MX0    -L.MODE
          SB7    X3-O.SLP 
          BX1    -X0*X4      1ST OPERAND MODE BITS. 
          SB2    X3-O.= 
          NZ     B7,SDM5     IF NOT SPECIAL OPERATOR
          BX6    X1 
          MX0    L.MODC+L.DMOD
          SA6    SMOD 
          LX0    P.MODC+L.MODC
          BX6    -X0*X3 
          EQ     SDMXA       EXIT.. 
  
 SDM5     LX7    X1 
          BX2    -X0*X5      2ND OPERAND MODE BITS. 
          LX6    X2 
          IX3    X1-X2
          ZR     X3,SDM10    IF 1ST = 2ND 
          =B3    2
          MI     X3,SDM10    IF 2ND = DOMINANT MODE.
          ZR     B2,SDM10    IF OPERATOR IS *=* 
          BX7    X2 
          =B3    1
          LX6    X1          1ST    = DOMINANT MODE.
  
**        HERE WITH 
*         (B3) = POINTER
*              = 0 = NO MODE CONVERSION.
*              = 1 = 1ST IS DOMINANT MODE.
*              = 2 = 2ND IS DOMINANT MODE.
*         (X6) = DOMINANT MODE. (WHICH IS ASSUMED TO BE THE RESULTANT 
*                                MODE OF THE OPERATION.)
*         (X6) = DOMINANT MODE. 
*         (X7) = MODE OF OPERAND TO BE CONVERTED. 
  
 SDM10    SX1    B3 
          SA2    X7+MODTBL   RELATIVE TO MODE TO BE CONVERTED 
          SX7    X6 
          LX1    18          POINTER FOR *SMOD* 
          LX7    3           8*DOMINANT MODE. 
          IX6    X1+X6       ADD IN DOMINANT MODE FOR *SMOD*
          SB2    X7          SHIFT COUNT FOR DOMINANT MODE. 
          MX0    -8          LENGTH OF EACH ENTRY IN MCTBL. 
          AX1    B2,X2
          SA3    SOPR 
          BX2    -X0*X1      ONLY 8 BITS FOR EACH MODE. 
          SA1    X3+=XCHARMAP 
          SB7    =XDUC.BTH
          SB7    -B7
          SB7    B7+X1
          ZR     B7,SDM11    IF NOT UNARY OPERATOR
          =X2    0
 SDM11    LX7    X2 
          NZ     X2,SDM12    IF MODE CONVERSION NECESSARY 
          SX6    X6          INDICATE NO MODE CONVERSION
 SDM12    SA7    SMOD1
          =A6    A7-SMOD1+SMOD
          MX7    -L.MODC
          SB7    X2-377B
          LX7    P.MODC 
          NZ     B7,SDM31    IF NO MODE CONVERSION ERROR
  
**        HERE IF MODE CONVERSION IS ILLEGAL
  
          FATAL  E.AT1       LOGICAL AND NON LOGICAL OPERANDS MIXED 
          SA3    SOPR 
          EQ     SDM32
  
*         (B2) = SHIFT COUNT FOR DOMINANT MODE. 
  
 SDM31    BX6    X7*X3       ZERO MODC FIELD IN OPERATOR
          AX3    P.JPAD 
          LX2    P.MODC 
          SA1    X3          DOMINANT MODE TABLE FOR OPERATION. 
          AX3    B2,X1
  
**        RESET OPERATOR JUMP OR LOAD ADDRESS RELATIVE TO DOMINANT MODE.
  
          BX0    -X0*X3 
          SB7    X0-377B
          LX0    P.JPAD 
          IX6    X6+X0       SET OPERATOR RELATIVE TO DOMINANT MODE.
          MI     B7,SDMXA    IF OPERATION DEFINED FOR THIS MODE 
          FATAL  E.AT1A 
          SA3    SOPR 
 SDM32    MX0    60-18       ON ERROR,CLEAR MODE
          SA1    SMOD        CONVERSION FLAG FROM SMOD
          BX7    -X0*X1 
          SA7    A1 
          =X0    1
          LX0    P.MODLS
          BX6    X0+X3       RESET OPERATOR MODELESS IF ERROR 
          SA6    SOPR1
          EQ     EXIT.       (ERROR)
 OMC      SPACE  4,8
**        OMC - OUTPUT MODE CONVERSION TURPLE 
* 
*         ENTRY  (X3) = OPERATOR
*                (X4) = 1ST OPERAND 
*                (X5) = 2ND OPERAND 
*                (SMOD) = 24/0,18/DOMINANT OPERAND,18/DOMINANT MODE 
*                (SMOD1) = OFFSET TO MODECON
* 
*         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/DOMINANT MODE
* 
*         USES   CANNOT DESTROY B4,B5,B6 X3,X4,X5 
*                X4,X5 MAY BE REPLACED BY MODE CONV. INTERMEDIATE 
* 
* 
*         GENERAL SMOD(18-35)   = 0  EXIT. (NO CONVERSION)
*                               = 1  CONVERT ARG IN X5 TO DOMINANT MODE 
*                               = 2  CONVERT ARG IN X4 TO DOMINANT MODE 
*         DOMINANT MODE IS IN SMOD(0-17)
* 
*                SMOD1 = OFFSET TO MODECON FOR CORRECT SKELETON 
*                            ADDRESS, CALCULATED BY *SDM*.
* 
* 
 OMC      SUBR               ENTRY/EXIT...
          SA2    SMOD 
          SX7    X2          (X7) MODE OF DOMINANT OPERAND
          =B3    X2-M.DBL 
          BX6    X3 
          AX2    18          X2 = ARG. NUMBER OF DOMINANT MODE
          SA6    OMCA        SAVE *X3*
          SB7    X3-O.= 
          MX0    -L.MODE
          BX6    -X0*X4      (X6) = MODE OF OPERAND TO BE CONVERTED 
*                            IF OPERATOR IS *=* 
          SX1    2R = 
          LX1    8*CHAR 
          ZR     X2,OMC03    IF NO MODE CONVERSION REQUIRED 
          NZ     B7,OMC05    IF NOT *=* OPERATOR
          SB2    X7-M.CPLX
          ZR     B2,OMC08    IF DOMINANT MODE COMPLEX 
          SB2    X6-M.CPLX
          ZR     B2,OMC08    IF OPERAND TO BE CONVERTED COMPLEX 
          EQ     OMC10
  
 OMC03    NZ     B7,EXIT.    IF NOT *=* OPERATOR
          SB2    X7-M.REAL
          NZ     B2,EXIT.    IF DOMINANT MODE NOT REAL
          SB2    X6-M.CPLX
          ZR     B2,OMC08    IF OPERAND TO BE CONVERTED COMPLEX 
          EQ     EXIT.
  
 OMC05    =B2    X2-1 
          BX1    X5 
          ZR     B2,OMC07    IF OPERAND IS IN X5
          BX1    X4          OPERAND IS IN X4 
 OMC07    SB7    X3-O.LP
          PL     B7,OMC10    IF OPERATOR GREATER THEN O.DIV 
          SB7    X3-O.PL
          MI     B7,OMC10    IF OPERATOR LESS THEN O.PL 
          BX6    -X0*X1      (X6) MODE OF OPERAND TO BE CONVERTED 
          SA1    X6+MODTBL   RELATIVE TO MODE TO BE CONVERTED 
          SB2    X7          SHIFT COUNT FOR DOMINANT MODE
          LX6    B2,X1
          PL     X6,OMC10    IF NO ANSI ERROR 
          SX1    X3+2R +-O.PL EXPECTS O.PL=4,O.MIN=5,O.MULT=6,O.DIV=7 
          LX1    8*CHAR 
 OMC08    BX6    X1 
          SA6    FILL.
          ANSI   E.ANS3      THE TYPE COMBINATION OF THE OPERANDS 
*                            IS NON-ANSI
          ZR     X2,EXIT.    IF NO MODE CONVERSION REQUIRED 
  
*         CHECK IF OPERAND TO CONVERT IS INTEGER CONSTANT.
*         IF IT IS - THEN LET CONRED DO IT. 
  
 OMC10    ZR     B3,OMC2     IF DOMINANT MODE DOUBLE
          SB7    X2-M.INT 
          AX2    P.TGB
          SB2    X2-C.CON/1S13
          NO
          SB7    B2+B7
          NO
          ZR     B7,EXIT.    IF OPERAND IS INTEGER CONSTANT 
  
 OMC2     BX7    X5 
          LX6    X4 
          SA7    OMCA+1      SAVE *X5*
          BX4    0           DUMMY ARG FOR MODE CONVERSION
          SX7    MODECON     BASE ADDRESS OF CONVERSION SKELETONS 
          SA2    SMOD1       CONVERSION OFFSET TO MODECON 
          =X3    O.MODC      MODE CONVERSION OPERATOR 
          IX5    X2+X7       SKELETON ADDRESS FOR MODE CONVERSION 
          =A6    A7+1        SAVE *X4*
          SA1    SMOD        DOMINANT MODE
          AX1    18          X1 = ARG. NUMBER OF DOMINANT MODE
          LX5    P.JPAD 
          IX6    X5+X3       FULL MODE CONVERSION OPERATOR. 
          SA5    X1+OMCA     OPERAND TO CONVERT 
          SA2    X1+OMC.RC
          BX3    X6 
          BX7    X2 
          SA6    SOPR        SET SOPR WITH CURRENT OPERATOR 
          SA7    OMC.RR      SET UP RESTORE WORD
          =B6    B6+1        DUMMY FOR *ADT* RESET USE TO TT.PAR
          RJ     ADT         PUT OUT CONVERSION TURPLE TO TT.PAR
          SA2    SMOD        CLEAR DOMINANT OPERAND 
          MX4    60-18
          SA3    OMCA        RESTORE *X3* 
          LX4    18 
          BX6    X3 
          BX7    X4*X2
          SA6    SOPR        RESET OPERATOR 
          SA7    A2 
  
 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
 SMM      SPACE  4,30 
**        SMM -  SET MODE OF MASKING/LOGICAL OPERATOR 
*                .AND. - .OR. - .NOT. 
* 
*         ENTRY  (X3) = OPERATOR
*                (X4) = 1ST OPERAND 
*                (X5) = 2ND OPERAND 
* 
*         EXIT   (SMOD) = RESULTANT MODE OF OPERATION 
*                (X3)   = (SOPR) = MODC, MODM BITS SET. 
*                (X4)   = PRESERVED.
*                (X5)   = PRESERVED.
* 
*         GENERAL - 
*                IF 1OP AND 2OP = LOGICAL 
*                            OPERATION PERFORMED AS MODELESS, RESULTANT 
*                            MODE SET TO LOGICAL. 
* 
*                IF ONLY ONE OPERAND IS LOGICAL 
*                            ILLEGAL USE OF LOGICAL OPERAND.
* 
*                IF 1OP AND 2OP " LOGICAL 
*                            OPERATION PERFORMED AS MODELESS, RESULTANT 
*                            MODE SET TO MODELESS.
  
  
 SMM      SUBR               ENTRY/EXIT...
          BX0    X4-X5
          MX2    -L.MODE
          BX1    -X2*X0 
          =X7    M.UNIV 
          BX6    -X2*X4 
          ZR     X1,SMM5     IF NOT MIXED MODE
  
**        MIXED MODE - CHECK IF ILLEGAL USE OF LOGICALS.
  
          BX1    -X2*X5 
          =X2    X6-M.LOG 
          =X7    M.UNIV 
          =X0    X1-M.LOG 
          ZR     X2,SMM3     IF 1ST LOGICAL     - ERROR 
          NZ     X0,SMM6     IF 2ND NOT LOGICAL - RESULTS = MODELESS
 SMM3     FATAL  E.AT1       ILLEGAL USE OF LOGICAL OPERAND 
          =X7    M.LOG
          EQ     SMM10       CONTINUE 
  
**        MO MIXED MODE, CHECK IF DOMINANT MODE = LOGICAL.
*         (X6) = MODE BITS FROM 1ST OPERAND 
*         (X7) = M.UNIV 
  
 SMM5     SB7    X6-M.LOG 
          NZ     B7,SMM6     IF DOMINANT MODE NOT LOGICAL 
          BX7    X6          SET = LOGICAL
          EQ     SMM10
  
 SMM6     ANSI   =XE.AT7
  
  
**        SET *SMOD* AND OPERATOR WORD WITH CORRECT MODE BITS.
  
 SMM10    MX1    L.MODC+L.DMOD
          LX1    P.MODC+L.MODC
          BX6    -X1*X3 
          SA7    SMOD 
          SA6    SOPR 
          BX3    X6 
          EQ     EXIT.
 SQZ      EJECT 
**        SQZ -  SQUEEZE OPERATION IF POSSIBLE. 
* 
*         CHECK TO SEE IF CURRENT TURPLE HAS ALREADY BEEN POPPED. 
*         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.
* 
*         EXIT   (B2) > 0 SQUEEZE PERFORMED.
* 
*         USES   A1,A2,A6  X0,X7  B2,B3,B5,B7 
  
  
 SQZ      SUBR               ENTRY/EXIT...
          SA2    BINOUT 
          SA1    TT.PAR 
          =B2    -1          INDICATE NO SQUEEZE PERFORMED
          PL     X2,EXIT.    IF BINARY SUPPRESS - NO SQUEEZE
          SA2    TT=PAR 
          IX0    X1+X2       LWA+1
          SA2    CURST
          =B3    X0-L.TURP   LAST OPERATOR
          IX0    X1+X2
          =B5    X0+OR.OPR   FWA
  
**        BACKWARD SCAN OF PARSED FILE FOR MATCHING TURPLE. 
  
 SQZ5     SA1    B3          LOAD NEXT OPERATOR 
          LT     B3,B5,EXIT. IF FINISHED
          BX6    X1-X3
          =B3    B3-L.TURP
          BX0    X3          SAVE OPERATOR
          =A2    A1+OR.2OP   2ND OPERAND
          ZR     X6,SQZ7     IF OPERATOR THE SAME 
          SB7    X1-O.= 
          NZ     B7,SQZ5     IF NOT TRYING TO PASS BY *=* 
          BX0    X2-X5
          IX7    X2-X4
          NO
          BX0    X0*X7
          NZ     X0,SQZ5     IF NOT RESETTING VALUE OF ONE OF OPERANDS
          =B2    -1 
          EQ     EXIT.
  
**        OPERATOR IS THE SAME,  CHECK 2ND OPERAND. 
*         (X0) = OPERATOR.
  
 SQZ7     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
          SB7    X3-O.= 
          ZR     X2,SQZ40    IF MATCH, ELIMINATE
          NZ     B7,SQZ5     IF NOT PROCESSING AN *=* OPERATION.
          BX0    X4 
          IFBIT  X0,-INTR,SQZ5
          SA1    TT.PAR 
          AX0    P.TAG-P.INTR-1 
          IX0    X1+X0
          SA1    X0 
          SB7    X1-O.= 
          NZ     B7,SQZ5     IF NOT AN *=* INTERMEDIATE.
  
**        ELIMINATE RIGHT OPERAND IN CASES LIKE --
*         C=B=C=2.0, WHERE *C* DOES NOT NEED TO BE RESET MORE THAN ONCE.
  
          =B2    0           INDICATE SQUEEZE.
 TEST     IFNE   TEST 
          RJ     SN.SQZ 
 TEST     ENDIF 
          =B6    B6-1        ELIMINATE OPERANDS.
          EQ     EXIT.
  
**        ELIMINATE TURPLE,  SQUEEZED PERFORMED.
  
 SQZ40    ZR     B7,SQZ5     IF *=* OPERATOR
          AX6    P.DMOD 
          SA2    ATTR        ATTRIBUTES FOR OPERAND RESULTS 
          MX0    -L.DMOD
          SA1    TT.PAR 
          =X3    M.INTR 
          BX5    -X0*X6      DOMINANT MODE
          IX3    X2+X3       INTER + ATTRIBUTES 
          =B2    X1-L.TURP
          SX4    B3-B2       ORDINAL
          IX6    X3+X5       ORDINAL + MODE 
          LX4    P.TAG
          NO
          IX6    X4+X6       ORDINAL + MODE + INTERMEDIATE BIT. 
          SA6    B6-2        SQUEEZE OPERATION TO ESTACK. 
          =B6    B6-1 
 TEST     IFNE   TEST 
          RJ     SN.SQZ 
 TEST     ENDIF 
          EQ     EXIT.
 TEST     IFNE   TEST 
 SN.SQZ   SPACE  4,8
**        SN.SQZ - NOTIFY OF SQUEEZE OPERATION PERFORMED. 
* 
*         ENTRY  (B3)+L.TURP _ OPERATOR THAT WAS SQUEEZED.
* 
*         EXIT   (A1) DESTROYED.
* 
*         USES   DESTROYS *A1* ONLY...
  
  
 SN.SQZ   SUBR   0
          SA1    CO.SNAP
          LX1    1RQ
          PL     X1,SN.SQZX  IF PARSED SNAPS NOT REQUESTED. 
          RJ     =XSVR
          SA3    =XSVB+3
          SA2    TT.PAR 
          IX0    X3-X2
          SX1    X0+L.TURP
          RJ     COD         CONVERT TO OCTAL 
          LX6    3*CHAR      4 DIGITS TO HIGH ORDER 
          MX0    4*CHAR 
          SA1    TT=PAR 
          BX4    X0*X6
          RJ     COD         CONVERT TO OCTAL 
          MX0    -6*CHAR
          LX6    8*CHAR 
          BX5    -X0*X6      EXTRACT LOWER 6 DIGITS 
          BX6    X5+X4
          SA6    SQZOPR 
          SA1    SOPR 
          SA2    X1+CHARMAP 
          MX0    L.CDPC 
          BX6    X0*X2
          SA6    SQZBUFC     OPERATOR SQUEEZED. 
          PLINE  SQZBUF 
          RJ     =XRSR
          EQ     SN.SQZX     EXIT.. 
  
**        SQZ LINE BUFFER.
  
 SQZBUF   DATA   10H
          DATA   10H OPERATOR 
          DIS    1,SQUEEZE AT 
 SQZOPR   DATA   0
          DIS    1, OPERATOR
 SQZBUFC  DATA   0
 TEST     ENDIF 
 ENTRY    SPACE  4,8
          LIST   D
          END 
