*DECK,    ARITH 
          IDENT  ARITH
 ARITH    TITLE  ARITH -     ARITHMETIC STATEMENT PROCESSOR 
*CALL     SSTCALL 
 B=ARITH  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
          SPACE  4
**        LISTING CONTROLS. 
* 
*         ALSO SEE AUTOMATIC NOREFS GENERATED FOR NAMES OF *IF* MACROS
*         WITHIN THE DEFINITION OF THE MACRO *RMACRO*.  THIS DEFINITION 
*         IS LOCATED AT THE BEGINNING OF THREE- AND TWO-BRANCH *IF* 
*         PROCESSING.  SEE CODE AFTER DEFINITION OF THE SYMBOL *IFERR1*.
  
          NOREF  A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
          NOREF  .A 
          NOREF  .B 
 MACROS   SPACE  4,8
          MACRO  ARLIST,LBL,LIM 
 .SLIM    SET    LIM 100
 LBL.ARL  SNAP   *O.ARLST,,*ARLPT,,1,.SLIM,1
 ARLIST   ENDM
 OPSTACK  SPACE  4,8
          MACRO  OPSTACK,LBL,LIM
 .SLIM    SET    LIM 100
 LBL.OPS  SNAP   OPSTAK+1,,*OSPTR,,1,.SLIM,1
 OPSTACK  ENDM
          SPACE  5
************************************************************************
*                                                                      *
*                DIAGNOSTIC ISSUANCE MACROS                            *
*                                                                      *
*         'IDM'        ISSUE INFORMATIVE DIAGNOSTIC                    *
*                                                                      *
*         'USASDM'     ISSUE 'USAS' SPECIFICATION VIOLATION DIAGNOSTIC *
*                                                                      *
*         'EERR'       ISSUE FATAL TO EXECUTION DIAGNOSTIC             *
*                                                                      *
*         'FCERR'      ISSUE FATAL TO COMPILATION DIAGNOSTIC           *
*                                                                      *
************************************************************************
          SPACE  1
IDM       MACRO  MSGNUM 
          IF     -DEF,IDCOUNT 
IDCOUNT   SET    0
          RMT 
IDMX      SA1    EPOINT 
          SB1    X1+1 
IDM       BSS    1
          SB7    IDMX 
          SA1    EPOINT 
          SA4    X1+1 
          ZR     ERPROI 
          RMT 
          ENDIF 
IDCOUNT   SET    IDCOUNT+1
          SB6    MSGNUM 
 .T       IFNE   TEST,0 
          SB4    *+2-*P/60D 
          CALL   TEM
 .T       ENDIF 
          RJ     IDM
IDM       ENDM
          SPACE  2
USASDM    MACRO  MSGNUM 
          IF     -DEF,USASCT
USASCT    SET    0
USASER    EQU    ASAER
          RMT 
USASDMX   SA1    EPOINT 
          SB1    X1+1 
USASDM    BSS    1
          SB7    USASDMX
          SA1    EPOINT 
          SA4    X1+1 
          ZR     USASER 
          RMT 
          ENDIF 
USASCT    SET    USASCT+1 
          SB6    MSGNUM 
 .T       IFNE   TEST,0 
          SB4    *+2-*P/60D 
          CALL   TEM
 .T       ENDIF 
          RJ     USASDM 
USASDM    ENDM
          SPACE  2
EERR      MACRO  MSGNUM 
          SB6    MSGNUM 
* 
 .T       IFNE   TEST,0 
          SB4    ERROUT 
          CALL   TEM         TRACE ERROR MESSAGE
 .T       ELSE
          EQ     ERROUT 
 .T       ENDIF 
* 
EERR      ENDM
          SPACE  2
FCERR     MACRO  MSGNUM 
          POSTER SEV=FC,NR=MSGNUM,FMT=ELIST,TXT=X1+1
FCERR     ENDM
          SPACE  5
*** 
*        E X P O N  -  MACRO
* 
*      THIS MACRO IS USED TO MAKE ENTRIES IN THE EXPONENT TABLE.
*      THIS TABLE CONSISTS OF ALL POSSIBLE CONFIGURATIONS OF
*      EXPONENTIATION.
* 
 EXPON    MACRO  TYPE,ANS,EXPR
 P1       MICRO  1,1,/EXPR/ 
 P2       MICRO  4,1,/EXPR/ 
          IFC    EQ,/ILLEGAL/ANS/,2 
          VFD    60/0              ILLEGAL ENTRY
 A1       DUP    0
 A        SET    0
          IFC    NE,/ANSI/ANS/,1
 A        SET    1
          VFD    4/TYPE,8/A,48/8H"P1"TO"P2".
 A1       ENDD
 EXPON    ENDM
          SPACE  5
*** 
*                R O U N D -- MACRO 
* 
*         THIS MACRO IS USED TO MAKE ENTRIES IN THE ROUNDED OPERATION 
*         TABLE.  THE TABLE WILL CONSIST OF ALL MACROS WHICH MAY BE 
*         SELECTED TO BE ROUNDED AND THE OPERATOR WHICH SELECTS THE 
*         ROUNDED OPTION. 
* 
 ROUNDMAC MACRO 
 A        SET    0
 ROUND    MACRO  OP,MAC,ROUNDMAC
          VFD    2/1,10/1R_OP,18/ROUNDMAC,30/MAC
          IFLE   MAC,A,1
           ERR   ROUND TABLE MUST BE IN ASCENDING NORMAL MACRO ORDER
          ENDM
          ROUNDMAC
          SPACE  5
************************************************************************
*                                                                      *
*                I N T R I N :   INTRINSIC FUNCTION TABLE ENTRY        *
*                                                                      *
************************************************************************
          SPACE  1
          MACRO  INTRIN,NAMEXXX,TYPE,PARAMS,MACROOP,MODECHAN,RNM,MXTYP
          LOCAL  NPARAMS,NRS
          LOCAL  SP1,SP2,SP3
NPARAMS   SET    0
NRS       SET    0
 TYMIC    MICRO  1,,
          COUNT  NPARAMS,NRS,PARAMS 
NRS       SET    NRS+1
          IFC    EQ, TYPE DOUBLE ,1 
NRS       SET    NRS+1
          IFC    EQ, TYPE COMPLEX ,1
NRS       SET    NRS+1
          IFC    EQ, TYPE ANYDBL ,1 
NRS       SET    NRS+1
NRS       DECMIC NRS
 SP1      SET    P.NAME-P.FUN 
 SP2      SET    P.TYP-P.FARG 
 SP3      SET    P.FARG-P.INF 
          VFD    L.NAME/0H_NAMEXXX,SP1/1,P.FUN/0,L.TYP/TYPE,SP2/"NPARAMS
,",SP3/1,P.INF/RNM
 NPAR     IFNE   NPARAMS,0
 .A       SET    6*NPARAMS+6
 .B       SET    60-.A
          VFD    .A/"TYMIC"_00B,.B/0
 MACRO    IFC    EQ,/MACROOP//,3
 .N       MICRO  1,8, MD.NAMEXXX
          VFD    1/1,29/".N",30/A_NAMEXXX 
 MACRO    ELSE   1
          ARMAC  MACROOP,0,"NRS",0
 NPAR     ELSE
 .A       OCTMIC MXTYP+1,2
          DUP    10,1 
          VFD    6/".A"_B 
          VFD    30/MODECHAN,30/MACROOP 
          ENDIF 
INTRIN    ENDM
          SPACE  5
************************************************************************
*                                                                      *
*                A R M A C :  GENERATE 'ARITH'S MACRO DESCRIPTOR       *
*                                                                      *
************************************************************************
          SPACE  1
          MACRO  ARMAC,LABEL,OPCODE,NCONS,NRS,NSYMS 
A         SET    NSYMS+1
 B        SET    A/2
A         SET    NRS+2
A         SET    A/3
 B        SET    B+A
A         SET    NCONS+2
A         SET    A/3
 NWDS     DECMIC B+A
          IFC    NE, LABEL
LABEL     VFD    2/1,10/OPCODE,12/"NWDS",12/NCONS,12/NRS,12/NSYMS 
          ELSE
          VFD    2/1,10/OPCODE,12/"NWDS",12/NCONS,12/NRS,12/NSYMS 
          ENDIF 
ARMAC     ENDM
          SPACE  5
*CALL     COUNTMC 
          SPACE  5
*** 
*         SUB -  ADDRESS SUBSTITUTION MACRO 
*                COLLECTS ARLIST REFERENCES SO THAT ADDRESS SUBSTITUTION
*                CAN BE PERFORMED FOR THE BASE OF THE ARLIST BUFFER 
  
 SUB      MACRO 
 A        SET    $+1
 B        SET    *-$/59D
          USE    OPSTAK 
          VFD    12/2000B+A,30/,18/B
          USE    *
          ENDM
*CALL PARSEM
          TITLE              SYSTEM EQU"S 
          SPACE  5
          EJECT 
          EJECT 
*     SYSTEM EQU"S
 RA       EQU       0 
 SYM1     EQU       RA+12B    START.ADR.OF SYMTAB 
 DIM1     EQU       RA+17B    ADR.OF DIMEN.INFO.TABLE 
 TYPE     EQU       RA+24B    TYPE CODE OF CURRENT STATEM.. 
 SELIST   EQU       RA+32B    ADR.OF NEXT E-LIST ELEMENT TO PROCESS.
 CDCNT    EQU       RA+37B    THE CARD NO.OF THE 1ST CARD OF THIS STATE.
 PROGRAM  EQU    56B
 NRLN     EQU       RA+64B
* 
* 
* 
 EPOINT   EQU       SELIST
 NARN     EQU       NRLN
  
          NOREF     MACNUM
          SPACE 3 
*     CONSTANT EQU"S
 LOGICAL  EQU    T.LOG
 INTEGER  EQU    T.INT
 REAL     EQU    T.REAL 
 DOUBLE   EQU    T.DBL
 COMPLEX  EQU    T.CPLX 
 OCTAL    EQU    T.OCT
 ANYSNGL  EQU    7
*ANYDBL   EQU    10B
 ANY      EQU    11B
*      SOME OF THE OP CODES AS USED IN OPSTACK WORKS. 
 RMINOC   EQU       27
 RDVDOC   EQU       28
 MLTOP    EQU    18           * 
 MLTSOP   EQU    29           */  MULT-SLASH OP 
 UMOP     EQU    26           U-
 RPOSO    EQU    2            ) 
 DVDORD   EQU    19           / 
 SFLPOC   EQU       30        STATE.FUN.LEFT PARENS OP CODE 
 XFLP     EQU       31        IXFN LP 
*      MISC.EQU"S 
 MXARGS   EQU       63        MAX.NO.OF ARGS.IN FUNCTION ARG.LIST.
* - ALLOWED, AND MAX.NO.OF NESTED FUNCTION CALLS. 
 RPLST    EQU    12           CODE SCANNER GIVES TO REPLACEMENT STATES. 
 R-OPC    TITLE  RLIST MACRO OPCODES
*         R-LIST MACRO OP CODES 
  
 APLMC    RMEQU  1           APLIST ENTRY 
 STLMAC   RMEQU  4           IXFN LD
 SSSXA    RMEQU  6           IXFN SETX
 M.EXM    RMEQU  8           INLINE EXPONENTIAL MACRO 
 M.SFR    RMEQU  9           SAVE FUNCTION RESULT 
  
 DEFMC    RMEQU  111B        ORDINAL OF 1ST OF 8 REG STORE MACROS FOR 
*                            BASIC EXT CALLS.  LAST 4 ARE USED IF ARG IS
*                            NOT RESULT OF FUNC (XMIT NOT NECESSARY)
 BEFMC    RMEQU  121B        BASIC EXT FUNC CALL MACRO ORDINAL
 RJ60MC   RMEQU  122B        60-BIT RJ, NO APLIST 
 GEFMC    RMEQU  124B        GENERAL EXT FUNC CALL MACRO ORDINAL
 DFRMC    RMEQU  125B        ORDINAL OF 1ST OF 2 REG DEFINITION MACROS
 TSMACC   RMEQU  127B        STORE TO TEMP
  
 DLMACO   RMEQU  131B        DBL LOAD MACRO ORDINAL 
 SLMACO   RMEQU  133B        SINGLE LOAD MACRO ORDINAL
 XMITOP   RMEQU  135B        TRANSMIT MACRO ORDINAL 
  
 SETMC    RMEQU  142B        SET R TO CONSTANT
 SXTAMC   RMEQU  143B        SET RI = IH + CA + RF
 P2TON    RMEQU  144B        P2 = (2**K1)*P1  ( P1 INTEGER )
 MZMC     RMEQU  145B        MXI 0 (ZERO MASK)
 MZZMC    RMEQU  146B        DBL ZERO MASK
 SDLMC    RMEQU  147B        SINGLE TO DBL LOAD (2ND WD=0)
 MIZMC    RMEQU  150B        MXI 60 
 DLTSMC   RMEQU  151B        DBL TO SINGLE LOAD 
 MCHMCB   RMEQU  152B        ORDINAL BASE OF MODE CHANGE MACROS 
  
 MAC      RMEQU  157B        BASE ORDINAL OF OPSWTB MACROS
 NOTMC    RMEQU  161B        .NOT.
 LORELM   RMEQU  162B        .LS. (LESS THAN) 
 HIRELM   RMEQU  211B        .GT. (GREATER THAN)
 M.SUB    RMEQU  212B        BASE ORDINAL OF SUBTRACT MACROS
 MPY.INT  RMEQU  223B        INTEGER MULT. MACRO ORDINAL
 DIV.INT  RMEQU  227B        INTEGER DIVIDE 
 DIVCR    RMEQU  241B        COMPLEX / REAL 
  
 RSUB     RMEQU  244B        BASE ORDINAL OF ROUND OPERATIONS MACROS
 CRSUB    RMEQU 
 RADD     RMEQU 
 CRADD    RMEQU 
 RMLT     RMEQU 
 CRMLT    RMEQU 
 RDIV     RMEQU 
 CRDIV    RMEQU 
 RRSUB    RMEQU 
 CRRSUB   RMEQU 
 RRDIV    RMEQU 
 CRRDIV   RMEQU 
  
*         MARCOX MACRO CODES FOR INLINE FUNCTIONS 
  
 IFMCB    RMEQU  260B        BASE ORDINAL OF INTRINSIC FUNC MACROS
 M.AND    RMEQU  IFMCB+26B         BOOLEAN AND
 M.OR     RMEQU  IFMCB+27B         BOOLEAN OR 
 M.COMPL  RMEQU  IFMCB+30B         BOOLEAN COMPLEMENT 
 MXMNMC   RMEQU  335B        BASE ORDINAL OF MIN/MAX MACROS 
 M.MOD    RMEQU  267B        MOD(I,J) 
 M.MODP2  RMEQU  273B        MOD(I,2**K)
 M.SHIFT  RMEQU  305B        VARIABLE SHIFT MACRO ORDINAL 
 M.MASK   RMEQU  311B        VARIABLE MASK MACRO ORDINAL
 M.MASKC  RMEQU  312B        CONSTANT MASK MACRO ORDINAL
 M.CSHFT  RMEQU  313B        CONSTANT LEFT SHIFT MACRO ORDINAL
  
 M.XOR    RMEQU  316B        EXCLUSIVE OR 
 M.COUNT  RMEQU              COUNT NUMBER OF BITS 
 M.UPE    RMEQU              UNPACK EXPONENT
 M.UPC    RMEQU              UNPACK COEFFICIENT 
 M.PACK   RMEQU              Y=PACK(EXP,COE)
 M.RANF   RMEQU              RANF(0)
 M.SXKXJ  RMEQU              18-BIT EXTRACT (SXI XK)
 M.DMULT  RMEQU              DBL MULT 
 M.NORM   RMEQU              NORMALIZE ARGUMENT 
 M.NORMC  RMEQU              RETURN VALUE OF NORMALIZATION COUNT
 M.IFTHEN RMEQU              Y=IF L THEN A ELSE B 
 M.FADD   RMEQU              FLOATING ADD 
 M.RADD   RMEQU              ROUNDED FLOATING ADD 
 M.FSUB   RMEQU              FLOATING SUBTRACT
 M.RSUB   RMEQU              ROUNDED FLOATING SUBTRACT
 #T       IFNE   TEST,0 
 M.FMULT  RMEQU  417B        FLOATING MULTIPLY
 M.RMULT  RMEQU              ROUNDED FLOATING MULTIPLY
 M.FDIV   RMEQU              FLOATING DIVIDE
 M.DADD   RMEQU              FLOATING DOUBLE ADD
 M.DSUB   RMEQU              FLOATING DOUBLE SUBTRACT 
 M.RNORM  RMEQU              ROUNDED NORMALIZE
 M.DSUMH  RMEQU              QUICK DOUBLE PREC. ADD 
 M.DDIFH  RMEQU              QUICK DOUBLE PREC. SUBTRACT
 M.DDIVH  RMEQU              QUICK DOUBLE PREC. DIVIDE
 M.DMULH  RMEQU              QUICK DOUBLE PREC. MULTIPLY
 M.BOOL   RMEQU              BOOLEAN (TYPELESS) TRANSMIT
 #T       ENDIF 
          SPACE  3
          SPACE  4,8
*      ERROR MESSAGE ASSIGNMENTS: 
 ERMSG52  EQU    76                ECS REF MUST APPEAR AS A STAND ALONE 
*                                  ARGUMENT IN A PARAM LIST 
 ERMSG    EQU       134 
 ERMSG0   EQU    ERMSG+0      MORE THAN ONE =SIGN 
 ERMSG1   EQU    ERMSG+1      ILLEGAL USE OF =SIGN
 ERMSG2   EQU    ERMSG+2      VARIABLE FOLLOWED BY (
 ERMSG3   EQU    ERMSG+3      NO MATCHING RIGHT PARENS
 ERMSG4   EQU    ERMSG+4      NO MATCHING LEFT PARENS 
 ERMSG5   EQU       ERMSG4+1  FE: THE OPERATOR INDICATED(-,+,*,1, OR **)
*            MUST BE FOLLOWED BY A CON, ID, OR (. 
 ERMSG6   EQU       ERMSG5+1  A NAME MAY NOT BE FOLLOWED BY A CONSTANT. 
 ERMSG7   EQU    ERMSG+7      MORE THAN 63 ARGUMENTS IN ARG.LIST. 
 ERMSG8   EQU       ERMSG7+1  A CONST MAYNT BE FOLOWD BY =, NAME, OR CON
 ERMSG9   EQU    ERMSG+9      OPSTACK FILLED: TOO MANY UNRESOLVED OPERA-
 ERMSG10  EQU    ERMSG+10     LOGICAL OPERAND USED WITH NON-        TORS
*                                        LOGICAL OPERATORS. 
 ERMSG11  EQU       ERMSG+11  NO MATCHING RT PARENS IN SUBSCRIPT
 ERMSG13  EQU    ERMSG+13     INFORMATIVE: ARRAY NAME NOT SUBSCRIPTED,
                                   FIRST WORD USED. 
 ERMSG14  EQU       ERMSG+14  NON-EXT FUN.MAY NOT USE FUN.NAME AS AC.ARG
 ERMSG15  EQU       ERMSG+15  ARG.NOT FOLLOWED BY , OR )
 ERMSG16  EQU       ERMSG+16  THIS FUNC.REF REQUIRES ARG.LIST 
 ERMSG60  EQU    151D        CONSTANT EXCEEDS 2**48-1 FOR * OR /
 ERMSG17  EQU       171D      ILLEGAL CALL FORMAT 
 ERMSG18  EQU       ERMSG+18  ARITHS FUN-RES-SAVE TB HAS OVERFLOWED 
 ERMSG19  EQU       ERMSG18+1 FE: THE OPERATOR INDICATED (A .NOT. OR A
*            RELATIONAL) MUST BE FOLLOWED BY A CONSTANT, ID, (, -, OR +.
ERMSG21  EQU        ERMSG+21  BASIC OR INT FUN WITH INCORRECT ARG CNT 
 ERMSG22  EQU       ERMSG+22  ARITH ARLIST BLOK OVERFLOWED. EXPR TOO LNG
 ERMSG23  EQU       ERMSG+23  ASA: FEWER SUBSCRIPTS THAN DIMESIONALITY
 ERMSG24  EQU       ERMSG+24  ILLEGAL I/O ADDRESS 
 ERMSG25  EQU       ERMSG+25  RIGHT PARENS FOLLOWED BY ID, CONST, OR (
 ERMSG26  EQU       ERMSG+26  MORE THAN 1 REL OP IN THIS REL EXPR 
 ERMSG27  EQU    ERMSG+27    INCORRECT SYNTAX FOLLOWS INDICATED ELEMENT 
 ERMSG28  EQU       ERMSG+28  TOO MANY SUBSCRIPT EXPRESSIONS
 ERMSG29  EQU       ERMSG+29  NO MATCHING RT PARENS IN ARG LIST 
 ERMSG30  EQU       ERMSG+30  ILLEGAL FORM INVOLVING THE USE OF A COMMA 
 ERMSG31  EQU       ERMSG+31  LOGCL AND NON-LOGCL OPDS MAY NOT BE MIXED 
 ERMSG32  EQU       ERMSG+32  DIVISION BY CONSTANT 0
 ERMSG33  EQU       ERMSG+33  CMPX BASE MAY ONLY BE EPONENTIATED BY INTG
 ERMSG34  EQU       ERMSG+34  USE OF THIS PROGRAM,SUBROUTINE,OR BLOCK-
*            DATA NAME IN AN EXPRESSION.
 ERMSG35  EQU       ERMSG34+1 SUBR.NAME REF.BY CALL IS USE OTHERWISE
 ERMSG36  EQU       ERMSG35+1 SUBR REF USES DIFFERENT NO.OF ARGS. 
*  ERMSG37 EQU 306B=198 
 ERMSG38  EQU       183       ASA: HOL CON
 ERMSG39  EQU       ERMSG38+1 I  :HOL CON AND ARITH OR REL OP 
 ERMSG40  EQU       ERMSG39+1 ASA:NON STD SUB 
 ERMSG41  EQU       ERMSG40+1 ASA:MASKING EXPR
 ERMSG42  EQU       ERMSG41+1 ASA:EXPONENT OPD COMBINATION
 ERMSG43  EQU       ERMSG42+1 ASA:RELATIONAL AND CPX OPD
 ERMSG44  EQU       ERMSG43+1 ASA:ARITH OR REL OPD COMBINATION
 ERMSG45  EQU       ERMSG44+1 ASA:EQUAL SIGN OPD COMBINATION
 ERMSG46  EQU       ERMSG45+1 ASA:TWO BRANCH IF 
 ERMSG47  EQU       ERMSG46+1 ASA:COMPLEX EXPR IN IF STATE. 
 ERMSG37  EQU       198       LEFT SIDE OF REPLACEMENT STATE. IS ILLEGAL
 ERMSG49  EQU       203       FE: NAME NOT LEGAL TYPE FOR ANY EXPRESSION
 ERMSG50  EQU       ERMSG49+1 CONST OPD FOR REAL OP O.R. OR INDEF.
 ERMSG51  EQU       70        THIS STATEMENT CONTAINS A CONSTANT ARITHME
* TIC OPERATION WHICH WILL GIVE AN INDEFINITE OR OUT-OF-RANGE RESULT. 
*ERMSG52  SEE 1ST ENTRY ABOVE 
 ERMSG53  EQU       219       .NOT. MUSNT BE PRECDD BY ID, CON, OR ). 
 ERMSG54  EQU    215               MASK OUT OF RANGE
 ERMSG56  EQU    302         SHIFT ARG OUT OF BOUNDS
 ERMSG55  EQU    146         INF OR BEF CALLED WITH WRONG TYPE
 ERMSG57  EQU    300               THIS PROGRAM UNIT CALLS ITSELF 
 ERMSG58  EQU    303         ASF REDEFINITION 
 ERMSG59  EQU    318         A**B**C IS NON ANSI
 ERMSG61  EQU    322         EXTERNAL IN ARGLIST MUST BE IN EXT STMT
 ERMSG.LF EQU    296               BAD ARG TO LOCF
 ERMSG62  EQU    154         REDEFINITION OF FPS IS NON-ANSI
 E328     EQU    328         SAME NAME USED AS FUNCTION AND SUBROUTINE
          TITLE 
          EJECT 
*     BSS"S  (NON-COMMON) 
*     SEE DECISIONS FILE RE SIZE OF ARLIST
 ARLIST   EQU    0                 SET TO ZERO FOR ADDSUB PURPOSES
          ENTRY  OPSTAK            NEEDED FOR ADDSUB CODE 
 SAVDAN   ENTRY.                   VARIABLE DIMENSION ARRAY NAME FLAG 
 CONST    ENTRY.             ENTRIES FOR CONVERTED CONSTANTS
          BSS    1
 IDORDL   ENTRY.                   SYMTAB ORD OF ID NAME
 NAMFWA   ENTRY.                   ADDRESS OF WORD A OF SYMTAB ENTRY
EQCOUNT   ENTRY.                   EQUAL SIGN COUNTER CELL
*                               NAME IN SYMTAB. 
 NCA      ENTRY.                   NEW CONSTANT ADDEND
 NCAD     ENTRY.             CA FOR DODEF 
 NRFD     ENTRY.             RF FOR DODEF 
 OP       ENTRY.                   HOLDS CURRENT ELIST OP 
 ARLST    BSS    1            FWA FOR BUFFER FLUSHING 
*     PARAMS HOLDS PARAMS FOR CURRENTLY FORMINE MACRO.  MAX NO PARAME-
*  TERS NOW BEING USED IS 6 + 4 SAFETY BUFFER.
PARAMS    BSS    10+4 
 RL1      BSSZ   1
 RL2      BSS    1  ARLIST). (  11   11 LAST           11     11  11
 SMACD    BSS    1    11  ).  SAVES MACRO CODE DURING MOP.
 SVRL2    BSS       1         SAVE RL2
 IDORDLTS BSS    2                 HOLDS ORDINAL FOR EQUIV VARIABLE 
 CRNTOP   BSS    1                 CURRENT OPERATOR 
 FRLW     BSSZ      MXARGS+6  PTS TO 1ST ARLIST WD OF FUNC SEQ
 FNAD     EQU       FRLW+1    FUN.ADR.IN SYMTAB 
 ACNT     EQU       FNAD+1    ARG.CNT=NO.OF ARGS SCANNED
          ENTRY  STAPLC 
 STAPLC   EQU    ACNT+1            STAPL CHAIN POINTER
 SSFRSTB  EQU    STAPLC+1          SAVED SFRSTB 
 RNTBC    EQU       SSFRSTB+1 
 RNTB     EQU       RNTBC+1   R-NAME TBL.HOLDS NAMES OF RESULT REGS.HOL-
*     -DING THE ARGUMENTS FOR INTRINSIC FUNCS.
*     TWO WORDS FOR DBL, CPX ARGS 
*     FORMAT OF FRSTB ENTRIES: B58=1 IF DBL LENGTH SAVE 
*                              B33-16=TEMP STO ORD (STORD)
*                              B15-0 =NAME OF RESULT SAVED
 FRSTB    BSS       MXFRSTB   FUNC RESULTS SAVED TBL (EXTERNALS)
 SSSFRSTB BSS    1           SAVE SSFRSTB 
 FRN      BSS       1 
 FNTYP    BSS       1         FUN.TYPE
 TS1      BSS       3+5       LEVEL A TEMP STO. USED BY NON-SUBROUTINES 
 LBTS     BSS       3+5       LEVEL B. USED BY 1ST LEVEL SUBROUTINES. 
 OPDTYP   BSS       1         OPERAND TYPE. NEEDED FOR RELATIONAL OPS.
 TYPEWD   BSS    1            HOLDS TYPE OF RESULT CODE 
 CA       BSS    1            CONSTANT ADDEND FOR A SUBSCRIPT 
 NAME     BSS    2            THE SYMTAB ENTRY FOR THIS NAME
 DIMINF   BSSZ   1                 DIMENSION INFO FOR ARRAY 
 ARORD    BSSZ   1                 ORDINAL OF ARRAY 
 SDIMIN   BSS    1
 TYADR    DATA   0                 POINTER TO ARGUMENT TYPES WORD 
 SARORD   BSS    1
 SPARLEV  BSS    1           SUBSCRIPT-PAREN LEVEL
SAVELEFT  BSS    1               SYMBOL TABLE ORDINAL OF VARIABLE ON
                                   THE LEFT-HAND SIDE OF A REPLACEMENT
                                   STATEMENT. 
 EXPFNE   BSS       1         HOLDS THE NAME OF THE CURRENT EXPONENT FUN
 EXRL1    BSS       1         HOLDS RL1 AFTER ** POPPED 
 EXRL2    BSS       1               RL2 
 VCA      BSS       1 
 MCOPDA   BSS       1         MODE-CHANGE-OPERAND ADDRESS (MODCH) 
 MCTYP    BSS       1         MODE-CHANGE TYPE
 MCHTS    BSS       2         MODCH TEMP.STO. 
 FMADR    BSS       2         FINAL-MACRO ADR 
 RNCNT    BSS       1 
 EXPRIA   BSS       1         EXPRESSION RESULT INSTRUCTION ADDRESS.
 ARN      BSS       1 
 EXPCON   BSS    1           TEMP CELL USED IN EXPON PROCESSING 
 FFRTSTS  BSS       1         FFRTS T.S.(SAVES NARN)
 ARGP1TS  BSS       6+2       ARP1RT TEMP STO 
 STAPL    BSS    1                 TEMPORARY FOR SAVING STAPLC
 EXPSTB   BSS       1 
 EXPNSF   BSS       1         HOLDS SFRSTB AT START OF ** ARG LIST
 NSFR     BSS       1         <0 IF DOESNT HOLD SFRSTB AT START OF BASE-
 RNFIB    BSS       1         R NAME OF 1ST INSTR IN START OF BASE OF  -
 MACDES   BSS    1           HOLDS SHIFT/MASK MACRO DESCRIPTOR
*                                   EXTERNAL **.
*                                                            OF **. 
          USE    OPSTAK       ENSURE THAT VFD PRECEDES BLOCK
 OPSTAK   VFD    12/2004B,48/0          EOS OPERATOR
          USE    *
          RMT 
          USE    OPSTAK 
          BSSZ   OPSTAK+MXOSE-*    ALLOCATE REMAINDER OF OPSTAK SPACE 
          USE    *
          RMT 
*     BSSZ"S
 EQFLG    BSSZ   1            =0 IF NO =SIGN YET
 ROFG     BSSZ      1         REVERSE OPD.FLG.IS NEGATIVE IF RL,S RVRSD 
 LEFRN    BSSZ      1         =LAST EXTERNAL FUNC RESULT NAME, OK ZERO -
*     - IF NONE.  B58=1 IF DBL LENGTH RESULT. 
 SFRSTB   BSSZ      1         SIZE OF FRSTB 
 OSPTR    BSSZ      1         OPSTAK POINTER=NO.OF WDS IN OPSTAK
 CC       BSSZ   1            COMMA COUNT 
 IXFNFG   BSSZ      1         IXFN-ROUTINE FLAG=0 IF NOT IN IXFN MODE 
 ITFFG    BSSZ      1 
 RNMFG    BSSZ      1         =0 IF THIS INTR FUN MACRO ISNT RNM-OP TYPE
 EQPO5F   BSSZ      1         FLAG TO AVOID MORE  THAN 1 XMIT FOR =,S 
 OCTHO    BSSZ   1           =0 IF A REPLACED ELEMENT IS NOT OF O OR H M
          TITLE  MACRO DESCRIPTOR WORDS 
SETMAC    ARMAC  SETMC,1,1,0       SET RI=IN
DLMAC     ARMAC  DLMACO,2,3,1      DOUBLE LOAD MACRO
DZRMD     ARMAC  MZZMC,0,2,0
ZRMD      ARMAC  MZMC,0,1,0        FMA P1,0      (FORM MASK OF 0) 
SDLMD     ARMAC  SDLMC,1,2,1
MZMD      ARMAC  MIZMC,0,1,0       FMA P1,60  (FORM MASK OF 60, -0) 
SLDMAC    ARMAC  SLMACO,1,2,1      SINGLE LOAD MACRO
 RJ60MD   ARMAC  RJ60MC,1,0,1      60-BIT RJ MACRO, NO APLIST 
          SPACE  1
*              DEFINITION/REGISTER STORE MACROS                        *
          SPACE  1
DEFMD     ARMAC  DEFMC+0,0,1,0     DEFINE X1=RI 
          ARMAC  DEFMC+1,0,1,0     DEFINE X3=RI 
          ARMAC  DEFMC+2,0,1,0     DEFINE X2=RI 
          ARMAC  DEFMC+3,0,1,0     DEFINE X4=RI 
          ARMAC  DEFMC+4,0,1,0     REGISTER STORE X1=P1 (NO TRANSMIT) 
          ARMAC  DEFMC+5,0,1,0     REGISTER STORE X3=P1 (NO TRANSMIT) 
          ARMAC  DEFMC+6,0,1,0     REGISTER STORE X2=P1 (NO TRANSMIT) 
          ARMAC  DEFMC+7,0,1,0     REGISTER STORE X4=P1 (NO TRANSMIT) 
DFRMD     ARMAC  DFRMC+0,0,1,0     DEFINE X6=RI 
          ARMAC  DFRMC+1,0,1,0     DEFINE X7=RI 
          SPACE  1
XMIT      ARMAC  XMITOP+0,0,2,0  SINGLE PRECISION TRANSMIT
          ARMAC  XMITOP+1,0,4,0  DOUBLE PRECISION TRANSMIT
          SPACE  1
 GEFMD    ARMAC  GEFMC,2,0,2       GENERAL EXTERNAL FUNCTION MACRO
                                   DESCRIPTOR ('GEFMD' PARAMETERS:  
                                   'IH' OF FUNCTION, 'IH' OF APLIST)
          SPACE  1
BEFMD     ARMAC  BEFMC,0,0,1       BASIC EXTERNAL FUNCTION MACRO
  
 APLMD    ARMAC  APLMC,1,0,0 APLIST MACRO DESCRIPTOR
          SPACE  1
TSMAC     ARMAC  TSMACC,1,1,1    TEMPORARY STORE MACRO
  
 EXPIN    ARMAC  M.EXM,2,2,0       INLINE EXPONENTIAL EVALUATION MACRO
  
* 
*         OTHER CONSTANT DATA 
 JNEXTE   EQ        NEXTE 
* 
*     OPSTACK CODES:  
* 
 MLTEOP   VFD       2/1,10/MLTOP,48/7   * 
 UMIOP    VFD    2/1,10/UMOP,48/6       U-
 INTEDVD  VFD       2/1,10/DVDORD,48/7  INT DVD FOR =* HEIRARCHY
 MLTDOP   VFD    2/1,10/MLTSOP,48/9     */
 LPSUB    VFD    2/1,10/22,48/0         (S
 ARGLP    VFD       2/1,10/21,48/0      (A
 CMASUB   VFD    2/1,10/23,48/1,2/1,10/24,48/1    ,S1 AND ,S2 
 ARGCMA   VFD    2/1,10/25,48/1         ,A
 RMIOP    VFD       2/1,10/RMINOC,48/6
 SUBRLP   VFD       2/1,10/32,48/0  (SUBR ARG LIST
          EJECT 
*** 
*         XPNMT:HOLDS THE NAMES OF THE EXPONENT FUNCTIONS FOR CALL BY 
*     NAME IN ORDER OF LOW BASE FIRST, THEN LOW POWER FIRST.
*         CALL BY VALUE NAME IS OBTAINED BY ADDING -.- TO END OF NAME.
*     THIS IS DONE BY THE END PROC FOR ALL NAMES IN SYMTAB WITH BASIC 
*     EXTERNAL FLAG.
*     AN ENTRY WITH B48 NON-ZERO IS A NON-ASA COMBINATION.
* 
  
 TYPEXT   EQU    P.TYP-P.EXT
 EXTARG   EQU    P.EXT-P.FARG      WORD B BITS SET FOR EXP FUN
 WB.EXP   VFD    L.TYP/T.CGS,TYPEXT/1,EXTARG/2,P.FARG/0 
  
 XPNMT    EXPON  INTEGER,ANSI,I**J
          EXPON  REAL,NONANSI,I**X
          EXPON  DOUBLE,NONANSI,I**D
          EXPON  COMPLEX,NONANSI,I**Z 
          EXPON  REAL,ANSI,X**I 
          EXPON  REAL,ANSI,X**Y 
          EXPON  DOUBLE,ANSI,X**D 
          EXPON  COMPLEX,NONANSI,X**Z 
          EXPON  DOUBLE,ANSI,D**I 
          EXPON  DOUBLE,ANSI,D**X 
          EXPON  DOUBLE,ANSI,D**D 
          EXPON  COMPLEX,NONANSI,D**Z 
          EXPON  COMPLEX,ANSI,Z**I
          EXPON  COMPLEX,ILLEGAL,C**R 
          EXPON  COMPLEX,ILLEGAL,C**D 
          EXPON  COMPLEX,ILLEGAL,C**C 
*     END OF XPNMT (ALWAYS 16 WDS LONG) 
* 
 ROUNDTBL ROUND  -,MAC+27,RSUB     REAL SUBTRACT
          ROUND  -,MAC+30,CRSUB    COMPLEX SUBTRACT 
          ROUND  +,MAC+31,RADD     REALL ADD
          ROUND  +,MAC+34,CRADD    COMPLEX ADD
          ROUND  *,MAC+35,RMLT     REAL MULTIPLY
          ROUND  *,MAC+38,CRMLT    COMPLEX MULTIPLY 
          ROUND  /,MAC+39,RDIV     REAL DIVIDE
          ROUND  /,MAC+42,CRDIV    COMPLEX DIVIDE 
          ROUND  -,MAC+45,RRSUB    REAL REVERSE SUBTRACT
          ROUND  -,MAC+48,CRRSUB   COMPLEX REVERSE SUBTRACT 
          ROUND  /,MAC+49,RRDIV    REAL REVERSE DIVIDE
          ROUND  /,MAC+52,CRRDIV   COMPLEX REVERSE DIVIDE 
          DATA   -1                END OF TABLE 
          TITLE  INTRINSIC FUNCTION TABLE AND MACROS
**        MAX/MIN INTRINSIC FUNCTION MACRO DESCRIPTORS
  
MXINT     ARMAC  MXMNMC+0,0,3,0 
MXREL     ARMAC  MXMNMC+1,0,3,0 
MXDBL     ARMAC  MXMNMC+2,0,6,0 
MNINT     ARMAC  MXMNMC+3,0,3,0 
MNREL     ARMAC  MXMNMC+4,0,3,0 
MNDBL     ARMAC  MXMNMC+5,0,6,0 
          SPACE  1
INTREL    ARMAC  MCHMCB+0,0,2,0 
RELINT    ARMAC  MCHMCB+2,0,2,0 
NCHSGL    DATA   -1 
NCHDBL    EQU    NCHSGL 
  
*         ARLIST DESCRIPTORS FOR SOME SPECIAL INLINE FUNCTIONS
  
 MD.LOCF  EQU    0                 NO MACRO DESCRIPTOR
 MD.MOD   ARMAC  M.MOD,0,3,0
 MD.MODP2 ARMAC  M.MODP2,1,2,0
 MD.SHIFT ARMAC  M.SHIFT,0,3,0     VARIABLE SHIFT 
 MD.COMPL ARMAC  M.COMPL,0,2,0     BOOLEAN COMPLEMENT 
 MD.MASK  ARMAC  M.MASK,0,2,0      VARIABLE MASK
 MD.MASKC ARMAC  M.MASKC,1,1,0     CONSTANT MASK
  
 MD.CSFT  ARMAC  M.CSHFT,1,2,0     CONSTANT LEFT SHIFT
          ARMAC  M.CSHFT+1,1,2,0     CONSTANT RIGHT SHIFT 
 MD.RANF  ARMAC  M.RANF,0,1,1      RANF MACRO DESCRIPTOR
  
*         VARIABLE ARG INTRINSIC FUNCTION MACRO DESCRIPTORS 
  
 MD.AND   ARMAC  M.AND,0,3,0       BOOLEAN AND
 MD.OR    ARMAC  M.OR,0,3,0        BOOLEAN OR 
 MD.XOR   ARMAC  M.XOR,0,3,0       EXCLUSIVE OR 
          EJECT 
*** 
*         INTFTB - INTRINSIC FUNCTION TABLE 
* 
*         FORMAT: 
*                WORDS 1 AND 2 - WORDS A AND B OF SYMBOL TABLE ENTRY
*                WORD 3 -- ARGUMENT TYPE WORD (TYP N = ACTUAL TYPE+1 ) *
*                   VFD    6/TYP1,6/TYP2,...,6/TYP10                   *
*                WORD 4 - "ARLIST" MACOUT DESCRIPTOR OR FLAG AND
*                POINTER TO SUCH IF FUNCTION IS SPECIAL CASED IN ARGP1RT
* 
          SPACE  1
INTFTB    BSS    0               BEGINNING OF INTRINSIC TABLE 
ABS       INTRIN REAL,(REAL),IFMCB+00 
IABS      INTRIN INTEGER,(INTEGER),IFMCB+00 
DABS      INTRIN DOUBLE,(DOUBLE),IFMCB+02 
AINT      INTRIN REAL,(REAL),IFMCB+03 
INT       INTRIN INTEGER,(REAL),IFMCB+04
IDINT     INTRIN INTEGER,(DOUBLE),IFMCB+05
AMOD      INTRIN REAL,(REAL,REAL),IFMCB+06
MOD       INTRIN INTEGER,(INTEGER,INTEGER)
FLOAT     INTRIN REAL,(INTEGER),IFMCB+08
IFIX      INTRIN INTEGER,(REAL),IFMCB+09
SIGN      INTRIN REAL,(REAL,REAL),IFMCB+10
ISIGN     INTRIN INTEGER,(INTEGER,INTEGER),IFMCB+10 
DSIGN     INTRIN DOUBLE,(DOUBLE,DOUBLE),IFMCB+12
DIM       INTRIN REAL,(REAL,REAL),IFMCB+13
IDIM      INTRIN INTEGER,(INTEGER,INTEGER),IFMCB+14 
SNGL      INTRIN REAL,(DOUBLE),IFMCB+15,RENAME
REAL      INTRIN REAL,(COMPLEX),IFMCB+16,RENAME 
AIMAG     INTRIN REAL,(COMPLEX),IFMCB+17,RENAME 
DBLE      INTRIN DOUBLE,(REAL),IFMCB+18,RENAME
CMPLX     INTRIN COMPLEX,(REAL,REAL),IFMCB+19,RENAME
CONJG     INTRIN COMPLEX,(COMPLEX),IFMCB+20,RENAME
AND       INTRIN OCTAL,(),MD.AND,NCHSGL,,ANY
OR        INTRIN OCTAL,(),MD.OR,NCHSGL,,ANY 
XOR       INTRIN OCTAL,(),MD.XOR,NCHSGL,,ANY
COMPL     INTRIN OCTAL,(ANY)
AMAX0     INTRIN REAL,(),MXINT,INTREL,,INTEGER
AMAX1     INTRIN REAL,(),MXREL,NCHSGL,,REAL 
MAX0      INTRIN INTEGER,(),MXINT,NCHSGL,,INTEGER 
MAX1      INTRIN INTEGER,(),MXREL,RELINT,,REAL
DMAX1     INTRIN DOUBLE,(),MXDBL,NCHDBL,,DOUBLE 
AMIN0     INTRIN REAL,(),MNINT,INTREL,,INTEGER
AMIN1     INTRIN REAL,(),MNREL,NCHSGL,,REAL 
MIN0      INTRIN INTEGER,(),MNINT,NCHSGL,,INTEGER 
MIN1      INTRIN INTEGER,(),MNREL,RELINT,,REAL
DMIN1     INTRIN DOUBLE,(),MNDBL,NCHDBL,,DOUBLE 
SHIFT     INTRIN OCTAL,(ANY,INTEGER)
MASK      INTRIN OCTAL,(INTEGER)
LOCF      INTRIN INTEGER,(ANY)
RANF      INTRIN REAL,(ANY) 
 L.INFT   EQU    *                 LWA+1 OF BASIC INTRINSIC FUNCTION TB 
  
*         START OF EXTENDED INTRINSIC FUNCTION TABLE
*         THE BELOW FUNCTIONS ARE COMPILED INLINE ONLY WHEN 
*         THE "SPP" OPTION IS SELECTED ON THE CONTROL CARD
  
IFTHEN    INTRIN OCTAL,(LOGICAL,ANYSNGL,ANYSNGL),M.IFTHEN 
COUNT     INTRIN INTEGER,(ANYSNGL),M.COUNT
 SETX     INTRIN INTEGER,(ANYSNGL),M.SXKXJ
UNPEXP    INTRIN INTEGER,(ANYSNGL),M.UPE
UNPCOE    INTRIN OCTAL,(ANYSNGL),M.UPC
PACK      INTRIN OCTAL,(ANYSNGL,ANYSNGL),M.PACK 
DMULT     INTRIN OCTAL,(ANYSNGL,ANYSNGL),M.DMULT
NORM      INTRIN REAL,(ANYSNGL),M.NORM
NORMC     INTRIN OCTAL,(ANYSNGL),M.NORMC
FADD      INTRIN REAL,(REAL,REAL),M.FADD
RADD      INTRIN REAL,(REAL,REAL),M.RADD
FSUB      INTRIN REAL,(REAL,REAL),M.FSUB
RSUB      INTRIN REAL,(REAL,REAL),M.RSUB
 #T       IFNE   TEST,0 
 SHSNGL   INTRIN REAL,(DOUBLE),IFMCB+17 
 DBLEE    INTRIN DOUBLE,(REAL,REAL),IFMCB+19
 FMULT    INTRIN REAL,(REAL,REAL),M.FMULT 
 RMULT    INTRIN REAL,(REAL,REAL),M.RMULT 
 FDIV     INTRIN REAL,(REAL,REAL),M.FDIV
 DADD     INTRIN REAL,(REAL,REAL),M.DADD
 DSUB     INTRIN REAL,(REAL,REAL),M.DSUB
 RNORM    INTRIN REAL,(REAL),M.RNORM
 DSUMH    INTRIN DOUBLE,(DOUBLE,DOUBLE),M.DSUMH 
 DDIFH    INTRIN DOUBLE,(DOUBLE,DOUBLE),M.DDIFH 
 DDIVH    INTRIN DOUBLE,(DOUBLE,DOUBLE),M.DDIVH 
 DMULH    INTRIN DOUBLE,(DOUBLE,DOUBLE),M.DMULH 
 BOOL     INTRIN OCTAL,(ANYSNGL),M.BOOL 
 #T       ENDIF 
 L.INFTE  BSSZ   1                 LWA+1 OF EXTENDED INTRINSIC FUNCTION 
*                                  TABLE
          SPACE  3
 STBASE   DATA     -1         <0 OR HOLDS ORDL OF START OF EXPONENT 
*   BASE EVALUATION IN ARLIST.  SEE FILE DESCRIBING STBASE USE. 
 FF       DATA   -1           FLIP-FLOF FLG FOR *-OP=-1 IF NOT TO POP 
 LASTR    DATA   0            HOLDS ADR OF LAST ARLIST ENTRY
 EMODE    DATA   1            EXPRESSION (TRANSLATION) MODE. INDICATES
*         THE TYPE OF PART NOW BEING TRANSLATED. =4,2,1 IF IN SUBSCRIPT,
*         ARGUMENT, OR NORMAL MODE.  NEEDED FOR CORRECT TREATMENT OF
*         COMMAS, AND ARRAY REFERENCES. 
          SPACE  3
          USE       /STSORD/  STATE.TEMP.STO.ORD  (I=1) 
 STSORD   BSS       1        INITIALIZED BY PS1CTL FOR EACH STATEM. 
          USE       /CLNFO/   CALL INFO 
 SUBFWA   BSS       1         ADDRESS OF SUBR NAME ENTRY IN SYMTAB
 SUBH     BSS       1         H ORDL OF SUBR NAME 
 ARGCNT   BSS       1         NO.OF ARGS IN LIST
 NARGSF   BSSZ      1         NON ZERO IF NO ARG LIST 
 SUBNAME  BSS       1         NAME OF SUBR IN ELIST FORM. SET BY CALL.
 ARLPT    ENTRY. 0                 ARLIST POINTER ( NUMBER OF WORDS ) 
          USE       0 
          USE    // 
 DEBUG    BSS    1            USED AS DEBUG BASE ADDRESS
          USE    *
  
          ENTRY   DBGEXT
 DBGEXT   BSS    0           SET DEBUG EXTERNAL BITS
          VFD     4/T.CGS 
          POS     P.EXT+1 
          VFD     1/1,*P/0
          TITLE 
          TITLE              EXTERNALS
*     EXTERNAL ROUTINES 
          EXT    O.GCON,FSTEX,VALUE.
          EXT    DOFLAG 
          EXT       ERPRO 
          EXT       CBNFLG
          EXT       PH2RETN 
          EXT       SYMBOL
          EXT       ASAER 
          EXT       CONVERT 
          EXT       ASFDEF
          EXT       ASFREF
          EXT       DOCALL
          EXT       DODEF 
          EXT       ERPROI
          EXT       DOGOOF
          EXT       IGCALL
          EXT       ST. 
          EXT       FP. 
          EXT       ALLARR
          EXT    ALLCALL
          EXT       ALLFUNC 
          EXT       CON.
          EXT       TRACEL
          EXT       LABEL.
          EXT       DFLAG 
          EXT       D.SAASI 
          EXT    BEFTB,L.BEFTB
          EXT       L.IOLST,O.IOLST 
  
          TABLES CON,ARLST
          SPACE  3
SLBMD     ARMAC  0,0,3,0         SINGLE LOAD TEMPLATE 
                                   'SLBMD' IS USED FOR VARIOUS MACROS 
                                   THAT USE UP TO THREE R-PARAMETERS
                                   ONLY.
          SPACE  1
DLBMD     ARMAC  0,0,6,0         DOUBLE LOAD
                                   'DLBMD' IS THE DOUBLE WORD ANALOGY 
                                   OF 'SLBMD'.
          SPACE  1
          TITLE                  N E X T E :  NEXT ELEMENT CONTROL
************************************************************************
*                                                                      *
*                N E X T E :  NEXT ELEMENT CONTROL                     *
*                                                                      *
*              'NEXTE' BEGINS THE CYCLE OF PROCESSING THE NEXT E-LIST  *
*         ELEMENT.  THE APPROPRIATE PROCESSOR FOR THE NEXT E-LIST      *
*         ELEMENT IS JUMPED TO AFTER THE FOLLOWING INFORMATION HAS     *
*         BEEN SET:                                                    *
*                                                                      *
*                REGISTERS --    B1 = ADDRESS OF THIS E-LIST ELEMENT   *
*                                B2 = OP CODE OF THIS E-LIST ELEMENT   *
*                                B4 = OP CODE OF NEXT E-LIST ELEMENT   *
*                                X1 = THIS E-LIST ELEMENT              *
*                                X2 = NEXT E-LIST ELEMENT              *
*                MEMORY --       'OP'     = THIS E-LIST ELEMENT        *
*                                'EPOINT' = ADDRESS OF NEXT E-LIST     *
*                                           ELEMENT                    *
*                                                                      *
************************************************************************
          SPACE  1
NEXTE     SA3    EPOINT 
          SA1    X3 
          BX7    X1 
          UX0    X1,B2
          SX6    X3-1 
          SA2    X6 
          SA6    A3 
          SA7    OP 
          SB1    X3 
          UX3    X2,B4
          SX6    B4 
          SA6    BSAV              SAVE B-FOUR
          JP     B2+EJTB
  
 EJTB     BSS    0
          LOC    0
          EQ        CON       CON 
          EQ        ID        ID
          EQ        RTPRN     ) 
          EQ        COMMA     , 
          ZR        CMPARE    EOS (COMPARE OP WITH OS)
          EQ        EQSIGN    = 
          EQ        LTPRN     ( 
          EQ        SSERR4    .OR.  (FIRST EXPLICIT OPERATOR) 
          EQ        SSERR4    .AND. 
          EQ        SSERR2    .NOT. 
          EQ        SSERR5    .LE.
          ZR        SSERR5    .LT.
          ZR        SSERR5    .GE.
          ZR        SSERR5    .GT.
          ZR        SSERR5    .NE.
          ZR        SSERR5    .EQ.
          EQ        MINUS     - 
          EQ        PLUS      + 
          ZR        MULTOP   *
          ZR        DIVIOP   /
          ZR        SSERR7    **
          ZR        RJWRP     21  ROGER WANGER,S RIGHT PARENS 
          LOC    *O 
* 
 LOWOP    EQU    EL.OR
          TITLE  DEBUG INFORMATION CELLS
          EJECT 
*** 
*         DEBUG INFORMATION WORDS AND TEMPORARIES 
* 
          ENTRY  DBGAPL 
 DBGAPL   BSSZ   5                 TABLE TO HOLD ARG LIST INFORMATION 
  
 RL1TS    BSS    1                 TEMP STORAGE FOR RL1 
 RL2TS    ENTRY. 0
 LASTRTS  BSS    1                 TEMP STORAGE FOR LASTR 
  
 FTRFLG   BSS    1                 FUNCTION TRACE FLAG
 TRCFLG   BSS    1                 TRACE FLAG FOR IF PROCESSOR
 WLSTR    BSS    1                 WAS LAST STORE TRACED FLAG 
  
 P.FCS    EQU    30                FREQUENCY COUNT
 L.FCS    EQU    9
 P.RO     EQU    27                RELATIONAL OPCODE
 L.RO     EQU    3
 P.CONST  EQU    30                CONSTANT TYPE, FLAG, ORDINAL 
 L.CONST  EQU    18 
 P.LINKI  EQU    12                ORDINAL FIELD FOR LINKED LIST
 P.COV    EQU    13                CONSTANT/VARIABLE FLAG BIT 
 P.GCF    EQU    14                GLOBAL CONSTANT FLAG BIT 
 L.CORD   EQU    14                CONSTANT TABLE ORDINAL FIELD 
 P.LINK   EQU    42                ADDRESS FIELD FOR LINKED LIST
 P.USED   EQU    45                USED BIT FOR RLIST MACROS
  
 DV.STO   EQU    5B                DEBUG VALUE FOR STORE CHECKING 
 DV.FUN   EQU    7B                DEBUG VALUE FOR FUNC TRACING 
 DV.CLL   EQU    13B               DEBUG VALUE FOR CALL TRACING 
 DV.ARR   EQU    11B               DEBUG VALUE FOR SUBSCRIPT CHECKING 
 DV.AAS   EQU    15B               DEBUG VALUE FOR SUBSCRIPT AND STORE
                                     CHECKING 
          TITLE  CON - CONSTANT PROCESSING
          EJECT 
*     CON IF CONST IN E-LIST
 CON      SB2    EL.= 
          SB3    EL.ID
          EQ  B4,B2,SSERR1    IF CON FOLLOWED BY =
          LE  B4,B3,SSERR1    IF CON FOLOWD BY CON OR NAME
          SB3    EL.( 
          EQ     B4,B3,IDER2       ERROR, CONSTANT FOLLOWED BY (
          SA1    B1 
          SB1      -1 
          RJ        CONVERT 
          BX6    X1 
          BX7    X2 
          SA6       CONST 
          SA7       CONST+1 
          SA1       EPOINT
          SB1    X1+1 
          SA1    B1           IS CONST TINT - 
          MX0       60-3
          LX1       15
          BX6   -X0*X1
 CON4     SX3    X6-T.HOL 
          NZ     X3,CON4A     IF CONST NOT TYPE HOL 
          SA1    B1-1 
          SA2    B1+1 
          UX0    B2,X2             E - 1
          SB3    EL.MINUS 
          UX0    B4,X1             E + 1
          SB5    EL.S)
          GE  B2,B3,CON4B     IF HOL CONST OPD
          EQ     B4,B5,CON4D       IF SPECIAL RIGHT PAREN 
          GE  B4,B3,CON4B     11 11 
          SA1       TYPE
 CON4D    BSS    0
          SX2    X1-19
          ZR     X2,CON4A     IF HOL CON IN CALL STATE
          USASDM ERMSG38         HOLERITH CONSTANT OTHER THAN CALL ARG
          ZR        CON4C 
 CON4B    IDM       ERMSG39   HOL CON OPD 
 CON4C    SX6    T.HOL
 CON4A    BSS       0 
          SA1    OSPTR
          SB2    EL.SLASH 
          SA2    X1+OPSTAK
          UX0    B3,X2
          NE     B2,B3,CON2  IF OP BEFORE CONST NOT / 
          SA1    CONST
          SA2    B1-1 
          SB2    X6-T.LOG 
          ZR     B2,MOP1     IF LOGICAL CONST, ERROR
          SB2    X6-T.CPLX
          ZR     B2,CON4E    IF COMPLEX CONST, CANT USE SIMPLE /0 TEST
          ZR     X1,CON7     IF DIVIDE BY CONST ZERO, ERROR 
          EQ     CON2 
 CON4E    BSS    0
  
 XYZ      IFEQ   NOINVERT,0 
  
*         ONLY COMPLEX CONSTANT DIVISORS CAN BE INVERTED AT THIS POINT. 
*         / CHANGED TO *. OTHER TYPES DEPENDS ON MODE OF OPERATION. 
          UX0    B4,X2
          SB5    EL.DSTR
          EQ     B4,B5,CON2  IF ** AFTER CONST
  
*     CON4F IF /COMPLEX CONST 
*     (C+DI)**-1=(C/(C**2+D**2)+(-D/C**2+D**2)I)
  
*CON4F    BSS    0
          SA2    CONST+1
          FX3    X1*X1               C**2 
          FX4    X2*X2               D**2 
          FX5    X3+X4
          NX6 B0,X5                  C**2+D**2
          ZR     X6,CON7      IF DIVISION BY ZERO 
          FX1    X1/X6               C/(C**2+D**2)
          MX0       0 
          FX3    X0-X2              -D
          FX2    X3/X6              -D/(C**2+D**2)
          SB1       2 
          RJ        CONVERT   B1 NEED NOT BE RESET TO EPOINT+1
          SX6    T.CPLX 
          RJ     CFETCH 
          SA1       MLTEOP    CHANGE OM TO *
          SA2       OSPTR 
          SA3    X2+OPSTAK
          MX6       30
          LX6       18+30 
          BX3    X6*X3        SAVE ALL OF OM EXCEPT OP CODE AND HEIRCHY 
          BX6    X3+X1
          SA3       FF        INVERT FF 
          SA6    X2+OPSTAK
          BX7    -X3
          SA7       FF
          ZR        NEXTE 
* 
*     CON2 IF CONST IN E NOT PRECEDED BY /.  ENTER WITH TYPE IN X6. 
 XYZ      ENDIF 
 CON2     SA6       TYPEWD
          SA1       EMODE     SEE IF CONST IS STAND ALONE ARG 
          SX2    X1-2 
          NZ     X2,CON2F     IF NOT IN ARG MODE
          SA1       EPOINT
          SA2    X1           E+1 
          SA3    X1+2         E-1 
          UX0 B2,X2 
          SB4       LOWOP 
          GE  B2,B4,CON2F     IF NOT STD ALONE ARG
          UX0 B2,X3 
          GE  B2,B4,CON2F     ' 
*     HERE IF STAND ALONE CONST ARG.  FORCE LOAD FROM CONLIST.
*     -UNLESS AN INTR FUNC ARG
          SA1       FNAD
          SA2    X1-1 
          LX2    59-P.INF 
          PL     X2,CON2AA   IF NOT IN AN INTRINSIC FUNCTION ARGLIST
          SA1    =7LLOCF
          SA2    A2+1 
          BX1    X1-X2
          AX1    18 
          NZ     X1,CON2F    IF NOT LOCF
 CON2AA   SB1    2
          SA1       CONST 
          SA2       CONST+1 
          SX3    X6-T.DBL 
          ZR     X3,CON2D     IF DBL
          SX3    X6-T.CPLX
          ZR     X3,CON2D     IF CPX
          SX3    X6-T.HOL 
          ZR     X3,CON2G     IF HOL
          SB1       1 
          ZR        CON2D     IF REAL,INT OR OCT
 CON2F    SX5    X6-T.HOL 
          ZR     X5,CON2H          IF HOL 
 CON2F1   SX1    X6-T.DBL 
          ZR     X1,CON2A     CON2A IF DBL WD CONST TO LOAD 
          SX1    X6-T.CPLX
          ZR     X1,CON2A 
          SA1       CONST 
          ZR     X1,CON2B     IF CONST=0 OR -0
          MI     X1,CON2D1   IF CONSTANT .LT. 0 
          MX0       60-17     B17 WOULD BE EXTENDED ON AN SXI 
          BX5    X0*X1
          ZR     X5,CON2C     IF CON < 400000B
 CON2E    SB1       1 
 CON2D    RJ        CONVERT 
          SA2       TYPEWD
          BX6    X2 
          RJ        CFETCH
          ZR        NEXTE 
  
*         SPECIAL-CASE CONSTANT VALUE OF -1, AS WILL BE PRODUCED BY 
*         LOGICAL CONSTANT .TRUE. . 
  
 CON2D1   NZ     X6,CON2E    IF TYPE .NE. T.LOG 
          SA3    MD.MASKC 
          SX6    59 
          SA6    PARAMS+1 
          SA2    NARN 
          MX5    0           TYPE = T.LOG 
          BX7    X2 
          SA7    PARAMS 
          SX7    X2+1 
          SA7    A2 
          RJ     MACOUT      ISSUE MASK 59 MACRO
          MX0    1
          LX0    1+47 
          SA2    X7 
          BX6    X0+X2
          SA6    A2          SET CONSTANT BIT 
          EQ     NEXTE
  
 CON2G    SA2       EPOINT    GET E FOR CONST IN X1.
          SA1    X2+1 
          SB1    B0 
          ZR        CON2D 
  
*         HERE IF HOLLERITH CONSTANT
 CON2H    SA3    IXFNFG 
          ZR     X3,CON2F+1        IF NOT IN I/O LIST 
          SA4    EMODE
          SX3    X4-2 
          ZR     X3,CON2F1         IF IN ARGUMENT MODE
          SA1    OSPTR
          SB4    XFLP 
          SA2    OPSTAK+X1
          UX3    B2,X2
          NE     B2,B4,CON2F1      IF TOP OF STACK NOT A IXFN ( 
          SA2    EPOINT 
          SA1    X2                E+1
          SB4    LOWOP
          UX0    B2,X1
          SA3    X2+2              E-1
          GE     B2,B4,CON2F+1     NOT STAND ALONE
          UX0    B3,X3
          GE     B3,B4,CON2F+1
          SA1    X2+1              ELIST ITEM FOR CONSTANT
          BX0    X1 
          SB1    B0 
          SA3    LDFLAG      LIST-DIRECTED-I/O FLAG 
          LX0    21          CHAR. STRING INDICATOR IN B59
          BX4    X3*X0
          SX3    6           TYPE IF CHAR. STRING 
          LX0    21 
          SX5    X0          CHAR. COUNT OF HOL STRING
          MI     X4,CON2H1   IF CHAR. STRING IN LIST-DIRECTED IOLIST
          SX4    9           ROUNDING FACTOR
          SA2    =0.1000000001P48 
          IX6    X5+X4
          PX0    X6 
          SX3    2           TYPE FOR HOL CONSTANT
          FX4    X0*X2       CONVERT TO WORD COUNT
          SX5    X4 
 CON2H1   LX5    6
          IX6    X3+X5
          LX6    36          18/COUNT,6/TYPE,36/0 
          SA6    HOLCON 
          RJ     CONVERT           CONVERT AND ENTER IN TABLE 
          SA2    HOLCON 
          SX0    X1          (X1)=12/0,18/CA,18/0,12/IH OF HOL. ENTRY 
          AX1    12 
          IX3    X1+X0       24/0,18/CA,18/IH 
          BX7    X2+X3
          SA7    A2                PACKED DATA WORD 
          EQ     NEXTE
* 
*     CON2A IF DBL WD CONST TO LOAD 
 CON2A    SA1       CONST 
          SB1       2 
          SA2       CONST+1 
          NZ     X2,CON2D    IF LOWER HALF " 0
  
          RJ     DLDSU       SETUP MXI 0/MXI 0 OR  LD CON.+CA/MXI 0 
          SA5    TYPEWD 
          RJ     MACOUT 
          SA1    RL2
          SA3    X1 
          MX0    1
          LX0    1+47        SET CON BIT FOR MACRO
          BX7    X0+X3
          SA7    A3 
          EQ     NEXTE
  
*         CON2B - CON = 0 OR -0 
  
 CON2B    SA2       NARN      SET UP FOR CALL TO MACOUT 
          BX6    X2 
          SX7    X2+1 
          SA6       PARAMS
          SA7       NARN
          SA5    TYPEWD 
          SA3    MZMD 
          MI     X1,CON2B1   IF -0
          SA3    ZRMD 
 CON2B1   RJ        MACOUT
          SA1    X7           TURN ON CONST BIT 
          MX0       1 
          LX0       48
          BX6    X1+X0
          SA6    X7 
          ZR        NEXTE 
* 
*     CON2C IF CON< 400000B 
 CON2C    SX2    X6-T.INT          WOULD NEED EXTRA COMPILER CODE FOR 
*                  OTHER THAN INT, OCT, OR HOL. 
          ZR     X2,CON2C1
*                NOW BSAV IS USED AS A FLAG TO STCON
*                 BSAV = 773B IMPLIES  TREAT THIS CONST AS NORMAL 
          SX2    X6-T.OCT 
          ZR     X2,CON2C1
          SX2    X6-T.HOL 
          NZ     X2,CON2E 
 CON2C1   BX5    X1 
          SX6    773B 
          SA6    BSAV 
          RJ        STCON 
          SA1       TYPEWD    SET TYPE OF CONST 
          SB2    X1 
          PX6    B2,X6
          SA6    A6 
          ZR        NEXTE 
  
 BSAV     BSSZ   1
  
 CON7     EERR   ERMSG32     ILLEGAL DIVIDE BY CONSTANT ZERO
          TITLE              ID - IDENTIFIER PROCESSING 
 ID.E34   EERR   ERMSG34           ILLEGAL USE OF SUBPROGRAM NAME 
  
*     ID IF E IS IDENTIFIER. FROM EJTB.  X1 HOLDS E.
 ID       SB2    EL.ID
          SB3    EL.DSTR
          NE     B4,B3,ID0
          SA3    ARLPT
          BX6    X3 
          SA6    STBASE            SAVE ADDRESS OF ** BASE
 ID0      BSS    0
          SPACE  1
          SB7       ID1       SET RETURN-FROM-SYMBOL ADR
          GT     B4,B2,SYMBOL      IF NAME NOT FOLLOWED BY NAME OR CONS 
          EERR      ERMSG6
 ID1      EQ     ID.F        FIRST OCCURANCE
          EQ     ID2               PREVIOUS OCCURANCES
  
*         FIRST OCCURANCE - CHECK SETTING OF DEBUG BITS AND ADD TYPE
  
 ID.F     ZR     X7,ID.F2          IF NO PREVIOUS MENTION IN DEBUG STMTS
          SA5    EPOINT 
          SA4    X5 
          SB4    EL.( 
          UX3    B3,X4
          MX0    0
          NE     B3,B4,ID.F1       IF NEXT IS NOT A ( 
          SX0    B5                ASSUME A FUNCTION REFERENCE
 ID.F1    CALL   CFO               CHECK SETTING OF DEBUG BITS
 ID.F2    IX2    X7+X2             ADD DEBUG BITS 
          BX6    X6+X2             AND TYPE 
          SA6    A2 
          SB7    B0                SET B7 TO 0 TO FLAG THE FIRST OCCURAN
          LX2    X6 
          EQ     ID3
  
 ID2      NE     B1,B5,ID3         IF NOT ORDINAL 1 
          SA3    VALUE. 
          ZR     X3,ID.E34         IF NOT A FUNCTION SUBPROGRAM 
          SB1    X3 
          SB2    B1+B1
          SA1    A0-B2             WORD A OF VALUE. 
          SA2    A1-B5             WORD B 
  
 ID3      SA5    REFSELCT        (REFERENCE MAP SELECTION--LOCAL COPY SO
                                   THAT FOR AN 'IXFN' CALL FOR LWA+1
                                   'ARITH' WILL NOT ACCUMULATE ANY REFS)
          SX6    B1 
          SX7    A1 
          SA6    IDORDL            SAVE SYMTAB ORDINAL
          SA7    NAMFWA            ADDRESS OF WORD A OF SYMTAB ENTRY
          SA6    IDORDLTS 
          ZR     X5,IDREF3   IF NO LONG REFERENCE MAP 
          SX6    B7                (ALSO SAVE THE 'FIRST TIME SYMBOL
          SA4    EQCOUNT
          SA6    =SFIRSTFLG 
          PL     X4,IDREF        IF NOT FIRST IXFN ID GO TO !IDREF! 
          BX6    X6-X6
          SA6    A4 
          ADDREF B1,REFTYPE      ADD A REFERENCE OF THE TYPE PREVIOUSLY 
          ZR     IDREF2            DETERMINED BY THE CALLER.
 IDREF    SA5    PARLEVEL        IF THE PARENTHESIS LEVEL IS NON-ZERO OR
          BX0    X0-X0             IF ALL THE EQUAL SIGNS HAVE BEEN 
          IX1    X0-X5             PASSED, THEN THIS IS A REFERENCE 
          IX2    X0-X4             ENCOUNTERED FLAG') 
          BX3    -X2+X1 
          MI     X3,IDREF1         GO TO 'IDREF1' TO FLAG REFERENCE.
          SPACE  1               OTHERWISE IT IS A DEFINITION.
          ADDREF B1,DEF          NOTE THE DEFINITION
          ZR     IDREF2 
          SPACE  1
IDREF1    ADDREF B1,REF          NOTE THE REFERENCE 
 IDREF2   SA4    FIRSTFLG 
          SA3    NAMFWA 
          SA1    X3                WORD A 
          SA2    A1-B5             WORD B 
          SB7    X4 
 IDREF3   SA5    EPOINT          SET REGISTER B1 TO E+1 
          SB1    X5+1        RESTORE REGISTER B1 (POINSE TO NEXT E) 
          BX6    X1 
          LX7    X2 
          SA6    NAME              SAVE SYMTAB ENTRY
          SA7    A6+B5
          ZR     B7,NIT          IF FIRST TIME SYMBOL ENCOUNTERED 
**        X1,X6 -- WORD 1 OF SYMBOL TABLE ENTRY FOR NAME
**        X2,X7 -- WORD 2 OF SYMBOL TABLE ENTRY FOR NAME
  
*         PREVIOUS OCCURANCES 
  
          MX0    L.TYP
          BX3    X0*X2
          LX3    L.TYP
          SX4    X3-T.OCT-1 
          PL     X4,ID12           IF AN ILLEGAL TYPE 
  
          LX6    59-P.FUN 
          NG     X6,ID8A           IF A FUNCTION
          MX0    -L.LVL 
          LX2    -P.LVL 
          BX3    -X0*X2            OBTAIN LEVEL NUMBER OF VARIABLE
          LX2    P.LVL
          SX4    X3-3 
          ZR     X4,LEVEL          IF LEVEL 3 VARIABLE
 IDREF.3  LX6    P.FUN-P.DIM
          NG     X6,ARRAY          IF AN ARRAY
  
          SA3    B1-B5             E+1
          UX4    B2,X3
          SB3    EL.( 
          LX7    59-P.VAR 
          PL     X7,ID4            IF NO PREVIOUS USEAGE AS A VARIABLE
  
          NE     B2,B3,VR3         IF NOT A ( 
 IDER2    EERR   ERMSG2            SIMPLE VAR FOLLOWED BY ( 
  
 ID4      NE     B2,B3,VR4         IF NEXT IS NOT A ( 
          LX1    59-P.FP
          LX2    59-P.EXT 
          BX3    X1+X2
          NG     X3,ID6            IF F.P. OR EXT 
          SB7    ID5               NOT FOUND ADDR 
          RJ     BEFTLU            CHECK BASIC EXT FUN TBL
          EQ     ID10              IF FOUND 
  
*     ID5 IF NOT IN BASIC EXT. SEE IF IN INTRINSIC TBL
 ID5      SB7       ID6 
          RJ        IFTLU 
 ID10     SA1       NAME+1    SEE IF SAME TYPE
          BX2    X1-X5
          AX2    60-L.TYP 
          NZ     X2,ID6       IF NOT SAME TYPE
 ID8      SA1       NAME      HERE IF FUN INT OR BASIC.  ENTER INTO SYMT
          SA2       NAME+1    SAVE POINTERS 
          MX0    L.DIF
          LX0    1+P.AC 
          BX7    X0*X2             GET DEBUG BITS 
          MX0       60-12 
          BX1   -X0*X1
          BX2   -X0*X2
          BX5    X0*X5        IN CASE RNM FLAG ON (SOME INTR FUNCS) 
          BX6    X1+X4
          BX5    X5+X7             FUNC + DEBUG BITS
          BX7    X2+X5
          SA1       NAMFWA
          SA6    X1 
          SA7    X1-1 
          SX6    A4 
          SA6    TYADR             ADDRESS OF FUNCTION TABLE ENTRY
          EQ     FUNC 
 ID8A     LX2    59-P.LIB 
          MI     X2,ID8C           IF A BASIC EXTERNAL
          LX2    P.LIB-P.INF
          PL     X2,FUNC           IF NOT AN INTRINSIC FUNCTION 
          RJ     IFTLU
 ID8B     SX6    A4 
          SA6    TYADR             SAVE FUNCTION TABLE ADDRESS
          EQ     FUNC 
  
 ID8C     RJ     BEFTLU 
          EQ     ID8B 
  
*         FIRST OCCURANCE 
  
 NIT      SA3    B1-B5             E+1
          UX0    B2,X3
          SB3    EL.( 
          EQ     B2,B3,ID7         IF USED AS A FUNCTION
          SX0    B5 
          LX0    P.VAR
          BX7    X0+X2             SET VAR BIT
          SA7    A2 
          EQ     VR3
*     VR4 IF ID HAS ONLY APPEARED IN TYPE STATE. AND/OR DMY ARG LIST AND
*  NOT FOLLOWED BY L.P. 
*  OR IF 1ST APPEARANCE OF VARIABLE IS AS 1ST ELEMENT IN A REPLACEMENT
*  STATEMENT. (TYPE SET AT ARITH4)
 VR4      SA3       NAMFWA    ENTER VAR FG BIT IF NOT EXT PROC.NAME.
          MX0       1 
          SA2       NAME+1
          LX0    1+P.VAR
          BX6    X2+X0
          LX2    59-P.EXT          CHECK EXTERNAL BIT 
          NG     X2,FUNC      IF EXT PROCD NAME (MUST BE DMY ARG) 
          LX2    P.EXT-59 
          SA6    X3-1 
          ZR        VR3 
* 
*     ID7 IF 1ST APPEARANCE OF FUN NAME 
 ID7      SB7       ID9       SET NOT-FOUND ADR 
          RJ        BEFTLU
          ZR        ID8 
 ID9      SB7       ID6 
          RJ        IFTLU 
          ZR        ID8 
* 
*     ID6 IF ID IS GEN.EXT.FUN
 ID6      MX0       1         TURN ON EXT BIT IN SYMTAB ENTRY 
          LX0    1+P.EXT
          SA2       NAME+1
          SA3       NAMFWA
          BX6    X2+X0
          SA6       NAME+1
          SA6    X3-1 
          SA1       NAME      TURN ON FUN BIT 
          LX0    P.FUN-P.EXT
          BX7    X1+X0
          SA7    A6+1 
          LX6    59-P.FCALL 
          PL     X6,FUNC1    IF NOT ALSO USED AS SUBROUTINE 
          USASDM  E328       SAME NAME USED AS FUNCTION AND SUBROUTINE
          EQ     FUNC1
          EQ     FUNC1
  
**        LDVRB - OUTPUT LOAD FOR A VARIABLE
  
 VR3      MX7    0
          SB7       LDVRB1    LDVRB1 IF NOT EQUIVED 
          SA7       VCA       CLEAR 
          SA7    IDORDLTS+1 
          RJ        EQUIVR
          SA6       VCA       HERE IF EQUIVALECED 
          SA7       IDORDL
 LDVRB1   SA1       VCA 
          SB7    X1           CA
          SB6    B0           RF
          SA5    IDORDL       H 
          RJ        FETCH     OUTPUT NORMAL VARIABLE LOAD MACRO 
          EQ     NEXTE
  
 ID12     EERR      ERMSG49   FE: ILLEGAL OPD TYPE
 SSP      TITLE  SSP - STANDARD SUBSCRIPT PROCESSOR.
 ERMSG75  EQU    75          CONSTANT ARRAY REFERENCE OUT-OF-BOUNDS 
 LEV      OCTMIC P.LVL
 V.LEV3   EQU    3S"LEV"
  
 MVARS    EQU    2           VARIABLES ALLOWED IN TERM OF IXFN
 DCF      BSS    1           DOUBLE/COMPLEX FLAG
 TARLPT   BSS    1           TEMPORARY ARLIST POINTER 
 REFTEMP  BSS    1           TEMP CELL FOR ADDREF LOOP
 INC      CON    1           INCREMENT FOR ADDRESSING IXFN TERMS
 TEP      BSS    1           TEMP E-LIST POINTER
 NDIMS    BSS    1           ARRAY DIMENSIONALITY 
 OBR      BSS    1           OUT-OF-BOUNDS REF FLAG 
  
*         STORAGE BETWEEN O.TTS AND L.TTS IS INITIALIZED AT THE 
*         START OF EACH TERM OF A STANDARD SUBSCRIPT. 
  
 O.TTS    BSS    0
 ACT      BSS    1           ADDITIVE CONSTANT
 COMP     BSS    1           COMPLEMENT FLAG
 CONSTT   BSS    1           CONSTANT TEMP
 IDF      BSS    1           ID ENCOUNTERED FLAG
 PMF      BSS    1           PLUS-OR-MINUS-ENCOUNTERED FLAG 
 VAR      BSS    MVARS       VARIABLE IH,CA ARRAY 
 VARS     BSS    1           VARIABLE-IN-TERM ORDINAL 
 L.TTS    EQU    *-O.TTS
  
 MC       BSS    MVARS+1     MULTIPLICATIVE CONSTANTS 
  
*         FOLLOWING CELLS ARE INITIALIZED (TO ZERO) AT THE START
*         OF IXFN PROCESSING ONLY.
  
 TERM     BSS    1           CURRENT TERM WITHIN IXFN 
 NANSI    BSS    1           NON-ANSI IXFN FLAG 
 DAF      BSS    1           DEBUG ARRAYS CHECK FLAG
  
*         FORM BIT MASK OF E-LIST OP-CODES THAT ARE ELEMENTS OF 
*         STANDARD SUBSCRIPTS.
  
 EL.RP    EQU    EL.) 
 IMASK    BSS    0
          ECHO   2,P=(CON,ID,RP,COMMA,PLUS,MINUS,STAR)
          POS    60-EL.P
          VFD    1/1
          VFD    *P/0 
  
 ARRAY    SB5    1
          SA2    IDORDL 
          BX6    X2 
          SA6    SARORD      FOR SSP.NS 
          SA1    NAME+1      WORD B OF SYMTAB ENTRY FOR ARRAY 
          MX0    -L.DIMP
          LX1    -P.DIMP
          BX2    -X0*X1 
          SA3    DIM1 
          LX2    1
          SB2    X3+B5
          SA1    X2+B2       WORD 2 OF DIM ENTRY
          BX6    X1 
          SA6    SDIMIN      SAVE DIMENSION INFO
          SA1    EPOINT 
          LX6    3
          MX0    -3 
          BX7    -X0*X6 
          SA2    X1 
          SA7    NDIMS       NUMBER OF DIMENSIONS FOR THIS ARRAY
          UX0    B2,X2
          SB3    B2-EL.(
          NZ     B3,NSAN     IF NEXTE .NE. (
          BX6    X1 
          SA6    TEP         TEMP ELIST POINTER AT LEFT PAREN 
          SA1    X1-1 
          UX0    B4,X1       B4 = OC(NEXTE) 
          CALL   SSERR3      CHECK NEXTE SYNTAX FOR ( 
          SETZERO  O.TTS,L.TTS   INITIALIZE TERM-TEMP CELLS 
          MX7    0
          SA7    TERM        TERM = 0 
          SA7    NANSI       NANSI = 0
          SA7    DAF         DAF = 0
          SX6    B5 
          SA6    MC          MC(1) = 1
          SA6    A6+B5       MC(2) = 1
          SA6    A6+B5       MC(3) = 1
  
          SA1    =XDFLAG
          SA2    NAME+1      WORD B 
          ZR     X1,ARRAY1   IF NOT DEBUG MODE
          SA4    =XALLARR 
          MX0    -L.DIF 
          LX2    -P.DIF 
          BX3    -X0*X2 
          BX6    X3+X4
          SA6    DAF         .NE. 0 IF ANY DEBUGGING ON FOR THIS ARRAY
          LX2    P.DIF       RESTORE WORD B 
  
 ARRAY1   SA1    ARLPT       NEXT ARLIST ENTRY LOCATION 
          MX0    -L.TYP 
          LX2    -P.TYP 
          BX6    -X0*X2      ARRAY TYPE 
          SB7    X6-T.DBL 
          MX6    0
          MI     B7,ARRAY2   IF ARRAY TYPE .LT. T.DBLE
          GT     B7,B5,ARRAY2  IF ARRAY TYPE .GT. T.CPLX
          SX6    B5 
  
 ARRAY2   SA6    DCF         STORE DOUBLE/COMPLEX FLAG
          SA2    NDIMS
          LX3    X2,B5
          SX7    X1+5 
          IX5    X2+X3
          SA7    TARLPT      POINTS TO START OF TERM INFO 
          SX6    X5+6-ARLSZ  WORDS POSSIBLY REQUIRED = 3*NDIMS + 6
          IX2    X1+X6
          PL     X2,ARLOVER  IF INSUFFICIENT ROOM IN ARLIST 
 SSP0     EJECT 
*         MAIN LOOP FOR STANDARD SUBSCRIPT E-LIST CRACKING. 
  
 SSP0     SA5    TEP         E-LIST POINTER WITHIN SSP
          SA4    X5-1        TEP = TEP + 1
          UX1    B2,X4       B2 = OC(TEP) , X1 = ELIST(TEP) 
          SA3    A4-B5
          UX2    B4,X3       B4 = OC(TEP+1) , X2 = ELIST(TEP+1) 
          SX6    A4 
          SA3    IMASK
          SA6    A5          UPDATE TEP 
          LX4    B2,X3
          PL     X4,SSP.NS   IF ELIST(TEP) NOT STAND. SUB. ELEMENT
          SB3    B2-EL.MINUS
          MI     B3,SSP01    IF OC(TEP) .LT. EL.MINUS 
          SB2    B2-EL.MINUS+EL.COMMA+1 
  
 SSP01    JP     SSP.JT+B2
 SSP.JT   BSS    0
          LOC    EL.CON 
          EQ     PSC         OC(TEP) = EL.CON 
          EQ     PSI                   EL.ID
          EQ     PSR                   EL.) 
          EQ     PCO                   EL.COMMA 
          LOC    EL.MINUS 
          EQ     PSM                   EL.MINUS 
          EQ     PSP                   EL.PLUS
          EQ     PSS                   EL.STAR
          LOC    *O 
 PSC      SPACE  4,5
**        PSC - PROCESS SUBSCRIPT CONSTANTS.
  
 PSC      CALL   ECON 
          SA6    CONSTT 
          EQ     SSP0 
 ECON     SPACE  3,8
**        ECON- PROCESS E-LIST CONSTANTS FOR STANDARD SUBSCRIPT 
*         PROCESSING. 
* 
*         ENTRY  (X1) = ELIST FOR CONSTANT
* 
*         EXITS TO SSP.NS IF CONSTANT .GE. 1S17 OR IF IT IS NOT 
*         TYPE INTEGER OR OCTAL.
*         OTHERWISE, RETURNS THROUGH ENTRY POINT WITH (X6) = CONVERTED
*         CONSTANT. 
  
 ECON     ENTRY. *
          BX2    X1          X2 = X1 = ELIST
          LX2    15 
          MX0    -3 
          BX3    -X0*X2 
          SX7    X3-T.INT 
          SX4    X3-T.OCT 
          ZR     X7,ECON1    IF TYPE(CON) = T.INT 
          NZ     X4,SSP.NS   IF TYPE(CON) .NE. T.OCT
          SA7    NANSI
  
 ECON1    SB1    -B5
          CALL   CONVERT
          BX6    X1 
          AX1    17          CONSTANT IS POSITIVE 
          NZ     X1,SSP.NS   IF CON .GE. 1S17 
          SA5    COMP 
          ZR     X5,ECON     IF COMPLEMENT FLAG OFF 
          MX7    0
          BX6    -X6
          SA7    A5          TURN OFF COMPLEMENT FLAG 
          EQ     ECON 
 PSI      SPACE  4,8
**        PSI - PROCESS SUBSCRIPT ID/S. 
  
 PSI      SA3    VARS        NUMBER OF VARIABLES IN CURRENT TERM
          SB1    EL.( 
          EQ     B4,B1,SSP.NS  IF NEXTE IS LEFT PAREN.
  
*         FOLLOWING TEST IS NECESSARY TO PREVENT FILING A FUNCTION
*         AS VARIABLE IF FIRST OCCURANCE. 
  
          SX5    X3-MVARS 
          SX6    X3+B5
          PL     X5,SSP.NS   IF MORE VARIABLES IN TERM THAN ALLOWED 
          SA6    A3          VARS = VARS + 1
          SA6    IDF         FLAG ID ENCOUNTERED IN TERM
          SYMBOL
          IX5    X7+X2
          BX6    X5+X6
          SA6    A2          UPDATE WORD B
          LX2    X6 
          NE     B1,B5,PSI1  IF ORD .NE. 1
          SA3    =XVALUE. 
          ZR     X3,SSP.NS   IF NOT FUNCTION SUBPROGRAM 
          SB1    X3 
          SB2    B1+B1
          SA1    A0-B2
          SA2    A1-B5
  
 PSI1     SX6    V.FUN+V.DIM
          SX0    V.LEV3 
          BX4    X6*X1
          BX3    -X2*X0 
          SX0    B5 
          NZ     X4,SSP.NS   IF TYPE FUNCTION OR DIMENSIONED
          ZR     X3,SSP.NS   IF LEVEL = 3 
          LX0    P.VAR
          BX6    X0+X2
          LX2    59-P.EXT 
          MI     X2,SSP.NS   IF EXTERNAL
          SA6    A2          SET VAR BIT
          AX6    P.TYP
          SX3    X6-T.INT 
          SX6    B1 
          NZ     X3,SSP.NS   IF NOT INTEGER 
          SA3    VARS        NUMBER OF VARIABLES IN TERM
          SA6    X3+VAR-1    VAR(VARS) = IH 
          EQ     SSP0 
 PSR      SPACE  4,8
**        PSR - PROCESS SUBSCRIPT RIGHT PARENTHESIS.
  
 PSR      SA3    TERM 
          SX6    X3+B5
          SA6    A3          TERM = TERM + 1
          SB3    EL.( 
          LE     B4,B5,SSP.NS  IF OC(NEXTE) .LE. OC.ID
          EQ     B4,B3,SSP.NS  IF OC(NEXTE) .EQ. EL.( 
          CALL   DIT         DUMP IXFN TERM TO ARLIST 
          SA1    TARLPT 
          MX7    60 
          SA7    X1+ARLIST   ARLIST(TERM + 1) = -0
          SUB 
          EQ     PIM         PROCESS IXFN MACRO 
 PCO      SPACE  3,8
**        PCO - PROCESS SUBSCRIPT COMMA.
  
 PCO      RJ     SSERR3 
          SA3    TERM 
          SA4    NDIMS
          SX6    X3+B5       T = TERM + 1 
          IX5    X4-X6
          ZR     X5,SSP.NS   IF T .EQ. NDIMS
          SA6    A3          TERM = T 
          CALL   DIT         DUMP IXFN TERM TO ARLIST 
          SETZERO  O.TTS,L.TTS   INITIALIZE TERM-TEMP CELLS 
          SX6    B5 
          SA6    MC          MC(1) = 1
          SA6    A6+B5       MC(2) = 1
          SA6    A6+B5       MC(3) = 1
          EQ     SSP0 
 PSM      SPACE  4,8
**        PSM - PROCESS SUBSCRIPT MINUS SIGN. 
  
 PSM      CALL   PPM         COMMON PLUS-MINUS PROCESSING 
          MX7    59 
          ZR     B4,PSM1     IF NEXTE IS CONSTANT 
          NE     B4,B5,SSP.NS      IF NEXTE IS NOT ID 
          SA3    VARS        VARIABLES IN THIS TERM SO FAR
          SA7    X3+MC       MC(VARS+1) = -1
          EQ     SSP0 
  
 PSM1     SA7    COMP        COMPLEMENT FLAG .NE. 0 
          EQ     SSP0 
 PSP      SPACE  3,8
**        PSP - PROCESS SUBSCRIPT PLUS SIGN.
  
 PSP      CALL   PPM         COMMON PLUS-MINUS PROCESSING 
          EQ     SSP0 
 PPM      SPACE  3,8
**        PPM - PROCESS PLUS OR MINUS.
*         PPM CHECKS FOR VALID SYNTAX AND ANSI COMPATABILITY. 
*         IT ALSO ADDS THE CURRENT CONTENTS OF THE TEMP CONSTANT
*         BUFFER, CONST, TO THE ACCUMULATED ADDITIVE CONSTANT IN
*         ACT.  THE ID-ENCOUNTERED FLAG, IDF, AND THE CONST BUFFER
*         ARE THEN BOTH ZEROED. 
  
 PPM      ENTRY. *
          CALL   SSERR6      CHECK THIS-NEXT SYNTAX 
          MX7    1
          ZR     B4,PPM1     IF NEXTE IS CONSTANT 
          SA7    NANSI       NON-ANSI USE 
          EQ     PPM3 
  
 PPM1     SA3    TEP
          SA4    X3+B5
          UX0    B7,X4
          EQ     B7,B5,PPM2  IF PREVIOUS ELIST IS ID
          SA7    NANSI       NON-ANSI USAGE 
          EQ     PPM3 
  
 PPM2     SA3    PMF
          ZR     X3,PPM3     IF NO + OR - PRECEDING IN THIS TERM
          SA7    NANSI       NON-ANSI USAGE 
  
 PPM3     SA7    PMF         PLUS OR MINUS FLAG 
          SA3    ACT         ADDITIVE CONSTANT SUM
          SA4    CONSTT 
          MX6    0
          IX7    X3+X4
          SA6    IDF         IDFLAG = 0 
          SA7    A3          ACT = ACT + CONST
          SA6    A4          CONST = 0
          EQ     PPM
 PSS      EJECT 
**        PSS - PROCESS SUBSCRIPT STAR. 
  
 PSS      ZR     B4,PSS2     IF NEXTE IS CONSTANT 
          NE     B4,B5,SSP.NS  IF NEXTE IS NOT ID 
          SA3    IDF         ID-IN-TERM-ENCOUNTERED FLAG
          NZ     X3,SSP.NS   IF ID1*ID2  OR  ID1*CON*ID2, ETC.
          SA5    TEP         TEMP ELIST POINTER 
          SB3    EL.( 
          SA4    X5+2 
          UX0    B7,X4
          MX7    1
          EQ     B7,B3,PSS1  IF CON PRECEDED BY ( 
          SB3    EL.COMMA 
          EQ     B7,B3,PSS1  IF CON PRECEDED BY COMMA 
          SA7    NANSI       NON-ANSI USAGE 
  
 PSS1     SA3    VARS        (X3) = NO OF VARIABLES IN TERM SO FAR
          SA2    CONSTT      C = CONSTT 
          MX7    0
          SA7    A2          CONST = 0
          SA1    X3+MC       X1 = MC(VARS+1)
          IX6    X1*X2
          SX4    X6 
          BX3    X6-X4
          NZ     X3,SSP.NS   IF PRODUCT .GE. 1S17 
          SA6    A1          MC(VARS+1) = MC(VARS+1) * C
          EQ     SSP0 
  
 PSS2     MX7    1
          SA7    NANSI       *CON NON-ANSI IN SUBSCRIPT 
          BX1    X2          (X1) = ELIST(CON)
          CALL   ECON        GET CONSTANT AND CHECK FOR ANSI USAGE
          SA5    IDF
          SA2    CONSTT      (X2) = PREVIOUS CONST BUFFER 
          LX1    X6          (X1) = CON 
          ZR     X5,PSS3     IF NO ID IN TERM YET 
          SA3    VARS 
          SA2    X3+MC-1     (X2) = MC(VARS)
  
 PSS3     IX6    X1*X2
          SX4    X6 
          BX3    X6-X4
          NZ     X3,SSP.NS   IF PRODUCT .GE. 1S17 
          SA1    TEP
          SX7    X1-1 
          SA6    A2          MC(VARS) = MC(VARS) * CON  OR
*                            CONST = CONST * CON
          SA7    A1          ADVANCE EPOINT OVER CONSTANT 
          EQ     SSP0 
 DIT      SPACE  4,8
**        DUMP INFORMATION PERTAINING TO ONE TERM OF SUBSCRIPT TO 
*         ARLIST BUFFER.
  
 DIT      ENTRY. *
          SA3    ACT
          SA4    CONSTT 
          IX6    X3+X4
          SX7    X6-1 
          MX0    -IX.MCL
          SA7    A3          ACT = ACT + CONST - 1
          SA2    TERM 
          SA5    DCF
          SA1    TARLPT      POINTER WITHIN ARLIST BLOCK
          LX2    IX.SUBP
          SA3    MC 
          SB6    X5          (B6) = DOUBLE/COMPLEX FLAG 
          LX3    B6          MULTIPLY MC * 2 FOR 2 WORD ARRAYS
          SA4    VAR
          BX3    -X0*X3 
          LX3    IX.MCP 
          BX6    X2+X3
          LX4    IX.IHP 
          BX7    X6+X4
          SA7    ARLIST+X1
          SUB 
  
          SA3    A3+B5       MC(2)
          LX3    B6 
          BX3    -X0*X3 
          LX3    IX.MCP 
          SA4    A4+B5       VAR(2) 
          BX6    X2+X3
          LX4    IX.IHP 
          BX7    X6+X4
          SA7    A7+B5       STORE SECOND VARIABLE INFORMATION
  
          SA3    ACT
          LX6    X3,B6       ADDITIVE CONSTANT = ACT S DCF
          SA6    A7+B5       ADDITIVE CONSTANT WORD 
          SX7    X1+3 
          SA7    A1          UPDATE ARLPT 
          EQ     DIT         RETURN 
 PIM      SPACE  4,8
**        PIM - PROCESS IXFN MACRO. 
* 
*         OUTPUT STANDARD SUBSCRIPT MACRO TO ARLIST.
  
 PIM      SA1    NANSI
          SA2    SAVDAN 
          NZ     X2,PIM0A    IF CALLED FROM LISTIO COLLAPSE 
          ZR     X1,PIM0A    IF NO NON-ANSI ASPECTS TO IXFN 
          USASDM ERMSG40     NON-STANDARD SUBSCRIPT 
  
 PIM0A    SA1    TERM 
          SA2    NDIMS
          IX6    X2-X1
          ZR     X6,PIM0B    IF TERM = NDIMS
          USASDM ERMSG23     FEWER SUBSCRIPTS THAN DIMENSIONS 
  
 PIM0B    SA3    DCF
          SB6    X3          (B6) = DOUBLE/ COMPLEX FLAG
          CALL   DIL         OUTPUT SIMPLE LOAD IF SUBSCRIPT IS CONSTANT
          SA1    TEP
          SX7    X1-1 
          SA2    DAF
          NZ     X2,SSP.NS1  IF DEBUGGING ON FOR THIS ARRAY 
          SA7    EPOINT      SET EPOINT BEYOND )
          SA1    ARLPT       INDEX TO FIRST AVAILABLE ARLIST WORD 
          MX4    0
          ZR     X1,PIM1     IF NO ENTRIES IN ARLIST YET
          SA2    LASTR       HEADER OF LAST ENTRY 
          SA3    X2 
          BX0    X3 
          AX0    59 
          BX3    X0-X3
          LX3    -18
          SX4    X3          NUMBER OF WORDS IN PREVIOUS ENTRY
  
 PIM1     SA5    TERM        (X5) = NUMBER OF TERMS IN PROCESSED IXFN 
          LX2    X5,B5
          IX3    X2+X5       (X3) = 3 * TERMS 
          SX5    X3+5        (X5) = NUMBER OF WORDS IN ARLIST ENTRY 
          SX2    X3+2        (X2) = NUMBER WORDS FOLLOWING FOR HEADER 
          LX5    18 
          BX4    X4+X5
          SA3    NAME+1      WORD B OF ARRAY
          LX2    30 
          MX0    -L.TYP 
          LX3    -P.TYP 
          BX0    -X0*X3      TYPE OF ARRAY
          SB1    X0 
          PX6    B1,X4
          SA5    EQCOUNT     EQUAL SIGN COUNT 
          SX4    X5 
          LX4    37 
          BX7    X6+X4
          SA7    X1+ARLIST   ARLIST HEADER WORD 
          SUB 
  
          SA4    IDORDL 
          BX7    X4 
          SA7    A7+B5       IH OF ARRAY TO SECOND WORD OF ENTRY
  
          SA3    NARN 
          SB2    -STLMAC     IXFN MACRO OP CODE 
          BX2    X3+X2       (X2) = 30/NWF,30/RI
          SX0    B6          (X0) = DOUBLE WORD ARRAY FLAG
          LX0    RM.RIL      POSITION ARRAY TYPE
          BX7    X2+X0       (X6) = 30/NWF,14/TYPE,16/RI
          PX7    B2,X7
          SA7    A7+B5     WORD 1 OF IXFN = 12/P(OC),18/NWF,14/TYP,16/RI
  
          SX6    X3+B5
          SX6    X6+B6       NARNT = NARN + 1 + DOUBLE WORD BIT 
          SA6    A3          NARN = NARNT 
          BX7    X4          (X7) = ORDINAL OF ARRAY
          SB7    PIM2 
          SA6    SAVENARN 
          CALL   EQUIVR 
          LX6    IX.CAP 
          BX7    X6+X7       IH,CA OF EQUIVALENCED ARRAY
 PIM2     SA7    A7+B5       WORD 2 OF IXFN = IH,CA OF ARRAY
  
          SA2    SDIMIN 
          BX7    X2 
          SA7    A7+B5       WORD 3 OF IXFN = DIMENSION INFO
  
          SA2    REFSELCT    LOCAL COPY OF LONG MAP FLAG
          ZR     X2,PIM4     IF NO LONG MAP 
          SA1    ARLPT
          SX6    X1+ARLIST+3
          SUB 
          SA6    REFTEMP
  
 PIM3     SA1    INC         INCREMENT FOR MACRO TERM ACCESS
          SX0    3
  
*         TOGGLE INDEX INCREMENT BETWEEN 1 AND 2.  THIS CAUSES EVERY
*         THIRD WORD OF MACRO (WHICH CONTAINS ADDITIVE CONSTANT 
*         INFORMATION) TO BE SKIPPED. 
  
          IX6    X0-X1
          SA2    REFTEMP
          IX7    X2+X6       NEXT VARIABLE INFO WORD
          SA3    X7 
          MI     X3,PIM4     IF VARIABLE WORD .LT. 0
          SA6    A1          STORE TOGGLED INCREMENT
          SA7    A2          REFTEMP = ADDRESS OF CURRENT VARIABLE WORD 
          LX3    -IX.IHP
          SB1    X3 
          ZR     B1,PIM3     IF THIS VARIABLE DID NOT APPEAR
          ADDREF B1,REF      NOTE REFERENCE 
          EQ     PIM3 
  
 PIM4     SB7    PIM6 
          SA2    ARLPT
          MX0    -IX.CAIHL
          SB6    B5+B5       (B6) = IXFN ACCESS INCREMENT = 2 
          SA1    SYM1 
          SB3    B6+B5       (B3) = 3 
          SA0    X1 
          SA3    X2+ARLIST+3
          SUB 
  
 PIM5     SA3    A3+B6       NEXT VARIABLE TERM FROM MACRO
          MI     X3,PIM7     IF VARIABLE WORD .LT. 0
          LX3    -IX.IHP
          BX6    -X0*X3      SYMTAB ORDINAL 
          ZR     X6,PIM6A    IF THIS VARIABLE DID NOT APPEAR
          IX1    X6+X6
          SB4    X1 
          SA1    A0-B4       WORD A OF VARIABLE/S SYMTAB ENTRY
          SA2    A1-B5       WORD B 
          BX6    X1 
          LX7    X2 
          SA6    NAME 
          SA7    A6+B5
          BX6    -X0*X3 
          CALL   EQUIVR 
          LX6    IX.CAP 
          BX6    X6+X7
  
 PIM6     LX3    IX.IHP 
          MX0    -IX.CAIHL
          BX1    X0*X3       CLEAR IH,CA
          LX6    -IX.IHP
          BX7    X6+X1
          SA7    A3          RESET EQUIVALENCED IH,CA 
  
 PIM6A    SB6    B3-B6       TOGGLE INCREMENT 
          EQ     PIM5 
  
 PIM7     SA3    ARLPT
          SA1    TARLPT 
          SA2    RL2
          BX6    X1 
          LX7    X2 
          SA6    A3          ARLPT = TARLPT 
          SA7    RL1         RL1 = RL2
          SX6    ARLIST+X3
          SUB 
          SA6    A2          RL2 = HEAD OF IXFN JUST OUTPUT 
          SA6    LASTR       LASTR = RL2
  
*         OUTPUT IO RESTART CALL IF IN AN INPUT STATEMENT WHICH 
*         PREVIOUSLY CONTAINED A VARIABLE THAT IS IN A TERM OF THIS 
*         IXFN. 
  
          SA2    IXFNFG 
          ZR     X2,NEXTE    IF NOT IN AN I/O LIST
          SA3    REFTYPE
          PL     X3,NEXTE    IF NOT INPUT 
          SA4    PARCNT 
          ZR     X4,NEXTE    IF NOTHING TO OUTPUT 
          SA5    =XIONAME 
          ZR     X5,NEXTE    IF LIST NOT BEING PROCESSED YET
          SA1    L.IOLST
          ZR     X1,NEXTE    IF NO PRECEDING INTEGER VARIABLES
          SA3    ABIO 
          NZ     X3,NEXTE    IF BUFFER I/O OR ENCODE/DECODE VARIABLE
          SA2    LASTR       POINTS TO HEADER OF IXFN JUST OUTPUT 
          SA3    O.IOLST     TABLE ORIGIN 
          SB6    X1          TABLE LENGTH 
          SA1    X2+5-2      FIRST VARIABLE IH,CA WORD IN IXFN
          MX0    -IX.IHL
          MX7    -IX.CAL
          SB7    B5+B5       B7 = IXFN INDEX INCREMENT = 2
          SA0    B7+B5       A0 = 3 
  
 PIM8     SA1    A1+B7       NEXT IXFN VARIABLE 
          MI     X1,NEXTE    IF END OF IXFN 
          SB2    B6          L.IOLST
          SA2    X3-1        FWA OF IOLST - 1 
          SB7    A0-B7       TOGGLE INCREMENT 
  
 PIM9     ZR     B2,PIM8     IF END OF IOLST
          SA2    A2+B5       NEXT IOLST ENTRY 
          LX1    -IX.IHP
          BX4    -X0*X1 
          LX2    -AP.IHP
          BX5    -X0*X2 
          IX6    X4-X5
          SB2    B2-B5
          LX2    AP.IHP+59-AP.CRP 
          NZ     X6,PIM9     IF NO MATCH ON IH
          MI     X2,PIM10    IF PREVIOUS USE WAS CLASS REFERENCE
          LX1    IX.IHP-IX.CAP
          BX4    -X7*X1      EXTRACT CA FROM IXFN TERM
          LX2    AP.CRP-59-AP.CAP 
          BX5    -X7*X2      EXTRACT CA FROM IOLST ENTRY
          IX6    X4-X5
          NZ     X6,PIM9     IF NO MATCH ON CA
  
 PIM10    MX0    -RM.RIL
          SA2    LASTR
          SA5    X2+2        MACRO HEADER 
          SX3    B5 
          BX6    -X0*X5      RESULT NUMBER
          IX7    X3+X5       INCREMENT RESULT NUMBER
          SA6    NARN        FOR RESTART CALL 
          SA7    A5 
          CALL   IARC        OUTPUT RESTART CALL
          SA2    SAVENARN 
          MX7    0
          SX6    X2+B5
          SA7    L.IOLST
          SA6    NARN 
          EQ     NEXTE
 DIL      SPACE  4,8
**        DIL - DEGENERATE IXFN TO LOAD.
*         OUTPUT SIMPLE LOAD (IH,CA) IF SUBSCRIPT VALUE IS A CONSTANT 
*         AT COMPILE TIME.
  
 DIL      ENTRY. *
          SA3    SDIMIN      DIMENSION INFO 
          MX0    3
          LX0    -3 
          BX6    X0*X3       EXTRACT P(ABC) (VARIABLE DIMENSION BITS) 
          LX6    2
          SA1    ARLPT
          MX7    0           CA = 0 
          SX5    B5          MULT = 1 
          MX0    -IH.IHL
          SB7    ARLIST+X1+5   FIRST TERM WORD
          SUB 
  
 DIL1     SA1    B7 
          ZR     X1,DIL2     IF TERM IS EMPTY 
          MI     X6,DIL      IF DIM(TERM-1) IS VARIABLE 
          LX1    -IH.IHP
          BX2    -X0*X1 
          NZ     X2,DIL      IF TERM CONTAINS VARIABLE
          SA2    B7+2        ADDITIVE CONSTANT
          LX6    1           POSITION NEXT VARIABLE DIMENSION BIT 
          IX4    X5*X2
          SB7    A2+B5       INCREMENT TERM COUNTER 
          SX1    X3 
          IX7    X4+X7       CA = CA + MULT * (AC - 1)
          IX5    X5*X1       MULT = MULT * DIM(I - 1) 
          AX3    18          I = I + 1
          EQ     DIL1 
  
 DIL2     SA1    IDORDL 
          SA7    NCA
          SA3    A3          RELOAD DIM INFO
          BX0    X6 
          AX3    36 
          SX2    X3-1        PRODUCT OF DIMENSIONS -  1 
          IX6    X2-X7
          BX6    X7+X6       .LT. 0 IFF REF OUT OF BOUNDS 
          SA2    DAF
          ZR     X0,DIL2A    IF NO DIMENSIONS VARIABLE
          BX6    X7          DIAGNOSE SUBSCRIPTS .LT. 1 ONLY
  
 DIL2A    ZR     X2,DIL3     IF NO DEBUGGING ON FOR THIS ARRAY
          MI     X6,DIL2B    IF OUT OF BOUNDS 
          ZR     X0,DIL3     IF NO VARIABLE DIMENSIONS
          EQ     SSP.NS1     GO COMPILE EXECUTION CHECK CODE
  
 DIL2B    IDM    ERMSG75     CONSTANT SUBSCRIPT OUT OF RANGE
          EQ     SSP.NS1
  
 DIL3     SA6    OBR
          SA7    IDORDLTS+1  RAW CA FOR FETCH 
          MX6    0
          BX7    X1 
          SA7    IDORDLTS    RAW IH FOR FETCH 
          SB7    DIL4        RETURN IF NON-EQ1IVALENCED 
          CALL   EQUIVR 
  
 DIL4     SA1    NCA         CA FROM SUBSCRIPT
          SX5    X7          EQIVALENCED IH 
          IX3    X6+X1
          SB6    B0          RF FOR FETCH 
          SB7    X3          CA INCLUDING EQUIV. INFO 
          CALL   FETCH
          SA1    OBR
          PL     X1,DIL5     IF REF WITHIN DIMENSION BOUNDS 
          IDM    ERMSG75
  
 DIL5     SA1    TEP
          SX7    X1-1 
          SA7    EPOINT      SET EPOINT BEYOND )
          EQ     NEXTE       EXIT TO MAIN LOOP
 SSP.NS   SPACE  4,8
*         NON-STANDARD SUBSCRIPT ENCOUNTERED. 
  
 SSP.NS   USASDM ERMSG40     NON-ANSI SUBSCRIPT 
 SSP.NS1  SA1    PARLEVEL 
          SA2    EPOINT 
          SX7    X2-1 
          SA7    A2 
          SX6    X1+1 
          SA6    A1          INCREMENT PAREN COUNT
          SA2    IXFNFG 
          ZR     X2,NSSETUP0       IF NOT IN AN I/O LIST
          SA3    REFTYPE
          PL     X3,NSSETUP0       IF NOT AN INPUT STATEMENT
          SA4    PARCNT 
          ZR     X4,NSSETUP0       IF NOTHING TO OUTPUT 
          SA2    =XIONAME 
          ZR     X2,NSSETUP0       IF LIST NOT BEING PROCESSED YET
          SA3    L.IOLST
          ZR     X3,NSSETUP0       IF THIS IS THE FIRST LIST ITEM 
          SA4    ABIO 
          NZ     X4,NSSETUP0 IF BUFFER I/O OR ENCODE/DECODE VAR 
          RJ     IARC              ISSUE RESTART CALL 
          MX7    0
          SA7    L.IOLST
 NSSETUP0 SA1    OSPTR       SAVE PREVIOUS (IF ANY) ARRAY REFERENCES
          SB2    X1-MXOSE+4   +4 FOR ADDING 4 WDS TO STAK 
          PL     B2,ERR03     IF OPSTAK FULL
          SA2    ARORD
          SA3    DIMINF 
          BX6    X2 
          BX7    X3 
          SA6    X1+OPSTAK+2  ARORD 
          SA7    X1+OPSTAK+3  DIMINF
          SA3    SFRSTB      COUNT OF FUNCTION RESULT SAVED 
          SA2       ARLPT     SAVE START OF SUBS EXP INCASE ** FOLLOWS. 
          LX3    18 
          BX7    X3+X2
          SA7    X1+OPSTAK+1
          SA2       CC
          BX6    X2 
          SA6    X1+OPSTAK+4
          SX6    X1+4 
          SA6       OSPTR 
          SA1    SARORD       INITIALIZE ARORD AND DIMINF FOR THIS ARRAY
          SA2    SDIMIN 
          BX6    X1 
          BX7    X2 
          SA6    ARORD
          SA7    DIMINF 
          MX6       0 
          SA6       CC
*     SET UP LEFT-PARENS-PREDEDING-SUBSCRIPT OP FOR ADDITION TO THE OP- 
** STACK.  INCLUDE THE CURRENT MODE OF EXPRESSION WE,RE IN (ARG.LIST, 
** SUB, OR NORMAL) IN THE OP AND SET EMODE TO SUBSCRIPT MODE. 
          SA2    EMODE        GET CURRENT MODE (4,2,1 IF SUB,ARG,EXP) 
          SA1    SPARLEV
          SX6    X1+1 
          SA6    A1          SPARLEV = SPARLEV + 1
          SA1    LPSUB        GET LP-SUBSCRIPT OP.
          LX2    19           POSITION FOR ORING INTO B21-19
          BX6    X1+X2
          SA1    SFRSTB 
          LX1    30 
          BX6    X1+X6             SAVE SFRSTB IN (S OPSTAK WORD
          SX7    4            SET EMODE TO SUBSCRIPT MODE.
          SA6    OP 
          SA7    EMODE
          SA1    LEFRN
          ZR     X1,ADDOP    IF NO SAVED FUNCTION RESULTS 
          SA2    DFLAG
          ZR     X2,ADDOP    IF NOT DEBUG MODE
          SA1    ALLARR 
          NZ     X1,NSSETUP1       BRANCH IF UNCONDITIONAL TRACING
          SA3    ARORD             ARRAY ORDINAL
          SA4    SYM1              START OF SYMBOL TABLE
          LX3    1
          IX5    X4-X3             COMPUTE ADDRESS OF ARRAY ENTRY 
          SA2    X5-1              WORD B OF ENTRY
          MX0    60-L.DIF 
          LX2    60-P.DIF 
          BX7    -X0*X2            MASK OUT DEBUG INFORMATION BITS
          SX6    X7-DV.ARR         IS ARRAY CHECKING TO BE DONE 
          SX7    X7-DV.AAS         ARE ARRAYS AND STORES ON 
          ZR     X6,NSSETUP1       IF YES 
          NZ     X7,ADDOP    IF ARRAYS AND STORES ARE OFF 
  
 NSSETUP1 RJ     FUNC8       PROCESS ANY SAVED FUNCTION RESULT
          MX0    1
          SA3    OP                (S WORD TO BE PLACED IN THE OPSTAK 
          LX0    1+30 
          IX7    X3+X0             INCREMENT SAVED SFRSTB VALUE 
          SA7    A3                RETURN TO OP WORD
          EQ     ADDOP       ADD (S TO OPSTAK AND PROCESS NEXTE 
* 
*     NSAN IF ID IS NON-SUBSCRIPTED ARRAY NAME
 NSAN     SA1       EMODE 
          SX2    X1-2 
          ZR     X2,NSAN1     IF IN AN ARG LIST 
          SA1       IXFNFG
          NZ     X1,NSAN1     IF IN IXFN MODE 
 NSAN2    IDM       ERMSG13   INF: ARRAY NAME NOT SUBSCRIPTED,1ST EL USD
          ZR        VR3 
 NSAN1    SA1    B1+1         WAS E-1 AN OP-
          SB3       LOWOP 
          UX0 B2,X1 
          GE  B2,B3,NSAN2     IF YES
          SA1    B1-1         IS E+1 AN OP- 
          UX0 B2,X1 
          NZ     X0,NSAN2     IF YES
          SA1    ABIO 
          MI     X1,NSAN2    IF BUFFER FWA OR LWA 
          SA2       IXFNFG
          SA1       FNAD      FUN ADR IN SYMTAB 
          NZ     X2,NSAN3          IF IN IXFN MODE
          SA2    X1-1         IS IT AN EXT FUN- 
          LX2    59-P.EXT 
          NG     X2,VR3       IF YES
          LX2    P.EXT-P.INF
          PL     X2,NSAN2    IF NOT INTRINSIC 
          USASDM ERMSG13
          EQ     VR3
 NSAN3    MX0    3
          SA1    SDIMIN            DIM INFORMATION WORD 
          LX0    -3 
          BX6    X0*X1             P(ABC) FIELD 
          SA6    SAVDAN            NON ZERO IF VARIABLE DIMENSIONS
          MX7    10 
          SA7    =XCRFLAG    USED BY I/O PROCESSOR
          EQ     VR3
  
*     GTOUT: IF EOS POPPED OUT.  SHOULD BE A GO TO STATEMENT.  IF NOT,
* IDAG.  IF TYPE OF EXPR IS NOT INT, OUTPUT ARLIST TO CONVERT TO TINT.
* THEN J  OUT.
 GTOUT    SA5       RL2 
          SB5    T.INT
          RJ        MODCH     CONVERT, IF NECESSARY, RL2 TO INT 
          ZR        OUT 
*** 
*         HERE IF VARIABLE NAMED IN LEVEL OR ECS STATEMENT
*         ECS VARIABLE TREATED AS LEVEL 3 TYPE
*         REFERENCE MUST BE STAND-ALONG, AND IN ARGUMENT MODE 
 LEVEL    SA2    EMODE
          SX3    X2-2              TEST FOR ARGUMENT MODE 
          NZ     X3,LVLERR1        NOT AN ARGUMENT
          SA1    B1-1              NEXT E-LIST ITEM 
          UX0    B2,X1
          SB3    LOWOP
          GE     B2,B3,LVLERR1     NOT A STAND-ALONG ARGUMENT 
          SB4    EL.( 
          SA1    FNAD 
          SA2    =7LLOCF
          SA3    X1 
          BX2    X2-X3
          AX2    18 
          ZR     X2,LEVEL1   IF LOCF(LEVEL3)
          SA2    X1-1 
          LX2    59-P.EXT 
          PL     X2,LVLERR1        NOT IN EXT ARG LIST
  
 LEVEL1   NE     B2,B4,IDREF.3   IF VARIABLE
          SA1    NAME 
          LX1    59-P.DIM 
          NG     X1,ARRAY          LCM ARRAY ITEM 
          EERR   ERMSG2            SIMPLE VARIABLE FOLLOWED BY A (
  
 LVLERR1  EERR   ERMSG52           NOT STAND-ALONG ARGUMENT 
          TITLE              FUNCTION PROCESSING
*     FUNC IF ID IS NAME OF FUN 
 FUNC     SA1    B1-1         IS E+1 (
          UX0 B2,X1 
          SB3    EL.( 
          EQ  B2,B3,FUNC1     IF YES
          SA2       NAMFWA    IS IT A STATE.OR INTR.FUN-
          SA1       X2-1      GET 2ND WD OF SYMTAB ENTRY
          BX3    X1 
          LX1    59-P.ASF 
          NG     X1,FUNC3     IF STATE FUN
          LX1    P.ASF-P.EXT
          PL     X1,FUNC3     IF NOT EXT (THEN INTR)
          LX1    P.EXT-P.BEF
          MI     X1,FUNC3    IF A BASIC EXTERNAL
          SA1       EMODE     ARE WE IN ARG LIST MODE-
          SX2    X1-2 
          NZ     X2,FUNC3     IF NO 
          SA1    B1+1         IS E-1 AN EXPLICIT OP-
          UX0 B2,X1 
          SB3       LOWOP 
          GE  B2,B3,FUNC3     IF YES
          SA1    B1-1         IS E+1 AN OP- 
          UX0 B2,X1 
          SB3       LOWOP 
          GE  B2,B3,FUNC3     IF YES
          SA1       FNAD      ARE WE IN AN EXT FUN ARG LIST-
          SA2    X1-1         GET 2ND WD SYMTAB ENTRY 
          LX2    59-P.EXT 
          PL     X2,ASAL7    IF NOT IN AN EXT FUN 
          LX3    59-P.EST    ARG LIST 
          MI     X3,ASAL     IF ARGUMENT SPECIFIED IN EXTERNAL
          EERR   ERMSG61     EXTERNAL IN ARGLIST MUST BE IN EXT STMT
  
 ASAL7    SA3    X1 
          SA4    =7LLOCF
          BX5    X3-X4
          AX5    18 
          NZ     X5,ASAL0    IF NOT LOCF(EXT) 
          SA5    IDORDL 
          SB6    B0 
          SB7    B0 
          RJ     FETCH             OUTPUT A LOAD
          EQ     NEXTE
  
 ASAL0    EERR   ERMSG14           INTRIN(EXT) NOT ALLOWED
* 
 ASAL     MX1    0           ST = 0 
          SA2    IDORDL 
          MX3    0           CA = 0 
          MX4    0           NO DIM CHECK 
          RJ        APLRT 
          SA1       ACNT
          SX6    X1+1 
          SA6       ACNT
          SA1    B1-1         IS E+1 A , :  
          SB3    EL.COMMA 
          UX0 B2,X1 
          EQ  B2,B3,ASAL2     IF YES
          SB3    EL.) 
          EQ  B2,B3,ASAL2     IF E+1 IS A ) 
          EERR      ERMSG15   ARG NOT FOLLOWED BY ) OR ,
 ASAL2    SA1       OSPTR     TAKE ,P OUT OF STAK 
          SX6    X1-1 
          SA6       OSPTR 
          EQ     NEXTE
* 
 FUNC3    EERR      ERMSG16   THIS FUN REF REQUIRES ARG LIST
 FUNC1    SPACE  4,8
*     FUNC1 IF FUNC( IN ELIST 
 FUNC1    SA2       EPOINT    MOVE EPOINT BEYOND (
          SA1    X2-1 
          UX7 B4,X1 
          RJ        SSERR3    CHECK SYNTAX AFTER LEFT PAR 
          SA1    PARLEVEL 
          SX6    X1+1 
          SA6    A1 
          SA1       NAME+1    IS FUN A STATE FUN -
          SX7    X2-1 
          LX1    59-P.ASF 
          SA7       EPOINT
          PL     X1,FUNC5     IF NO 
          MX0    60-L.TYP 
          SB2       SFLPOC    S.F.LP OPCODE EQU 30
          BX2   -X0*X1
          SA3       EMODE     SAVE CURRENT MODE 
          LX2       44        POSITION SF TYPE
          LX3       19        POSITION MODE 
          BX0    X2+X3
          PX6    B2,X0
          SX7       1         SET EMODE TO EXPR 
          SA4       OSPTR 
          SB2    X4-MXOSE+2 
          SA7       EMODE 
          PL     B2,ERR03     IFOPSTAK FULL 
          SX7    X4+2         UP OSPTR
          SA6    X4+OPSTAK+2  STORE SF LP- (SF
          SA1       ARLPT 
          SA7       OSPTR 
          SA2       SFRSTB
          LX2       18
          BX6    X2+X1
          SA1       EPOINT    FIX EPOINT TO POINT TO ASF NAME 
          SA6    X4+OPSTAK+1  STORE ARLPT FOR POSSIBLE USE BY EXPOP.
          SX6    X1+2 
          SA6       EPOINT
          RJ        ASFREF
          EQ     NEXTE
 FUNC5RT  SPACE  4,8
 FUNC5RT  DATA      0 
          SA1       RNTBC     ENTER (A IN OPSTAK PRECEDED BY ARGLIST   -
          SA2       OSPTR        INFO OF A POSSIBLY PRECEDING AND IN-  -
          IX3    X1+X2           COMPLETE FUNC REF. 
          SB2    X3-MXOSE+9   SEE IF ROOM FOR RNTBL + 9 OTHER WDS OF INF
          PL     B2,ERR03 
          SA4    FTRFLG 
          SA3    FRLW 
          LX4    -1 
          BX6    X3+X4
          SA6    A3                SAVE FUNCTION TRACE FLAG 
          SB2    X1+6         B2=NO.WORDS TO MOVE 
          SB3    B0           B3 WILL COUNT 
          SB4    X2+OPSTAK    B4=FWA-1 TO STORE TO
 FUNC6    SA1    B3+FRLW      FRLW IS 1ST WD IN BLOK
          BX6    X1 
          SB3    B3+1 
          SA6    B3+B4        1ST WD GOES INTO X2+OPSTAK+1
          NE  B3,B2,FUNC6     IF MORE TO MOVE 
* 
          SB2    B2+1 
          SX7    B2 
          SA7    B2+B4        STORE CNT OF WORDS PRECEDING (A 
          SX6    X2+B2        UPDATE OSPTR
          SA6       OSPTR 
*     SET UP FRLW BLOK FOR THIS FUN 
          SA2       ARLPT                                          FUNC.
          MX6    0
          SA1    TYADR       ADDRESS OF ARGUMENT TYPES WORD 
          LX1    18 
          BX7    X1+X2
          SA6    STAPLC 
          SA7       FRLW
          SA1       NAMFWA
          MX7       0 
          BX6    X1 
          SA7       RNTBC 
          SA6       FNAD
          SA7       ACNT
          SA1       SFRSTB
          BX6    X1 
          SA6       SSFRSTB 
          SA1       EMODE 
          SA2       ARGLP 
          LX1       19
          SA3       OSPTR 
          BX6    X1+X2
          SA6    X3+OPSTAK+1  (A
          SA1       ARGCMA
          BX7    X1 
          SX6    X3+2 
          SA7    X3+OPSTAK+2  ,A
          SA6       OSPTR 
          SX7       2         SET CURRENT MODE TO ARG.LIST MODE 
          SA7       EMODE 
          SA1       FNAD      IS THIS FUNC INTR OR BASIC EXT- 
          SA2    X1-1 
          LX2    59-P.INF 
          MI     X2,FUNC5RT  IF AN INTRINSIC FUNCTION 
  
          CALL   DOCALL      INFORM *DOPROC* OF EXTERNAL REFERENCE
*         (WILL ALSO REACH THIS POINT FOR ** FUNCTION CALLS)
          SA1       LEFRN     IS THERE AN UNSAVED RESULT NAME IN LEFRN -
          ZR     X1,FUNC5RT   IF NOT
          SA2       EXRL1 
          SA3       EXRL2 
          ZR     X2,FUNC7    IF NOT PROCESSING ** 
          SA2    EXPSTB       GET R NAME OF FIRST ISSTR OF BASE 
          SA3    X2+ARLIST+2
          SUB 
          MX0       60-16 
          BX4    -X0*X1 
          BX6  -X0*X3 
          IX2    X4-X6
          SA6       RNFIB     SAVE RNAME OF FIRST INSTR IN BASE 
          PL     X2,FUNC5RT   IF THE LAST FUNC RESULT IS PART OF THE
*                  BASE OR POWER OF THIS **.
          SA3       EXPNSF
          SX6    X3+1 
          SA6       EXPNSF
  
 FUNC7    RJ     FUNC8       OUTPUT ANY SAVED FUNCTION RESULT 
          SA7    SSFRSTB     RESET BASE FOR NEXT EXTERNAL 
          EQ     FUNC5RT
          SPACE  4,8
**        FUNC8 - OUTPUT ANY SAVED FUNCTION RESULT. 
* 
*         EXIT   (X7) = (SFRSTB), UPDATED IF A *SFR* WAS PROCESSED. 
* 
 FUNC8    ENTRY. *
          SA1    LEFRN
          ZR     X1,FUNC8    IF NO SAVED RESULTS
          RJ     FRTS        OUTPUT TEMP-STORE AS *SFR* MACRO 
          SA3    STSORD      CA = (STSORD)
          SA2    LEFRN
          SX3    X3-1 
          MX0    59 
          LX2    -58         *DOUBLE* BIT TO BIT 0
          BX0    -X0*X2 
          LX2    58 
          IX3    X3-X0       CA = CA-1 (CA-2 IF DOUBLE) 
          LX3    16 
          MX6    0
          SA1    SFRSTB 
          SA6    A2          LEFRN = 0
          SX4    X1-MXFRSTB 
          MI     X4,FUNC8A   IF NO OVERFLOW 
          EERR   ERMSG18
  
 FUNC8A   BX6    X2+X3
          SX7    X1+1 
          SA6    X1+FRSTB    FRSTB(SFRSTB) = LEFRN
          SA7    A1          SFRSTB = SFRSTB + 1
          EQ     FUNC8
          SPACE  4,8
 FUNC5    RJ        FUNC5RT 
*         GEN EXT FUN REF. OUTPUT GEN  EXT MACRO WITH NAME (IH) OF
*         FUN AND NAME (IH) OF APLIST AS PARAMS.
  
          SA2    DFLAG
          ZR     X2,FUNC5B         BRANCH IF NOT IN DEBUG MODE
          SA1    IXFNFG 
          NZ     X1,FUNC5B         IF IN AN I/O LIST
          SA3    EXRL1
          NZ     X3,FUNC5B         IF PROCESSING ** CALL
          SA1    FNAD 
          SA2    X1-1              WORD 2 OF SYMTAB ENTRY 
          SA1    X1                WORD 1 OF SYMTAB ENTRY 
          BX7    X2 
          LX7    59-P.INF 
          MX6    0
REQUEST   SA6    FTRFLG      INITIALIZE FLAG
          MI     X7,FUNC5B   IF INTRINSIC FUNCTION
          SA3    ALLFUNC
          NZ     X3,FUNC5A         IF ALL FUNCTIONS TO BE TRACED
          BX3    X2 
          LX3    60-P.DIF          SHIFT DEBUG BITS 
          MX0    60-L.DIF 
          BX7    -X0*X3            MASK OUT DEBUG BITS
          SX6    X7-DV.FUN         IS FUNCTION TRACING TO BE DONE 
          NZ     X6,FUNC5B         IF NOT 
 FUNC5A   SX7    1
          SA7    FTRFLG      SIGNAL TRACING ON FOR THIS FUNCTION
 FUNC5B   BSS    0
          ZR        NEXTE 
          EJECT 
*     SIMPLE SYNTAX (THIS E : NEXT E) CHECKING. 
 SSERR1   EERR      ERMSG8
 SSERR2   SA1    B1+1         GET PRECEDING E-ITEM
          UX0 B2,X1 
          SB3    EL.) 
          GT  B2,B3,SSERR5
          EERR      ERMSG53   .NOT. MUSNT BE PRECEDED BY ID, CON, OR ). 
* 
 SSERR3   DATA      0         HERE IF E IS A COMMA, =, (, .OR., OR .AND.
*     DONT DESTROY X2 
          SB2    EL.ID
          SB3    EL.( 
          LE  B4,B2,SSERR3    IF FOLLOWED BY ID OR CONST
          EQ  B4,B3,SSERR3    BY (
          SB2    EL.MINUS 
          SB3    EL.NOT 
          EQ  B4,B2,SSERR3    - 
          EQ  B4,B3,SSERR3    .NOT. 
          SB2    EL.PLUS
          EQ  B4,B2,SSERR3    + 
*     HERE IF E NOT FOLLOWED BY CON,ID,(,NOT,-,+
          EERR      ERMSG27 
* 
*     SSERR4 IF .OR. OR .AND. IN ELIST
 SSERR4   RJ        SSERR3
          ZR        CMPARE
* 
 SSERR5   SB2    EL.ID
          SB3    EL.( 
          LE  B4,B2,CMPARE    IF FOLLOWED BY CON OR ID
          EQ  B4,B3,CMPARE    BY (
          SB2    EL.MINUS 
          SB3    EL.PLUS
          EQ  B4,B2,CMPARE    - 
          EQ  B4,B3,CMPARE    + 
          EERR      ERMSG19 
* 
*     SSERR6 IF A -,+,*,/, OR ** IN E-LIST
 SSERR6   DATA      0 
          SB2    EL.ID
          SB3    EL.( 
          LE  B4,B2,SSERR6    IF FOLLOWED BY CON OR ID
          EQ  B4,B3,SSERR6    BY (
          EERR      ERMSG5
* 
 SSERR7   RJ        SSERR6
*     HERE (*-1) IF **
          ZR        CMPARE
* 
*     END OF SSERR CODING 
          EJECT 
*     CARPO IF A ,A POPPED OUT
 CARGPO   BSS       0 
          RJ        CARGPORT
          ZR        CMPARE
* 
* 
* 
* 
 CARGPORT DATA      0 
          SA1       ACNT      UP ARG CNT
          SA2       FNAD      ARE WE IN BASIC EXT ARG LIST- 
          SB2    X1-MXARGS
          SX6    X1+1 
          NG     B2,CARGP6    IF NOT TOO MANY ARGS IN ARG LIST
          EERR      ERMSG7    TOO MANY ARGS IN ARG LIST 
 CARGP6   SA3    X2-1 
          SA6       ACNT
          LX3    59-P.BEF 
          NG     X3,CRGP10    IF WE ARE IN BASIC EXT ARG LIST 
          LX3    P.BEF-P.INF
          NG     X3,CRGP20    IF YES
*     HERE IF A ,A POPPED DURING SCAN OF GEN EXT FUN ARG LST
          LX3    P.INF-P.LIB
          PL     X3,CRGP0          IF NOT BEF CALL BY NAME
          SA1    RL2
          SA2    X1                SET UP FOR CALL TO CHKARG
          UX1    B2,X2             (B2) = TYPE OF ACTUAL ARGUMENT 
          RJ     CHKARG 
 CRGP0    SA1    RL2               IF LAST UNUSED R-LINE A FETCH- 
          SA2    X1+2         (1ST WD OF MACRO) 
          UX0 B2,X2 
          SB3    -SLMACO
          EQ  B2,B3,CRGP1     IF YES
          SB3      -STLMAC
          EQ     B2,B3,CRGP6  IF YES
          SB3      -DLMACO
          EQ  B2,B3,CRGP1     IF YES
          MX2    10          FLAG FOR POSITIONING RL2,RL1 BACK 1 ARLIST 
          RJ     OTS         OUTPUT TEMP STORES 
          BX1    X4 
          LX1    AP.P1P 
          MX4    0
 CRGP5    RJ     APLRT       OUTPUT APLIST
          SA1       EPOINT    SET B1 UP TO POINT TO CURRENT E 
          SB1    X1+1 
          ZR        CARGPORT
 CRGP1    RJ     SDFINE      SET DEFINE BIT, (X6) = WORD A
          SA3    EXRL1
          ZR     X3,CRGP1B   IF NOT PROCESSING ** ARGS
          BX6    X4 
          SA6    A6 
 CRGP1B   LX6    59-P.FP
          MI     X6,CRGP4 
          SA3    X1+4 
          MX0    -RM.RIL
          AX3    RM.RIL 
          BX3    -X0*X3 
          NZ     X3,CRGP4     IF AN INDEXED FETCH 
          SA1    X1           NO-OP THE FETCH 
          BX6   -X1 
          SA6    A1 
          SA3    A1+5         GET CA
          SA2    A1+3         GET IH
          SA1       RL1       RESET RL2 
          SA4    A2-2        IDORD FOR DIM CHECK
          BX6    X1 
          MX1    0
          SA5    EXRL1
          SA6    RL2
          NZ     X5,CRGP5    IF PROCESSING ** ARGS
          SA5    NARN 
          SX7    X5-1        DECREMENT NARN TO CONSERVE R-NUMBERS 
          SA7    A5 
          EQ     CRGP5
  
 CRGP4    SA2    X1+2         GET 1ST WD OF FETCH MACRO TO SET MACRO
*                                CODE TO A SET XI BA+CA+RF  MACRO.
          SB2      -SXTAMC
 CRGP7    PX6    B2,X2
          SA6    X1+2 
          SA1    RL2
          SA2    X1 
          UX0 B2,X2 
          SB3    T.DBL
          SB4    T.CPLX 
          EQ  B2,B3,CRGP7A    IF DBL LENGTH LOAD
          NE  B2,B4,CRGP7B    IF SNGL LENGTH LOAD 
 CRGP7A   SA5    NARN 
          SX6    X5-1        ADJUST NARN FOR STALR
          SA6    A5+
 CRGP7B   BX7    X1          SAVE RL2 FOR STALR 
          SA7    CRGPA
          RJ     CHKOFF 
          SA1    CRGPA
          RJ        STALR     GO OUTPUT STORE-TO-APLIST INSTR 
          ZR        CARGPORT
* 
 CRGP6    RJ        SDFINE    WONT DESTROY X1 OR X2 
          SB2      -SSSXA 
          EQ        CRGP7 
  
 CRGPA    BSS    1
* 
* 
*     CRGP10 IF ,P POPPED OUT OF BASIC EXT ARG LIST.  OUTPUT PSUEDO-OP
*  TO DEFINE REGISTER TO PLACE ARG IN.
 CRGP10   SA1       ACNT
          SX6       1 
          IX2    X1-X6
          ZR     X2,CRGP11    IF 1ST ARG
          SX6       2 
 CRGP11   SA6       TS1 
          MX0       60-16 
          SA1       RL2       IS IT DBL WD ARG- 
          SA2    X1+2         GET R NAME
          BX6   -X0*X2
          SA6       TS1+2     SAVE
          BX7    X0*X2
          MX2       12
          BX0    X7-X2
          ZR     X0,CRGP11A   IF ARG IS A FUNC RESULT 
          SA3    X1 
          LX3    59-44
          MI     X3,CRGP11A        IF *XMT* BIT SET 
          SA2       TS1       USE NON-XMIT REG DEFS 
          SX7    X2+4 
          SA7       TS1 
 CRGP11A  BSS       0 
          SX7       2 
          SA2    X1 
          UX0 B2,X2 
          SB3    T.DBL
          EQ  B2,B3,CRGP12    IF DBL WD 
          SB3    T.CPLX 
          EQ    B2,B3,CRGP12
          SX7       1 
 CRGP12   SA7       TS1+1 
          RJ     CHKARG      CHECK ARGUMENT TYPE
          RJ        CHKOFF    CHKOFF RL2 ENTRY
          SA2       TS1+2     GET NAME OF ARG 
          BX6    X2 
          SA6       PARAMS
          SA1       TS1 
          SA3    X1+DEFMD-1   GET CORRECT DEFINE MAC DESC 
          RJ        MACOUT
          RJ        CHKOFF
          SA1       TS1+1     DBL WD ARG- 
          SB2    X1-1 
          ZR     B2,CARGPORT
          SA2       TS1+2 
          SX6    X2+1 
          SA6       PARAMS
          SA1       TS1 
          SA3    X1+DEFMD+1 
          RJ        MACOUT
          RJ        CHKOFF
          ZR        CARGPORT
* 
* 
*     CRGP20 IF ,A POPPED OUT OF INTRINSIC FUN ARG LIST 
 CRGP20   SA1       RL2       SAVE LAST UNCHECKED R-LIST RESULT NAME IN 
          SA2       RNTBC                                    THE RNTB.
          SA3    X1+2         GET RN LINE 
          SA4    X1           GET TYPE
          SX7    X2+1         UP RNTBC (ARG MAX ALREADY CHECKED - CRGP7)
          MX0       60-16 
          BX6   -X0*X3
          SA6    X2+RNTB
          UX0 B2,X4 
          SB3    T.DBL
          SB4    T.CPLX 
          EQ  B2,B3,CRGP20A   IF DBL
          NE  B2,B4,CRGP20B   IF NOT CPX
 CRGP20A  MX0    1
          BX6    X0+X6       SET FLAG THAT ARG IS DOUBLE WORD 
          SA6    A6 
 CRGP20B  SA7       RNTBC 
          RJ     CHKARG      CHECK ARGUMENT TYPE
          RJ        CHKOFF
          EQ     CARGPORT 
          SPACE  1
*     ARGPO IF (A POPPED
 ARGPO    SA1       OP        IS OP=) - 
          SB2    EL.) 
          UX0 B3,X1 
          EQ  B2,B3,ARGP1     IF YES
          EERR      ERMSG29   NO MATCHING RP FOR ARG LIST 
 ARGP1    RJ        ARGP1RT 
          SA2    IXFNFG 
          SA1    EPOINT 
          ZR     X2,NEXTE    IF NOT IN AN I/O LIST
          SB2    EL.) 
          SA3    X1          E + 1
          UX0    X3,B3
          SB4    EL.( 
          LT     B3,B2,RTPRN4      IF E + 1 IS ID OR CON
          EQ     B3,B4,RTPRN4      IF E + 1  =  LEFT PAREN
          EQ     NEXTE
  
*         DEBUG PROCESSOR FOR FUNCTION TRACING
* 
 FN0.     SA1    DBGAPL+4    ADDR OF FUNC NAME IN SYMTAB
          SA1    X1 
          SA2    ARLPT
          BX6    X2 
          SA6    DBGAPL+4          SAVE BUFFER POINTER
          SA2    RL1
          SA3    RL2
          BX6    X2 
          LX7    X3 
          SA6    RL1TS
          SA7    RL2TS
          SA2    LASTR
          BX6    X2 
          SA6    LASTRTS
          MX0    60-18
          BX6    X0*X1             GET FUNCTION NAME
          SA2    FNTYP             GET FUNCTION TYPE
          MX7    0
          SB2    X2 
          SB3    T.DBL
          SB1    T.CPLX 
          EQ     B2,B3,FN1.        DBL WORD FUNCTION RESULT 
          EQ     B2,B1,FN1.        DBL WORD FUNCTION RESULT 
          MX7    10 
 FN1.     SA7    TS1
          BX1    X2+X6
          RJ     STRIP             CHECK FOR TRAILING $ IN NAME 
          SB1    1
          RJ     CONVERT           PLACE IN CONS TABLE
          BX6    X1 
          SA6    DBGAPL            BEGIN BUILDING ARGLIST TABLE 
          MX7    0
          SA7    DBGAPL+2 
          SX6    =8RBUGFUN
          SA6    DBGAPL+3 
          SA1    RL2TS
          MX2    0
          RJ     OTS         OUTPUT TEMP STORE
          LX3    30 
          BX6    X3+X2       30/CA(ST.), 30/ORD(ST.)
          SA1    DBGAPL      START OF ARGLIST TABLE 
          SA6    DBGAPL+1    SET UP FOR APLIST PROCESSOR
          SA2    =XN.AP 
          BX6    X2 
          SX7    X2+1 
          SA7    A2                UPDATED APLIST NUMBER
          RJ     IGCALL            GENERATE CALL MACROS 
          SA1    =8RBUGFUN
          SB7    *+1
          EQ     SYMBOL            WILL ALWAYS RETURN TO FOUND ADDRESS
          SX6    T.CGS             PLACE TYPE CGS IN SYMTAB WORD
          LX6    P.TYP                SO REFERENCE WONT APPEAR IN 
          BX7    X6+X2                THE REFERENCE MAP 
          SA7    A2 
          SB6    B0 
          SA2    STSORD 
          SX6    B0 
          SA6    IDORDLTS 
          SA6    A6+1 
          SB7    X2-1              FOR SINGLE LOAD
          SA5    ST.               IH OF ST.
          SA1    TS1               GET TYPE FLAG,  0 IF DBL 
          NZ     X1,FN3.
          SB7    B7-1              FOR DBL LOAD 
 FN3.     SA1    FNTYP             GET TYPE 
          LX1    60-4 
          BX6    X1 
          SA6    NAME+1            SET WORD FOR CALL
          RJ     FETCH             GENERATE LOAD(S) 
          SA1    RL2
          SA5    X1+2              LAST MACRO WORD
          MX0    60-16
          BX4    -X0*X5            RESULT NUMBER
          SA2    NARN              NEXT R NUMBER
          BX6    X2 
          LX7    X4 
          SA6    PARAMS            NARN 
          SA5    EQCOUNT
          SX5    X5 
          LX5    34 
          BX6    X5+X6             INSERT EQUAL SIGN COUNT
          SA6    LEFRN
          SA7    PARAMS+1          RESULT 
          SA3    XMIT 
          SX7    X2+1              INCREMENT R NUMBER 
          SB3    B0 
          SA1    TS1
          NZ     X1,FN4.           0 IF DBL 
          SA3    LEFRN
          MX0    1
          LX0    59 
          BX6    X0+X3
          SA6    A3 
          SA3    XMIT+1 
          SA7    PARAMS+2          NARN+1 
          SX6    X4+1 
          SA6    PARAMS+3          RESULT+1 
          SX7    X7+1              INCREMENT R NUMBER 
 FN4.     SX5    B3 
          SA7    A2 
          RJ     MACOUT            OUTPUT XMIT
          RJ     CHKOFF 
          SA4    DBGAPL+4 
          SA5    ARLPT             END OF FUNC BLOCK
          BX6    X4 
          SA6    A5                START=END
          RJ     DARLIST           FLUSH BUFFER 
          SA1    LASTR
          SA2    X1+2 
          MX0    60-16
          BX5    -X0*X2            R RESULT 
          SA3    RL2TS             FORMER RESULT MACRO
          SA4    X3+2 
          BX6    X0*X4
          BX6    X6+X5             INSERT NEW R NUMBER
          SA6    A4 
          BX6    X3 
          SA6    RL2               RESTORE NEW VALUE
          SA1    RL1TS
          SA2    LASTRTS
          BX6    X1 
          LX7    X2 
          SA6    RL1               RESTORE VALUE
          SA7    LASTR             RESTORE VALUE
          EQ     ARGP1RT
  
  
*         DEBUG FUNCTION PREPROCESSOR 
* 
 SARGLST  ENTRY. *
          SA1    FNAD 
          SA2    X1-1 
          SA1    X1 
          MX0    60-18
          BX6    X0*X1             GET FUNCTION NAME
          MX0    60-L.TYP 
          LX2    60-P.TYP 
          BX2    -X0*X2            GET FUNCTION TYPE
          BX1    X6+X2
          RJ     STRIP             CHECK FOR TRAILING $ IN NAME 
          SB1    1
          RJ     CONVERT           PLACE IN CONS TABLE
          BX6    X1 
          SA6    DBGAPL            START BUILDING ARGLIST TABLE 
          MX7    0
          SA7    DBGAPL+1 
          SX6    =8RBUGFNN
          SA6    DBGAPL+2 
          SA1    DBGAPL            START OF ARGLIST TABLE 
          SA2    N.AP 
          BX6    X2 
          SX7    X2+1              INCREMENT APLIST NUMBER
          SA7    A2 
          RJ     IGCALL            OUTPUT CALL MACRO
          SA1    =8RBUGFNN
          SB7    *+1
          EQ     SYMBOL            WILL ALWAYS RETURN TO FOUND ADDRESS
          SX6    T.CGS             PLACE TYPE CGS IN SYMTAB WORD
          LX6    P.TYP                SO REFERENCE WONT APPEAR IN 
          BX7    X6+X2                THE REFERENCE MAP 
          SA7    A2 
          EQ     SARGLST
          EJECT 
 ARGP1RT  DATA      0 
          SA1       FNAD      CHECK NO.OF ARGS
          SA3       ACNT
          SA2    X1-1 
          MX0    60-L.FARG
          LX2    60-P.FARG
          BX4    -X0*X2 
          IX5    X3-X4
          NZ     X4,ARGP2     IF NO.OF ARGS.IS OR HAS BEEN ESTABLISHED. 
          LX2    P.FARG-P.INF-1    IS INTRIN BIT SET
          NG     X2,ARGP10    IF YES (INTR FUN WITH NO ARG CNT SPECIFYD)
          LX2    P.INF-59 
          LX3    P.FARG 
          BX6    X2+X3
          SA6    A2           STORE 2ND WD OF SYMTAB ENTRY WITH NO.OF 
          ZR        ARGP3                                     ARGS SET
* 
 ARGP2    ZR     X5,ARGP3     IF NO. OF ARGS USED SAME AS ESTABLISHED NO
          LX2    P.FARG-P.LIB-1 
          NG     X2,ARGP5          IF BASIC EXTERNAL
          LX2    P.LIB-P.INF
          PL     X2,ARGP5A   IF NOT INTRINSIC 
 ARGP5    EERR   -ERMSG21    WRONG NO. OF ARGS FOR INT OR BEF FUNC
  
 ARGP5A   IDM    ERMSG36     INCONSISTENT ARGUMENT COUNT
  
 ARGP3    SA1    FNAD 
          SA2    X1-1 
          LX2    59-P.BEF 
          NG     X2,ARGP4     IF BASIC EXT
          LX2    P.BEF-P.INF
          NG     X2,ARGP10    IF INTR.
          SA1    FTRFLG 
          ZR     X1,ARGP3A   IF NOT DEBUG-TRACING THIS FUNCTION 
          RJ     FUNC8       STORE ANY FUNCTION RESULT ACROSS *BUGFNN*
          SA5    ARLPT
          BX6    X5 
          SA6    TS1         SAVE ARLIST POINTER
          RJ     SARGLST     GENERATE *RJ BUGFNN* 
          SA4    TS1
          BX6    X4 
          SA5    ARLPT
          SA6    A5          RESTORE ARLIST POINTER 
          RJ     DARLIST     FLUSH *RJ BUGFNN*
  
 ARGP3A   SA2    FNAD 
          SA3    SYM1              START OF SYMTAB
          IX2    X3-X2
          AX2    1                 IH OF FUNCTION 
          SA4    STAPLC 
          SA1    N.AP 
          SX6    X1+1 
          SA6    A1 
          SA3    CDCNT             LINE COUNT 
          RJ     GEFCM
          RJ        ARGP8CR 
          ZR        ARGP8A
  
 ARGP8CR  DATA      0 
 ARGP8C   SA1       SSFRSTB   SIZE OF FRSTB AT START OF THIS FUNC 
          SA2       SFRSTB    SIZE AT END OF FUNC 
          IX3    X2-X1
          ZR    X3,ARGP8CR    IF NO (MORE) FUNCS SAVED IN THIS ARG LIST.
          SA1    X2+FRSTB-1   GET LAST ENTRY
          SX6    X2-1 
          SA6       SFRSTB    REDUCE SIZE 
          SA4       NARN      X4=I1 (INTERMEDIATE RESULT 1) 
          MX0       60-16 
          BX7   -X0*X1        X7,P1(FINAL RESULT 1) 
          SA3       EXRL1 
          SA2       RNFIB     R NAME OF 1ST INSTR IN BASE 
          ZR     X3,ARGP8C1   IF NOT PROCESSING ** CALL 
          IX3    X7-X2
          PL     X3,ARGP8C1   IF THIS FUNC IS PART OF THIS ** 
          SA3       SFRSTB
          SX6    X3+1 
          SA6       SFRSTB
          ZR        ARGP8CR 
 ARGP8C1  BSS       0 
          BX6    X4 
          LX6    16 
          BX6    X6+X7
          MX0    60-18
          SA6    ARGP1TS+5         NARN AND RESULT
          SB2    -SLMACO
          MX3    1
          LX3    31 
          SB3    -XMITOP
          BX6    X3+X7
          PX6    B3,X6             FORM MACRO WORD
          SA6    ARGP1TS+4         MACRO WORD 
          SX3    3
          LX3    30 
          BX6    X3+X4
          PX6    B2,X6             FORM MACRO WORD
          SA3    ST.
          BX7    X3 
          SA6    ARGP1TS           MACRO WORD 
          LX1    60-16
          BX6    -X0*X1            TS ORD 
          SA7    ARGP1TS+1         IH OF ST.
          SA6    ARGP1TS+3         TS ORD 
          BX7    X4 
          SA7    ARGP1TS+2         NARN 
          LX1    59-58+16 
          SX6    X4+1 
          PL     X1,ARGP8B         IF NOT DBL 
          MX7    0
          SX6    X6+1 
 ARGP8B   SA7    ARGP1TS+7
          SA6    NARN 
          SB1    1
          WRITEW =XF.RLST,ARGP1TS,6      MACROS TO -RLIST-
          SA1    ARGP1TS+7
          SB5    1
          NZ     X1,ARGP8C
          SX1    1
          SA2    ARGP1TS
          SA3    ARGP1TS+2
          IX6    X2+X1             UP NARN IN MACRO WORD
          IX7    X3+X1             UP NARN IN MACRO 
          SA6    A2 
          SA7    A3 
          SA2    ARGP1TS+3
          SA3    ARGP1TS+4
          IX6    X2+X1             UP ST ORD
          IX7    X3+X1             UP NARN IN MACRO WORD
          SA6    A2 
          SA7    A3 
          SA2    ARGP1TS+5
          IX2    X2+X1             UP RESULT IN MACRO 
          LX2    60-16
          IX6    X2+X1             UP NARN IN MACRO 
          LX6    16 
          SA6    A2 
          WRITEW =XF.RLST,ARGP1TS,6      MACROS TO -RLIST-
          SB5    1
          EQ     ARGP8C 
  
 ARGP8A   BSS       0 
          SA1       FNAD      GET FNTYP 
          BX6    X1 
          SA6    DBGAPL+4          SAVE ADDR OF FUNC NAME 
          MX0    60-L.TYP 
          SA2    X1-1 
          LX2    60-P.TYP 
          BX7   -X0*X2
          SX6    X7-T.CGS 
          ZR     X6,ARGP15         BRANCH IF EXPONENTIAL FUNCTION 
 ARGP8D   SA7    FNTYP             SAVE FUNCTION TYPE 
          BX5    X7           X5=TYPE FOR MACOUT
          SA2       NARN
          BX6    X2 
          SA6       PARAMS    NAME OF RESULT OF FUN 
          SA6       FRN 
          SX6    X2+1 
          SA6       NARN
          SA3       DFRMD 
          RJ        MACOUT    OUTPUT REG DEFINE OP RN=X6
          RJ        CHKOFF
          SA3    FNTYP
          SX4    X3-T.DBL 
          ZR     X4,ARGP6     IF DBL WD FUN 
          SX4    X3-T.CPLX
          NZ     X4,ARGP7     IF SNGL WD FUN
 ARGP6    SA2       NARN
          BX6    X2 
          SA6       PARAMS
          SX7    X2+1 
          SA7       NARN
          SA3       DFRMD+1 
          RJ        MACOUT
          RJ        CHKOFF
          SA1       FRN 
          MX0       1 
          LX0       59
          BX6    X1+X0
          SA6       FRN 
 ARGP7    SA1       FRN 
          BX6    X1 
          SA5    EQCOUNT
          SX5    X5 
          LX5    34 
          BX6    X5+X6             INSERT EQUAL SIGN COUNT
          SA6       LEFRN 
          SA5       ARLPT     CALL DARLIST. FRLW AND ARLPT ARE BOUNDS OF
          SA4       FRLW        ARLIST OT SEND TO RLIST.
          SX7    X4 
          SA7       ARLPT 
          RJ        DARLIST 
*     RESET LASTR 
          SA1       ARLPT 
          SA2    X1+ARLIST    A2=ADR OF 1ST ENTRY OUTPUT BY DARLIST 
          SUB 
          PL     X2,ARGP7A    IF NOT NO-OPED
          BX2   -X2 
 ARGP7A   SB2    X2           B2=NO.WDS IN PRECEDING ENTRY
          SX6    A2-B2
          SA6       LASTR 
          SA2       FRN       FUNCTION RESULTNAME 
          SA5       FNTYP     FUN TYPE
          MX3       0         OUTPUT PSUEDO-OP TO ARLIST NAMING FRN AS -
          RJ        MACOUT                               AN OPERAND.
          SA1       RL2       TURN ON NO-OP BIT IN MACRO
          SA2    X1+2 
          MX0       1 
          BX6    X0+X2
          SA6    X1+2 
 ARGP21   SA1       EPOINT    IS NEXT E A ** -
          SB3    EL.DSTR
          SA2    X1 
          UX0 B2,X2 
          NE B2,B3,ARGP22     IF NOT
          SA1       ITFFG     IS THIS INTR FUN- 
          ZR     X1,ARGP22    IF NOT
          SA1       FRLW      SET UP START OF BASE IN ARLIST FOR ** OP
          SA3    SSFRSTB     COUNT OF FUNCTION RESULT SAVED 
          SX7    X1 
          BX6    X3 
          SA7       STBASE
          SA6    NSFR 
 ARGP22   MX6       0 
          SA6       ITFFG 
          SA1       OSPTR 
          MX0       60-3      RESET EMODE 
          SA2    X1+OPSTAK+1
          AX2       19
          BX6   -X0*X2
          SA6       EMODE 
          SA2    X1+OPSTAK    GET NO.OF WORDS TO MOVE TO FRLWBLOK 
          IX6    X1-X2        REDUCE OSPTR ACCORDINGLY
          SA6       OSPTR 
          SB2    X2-1         B2=NO.OF WORDS TO MOVE TO FRLW BLOK 
          SB3    B0 
          SB4       1 
 ARGP20   SA3    A2-B2        MOVE FROM OPSTAK TO FRLW
          BX6    X3 
          SA6    B3+FRLW
          SB2    B2-B4
          SB3    B3+B4
          NZ     B2,ARGP20    IF MORE TO MOVE 
          SA3    FRLW 
          MX6    1
          BX7    X6*X3       RECOVER FUNCTION TRACE FLAG
          SA2    FTRFLG 
          LX7    1
          SA7    A2 
          BX6    -X6*X3            IGNORE FUNCTION TRACE FLAG 
          SA6    A3 
          AX6    18 
          SA6    TYADR
          NZ     X2,FN0.     IF TO PROCESS DEBUG FUNCTION TRACING 
          ZR        ARGP1RT 
* 
*     ARGP4 IF BASIC EXT FUN (A POPPED
 ARGP4    SA1       FNAD      SET UP IH OF FUN
          SA2       SYM1
          IX6    X2-X1
          AX6       1 
          SA6       PARAMS    IH OF FUN 
          SA3       BEFMD 
          SA2    NARN 
          MX5    0
          RJ     MACOUT 
          RJ     CHKOFF 
          RJ     ARGP8CR
          EQ     ARGP8A 
  
*     ARGP10 IF INTRINSIC FUN (A POPPED 
ARGP10    LX2    -1              IF THE ARG COUNT IS 0 ITS A MAX OR MIN 
          SX7       10        SET INTR FUN FLG FOR ARGP21 
          MX0    60-L.FARG
          SA7       ITFFG 
          BX5   -X0*X2
          SA1       FNAD      GET MAC DESC WD 
          BX6    X1 
          SA6    DBGAPL+4          SAVE SYMTAB ADDRESS
          SA2    X1           GET NAME OF FUN IN E LIST FORMAT
          MX0    L.NAME 
          BX6    X0*X2
          AX6    P.NAME-6 
          SX2       1R        SET X2=BLANK
          BX6    X6+X2
          SA6       OP
          SX7    B0          INITIALIZE BIAS OF PARAMS
          ZR     X5,MXMNF 
          SB5    1
          SA2    RNTB-1      MOVE RNTB TO PARAMS
          SA1    RNTBC
 ARGP10A  SA2    A2+B5
          SX1    X1-1 
          SX6    X2 
          SA6    X7+PARAMS
          SX7    X7+B5
          SX6    X6+B5
          PL     X2,ARGP10B  IF NOT DBL WORD
          SA6    A6+B5
          SX7    X7+B5
 ARGP10B  NZ     X1,ARGP10A  IF MORE TO MOVE
          SA7    RNTBC
          SA2    TYADR
          SA4    X2                WORD 1 OF FUNCTION TABLE ENTRY 
          SA5    X2+1              2ND WORD OF ENTRY
          SA3    X2+3              4TH WORD OF ENTRY
          SX2    X5-1         SEE IF RNM TYPE FUNC
          NZ     X2,ARGP11A   IF NOT RNM TYPE 
          MX6       10
          SA6       RNMFG 
  
*         RNTBC = PARAMS INDEX TO STORE R NUMBER OF RESULT
*         X3 = MACRO DESCRIPTOR WORD FOR "MACOUT" 
  
ARGP11B   MX0    L.TYP
          SA2       FNAD
          BX6    X2 
          SA6    DBGAPL+4          SAVE ADDRESS OF FUNC NAME
          SA5    X2-1 
          BX5    X0*X5
          LX5    L.TYP
          SA4       RNTBC 
          SA2       NARN
          SB2    X5-T.DBL 
          BX6    X2 
          SA6    X4+PARAMS
          ZR     B2,ARGP12
          SB2    X5-T.CPLX
          NZ     B2,ARGP14   IF SINGLE WD RESULT
 ARGP12   SX6    X6+1 
          SA6    X4+PARAMS+1
 ARGP14   SX6    X6+1 
          SA6       NARN
          RJ        MACOUT    X2,X3,X5 ALL SET
          SA1       RNMFG     SEE IF RNM TYPE FUNC
          ZR     X1,ARGP21    IF NOT
          SA1       LASTR     SET XMT BIT IN ARLIST 
          MX6       0 
          SA2    X1 
          SA6       RNMFG 
          MX0       1 
          LX0       45
          BX7    X0+X2
          SA7    A2 
          ZR        ARGP21    GO RESTORE FRLW,EMODE,ETC., TO PREVIOUS FN
  
*         GET TYPE OF EXPONENTIAL FUNCTION
  
 ARGP15   SA1    EXPFNE            FUNCTION NAME AND TYPE 
          LX1    60-P.TYP 
          BX7    -X0*X1            EXP FUNC TYPE
          EQ     ARGP8D 
  
 ARGP11A  PL     X3,ARGP11B        IF THIS INTRIN DOESNT NEED SPECIAL 
*                                  PROCESSING 
          SA2    LASTR
          SB3    X3                JUMP ADDRESS OF PROCESSOR
          AX3    30 
          SA1    X2                ARLIST HEADER WORD 
          BX4    X1 
          SA3    X3                FETCH DEFAULT MACRO DESCRIPTOR 
          LX4    59-47             POSITION CONSTANT/VAR BIT
          JP     B3 
  
*         COMPL(WORD) - PASS ONLY ONE ARG IN RLIST
  
 ACOMPL   SX7    B5 
          SA7    A7          FORCE RNTBC TO BE 1
          EQ     ARGP11B
  
*         SHIFT(WORD,SC) - SPECIAL CASE CONSTANT SHIFT COUNT
  
 ASHIFT   SA5    RNTB+1            CORRECT PARAMS IF SHIFT WORD IS DBL
          SX7    B5+B5
          BX6    X5 
          SA7    RNTBC
          SA6    PARAMS+1 
          PL     X4,ARGP11B        IF 2ND ARG NOT CONSTANT
          RJ     NEWCON            GET THE CONSTANT 
          SX7    B5 
          SX6    X6                TRUNCATE CONSTANT
          SA7    RNTBC             SET INDEX FOR NRLN  STORE
          ZR     X6,ASHIFT1        IF SC = 0
          NG     X6,ASHIFT0        IF NEG COUNT 
          AX3    B5,X6
          ZR     X3,ASHIFT2        IF CONSTANT SHIFT OF + 1 
          SB4    X6-60
          ZR     B4,ASHIFT1  IF SC = 60 
 ASHIFT0  MX0    1
          BX5    X0*X6             GET SIGN OF CONSTANT 
          LX7    B5,X5
          AX5    59 
          BX6    X6-X5             ABS(SC)
          SA3    MD.CSFT+X7        CONSTANT SHIFT MACRO DESCRIPTOR
          SA6    PARAMS+2 
          SA6    RNMFG             INDICATE XMT NEEDED BEFORE STORE 
          SX0    X6-61
          MI     X0,ARGP11B  IF S.C. IN RANGE, ABS(S.C.) .LE. 60
          LX7    X3 
          SA7    MACDES 
          IDM    -ERMSG56    SHIFT ARG OUT OF RANGE 
          SA3    MACDES 
          EQ     ARGP11B
  
*         SHIFT(WORD,0) - RENAME THE RESULT 
  
 ASHIFT1  SB7    MCHMCB+4          RENAME OPCODE
          SA4    SLBMD             DESCRIPTOR WORD
          PX3    B7,X4
          EQ     ARGP11B
  
*         SHIFT(WORD,1) - GENERATE INTEGER ADD
  
 ASHIFT2  SA1    PARAMS 
          BX6    X1 
          SA6    A1+1 
          SA6    A1+2 
          MX7    0
          SA7    RNTBC
          SB7    MAC+32 
          SA4    SLBMD
          PX3    B7,X4
          EQ     ARGP11B
  
*         MASK(N) - SPECIAL CASE CONSTANT MASK COUNT
  
 AMASK    PL     X4,ARGP11B        IF NOT A CONSTANT MASK 
          RJ     NEWCON            GET THE CONSTANT 
          SX7    B0 
          SA7    RNTBC             SET PARAM STORE INDEX
          SX6    X6          TRUNCATE N 
          SA3    MD.MASKC    MACRO DESCRIPTOR 
          SA6    PARAMS+1    STORE N
          MI     X6,AMASK2   IF N .LT. 0
          SX0    X6-61
          MI     X0,ARGP11B  IF N IN RANGE,N .GE. 0 .AND. N .LE. 60 
 AMASK2   LX7    X3 
          SA7    MACDES 
          IDM    -ERMSG54    MASK ARG OUT OF RANGE
          SA3    MACDES 
          EQ     ARGP11B
  
*         MOD(I,J) - SEE IF J IS A POWER OF 2 
  
 AMOD     PL     X4,ARGP11B  IF SECOND ARG NOT CONSTANT 
          SA1    LASTR
          RJ     CHKP2
          SA3    MD.MOD 
          NZ     X7,ARGP11B  IF CON NOT A POWER OF 2
          SA3    MD.MODP2 
          SX5    60 
          IX6    X5-X6       MASK COUNT = 60-K
          SX7    B5 
          SA6    PARAMS+2 
          SA7    RNTBC       RESULT R-NUM = P2
          EQ     ARGP11B
  
*         RANF(0) - GET SYMTAB ORDINAL OF SEED
  
 ARANF    SYMBOL =8RRANDOM.        GET SYMTAB ORDINAL OF RANDOM. / RANN 
          SX0    V.COM
          BX6    X0+X1       SET COMMON BIT FOR OPT=2 USE/DEF INFO
          SA6    A1 
          SA3    WB.EXP 
          BX7    X3+X2             SET TYPE = CGD AND EXT BIT 
          SA7    A2 
          SA3    MD.RANF           MACRO DESCRIPTOR 
          SX6    B1 
          SX7    B5 
          SA6    PARAMS 
          SA7    RNTBC             SET INDEX FOR NRLN STORE 
          EQ     ARGP11B
  
*         LOCF(A) - CHANGE LAST LOAD TO A SET 
  
 ALOCF    SA2    A1+2        RLIST MACRO HEADER WORD
          SA3    IXFN.TAB 
          UX0    B2,X2
  
*         CHECK TO SEE IF LAST OP WAS A LOAD
  
 ALOCF1   SX4    B2+X3
          ZR     X4,ALOCF3         IF A MATCH 
          SA3    A3+B5
          NZ     X3,ALOCF1         IF MORE TO GO
          EERR   ERMSG.LF    BAD ARGUMENT TO LOCF 
  
*         LOCF(LOCAL OR COMMON SYMBOL OR ARRAY) - CHANGE TO SX MACRO
  
 ALOCF3   UX3    B3,X3
          PX6    B3,X0       CHANGE LOAD TO SET X MACRO 
          UX1    B2,X1       (B2) = TYPE OF RESULT
          PX7    B5,X1       RESET TYPE TO INTEGER
          SA7    A1 
          SA6    A2 
          MX6    0
          SA6    A1+1        CLEAR IH WORD
          SA3    A2+1        IH OF SYM , BASE IF EQUIVED
          SA5    SYM1 
          SX3    X3 
          LX3    1
          IX6    X5-X3
          MX0    1
          SA4    X6-1        WORDB
          LX0    1+P.LOCF 
          BX6    X4+X0       SET LOCF REF BIT IN WORDB
          SA6    A4 
          SB4    T.CPLX 
          SB3    T.DBL
          LT     B2,B3,ALOCF4      IF SINGLE PRECISION
          GT     B2,B4,ALOCF4      IF NOT DOUBLE OR COMPLEX 
          SA5    NRLN 
          SX6    X5-1              BACK OFF NRLN
          SA6    A5 
 ALOCF4   SA2    LASTR
          MX0    1
          SA1    X2 
          LX0    1+P.USED 
          BX6    X2          RL2 = LASTR
          SA6    RL2
          BX7    -X0*X1      CLEAR USED BIT 
          SA7    A1 
          RJ     FNDOP       FIND A NEW RL1 
          SA6    RL1
          EQ     ARGP21 
          SPACE  2
*         MXMNF -- PROCESSES MAX/MIN AND OTHER INTRINSIC FUNCTIONS WITH 
*         VARIABLE NUMBER OF ARGUMENTS.  SUCCESSIVE FUNCTION RMACROS ARE
*         PROCESSED, EACH WITH 2 ARGS, UNTIL ALL THE ARGS ARE PROCESSED.
*         THE FIRST RMACRO USES THE FIRST 2 ARGS FROM RNTB.  THE NEXT 
*         RMACRO USES AS ARGS THE RESULT FROM THE PRECEDING RMACRO AND
*         THE NEXT ARG FROM RNTB.  THIS CONTINUES UNTIL RNTB IS 
*         EXHAUSTED.
  
 MXMNF    RJ        IFTLU     GET INFO FOR THIS FUNC
          AX5    60-L.TYP 
          BX6    X5 
          SA6       TYPEWD
          SA1    RNTBC
          SX6    X5-T.DBL 
          AX1    1
          BX7    X3 
          SA7       FMADR     FINAL-MACRO ADR 
          SA6    FMADR+1
          NZ     X1,MXMN1    IF AT LEAST 2 ARGS 
          EERR   -ERMSG21    WRONG NO. OF ARGS FOR INT OR BEF FUNC
  
 MXMN1    SA1    RNTB 
          SB5    1
          SX7    B5 
          SX1    X1          1ST ARG
          SA7    RNCNT       INITIALIZE TO 1
  
*         MXMN2 - MXMN5 CONSIST OF LOOP TO OUTPUT RMACRO
  
 MXMN2    SA3    FMADR+1
          SA4    RNCNT
          SB5    1
          SA5    TYPEWD 
          BX6    X1          1ST ARG
          SX7    X4+B5       INCREMENT RNCNT
          SA6    PARAMS 
          NZ     X3,MXMN3    IF NOT DBL WORD
          SX6    X6+B5       UPDATE 1ST ARG 
          SA6    A6+B5
 MXMN3    SA1    X4+RNTB     2ND ARG
          SX6    X1 
          SA6    A6+B5
          NZ     X3,MXMN4    IF NOT DBL WORD
          SX6    X6+B5       UPDATE 2ND ARG 
          SA6    A6+B5
 MXMN4    SA2    NARN 
          SA7    A4          UPDATE RNCNT 
          BX6    X2 
          LX7    X2 
          SA6    A6+B5
          SA7    ARN         1ST ARG FOR NEXT MACRO 
          NZ     X3,MXMN5    IF NOT DBL WORD
          SX6    X6+B5       UPDATE RESULT
          SA6    A6+B5
 MXMN5    SX6    X6+B5       UPDATE NARN
          SA1    FMADR
          SA6    A2 
          SA3    X1 
          RJ        MACOUT    (X5 CAN CONTAIN GARBAGE)
          SA1       RNTBC     GET NO.OF WDS IN RNTBC
          SA2       RNCNT     GET NO.OF WDS MOVED FROM RNTB 
          IX3    X2-X1
          PL     X3,MXMN8     IF NO MORE ARGS 
          RJ        CHKOFF    CHKOFF LAST MX/MN MAC 
          SA1    ARN         1ST ARG
          EQ     MXMN2
  
*         IF THE RESULT OF THE FUNCTION IS OF A DIFFERENT TYPE THAN THE 
*         ARGS, A TYPE CONVERSION RMACRO MUST BE OUTPUT SINCE THE 
*         FUNCTION RMACRO OUTPUT HAVE BEEN ASSUMED TO BE OF THE SAME
*         TYPE AS THE ARGS.  PRESENTLY THESE CONVERSIONS ARE ONLY OF THE
*         SINGLE TYPE; E.G. INTEGER TO REAL, REAL TO INTEGER. 
  
 MXMN8    SA2       FMADR 
          LX2    30 
          SA3    X2 
          NG     X3,MXMN10    IF NO MODE CHANGE NEEDED. 
          RJ        CHKOFF    CHK LAST MX MN MAC
          SA1    ARN
          SA2    NARN 
          SB5    1
          BX6    X1 
          SX7    X2+B5
          SA6    PARAMS 
          SA5    TYPEWD 
          BX6    X2 
          SA7    A2          UPDATE NARN
          SA1    FMADR
          SA6    A6+B5
          LX1    30 
          SA3    X1          MACRO DESCRIPTOR 
          RJ     MACOUT      X2,3,5 INITIALIZED 
 MXMN10   SA1       JNEXTE
          BX6    X1 
          SA6       ARGP1RT 
          ZR        ARGP21
          TITLE              EXPONENTIAL PROCESSING 
*     EXPOP 
*         HERE IF ** POPPED FROM OPSTAK 
 EXPOP    SA2    OP          GET OP BEING SCANNED 
          SB1    EL.DSTR
          UX2    B2,X2
          NE     B1,B2,EXP0  IF OP .NE. **
          USASDM ERMSG59     A**B**C IS NON ANSI
          SA2    OSPTR
          BX6    X2          RESTORE X6 TO CONTENTS BEFORE USASDM CLLL
  
 EXP0     SA2    X6+OPSTAK   GET STBASE 
          SX6    X6-1         REDUCE OSPTR 1 MORE 
          SA6       OSPTR 
          SX7    X2 
          AX2       18        SAVE SFRSTB AT START OF **
          BX6    X2 
          SA6       EXPNSF
          SA7       EXPSTB
          SA4    RL1
          SA3    RL2
          SA1    X4 
          SA2    X3 
          UX0    B1,X1
          SB7    T.OCT
          UX7    B2,X2
          ZR     B1,MOP1     ERROR IF BASE LOGICAL
          ZR     B2,MOP1     ERROR IF EXPON LOGICAL 
          SB3    T.INT
          LT     B1,B7,EXP1  IF BASE NOT OCT OR HOLL
          PX6    B3,X1       BASE CONVERTED TO INT TYPE 
          SA6    A1 
          SB1    B3 
  
 EXP1     LT     B2,B7,EXP2  IF EXPON NOT OCT OR HOLL 
          PX6    B3,X2       EXPON CONVERTED TO INT TYPE
          SA6    A2 
          SB2    B3 
  
*         FIRST CHECK SPECIAL-CASE-EXPONENTIATION 
  
 EXP2     MX6    0           CLEAR FLAG FOR ADJUSTING TYPE OF RESULT
          SX7    B1-1 
          LX2    59-47
          SA6    EXPCON 
          SA7    TS1         TYPE-1 OF RL1
          PL     X2,EXP3B    IF EXPON IS NOT A CONST
          SB6    T.REAL 
          GT     B2,B6,EXP3B IF EXPON NOT INT OR REAL 
          LT     B2,B6,EXP2B IF EXPON IS INT
  
*         CHECK IF EXPONENT IS FLOAT(N), N AN INTEGER 
  
          SA1    A2          FWA OF ARLIST FOR EXPON
          RJ     NEWCON 
          MI     X6,EXP3BA   IF NEG CONST 
          ZR     X6,EXP3BA   IF CONST 0 
          UX4    B1,X6
          LX5    B1,X4       INT VALUE IF EXPON IS FLOAT(N) 
          PX3    X5 
          NX4    X3 
          BX0    X6-X4
          NZ     X0,EXP3BA   IF EXPON NOT FLOAT(N)
          BX6    X5 
          AX5    17 
          SA6    EXPCON      TEMP STORE FOR CONST EXPON 
          NZ     X5,EXP3BA   IF N\400000B 
          SA3    RL1
          SB6    T.REAL 
          SA2    X3 
          UX0    B2,X2
          GE     B2,B6,EXP2A IF BASE IS NOT INT 
          MX0    1
          BX6    X0+X6       SET FLAG FOR RESULT IS INT, S/B REAL 
          SA6    EXPCON 
  
 EXP2A    SX5    X6          PARAMETER FOR STCON
          SX6    773B 
          BX7    X3          SWITCH (RL1) INTO (RL2) FOR STCON CALL 
          SA6    BSAV        TREAT THIS CONST AS NORMAL 
          SA7    RL2
          RJ     STCON       CREAT ARLIST FOR CONST N 
          SA3    RL1
          SA4    RL2
          SB6    T.REAL 
          SA1    X3 
          SA2    X4 
          UX0    B1,X1
          SA5    EXPCON 
          EQ     EXP2C
  
*         EXPON IS CONST INTEGER
  
 EXP2B    SA3    A2+2 
          SB7    -SETMC 
          LX2    47+1        RESTORE ARLIST HDR WORD FOR EXPON
          UX0    B3,X3
          NE     B3,B7,EXP3B IF CONST\400000B 
          SA5    A2+4 
  
*         CHECK FOR  C**2 OR D**2 
  
 EXP2C    LE     B1,B6,EXP2F IF BASE IS INT OR REAL 
          SX6    B1-T.CPLX
          SA4    EXPCON 
          NZ     X6,EXP2D    IF BASE IS NOT COMPLEX TYPE
          ZR     X4,EXP2D    IF EXPON NOT FLOAT(N)
          EERR   ERMSG33     FATAL WHEN EXPON OF C NOT INTEGER
 EXP2D    SX0    X5-2 
          NZ     X0,EXP3B    IF EXPON IS NOT 2
          SA3    OP 
          SB4    EL.DSTR
          UX0    B3,X3
          NE     B3,B4,EXP2E IF THIS ** NOT POPPED BY **
          SA4    EXPNSF 
          SA3    EXPSTB 
          BX6    X4 
          LX7    X3 
          SA6    NSFR 
          SA7    STBASE 
  
*         CHANGE C**2 TO C*C OR D**2 TO D*D 
  
 EXP2E    SX7    A1          CHANGE EXPON  TO LOAD OF C OR D
          BX6    -X2
          SA7    RL2
          SA6    A2          NOOP ORIGINAL RL2 (EXPON)
          SA3    OSPTR
          SA5    MLTEOP      INSERT * IN  OPSTAK
          SX7    X3+1 
          BX6    X5 
          SA7    A3 
          SA6    X3+OPSTAK+1
          EQ     POP1 
  
*         OUTPUT INLINE EXPONENTIATION FOR I**K, X**K, K .LT. 17
  
 EXP2F    SB2    17          MAX INLINE EXP+1 
          SB3    X5          VALUE OF CONST POWER 
          SB4    1
          GE     B3,B2,EXP3B IF EXPON\ 17 
          LE  B3,B4,EXP3B     IF @1 
  
*         OUTPUT SPECIAL MACRO FOR INLINE EVALUATION OF EXPONENTIAL 
  
          SX5    B1          TYPE OF RESULT 
          BX6    -X2         NO-OP CONSTANT 
          SA6    A2 
          SX7    B3 
          SA7    PARAMS+2    K1 = EXPONENT
          SX0    X5-T.INT 
          SX6    OC.IM
          ZR     X0,EXP3A1   IF TYPE = INTEGER
          SA2    =XROPFLAG
          SX6    OC.FM
          LX2    1R*
          PL     X2,EXP3A1   IF MULTIPLICATION NOT ROUNDED
          SX6    OC.RFM 
 EXP3A1   SA1    RL1
          SA2    NARN 
          SA6    PARAMS+3    K2 = OPCODE
          SX7    X2+1 
          SA7    A2          NRLN = NRLN + 1
          BX6    X2 
          SA6    PARAMS      R1 = NRLN - 1
          MX0    1
          SA4    X1 
          LX0    1+45 
          BX7    X0+X4       SET USED BIT FOR RL1 
          SA7    A4 
          SA4    X1+2 
          MX0    -R1.RIL
          BX7    -X0*X4      R2 = RI OF OPERAND 
          SA7    PARAMS+1 
          SA3    EXPIN
          RJ     MACOUT      OUTPUT INLINE ** MACRO 
          RJ     FNDOP
          SA6    RL1
          SA4    EXPCON 
          PL     X4,EXP3A2   IF TYPE OF RESULT NEED NOT BE ADJUSTED 
          USASDM ERMSG42     NON-ANSI IF I**FLOAT(N)
          SA5    RL2         RESULT INT, S/B REAL 
          SB5    T.REAL 
          RJ     MODCH
          SA6    RL2
 EXP3A2   SA1    OP          HERE TO EXP3B TO ATKE SPECIAL ACTION IF
          UX0 B2,X1               THISS ** POPPED BY ** 
          SX2    B2-EL.SLASH TEST WHETHER OP=/
          SB3    EL.DSTR
          NE  B2,B3,EXP3AB    IF THIS INLINE ** NOT POPPED BY **
          SA1       EXPNSF
          SA2       EXPSTB
          BX6    X1 
          LX7    X2 
          SA6       NSFR
          SA7       STBASE
 EXP3AB   BSS       0 
          SA1    EPOINT 
          SB1    X1+1 
          NZ     X2,CMPARE   IF OP IS NOT / 
          ZR     DIVX 
* 
 EXP3BA   BX6    X1          RESTORE ARLIST HDR WORD NOPED BY NEWCON
          SA6    A1 
* 
* 
 EXP3B    SA1       RL1       SAVE RL1 AND RL2 FOR THIS ** OP 
          SA2       RL2 
          AX6    B0,X1
          BX7    X2 
          SA6       EXRL1 
*  (EXRL1 ALSO NOW ACTS AS FLAG FOR FUNC5RT. IF REACH THIS POINT, MUST
*   ALWAYS GET TO EXP10 IF FINISH EXPRESSION.)
          SA7       EXRL2 
          SA1       SFRSTB    SEE IF OPDS ADDRESS A SAVED FUNCTION RSLT 
*                              (IT COULD ONLY BE THE LAST FUNCT SAVED.) 
          ZR     X1,EXP3E     IF NO PREVIOUS FUNCS SAVED
          SA3    X6+2         GET RL1 NAME
          SA4    X1+FRSTB-1   GET LAST FUNC RESULT SAVED
          MX0       60-16 
          BX3    X3-X4
          SA2       RL2 
          BX5   -X0*X3
          SA3    X2+2 
          NZ     X5,EXP3C     IF RL1 NOT NAME OF SAVED FUNC 
*     HERE: OUTPUT LOAD OF TS VALUE SAVED FOR RL1 OPD 
          SA1       RL1 
          SA2    X1 
          BX6   -X2 
          UX0 B2,X2 
          SA6    X1           NO-OP THE RL1 ENTRY 
          RJ        FFRTS     OUTPUT FETCH OF SAVED FUNC.  GO WITH B2=
*          TYPE AND X4=FRSTB ENTRY.  RETURN AFTER OUTPUT THE INSTR
          SA1       RL2 
          SA2       EXRL2 
          BX6    X1 
          AX7    B0,X2
          SA6       EXRL1 
          SA6       RL1 
          SA7       RL2 
          ZR     EXP3E
* 
* 
 EXP3C    BX3    X3-X4
          BX5   -X0*X3
          NZ     X5,EXP3E    IF RL2 NOT A SAVED FUNC
          SA1       RL2       OUTPUT FETCH(SEE SEQUENCE ABOVE)
          SA2    X1 
          BX6   -X2 
          UX0 B2,X2 
          SA6    X1 
          RJ        FFRTS 
          SA1       RL2 
          BX6    X1 
          SA6       EXRL2 
 EXP3E    BSS       0 
          SA1       RL1       SET UP FOR POINT TO ** FUNC NAME
          SA2       RL2 
          SA3    X1 
          SA4    X2 
          UX1 B3,X3 
          UX2 B2,X4           B2=TYPE OF POWER
          SX1    B3-1         X1=TYPE-1 OF BASE 
          SX2    B2-1 
          LX1       2 
          BX3    X1+X2     X3:B3,2=BASE TYPE-1, B1,0=POWER TYPE-1 
          SA1    X3+XPNMT 
          BX6    X1 
          SA6       EXPFNE
          NZ     X1,EXP5
          EERR      ERMSG33   CMPX BASE ** NON-INT
 EXP5     LX6       59-48 
          PL     X6,EXP5A     IF AN ASA COMB
          USASDM ERMSG42         NON-USAS EXPONENTIATION COMBINATION. 
          SA1    EXPFNE            REFETCH NAME 
  
 EXP5A    SA4    CBNFLG 
          ZR     X4,EXP5B          IF CALL BY VALUE 
          SX2    1R$-1R.
          LX2    18 
          IX1    X1+X2             CHANGE . TO A $
  
 EXP5B    SYMBOL
          SA3    WB.EXP            WORD B BITS
          SB7    0
          NZ     B7,EXP7           IF NOT THE FIRST TIME
          SA4    CBNFLG 
          SX7    B5 
          LX7    P.LIB             SET LIB FLAG 
          IX3    X3+X7
          SX5    B5 
          ZR     X4,EXP6           IF CALL BY VALUE 
          MX5    0
 EXP6     LX5    P.BEF
          IX3    X3+X5
          BX7    X3+X2             SET WORD B BITS
          SA7    A2 
          SX0    V.FUN
          BX6    X0+X1
          SA6    A1                UPDATE SYMTAB ENTRY
  
 EXP7     SX7    A1 
          SA7    NAMFWA            SAVE ADDR OF SYMTAB ENTRY
          RJ     FUNC5RT
          SA1       EXRL1     SET UP BASE AS NEXT ARG.  PUT ITS ADR IN -
          BX6    X1           -RL2
          SA6       RL2 
          RJ        FNDOP 
          SA6       RL1 
          SA1      CBNFLG 
          ZR       X1,NOTINTM  JUMP IF NORMAL MODE
          SA1    NARN            DECREMENT NARN IN CASE THIS IS A 
          SA2    EXRL1             POINTER TO BASE OF **
          BX6    X1 
          SA3    X2                HEADER WORD OF MACRO 
          SA4    X2+2              FIRST WORD OF MACRO
          SA6    =SSAVENARN 
          MX0    60-16
          SB2    T.DBL
          BX1    -X0*X4            GET R NUMBER OF BASE MACRO 
          SB3    T.CPLX 
          UX0    B1,X3             TYPE OF BASE TO B1 
          SX6    X1+2              ASSUME DOUBLE WORD BASE
          EQ     B1,B2,EXP11
          EQ     B1,B3,EXP11
          SX6    X6-1              ADJUST FOR SINGLE WORD BASE
 EXP11    SA6    NARN 
NOTINTM   BSS      0
          RJ        CARGPORT
          SA1      CBNFLG 
          ZR       X1,NOTINAG 
          SA1    SAVENARN 
          BX6    X1 
          SA6    NARN              RESTORE SAVED R VALUE
NOTINAG  BSS       0
          SA2    FTRFLG 
          BX7    X2 
          SA7    EXPA        SAVE CURRENT FUNCTION TRACE FLAG 
          MX7    0
          SA7    A2          TURN OFF FUNCTION TRACING FOR ** 
          SA2       EXRL2 
          AX7    B0,X2
          SA7       RL2 
          RJ        FNDOP 
          SA6       RL1 
          RJ        CARGPORT
          SA1       EXPSTB
          BX6    X1 
          SA6       FRLW      FIRST RLIST WORD (ORDL OF-) 
          SA2       OSPTR     CHANGE OSPTR TO POINT BEFORE THE (A ,A OPS
          SX6    X2-2 
          SA6       OSPTR 
          SA1       EXPNSF
          BX7    X1 
          SA7       SSFRSTB 
          RJ        ARGP1RT 
          SA4    EXPCON 
          PL     X4,EXP12    IF TYPE OF RESULT NEED NOT BE ADJUSTED 
          USASDM ERMSG42     NON-ANSI IF I**FLOAT(N)
          SA5    RL2         RESULT INT, S/B REAL 
          SB5    T.REAL 
          RJ     MODCH
          SA6    RL2
 EXP12    BSS    0
          MX6       0 
          SA6       EXRL1     CLEAR FUNC5RT FLAG
          SA1       OP        HERE TO EXP10A TO TAKE SPECIAL ACTION IF
          UX0 B2,X1               THISS ** POPPED BY ** 
          SA1    EPOINT 
          SB1    X1+1 
          SX2    B2-EL.SLASH
          ZR     X2,DIVX     IF OP=/
          SB3    EL.DSTR
          SA1    EXPA 
          BX6    X1 
          SA6    FTRFLG      RESET FUNCTION TRACE FLAG
          NE  B2,B3,CMPARE    IF THIS ** NOT POPPED BY ** 
          SA1       EXPNSF
          SA2       EXPSTB
          BX6    X1 
          LX7    X2 
          SA6       NSFR
          SA7       STBASE
          ZR        CMPARE    NORMAL EXIT FROM EXPOP CODING 
  
 EXPA     BSS    1           HOLD FTRFLG ACROSS CARGPORT/ARG1PRT
          TITLE 
*     COMMA FROM EJTB 
 COMMA    SA3    IXFNFG 
          NZ     X3,CMMA2    IF IN IXFN MODE
  
 CMMAB    RJ     SSERR3 
  
 CMMA2    BSS    0
          SA1       EMODE     ARE WE IN EXPRESSION MODE:  
          SB2    X1-1 
          ZR     B2,CMMA1     IF YES (MUST BE COMPLEX CONST.) 
          SB2   X1-4          ARE WE IN SUBS MODE-
          NZ     B2,CMMA3     IF NO 
          SA1    CC           GET COMMA CNT 
          SA2    DIMINF       GET DIMENSIONALITY
          SX6    X1+1 
          AX2    57 
          SA6    CC           CC NOW=NO.OF SUBS.EXPS.SCANNED
          IX1    X6-X2        IS CC< DIMENSIONALITY:  
          NG     X1,CMMA4     IF YES
          EERR      ERMSG28   TOO MANY SUBSCRIPT EXPRS. 
 CMMA4    SA1    X6+CMASUB-1  X6=1 OR 2.  LOAD ,S1 OR ,S2 OP. 
          BX6    X1 
          SA6    OP 
          ZR        CMPARE
*     CMMA3 IF , IN ARG.MODE
 CMMA3    RJ     SSERR3      SIMPLE SYNTAX CHECKING 
          SA1    ARGCMA 
          BX6    X1 
          SA6    OP 
          ZR        CMPARE
*     CMMA1 IF COMMA IN NORMAL EXPR MODE.  MUST BE IN COMPLEX CONST 
 CMMA1    BSS       0 
          SA2    ARORD
          SA1    FNAD 
          SB3    EL.( 
          SA4    B1+2        SKIP OVER CONST
          UX0    B4,X4
          EQ     B4,B3,CMMA6 IF FOUND LEFT PAREN
          SA4    A4+1        ALLOW FOR SIGN PRECEDING CONST 
          BX0    X1+X2
          UX4    B1,X4
          EQ     B1,B3,CMMA5 IF LEFT PAREN FOUND
          SA2    IXFNFG 
          NZ     X0,CMMA1A   IF IN FUNC OR ARRAY
          NZ     X2,CMPARE   IF IN IXFN MODE
          EQ     CMMA1A 
  
 CMMA5    SB2    EL.MINUS 
          NE     B4,B2,CMMA6 IF NOT U-
          SA2    OSPTR
          SX7    X2-1        REMOVE U-
          SA7    OSPTR
 CMMA6    SB5    1
          CALL   CFCD        CHECK FOR COMPLEX DATA 
          SA3    IXFNFG 
          ZR     X0,CMMA7    IF CPLX CONST
          NZ     X3,CMPARE   IF IN IXFN MODE
          EQ     CMMA1A      ERROR IF NOT CPLX CONST
  
 CMMA7    BX6    X1 
          LX7    X2 
          SA6    CONST
          SA7    CONST+1
          SA3    EPOINT      POINTS PAST )
          SB2    EL.ID
          SA1    X3 
          UX0    B1,X1
          GE     B2,B1,CMMA1B IF NEXT E IS ID OR CONST
          SB2    EL.( 
          EQ     B2,B1,CMMA1B IF NEXT E IS (
          SA1       RL2       NO-OP LOAD OF 1ST REAL CONST
          SA2    X1 
          BX6   -X2 
          SA6    X1 
          SA1       RL1       RESET RL2 
          BX6    X1 
          SA6       RL2 
          RJ        FNDOP 
          SA6       RL1 
          SA1       OSPTR     REMOVE (E AND SAVED ARLPT FROM OPSTAK 
          SX7    X1-2 
          SA1    X1+OPSTAK    RESTORE PREVIOUS MODE 
          MX0       60-3
          AX1       19
          BX6   -X0*X1
          SA6       EMODE 
          SA7       OSPTR 
          SX6    T.CPLX 
          ZR        CON4
* 
 CMMA1A   EERR      ERMSG30 
  
 CMMA1B   SX6    X3-1        MOVE EPOINT SO ID, CON, OR ( WILL BE LISTED
          SA6    EPOINT 
          EERR   ERMSG25     ) FOLLOWED BY ID, CON, OR (
          TITLE              SUBSCRIPT PROCESSING 
* 
*     CS1PO IF COMMA-AFTER SUBSC.-NO. 1 POPPED OUT
 CS1PO    SA5    RL2          IS LAST SUBS.RESULT TYPE INT: 
          SA2    X5 
          SB5    T.INT
          UX0 B2,X2 
          EQ  B2,B5,CS1P1     IF YES
          RJ        MODCH     CONVERT TO TYPE INT.
          SA6    RL2          STORE NEW START ADR.
 CS1P1    SA5    RL1          IS R(*-2) INT:  
          SA2    X5 
          SB5    T.INT
          UX0 B2,X2 
          EQ  B2,B5,CS1P2     IF YES
          RJ        MODCH 
          SA6    RL1          STORE NEW RL1 
 CS1P2    SX5    1            RN+1=1 TO ARLIST
          MX7    0
          SA7    BSAV 
          RJ     STCON             (A MXI 59 INSTRUCTION WILL BE FORMED)
          SX6    MAC+32            ADD A NEGATIVE ONE 
          SX5    T.INT
          SA6    SMACD
          RJ        INGEN 
          SA5    DIMINF 
          LX5    3            IS 1ST DIMEN CONSTANT:  
          NG     X5,CS1P3     IF NOT
 CS1P5    AX5       3 
          SX7    773B 
          SA7    BSAV              MAKE SURE NO SPECIAL CONSTANT FORMED 
          RJ     STCON
 CS1P4    SX6    MPY.INT
          SX5    T.INT
          SA6    SMACD
          RJ     INGEN
          SX6       MAC+32    INT +.
          SX5    T.INT
          SA6    SMACD
          RJ     INGEN
          ZR        CMPARE
* 
*     CS1P3 IF 1ST DIMEN VARIABLE 
 CS1P3    MX0    60-18        GET SYMTAB ENTRY FOR 1ST DIMEN.TO GET ORD 
          AX5    3                           OF DIMEN.IN ARG.LIST.
          BX1    -X0*X5       X5=DIMIN= 
          RJ        DALV
          ZR        CS1P4 
* 
* 
*     CS2PO IF COMMA-AFTER SUBSC.-NO. 2 POPPED OUT
 CS2PO    SA5    RL2          IS LAST SUBS RESULT TYPE INT: 
          SA2    X5 
          SB5    T.INT
          UX0 B2,X2 
          EQ  B2,B5,CS2P1     IF YES
          RJ        MODCH     CONVERT TO TYPE INT 
          SA6    RL2          STORE NEW RL2 
 CS2P1    SX5    1
          MX7    0
          SA7    BSAV              ALLOW SPECIAL CONSTANT 
          RJ     STCON             (A MXI 59 WILL BE FORMED)
          SX6    MAC+32            ADD A NEGATIVE ONE 
          SX5    T.INT
          SA6    SMACD
          RJ        INGEN 
          SA5    DIMINF 
          LX5    3
          NG     X5,CS2P2     IF I IS VARIABLE
          AX5    3
          SX7    773B              INHIBIT SPECIAL CONSTANTS
          SA7    BSAV 
          RJ     STCON
 CS2P4    SX6    MPY.INT
          SX5    T.INT
          SA6    SMACD
          RJ        INGEN 
          SA5    DIMINF 
          SB2       4 
          LX4    B2,X5
          AX5       18-3
          PL     X4,CS1P5     IF 2ND DIM IS CONST.
          ZR        CS1P3 
 CS2P2    MX0    60-18
          AX5    3
          BX1    -X0*X5 
          RJ        DALV
          ZR        CS2P4 
* 
* 
* 
*     SUBPO IF SUBSCRIPT LEFT PARENS (S POPPED OUT
 SUBPO    SA1       OP
          SA5    RL2
          UX0 B2,X1 
          SB3    2            2=CODE FOR )
          EQ  B2,B3,SUBP3     IF (S WAS POPPED BY R.P.
          EERR   ERMSG11      ILLEGAL SUBS. 
 SUBP3    SA1    X5 
          SB5    T.INT
          UX0 B2,X1 
          EQ B2,B5,SUBP4      IF TYPE OF SUBS.VALUE IS INT. 
          RJ        MODCH     CONVERT TO INT
          SA6    RL2
 SUBP4    SA1    ARORD        IS ARRAY TYPE DBL OR CMPX:  
          MX0    60-L.TYP 
          BX6    X1 
          SA6    IDORDLTS 
          LX1    1
          MX7    0
          SA7    TS1               SET TYPE FLAG
          SA7    IDORDLTS+1 
          SA2    SYM1 
          SB2    X1+1         GET 2ND WD OF ENTRY 
          SB2    -B2
          SA3    X2+B2        LOAD 2ND WD OF SYMTAB ENTRY 
          SA4    A3+1         LOAD 1ST WD 
          BX7    X4 
          SA7       NAME
          BX7    X3 
          LX3    60-P.TYP 
          SA7       NAME+1    USED BY FETCH 
          BX4    -X0*X3 
          SB4    T.DBL
          SB3    X4 
          MX0    60-L.LVL 
          LX7    60-P.LVL 
          BX4    -X0*X7            OBTAIN LEVEL NUMBER OF VARIABLE
          SB6    X4-3 
          NZ     B6,SUBP4A         NOT A LEVEL 3 ARRAY
          SA3    EPOINT 
          SA4    X3 
          UX0    X4,B2
          SB2    B2-LOWOP 
          PL     B2,LVLERR1        NOT A STAND-ALONG ARGUMRNT 
SUBP4A    BSS    0
          MX6      59 
          SA6      CA        CA=-1
          SB2    T.CPLX 
          EQ  B4,B3,SUBP5     IF TYPE DBL 
          NE  B2,B3,SUBP6     IF NOT TYPE CMPX
 SUBP5    SX6    -2           SET CA=-2 
          SA6    CA 
          SA6    TS1               SET NONZERO FOR DBL WRD TYPE 
          SA1    RL2          DBL RESULT OF IX.FN.CALC. 
          BX7    X1 
          SX6       MAC+31+1  INT + 
          SA7    RL1
          SX5    T.INT
          SA6    SMACD
          RJ        INGEN 
 SUBP6    SA3    RL2
          SA5    X3+2 
          LX6    X5 
          SA6    SVRL2       RESULT OF SUBSCRIPT CALCULATION
          RJ     CHKOFF 
          SB7       SUBP7     RETURN ADR.FROM EQUIVR IF NOT EQUIVED 
          RJ        EQUIVR
          SA1       CA        HERE IF EQUIVALENCED ARRAY
          IX6    X6+X1        ADD BIAS TO CA
          SA7       ARORD     STORE BASE ORDINAL
          SA6       CA
 SUBP7    BSS       0 
          SA2    DFLAG
          ZR     X2,SUBP7.         BRANCH IF NOT IN DEBUG MODE
          SA3    IXFNFG 
          NZ     X3,SUBP7.         IF IN AN I/O LIST
          SA1    ALLARR 
          NZ     X1,TALARR         BRANCH IF UNCONDITIONAL TRACING
          SA2    NAME+1            WORD 2 OF SYMTAB ENTRY 
          LX2    60-P.DIF          SHIFT DEBUG BITS 
          MX0    60-L.DIF 
          BX7    -X0*X2            MASK OUT DEBUG BITS
          SX6    X7-DV.ARR         IS ARRAY CHECKING TO BE DONE 
          SX5    X7-DV.AAS         IS ARRAY/STORE CHECKING TO BE DONE 
          ZR     X5,TALARR         IF YES 
          NZ     X6,SUBP7.         IF NOT 
 TALARR   RJ     ARR               SUBSCRIPT CHECK PROCESSOR
 SUBP7.   SA1    SVRL2
          SA2    CA 
          SB6    X1          RF NAME
          SB7    X2 
          SA5    ARORD
          RJ     FETCH
          SA1    OSPTR        GET PREVIOUS MODE SETTING FROM (S 
          SA2       X1+OPSTAK+1   GET  (S WORD FROM STAK
          MX0    60-3 
          AX2    19 
          SX7    X1-4         UPDATE FOR 4 MORE WDS 
          SA7       OSPTR 
          BX6    -X0*X2 
          SA6    EMODE
          SA3    A2-2         GET PREVIOUS DIMINF 
          SA4    A2-3                      ARORD
          BX6    X3 
          BX7    X4 
          SA6    DIMINF 
          SA7    ARORD
          SA3    A2-1 
          BX6    X3 
          SA6       CC
          SA4    SPARLEV
          SX6    X4-1 
          SA6    A4          SPARLEV = SPARLEV - 1
          NZ     X6,SUBP8    IF SPARLEV .NE. 0  NOT OUTERMOST REF 
          SX0    1
          SA1    LASTR             POINTER TO MACRO 
          LX0    36                POSITION THE NSL BIT 
          SA3    X1                MACRO HEADER WORD
          BX6    X3+X0             INSERT MARKING BIT 
          SA6    X1                RESTORE TO BUFFER
 SUBP8    BSS    0
*         SEE IF STBASE SHOULD BE SET 
          SA3    A2-4         SAVED ARLPT 
          SA1       EPOINT    IS NEXT E A ** -
          SB3    EL.DSTR
          SA2    X1 
          UX0 B2,X2 
          NE  B2,B3,NEXTE     IF NEXTE NOT A ** 
          SX7    X3 
          AX3    18 
          BX6    X3 
          SA7       STBASE
          SA6    NSFR 
          ZR        NEXTE 
*     END OF NSSP 
* ****             ****                 ****
          EJECT 
*         DEBUG PROCESSOR FOR SUBSCRIPT CHECKING
* 
 ARR      DATA   0
          SA1    RL1
          SA2    RL2
          BX6    X1 
          LX7    X2 
          SA6    RL1TS             SAVE VALUE 
          SA7    RL2TS             SAVE VALUE 
          SA1    NAME 
          MX0    L.NAME 
          BX1    X0*X1             GET ARRAY NAME 
          RJ     STRIP             CHECK FOR TRAILING $ IN NAME 
          SB1    1
          RJ     CONVERT           PLACE IN CONS TABLE
          BX6    X1 
          SA6    DBGAPL            BEGIN BUILDING ARGLIST TABLE 
          SA2    NAME+1 
          LX2    60-P.DIMP         POSITION DIMP FIELD
          MX0    60-L.DIMP
          BX3    -X0*X2            GET DIMP FIELD 
          MX0    60-3 
          SA1    DIM1 
          LX3    1
          SB4    X1+1              FWA+1 OF DIMTAB
          SA1    B4+X3             WORD 2 OF DIMTAB ENTRY FOR ARRAY 
          LX1    6
          BX2    -X0*X1            GET P-ABC FIELD
          NZ     X2,AR1.           IF VARIABLE DIMENSION
          LX1    18 
          MX0    60-18
          BX1    -X0*X1            GET ARRAY BOUND
          SB1    1
          RJ     CONVERT           PLACE IN CONS TABLE
          BX6    X1 
          SA6    DBGAPL+1          BOUND TO ARGLIST TABLE 
          EQ     AR2. 
 AR1.     SA1    ARORD             ORDINAL OF ARRAY 
          SX2    X1-2              COMPUTE CA FIELD 
          SA3    FP.               SYMTAB ORDINAL FOR FP. 
          LX2    30                POSITION CA
          BX6    X2+X3
          SA6    DBGAPL+1          FP. ORD TO ARGLIST TABLE 
 AR2.     MX7    0
          SA7    DBGAPL+3          ZERO TO ARGLIST TABLE
          SX6    =8RBUGARR
          SA6    DBGAPL+4          ADDRESS TO ARGLIST TABLE 
          SA1    LASTR             LAST MACRO 
          SA2    X1+2              1ST WORD OF MACRO
          UX0    B2,X2
          SB3    -SLMACO           IS LAST MACRO A LOAD 
          NE     B2,B3,AR3.        BRANCH IF NOT
          SA3    X1 
          MX0    1
          LX0    44+1 
          BX7    X3+X0       SET XMIT BIT IN HDR WORD 
          SA7    X1 
 AR3.     MX2    0
          RJ     OTS         OUTPUT TEMP STORE
          LX3    30 
          BX6    X3+X2       30/CA(ST.), 30/ORD(ST.)
          SA1    OSPTR
          SA6    DBGAPL+2    SET UP FOR APLIST PROCESSOR
          SA2    X1+OPSTAK+1       (S WORD FROM OPSTAK
          SA3    SSFRSTB
          LX2    30 
          BX6    X3 
          SX7    X2                EXTRACT SAVED SFRSTB 
          SA6    SSSFRSTB          SAVE CURRENT SSFRSTB 
          SA7    A3                RESET SSFRSTB
          RJ     ARGP8CR           PROCESS ANY SAVED FUNCTION RESULTS 
          SA1    SSSFRSTB 
          BX6    X1 
          SA6    SSFRSTB           RESTORE SAVED VALUE
          SA1    DBGAPL 
          SA2    N.AP 
          SA3    STAPLC 
          MX7    0                 ZERO CHAIN WORD FOR THIS FUNCTION
          BX6    X3 
          SA7    A3 
          SA6    STAPL
          SX7    X2+1 
          BX6    X2 
          SA7    A2                UPDATED APLIST NUMBER
          RJ     IGCALL            GENERATE CALL MACRO
          SA1    =8RBUGARR
          SB7    *+1
          EQ     SYMBOL            WILL ALWAYS RETURN TO FOUND ADDRESS
          SX6    T.CGS             PLACE TYPE CGS IN SYMTAB WORD
          LX6    P.TYP                SO REFERENCE WONT APPEAR IN 
          BX7    X6+X2                THE REFERENCE MAP 
          SA3    STAPL
          SA7    A2 
          BX6    X3 
          SA6    STAPLC            RESTORE STORE-TO-APLIST CHAIN
          SA2    NARN              NEXT AVAILABLE R NUMBER
          BX6    X2 
          SX7    X2+1              INCREMENT R NUMBER 
          SA7    A2 
          MX5    0
          SA6    PARAMS 
          SA3    DFRMD
          SA4    EQCOUNT
          SX4    X4 
          LX4    34 
          BX6    X4+X6             INSERT EQUAL SIGN COUNT
          SA6    LEFRN             INDICATE AN UNSAVED FUNCTION RESULT
          RJ     MACOUT            OUTPUT REG DEFINE RN=X6
          SA3    RL2
          SA5    X3+2 
          BX6    X5 
          SA6    SVRL2       FOR ISSUANCE OF INDEXED FETCH
          RJ     CHKOFF 
          SA1    OSPTR             OPSTACK POINTER
          SA4    X1+OPSTAK-3       FWA OF SUBSCRIPT CODE
          SA5    ARLPT             LWA OF SUBSCRIPT CODE
          SX6    X4 
          SA6    A5                START = END
          RJ     DARLIST           FLUSH SUBSCRIPT CODE 
          SA1    ARLPT
          SA2    X1+ARLIST
          SUB 
          BX3    X2 
          AX2    59 
          BX2    X2-X3
          BX3    X2 
          AX2    59 
          BX2    X2-X3
          SB2    X2 
          SX6    A2-B2
          SA6    LASTR
          SA1    RL1TS
          SA2    RL2TS
          BX6    X1 
          LX7    X2 
          SA6    RL1
          SA7    RL2
          SA2   NARN
          SX2    X2-1              RN OF FUNCTION RESULT
          SX5   1 
          MX3   0                  OUTPUT PSUEDO-OP TO ARLST
          RJ     MACOUT            WITH FUNCTION RESULT AS OPERAND
          SA2   RL2 
          SA3   X2+2
          MX0   1 
          BX7   X0+X3              TURN ON NO-OP BIT
          SA7    A3 
          RJ     CHKOFF 
          EQ     ARR
          TITLE 
 MULTOP   SPACE  4,8
 MULTOP   RJ     SSERR6 
          SA1    FF          TOGGLE FLIP FLOP 
          BX6    -X1
          SA6    FF 
          ZR        CMPARE
* 
*     FROM EJTB 
RTPRN     SA5    PARLEVEL        DECREMENT THE PARENTHESIS LEVEL
          SX6    X5-1 
          SA6    A5 
          SB2    B4-EL.STAR 
          SB7    EL.ID
          ZR     B2,CMPARE    IF E+1 IS * 
          SB2    EL.DSTR
          EQ  B2,B4,CMPARE    IF E+1 IS **
          GE  B7,B4,RTPRN1    IF NEXT E IS ID OR CONST
          SB7    EL.( 
          EQ  B7,B4,RTPRN2    IF NEXT E IS (
          SA1       EMODE 
          SX2    X1-1 
          NZ     X2,CMPARE    IF NOT EXP. MODE. 
          SA5       RL2       IS LAST OPD TYPE INT -
          SA4       X5
          SB7    T.INT
          UX0 B6,X4 
          EQ  B6,B7,CMPARE    IF YES
          SA2    B1-1         GET E+1 
          MX0    1            SET GP FLG IN E+1 (B46) 
          LX0    19 
          BX6    X0+X2
          SA6    B1-1 
          ZR        CMPARE
 RTPRN1   SA1       TYPE
          SX2    X1-16
          ZR     X2,RTPRN3    IF 2 OR 3 BRAN IF 
          SX2    X1-17
          NZ     X2,RTPRN2    IF NOT IN IF STATE. 
          SA5    PARLEVEL 
          NZ     X5,RTPRN4   NOT AT FINAL ) FOR IF
 RTPRN3   SA1       IFRPF 
          MX6       10
          NZ     X1,RTPRN2    IF )CONST HAS ALREADY APPEARED FOR THIS IF
          SA6       IFRPF     SET )CONST FLAG (INITIALIZED IN IF) 
          ZR        CMPARE
* 
 RTPRN2   SA2    IXFNFG 
          SA1    PARLEVEL 
          PL     X1,RTPRN4   IF I/O UNIT OR VAR FORMAT AND 0-LVL PARN 
          MI     X2,CMPARE   IF I/O UNIT OR VAR FORMAT
 RTPRN4   BSS    0
          SA1       EPOINT    MOVE EPOINT SO ID,CON, OR ( WILL BE LISTED
          SX6    X1-1 
          SA6       EPOINT
          EERR      ERMSG25   ) FOLLOWED BY ID, CON, OR ( 
* 
* 
*     HERE FROM EJTB FOR WANGERS RIGHT PARENS 
 RJWRP    SB2    EL.) 
          MX0       0 
          PX6    B2,X0
          SA6       OP
          ZR        CMPARE
* 
* 
* 
*     HERE IF ( IN E-LIST 
*         X2=E+1
 LTPRN    RJ        SSERR3
          SB4    EL.) 
          NE  B3,B4,LTPRN1    IF NOT )
          EERR   ERMSG8       EMPTY PAREN.EXP.
* 
 LTPRN1   SA1       OSPTR     SAVE ARLPT. (SEE STBASE)
          SB2    X1-MXOSE+1 
          PL     B2,ERR03     IF OPSTAK FULL
          SA2       ARLPT 
          SA3       SFRSTB    IN CASE SAVED FUNC RESULTS IN BASE OR PWR 
          LX3       18
          BX6    X2+X3
          SA6    X1+OPSTAK+1
          SX7    X1+1 
          SA7       OSPTR 
          SA1       EMODE     SAVE CURRENT MODE IN B21-19 
          SB2    EL.( 
          LX1    19 
          PX6    B2,X1
          SX7    1            SET MODE TO NORM.EXP.MODE 
          SA6    OP 
          SA7    EMODE
          SA1    PARLEVEL        INCREMENT THE PARENTHESIS LEVEL
          SX6    X1+1 
          SA6    A1 
          ZR        ADDOP 
* 
          EJECT               END OF ID PROCESSING
*     EQSIGN IF = IN E-LIST (FROM EJTB) 
 EQSIGN   RJ        SSERR3    SYNTAX CHK
          SA5    EQCOUNT         DECREMENT THE COUNT OF EQUAL SIGNS 
          SX6    X5-1 
          SA6    A5 
          SA4    NARN 
          SX6    X4-1        MAKE R-NUMBER IN LAST LOAD AVAIL FOR REUSE 
          SA6    A4 
          SA1       TYPE
          SA2    EQFLG
          SB2    X1-RPLST 
          NZ     X2,EQS1      IF AN =SIGN HAS ALREADY APPEARED. 
          NZ     B2,EQS2      IF NOT A REPLACEMENT STATEMENT
          MX6    10           SET EQFLG 
          SA6    EQFLG
          ZR        ADDOP 
EQS1      USASDM ERMSG0          MORE THAN ONE = SIGN (NON-USAS)
          SA1       OSPTR     SEE IF EXPRESSION IN BETWEEN = SIGNS. 
          SB3    EL.= 
          SA2    X1+OPSTAK
          UX0    B2,X2
          NE  B2,B3,EQS2      IF LAST OP IN OPSTAK NOT = SIGN 
          SA1       RL2       LAST OPD MUST BE A LOAD 
          SA2    X1+2 
          SA3    IXFN.TAB 
          UX0    B2,X2
 EQS1A    SB3    X3+B2
          SA3    A3+1 
          ZR     B3,ADDOP          IF A LOAD MACRO
          NZ     X3,EQS1A          IF MORE TO CHECK 
  
 EQS2     EERR   ERMSG1            ILLEGAL USE OF = SIGN
ERROUT    SA1    TYPE            IF THIS WAS A REPLACEMENT STATEMENT
          MX7    0
          SA7    IXFNCL 
          SX2    X1-RPLST          THEN CALL 'DODEF' IN CASE A CURRENT
          NZ     X2,ERROUT.1       DO-LOOP PARAMETER WAS ALSO REDEFINED.
          SA1    SAVELEFT 
          SB1    X1 
          SX6    B6              SAVE THE ERROR NUMBER. 
          SA6    A1 
          RJ     DODEF
          SA1    SAVELEFT 
          SB6    X1              RESTORE THE ERROR NUMBER.
 ERROUT.1 SB7    PH2RETN
          SA1    EPOINT 
          SA4    X1+1         LOAD LAST E PROCESSED 
          SA2    IXFNFG 
          ZR     X2,ERPRO          IF NOT IN IXFN MODE
          SB7    =XDOGOOF          IN CASE WE ARE IN THE MIDDLE OF
          EQ     ERPRO             AN I/O LOOP
* 
*     FROM EJTB. IF - 
 MINUS    RJ        SSERR6
          SA1    B1+1 
          UX0 B2,X1 
          SB3    EL.) 
          LE  B2,B3,RSFF      IF E-1 IS A ), ID, OR CON.
          SA1    UMIOP        HERE IF U-
          BX6    X1 
          SA6    OP 
          ZR        RSFF
  
*         DIVIDE OPERATOR 
  
 DIVIOP   SA3    RL2
          SA4    X3 
          UX0 B3,X4 
          SB5    T.INT
          SB6    T.OCT
          EQ  B3,B5,DIVIDE1   IF INT /
          LT  B3,B6,DIVD      IF NOT A POSSIBLE INT / 
 DIVIDE1  SA3       INTEDVD 
          BX6    X3 
          SA6       OP
 DIVD     RJ        SSERR6
          SA2       FF        SO IF A=B/C*D*E WILL GET (B/C)*(D*E)
          BX6   -X2 
          SA6    A2 
 DIVX     SA1    RL2
          SA2    X1 
          SB2    T.INT
          UX0 B3,X2 
          SX4    B3 
          EQ  B2,B3,CMPARE    IF TYPE OF LAST OPD WAS INT 
          SB2    T.OCT
          EQ     B2,B3,CMPARE      IF TYPE OF LAST OPND WAS OCTAL 
          SA2    OSPTR
          SA1    OP 
          SA3    X2+OPSTAK
          AX1    3           ASSURES THAT THE HIERARCHY IS NOT THAT OF I
          UX0    B3,X3
          LX1    60-1 
          MX2    57 
          PL     X1,DIVX1    IF HIERARCHY IS OF INT/
          LX1    60-15
          PL     X1,DIVD1     IF GP FLG NOT ON IN OP
          LX1    60-4 
  
 DIVX2    BX1    X2*X1
          BX6    X4+X1       ADD TYPE OF LAST OPD 
          LX6    23 
          SA6    A1          RESTORE INTO OP
          SB2    B3-EL.STAR 
          ZR     B2,TM3B
 DIVD1    SB2    B3-EL.SLASH
          SB4    MLTSOP 
          ZR     B2,DIVD2 
          NE     B3,B4,CMPARE 
 DIVD2    SA1    MLTDOP 
          BX6    X1 
          SA6    OP 
          ZR        CMPARE
  
 DIVX1    MX0    1
          BX3    X1+X0       HIERARCHY CHANGED TO 10B 
          LX3    60-15
          BX1    X3+X0       GP BIT TURNED ON 
          LX1    60-4 
          EQ     DIVX2
* 
*     PLUS IF + SIGN IN E-LIST
 PLUS     RJ        SSERR6
          SA1    B1+1 
          UX0 B3,X1 
          SB2    EL.) 
          GT  B3,B2,NEXTE     IF NOT PRECEDED BY CON, ID, OR ) (U+) 
*     RSFF IF + OR -
 RSFF     MX6    10           RESET FF TO <0
          SA6    FF 
 CMPARE   SA1    OSPTR        OPSTACK PTR 
          SB2    X1 
          SA2    OPSTAK+B2    LAST ENTRY
          SA3    OP           GET OP
          SB6    X2           COMPARE HEIRARCHIES 
          UX0 B3,X2 
          SB7    X3 
          UX0 B4,X3 
          GT  B7,B6,ADDOP1    IF H(OP)>H(OM)
          EQ  B7,B6,TM3       IF H(OP)=H(OM)
          SA5       RL2       IS LAST OPD TYPE INT -
          SA4       X5
          SB7    T.INT
          UX0 B6,X4 
          EQ B6,B7,POPOP      IF YES
          MX0    1            SET GP FLG IN OP
          SX1    B6                TYPE 
          LX0    19           IN B18
          BX6    X0+X3
          LX1    23 
          BX6    X6+X1             ADD TYPE 
          SA6    OP 
*     POPOP IF AN OPERATOR IS TO BE POPPED OUT OF OPSTAK
 POPOP    LX2       59-22 
          PL     X2,POP1      IF CGP BIT OFF IN OM
          RJ     CLGP        CLEAR GPTU BIT IN LAST GPTU ENTRY
  
 POP1     SA5    OSPTR
          SA4    X5+OPSTAK
          SA1    RL1
          UX0    B3,X4
          SA2    RL2
          SX6    X5-1              DECREMENT OPSTACK PTR
          BX7    X4 
          SA3    X1                (RL1)
          SA7    CRNTOP            CURRENT OPERATOR 
          SA4    X2                (RL2)
          SA6    A5 
          JP     B3+OPSWTB-4  LOWEST OP=4 
  
 OPSWTB   BSS    0
          LOC    4
          EQ        EOSPO     END-OF-STMT PSEUDO OP 
          ZR        EQPO      = 
          ZR        LPAR      ( 
          SX6       MAC+0     .OR.
          ZR        AOOP      .AND.  .OR. OP PROCESSOR
          SX6       MAC+1     .AND. 
          ZR        AOOP
          SX6       MAC+2     .NOT. 
          ZR        NOTOPR
          SX6    MAC+3        LE    MAC+3 IF REAL 
*                                      +4 IF INT
*                                      +5 IF DBL
*                                      +6 IF CMPX (ONLY REALS USED) 
          ZR        ROP 
          SX6       MAC+7     LT
          ZR        ROP 
          SX6       MAC+11    GE
          ZR        ROP 
          SX6       MAC+15    GT
          ZR        ROP 
          SX6       MAC+19    NE
          ZR        ROP 
          SX6       MAC+23    EQ
          ZR        ROP 
*     ANY CHANGE TO -,+,*,/ OP NO,S WILL REQUIRE CHANGE TO BOPSTB 
          SX6       MAC+27    - 
          ZR        MOP 
          SX6       MAC+31    + 
          ZR        MOP 
          SX6       MAC+35    * 
          ZR     MOPA 
          SX6       MAC+39    /     MAC+39 IF REAL
*                                       40    INT 
*                                       41    DBL 
*                                       42    CMPX
          ZR     MOPB 
          ZR        EXPOP     **
          ZR        ARGPO     (A  LEFT PAREN PRECEDING ARG LIST 
          ZR        SUBPO     (S  LEFT PAREN PRECEDING NSSP 
          ZR        CS1PO     ,S1  COMMA AFTER SUBSCRIPT ONE
          ZR        CS2PO     ,S2  COMMA AFTER SUBSCRIPT TWO
          ZR        CARGPO    ,A  COMMA FOLLOWING ARGUMENT
*     ANY CHANGE TO U- WILL REQUIRE CHANGE IN UINGEN. 
          SX6       MAC+43    U-
          ZR        MOP15 
          SX6       MAC+45    R-    INT CASE ONLY WHEN U- FOLLOWED BY + 
          ZR        MOP 
          SX6       MAC+49    R/    NO INT CASE 
          ZR        MOP 
          SX6       MAC+35    */    NO INT CASE 
          ZR        MOP 
          ZR        SFLPR     (SF  STATE FUN.LP ROUTINE 
          ZR        IXFN2     (X   IXFN LP ROUTINE
          ZR        ACAL7     (SUBR.LP
*     END OF OPSWTB 
          LOC    *O 
*     ADDOP TO PUT OP IN OPSTAK 
 ADDOP    SA1    OSPTR        OSPTR=NO.OF OPS IN STAK-1 (LAST=EOS OP) 
          SB2    X1 
          SA3    OP 
 ADDOP1   ZR     B2,ADDOP2    IF NO OPS IN STACK
          SB3    B2-MXOSE+1   TEST SIZE OF STAK 
          NG     B3,ADDOP3    IF OPSTAK NOT FULL
 ERR03    EERR      ERMSG9
* 
 ADDOP3   BX6    X3 
          UX0 B3,X3           SEE IF ** OP
          SB4    EL.DSTR
          EQ  B3,B4,ADDOP4    IF ** 
 ADDOP6   SA6    B2+OPSTAK+1  STORE OP IN OPSTAK
          SX7    B2+1         UP OSPTR
          SA7    OSPTR
          ZR        NEXTE 
 ADDOP2   UX0 B3,X3           SEE IF OP IS )
          SX1    B3-EL.)
          NZ     X1,ADDOP3    IF NOT )
          EERR   ERMSG4 
*         (DONT DESTROY X6 OR B2
 ADDOP4   SA1       STBASE
          PL     X1,ADDOP5    IF X1=POINT TO START OF BASE
          SA1       RL2       COMPUTE POINT TO START OF BASE
          SX2    ARLIST 
          SUB 
          IX1    X1-X2
 ADDOP5   BX7    X1 
          SA2       NSFR
          PL     X2,ADDOP5A 
          SA2       SFRSTB
 ADDOP5A  LX2       18
          BX7    X2+X7
          SA7    B2+OPSTAK+1  STORE STBASE
          SB2    B2+1 
          SB3    B2-MXOSE+1 
          MX7    10 
          SA7    NSFR 
          SA7    STBASE 
          NG     B3,ADDOP6    IF OPSTAK NOT FULL
          ZR        ERR03 
 AOOP     SPACE  4,8
*         AOOP - AND , OR OP POPPED FROM STACK
  
 AOOP     UX0    B2,X3
          SA6    SMACD             SAVE MACRO NUMBER
          UX7    B3,X4
          SB4    T.LOG
          SX5    B2+B3
          ZR     X5,AOOP3          IF BOTH OPERANDS ARE TYPE LOGICAL
          ZR     B2,AOOP1          IF RL1 IS LOGICAL
          NZ     B3,AOOP2          IF RL2 IS NOT TYPE LOGICAL 
 AOOP1    EERR   ERMSG31           LOG AND NON LOG OPNDS MAY NOT BE MIXE
  
 AOOP2    RJ     SNGLR             CHANGE RL1 TO SINGLE LOAD
          SA1    RL2
          RJ     SNGLR             CHANGE RL2 TO SINGLE LOAD
          USASDM ERMSG41           MASKING EXPR 
          SB4    T.OCT
  
 AOOP3    SX5    B4 
          RJ     INGEN             OUTPUT MACRO 
          EQ     CMPARE 
 NOTOPR   SPACE  4,8
*         NOTOPR - .NOT. OP POPPED
  
 NOTOPR   UX0    B2,X4             MODE OF RL2
          BX1    X2                X1 = RL2 
          SB3    T.LOG
          EQ     B2,B3,NOTOPR1     IF TYPE LOGICAL
          RJ     SNGLR             CHANGE TO SINGLE LOAD
          USASDM ERMSG41           *MASKING EXPR IS NON-ANSI* 
          SA1    RL2
          SB2    T.OCT
          SA2    X1 
          SX6    NOTMC
          PX7    B2,X2             CHANGE TYPE TO OCT 
          SA7    A2 
 NOTOPR1  RJ     UINGEN            OUTPUT MACRO 
          MX6    0
          EQ     CMPARE 
 MOPA     SPACE  4,8
*         * OPERATOR, SPECIAL CASE 2*X TO X+X 
  
 MOPA     BX7    X3+X4
          LX7    59-47
          PL     X7,MOPA0    IF NEITHER OPERAND IS A CONST
          RJ     CLC         CHECK FOR LARGE CONSTANTS
 MOPA0    UX0    B3,X3
          SB6    T.DBL
          LX3    59-47
          UX0    B4,X4       RL2
          SB7    T.CPLX 
          LX4    59-47
          ZR     B3,MOP1     IF RL1 TYPE LOGICAL, ERROR 
          ZR     B4,MOP1     IF RL2 TYPE LOGICAL, ERROR 
          PL     X3,MOPA1    IF RL1 NOT A CONST 
          LT     B3,B6,MOPA2 IF RL1 IS INT OR REAL
  
 MOPA1    PL     X4,MOP      IF RL2 NOT A CONST 
          GE     B4,B6,MOP   IF RL2 IS NOT INT OR REAL
          GT     B3,B7,MOP   IF RL1 IS OCT OR HOLL
          SA1    RL1
          SA2    RL2
          BX6    X1          SWITCH (RL1) AND (RL2) IF RL2 IS CONST 
          LX7    X2          RL2
          SA6    RL2
          SA7    RL1
          SA3    A4 
          UX0    B3,X3
          EQ     MOPA3
  
 MOPA2    GT     B4,B7,MOP   IF RL2 OCT OR HOLL 
          PL     X4,MOPA3    IF RL1 CONST AND RL2 NOT 
          EQ     B4,B6,MOPA3 IF NOT POSSIBLE COMPILE-TIME EVAL. 
          NE     B4,B7,MOP   IF POSSIBLE COMPILE-TIME EVAL. 
  
*         RL1 CAN BE INT OR REAL, RL2 CAN BE INT,REAL,DBL,OR CMPLX
 MOPA3    SA1    A3          RL1
          RJ     NEWCON      GET VALUE OF CONST 
          SA2    RL2
          SB2    T.REAL 
          SX7    2
          SA4    X2 
          IX0    X7-X6
          UX5    B4,X4
          NE     B3,B2,MOPA4 IF TYPE INTEGER CONSTANT 
          LT     B4,B2,MOPA5 NO REDUCTION IF INT VAR AND REAL CONST 
          SX0    2./1S45
          LX6    15 
          IX0    X0-X6       TEST IF FLOATING POINT 2 
  
 MOPA4    NZ     X0,MOPA5    IF NOT CONST 2 
  
*         CHANGE 2*X TO X+X 
  
          BX7    X2          RL1 CHANGED TO SAME AS RL2 
          SA1    RL1
          SA3    X1 
          UX0    B3,X3
          SA7    A1 
          EQ     B3,B2,MOPA4B IF CONST IS TYPE REAL, ANSI COMBINATION 
          SB6    B3-B4
          NZ     B6,MOPA4A   IF NON-ANSI COMBINATION
          LT     B3,B2,MOPA4B IF INT * INT
 MOPA4A   USASDM ERMSG42     ISSUE NON-ANSI COMBINATION MSG 
 MOPA4B   SX6    MAC+31      MACRO CODE CHANGED TO +
          EQ     MOP
  
 MOPA5    SX6    MAC+35      RESTORE * MACRO CODE 
          BX7    X1          RESTORE ARLIST HDR WORD NOOPED BY NEWCON 
          SA7    A1 
          EQ     MOP
  
*         / OPERATOR, SPECIAL CASE C/R
*         CONSTANT DIVISORS MAY BE INVERTED AND OPERATION CHANGED TO *. 
  
 MOPB     BX7    X3+X4
          LX7    59-47
          PL     X7,MOPB1    IF NEITHER OPERAND IS A CONST
          RJ     CLC         CHECK FOR LARGE CONSTANTS
 MOPB1    SA2    =XROPFLAG
          UX0    B4,X4       DIVISOR
          LX4    59-47
          SB2    B4-T.REAL
          UX0    B3,X3       DIVIDEND 
          LX2    1R/
          NZ     B2,MOP      IF DIVISOR NOT REAL
          MI     X4,MOPB2    IF DIVISOR IS CONST
          SB6    B3-T.CPLX
          MI     X2,MOP      IF ROUNDED / 
          NZ     B6,MOP      IF DIVIDEND NOT COMPLEX
          SX7    B3 
          SX6    DIVCR       C/R MACRO CODE 
          SA7    TYPEWD      RESULT IS TYPE COMPLEX 
          SA6    SMACD
          EQ     MOP18       OUTPUT MACRO 
  
 MOPB2    BSS    0
  
          IFEQ   NOINVERT,0 
  
*         REAL CONSTANT DIVISORS CAN BE INVERTED IF DIVIDEND IS NOT 
*         TYPE DOUBLE. / CHANGED TO *.
          SB6    B3-T.DBL 
          ZR     B6,MOP      IF DIVIDEND IS DBL, NO INVERT
          SA1    RL1
          SA2    RL2
          SA5    A2          A5,X5 MUST BE PRESERVED IN CASE ARLIST 
*                            POINTER IS  RESTORED.
          BX6    X1 
          SA1    X2 
          SA6    A2          REPLACE (RL2) WITH (RL1) FOR CFETCH
          RJ     NEWCON      FETCH VALUE OF CONST 
          ZR     X6,CON7     IF DIVIDE BY 0, ERROR
          SA2    =1.0 
          SA4    =XROPFLAG
          BX0    X4 
          FX3    X2/X6
          LX4    1R/
          PL     X4,MOPB3    IF ROUNDED DIVIDE NOT SELECTED 
          RX3    X2/X6
 MOPB3    OR     X3,MOPB5    IF CONSTANT INFINITE 
          ID     X3,MOPB5    IF CONSTANT INDEFINITE 
          FX4    X3*X6
          LX0    1R*
          PL     X0,MOPB4    IF ROUNDED MULTIPLY NOT SELECTED 
          RX4    X3*X6
 MOPB4    OR     X4,MOPB5    IF CONSTANT INFINITE 
          ID     X4,MOPB5    IF CONSTANT INDEFINITE 
          IX3    X4-X2
          ZR     X3,MOPB6    IF(1/CON)*CON.EQ.1) -    INVERT
 MOPB5    BX6    X5 
          BX7    X1 
          SA6    A5          RESTORE RLIST POINTER
          SA7    A1          RESTORE ARLIST HDR WORD NOOPED BY NEWCON 
          SX6    MAC+39      / MACRO CODE 
          EQ     MOP
  
 MOPB6    SB1    1
          RX1    X2/X6
          RJ     CONVERT
          SX6    T.REAL 
          RJ     CFETCH 
          SX6    MAC+35      * MACRO CODE 
  
          ENDIF 
  
          EQ     MOP
          TITLE  CLC - CHECK FOR LARGE INTEGER CONSTANTS
 CLC      SPACE  4,8
**        CLC - CHECK FOR LARGE INTEGER CONSTANTS 
*         INTEGER CONSTANTS USED AS OPERANDS OF MULTIPLICATION OR 
*         DIVISION ARE CHECKED FOR VALUES EXCEEDING 2**48-1.
*         A FATAL ERROR IS GIVEN FOR SUCH USAGES. 
*         ENTRY  A3 _ (RL1) 
*                A4 _ (RL2) 
*         EXIT   A3 AND A4 SAME AS ON ENTRY 
*         SAVES  X6 
  
 CLC      ENTRY. *
          SA1    RL1         SET UP FOR CHKP2 CALL
          UX0    B3,X3
          BX7    X4          OTHER OPERAND
          SA6    MCHTS+1
          LX0    59-47
          SA7    MCHTS       TEMP FOR RL2 INFO
          MI     X0,CLC2     IF RL1 IS A CONST
 CLC1     LX7    59-47
          PL     X7,CLC      IF RL2 ALSO IS NOT A CONST, EXIT 
          UX0    B3,X4
          MX7    0
          SA7    MCHTS
          SA1    RL2         SET UP FOR CHKP2 CALL
          LX7    X3          OTHER OPERAND
 CLC2     SB2    T.INT
          SB6    T.OCT
          SB7    T.HOL
          EQ     B3,B2,CLC4  IF OPERAND IS INTEGER, CHECK VALUE 
          EQ     B3,B6,CLC3  IF OPERAND IS OCTAL,CHECK TYPE OF OPERATION
          EQ     B3,B7,CLC3  IF OPERAND IS HOLL, CHECK TYPE OF OPERATION
          SA5    MCHTS
          ZR     X5,CLC      IF BOTH OPERANDS CHECKED 
          EQ     CLC1 
 CLC3     UX0    B4,X7
          EQ     B4,B2,CLC4  IF INTEGER 
          EQ     B4,B6,CLC4  IF OCTAL 
          NE     B4,B7,CLC   IF NOT HOLL
 CLC4     SA1    X1 
          BX1    -X1
          RJ     NEWCON 
          AX6    48 
          NZ     X6,CLCE     IF LARGE CONST.
          SA4    MCHTS
          ZR     X4,CLC5     IF BOTH OPERANDS PROCESSED 
          UX0    B4,X4
          LX4    59-47
          PL     X4,CLC5     IF NOT A CONST 
          MX6    0
          SB2    T.INT
          SA6    A4 
          SB6    T.OCT
          SA1    RL2
          EQ     B4,B2,CLC4  IF INTEGER 
          EQ     B4,B6,CLC4  IF OCTAL 
          SB7    T.HOL
          EQ     B4,B7,CLC4  IF HOLL
 CLC5     SA1    RL1         SET EXIT REGISTERS 
          SA2    RL2
          SA3    X1 
          SA5    MCHTS+1
          SA4    X2 
          BX6    X5 
          EQ     CLC
 CLCE     EERR   -ERMSG60    INT CONST .GE. 2**48 
          TITLE  MOP
*         ARITHMETIC OPERATION IS POPPED FROM STACK. R-LIST IS TO BE
*         OUTPUT. 
*         ENTRY  (X6) = MACRO CODE
*     MOP OUTPUTS R-LIST FOR THE POPPED OP
 MOP      SA6    SMACD        SAVE MACRO CODE 
          SA1    RL1          GET LOC OF NEXT TO LAST UNUSED R-ENTRY
          SA2    RL2                     LAST 
          SA3    X1           GET 1ST WORD OF PENULT.ENTRY
          SA4    X2                            LAST 
          UX0 B4,X3           IS EITHER TYPE LOGICAL
          UX0 B5,X4 
          SB6    B4-T.LOG 
          SB7    B5-T.LOG 
          ZR     B6,MOP1      IF TYPE LOG.(ERR.)
          ZR     B7,MOP1      11      11
          SB6    X6           SEE IF REL WITH CPX OPD 
          SB7       HIRELM    HIGHEST REL MAC 
          GT  B6,B7,MOP2      IF NOT REL
          SB7       LORELM    LOWEST REL MAC
          LT  B6,B7,MOP2      IF NOT REL
          SB6    T.CPLX 
          EQ  B6,B4,MOP2A     IF CPX
          NE  B6,B5,MOP2      IF NOT CPX
MOP2A     USASDM ERMSG43         A RELATIONAL OP HAS A COMPLEX OPERAND
          SA1       RL1 
          SA2       RL2 
          SA3    X1 
          SA4    X2 
          UX0 B4,X3 
          UX0 B5,X4 
 MOP2     SB6    B4-B5        ARE OPD TYPES DIFFERENTY
          SX7    B4 
          SA7    TYPEWD       (SAVE TYPE IN CASE THE SAME)
          ZR     B6,MOP5A          IF NO
          SB7    T.OCT
          GE  B4,B7,MOP28     IF RL1 IS OCT OR HOL
          GE  B5,B7,MOP29     IF RL2 IS OCT OR HOL
          NG     B6,MOP6      YES.  IF RL1 POINTS TO LOWER TYPE.
          MX6       1         SET REVERSE-OPDS FG 
          SA6       ROFG
          SX7    X1           REVERSE RL1 AND RL2 
          SX6    X2 
          SA7    RL2
          SA6    RL1
 MOP6     SA3       RL1 
          SA4       RL2 
          SA1    X3 
          SA2    X4 
          UX0 B2,X1 
          SB3    T.REAL 
          UX7 B4,X2 
          EQ  B2,B3,MOP6A     IF LOW TYPE REAL (IN WHICH CASE HIGH TYPE 
*      WOULD HAVE TO BE DBL OR CPX AT THIS POINT.)
          USASDM ERMSG44         TYPE COMBINATION NOT USAS
 MOP6A    SA1       RL1       IS LOWER TYPE A CONST-- 
          SA2       RL2 
          BX7    X2 
          SA2    X2 
          SA7       SVRL2     SAVE RL2
          UX0 B3,X2 
          SX6    B3 
          SA6       TYPEWD
 MOP6B    SA1    X1 
          UX0 B3,X1           GET TYPE IN B3
          LX1    12           CONSTANT FLG BIT
          PL     X1,MOP7      IF NO 
*     HERE IF MIXED MODE, RL1 (LOW TYPE) IS CONST, AND NEITHER RL1 NOR -
*       - RL2 IS OCT OR HOL.
          LX1    -12             NO-OP RL1 ENTRY (LOW CONST)
          RJ     NEWCON       ENTER WITH X1=1ST WD OF ARLIST ENTRY, A1= 
*                               ADR OF THAT ENTRY.  LEAVE WITH CONST
*                               SET UP WITH VALUE OF CONST, OLD ENTRY 
*                               NO-OPED. LEAVE B3 AS BEFORE RJ NEWCON 
          SB4    T.INT
          EQ  B3,B4,MOP10 
 MOP14    RJ        DLDSU     CALL DOUBLE LOAD SET-UP ROUTINE (TP CMPX) 
          SA5       TYPEWD
          RJ        MACOUT    MACOUT OUTPUTS RLIST ENTRY MACRO
          SA1       RL2       SET CONST BIT IN LOAD INSTR 
          MX0       1 
          LX0       48
          SA2    X1 
          BX6    X0+X2
          SA6    A2 
          ZR        MOP8
* 
*     MOP28 IF RL1 IS OCT OR HOL
 MOP28    GE  B5,B7,MOP30     IF RL2 IS ALSO OCT OR HOL 
 MOP31    SB7    T.DBL
          SX6    B5 
          SA6       TYPEWD
          LT  B5,B7,MOP5      IF RL2 IS NOT DBL OR CMPX 
          SA1    RL1
          EQ     MOP6B
* 
*     MOP30 IF RL1 AND RL2 ARE OCT OR HOL CONSTS
 MOP30    SX6    T.INT
          SA6       TYPEWD
          ZR        MOP5
* 
*     MOP29 IF RL2 IS OCT OR HOL BUT RL1 IS NOT.
 MOP29    MX6       1         SET REVERSE-OPDS FG 
          SA6       ROFG
          BX7    X1 
          AX6    B0,X2
          SA7       RL2 
          SA6       RL1 
          SB7    B4           REVERSE B4 AND B5 
          SB4    B5 
          SB5    B7 
          ZR        MOP31 
* 
* 
*     MOP10 IF LOW TYPE IS INT CONST (HIGH ISNT OCT OR HOL) 
 MOP10    SA1       CONST     CONVERT TO REAL 
          SA3       TYPEWD
          PX2    X1 
          NX6 B0,X2 
          SX0    X3-T.REAL
          ZR     X0,MOP11     IF HIGH TYPE IS REAL
          SA6       CONST     MUST BE DBL WD
          ZR        MOP14 
* 
 MOP11    BX1    X6 
          SB1       1 
          ZR     X6,MOP11A   IF CONST ZERO
          RJ        CONVERT 
          SA5       EPOINT
          SB1    X5+1 
          SX6    T.REAL            FOR CALL TO FETCH
          RJ        CFETCH    CALL CON. FETCH ROUTINE 
          ZR        MOP8
 MOP11A   SA3    RL1         RESTORE OLD ENTRY OF MASK ZERO 
          SA1    X3 
          BX7    -X1
          SA7    X3 
          EQ     MOP5 
  
*         MOP5A IF OPERANDS SAME TYPE WHEN MOP ENTERED
 MOP5A    SA1    CRNTOP            CURRENT OPERATOR 
          UX0    B5,X1             UNPACK OPERATOR
          SX2    B5-EL.SLASH
          NZ     X2,MOP5           IF NOT A / OPERATOR
          LX1    59-18
          PL     X1,MOP5           GP BIT NOT SET 
          SA2    TYPEWD            OPERAND TYPE 
          AX1    4
          MX0    60-L.TYP 
          BX6    -X0*X1            FETCH TYPE 
          IX0    X2-X6
          ZR     X0,MOP5           IF SAME TYPE 
          PL     X0,MOP5B    IF OPERAND TYPE .GT. TYPE
          SX5    X6-T.OCT 
          PL     X5,MOP5     IF TYPE IS OCTAL OR HOLL 
          SA6    TYPEWD            RESET
          SA5    RL1
          SB5    X6 
          RJ     MODCH             CONVERT TO HIGHER TYPE 
          SA6    RL1
          SA1    TYPEWD 
          SA5    RL2
          SB5    X1 
          RJ     MODCH             CONVERT TO HIGHER TYPE 
          SA6    RL2
          EQ     MOP5 
  
 MOP5B    SX5    X2-T.OCT 
          MI     X5,MOP5     IF OPERAND NOT TYPE OCTAL OR HOLL
          SA6    TYPEWD 
  
*     MOP5 WHEN READY TO OUTPUT RLIST FOR POPPED OP 
 MOP5     SA1    TYPEWD       IS TYPE REALY 
          SX2    X1-T.REAL
          NZ     X2,MOP17     IF NO 
 MOPROUND SA2    ROPFLAG           IF NO ROUNDED ARITHMETIC IS TO BE
          ZR     X2,MOP12            PERFORMED GO TO 'MOP12'. 
          SA3    ROUNDTBL          SEE IF THE MACRO INVOLVED IS AMONG 
          SX5    X3                  THE POSSIBLE ROUNDED MACROS
          UX0    X3,B7
          SA1    SMACD
          SPACE  1
 MOPR1    IX6    X1-X5
          LX3    30 
          ZR     X6,MOPR2 
          SA3    A3+1 
          MI     X6,MOP12 
          SX5    X3 
          UX0    X3,B7
          NZ     X3,MOPR1 
          ZR     MOP12             IF NOT GO TO 'MOP12' 
*** 
*         IF A POSSIBLY ROUNDED MACRO SEE IF THE OPERATOR WHICH CAUSED
*         THE MACRO TO BE GENERATED IS SELECTED FOR ROUNDED OPERATIONS
* 
 MOPR2    LX6    X2,B7
          PL     X6,MOP12 
          SX6    X3                IF SO CHANGE THE MACRO CODE. 
          SA6    SMACD
          SPACE  1
 MOP12    SA1    SMACD
          SX2    X1-HIRELM-1  IS OP A RELATIONAL -
          PL     X2,MOP18     IF NO 
          SX2    X1-LORELM    MAYBE 
          NG     X2,MOP18     IF NO 
          SX6    T.LOG
          SA6    TYPEWD 
 MOP18   SA5        TYPEWD    OUTPUT MAC FOR BIN OP 
          RJ        INGEN 
          SA1    OP           IS OP=/:  
          UX0 B7,X1 
          SX2    B7-EL.SLASH
          NZ     X2,CMPARE    IF NO 
          SA3       EPOINT
          SA2    X3 
          UX3 B4,X2 
          ZR        DIVD
* 
* 
*     MOP15 IF U- POPPED OUT
 MOP15    SA1       RL2       IS TYPE LOG-
          SA2    X1 
          UX0 B2,X2 
          SB3    B2-T.LOG 
          ZR     B3,MOP1      IF YES
          RJ        UINGEN
          ZR        CMPARE
* 
* 
*     INGEN: COME WITH RL1,RL2,SMACD SET TO INDICATE TWO OPERANDS      -
** OF SAME TYPE AND MACRO CODE.  OUTPUT MACRO INTR. AND UPDATE RL,S ETC 
*         X5=TYPE OF RESULT 
 INGEN    DATA   0
          SA1    RL1          GET RN NOS
          SA2    RL2
          SA3    X1 
          UX0 B2,X3 
          SX6    B2 
          SA6       OPDTYP
*  COMPILE TIME EVALUATION CODING RUNS FROM HERE TO INGEN2. 
          BX6    X5           SEE IF CONSTANT OPERATION 
          SA6       TYPEWD    SAVE TYPE OF RESULT 
          LX0       59-47 
          SA4    X2 
          PL     X0,INGEN2    IF RL1 NOT CONST
          LX4       59-47 
          PL     X4,INGEN2    IF RL2 NOT CONST
          SA4       SMACD     IS MACRO CODE AMONG THOSE ACCEPTABLE- 
          SB2       BOPSTS    (BINARY OPS TBL SIZE) 
          SB3    B0 
          MX0       60-12 
 INGEN4   SA5    B3+BOPSTB
          BX6    X4-X5
          SB3    B3+1 
          BX6   -X0*X6
          ZR     X6,INGEN1    IF HAVE FOUND THE MACRO CODE IN BOPSTB
          LT  B3,B2,INGEN4    IF MORE BOPSTB ENTRIES TO LOOK AT 
          ZR        INGEN2    IF NOT ACCEPTABLE OP
 INGEN1   BX7    X5           SAVE BRANCH POINT 
          SA7       BRPNT 
          SA2       RL2 
          SA1    X2 
          RJ        NEWCON    NO-OP RL2 AND RETURN WITH - 
          SA6       CONST+1   VALUE OF 2ND CONST. 
          SA2       RL1 
          SA1    X2 
          PL    X1,INGEN3     IF NOT NO-OPED (INCASE RL1=RL2 - SUBP5) 
          BX1   -X1 
 INGEN3   RJ        NEWCON    RETURN WITH VALUE OF 1ST CONST IN CONST 
          SA2       CONST+1 
          BX1    X6 
          SA4       TYPEWD
          SB2    X4-T.REAL
          NZ     B2,INGEN6    IF OPERATION NOT REAL 
          OR     X1,INGEN7    IF OPD OUT OF RANGE 
          OR     X2,INGEN7
          ID     X1,INGEN7
          ID     X2,INGEN7
 INGEN6   SA3       ROFG
          PL     X3,BRPNT     IF OPDS WERENT REVERSED 
          BX1    X2 
          SA2       CONST 
          MX6       0 
          SA6       ROFG      CLEAR FLAG
          ZR        BRPNT 
* 
* 
 BRPNT    BSS       1         HOLDS ENTRY SELECTED FROM BOPSTB
* 
* 
*** 
*         B O P S T B -- BINARY OPERATIONS WHICH MAY BE PERFORMED AT
*         COMPILE TIME. 
* 
* 
 BOPSTB   BX2    -X2         - REAL 
          EQ     INGN01 
 -        VFD    15/MAC+27
          SPACE  1
          IX6    X1-X2       - INTEGER
          EQ     INGEN5 
 -        VFD    15/MAC+28
          SPACE  1
          EQ     INGN01      + REAL 
 -        VFD    30/MAC+31
          SPACE  1
          IX6    X1+X2       + INTEGER
          EQ     INGEN5 
 -        VFD    15/MAC+32
          SPACE  1
          FX6    X1*X2       * REAL 
          EQ     INGEN5 
 -        VFD    15/MAC+35
          SPACE  1
          EQ     INGN02      * INTEGER
 -        VFD    30/MAC+36
          SPACE  1
          FX6    X1/X2       / REAL 
          EQ     INGEN5 
 -        VFD    15/MAC+39
          SPACE  1
          EQ     INGN03      / INTEGER
 -        VFD    30/MAC+40
          SPACE  1
          BX2    -X2         ROUNDED- REAL
          EQ     INGN04 
 -        VFD    15/RSUB
          SPACE  1
          EQ     INGN04      ROUNDED+ REAL
 -        VFD    30/RADD
          SPACE  1
          RX6    X1*X2       ROUNDED* REAL
          EQ     INGEN5 
 -        VFD    15/RMLT
          SPACE  1
          RX6    X1/X2       ROUNDED/ REAL
          EQ     INGEN5 
 -        VFD    15/RDIV
          SPACE  1
 BOPSTS   EQU    *-BOPSTB 
          SPACE  2
 INGEN7   EERR   ERMSG50     CONSTANT OUT-OF-RANGE OR INDEFINITE
          SPACE  1
 INGN01   FX3    X1+X2       + OR - REAL
          NX6    X3 
          ZR     INGEN5 
          SPACE  1
 INGN02   PX2    X2          * INTEGER
          PX1    X1 
          DX3    X1*X2
          UX6    X3 
          ZR     INGEN5 
          SPACE  1
 INGN03   PX2    X2          / INTEGER
          PX1    X1 
          NX2    X2 
          FX1    X1/X2
          UX2    X1,B2
          LX6    X2,B2
          ZR     INGEN5 
          SPACE  1
 INGN04   RX3    X1+X2       ROUNDED + OR - REAL
          NX6    X3 
          SPACE  1
* 
* 
*    (ALSO FALLS THRU FROM INGN04)
 INGEN5   SA1    TYPEWD 
          SB2    X1-T.REAL
          NZ     B2,INGEN5A        IF NOT TYPE REAL GO TO 'INGEN5A' 
          OR     X6,INGEN5B        OTHERWISE CHECK FOR OUT-OF-RANGE OR
          ID     X6,INGEN5B        INDEFINITE VALUES. 
 INGEN5A  RJ     OPNCON            GO OTUPUT A NEW CONSTANT (RL-S WILL
*                                  BE RESET)
          ZR        INGEN 
 INGEN5B  EERR      ERMSG51 
*    END OF COMPILE TIME EVALUATION CODING. 
* 
* 
 INGEN2   SA5    SMACD
          SB7    X5-DIV.INT 
          NZ     B7,INGEN2B        IF NOT AN INTEGER DIVIDE 
          SA1    ROFG              *** TEMPORARY ***
          NZ     X1,INGEN2B        IF OPERANDS REVERSED 
          SA1    RL2
          RJ     CHKP2             SEE IF RL2 = 2**N
          NZ     X7,INGEN2Z        IF NOT 
          SA1    RL1
          SA3    MD.CSFT+1         CHANGE TO CONSTANT RIGHT SHIFT 
          EQ     INGEN2D           GO OUTPUT SHIFT MACRO
  
 INGEN2B  SB7    X5-MPY.INT 
          NZ     B7,INGEN2Z        IF NOT AN INTEGER MULTIPLY 
          SA1    RL2
          RJ     CHKP2             SEE IF RL2 A POWER OF2 
          SA1    RL1
          ZR     X7,INGEN2C        IF YES 
          RJ     CHKP2             TRY RL1
          NZ     X7,INGEN2Z        IF NOT 
          SA1    RL2
 INGEN2C  SA3    MD.CSFT           CONSTANT LEFT SHIFT
  
*         OUTPUT SHIFT MACRO
  
 INGEN2D  SA2    X1 
          NZ     X6,INGEN2D1       IF SHIFT COUNT " 0 
  
*         OUTPUT XMIT FOR MULTIPLY BY 1 SO THAT ST. WILL BE GENER-
*         ATED FOR ARGUMENT.
  
          MX0    1
          SA4    X1+2 
          LX0    1+45 
          BX7    X0+X2
          SA3    XMIT 
          SA7    A2          SET USED BIT 
          MX0    -16
          BX6    -X0*X4 
          SA2    NRLN 
          SA6    PARAMS+1 
          BX7    X2 
          SX6    X2+1 
          SA7    PARAMS 
          SA6    A2          NRLN = NRLN + 1
          SX5    T.INT
          RJ     MACOUT 
          EQ     INGEN2D2 
  
 INGEN2D1 MX0    1
          SA4    X1+2              GET RI OF RLI
          LX0    1+45 
          BX7    X0+X2             SET USED BIT 
          SA7    A2 
          MX0    60-16
          SA6    PARAMS+2          STORE SHIFT COUNT
          BX6    -X0*X4 
          SA2    NRLN 
          SA6    PARAMS 
          BX7    X2 
          SX6    X2+1              NRLN = NRLN+1
          SA7    PARAMS+1          STORE R NUMBER OF RESULT 
          SA6    A2 
          SX5    T.INT
          RJ     MACOUT            OUTPUT MACRO 
          SA1    LASTR
          MX0    1
          SA2    X1 
          LX0    1+44        SET XMT BIT IN HEADER WORD 
          BX6    X0+X2
          SA6    A2 
  
 INGEN2D2 BX7    X7-X7
          SA7    ROFG              CLEAR REVERSE OPERAND FLAG 
          RJ     FNDOP
          SA6    RL1
          EQ     INGEN
          SPACE  3
 INGEN2Z  SA1    RL1
          SA2       RL2 
          SA3    X1 
          MX0       1 
          SA4    X2 
          LX0       46        TURN ON USED BIT IN OPD 
          BX6    X3+X0
          BX7      X4+X0           SET USED BIT FOR RL2 
          SA6    A3 
          SA7    A4 
          SA3    X1+2         GET RN,S OF OPDS
          MX0    60-16
          SA4    X2+2 
          BX6    -X0*X3 
          BX7    -X0*X4 
          SA1    ROFG 
          PL     X1,MOP22     IF OPDS WERENT REVERSED 
          MX7    0
          BX6   -X0*X4
          SA7    ROFG         RESET ROFG
          BX7   -X0*X3
 MOP22    SA6    PARAMS+1     RJ
          SA7    PARAMS+2     RK
          SX6    X6+1         IN CASE DBL LNGTH 
          SA6       PARAMS+4
          SX7    X7+1 
          SA7       PARAMS+5
          SA2       NARN
          BX6    X2 
          SA6       PARAMS
          SX7    X2+1 
          SA7       PARAMS+3
          SA1       OPDTYP
          SA3       SLBMD 
          SB2    X1-T.DBL 
          ZR     B2,MOP25     IF DBL
          SB2    X1-T.CPLX
          NZ     B2,MOP26     IF SNGL 
 MOP25    SX7    X7+1 
          SA3       DLBMD 
 MOP26    SA7       NARN
          SA1    SMACD
          SB2    X1 
          PX3    B2,X3        X3 NOW=ARITH,S MACRO DESCRIPTOR WORD
          SA5       TYPEWD
          RJ        MACOUT
          RJ        FNDOP     FIND UNUSED OP PRECEDING RL2. RETURN WITH 
          SA6    RL1            ADR IN X6 
          ZR        INGEN 
*     END OF INGEN
* 
* 
*     MOP1 IF LOGICAL OPERANDS AND NON-LOG.OPERATOR 
 MOP1     EERR      ERMSG10 
* 
*     MOP17 IF OPDS NOT TYPE REAL 
 MOP17    SX2    X1-T.INT 
          SA3       SMACD 
          SX6    X3+1 
          ZR    X2,MOP24      IF TINT 
          SX2    X1-T.OCT 
          PL     X2,MOP30     IF BOTH OPDS ARE OCT OR HOL 
          SX2    X1-T.DBL 
          SX6    X6+1 
          ZR     X2,MOP24     IF TDBL 
          SX6    X6+1         HERE IF TYPE CMPX 
          SA6    SMACD
          BX1    X6 
          ZR     MOPROUND          CHECK FOR POSSIBLE COMPLEX ROUND 
 MOP24    SA6       SMACD     SAVE NEW MACRO CODE 
          ZR        MOP12 
* 
*     MOP7 IF MIXED MODE OPERANDS, LOWER TYPE NOT CONST.
 MOP7     SA1       TYPEWD
          SA5       RL1       X5=ADR OF R-ENTRY TO BE CONVERTED 
          SB5    X1           B5=TYPE TO CONVERT TO 
          RJ        MODCH 
          SA6       RL1 
          ZR        MOP5
* 
* 
 MOP8     SA1       ROFG      RL1 AND RL2 HAVE IN EFFECT BEEN REVERSED
          BX6   -X1           MIGHT HAVE PREVIOUSLY BEEN REVERSED 
          SA6       ROFG
          ZR        MOP5
* 
* 
*     TM3 FROM CMPARE IF H(OP)=H(OM). 
 TM3      SB5    B3-UMOP      IS OM U-Y 
          SB7    B6-2 
          ZR     B5,TM3A      IF YES
          NG     B7,POPOP     IF HIERARCHY IS L2
          LX3    59-18        PUT B18 OF OP IN B0 
          NG     X3,TM3B      IF GP FLG BIT ON
          SB5    B4-EL.STAR 
          ZR     B5,TM3C      IF *
          SB5    B4-MLTSOP
          NZ     B5,POPOP     IF NO 
 TM3C     SB5    B3-EL.SLASH
          ZR       B5,POPOP  IF INTEGER DIVIDE
          SA1      FF 
          NG     X1,POPOP     IF YES
          ZR        ADDOP     NO
*     TM3B ENTERED WITH B3=OM OP CODE 
 TM3B     SB5    B3-RMINOC
          ZR     B5,POPOP      POP OPERATOR IF OP IS REVERSE MINUS OR 
          SB5    B3-RDVDOC         REVERSE DIVIDE.
          ZR     B5,POPOP 
          SA1    RL2           TURN ON GPTU BIT IN LAST RL. 
          SX6    B3 
          SA2    X1 
          MX3    1
          SA6       TS1 
          LX3    47 
          BX6    X2+X3
          SA6    A2 
          SA1       RL1       RESET RLS 
          BX7    X1 
          SA7       RL2 
          SA1       OP        SET CGP BIT IN OP (CONFIRMED GP BIT)
          MX0       1 
          LX0       23
          BX6    X0+X1
          SA6       OP
          RJ        FNDOP 
          SA1       TS1 
          SA6       RL1 
          SB3    X1 
          SB5    B3-EL.MINUS       IS OM = -Y 
          NZ     B5,TM3D      IF NO 
          SB2       RMINOC
 TM3E     SA1    OSPTR
          SA2    X1+OPSTAK
          PX6    B2,X2
          SA6    A2 
          ZR        ADDOP 
 TM3D     SB5    B3-EL.SLASH       IS ON = /Y 
          NZ     B5,ADDOP     IF NO 
          SB2       RDVDOC
          ZR        TM3E
* 
*     TM3A IF OM=U- AND H(OP) =H(OM)
 TM3A     SB7    B4-EL.PLUS 
          EQ     B7,B0,TM3A2       PLUS 
          SA1    OSPTR
          SB2    X1 
          SA2    B2+OPSTAK
          EQ    POPOP 
TM3A2     BSS    0
          SA1    OSPTR             REMOVE U- FROM  OS 
          SA2    RMIOP        PUT R- IN OP
          SX6    X1-1 
          BX7    X2 
          SA6    OSPTR
          SA7    OP 
          EQ     ADDOP
          TITLE  ROP - RELATIONAL OP POPPED FROM STACK
*         ROP - RELATIONAL OP POPPED
  
 ROP      SA5    OP                OP THAT POPPED THE RELATIONAL
          SB7    EL.LE
          SB3    B3-B7             CHANGE ELIST CODE TO ORDINAL 
          UX0    B6,X5       B6 = ELIST CODE(OP)
          SX7    X5-5 
          NZ     X7,ROP1           IF NOT AN RELATIONAL OP
          EERR   ERMSG26           SYNTAX ERROR 
  
*         ISSUE A DIAGNOSTIC IF EITHER OPERAND IS TYPE LOGICAL. 
  
 ROP1     UX3    B4,X3             B4 = MODE(RL1) 
          SB2    T.LOG
          UX4    B7,X4             B7 = MODE(RL2) 
          EQ     B2,B4,MOP1  IF MODE(RL1) = LOGICAL 
          EQ     B2,B7,MOP1  IF MODE(RL2) = LOGICAL 
  
*         ISSUE AN ANSI DIAGNOSTIC IF EITHER OPERAND IS COMPLEX.
  
          SB2    T.CPLX 
          EQ     B4,B2,ROP2        IF TYPE COMPLEX
          NE     B7,B2,ROP3        IF NOT 
  
 ROP2     PX6    B3,X6             SAVE OP CODE AND MACRO NUMBER
          SA6    SMACD
          USASDM ERMSG43           ISSUE DIAGNOSTIC 
          SA1    SMACD
          UX6    B3,X1             RESTORE REGISTERS
          SA5    OP 
          UX0    B6,X5
  
*         SEE IF THIS IS THE ONLY RELATIONAL EXPR IN A IF STMT
*         AND IF SO, OPTIMIZE IT BY CHANGING THE RELATIONAL INTO
*         A SUBTRACT. 
  
 ROP3     SB7    EL.) 
          NE     B6,B7,MOP         IF RELATIONAL OP NOT POPPED BY A ) 
          SA5    OSPTR
          SX7    X5-2 
          NZ     X7,MOP            IF OPSTACK CONATINS MORE THAN A )
          SA5    TRCFLG 
          PL     X5,MOP      IF DEBUG TRACING ON BYPASS OPTIMIZATION
          SA5    TYPE 
          SX7    X5-16
          SX5    X5-17
          ZR     X7,ROP4           IF AN IF STMT
          NZ     X5,MOP            IF NOT AN IF STMT
  
*         SET IFRELOP TO  1   2   3   4   5   6 
*                         GT  EQ  GE  LT  NE  LE
  
 ROP4     SB4    B3+B3
          SX5    251346B           CONVERSION TABLE 
          MX0    60-3 
          SB4    B3+B4             3*ORD
          AX5    B4,X5
          BX7    -X0*X5 
          SA7    IFRELOP
  
*         CHANGE GT TO LT AND LE TO GE BY SWAPPING OPERANDS 
*         THIS IS DONE BECAUSE LT AND GE ARE MACHINE INSTRUCTIONS 
  
          SX5    X7-1 
          SB7    4
          ZR     X5,ROP5           CHANGE GT TO LT
          SX5    X7-6 
          NZ     X5,ROP6           CHANGE LE TO GE
          SB7    3
 ROP5     SA1    RL1
          SA2    RL2
          SX7    B7 
          SA7    A7                UPDATE IFRELOP 
          BX6    X2 
          LX7    X1                SWAP( RL1 , RL2 )
          SA6    A1 
          SA7    A2 
  
 ROP6     SX6    M.SUB
          EQ     MOP
          TITLE 
*         SFLPR - STATEMENT FUNCTION ( POPPED 
 SFLPR    UX7    B2,X4             B2 = MODE OF RESULT
          BX5    X2 
          AX0    44 
          SB5    X0                B5 = TYPE OF ASF 
          EQ     B2,B5,LPAR        IF TYPES THE SAME
          MX7    1
          SA7    ASFMF       STATEMENT FUNCTION FLAG
          RJ     MODCH       CHANGE TYPE TO THAT OF ASF 
          MX7    0
          SA7    ASFMF       RESET STATEMENT FUNCTION FLAG
          SA1    MCOPDA      MODE CHANGE - OPERAND ADDRESS
          SA2    X1 
          UX7    B2,X2
          SB6    T.OCT
          NE     B2,B6,SFLPR1 IF MODE OF RESULT ISNT OCTAL
          SA1    MCTYP       MODE CHANGE TYPE 
          SB5    X1 
          PX7    B5,X7       UPDATE 
          SA7    A2          SAVE 
 SFLPR1   SA1    OSPTR
          SA2    OPSTAK+1+X1       LOAD SF( AND FALL THROUGH
          SA6    RL2
 LPAR     SA3       OP        RESTORE PREVIOUS MODE 
          SA1    OSPTR
          SA2    OPSTAK+1+X1
          SB2    EL.) 
          MX0    60-3 
          AX2    19 
          BX6   -X0*X2
          UX0 B3,X3 
          SA6    EMODE
          NE  B2,B3,LPAR1     IF -(- NOT POPPED BY -)-
          SA1       OSPTR     TAKE CARE OF SAVED ARLPT
          SA2       TYPE      SEE IF END OF IF EXPRESSION 
          SX6    X1-1         REDUCE OSPTR FOR SAVED ARLPT
          NZ     X6,LPAR2     IF OPSTAK NOT EMPTY 
          SB2    X2-16
          SB3    X2-17
          ZR     B2,OUT3      IF END OF IF EXPR 
          ZR     B3,OUT3      ' 
 LPAR2    SA2       EPOINT
          SA3    X2 
          SA6       OSPTR 
          UX0 B2,X3 
          SB3    EL.DSTR
          NE  B2,B3,NEXTE     IF STATE FUN OR PAREN EXPR NOT FLWD BY ** 
          SA1    X6+OPSTAK+1  GET SAVED ARLPT 
          SX7    X1 
          AX1       18
          SA7       STBASE
          BX6    X1 
          SA6       NSFR
          ZR        NEXTE 
* 
 LPAR1    EERR      ERMSG3    NO MATCHING RT PARENS 
* 
*     EOSPO IF (OPERATOR BUFFER CLOSED OUT) END OF STATEMENT OP POPPED
 EOSPO    SA1    OP           IS OP=)   (FROM OPSWTB) 
          UX0 B3,X1 
          SB1    B3-EL.)
          ZR     B1,EQPO1     IF YES
          SA1       TYPE      GET STATE TYPE
          SB2    X1-RPLST 
          ZR     B2,OUT       IF REPL STATE 
          ZR        GTOUT 
          TITLE              STORES PROCESSING
 EQPO1    EERR   ERMSG4       NO MATCHING LEFT PAREN. 
* 
*     EQPO IF =SIGN POPPED. 
 EQPO     SA1    OP           IS OP THE EOS OP Y
          SB2    EL.EOS 
          UX0 B3,X1 
          NE  B2,B3,EQPO1     IF NO 
          SA5    EQCOUNT
          SX7    X5+1 
          SA7    A5                INCREMENT EQUAL SIGN COUNTER 
          SA1    SFRSTB 
          ZR     X1,EQPO4.         IF NO SAVED FUNCTION RESULTS 
          SA3    NARN 
          BX6    X3 
          SA6    SAVENARN          SAVE CURRENT R NUMBER
 EQPO1.   SA2    X1+FRSTB-1        FUNCTION RESULT INFORMATION WORD 
          SX6    X1-1 
          BX3    X2 
          SA6    TS1+2             SAVE DECREMENTED COUNT 
          AX3    34 
          SA5    EQCOUNT
          SX4    X3                IF THE EQUAL SIGN COUNTER AND THE
          IX6    X5-X4                 INFORMATION FIELD MATCH, WE NEED 
          NG     X6,EQPO3.             TO OUTPUT A LOAD OF THE SAVED
          NZ     X6,EQPO2.             FUNCTION RESULT
          BX3    X2 
          MX0    60-16
          AX2    58                POSITION SINGLE/DOUBLE BIT 
          BX7    -X0*X3            R NAME 
          SX6    X2+T.REAL         REAL IF SINGLE, DBL IF DOUBLE
          SB6    B0 
          LX6    P.TYP             POSITION IN TYPE FIELD 
          SA7    NARN              RESET
          SA6    NAME+1            NEEDED FOR FETCH CALL
          AX3    16 
          SA5    ST.               ST. ORDINAL
          SB7    X3                STATEMENT TEMPORARY ORDINAL
          SX6    B0 
          SA6    IDORDLTS 
          SA6    A6+1 
          RJ     FETCH             OUTPUT LOAD OF FUNCTION RESULT 
          RJ     CHKOFF 
 EQPO2.   SA1    TS1+2
          NZ     X1,EQPO1.         IF MORE FUNCTION RESULTS 
 EQPO3.   SA3    SAVENARN 
          BX6    X3 
          SA6    NARN              RESTORE NARN VALUE 
 EQPO4.   BSS    0
          SA1       RL1       SET DEFINED BIT IN SYMTAB FOR VARIABLE
          SA3    X1+1 
          SB1    X3 
          AX3    18 
          SX6    X3 
          SA6    NCAD        STORE CA FOR DODEF 
          SA3    A3+3 
          MX0    -R1.RIL
          LX3    -R1.RIL
          BX6    -X0*X3 
          SA6    NRFD        RF OF LOAD 
          SA3    X1+2        RMACRO HEADER
          UX1    B6,X3
          SB6    B6+STLMAC
          NZ     B6,EQPO4.1  IF NOT AN IXFN 
          MX6    1
          SA6    NRFD        SET RF .NE. 0
 EQPO4.1  BSS    0
          SX3    B1+B1
          SA4       SYM1      GET ADR OF SYMTAB 
          IX5    X4-X3        COMPUTE ADR.
          MX0       1 
          SA3    X5           GET 1ST WD
          LX0       17        POSITION DEFINED BIT (B16)
          BX6    X3+X0
          SA6    X5           STORE BACK IN SYMTAB
          SA4    X5-1        GET WORD B FOR THIS SYMBOL 
          LX4    59-P.FPB 
          PL     X4,EQPO4.2  IF NOT FP
          LX4    P.FPB-P.RL 
          PL     X4,EQPO4.2  IF NOT RL
          SA5    X5 
          MX3    L.NAME 
          BX3    X3*X5      EXTRACT SYMBOL
          LX3    60-12
          SX2    1R 
          BX3    X3+X2      ADD BLANK FILL
          POSTER SEV=ANSI,NR=ERMSG62,FMT=DPC,TXT=X3 
          SA1    RL1
          SA3    X1+1 
          SB1    X3          RESTORE B1 
 EQPO4.2  BSS    0
          RJ        DODEF 
          SA1       EPOINT    RESTORE B1
          SB1    X1+1 
*     ARE TYPES THE SAME- 
          SA1    WLSTR
          MX7    0
          SA7    NCAD 
          SA7    NRFD 
          ZR     X1,EQPO7C         LAST STORE NOT TRACED
          SA7    A1                CLEAR FLAG 
          SA7    EQPO5F            CLEAR XMIT FLAG
          SA2    TS1+1             NAME AND TYPE
          SA1    DBGAPL+1          IH, CA INFORMATION 
          SX6    X2                GET TYPE 
          SX5    X1                IH FIELD 
          LX6    P.TYP
          LX1    30 
          SB7    X1                CA FIELD 
          SA6    NAME+1            NEEDED FOR FETCH 
          SB6    B0 
          SA1    RL1               POINTS TO REPLACEMENT MACRO
          MX0    1
          LX0    1+P.USED 
          SA2    RL2               POINTS TO RESULT MACRO 
          SA3    X2                HEADER WORD
          BX7    X0+X3             SET USED BIT IN RESULT MACRO 
          BX6    X1 
          SA7    A3 
          SA6    RL1TS             SAVE POINTER 
          RJ     FETCH             OUTPUT LOAD MACRO
          SA2    RL1TS
          BX6    X2 
          SA6    RL1               RESTORE POINTER
 EQPO7C   SA1    RL1
          SA5       RL2       X5=ADR OF RESULT OF EXPR. 
          SA3    X1 
          SA4    X5 
          UX0 B5,X3           (B5=TYPE OF REPLACEMENT ELEMENT)
          UX6 B2,X4 
          EQ  B2,B5,EQPO2     IF TYPES ARE THE SAME 
          SB3    T.CPLX 
          EQ  B3,B2,EQPO7A    IF CPX OPD
          NE  B3,B5,EQPO7B    IF NEITHER OPD CMPX 
EQPO7A    USASDM ERMSG45         NON-USAS COMBINATION 
          SA1       RL1 
          SA5       RL2 
          SA3    X1 
          UX0 B5,X3 
 EQPO7B   BSS       0 
          RJ        MODCH     CONVERT RESULT TO TYPE OF REPLACEMENT-
          SA6    RL2                                        -ELEMENT. 
          BX2    X6-X5
          NZ     X2,EQPO2          IF CONVERSION TOOK PLACE 
          SA6    OCTHO             TURN ON OCTAL-HOLLERITH FLAG 
 EQPO2    SA1       RL2       SEE IF LAST OP WAS LOAD.  (A=B TYPE STATE)
          SA3    X1 
          SA2    X1+2         IF SO, OUTPUT BX6=XI
          LX3       59-44 
          UX0 B3,X2 
          NG     X3,EQPO5     IF XMT FLAG ON
*             XMT SET BY MODCH, LDVRPRT 
*         AND FOR RNM TYPE INTRINSICS 
          SB2    B3+SLMACO
          ZR     B2,EQPO5     IF LOAD 
          SB2    B3+DLMACO
          ZR     B2,EQPO5     IF LOAD 
          SB2    B3+STLMAC     STD SUBSLD)
          NZ     B2,EQPO6     IF NOT A LOAD 
*     REPLACE XMITOP WITH NEW MACRO IF A NEW RLIST OP IS DEFINED TO 
*  TRANSMIT ONLY IF PREVIOUS OP A LOAD. 
 EQPO5    SX6       XMITOP    OUTPUT TRANSMIT MACRO 
          SA1       EQPO5F
          NZ     X1,EQPO6     IF HAVE ALREADY OUTPUT A XMIT 
          SA6       EQPO5F
*     IF DBL LENGTH, UINGEN WILL SX6=X6+1 
          RJ        UINGEN
 EQPO6    BSS    0                 SUPPOSE A=B IS STMT
          SA4    OCTHO             OCTAL-HOLL FLAG
          SA1    RL1               REPLACEMENT ELEMENT,/A/
          SA5    RL2               REPLACED ELEMENT,/B/ 
          ZR     X4,EQPO6A         IF /B/ NOT OCTAL OR HOLL 
          SA2    X5                HEADER WORD OF /B/ 
          SA3    X1                HEADER WORD OF /A/ 
          MX6    0
          UX4    X2 
          SA6    A4                CLEAR OCTAL-HOLLERITH FLAG 
          UX0,B4 X3 
          PX7    B4,X4             NEW HEADER WORD OF /B/   - 
          SA7    X5 
  
 EQPO6A   SA2    X5+2              1ST WORD OF RLIST INSTR OF /B/ 
          MX3    60-16
          BX4    -X3*X2       X4=RN 
          SA2    X1+2         CHANGE MACRO CODE AND RI
          UX0 B2,X2 
          SB2    B2-1         CHANGE CODE TO A STORE
          BX2    X3*X2        INSERT NAME OF RESULT 
          BX2    X2+X4
          PX6    B2,X2
          SA6    A2 
          SB3      -STLMAC-1
          EQ  B2,B3,EQPO4     IF STD SUBS STORE 
          SA5    A2+2         CHANGE R-PARAMETERWORD
          BX2    X3*X5
          BX6    X4+X2
          SX4    X4+1         JUST IN CASE A DOUBLE STORE 
          LX6    -32
          BX6    X3*X6
          BX6    X4+X6
          LX6       32
          SA6    A5 
 EQPO4    SA4    X1 
          LX4    59-36
          NG     X4,EQPO10         IF NON STD SUB ARRAY LOAD
          SA2    X1                HEADER WORD
          SA0    B0                NEEDED FOR LASTR ADJUSTMENT
 EQPO4A   BSS    0
          AX2       18
          SB2    X2 
          SA2    ARLPT        MOVE STORE INSTR TO ARLIST. NOP OLD RLIST 
          SB3    X2+B2
          SB4    B3-ARLSZ 
          PL     B4,MAC1D     IF ARLIST BLOK FULL 
          SA3    X1           VOID THE LOAD ENTRY 
          MX0       1         SET USED BIT OF STORE INSTR IN CASE A=B=C=
          BX6   -X3 
          LX0       46
          SA6    X1 
          BX3    X0+X3
          SA4       LASTR     GET CORRECT PREVIOUS ENTRY SIZE AND INSERT
          MX0       60-18     -IN NEW ENTRY 
          SA5    X4 
          SB7    X2+ARLIST
          SUB 
          PL     X5,EQPO9     IF LAST ENTRY NOT NO-OPED 
          BX5   -X5 
 EQPO9    BSS       0 
          BX3    X0*X3
          AX5       18
          BX4    X3 
          AX4    59 
          BX4    X4-X5       SIGN OF LENGTH MATCHES HEADER
          BX4    -X0*X4      EXTRACT SIGNED LENGTH
          BX3    X3+X4
          SX7    B7+A0             POINT TO LAST MACRO MOVED
          SA7       LASTR 
 EQPO3    BX6    X3 
          SA6    X2+ARLIST    STORE IN NEW LOC. 
          SUB 
          SX1    X1+1 
          SX2    X2+1 
          SB2    B2-1 
          SA3    X1 
          NZ     B2,EQPO3 
          BX6    X2 
          SA6       ARLPT 
          SA2    DFLAG
          ZR     X2,EQPO3A         BRANCH IF NOT IN DEBUG MODE
          SA1    LASTR
          SA2    X1+1              ORDINAL OF NAME
          BX7    X2 
          SX2    X2          REMOVE ALL BUT LOWER 18 BITS 
          SA3    X1+3              ORDINAL OF VARIABLE
          SA4    X1+5              BIAS FOR VARIABLE
          LX4    30 
          LX2    1
          BX6    X4+X3
          SA6    DBGAPL+1          USED IN DEBUG CODE 
          SA3    SYM1              START OF SYMTAB
          IX4    X3-X2
          SA1    X4                WORD A 
          LX1    59-P.FP           IS THIS A FORMAL PARAMETER STORE 
          PL     X1,EQPO3B         IF NOT 
          SA7    A6                RESET TABLE WORD 
 EQPO3B   BSS    0
          SA2    X4-1              WORD B OF ENTRY
          MX0    60-L.DIF+1        ONLY NEED BOTTOM BITS
          LX2    60-P.DIF          SHIFT DEBUG BITS 
          BX7    -X0*X2            MASK OUT DEBUG BITS
          SX6    X7-DV.STO         IS STORES CHECKING TO BE DONE
          NZ      X6,EQPO3A        IF NOT 
          RJ     STRCK             PROCESS DEBUG STORES 
 EQPO3A   RJ     FNDOP
          SA6       RL1       ADR OF NEXT REP.VAR.
          EQ     CMPARE 
  
*         THIS CODE ALLOWS FOR NON STANDARD SUBSCRIPT CALCULATION MACROS
*         TO BE MOVED ALONG WITH THE LOAD MACRO AS ONE LARGE MACRO BLOCK
 EQPO10   LX4    1+36              REPOSITION WORD
          SX0    B0                INITIALIZE 
          SX6    X4                WORD COUNT OF PREVIOUS MACRO, IF ANY 
          AX4    18 
          IX3    X1-X6             ADDRESS OF PREVIOUS MACRO
          SB7    X4                WORD SIZE OF LOAD MACRO
          ZR     X6,EQPO14         IF AT BEGINNING OF BUFFER
 EQPO11   SA4    X3                MACRO HEADER 
          PL     X4,EQPO12         IF NOT NO OPED 
          BX4    -X4
 EQPO12   LX4    59-36             IS THIS A NON STD SUB ARRAY LOAD 
          NG     X4,EQPO13         IF YES 
          MX7    60-7 
          SA5    EQCOUNT           EQUAL SIGN COUNTER 
          BX7    -X7*X4            EQUAL SIGN COUNT FOR MACRO 
          IX2    X5-X7
          NZ     X2,EQPO13         IF PREVIOUS GROUP REACHED
          LX4    1+36 
          SX5    X4                WORD COUNT OF PREVIOUS MACRO, IF ANY 
          ZR     X5,EQPO14         IF AT BEGINNING OF BUFFER
          IX3    X3-X5             ADDRESS OF PREVIOUS MACRO
          IX0    X0+X6             ADD WORD COUNT TO BLOCK LENGTH 
          BX6    X5                SAVE CURRENT MACRO SIZE
          EQ     EQPO11 
 EQPO13   IX3    X3+X6             CORRECT MACRO POINTER
          SX6    B0                CLEAR
 EQPO14   IX0    X0+X6             ADD WORD COUNT TO BLOCK LENGTH 
          SA2    X1                ORIGINAL LOAD MACRO
          SX4    X0+B7             TOTAL BLOCK LENGTH 
          LX2    42 
          MX5    1
          SB6    X2                SIZE OF LOAD MACRO 
          SB2    X1+B7             POINT BEYOND LOAD MACRO
          LX2    18                REPOSITION 
          SA0    X4 
          LX5    1+45              POSITION USED BIT
          BX6    X5+X2             SET USED BIT IN CASE OF MULTIPLE = 
          LX4    18 
          SA0    A0-B6             NEEDED FOR LASTR ADJUSTMENT
          SA2    ARLIST            START OF ARLIST BUFFER 
          SUB 
          SA6    X1                RESTORE TO BUFFER
          SB3    A2 
          BX1    X3                ADJUST POINTER FOR AFTER RETURN
          SA2    ARLST             RELATIVE POINTER AFTER ENTIRE BLOCK
          SX6    B2-B3             RELATIVE POSITION OF MACRO AFTER LOAD
          IX5    X6-X2
          BX2    X4 
          NG     X5,EQPO4A         EFFECTIVELY EXIT IF ALREADY SET
          SA6    A2                REALLY ONLY SET ONCE FOR MULTIPLE =
          EQ     EQPO4A            ARLST SET SO OLD BLOCK NOT FLUSHED 
 STRCK    SPACE  4,8
*         DEBUG PROCESSOR FOR STORES CHECKING 
* 
 STRCK    DATA   0
          SA1    RL1
          SA3    RL2
          BX6    X1 
          LX7    X3 
          SA6    RL1TS             SAVE CURRENT VALUES
          SA7    RL2TS
          SA1    A2+1              WORD A OF ENTRY
          MX0    L.NAME 
          BX5    X0*X1             VARIABLE NAME
          LX2    P.DIF-P.TYP
          MX0    60-L.TYP 
          BX7    -X0*X2            VARIABLE TYPE
          SA7    TS1+3             TYPE WORD
          BX6    X5+X7
          SA6    TS1+1             NAME AND TYPE
          BX7    X2 
          SA7    NAME+1            SAVE WORD B
          LX1    59-P.DIM          ID VARIABLE DIMENSIONED
          PL     X1,STRCK0.        IF NOT 
          SA1    LASTR             ADDRESS OF LAST STORE MACRO
          MX2    0
          RJ     OTS         OUTPUT TEMP STORE
          LX3    30 
          BX6    X3+X2       30/CA(ST.), 30/ORD(ST.)
          SA6    DBGAPL+1    SET UP FOR APLIST PROCESSOR
 STRCK0.  SA2    NAME+1            RESTORE WORD B 
          MX6    0
          SA6    DBGAPL+3          ZERO TO ARGLIST TABLE
          SX7    =8RBUGSTO
          SA7    A6+1              ADDRESS TO ARGLIST TABLE 
          SA3    D.SAASI           BASE OF AS TABLE 
          LX2    P.TYP-P.DTO
          MX0    60-L.DTO 
          BX4    -X0*X2            GET DEBUG TABLE ORDINAL
          IX4    X3+X4             BASE + ORDINAL 
          SA1    DEBUG-1
          SB2    X4 
          SA3    A1+B2             DEBUG TABLE WORD 
          MX0    60-L.FCS 
          LX3    60-P.FCS 
          BX6    -X0*X3            FREQUENCY COUNT
          ZR     X6,STRCK3. 
          SX5    9                 HERE IF NO STORES TEST 
          SA6    TS1+2             MORE TO LINK FLAG
          MX7    0
          SA7    TS1+5             NEEDED TO EXIT LOOP
 STRCK1.  LX5    3
          SA4    TS1+1             NAME AND TYPE
          BX1    X4+X5             INSERT RELOP 
          RJ     STRIP             CHECK FOR TRAILING $ IN NAME 
          SB1    1
          RJ     CONVERT           PLACE IN CONS TABLE
          BX6    X1 
          SA6    DBGAPL            FORM ARGLIST TABLE 
          SA1    DBGAPL+3 
          SA2    A1+B5
          BX6    X1 
          LX7    X2 
          SA6    A1-B5             COLLAPSE ARGLIST TABLE TO AVOID
          SA7    A1                UNNECESSARY APLIST PARAMETER 
 STRCK2.  SA1    DBGAPL 
          SA3    STAPLC 
          MX7    0                 ZERO CHAIN WORD FOR THIS FUNCTION
          BX6    X3 
          SA7    A3 
          SA6    STAPL
          SA2    N.AP 
          BX6    X2 
          SX7    X2+1              INCREMENT APLIST NUMBER
          SA7    A2 
          RJ     IGCALL            GENERATE CALL MACRO
          SA1    =8RBUGSTO
          SB7    *+1
          EQ     SYMBOL            WILL ALWAYS RETURN TO FOUND ADDRESS
          SX6    T.CGS             PLACE TYPE CGS IN SYMTAB WORD
          LX6    P.TYP                SO REFERENCE WONT APPEAR IN 
          BX7    X6+X2                THE REFERENCE MAP 
          SA3    STAPL
          SA1    TS1+2             IS THERE MORE TO LINK
          BX6    X3 
          SA7    A2 
          SA6    STAPLC            RESTORE STORE-TO-APLIST CHAIN
          NZ     X1,STRCK7.        EXIT IF NOT
          SA2    TS1+3             CURRENT LINK WORD
          SX7    X2                GET LINK 
          ZR     X7,STRCK7.        EXIT IF AT LAST LINK 
          SA5    TS1+4             RELOCATION ADDRESS 
          MX6    0
          IX7    X5+X7             NEXT LINK ADDRESS
          SA6    DBGAPL+3 
          EQ     STRCK4.
 STRCK3.  LX3    P.FCS-P.LINK 
          MX6    0
          SX7    X3                TABLE ADDRESS
          SA6    TS1+2             LINK FLAG
          ZR     X7,STRCK8. 
          SA2    DEBUG-1
          SX6    A2                RELOCATION ADDRESS 
          SB3    X7                TABLE ADDRESS
          SA6    TS1+4
          SX7    A2+B3             NEXT LINK ADDRESS
          BX6    X3 
          SA6    TS1+5             SAVE LINK WORD 
          EQ     STRCK4.
 STRCK8.  LX3    P.LINK-P.LINKI 
          MX7    0
          SX6    X3                TABLE ORDINAL
          SA7    TS1+5             WILL TERMINATE LOOP
          ZR     X6,STRCK7.        IF DONE
          SA2    DEBUG-1
          SA3    D.SAASI           BASE OF AS TABLE 
          IX4    X3+X6             ORDINAL + BASE 
          SB2    X3 
          SX6    A2+B2             RELOCATION ADDRESS 
          SB3    X4 
          SA6    TS1+4
          SX7    A2+B3             NEXT LINK ADDRESS
          MX6    0
          SA6    TS1+5             WILL TERMINATE LOOP
 STRCK4.  SA2    X7                GET NEXT LINK ENTRY
          MX0    60-L.RO
          BX6    X2 
          SA6    TS1+3             SAVE LINK WORD 
          LX2    60-P.RO
          BX5    -X0*X2            GET RELOP
          SB2    X5 
          EQ     B0,B2,STRCK1.     INDEF RELOP
          SB3    7
          EQ     B3,B2,STRCK1.     RANGE RELOP
          LX5    3
          SA4    TS1+1             NAME AND TYPE
          BX1    X4+X5
          RJ     STRIP             CHECK FOR TRAILING $ IN NAME 
          SB1    1
          RJ     CONVERT           PLACE IN CONS TABLE
          BX6    X1 
          SA6    DBGAPL            FORM ARGLIST TABLE 
          SA3    TS1+3             LINK WORD
          MX0    60-L.CONST 
          LX3    60-P.CONST 
          BX4    -X0*X3            GET CONSTANT FIELD 
          MX0    60-L.CORD
          BX3    -X0*X4            GET CONSTANT ORDINAL 
          LX4    59-P.COV 
          NG     X4,STRCK9.        BRANCH IF VARIABLE AFTER RELATIONAL
          LX4    P.COV-P.GCF
          PL     X4,STRCK6.        BRANCH IF CONS IN REAL TABLE 
          MX0    60-L.TYP 
          BX7    -X0*X4            GET CONSTANT TYPE
          SB1    B5 
          SA2    O.GCON            START OF GLOBAL CONS TABLE 
          SB3    X3 
          SA1    X2+B3             LOAD CONSTANT
          SB4    X7-T.DBL 
          SB3    X7-T.CPLX
          NZ     B4,STRCK5.        IF NOT DOUBLE WORD 
          NZ     B3,STRCK5.        IF NOT DOUBLE WORD 
          SB1    B5+B5             IF DOUBLE WORD CONSTANT
          SA2    A1+B5             SECOND HALF OF CONSTANT
 STRCK5.  RJ     CONVERT           PLACE IN CONS TABLE
          BX6    X1 
          SA6    DBGAPL+2          FORM ARGLIST TABLE 
          MX7    0
          SA7    A6+B5
          EQ     STRCK2.
 STRCK6.  SA1    CON.              CONSTANT TABLE ORDINAL 
          LX3    30 
          BX6    X3+X1             IH OF CONSTANT 
          SA6    DBGAPL+2          FORM ARGLIST TABLE 
          MX7    0
          SA7    A6+B5
          EQ     STRCK2.
 STRCK7.  SA3    TS1+5
          NZ     X3,STRCK8.        IF MORE TO LINK
          SA1    RL1TS
          SA2    RL2TS
          BX6    X1 
          LX7    X2 
          SA6    RL1               RESTORE SAVED VALUES 
          SA7    RL2
          SA6    WLSTR             SET FLAG NON ZERO
          EQ     STRCK
 STRCK9.  MX0    60-12
          BX6    -X0*X3            VARIABLE ORDINAL 
          SA6    DBGAPL+2          FORM ARGLIST TABLE 
          MX7    0
          SA7    A6+B5
          EQ     STRCK2.
          TITLE 
          EJECT 
 OUT3     SA1       RL2 
          BX6    X1 
          SA6       EXPRIA    SAVE ADR OF EXPR RESULT INSTR 
*     OUT IF NORMAL ARITH EXIT
 OUT      SA1       SFRSTB
          ZR     X1,OUT6     IF NO FUNCTION RESULTS SAVED 
          SA3       NARN
          SA2       ARLPT 
          BX6    X3 
          AX7    B0,X2
          SA6       TS1       SAVED NARN
          SA7       TS1+1       11  ARLPT 
 OUT2     SA2    X1+FRSTB-1 
          SX6    X1-1 
          BX3    X2           PREPARE FOR CALL OF FETCH 
          SA6       TS1+2     FUNC RESULT CNT 
          AX2    34 
          SX7    X2                EQUAL SIGN COUNT 
          NZ     X7,OUT4           FUNCTION RESULT NOT FROM MAIN EXPSSON
          BX2    X3 
          AX2       58        RIGHT ADJ.DBL WD EL FLAG BIT
          SX6    X2+T.REAL         REAL IF SINGLE, DBL IF DOUBLE
          LX6    P.TYP             PLACE IN TYPE FIELD
          SA6       NAME+1
          MX0       60-16     SET UP NAME OF RESULT SAVED 
          BX7   -X0*X3
          SA7       NARN
          SB6    B0 
          AX3    16 
          SB7    X3                CA OF ST.
          SA5    ST.               IH OF ST.
          SX6    B0 
          SA6    IDORDLTS 
          SA6    A6+1 
          RJ        FETCH 
          SA1       TS1+2 
          NZ     X1,OUT2      IF MORE FRSTB ENTRIES 
 OUT4     BSS    0
          SA4       TS1+1     OUTPUT THE LOADS TO RLIST 
          SA5       ARLPT 
          BX6    X4 
          SA6       ARLPT 
          RJ        DARLIST 
          SA1       TS1 
          BX6    X1 
          SA6       NARN
 OUT6     SA4    ARLST             RESET APL POINTER FOR SUBROUTINE APL 
          SA5       ARLPT 
          RJ        DARLIST 
          SA2    IXFNFG 
          NZ     X2,IXFN7          RETURN TO IXFN PROCESSOR 
          ZR        ARITH 
 FNDOP    TITLE  SUBROUTINES
**        FNDOP - FIND FIRST UNUSED OPERAND PRECEDING RL2.
*         OPERANDS WITH GPTU BIT SET, AS WELL AS THOSE WHICH HAVE BEEN
*         NO-OPED, ARE PASSED OVER. 
* 
*         EXIT   X6 - ADDRESS OF FOUND OPERAND, OR 0 IF NONE EXISTS.
* 
*         PRESERVES  B1.
  
 FNDOP    ENTRY. *           ** ENTRY/EXIT ** 
          SA1    RL2
          SA3    FNDOPA 
          MX6    0
          SA2    X1 
          SB2    X1 
          BX2    -X2         SIMULATE NO-OP FOR RL2 
  
 FNDOP1   ZR     B2,FNDOP    IF NO PRECEDING ENTRY
          BX0    X2 
          AX2    59 
          BX1    X2-X0
          SB2    X1+         LENGTH OF PRECEDING ENTRY
          BX0    X3*X0
          SA2    A2-B2       LOAD HEADER OF PRECEDING ENTRY 
          NZ     X0,FNDOP1   IF ENTRY NO-OPED, USED OR GPTU 
          SX6    A2+B2       RESTORE ADDRESS OF NEXT ENTRY
          EQ     FNDOP
  
 FNDOPA   CON    1S59+1S46+1S45    NO-OP .OR. USED .OR. GPTU BITS 
          SPACE  4,8
**        CLGP - CLEAR GPTU BIT.
*         CLEAR GPTU BIT OF FIRST ENTRY IN ARLIST PRECEDING RL2 WITH
*         THAT BIT SET. 
  
 CLGP1    ZR     B3,CLGP     IF NO PRECEDING ENTRY
          BX0    X2 
          AX2    59 
          BX6    -X2-X0 
          SB3    X6          LENGTH OF PRECEDING ENTRY
          LX6    59-46
          BX3    X6+X0
          SA2    A2+B3       HEADER OF PRECEDING ENTRY
          MI     X3,CLGP1    IF ENTRY NO-OPED OR NOT GPTU 
  
*         CLEAR GPTU BIT. 
  
          MX4    1
          LX4    1+46 
          BX7    -X4*X0 
          SA7    A2-B3
  
 CLGP     ENTRY. *           ** ENTRY/EXIT ** 
          SA1    RL2
          SA2    X1+
          BX2    -X2         SIMULATE NO-OP FOR RL2 
          SB3    X1 
          EQ     CLGP1
 CHKOFF   SPACE  3
 CHKOFF   ENTRY. *                 ** ENTRY/EXIT ** 
          SA1       RL2       TURN ON USED BIT OF ENTRY AT RL2
          MX0       1 
          SA2    X1 
          LX0       46
          BX7    X0+X2
          SA7    X1 
          SA2       RL1       ADJUST RLS
          BX6    X2 
          SA6       RL2 
          RJ        FNDOP 
          SA6       RL1 
          ZR        CHKOFF
          EJECT 
*     UINGEN: OUTPUTS UNARY OPERATORS WITH RL2 INDICATING OPERAND.  TYPE
** OF RESULT WILL BE SAME AS OPD,S.   COME WITH X6=MACRO CODE 
** IF OPD TYPE IS DBL/CMPX, UINGEN ADDS 1 TO MAC CODE IN S6.
*  IF .NOT. HAS A DBL OPD, IT WILL BE CHANGED TO SNGL BEFORE CALL UINGEN
 UINGEN   ENTRY. *                 ** ENTRY/EXIT ** 
          SA1       RL2 
          SA2    X1 
          UX0 B2,X2 
          LX2       59-47 
          PL     X2,UINGN3    IF NOT CONST OPD
          SX7    B2 
          SB3    X6-MAC-43
          NZ     B3,UINGN3         NOT U- 
          SB3    T.DBL
          SB4    T.CPLX 
          EQ  B2,B3,UINGN3    IF DBL U- 
          EQ  B2,B4,UINGN3    IF CPX U- 
          SA7       TYPEWD    HERE FOR COMPILE TIME U-
          SA1    X1 
          RJ        NEWCON    NO-OP OLD CONST AND GET VALUE 
          BX6   -X6 
          RJ     OPNCON       OUTPUT NEW CONSTANT 
          ZR        UINGEN
 UINGN3   SA1       RL2 
          MX0       1 
          SA2    X1           TURN ON USED BIT
          LX0       46
          BX7    X2+X0
          UX0 B2,X2           GET TYPE IN X5
          SA7    X1 
          SX5    B2 
          SA2    X1+2         GET RN OF OPD 
          MX0    60-16
          BX7   -X0*X2
          SA7    PARAMS+1 
          SX7    X7+1         IN CASE DBL LENGTH
          SA7       PARAMS+3
          SA2    NARN         GET RESULT NO.
          BX7    X2 
          SA7    PARAMS       RI
          SX7    X2+1         UPDATE RN 
          SA3       SLBMD 
          SA7       PARAMS+2
          SB3    T.DBL
          SB4    T.CPLX 
          EQ  B2,B3,UINGN2
          NE  B2,B4,UINGN1
 UINGN2   SX7    X7+1 
          SA3       DLBMD 
          SX6    X6+1 
 UINGN1   SA7       NARN
          SB2    X6 
          PX3    B2,X3
          RJ        MACOUT
          RJ        FNDOP 
          SA6    RL1
          ZR        UINGEN    END OF UINGEN 
          TITLE                  MACOUT--OUTPUT R-LIST MACROS TO 'ARLIST
,' BUFFER 
************************************************************************
*                                                                      *
*                M  A  C  O  U  T                                      *
*                                                                      *
*              THIS ROUTINE WILL OUTPUT A DESIGNATED R-LIST MACRO TO   *
*         THE 'ARLIST' BUFFER AREA, PACKING THE PARAMETERS SUPPLIED IN *
*         THE 'PARAM' AREA (ONE PER WORD, RIGHT-JUSTIFIED).  UPON      *
*         ENTRY TO  'MACOUT' THE FOLLOWING REGISTERS MUST HAVE BEEN    *
*         SETUP:                                                       *
*                                                                      *
*                X2      -- RI                                         *
*                X3      -- 'ARITH'S MACRO DESCRIPTOR WORD             *
*                X5      -- TYPE OF RESULT                             *
*                PARAMS -- MACRO PARAMETERS (ONE PER WORD)             *
*                                A)  SYMBOLS   (IF ANY)                *
*                                B)  R-S       (IF ANY)                *
*                                C)  CONSTANTS (IF ANY)                *
*                                                                      *
*              UPON EXIT FROM 'MACOUT' THE FOLLOWING INFORMATION WILL  *
*         BE AVAILABLE:                                                *
*                                                                      *
*                X7      -- ADDRESS OF R-LIST MACRO ENTRY IN 'ARLIST'  *
*                B1      -- CONTENTS UNDISTURBED                       *
*                RL1     -- UPDATED                                    *
*                RL2     -- UPDATED                                    *
*                ARLPT   -- UPDATED                                    *
*                LASTR   -- UPDATED                                    *
*                                                                      *
************************************************************************
          SPACE  1
MACOUT    BSS    1
          UX4    X3,B2           EXTRACT THE R-LIST MACRO OPCODE AND THE
          MX0    60-12             NUMBER OF PARAMETER WORDS WHICH WILL 
          LX4    24                FOLLOW (IN PACKED FORM). 
          BX6    -X0*X4 
          SB4    X6-ARLSZ 
          SA1    ARLPT           LOAD THE CURRENT 'ARLIST' POINTER. 
          SB2    -B2             (COMPLEMENT THE MACRO OPCODE)
          LX6    30 
          IX4    X6+X2
          PX7    X4,B2
          SB7    X1+3 
          SB4    B4+B7
          BX1    -X0*X3          (EXTRACT THE NUMBER OF SYMBOLIC
          SB6    X1                PARAMETERS FOR THIS MACRO.)
          PL     B4,ARLOVER      IF THE 'ARLIST' BUFFER WILL OVERFLOW 
          SA7    B7+ARLIST-1     STORE THE MACRO HEADER WORD INTO THE 
                                   'ARLIST' AREA. 
          SUB 
          SB5    1               (SET A CONSTANT ONE FOR THE  REMAINDER 
                                   OF THIS ROUTINE ONLY.) 
          SB2    PARAMS 
          SB4    48 
          ZR     X1,MACOUT.4     IF THERE ARE NO SYMBOLIC PARAMETERS
MACOUT.1  MX1    60-30           FORM A MASK TO EXTRACT SYMBOLIC FIELDS.
          BX6    X6-X6           CLEAR THE PACKED PARAMETER ACCUMULATOR.
          SB3    B0              INITIALIZE THE SHIFT COUNT.
MACOUT.2  SA2    B2              FETCH THE NEXT PARAMETER.
          SB6    B6-B5           DECREMENT THE NUMBER OF SYMBOLS. 
          BX7    -X1*X2          EXTRACT THE SYMBOL FIELD.
          LX2    X7,B3           POSITION THE SYMBOL FOR PACKING. 
          SB2    B2+B5           INCREMENT THE 'PARAM' ADDRESS. 
          BX6    X2+X6           PACK IN THESYMBOL. 
          SB3    B3+30           INCREMENT THE SHIFT COUNT. 
          ZR     B6,MACOUT.3     IF NO MORE SYMBOLS 
          LT     B3,B4,MACOUT.2  IF ROOM FOR MORE IN CURRENT PARAM WORD 
MACOUT.3  SA6    B7+ARLIST       STORE THE PACKED PARAMETER WORD. 
          SUB 
          SB7    B7+B5           INCREMENT THE 'ARLIST' POINTER ADDRESS.
          NZ     B6,MACOUT.1     IF MORE SYMBOLS
MACOUT.4  AX3    12              EXTRACT THE NUMBER OF R-S. 
          BX1    -X0*X3 
          SB6    X1 
          AX3    12 
          BX3    -X0*X3 
          ZR     X1,MACOUT.8     IF NO R-PARAMETERS 
          MX1    60-16
MACOUT.5  BX6    X6-X6           CLEAR THE PARAMETER ACCUMULATOR. 
          SB3    B0              INITIALIZE THE SHIFT COUNT.
MACOUT.6  SA2    B2              FETCH THE NEXT R-PARAMETER.
          SB6    B6-B5           DECREMENT THE COUNT OF R-PARAMETERS
          BX7    -X1*X2          EXTRACT THE R-PARMAETER. 
          LX2    X7,B3
          IX6    X6+X2
          SB2    B2+B5           INCREMENT THE 'PARAM' ADDRESS. 
          SB3    B3+16           INCREMENT THE SHIFT COUNT. 
          ZR     B6,MACOUT.7     IF NO MORE R-PARAMETERS
          LT     B3,B4,MACOUT.6  IF ROOM FOR MORE R-PARAMETERS
MACOUT.7  SA6    B7+ARLIST       STORE THE PACKED PARAMETER WORD. 
          SUB 
          SB7    B7+B5           INCREMENT THE 'ARLIST' POINTER.
          NZ     B6,MACOUT.5     IF MORE R-PARAMETERS 
 MACOUT.8 ZR     X3,MACOUT.C     IF NO CONSTANT PARAMETERS
          SB6    X3 
          MX1    60-18           SET UP MASK TO EXTRACT CONSTANTS.
MACOUT.9  BX6    X6-X6           CLEAR THEPACKED PARAMETER ACCUMULATOR. 
          SB3    B0              INITIALIZE THE SHIFT COUNT.
MACOUT.A  SA2    B2              FETCH THE NEXT CONSTANT PARAMETER. 
          SB6    B6-B5           DECREMENT THE COUNT OF CONSTANT
                                   PARAMETRS. 
          BX7    -X1*X2          EXTRACT THE CONSTANT 
          LX2    X7,B3           POSITION THE CONSTANT FOR PACKING. 
          IX6    X6+X2             (AND PACK IT)
          SB2    B2+B5           INCREMENT THE 'PARAM' ADDRESS. 
          SB3    B3+18           INCREMENT THE SHIFT COUNT. 
          ZR     B6,MACOUT.B     IF NO CONSTANTS PARAMETERS REMAIN
          LT     B3,B4,MACOUT.A  IF MORE ROOM REMAINS FOR CONSTANTS THEN
MACOUT.B  SA6    B7+ARLIST       STORE THE  PACKED CONSTANT PARAMETERS. 
          SUB 
          SB7    B7+B5           INCREMENT THE 'ARLIST' POINTER ADDRESS.
          NZ     B6,MACOUT.9     IF MORE CONSTANTS THEN GO TO 'MACOUT.9'
MACOUT.C  SA1    ARLPT
          SX7    B7              (CURRENT 'ARLIST' POINTER) 
          IX6    X7-X1           (NUMBER OF WORDS IN 'ARLIST' ENTRY.) 
          SA2    LASTR           PICKUP THE FIRST WORD OF THE LAST ENTRY
          SA4    X2 
          SA7    A1              UPDATE THE VALUE OF 'ARLPT'. 
          NZ     X1,MACOUT.D     IF THIS IS NOT THE FIRST 'ARLIST' ENTRY
          BX4    X4-X4           (OTHERWISE SET THE WORD COUNT TO ZERO.)
MACOUT.D  BX2    X4 
          AX2    59 
          BX4    X2-X4           MAKE SURE THE WORD IS POSITIVE (INCASE 
                                   THE LAST ENTRY WAS NO-OPED)
          AX4    18              EXTRACT THE NUMBER OF WORDS IN THE 
          BX4    -X0*X4            PRECEEDING ENTRY.
          LX6    18 
          BX4    X4+X6
          SB6    X5 
          SA2    EQCOUNT           EQUAL SIGN COUNTER 
          SX3    X2 
          LX3    37 
          BX4    X4+X3             INSERT IN HEADER WORD
          PX6    X4,B6           PACK THE TYPE OF RESULT INTO THE 
          SA6    X1+ARLIST         'ARLIST' HEADER WORD AND STORE IT. 
          SUB 
          BX7    X7-X7
          SA7    X1+ARLIST+1     (STORE ZERO INTO THE SECOND WORD OF THE
                                   'ARLIST' ENTRY.) 
          SUB 
          SX7    A6              UPDATE THE RL-S (REGISTER X6 WILL
          SA2    RL2               CONTAIN THE ADDRESS OF THE NEW 
          SA7    RL2               'ARLIST' ENTRY.) 
          BX6    X2 
          SA6    RL1
          SA7    LASTR           UPDATE 'LASTR'.
          EQ     MACOUT      EXIT 
  
ARLOVER   BSS    0
MAC1D     EQU    ARLOVER
          EERR   ERMSG22         'ARITH'S 'ARLIST' BLOCK FULL 
 FETCH    EJECT 
**        FETCH - OUTPUT A LOAD MACRO FOR A VARIABLE
*         ENTRY  (B6) = RF
*                (B7) = CA
*                (X5) = IH ( SYMTAB ORD ) 
*                IDLORTS = 60/IH,60/CA
*                UPDATES NARN 
  
 FETCH    ENTRY. *                 ** ENTRY/EXIT ** 
          BX6    X5 
          SA6       PARAMS    (I,H) 
          SX7    B6 
          SA7    PARAMS+2     RF
          SX6    B7 
          SA2    NARN         NEXT AVAILABLE RN 
          BX7    X2 
          MX0    60-L.TYP 
          SA7    PARAMS+1     RI
          SA1    NAME+1       GET 2ND WD OF ID TO SEE IF DBL WD ELEMENT 
          LX1    60-P.TYP 
          BX5    -X0*X1       X5 NOW HOLDS TYPE OF OPD
          SX1    X5-T.DBL 
          SX0    X5-T.CPLX
          ZR     X1,FECH2     IF DOUBLE 
          ZR     X0,FECH2     IF CMPX 
          SA6    PARAMS+3    CA 
          SA3    SLDMAC       SINGLE LOAD MACRO DESCRIPTOR. 
 FECH3    SX7    X7+1         UPDATE NARN 
          SA7    NARN 
          RJ        MACOUT
          SA2    IDORDLTS+1 
          MX1    -18
          BX2    -X1*X2 
          SA1    LASTR
          LX2    18 
          SA3    A2-1 
          BX6    X2+X3
          SA6    X1+1              SAVE ORIGINAL IH,CA IN MACRO HEADER
          ZR        FETCH 
*     FECH2 IF DOUBLE WORD ELEMENT
 FECH2    SA6    PARAMS+4     CA
          SX7    X7+1 
          SA7    PARAMS+3     RII 
          SX6    X6+1 
          SA6    PARAMS+5     CA+1
          SA3    DLMAC
          ZR        FECH3 
          EJECT 
* 
*         ROUTINE TO SEE IF CONST CAN BE EXPRESSED
*         IS OF THE FORM -(2**N - 1)
*                COME WITH CONST IN X5
*                LEAVE WITH B3 = 0 IF SPECIAL CON 
* 
SPCON     DATA   0
          CX6    X5           COUNT ONES
          SX0    59 
          IX2    X0-X6
          SB3    X2 
          MX0    1
          BX0    -X0
          AX0    B3,X0
          IX2    X5-X0        IS THIS A SPECIAL CONST 
          SX0    60 
          SB3    X0 
          NZ     X2,SPCON          NO SPECIAL CONSTANT
          IX6    X0-X6             NUMBER OF BITS IN MASK 
          SB3    0
          ZR     SPCON
 CHKARG   TITLE  CHKARG - CHECK ARGUMENT TYPE 
*** 
*         CHKARG - CHECK ARGUMENT TYPE. 
* 
*         CHECKS TO ENSURE THAT THE ARGUMENT TYPE IN THE CALL TO A
*         BASIC EXTERNAL FUNCTION OR AN INTRINSIC FUNCTION MATCHES THE
*         REQUIRED ARGUMENT TYPE. 
* 
*         ENTRY - B2 = TYPE OF ACTUAL ARGUMENT. 
*                 X2 = WORD 1 OF ARLIST ENTRY OF ACTUAL ARGUMENT. 
*                ACNT = ARGUMENT NUMBER.
*                TYADR = HOLDS POINTER TO INF OR BEF TABLE ENTRY
* 
*         EXIT - A FATAL ERROR IS ISSUED IF TYPES FAIL TO MATCH.
* 
*         USES - X0,A1,X1,B3,B4.
  
  
 CHKARG   JP     *+1S17 
          SA1    ACNT 
          SB3    X1                SAVE ACTUAL NUMBER OF ARGUMENTS
          SA1    FNAD              RETRIEVE NUMBER OF ARGS FOR THIS BEF 
          SA1    X1-1 
          MX0    -L.FARG
          LX1    -P.FARG
          BX0    -X0*X1            EXTRACT EXPECTED NUMBER OF ARGUMENTS 
          SB4    X0                SAVE NUMBER OF ARGUMENTS EXPECTED
          GE     B4,B3,CHKA0       IF NOT TOO MANY ARGUMENTS
          NZ     B4,CHKA7          IF NUMBER OF ARGS EXPECTED .NE. 0
          LX1    P.FARG-P.INF-1 
          PL     X1,CHKA7          IF NOT INTRINSIC FUNCTION
 CHKA0    MX0    -3 
*                                  FOR INTRINSIC FUNCTIONS WITH MORE
*                                  THAN 4 ARGUMENTS, ALL ARGUMENTS MUST 
*                                  BE THE SAME TYPE.  THEREFORE, THE
*                                  ARGUMENT NUMBER MAY BE TREATED MOD 4 
*                                  FOR PURPOSES OF TYPE CHECKING. 
          SX1    B3+B3
          BX1    -X0*X1 
          IX0    X1+X1
          IX0    X0+X1
          SB3    X0          (B3) = 6*ACNT
          MX0    60-6 
          SA1    EXRL1
          NZ     X1,CHKARG   IF AN EXPONENTIAL DUMMY FUNCTION 
          SA1    TYADR
          SA1    X1+2              TYPE WORD OF FUNCTION ENTRY
          LX1    B3,X1
          BX0    -X0*X1      EXTRACT EXPECTED TYPE
          SB4    X0-1        UNBIAS TYPE
          EQ     B2,B4,CHKARG      IF CORRECT TYPE
          SX0    B4-ANYSNGL 
          NG     X0,CHKA3    IF A SPECIFIC TYPE NEEDED
          SB3    B4-ANY 
          ZR     B3,CHKARG   IF TYPE ANY, NO NEED TO CHECK
          SB4    B2-DOUBLE
          ZR     B4,CHKA1    IF DOUBLE
          SB4    B2-COMPLEX 
          ZR     B4,CHKA1    IF COMPLEX 
          ZR     X0,CHKARG   IF ANYSNGL AND NOT DBL/CMPLX 
          EQ     CHKA2
 CHKA1    NZ     X0,CHKARG   IF DBL/CMPLX AND ANYDBL
 CHKA2    EERR   -ERMSG55 
          EQ     CHKARG 
  
 CHKA3    SB3    B4-DOUBLE
          ZR     B3,CHKA2    IF DOUBLE EXPECTED 
          SB3    B4-COMPLEX 
          ZR     B3,CHKA2    IF COMPLEX EXPECTED
          SB3    B2-T.OCT 
          ZR     B3,CHKARG   IF TYPE OCTAL
          SB3    B2-T.HOL 
          ZR     B3,CHKARG   IF TYPE HOLLERITH
          EQ     CHKA2
  
 CHKA7    EERR   -ERMSG21          TOO MANY ARGS FOR BEF OR INTRINSIC 
 DLDSU    SPACE  4,8
*** 
*         DLDSU -- TO SET UP A DOUBLE LOAD R-LIST MACRO FOR 
*         'MACOUT'.  THE VALUE TO LOAD IS IN 'CONST'.  BEFORE CALLING 
*         'MACOUT', SET TYPE PARAM. 
* 
 DLSU1    SA2    NARN              FORM A DOUBLE-ZERO MACRO REFERENCE 
          BX6    X2 
          SA6    PARAMS 
          SX7    X2+1 
          SA7    PARAMS+1 
          SPACE  1
DLSU2     SX6    X2+2              UPDATE R-NUMBER
          SA6    NARN 
 DLDSU    JP     *
          SA1    CONST
          SA3    DZRMD
          ZR     X1,DLSU1          IF THE CONSTANT IS ZERO GO TO 'DLSU1'
          SPACE  1
          SB1    1                 GO ENTER THE CONSTANT INTO THE CON 
          RJ     CONVERT           TABLE. 
          SA5    EPOINT            (RESTORE E-LIST POINTER) 
          SB1    X5+1 
          SX7    X1 
          SA7    PARAMS            CONLIST ORDINAL
          AX1    30 
          BX6    X1 
          SA6    PARAMS+3          CONSTANT 'CA'
          SA3    SDLMD             (SINGLE-TO-DOUBLE LOAD)
          SA2    NARN              GET THE NEXT R-NUMBER
          BX6    X2 
          SA6    PARAMS+1 
          SX7    X2+1 
          SA7    PARAMS+2 
          ZR     DLSU2             GO TO 'DLSU2' TO FINISH UP 
          TITLE 
          EJECT 
*     STCON: CAUSES AN R-LIST INSTR TO BE OUTPUT TO SET A REG.TO AN 18- 
** BIT CONST.  COME WITH CONST.IN B17-B0 OF X5
*      THE TYPE ARLIST INSTR OUTPUT IS SET TO TINT. 
*     LEAVE WITH X6,A6=1ST WD OF MACOUT ENTRY, FWA ---. (THIS INFO USED 
*     BY CON2C1.) 
 STCON    DATA   0
          SA3    SETMAC            GUESS SET MAC
          SA2    BSAV 
          NZ       X5,ACT2         NOT A ZERO CONST 
          SA3      ZRMD            PLUS ZERO
          PL     X5,ACT3
          SA3    MZMD 
          EQ     ACT3 
 PRENORM  BX5    -X5
          RJ     SPCON
          BX5    -X5               (IN CASE CON IS NOT 2**N-1)
          SA3    SETMAC 
          NZ     B3,ACT5
          ZR     ACT4 
 ACT2     SX2    X2-773B
          ZR     X2,PRENORM        IF INHIBIT FORMATION OF -CON 
          RJ     SPCON
          NZ     B3,ACT5     IF -CON CANT BE FORMED BY A MASK 
 ACT4     SA3    MD.MASKC          MACOUT DESCRIPTOR WORD 
          SX5    X6                PLACE MASK COUNT 
 ACT5     MX0    -18
          BX6    -X0*X5 
          SA6      PARAMS+1        AND STORE IT 
 ACT3     SX5    T.INT
          SA2    NARN 
          BX7    X2 
          SA7       PARAMS
          SX7    X2+1              INCR NARN
          SA7    NARN 
          RJ       MACOUT 
*     TURN ON CONST FLAG BIT
          MX0       1 
          LX0       48
          SA2    X7 
          BX6    X0+X2
          SA6    A2 
          ZR        STCON     END OF STCON
 APLRT    SPACE  3,14 
**        APLRT - OUTPUT APLIST R-MACRO 
*         ENTRY  (X1) = ST APL FLAG  ( 1S59 OR 0 )
*                (X2) = IH
*                (X3) = CA
*                (X4) = IDORD OF SYM OR 0 
  
 APLRT    ENTRY. ** 
          SA5    =XOPT2 
          MX0    -RM.CAL
          BX3    -X0*X3 
          LX2    AP.IHP 
          LX3    AP.CAP 
          BX6    X1+X2
          SB4    X4 
          IX7    X3+X6
          ZR     X5,APLRT2   IF NOT OPT=2 
          ZR     X4,APLRT2   IF NO ORD
          SA5    SYM1 
          SB4    B4+B4
          SA0    X5 
          SA1    A0-B4       WORD A 
          MX0    1
          LX1    59-P.DIM 
          PL     X1,APLRT1   IF ^DIM
          LX0    1+AP.CRP    SET CLASS REFERENCE BIT
          BX7    X0+X7
          EQ     APLRT2 
  
 APLRT1   SA2    A1-1        WORDB
          SX4    30B
          MX5    -L.TYP 
          LX2    -P.TYP 
          BX3    -X5*X2 
          SB4    X3 
          AX4    B4,X4
          LX4    59 
          PL     X4,APLRT2   IF NOT DOUBLE OR COMPLEX 
          LX0    1+AP.P1P    SET DOUBLE INDICATOR 
          BX7    X0+X7
  
 APLRT2   SA2    NARN 
          SA3    APLMD
          SX2    X2-1 
          SA7    PARAMS 
          MX5    0
          RJ     MACOUT      OUTPUT MACRO 
          SA5    PARAMS 
          BX6    X5 
          SA6    X7+3        STORE INFO IN ARLIST BUFFER
          RJ     CHKOFF 
          EQ     APLRT
 STALR    SPACE  3,14 
**        STALR - OUTPUT STORE TO APLIST
*         ENTRY  (X1) = ADDR OF LOAD R-MACRO
  
 STALR    ENTRY. *
          SA5    X1+2 
          SA2    X1+3        IH 
          MX3    0           CA = 0 
          SA4    X1+1        IDORD
          LX5    -R1.INP
          SX6    X5-3 
          NZ     X6,STALR1   IF AN IXFN MACRO 
          SA3    X1+5 
 STALR1   MX1    1
          LX1    1+AP.STP 
          RJ     APLRT       OUTPUT APLIST WORD FOR -0
          SA3    NARN 
          SX6    X3-1 
          SA4    ACNT 
          SA6    PARAMS+1          RI OF REG WITH ADDRESS 
          SX7    X4-1        ORD OF ARG IN LIST 
          SA7    PARAMS+2 
          MX6    0
          SA6    PARAMS      IH OF APLIST 
          SX2    X3-1 
          SA3    TSMAC
  
          RJ     MACOUT 
          SA1    STAPLC 
          BX6    X1 
          SX7    X7+1 
          SA6    X7                [LASTR + 1] = APLS 
          SA7    A1                APLS = LASTR + 1 
          RJ     CHKOFF 
          EQ     STALR
 OTS      SPACE  3
**        OTS - OUTPUT TEMPORARY STORES 
*         ENTRY  (X1) = ADDRESS OF ARLIST MACRO TO BE STORED
*                (X2) = NON-ZERO IF RL2, RL1 NEED TO BE POSITIONED
*         EXIT   (X2) = ORD(ST.)
*                (X3) = CA OF TEMP STORE
*                (X4) = N.STORES - 1 ( 0 OR 1 ) 
  
 OTS0     SA2    ST.
          SA3    STSORD 
          IX3    X3-X4
          SX4    X4-1 
 OTS      ENTRY. *           ** ENTRY/EXIT ** 
          ZR     X2,OTS1A    IF NO NEED TO POSITION RL2, RL1
          BX7    X1 
          SA7    OTSB        TEMP FOR RL2 
          RJ     CHKOFF      REPOSITION RL2, RL1
          SA1    OTSB 
 OTS1A    SA3    X1          ARLIST HDR WORD
          SX0    06B         BIT MASK FOR DBL/CMPLX TYPES 
          UX7    B2,X3
          LX0    54 
          SA2    X1+2        MACRO HEADER WORD
          LX7    B2,X0
          MX0    -R1.RIL
          BX2    -X0*X2 
          PL     X7,OTS1     IF A SINGLE WORD RESULT
  
          SX7    X2+1 
          SA7    OTSA 
          RJ     AVTS        OUTPUT TEMP STORE
          SA2    OTSA 
          RJ     AVTS 
          SX4    2
          EQ     OTS0 
 OTS1     LX3    59-44
          PL     X3,OTS2     IF XMT BIT NOT SET 
          BX6    X2 
          SA2    NARN 
          BX7    X2 
          SA7    PARAMS 
          SA6    PARAMS+1 
          SX6    X2+1 
          SA6    A2 
          MX5    0
          SA3    XMIT 
          RJ     MACOUT 
          RJ     CHKOFF 
          SA3    NARN 
          SX2    X3-1 
 OTS2     RJ     AVTS 
          SX4    1
          EQ     OTS0 
  
 OTSA     BSS    1
 OTSB     BSS    1           TEMPORARY ADDRESS OF RL2 
 AVTS     SPACE  3
*     AVTS TO OUTPUT INSTR TO DO TEMP STO OF RESULT NAMED IN X2.
*         OUTPUT TO ARLIST
  
 AVTS     ENTRY. *                 ** ENTRY/EXIT ** 
          SA1    STSORD            H1 
          SA3    ST.               SYMTAB ORDINAL 
          SX6    X1+1              INCREMENT H1 
          SA6    A1 
          BX7    X3 
          BX6    X1 
          SA6    PARAMS+2          CA OF ST.
          BX6    X2 
          SA6    PARAMS+1          RI 
          SA7    PARAMS            IH OF ST.
          SA3    TSMAC
          RJ     MACOUT 
          RJ     CHKOFF 
          EQ     AVTS 
 GEFCM    SPACE  3
**        GEFCM - OUTPUT GENERAL EXTERNAL FUNCTION CALL 
*          ENTRY (X1) = N.AP OR 0 
*                (X2) = IH OF FUNCTION
*                (X3) = LINE COUNT
*                (X4) = STAPL CHAIN POINTER 
*                (X5) = CA (IF N.ARG .EQ. 0 AND ZFLAG .NE. 0) 
  
 GEFCM1   SA6    PARAMS+1          LINE COUNT 
          SA3    RJ60MD            RJ CALL WITHOUT APLIST 
 GEFCM2   MX5    0
          RJ     MACOUT 
          RJ     CHKOFF 
  
 GEFCM    ENTRY. **                ENTRY/EXIT 
          BX7    X2 
          BX6    X3 
          SA7    PARAMS            STORE IH OF FUNCTION 
          ZR     X1,GEFCM1         NO APLIST REQUIRED 
          SX7    I.AP+X1
          SA6    A7+2              STORE LINE COUNT 
          SA7    A7+1              STORE AP NUMBER
          MX6    0
          PL     X1,GEFCM3A  IF N.ARG.NE.0 .OR. ZFLAG.EQ.0
          BX6    X5 
 GEFCM3A  SA6    A6+1 
          ZR     X4,GEFCM4         IF STAPLC = 0
 GEFCM3   SA7    X4+2 
          SA4    X4 
          NZ     X4,GEFCM3
  
 GEFCM4   SA3    GEFMD
          EQ     GEFCM2 
          EJECT 
*     FRTS: FUNCTION RESULT TEMP-STO-INSTR OUTPUT 
*     COME WITH X1=RNAME OF RESULT TO BE SAVED. 
*     AND B58=1 IF DBL LENGTH 
  
 FRTS     ENTRY. *                 ** ENTRY/EXIT ** 
          MX0    18 
          LX0    18+34
          BX1    -X0*X1            MASK OUT EQUAL SIGN COUNT
          SB2    -M.SFR            SAVED FUNCTION RESULT MACRO
          SB7    4           (B7) = *RLIST* WORD COUNT
          SA2    STSORD            CA OF ST.
          BX7    X2 
          SX6    X1 
          SA7    LBTS+3            SAVE CA
          SA6    LBTS+2            SAVE RNAME 
          SA4    ST.               IH OF ST.
          SX3    3
          LX3    30 
          BX3    X3+X1             FORM PART OF MACRO WORD
          BX6    X4 
          PX7    B2,X3             FORM MACRO WORD
          SA6    LBTS+1            SAVE IH
          SA7    LBTS              SAVE MACRO WORD
          SX6    X2+1              INCREMENT STSORD 
          LX1    59-58
          PL     X1,FRTS1          IF NOT DBL 
          SA6    LBTS+7            SAVE CA+1
          SX6    X6+1              INCREMENT STSORD 
          SX2    1
          SA3    LBTS 
          IX7    X3+X2             ADD 1 TO MACRO NAME
          SA7    LBTS+4            SAVE 2ND MACRO WORD
          SA3    LBTS+1 
          SA4    LBTS+2 
          BX7    X3 
          IX5    X4+X2
          SA7    LBTS+5            SAVE IH
          BX7    X5 
          SA7    LBTS+6            SAVE RNAME+1 
          SB7    8           (B7) = *RLIST* WORD COUNT
 FRTS1    BSS       0 
          SA6       STSORD
          SB1    1
          WRITEW =XF.RLST,LBTS,B7 
          SB5    1
          EQ     FRTS              EXIT 
          EJECT 
*     DARLIST: DUMP ARLIST: SENDS CLEAN R-LIST TO RLIST FROM ARLIST.
*  ENTER WITH X4= POINT(+ARLIST) TO 1ST WD OF AREA IN ARLIST AND
*             X5= POINT(+ARLIST) TO LAST WD+1 IN ARLIST TO SEND TO RLST 
* 
*     ONE OF THE 1ST IMPROVEMENTS (ONE OF MANY THAT SHOULD BE MADE) OF
*  ARITH SHOULD BE IN RE-WRITING DARLIST SO THAT WRLST NEED NOT BE
*  CALLED FOR EACH R-LIST MACRO OR INSTRUCTION. 
  
 DARLIST  ENTRY. **          ** ENTRY/EXIT ** 
          SB2    X4+ARLIST    FWA 
          SUB 
          SB3    X5+ARLIST    LWA+1 
          SUB 
          EQ     B2,B3,DARLIST     EXIT IF NOTHING TO DUMP OUT
 DRLST2   SA1    B2           GET NXT WD
          SA2    B2+2 
          BX7    X1+X2
          SB4    18 
          MI     X7,DRLST1         IF NOOPED OR GARBAGE 
          AX6    B4,X1        GET SIZE OF ENTRY 
          SA6       LBTS      SAVE
          SB7    X6-2              (B7) = MACRO LENGTH = SIZE - 2 
          SX6    B2 
          SX7    B3 
          SA6       LBTS+1
          SA7       LBTS+2
          SB1    1
          WRITEW =XF.RLST,B2+2,B7 
          SA2    LBTS+1 
          SB5    1
          SA3    A2+B5
          SA1    A2-B5
          SB2    X2 
          SB3    X3 
 DRLST3   SB2    X1+B2        SET NEW FWA 
          NE  B2,B3,DRLST2    IF MORE TO OUTPUT 
          EQ     DARLIST
  
 DRLST1   BX6    -X1
          AX1    B4,X6
          PL     X6,DRLST3         IF NOOPED
          BX1    -X1
          EQ     DRLST3 
 DALV     EJECT 
**        DALV - OUTPUT F.P. LOAD 
*         ENTRY  (X1) = SYMTAB ORD
  
 DALV     ENTRY. *           ** ENTRY/EXIT ** 
          SA2    SYM1 
          BX5    X1 
          LX1    1
          SB2    X1+1 
          SB3    -B2
          SA2    X2+B3       WORD B OF SYMTAB ENTRY 
          BX6    X2 
          SB6    B0          RF = 0 
          SB7    B0          CA = 0 
          SA6    NAME+1 
          RJ     FETCH
          EQ     DALV 
 CFETCH   SPACE  3
**        CFETCH - OUTPUT LOAD OF A CONSTANT
*         ENTRY  (X1) = 30/CA,30/SYMTAB ORD 
*                (X6) = TYPE
  
 CFETCH   ENTRY. *           ** ENTRY/EXIT ** 
          SB6    B0           RF NAME 
          SX5    X1           IH
          AX1       30
          SB7    X1           CA
          BX7    X1 
          LX6    P.TYP
          SA7    NCA               SAVE FOR POSSIBLE USE BY LISTIO
          SA6       NAME+1
          BX7    X5 
          SA7    IDORDLTS 
          SX6    B7 
          SA6    A7+1 
          RJ        FETCH 
          SA1       RL2 
          SA3    X1 
          MX0       1 
          LX0       48
          BX7    X0+X3        SET CONST BIT IN FETCH OP 
          SA7    A3 
          EQ     CFETCH 
          TITLE  CHKP2
*** 
*         CHKP2 - CHECK ARLIST MACRO TO SEE IF IT IS A CONSTANT 
*                THAT IS A POWER OF 2 
* 
*         ON ENTRY: 
*                X1 = ADDRESS OF ARLIST ENTRY 
* 
*         ON EXIT:  
*                X7 = 0 IF A POWER OF 2 
*                X6 = SHIFT COUNT  ( CON = 2**X6 )
* 
  
 CHKP2X   SA2    A1                RESTORE ARLIST ENTRY 
          BX6    -X2
          SA6    A2 
  
 CHKP2    ENTRY. *                 ** ENTRY/EXIT ** 
          SA1    X1 
          MX7    1
          BX2    X1 
          LX2    59-47
          PL     X2,CHKP2          IF NOT A CONSTANT
          RJ     NEWCON            GET VALUE
          BX7    X6 
          CX5    X6 
          AX7    48 
          PX6    X6 
          NZ     X7,CHKP2X   IF CONST TOO LARGE 
          SX7    X5-1 
          NZ     X7,CHKP2X         IF NOT A POWER OF 2
          SB6    47 
          NX5    B7,X6
          SX6    B6-B7             SC = LOG2(CON) 
          EQ     CHKP2
          TITLE  NEWCON 
 CHKOP    MACRO  CODE,LABEL 
          SX4    B2+CODE
          ZR     X4,LABEL 
          ENDM
  
*** 
*         NEWCON - RETURN VALUE OF CONSTANT 
* 
*         ON ENTRY: 
*                A1,X1 - ADDR AND ARLIST WORD TO SET UP CONSTANT
* 
*         ON EXIT:  
*                (CONST) = X6 = VALUE OF CONSTANT 
*                CONSTANT LOAD OR SET MACRO NOOPED IN ARLIST BUFFER 
*                B3 AND A1 SAME AS ON ENTRY 
*                X1 IS ARLIST HDR WORD
* 
  
*         GET VALUE OF CONSTANT FROM CON TABLE
  
 NEWCON1  SA4    A1+5              CON TAB ORDINAL
          IX7    X2+X4
          SA3    X7                FETCH CONSTANT 
          BX6    X3 
 NEWCONX  SA6    CONST
  
 NEWCON   ENTRY. *                 ** ENTRY/EXIT ** 
          SA2    A1+2              RLIST MACRO HEADER WORD
          SA3    A1+4              POSSIBLE CONSTANT
          MX6    1
          LX6    1+45              POSITION USED BIT
          BX1    X1+X6             INSERT BIT IN HEADER 
          BX7    -X1
          UX2    B2,X2
          SA7    A1                NO OP RLIST CONSTANT LOAD OR SET 
          SX6    X3                SIGN EXTEND
  
          CHKOP  SETMC,NEWCONX     IF A SXI CON 
          MX6    0
          CHKOP  MZMC,NEWCONX      IF A MXI 0 
          CHKOP  MZZMC,NEWCONX     IF A DOUBLE MASK 0 
          MX6    60 
          CHKOP  MIZMC,NEWCONX     IF A MXI 60
          SX4    B2+M.MASKC 
          SA2    O.CON
          NZ     X4,NEWCON1        IF NOT A CONSTANT MASK MACRO 
  
          SB2    X3-1              FORM MASK AS THE CONSTANT
          MX4    1
          AX6    B2,X4
          EQ     NEWCONX
          TITLE  SNGLR
*** 
*     SNGLR: SINGLE ROUTINE.  IF ARLIST INSTR ADDRESSED BY X1 IS A
*  DLMACO, CHANGE OP CODE TO DLTSMC (DBL LD TO SNGL) AND SET TYPE TO OCT
  
 SNGLR    ENTRY. *           ** ENTRY/EXIT ** 
          SA2    X1 
          UX3    B3,X2
          SB4    T.DBL
          SB6    T.CPLX 
          EQ  B3,B4,SNGLR1    IF OPD TDBL 
          NE  B3,B6,SNGLR     IF OPD NOT CPX OR DBL 
 SNGLR1   SA2    X1           CHANGE OPD TYPE TO OCT
          SB4    T.OCT
          PX6    B4,X2
          SA6    X1 
          SA2    X1+2 
          SB2      -DLMACO
          UX0 B3,X2 
          NE  B2,B3,SNGLR     IF INSTR NOT DLMACO 
          SB2      -DLTSMC    DBL LOAD TO SNGL LOAD INSTR 
          PX6    B2,X2
          SA6    A2 
          ZR        SNGLR 
          TITLE  INFTLU AND BEFTLU - FUNCTION TABLE LOOKUP ROUTINES 
**        IFTLU AND BEFTLU - INTRINSIC AND BASIC EXTERNAL FUNCTION
*                            TABLE LOOKUP SUBROUTINES.
* 
*         ENTRY  (B7) = *NOT FOUND* RETURN ADDRESS. 
*                (OP) = FUNCTION NAME, E-LIST FORMAT. 
* 
*         EXIT   IF LOOKUP SUCCESSFUL --
*                (X4,X5) = TABLE ENTRY WORDS 1 AND 2.  MAY BE ENTERED 
*                          IN SYMBOL TABLE WORDS A AND B. 
*                (X3) = WORD 4 OF INTRINSIC FUNCTION TABLE ENTRY. 
  
 IFTLU    ENTRY. **                ** ENTRY/EXIT ** 
          SA5    IFTLU.P
          RJ     FTLU              LOOK FOR FUNCTION NAME 
          SA3    A4+3              4TH WORD 
          EQ     IFTLU
  
 BEFTLU   ENTRY. **                ** ENTRY/EXIT ** 
          SA5    BEFTLU.P 
          RJ     FTLU              GO LOOK FOR NAME 
          ZR     X1,BEFTLU         IF NOT T MODE
          SA1    BEFTLUA
          BX5    -X1*X5      CLEAR BEF AND *BRP* FIELDS 
          EQ     BEFTLU 
  
 BEFTLUA  BSS    0
          POS    P.BEF+1
          VFD    1/1
          POS    P.RA+L.RA
          VFD    L.RA/-0,*P/0 
  
          ENTRY  IFTLU.P
 IFTLU.P  VFD    12/4,18/INTFTB,30/L.INFT 
          VFD    12/4,18/INTFTB,30/L.INFTE
 BEFTLU.P VFD    12/3,18/BEFTB,30/L.BEFTB 
 FTLUX    SA4    A4-B4             WORD 1 
          SA1    CBNFLG            X1 = CBNFLG
          SA5    A4+B5             X5 = WORD 2 OF TABLE ENTRY 
 FTLU     ENTRY. *                 ** ENTRY/EXIT ** 
          SB3    X5                LWA+1 OF TABLE 
          AX5    30 
          SA4    X5                FETCH FIRST NAME 
          AX5    18 
          SB4    X5                INCREMENT
          SA2    OP                FUNCTION NAME
          UX7    X2 
          SB6    60-L.NAME
          LX7    12                POSITION NAME
          SA7    B3                STORE SEARCH TERMINATOR
          SB5    1
 FTLU1    BX5    X4-X7
          AX6    B6,X5             REMOVE GARBAGE IN LOWER BITS 
          SA4    A4+B4             NEXT 
          NZ     X6,FTLU1          IF NO MATCH
          SB2    A4-B4
          SA6    B3                CLEAR TABLE TERMINATOR 
          LT     B2,B3,FTLUX       IF A MATCH IN THE TABLE
          JP     B7                GO TO NOT FOUND EXIT 
          TITLE 
 EQUIVR   SPACE  4,8
*** 
*         EQUIVR - RETURN BASE AND BIAS OF EQUIVALENCED VARIABLE
* 
*         ON ENTRY: 
*                NAME,NAME+1 = WORD A AND B OF SYMTAB ENTRY 
*                B7 = RETURN EXIT IF VAR IS NOT EQUIVALENCED
* 
*         EXIT:  EQUIVALENCED CASE
*                X6 = BIAS
*                X7 = SYMTAB ORDINAL OF BASE
* 
  
 EQUIVR1  SA4    NAME+1            WORD B 
          SA5    DIM1 
          AX4    P.DIMP 
          BX6    -X0*X4            DIMP ORD 
          LX6    1
          SB2    X5 
          SA2    X6+B2             WORD 1 OF DIM ENTRY
          AX2    18 
          SX6    X2                X6 = BIAS
          AX2    18 
          SX7    X2                X7 = SYMORD OF BASE
  
 EQUIVR   ENTRY. *                 ** ENTRY/EXIT ** 
          SA1    NAME              WORD A 
          LX1    59-P.EQU 
          MX0    60-L.DIMP
          NG     X1,EQUIVR1        IF EQUIVALENCED
          JP     B7 
          EJECT 
*     MODCH: USED TO GENERATE RLIST TO CONVERT FROM ONE DATA MODE TO
*           ANOTHER.  CONVERTS FROM HIGH TO LOW (E.G. INT=REAL), OR LOW 
*           TO HIGH.  ENTER WITH X5=ADR OF ARLIST ENTRY TO BE CONVERTED,
*                                B5=TYPE TO CONVERT TO. 
*         IF DONT CONVERT, EXIT WITH X6=X5.  IF CONVERT, EXIT WITH X6=
*     ADDRESS OF CONVERT MACRO, (X5) USED BIT TURNED ON, RL1,RL2 SAME AS
*     ON ENTRY. 
* (LATER IMPROVEMENT: CONVERT CONSTANTS AT COMPILE TIME.) 
  
 MODCH    ENTRY. *           ** ENTRY/EXIT ** 
          BX6    X5           SAVE
          SA6       MCOPDA     MODE-CHANGE-OPERAND ADDRESS
          SX7    B5           SAVE
          SA7       MCTYP      MODE CHANGE TYPE 
          SA1    X5           GET TYPE OF (X5)
          UX0 B2,X1 
          SB3    T.LOG
          EQ  B5,B3,MCH1      IF TLOG 
          EQ  B2,B3,MCH2      IF TLOG 
          LX1    59-47
          SX6    X5 
          PL     X1,NOTCON         BRANCH IF OPERAND IS NOT A CONSTANT
          SA1    X5+2              DO NOT CONVERT A ZERO CONSTANT IF
          UX0    X1,B3             A SINGLE WORD ITEM 
          SX2    B3+MZMC
          ZR     X2,MDISCON 
          SB3    B3+MIZMC 
          NZ     B3,NOTCON
 MDISCON  SB3    T.REAL 
          LE     B5,B3,MODCH
          JP     B5+MDCHTB+5 CONVERT 0 CONST TO DBL WORD
 NOTCON   BSS    0
          SB2    B2-1         (X5) TYPE   COMPUTE POINT TO MDCHTB 
          SB5    B5-1 
          SB2    B2+B2        MULTIPLY B2 BY 6
          SB4    B2+B2        4*B2
          SB2    B2+B4        6*B2
          SB4    B2+B5
          JP        B4+MDCHTB 
*                             (X5) TYPE TO B5 TYPE
 MDCHTB   SX6    X5           INT         INT 
          EQ        MODCH 
          SB7       MCHMCB    INT         REAL
          EQ        MCH3
          SB7       MCHMCB+1  INT         DBL 
          EQ        MCH4
          SB7       MCHMCB+1  INT         CMPX
          EQ        MCH4
          SX6    X5           INT         OCT 
          EQ        MODCH 
          SX6    X5           INT         HOL 
          EQ        MODCH 
          SB7       MCHMCB+2  REAL        INT 
          EQ        MCH3
          SX6    X5           REAL        REAL
          EQ        MODCH 
          SB7       MCHMCB+3  REAL        DBL 
          EQ        MCH4
          SB7       MCHMCB+3  REAL        CMPX
          EQ        MCH4
          SX6    X5           REAL        OCT 
          EQ        MODCH 
          SX6    X5           REAL        HOL 
          EQ        MODCH 
          SB7       MCHMCB+2  DBL         INT 
          EQ        MCH3
          SB7       MCHMCB+4  DBL         REAL
          EQ        MCH3
          SX6    X5           DBL         DBL 
          EQ        MODCH 
          SB7       MCHMCB+3  DBL         CMPX
          EQ     MCH4 
          SB7       MCHMCB+4  DBL         OCT 
          EQ        MCH3
          SB7       MCHMCB+4  DBL         HOL 
          EQ        MCH3
          SB7       MCHMCB+2  CMPX        INT 
          EQ        MCH3
          SB7       MCHMCB+4  CMPX        REAL
          EQ        MCH3
          SB7       MCHMCB+3  CMPX        DBL 
          EQ     MCH4 
          SX6    X5           CMPX        CMPX
          EQ        MODCH 
          SB7       MCHMCB+4  CMPX        OCT 
          EQ        MCH3
          SB7       MCHMCB+4  CMPX        HOL 
          EQ        MCH3
          SX6    X5           OCT         INT 
          EQ        MODCH 
          SX6    X5           OCT         REAL
          EQ        MODCH 
          SB7       MCHMCB+3  OCT         DBL 
          EQ        MCH4
          SB7       MCHMCB+3  OCT         CMPX
          EQ        MCH4
          SX6    X5           OCT         OCT 
          EQ        MODCH 
          SX6    X5           OCT         HOL 
          EQ        MODCH 
          SX6    X5           HOL         INT 
          EQ        MODCH 
          SX6    X5           HOL         REAL
          EQ        MODCH 
          SB7       MCHMCB+3  HOL         DBL 
          EQ        MCH4
          SB7       MCHMCB+3  HOL         CMPX
          EQ        MCH4
          SX6    X5           HOL         OCT 
          EQ        MODCH 
          SX6    X5           HOL         HOL 
          EQ        MODCH 
  
*     MCH1 IF B5 IS TLOG
 MCH1     SX6    X5 
          SA1    ASFMF
          NZ     X1,MCH6     IF HERE FROM SFLPR - STATEMENT FUNCTION
*                            PROCESSING 
          NE  B2,B3,MCH2      IF LOG MIXED WITH NON-LOG 
          EQ        MODCH     RETURN
 MCH2     MX7    0
          SA7    ASFMF       RESET STATEMENT FUNCTION FLAG
          EERR   ERMSG31     FE - LOG MIXED WITH NON-LOG
  
 MCH3     SA2    NARN         HERE FOR TWO PARAMETER MACROS 
 MCH5     SA1       MCOPDA    GET RI OF OPD:  
          SA3    X1+2         LOAD 1ST WD OF RLIST MACRO
          MX0       60-16 
          BX7   -X0*X3
          AX6    B0,X2
          SA7       PARAMS    STORE RI OF OPD 
          SA6       PARAMS+1  NARN TO PARAMS+1
          SA1    A3-2         TURN ON USED-BIT IN (X5)
          MX0       1 
          LX0       46
          BX7    X0+X1
          SA7    A1 
          SA4       NARN      UPDATE NARN 
          SX7    X4+1 
          SA7       NARN
          SA1       SLBMD     FOR MACRO DESCRIPTOR WORD 
          PX3    B7,X1        (ONLY 2 OF THE THREE R,S PACKED FOR SLBMD 
          SA5       MCTYP       WILL BE USED BY MCH3 TYPE MACROS. MCH4
          SA1       RL1         HAS ALREADY PLACED A 3RD) 
          SA4       RL2       SAVE RL1,2
          BX6    X1 
          AX7    B0,X4
          SA6       MCHTS 
          SA7       MCHTS+1 
          RJ        MACOUT    OUTPUT MODE CHANGE MACRO
          SA1    X7+2         SEE IF RNM TYPE MAC 
          SB2      -MCHMCB-3
          UX0 B3,X1 
          EQ  B2,B3,MCH5A     IF SO 
          SB2      -MCHMCB-4
          NE  B2,B3,MCH5B     IF NOT
 MCH5A    MX0       1         TURN ON XMT BIT IN FIRST WD OF ARLIST ENTY
          SA1    X7 
          LX0       45
          BX6    X0+X1
          SA6    X7 
 MCH5B    SA1    MCHTS
          SA2       MCHTS+1 
          BX6    X1 
          AX7    B0,X2
          SA3       RL2 
          SA6       RL1 
          SA7       RL2 
          BX6    X3           SET X6 TO ADR OF CONVERT MACRO
          EQ     MODCH
  
 MCH4     SA2    NARN         HERE FOR THREE PARAMETER MACROS 
          SX7    X2+1 
          SA7       PARAMS+2
          SA7       NARN
          EQ        MCH5
  
 MCH6     SA6    ASFMF       SAVE CURRENT ARLIST ADDRESS
          IDM    ERMSG31     WARNING - LOG MIXED WITH NON LOG 
          SA5    ASFMF
          BX6    X5          RESTORE CURRENT ARLIST ADDRESS 
          EQ     MODCH       RETURN 
  
 ASFMF    CON    0
          EJECT 
*     FFRTS: OUTPUTS FETCH OF SAVED FUNCTION RESULT.  ENTER WITH B2=TYPE
*           OF FUNC, AND X4=FRSTB ENTRY.
  
 FFRTS    ENTRY. *           ** ENTRY/EXIT ** 
          SA1       SFRSTB
          SX6    X1-1 
          SA6       SFRSTB
          SA1       NARN      SAVE NARN 
          BX6    X1 
          SA6       FFRTSTS 
          SX7    B2           PREPARE FOR CALL TO FETCH 
          LX7    P.TYP
          SA7       NAME+1    SET UP TYPE 
          MX0       60-16 
          BX6   -X0*X4
          SA6       NARN      SET NAME OF RESULT
          SB6    B0           RF
          AX4    16                POSITION ST NUMBER 
          SB7    X4                CA 
          SA5    ST.               IH OF ST.
          SX6    B0 
          SA6    IDORDLTS 
          SA6    A6+1 
          RJ        FETCH     B6,7,X5 SET 
          SA1       FFRTSTS 
          BX6    X1 
          SA6       NARN
          ZR        FFRTS 
          EJECT 
*     OPNCON: ENTER WITH CONST IN X6, AND TYPEWD SET.  OUTPUT NEW CONST 
*            FETCH OR SET, AND RESET RL,S.
 OPNCN3   RJ        FNDOP 
          SA6       RL1 
  
 OPNCON   ENTRY. *           ** ENTRY/EXIT ** 
          MX0       60-17 
          BX1    X0*X6
          ZR     X1,OPNCN1    IF CON< 400000B 
          ZR     X6,OPNCN1
          BX1    -X6*X0 
          ZR     X1,OPNCN1    IF -CON< 400000B
 OPNCN2   BX1    X6 
          SB1       1 
          RJ        CONVERT   ENTER CONST IN CONLIST
          SA2    EPOINT 
          SB1    X2+1 
          SA2       TYPEWD
          BX6    X2 
          RJ        CFETCH    OUTPUT CONST LOAD.
          ZR        OPNCN3
* 
 OPNCN1   SA1       TYPEWD
          SB2    X1-T.REAL
          ZR     X6,OPNCN4
          ZR     B2,OPNCN2    IF REAL CONST, FORCE FETCH
 OPNCN4   BX5    X6 
          SX7    773B              INHIBIT FORMATION OF -CON
          SA7    BSAV              IF CON IS OF FORM -(2**N - 1)
          RJ     STCON
          SA1       TYPEWD
          SB2    X1 
          PX6    B2,X6
          SA6    A6 
          ZR        OPNCN3
 SDFINE   SPACE  3
**        SDFINE - SET DEFINE BIT IN SYMTAB 
*         ENTRY  (X1) = ADDRESS OF ARLIST ENTRY 
*         EXIT   (X6) = WORD A OF SYMTAB ENTRY
*                (A6) = ADDRESS OF WORD A 
*                (X4) = WORD A BEFORE DEFINE BIT WAS SET
*         PRESERVES X1,X2 
  
 SDFINE   ENTRY. *           ** ENTRY/EXIT ** 
          SA4    X1+3 
          SX6    X4-I.GL
          PL     X6,SDFINE   IF NOT IN SYMTAB 
          SA3    SYM1 
          SX4    X4 
          LX4    1
          IX6    X3-X4
          SA4    X6                WORD A 
          SX0    V.DEF
          BX6    X0+X4       SET DEF BIT FOR THIS SYMBOL
          SA6    A4 
          EQ     SDFINE 
 CVDB     TITLE 
**        CVDB - ISSUE R-MACRO TO COMPUTE VARIABLE DIM ARRAY BOUNDS.
  
 CVDB     ENTRY. **          ** ENTRY/EXIT ** 
          SA1    =XDFLAG
          SA2    =XVARDIM 
          ZR     X1,CVDB     IF DEBUG OFF, EXIT ... 
          ZR     X2,CVDB     IF NO VARDIM FORMAL PARAMS, EXIT ... 
          SA4    SYM1 
          SX5    2           SYMBOL TABLE ORDINAL OF FIRST F.P. 
          SA2    =XFP.
          SB5    1
          SA0    X4 
          BX7    X2 
          SA7    CVDBB+1
 CVD1     LX6    B5,X5
          SB2    X6 
          SA1    A0-B2       WORDA
          LX1    59-P.FP
          PL     X1,CVDB     IF NOT AN F.P. 
          LX1    P.FP-P.DIM 
          SX5    X5+B5
          PL     X1,CVD1     IF NOT DIMENSIONED 
          SA2    A1-B5       WORDB
          BX6    X5 
          MX0    -L.TYP 
          SA6    CVDA        SAVE SYMBOL TABLE ORDINAL
          LX2    -P.TYP 
          BX3    -X0*X2 
          SB6    X3-T.DBL 
          LX2    P.TYP-P.DIMP 
          MX0    -L.DIMP
          BX2    -X0*X2 
          SA1    DIM1 
          LX2    1
          SB2    X1+B5
          MX0    3
          SA5    B2+X2       DIM INFO WORD
          LX0    -3 
          BX4    X0*X5
          ZR     X4,CVD3     IF P(ABC) = 0 */ NOT VARDIM
          SX6    X6-3 
          SA6    CVDBB+3     CA OF STORE
          BX3    X5 
          AX3    57 
          SB3    B0 
          MI     B6,CVD2     IF SINGLE PRECISION
          SB3    B5 
 CVD2     MX7    0
          CALL   WWC         OUTPUT BOUNDS COMPUTATION MACRO
          SA1    NRLN 
          SX6    X1-1 
          SA6    CVDBB+2
          WRM    CVDBB       OUTPUT STORE MACRO 
 CVD3     SA5    CVDA 
          SA4    SYM1 
          SA0    X4 
          EQ     CVD1 
  
 CVDA     CON    2           ORD OF FIRST F.P.
 CVDBB    RMHDR  TSMACC,3 
          BSS    3
 STRIP    SPACE  4,8
*** 
*         ROUTINE TO STRIP OFF A TRAILING $ FROM A NAME 
*           ENTRY: NAME IN UPPER 42 BITS OF X1
*           EXIT: SAME AS ENTRY, BUT WITHOUT $ IF ONE FOUND 
* 
 STRIP    ENTRY. **                ** ENTRY/EXIT ** 
          SB1    18                INITIAL SHIFT COUNT
          SB2    6                 SHIFT INCREMENT
          SX2    1R                BLANK CHARACTER
          BX6    X1                SAVE ORIGINAL COPY 
          MX0    60-6              CHARACTER MASK 
          AX1    18                POSITION LAST CHARACTER FIELD OF NAME
 STRIP0   BX3    -X0*X1            GET CHARACTER
          IX7    X3-X2       IS CHARACTER A BLANK 
          ZR     X7,STRIP1   YES
          SX5    X3-1R$            IS CHARACTER A $ 
          ZR     X5,STRIP2         YES
          BX1    X6                SET UP EXIT CONDITION
          EQ     STRIP             EXIT 
 STRIP1   SB1    B1+B2             INCREMENT SHIFT COUNT
          LX1    60-6              POSITION NEXT CHARACTER
          EQ     STRIP0 
 STRIP2   LX7    B1 
          IX6    X6-X7             CONVERT THE $ TO A BLANK 
          BX1    X6                SET UP EXIT CONDITION
          EQ     STRIP             EXIT 
  
  
*         ENTRY POINT FOR FORTRAN CALLS 
 FSTRIP   ENTRY. **                ** ENTRY/EXIT ** 
          SA1    X1                GET FUNCTION PARAMETER 
          PLUG   AT=STRIP,FROM=FSTRIP,FREG=2
          EQ     STRIP+1           BEGIN EXECUTION
          TITLE              IXFN -GENERATE LOADS FOR I/O PROCESSOR 
*** 
*         IXFN - SET UP ADDRESS OF SYMBOL SBI  LOCF(EXPR) FOR 
*         I/O LIST PROCESSOR
* 
*         ON ENTRY: 
*                SELIST POINTS TO FIRST ITEM IN LIST
*                X3 = EXPRESSION FLAG 
*                X6 = REFMAP REFERENCE TYPE FLAG
* 
*         ON EXIT:  
*                SELIST POINTS PAST EXPRESSION ( TO A , OR EOS )
*                X2 = SYMTAB ORDINAL OF NAME
* 
  
 REFTYPE  BSS    1                 REFERENCE TYPE FOR FIRST REFERENCE 
 EXPFLAG  BSS    1           ZERO IF EXPRESSIONS ALLOWED, NON-ZERO OTHER
 IXFN.SN  BSSZ   1                 SAVED VALUE OF NAME
*         ALLOCATE LOCAL *BIO* FLAG WITH FOLLOWING MEANINGS.. 
*         ABIO .NZ. MEANS NO RESTART CALLS FOR THAT ITEM. 
*         ABIO .MI. MEANS UNQUALIFIED ARRAY NAME SYNTACTICALLY ACCEP- 
*         TABLE.
*         ABIO .MI. AND SET(ABIO) .NZ. FURTHER MEANS THAT THIS IS A 
*         BUFFER I/O LWA ITEM, AND ADDRESS MUST BE INCREMENTED IF DOUBLE
*         WORD. 
  
 ABIO     BSS    1
  
          EXT    IXFNCL 
          EXT    APLRST,HOLCON,IARC,IOEXP,PARCNT,TYPEFG 
          EXT    LDFLAG 
  
 IXFN     ENTRY. **                ** ENTRY/EXIT ** 
          BX7    X3 
          SA7    EXPFLAG     EXPRESSION FLAG
          SA6    REFTYPE           SAVE REFERENCE MAP REFERENCE TYPE
          SA5    =XRSELECT         FOR AN 'IXFN' CALL SET THE LOCAL 
          NZ     X6,IXFN1           COPY OF THE REFERENCE-SELECTION-FLAG
          PL     X6,IXFN1          EQUAL TO THE EXTERNAL VALUE UNLESS 
          BX5    X5-X5             THIS IS A SPECIAL CALL (I.E. 'IXFN'
                                   FLAG IS -0), IN WHICH CASE SET THE 
                                   FLAG SO THAT NO REFERENCES WILL BE 
                                   COLLECTED. 
 IXFN1    BX6    X5 
          MX7    1
          SA6    REFSELCT 
          SA7    EQCOUNT           SET IXFN FLAG FOR ID/REFMAP PROC 
          RJ     INITR             INITIALIZE ARITH 
          SA2    IXFNCL 
          MX7    0
          SA7    A2 
          ZR     X2,IXFN1A   IF NOT I/O UNIT OR VAR FORMAT
          BX6    -X6
  
 IXFN1A   SA6    IXFNFG      NON-ZERO VALUES ARE USED IF FROM IXFN
          SA2    =XBIO
          BX6    X2 
          SA6    ABIO 
          MX6    0
          SA3    EXPFLAG
          SA5    SELIST 
          SA6    A2 
          SA4    X5 
          UX5    B4,X4
          BX7    X4 
          ZR     X3,IXFN1B   IF EXPRESSIONS ALLOWED 
          NE     B4,B5,IXFN5 IF NOT A NAME, ERROR 
 IXFN1B   SA7    IXFN.SN     SAVE NAME FOR POSSIBLE ERROR 
          RJ     SSERR3      CHECK SYNTAX OF ITEM, B4_ITEM
          SA5    SELIST 
          SB3    EL.COMMA 
          PX6    B3,X3
          SA6    X5+B5       FOR CORRECT UNARY MINUS PROCESSING 
          SX7    2000B+XFLP 
          LX7    48 
          SX6    B5 
          SA7    OPSTAK+1          SET A IXFN ( IN THE OPSTACK
          SA6    OSPTR       OSPTR = 1
          SA3    =XCPLXC
          MX7    0
          SA7    A3 
          ZR     X3,NEXTE    IF NOT PROCESSED CPLX CONST
          SX7    T.CPLX 
          BX6    X3 
          SA7    TYPEWD 
          SA6    A5          POINT PAST ) 
          EQ     CON2A
  
*         IXFN ( POPPED FROM THE STACK
  
 IXFN2    OUTUSE DATA.       IN CASE HOL. CON WAS OUTPUT
          SA2    HOLCON 
          SX6    0
          SA6    IXFNCL 
          SB5    1
          ZR     X2,IXFN2A         IF NOT STAND ALONE HOLLERITH CONSTANT
          SA5    REFTYPE
          SA4    IXFN.SN           IN CASE OF AN ERROR
          NG     X5,IXFN5          IF CONSTANT IN A READ STMT 
          EQ     IXFN9
  
 IXFN2A   SA1    RL2
          SA2    X1                LAST RLIST OP
          UX0    B2,X2
          BX6    X1 
          SA6    RL2TS             SAVE ADDRESS OF LAST MACRO 
          SX7    B2 
          SA7    TYPEFG            SAVE LAST MACRO TYPE 
          SB3    T.DBL
          LT     B2,B3,IXFN3       IF SINGLE PRECISION
          SB4    T.CPLX 
          GT     B2,B4,IXFN3       IF NOT DOUBLE OR COMPLEX 
          SA3    NRLN 
          SX6    X3-1              DOUBLE PRECISION, BACK OFF NRLN
          SA6    A3 
          MX0    1
          BX7    X0+X7             SET TOP BIT IF DOUBLE WORD 
          SA7    A7 
 IXFN3    SA2    X1+2              GET FIRST RLIST WORD 
          UX0    B2,X2
          MX6    0
  
*         SEE IF THE LAST MACRO IS A LOAD, AND IF SO REPLACE IT WITH
*         THE CORRESPONDING SET MACRO 
  
          SA3    IXFN.TAB-1 
          SB5    1
 IXFN4    SA3    A3+B5             TABLE ENTRY
          SX4    X3+B2
          ZR     X4,IXFN6          IF A MATCH 
          NZ     X3,IXFN4          IF NOT END OF THE TABLE
          SA5    EXPFLAG
          ZR     X5,IXFN5A   IF EXPRESSIONS ARE ALLOWED 
          SA4    IXFN.SN
 IXFN5    SB6    ERMSG24           ILLEGAL I/O ADDRESS
          SB7    DOGOOF 
          EQ     ERPRO
 IXFN5A   MX2    10 
          RJ     OTS         OUTPUT TEMP STORES 
          LX2    AP.IHP 
          LX3    AP.CAP 
          BX2    X2+X3
          LX4    AP.P1P 
          IX7    X2+X4       IOEXP = AP(P1,CA,IH) 
          SA7    IOEXP             SET NONZERO
          EQ     OUT               OUTPUT EXPRESSION
  
 IXFN6    SA4    SAVDAN 
          ZR     X4,IXFN6D         IF NOT EXPLICIT CODE FLUSHING
          MX7    0
          SA7    A4                CLEAR FLAG 
          SA7    APLRST            ENSURE A ZERO FLAG 
          PL     X4,IXFN6C
          SX6    B5+B5
 IXFN6D   SA4    X1                MACRO HEADER 
          LX4    59-36             SHIFT NON STANDARD LOAD BIT
          SA5    ABIO 
          MX7    0
          PL     X4,IXFN6D1  IF NOT NON-STANDARD LOAD 
          SX6    B0-B5
 IXFN6D1  PL     X5,IXFN6D2  IF NOT BUFFER I/O
          SX5    X5 
          NZ     X5,IXFN6D2  IF NOT LWA 
          SA5    TYPEFG 
          PL     X5,IXFN6D2  IF NOT DOUBLE WORD ITEM
          MX7    1
          PL     X4,IXFN6A   IF NOT NON-STANDARD LOAD 
          SA5    X1+2+3 
          MX4    -18
          SX7    X5+B5
          BX5    X4*X5
          BX7    -X4*X7 
          BX7    X7+X5
          SA7    A5          CA = CA + 1
          EQ     IXFN6B 
  
 IXFN6D2  PL     X4,IXFN6A   IF NOT NON-STD LOAD
          EQ     IXFN6B 
  
 IXFN6A   SX4    B2+STLMAC
          NZ     X4,IXFN6B1  IF NOT IXFN MACRO
          SX6    B5 
          PL     X7,IXFN6B   IF NOT DOUBLE WORD BUFFER LWA
          SA5    X1+2+1            IH,CA OF ARRAY 
          MX4    -IX.CAL
          LX5    -IX.CAP
          SX7    X5+B5
          BX7    -X4*X7 
          BX5    X4*X5
          BX7    X7+X5
          LX7    IX.CAP 
          SA7    A5                CA = CA + 1
          EQ     IXFN6B 
  
 IXFN6B1  PL     X7,IXFN6B   IF NOT DOUBLE WORD BUFFER LWA
          SA5    NCA
          SX7    X5+B5
          SA7    A5                NCA = NCA + 1
 IXFN6B   SA6    APLRST      APLIST RESTART FLAG
          ZR     X6,IXFN7          ONLY DUMP ARRAY REFERENCES 
 IXFN6C   UX4    B2,X3             GET SET X MACRO OP 
          PX7    B2,X0             REPLACE SA WITH SX MACRO 
          SA7    A2 
          EQ     OUT
  
 IXFN7    SA3    IOEXP
          ZR     X3,IXFN8          IF NOT AN I/O EXPRESSION 
          SA2    ST.               NEEDED FOR LISTIO PROCESSING 
          EQ     IXFN9
  
 IXFN8    SA1    RL2TS
          SA2    X1+1              SYMTAB ORDINAL OF THE FIRST ITEM 
 IXFN9    SA5    SELIST 
          SX6    X5+B5             ADVANCE SELIST 
          SA6    A5 
          SA4    REFTYPE           IF THIS WAS A READ TYPE I/O-LIST THEN
          PL     X4,IXFN           SET THE DEFINED BIT, OTHERWISE EXIT. 
          SA4    SYM1 
          LX7    X2,B5
          SX3    X7 
          IX7    X4-X3
          SA4    X7 
          SX3    V.DEF
          BX7    X4+X3
          SA7    A4 
          EQ     IXFN 
          SPACE  3
*** 
*         IXFN MACRO EQUIVALENCE TABLE
*         NOTE THAT THE TRANSFORMATIONS PERFORMED BY IXFN ARE 
*         DEPENDENT ON THE FACT THAT THE EQUIVALENT MACROS HAVE THE 
*         SAME PARAMETERS, AND HENCE ARE THE SAME LENGTH, ETC.
  
          MACRO  IXME,LOADOP,SETOP   IXFN RLIST MACRO EQUIVALENCE 
          LOCAL  X
 X        SET    SETOP
          VFD    12/1777B-X,48/LOADOP 
          ENDM
  
 IXFN.TAB BSS    0
 SLMACO   IXME   SXTAMC 
 DLMACO   IXME   SXTAMC 
 STLMAC   IXME   SSSXA             STD SUBS 
          BSSZ   1                 TABLE TERMINATOR 
          TITLE              ACALL - CALL PROCESSOR 
*** 
*         ACALL - PROCESS SUBROUTINE NAME AND ARGUMENT LIST 
* 
*         ON ENTRY: 
*                NARGSF " 0 IF NO ARGS, ELSE = 0
*                SELIST POINTS PAST NAME
*                SUBNAME = NAME IN ELIST FORMAT 
  
*         FORM MASK OF ATTRIBUTES THAT CONFLICT WITH SUBROUTINE REF.
  
 P.ASF    DECMIC P.ASF
 P.BEF    DECMIC P.BEF
 P.INF    DECMIC P.INF
 P.VAR    DECMIC P.VAR
 CMASK    CON    1S"P.ASF"+1S"P.BEF"+1S"P.INF"+1S"P.VAR"
 ACALLD   CFO    EXT               CHECK SETTING OF DEBUG BITS
          IX2    X6+X2             SET TYPE 
          EQ     ACALL2 
  
 ACALL    ENTRY. **                ** ENTRY/EXIT ** 
          SA2    =XRSELECT         REFERENCE COLLECTION FLAG
          MX7    0
          BX6    X2 
          SA7    EQCOUNT           INITIALIZE 
          SA6    REFSELCT          SAVE IN LOCAL COPY 
          SA5    NARGSF 
          NZ     X5,ACALL1         IF NO ARGS 
          SA2    SELIST 
          SA1    X2                FIRST AFTER NAME 
          UX0    B4,X1
          RJ     SSERR3            CHECK ( SYNTAX 
 ACALL1   MX7    0
          SA7    ACNT 
          SYMBOL SUBNAME           GET SYMTAB ORDINAL 
          NZ     X7,ACALLD         IF PREVIOUS IN DEBUG STMTS 
          IX2    X6+X2             SET TYPE 
  
          SA3    CMASK
          BX0    X3*X2
          NZ     X0,ACALL4   IF CONFLICTING PREVIOUS USE
          MX0    L.TYP
          BX3    X0*X2
          LX3    L.TYP
          SX4    X3-T.ILL 
          MI     X4,ACALL2         IF LEGAL TYPE
          SX4    X3-T.ENT 
          ZR     X4,ACALL6         IF THIS IS AN ENTRY POINT
          EQ     ACALL4            NAME USED OTHER THAN AS SUBR NAME
  
 ACALL2   SX0    B5 
          LX0    P.EXT             SET EXT BIT
          BX7    X0+X2
          SA7    A2 
          SX6    B1 
          SX7    A1 
          SA6       SUBH
          SA7       SUBFWA
          SA7       FNAD
          MX6       0 
          SA6       SSFRSTB 
          SA1       NARGSF
          SA6    STAPLC 
          NZ     X1,ACAL7     IF NO ARG LIST
          SA1       SUBRLP
          SX7       2         SET EMODE TO ARG
          SA2       ARGCMA
          BX6    X1 
          SA7       EMODE 
          SA6       OPSTAK+1  STORE (SUBR 
          BX7    X2 
          SA7       OPSTAK+2  ,A
          SX6       2         SET OSPTR UP
          SA6       OSPTR 
          EQ     NEXTE
  
 ACALL4   SB6    ERMSG35
 ACALL5   SA2    NARGSF 
          SA1    EPOINT 
          NZ     X2,ACALL5A        IF NO ARGUMENTS
          SX6    X1+B5
          SA6    A1           RESET *EPOINT* TO ADDR OF SUBROUTINE NAME 
 ACALL5A  EQ     ERROUT 
  
 ACALL6   SB6    ERMSG57
          EQ     ACALL5 
  
*     ACAL7 ALSO ENTERED DIRECTLY FROM OPSWTB WHEN (C POPPED. 
  
 ACAL7    RJ     ACALA       CHECK DEBUG STATUS 
          ZR     X6,ACAL8    IF CALL TO BE TRACED 
          RJ     ARGP8CR
 ACAL8    SA1    SUBFWA 
          SA3    X1 
          LX3    59-P.FUN 
          PL     X3,ACAL8A   IF NOT ALSO USED AS A FUNCTION 
          USASDM  E328       SAME NAME USED AS A FUNCTION AND AS A SUB
 ACAL8A   SA5    ACNT 
          MX6    0
          BX7    X5 
          SA6    FNAD 
          SA7    ARGCNT 
          SA1    SUBFWA 
          SA2    X1-1 
          MX0    -L.FARG
          BX3    X2 
          LX3    -P.FARG
          BX6    -X0*X3 
          BX4    X2 
          LX4    59-P.FCALL 
          NG     X4,ACAL9    IF NOT THE FIRST CALL
          SX4    1
          LX4    P.FCALL     MARK FIRST CALL IN WORD B
          BX2    X2+X4
          LX5    P.FARG 
          BX6    X2+X5
          SA6    A2          ARG COUNT TO SYMTAB WORD B 
          NZ     X5,ACAL10   IF ARG COUNT .NZ.
          SA1    NARGSF 
          NZ     X1,ACAL10   IF NO ARGS EXPECTED
          EERR   ERMSG17     *ILLEGAL CALL FORMAT*
  
 ACAL9    BX6    X6-X5
          ZR     X6,ACAL10   IF CURRENT AND PREVIOUS ARG COUNTS MATCH 
          IDM    ERMSG36     *SUBR REF DOESN-T USE SAME NR ARGS*
  
 ACAL10   RJ     ACALA       CHECK DEBUG STATUS 
          SA6    TRCFLG 
          NZ     X6,ACALL    IF CALL TRACE NOT REQUIRED, EXIT ... 
          SA1    ARLPT
          MX6    0
          BX7    X1 
          SA6    =XTYPECLL
          SA7    TS1         TEMP SAVE SUBR APLIST POINTER
          RJ     FUNC8       ISSUE ANY SAVED FUNCTION RESULTS 
          RJ     =XFARGLST   CREATE *BUGCLL* APL AND RJ R-MACROS
          SA4    TS1         (X4) = FWA SUBR APL
          SA5    ARLPT       (X5) = LWA+1 
          BX6    X4 
          SA6    A5 
          RJ     DARLIST     APL AND RJ TO *RLIST* FILE 
          RJ     ARGP8CR
          SA1    TRCFLG 
          BX6    X1          (X6) = EXIT WITH SAVED TRACE FLAG
          EQ     ACALL       EXIT ... 
 ACALA    SPACE  4,8
**        ACALA - OBTAIN *CALL* DEBUG STATUS. 
* 
*         EXIT   (X6) = .ZR. IF DEBUG SELECTED FOR CURRENT *CALL*.
*                     = .NZ. IF NOT SELECTED. 
* 
*         USES   X - 0,1,2,6.   A - 1,2.   B - NONE.
  
  
 ACALA    JP     *+4S15      ** ENTRY/EXIT ** 
          SA1    =XDFLAG
          SX6    *           PRESET *NOT SELECTED* STATUS RETURN
          ZR     X1,ACALA    IF NOT DEBUG MODE
          SA1    =XALLCALL
          BX6    X6-X6       PRESET *DEBUG SELECTED* STATUS RETURN
          MX0    -L.DIF 
          NZ     X1,ACALA    IF ALL CALLS TO BE TRACED
          SA1    SUBFWA 
          SA2    X1-1 
          LX2    -P.DIF 
          BX1    -X0*X2 
          SX6    X1-DV.CLL   SET STATUS RETURN
          EQ     ACALA       EXIT ... 
          EJECT 
*** 
*         ARITH - ARITHMETIC EXPRESSION TRANSLATOR
* 
  
 ARITH    ENTRY. **                ** ENTRY/EXIT ** 
          SA5    TYPE 
          SX4    X5-RPLST 
          SA3    =XRSELECT        COPY THE EXTERNAL REFMAP FLAG TO THE
          BX7    X3                LOCAL CELL.
          SA7    =SREFSELCT 
          BX6    X6-X6           ZERO THE COUNT OF EQUAL SIGNS WHICH
          SA6    EQCOUNT           OCCUR IN THIS STATEMENT. 
          NZ     X4,ARITH9         IF NOT A REPLCAEMENT STMT
          SA1    =XN.EQUAL       PLACE THE NUMBER OF EQUAL SIGNS WHICH
          BX6    X1                OCCUR IN THIS STATEMENT INTO A LOCAL 
          SA6    =SEQCOUNT         CELL.
          SA2    EPOINT 
          SA1    X2 
          SYMBOL                   GET SYMTAB ORDINAL OF FIRST ENTRY
          EQ     ARITH.N           IF FIRST OCCURANCE 
  
          NE     B1,B5,ARITH2      IF NOT ORDINAL 1 
          SA3    VALUE. 
          ZR     X3,ARITH3         IF NOT A FUNCTION SUBPROGRAM 
          SB1    X3 
          SB2    B1+B1             2*ORD
          SA1    A0-B2             WORD A OF VALUE. 
          SA2    A1-B5
  
 ARITH2   BX3    X1 
          LX3    59-P.DIM 
          NG     X3,ARITH4         IF AN ARRAY
          SA5    EPOINT 
          SA4    X5-1 
          UX3    B3,X4
          SB4    EL.( 
          NE     B3,B4,ARITH4      IF NEXT IS NOT A ( 
  
          SA3    FSTEX
          NZ     X3,ARITH3         IF IT CANT BE AN ASF 
  
*         CHECK FOR ASF DEFINITION
  
          BX4    X2 
          MX0    60-L.TYP 
          LX4    L.TYP
          BX6    -X0*X4            EXTRACT TYPE 
          PL     X4,ARITH2A        IF NO ASF REDEFINITION 
          SA4    X5                X5 = ADDR OF ASF NAME (ELIST)
          POSTERR NR=ERMSG58,SEV=FE,FMT=ELIST,TXT=X4,RETURN=PH2RETN 
 ARITH2A  BX3    X1 
          LX4    59-P.EXT-L.TYP 
          LX3    59-P.FP
          BX3    X4+X3
          LX4    P.EXT-P.VAR
          BX3    X4+X3
          NG     X3,ARITH3         IF FP , EXT OR VAR 
          SX7    X6-T.ILL 
          PL     X7,ARITH3         IF AN ILLEGAL TYPE 
  
          SX0    V.FUN
          BX6    X0+X1             SET FUNCTION BIT 
          SA6    A1 
          MX5    L.DBGI 
          LX5    L.DBGI+P.DBGI
          BX2    -X5*X2            CLEAR DEBUG FIELD
          LX0    P.ASF-P.FUN
          BX7    X0+X2             SET FUNCTION TYPE
          SA7    A2 
          EQ     ASFDEF            GO PROCESS THE DEFINITION
  
 ARITH3   SA1    EPOINT 
          SX6    X1-1 
          SA6    A1                MOVE EPOINT BACK FOR ERROUT
          SX7    B1 
          SA7    SAVELEFT 
          EERR   ERMSG37           LEFT SIDE OF REPL STMT IS ILLEGAL
  
*         FIRST OCCURANCE - SET TYPE
  
 ARITH.N  ZR     X7,ARITH.N1       IF NO PREVIOUS USE IN DEBUG STMTS
          CFO    VAR               CHECK SETTING OF DEBUG BITS
 ARITH.N1 IX5    X7+X2
          BX6    X6+X5             ADD TYPE 
          SA6    A2 
          LX2    X6 
          EQ     ARITH2 
  
*         INITIALIZE FOR ASSIGNMENT STMT PROCESSING 
  
 ARITH4   SX0    V.DEF
          BX6    X0+X1
          SA6    A1                SET DEFINED BIT
          SX7    B1 
          SA7    SAVELEFT 
  
 ARITH9   SA2    FSTEX
          NZ     X2,ARITH10        IF NOT THE FIRST EXECUTABLE STMT 
          CALL   IPH2              INITIALIZE FOR PHASE 2 
  
 ARITH10  RJ     INITR
          EQ     NEXTE
          SPACE  3
*** 
*     INITR INITIALIZES ARITH AND LEAVES WITH X6 NOT=0
*         SOME WORDS ARE INITIALIZED BECAUSE IF FATAL DIAG IS GIVEN, THE
*        WORD MIGHT NOT HAVE BEEN RESET, AND TROUBLES MIGHT RESULT IN 
*        NEXT ARITH CALL. 
  
 INITR    ENTRY. **                ** ENTRY/EXIT ** 
          MX6       0 
          SA6    WLSTR
          IX7    X0-X0
          SA7    ARLST
          SA6    NCA
          SA7    NCAD 
          SA6    NRFD 
          SA7    ACALL       FOR TEST IN *OUT*
          SA7       FTRFLG
          SA6       EQFLG 
          SA7       OSPTR 
          SA6       ARLPT 
          SA7       SFRSTB
          SA6       RNTBC 
          SA7       IXFNFG    CLEARED HERE BECAUSE WOULD NOT RETURN TO
*                              IXFN IF FATAL DIAGNOSIC GIVEN. 
          SA6       ARLIST
          SUB 
          SA7       LEFRN 
          SA6    STAPLC 
          SA7       CC
          SA7       ITFFG 
          SA6       EQPO5F
          SA7       EXRL1     USED AS FLAG BY FUNC5RT 
          SA7    =SPARLEVEL      ZERO THE PARENTHESIS LEVEL 
          SA7    SPARLEV
          SA6       ROFG
          SA7    ARORD
          SA6    FNAD 
          SA7    ABIO 
          MX6       59        SET X6=-1 
          SX7       ARLIST
          SUB 
          SA6       FF
          SA6       STBASE
          SA6       NSFR
          SA7       LASTR 
          BX6   -X6           SET X6=1
          SA7       RL2 
          SA6       EMODE 
*     IXFN COUNTS ON X6 BEING NON-ZERO AT THIS POINT. 
          ZR        INITR 
          ZR        NEXTE 
          TITLE  *IF* STATEMENT PROCESSING
*     THREE AND TWO BRANCH IF 
* 
 LTYPE    EQU       RA+21B    TYPE OF S IN LOG IF 
 CLABEL   EQU       RA+23B    CURRENT STATE.LABEL 
 LELIST   EQU       RA+34B    START OF S IN LOG IF
 NLABEL   EQU       RA+60B    NEXT STATE.LABEL
  
*         ERROR NUMBERS.
  
 E173     =      173         ILLEGAL LABELS IN IF STATEMENT 
 E174     =      174         LOGICAL EXPRESSION IN 3 BRANCH IF
 E193     =      193         THIS STATEMENT BRANCHES TO ITSELF
 E194     =      194         THIS IF DEGENERATES INTO A SIMPLE TRANSFER 
 E316     =      316         ILLEGAL SYNTAX IN IF STATEMENT 
  
 IFTS1    BSS    6                 TEMPORARY STORAGE
 IFTS2    BSS    2
 IFRPF    BSSZ   1           IF -)CONST- FLAG .NZ. FOR CONSTANT FOUND 
 IFRELOP  BSSZ   1                 SET TO RELOP CODE IF A SIMPLE IF STMT
 IFETYPE  BSS    1                 MODE OF EXPRESSION IN IF STMT
 IFRETURN BSS    1                 RETURN ADDR ( AFTER OUTPUTTING JUMPS 
 LIFTS1   BSS    1                 ORDINAL OF FALSE BRANCH LABEL
 BRANCHNO BSS    1                 BRANCH NUMBER
 K1       BSS    1                 BRANCH ORDINALS AS SET BY 'IFBRT'
 K2       BSS    1
 K3       BSS    1
 DOT      BSS    1           CURRENT STATEMENT DO TERMINATOR FLAG 
  
 M.UJP    RMEQU   105B
          SPACE  1
          ENTRY  APLST
 APLST    RMHDR  APLMC,1     APLIST MACRO FOR DEBUG 
          BSS    1
 GEFM     RMHDR  GEFMC,2
 UJPM     RMHDR   M.UJP,1 
          BSS     1 
 IFMC     ARMAC  0,0,2,3           IF MACRO TEMPLATE
  
          MACRO  RMACRO,NAME,BASE 
          NOREF  NAME 
 NAME     =      BASE  MACNUM 
 MACNUM   SET    NAME+1 
RMACRO    ENDM
  
 IFTABLE  MACRO  T1,A,B,C 
          IRP    T1 
CHAR      MICRO  1,1, T1
          IFGE   IF("CHAR")A_B_C,0,2
          VFD    12/2000B+IF("CHAR")A_B_C,12/T1,2/A,2/B,2/C 
          SKIP   1
          VFD    12/1777B+IF("CHAR")A_B_C,12/T1,2/A,2/B,2/C 
          IRP 
 IFTABLE  ENDM
 N        EQU    0                 CODE FOR NEXT LABEL IN IFTAB MACROS
  
*         RLIST MACRO NUMBERS OF THE IF MACROS
  
 IF(R)123 RMACRO 362B        BASE RMACRO NUMBER FOR IF MACROS 
IF(I)123  RMACRO IF(R)123 
 IF(D)123 RMACRO IF(R)123 
IF(R)122  RMACRO
 IF(D)122 RMACRO IF(R)122 
IF(I)122  RMACRO
IF(R)113  RMACRO
 IF(D)113 RMACRO IF(R)113 
IF(I)113  RMACRO
IF(R)121  RMACRO
 IF(D)121 RMACRO IF(R)121 
IF(I)121  RMACRO IF(R)121 
IF(R)N23  RMACRO
 IF(D)N23 RMACRO IF(R)N23 
IF(I)N23  RMACRO IF(R)N23 
IF(R)1N3  RMACRO
 IF(D)1N3 RMACRO IF(R)1N3 
IF(I)1N3  RMACRO
IF(R)12N  RMACRO
 IF(D)12N RMACRO IF(R)12N 
IF(I)12N  RMACRO IF(R)12N 
IF(R)N22  RMACRO
 IF(D)N22 RMACRO IF(R)N22 
IF(I)N22  RMACRO
IF(R)1NN  RMACRO
 IF(D)1NN RMACRO IF(R)1NN 
IF(I)1NN  RMACRO
IF(R)NN3  RMACRO
 IF(D)NN3 RMACRO IF(R)NN3 
IF(I)NN3  RMACRO
IF(R)11N  RMACRO
 IF(D)11N RMACRO IF(R)11N 
IF(I)11N  RMACRO
IF(R)N2N  RMACRO
 IF(D)N2N RMACRO IF(R)N2N 
IF(I)N2N  RMACRO IF(R)N2N 
IF(R)1N1  RMACRO
 IF(D)1N1 RMACRO IF(R)1N1 
IF(I)1N1  RMACRO IF(R)1N1 
IF(L)12   RMACRO
IF(L)N2   RMACRO
IF(L)1N   RMACRO
IF(C)121  RMACRO
IF(C)N2N  RMACRO
IF(C)1N1  RMACRO
 IFFLAG1  RMACRO
IFFLAGN   RMACRO
IF(R)111  EQU    -IFFLAG1 
IF(R)NNN  EQU    -IFFLAGN 
IF(I)111  RMACRO IF(R)111 
IF(D)111  RMACRO IF(R)111 
IF(C)111  RMACRO IF(R)111 
IF(L)11   RMACRO IF(R)111 
IF(I)NNN  RMACRO IF(R)NNN 
IF(D)NNN  RMACRO IF(R)NNN 
IF(C)NNN  RMACRO IF(R)NNN 
IF(L)NN   RMACRO IF(R)NNN 
          SPACE  2,10 
**        IFTABLE - FOR LOOKING UP *IF* R-MACRO NUMBER, GIVEN THE 
*                   EXPRESSION MODE AND BRANCH PATTERN. 
  
IFTABLE   BSS    0
          IFTABLE  (INTEGER,REAL,DOUBLE),1,2,3
          IFTABLE  (INTEGER,REAL,DOUBLE),1,2,2
          IFTABLE  (INTEGER,REAL,DOUBLE),1,2,1
          IFTABLE  (INTEGER,REAL,DOUBLE),1,1,3
          IFTABLE  (INTEGER,REAL,DOUBLE),1,2,N
          IFTABLE  (INTEGER,REAL,DOUBLE),1,N,3
          IFTABLE  (INTEGER,REAL,DOUBLE),N,2,3
          IFTABLE  (INTEGER,REAL,DOUBLE),1,N,N
          IFTABLE  (INTEGER,REAL,DOUBLE),N,2,2
          IFTABLE  (INTEGER,REAL,DOUBLE),1,N,1
          IFTABLE  (INTEGER,REAL,DOUBLE),N,2,N
          IFTABLE  (INTEGER,REAL,DOUBLE),1,1,N
          IFTABLE  (INTEGER,REAL,DOUBLE),N,N,3
          IFTABLE  (INTEGER,REAL,DOUBLE,COMPLEX),1,1,1
          IFTABLE  (INTEGER,REAL,DOUBLE,COMPLEX),N,N,N
          IFTABLE  (COMPLEX),1,2,1
          IFTABLE  (COMPLEX),1,N,1
          IFTABLE  (COMPLEX),N,2,N
          IFTABLE  (LOGICAL),1,2
          IFTABLE  (LOGICAL),1,N
          IFTABLE  (LOGICAL),N,2
          IFTABLE  (LOGICAL),1,1
          IFTABLE  (LOGICAL),N,N
          SPACE  2
**        IF1.TBL AND IF2.TBL - SET BRANCH PATTERN FOR 1- AND 2-BRANCH
*         IF STMT WHEN THEY CAN BE REDUCED TO AN ARITHMETIC IF
*         BECAUSE THEY CONTAIN ONLY A SINGLE RELATIONAL EXPRESSION. 
  
 IFBP     MACRO  B1,B2,B3          IF BRANCH PATTERN MACRO
          VFD    2/B1,2/B2,2/B3 
          ENDM
  
 IF1.TBL  IFBP   N,N,3             GT 
          IFBP   N,2,N             EQ 
          IFBP   N,2,2             GE 
          IFBP   1,N,N             LT 
          IFBP   1,N,1             NE 
          IFBP   1,1,N             LE 
 IF2.TBL  IFBP   1,1,3             GT  * MUST SWAP LABELS 
          IFBP   1,2,1             EQ  *
          IFBP   1,2,2             GE  *
          IFBP   1,2,2             LT 
          IFBP   1,2,1             NE 
          IFBP   1,1,3             LE 
 IF       TITLE  IFE - IF STATEMENT PROCESSING
**        PIE - PROCESS IF STATEMENT. 
*                IF STATEMENT INITIAL PROCESSING. 
  
  
 PIE      ENTRY. *                 ** ENTRY/EXIT ** 
          BX6    X6-X6
          MX7    0
          SA6    IFRPF             CLEAR *CONSTANT AFTER RT PAREN* FLAG 
          SA7    IFRELOP     CLEAR *SINGLE RELTNL EXPR ONLY* FLAG 
          SA6    K2 
          SA1    TRACEL 
          SA2    DOFLAG 
          IX7    X1-X2
          SA7    TRCFLG            NEG IF NO FLOW TRACING 
          GETE
          IF.NE  EL.(,IF.ERR3      IF NOT LEFT PAREN
          RJ     ARITH             PARSE IF EXPRESSION
          BX6    X6-X6
          SA6    ARLPT             RESET THE ARLIST BUFFER POINTER
          SA6    RL2                 AND LAST OPERAND POINTER 
          SA5    EXPRIA            EXAMINE THE EXPRESSION RESULT AND
          SA3    X5+2              EXTRACT THE RESULT 'RI' NUMBER AND 
          SA2    X5                RESULT EXPRESSION TYPE 
          SB5    1
          UX0    X2,B1
          SX7    X3 
          SA7    PARAMS+3          PLACE THE 'RI' OF THE RESULT IN THE
          SX6    B1                'PARAMS' BUFFER
          SX7    X7+B5
          SA6    IFETYPE           SAVE THE EXPRESSION TYPE 
          SA7    A7+B5             ALSO PLACE 'RI'+1 INTO THE 'PARAMS'
*                                  BUFFER IN CASE THE RESULT IS A 
*                                  DOUBLE WORD ITEM.
          EQ     PIE
          SPACE  4,8
**        IFE - IF STMT PROCESSING FOR IF(E) N1,N2 AND IF(E) N1,N2,N3 
  
 IF.ERR1  EERR   E173              ERR MSG NR - *ILL LABELS IN IF STMT* 
 IF.ERR3  UPDATE
          EERR   E316              ERR MSG NR - *ILL SYNTAX IN IF STMT* 
 IF.ERR4  EERR   E174              ERR MSG NR - *LOG EXP IN 3 BRANCH IF*
  
 IFE      ENTRY. **                ** ENTRY/EXIT ** 
          BX6    X6-X6
          SA6    IFRETURN          SET *RETURN THROUGH -IFE-* FLAG
          RJ     PIE               PROCESS *IF* EXPR
          SX6    B5 
          SA6    BRANCHNO          SET BRANCHNO TO 1
          RJ     IFBRT           CALL 'IFBRT' TO PROCESS BRANCH ONE.
          NZ     X7,IF.ERR1      IF ONLY ONE BRANCH THEN GO TO 'IF.ERR1'
                                   TO FLAG THE ERROR. 
          SA6    K1              SAVE THE BRANCH INDICATOR IN 'K1' AND
          SA6    K3                'K3' IN CASE THIS IS A TWO-BRANCH
          SA1    PARAMS            ARITHMETIC 'IF' STATEMENT.  (ALSO
          BX7    X1                REPLICATE THE BRANCH 'IH' INFORMATION
          SA7    PARAMS+2          IN THE 'PARAMS' BUFFER.) 
          SA5    EPOINT          UPDATE 'EPOINT' TO POINT TO THE NEXT 
          SX6    X5-2              WOULD BE LABEL 
          SA6    A5 
          RJ     IFBRT           CALL 'IFBRT' TO PROCESS BRANCH TWO.
          SA6    K2              SAVE THE SECOND BRANCH INDICATOR IN
          NZ     X7,IFTWOBR        'K2' AND GO TO 'IFTWOBR' IF THERE ARE
                                   ONLY TWO BRANCHES. 
          SA5    EPOINT          UPDATE 'EPOINT' TO POINT TO THE NEXT 
          SX6    X5-2              WOULD BE LABEL 
          SA6    A5 
          RJ     IFBRT           CALL 'IFBRT' TO PROCESS BRANCH THREE.
          ZR     X7,IF.ERR1      IF THE THIRD BRANCH WAS NOT FOLLOWED BY
                                   AN END-OF-STATEMENT GO TO 'IF.ERR1'
                                   TO FLAG THE ERROR. 
          SA6    K3              SAVE THE THIRD BRANCH INDICATOR IN 'K3'
          SA1    IFRELOP
          NZ     X1,IF.ERR4        IF THREE BRANCH LOGICAL IF 
IF.1      SA5    IFETYPE
          SX1    X5-T.CPLX
          NZ     X1,IF.2         IF THE EXPRESSION WAS NOT TYPE COMPLEX 
          USASDM ERMSG47           THEN GO TO 'IF.2', OTHERWISE ISSUE 
                                   A 'USAS' DIAGNOSTIC. 
          SX6    T.REAL          CHANGE THE EFFECTIVE EXPRESSION TYPE TO
          SA6    IFETYPE           REAL.
IF.2      SA5    IFETYPE
          SX4    X5-T.LOG 
          ZR     X4,IF.ERR4        IF TYPE LOGICAL
  
 IF.3     SA4    K1 
          SA3    A4+B5             K2 
          LX4    4
          SA2    A3+B5             K3 
          LX3    2
          IX6    X2+X3
          BX4    X4+X6             FORM BRANCH PATTERN
          SA5    IFETYPE
* 
*         (X4) = BRANCH PATTERN 
*         (X5) = IFETYPE
* 
 IF.4     SX7    X5-T.OCT 
          MI     X7,IF.4A          IF EXPR TYPE NOT OCTAL OR HOLL 
          SX5    T.INT             CHANGE TO INTEGER
 IF.4A    LX5    6
          IX0    X4+X5             X0 = SEARCH PATTERN
*                                     = 4/EXPR MODE,2/K1,2/K2,2/K3
          BX1    -X0
          SB3    X1              (REGISTER B3 NOW CONTAINS THE
          SA1    IFTABLE           COMPLEMENT OF THE SEARCH KEY.) 
IF.5      UX0    X1,B2
          SX3    X1+B3
          LX1    30 
          SX2    X1+B3
          ZR     X2,IF.6         IF THE 'IFTABLE' ENTRY IN THE TOP HALF 
                                   OF THE WORD MATCHES THEN GO TO 'IF.6'
          UX0    X1,B2
          SA1    A1+B5             (FETCH THE NEXT TABLE WORD.) 
          NZ     X3,IF.5         IF THE 'IFTABLE' ENTRY IN THE BOTTOM 
                                   HALF OF THE WORD DOES NOT MATCH THEN 
                                   CONTINUE WITH THE SEARCH.
 IF.6     PL     B2,IF.6A        IF THE STATEMENT DID NOT DEGENERATE TO 
                                   A SIMPLE 'GO TO' THEN GO TO 'IF.6A'
          SX7    -B2             OTHERWISE SAVE THE MACRO CODE AND ISSUE
          SA7    IFTS2             AN INFORMATIVE DIAGNOSTIC. 
          SA1    EPOINT          SET EPOINT TO POINT AT THE LABEL 
          SX6    X1-1 
          SA6    A1 
          IDM    E194              ERR MSG NR - *DEGENERATES TO SMPL TR*
          SA4    IFTS2           RESTORE THE MACRO CODE AND CONTINUE. 
          SB2    X4 
          SX6    X4-IFFLAGN 
          ZR     X6,IF.6C    IF  IF(E)NNN CASE
 IF.6A    SA1    TRCFLG 
          MI     X1,IF.6B        GO TO 'IF.6B' IF NO FLOW TRACING.
          SA1    DBGAPL            TRANSFER GL NUMBERS FROM 
          SA2    A1+1                THE TEMPORARY BUFFER TO
          BX6    X1                  THE PARAMS BUFFER FOR
          LX7    X2                  THE MACOUT CALL
          SA6    PARAMS 
          SA1    A2+1 
          SA7    A6+1 
          BX6    X1 
          SA6    A7+1 
 IF.6B    SA4    IFMC            PICKUP THE 'IF' MACRO TEMPLATE AND 
          PX3    X4,B2             INSERT THE APPROPRIATE R-LIST MACRO
          SA2    NARN 
          MX5    0
          RJ     MACOUT          CALL 'MACOUT' TO ISSUE THE R-LIST MACRO
          SA5    ARLPT
          BX4    X4-X4
          RJ     DARLIST         CALL 'DARLIST' TO DUMP THE ACCUMULATED 
          BX6    X6-X6
          SA6    ARLPT       RESET THE ARLIST POINTER 
 IF.6C    SA5    IFRETURN 
          ZR     X5,IF.7           TO THE CALLER. 
          SB7    X5 
          JP     B7 
          SPACE  1
IF.7      SA1    TRCFLG 
          NG     X1,IFE            EXIT IF NO FLOW TRACING
          SX7    B5                INITIALIZE TO 1
          SA1    IFTS1+5           USED AS TABLE COUNTER
IF.8      SA2    IFTS1+X7          FETCH TABLE WORD 
          ZR     X2,IF.9           ZERO IF END OF TABLE 
          SA7    A1                SAVE COUNTER 
          SA5    IFTS1+5     TABLE COUNTER
          SA1    LABEL. 
          SA2    IFTS1+X5 
          SX3    X2-1        LABTAB ORD - 1 
          LX3    AP.CAP 
          AX2    18 
          BX7    X2 
          SA7    UJPM+1      USE AS TEMPORARY STORAGE 
          BX6    X1+X3
          SA6    APLST+1
          WRM    APLST       APLIST FOR LABEL. + CA 
          SA4    UJPM+1 
          BX6    X4 
          AX6    18                ISOLATE LABEL IH 
          SA6    A4 
          SX5    X4+I.GL           SET GL IH
          CALL   WLABM
          SYMBOL =8RBUGTRU
          SA3    =XDBGEXT 
          BX7    X2+X3             SET CGS AND EXT BITS 
          SA7    A2 
          SA1    =XN.AP 
          SX7    X1+B5             INCREMENT N.AP 
          SA7    A1 
          SX2    I.AP+X1
          LX2    RM.IHL 
          SA5    GEFM 
          SX3    B1 
          SA4    CDCNT
          BX7    X5 
          BX6    X2+X3             CREATE 1ST WORD OF GEF PARAMETERS
          SA7    DBGAPL            STORE GEF MACRO HEADER 
          BX7    X4 
          SA6    A7+B5
          SA7    A6+B5
          WRM    DBGAPL 
          WRM    UJPM 
          SA1    IFTS1+5           TABLE COUNTER
          SB5    1
          SX7    X1+B5             INCREMENT POINTER
          EQ     IF.8 
 IF.9     SA3    =XN.GL 
          IX6    X3+X1             UPDATE GL NUMBER 
          SA6    A3 
          EQ     IFE               EXIT IF PROCESSOR
  
*         2 BRANCH IF STMT PROCESSING - IF(EXPR) 1,2
  
 IFTWOBR  USASDM ERMSG46     *TWO-BRANCH IF NON-ANSI* 
          SA3    IFRELOP
          NZ     X3,IFTWO1         IF EXPR IS A SIMPLE RELATIONAL 
          SA5    IFETYPE
          SX6    X5-T.LOG          IF EXPR IS NOT LOGICAL, THEN 
          NZ     X6,IF.1           PROCESS AS IF IF(EXPR) 1,2,1 
          SA6    K3 
          EQ     IF.3              GO OUTPUT BRANCH CODE
  
 IFTWO1   SA1    K1 
          SA2    A1+B5             K2 
          IX0    X1-X2
          BX6    X2 
          SA6    A2+B5             K3 = K1
          ZR     X0,IF.3           IF DEGENERATE
          IX7    X1+X2
          SB7    X7 
          JP     B7+IFTWO.J-1      JUMP TO APPROPIATE PROCESSOR 
  
 IFTWO.J  EQ     IFTWO7            IF(E) 1,N
          EQ     IFTWO6            IF(E) N,2
  
+         SX4    X3-4              IF(E) 1,2
          PL     X4,IFTWO2         IF NOT NEC TO SWAP LABELS
          SA1    PARAMS 
          SA2    A1+B5             SWAP( LAB1 , LAB2 )
          BX7    X1 
          LX6    X2 
          SA6    A1 
          SA7    A2 
 IFTWO2   SA1    IF2.TBL           BRANCH PATTERN TABLE 
          SA5    PARAMS+1 
          BX7    X5 
          SA7    A5+B5
  
*         X1 = IF BRANCH PATTERN TABLE
*         X3 = IFRELOP
  
 IFTWO3   SX3    X3          REMOVE ANY FLAG BITS 
          MX0    60-6              DETERMINE BRANCH PATTERN FROM TABLE A
          IX6    X3+X3
          LX3    2                 AND IFRELOP
          IX7    X3+X6
          SB2    X7                6*IFRELOP
          LX1    B2,X1
          BX4    -X0*X1            X4 = BRANCH PATTERN
          SA5    IFETYPE
          SX6    X5-T.CPLX
          NZ     X6,IF.4           IF EXPR MODE NOT COMPLEX 
          SX0    X3-2S2            .EQ. OP
          SX7    X3-5S2            .NE. OP
          ZR     X0,IF.4           IF EQ OP 
          ZR     X7,IF.4           IF .NE. OP 
          SX5    T.REAL            CHANGE EXPR MODE TO REAL FOR 
          EQ     IF.4              COMPARISION OPS LT , LE , GT  AND GE 
  
 IFTWO6   SX0    7                 IF(E) N,2 - COMPLEMENT IFRELOP 
          BX4    -X0*X3            SAVE SIGN BIT
          SX3    X3 
          IX5    X0-X3             IFRELOP = 7-IFRELOP
          BX3    X4+X5
 IFTWO7   SA2    PARAMS-1+B7       ACTIVE LABEL 
          SA1    IF1.TBL
          BX6    X2 
          SA6    PARAMS            REPLICATE LABEL IN PARAMS BUFFER 
          SA6    A6+B5
          SA6    A6+B5
          SA2    DBGAPL-1+B7       ALSO REPEAT IN THE DBGAPL TABLE
          BX6    X2 
          SA6    DBGAPL 
          SA6    A6+B5
          SA6    A6+B5
          EQ     IFTWO3            GET BRANCH PATTERN AND OUTPUT JUMPS
 ARITH    TITLE                  IFBRT - 'IF' BRANCH PROCESSING 
**        IFBRT - PROCESS REFERENCE TO A LABEL IN AN IF STMT
*                EPOINT -- 'E-LIST' ADDRESS OF LABEL TO BE PROCESSED   *
*                BRANCHNO -- NUMBER OF 'IF' BRANCH (1 FOR FIRST, ETC.) *
*         RETURNS:                                                     *
*                PARAMS-1+[BRANCHNO] -- 'IH' OF LABEL                  *
*                BRANCHNO -- BRANCHNO + 1                              *
*                X6       -- 0 (LABEL IS THE SAME AS THE LABEL ON THE  *
*                               NEXT STATEMENT)                        *
*                            1 (LABEL IS THE SAME AS THE FIRST BRANCH) *
*                            2 (LABEL IS THE SAME AS THE SECOND BRANCH)*
*                            3 (LABEL IS THE SAME AS THE THIRD BRANCH) *
*                X7       -- .EQ. 0 (LABEL FOLLOWED BY A COMMA)        *
*                            .NE. 0 (LABEL FOLLOWED BY EOS)            *
  
 IFBRT    ENTRY. *                 ** ENTRY/EXIT ** 
          SA5    CLABEL 
          MX6    0
          ZR     X5,IFBRT1   IF CURRENT STATEMENT NOT LABELLED
          SA1    =XLORD 
          SA2    SYM1 
          IX0    X1+X1
          IX3    X2-X0
          SA4    X3-1        WORD B OF CURRENT LABEL
          LX4    59-P.DLT 
          BX6    X4 
  
 IFBRT1   SA6    DOT
          SA1    EPOINT            IF NEXTE IS NOT AN 
          SA2    X1                INTEGER CONSTANT THEN GO TO 'IF.ERR1'
          UX0    X2,B2             TO ISSUE A FATAL DIAGNOSTIC. 
          NZ     B2,IF.ERR1 
          AX0    45 
          SA4    A2-B5             (OBTAIN NEXT 'E-LIST' ELEMENT.)
          SA3    X2                (OBTAIN THE LABEL IN HOLLERITH FORM.)
          MX6    60-3 
          BX0    -X6*X0 
          SX7    X0-T.INT 
          UX0    X4,B2
          NZ     X7,IF.ERR1 
          SX7    B2-EL.COMMA
          IX1    X3-X5
          BX6    X3 
          ZR     X7,IFBRT.1      IF THE LABEL IS NOT FOLLOWED BY A COMMA
          SB2    B2-EL.EOS         OR END-OF-STATEMENT, THEN GO TO
          NZ     B2,IF.ERR1        'IF.ERR1' TI ISSUE A FATAL DIAGNOSTIC
IFBRT.1   SA7    IFTS2           (SAVE THE TERMINATING ELEMENT INDICATOR
          NZ     X1,IFBRT.2 
          IDM    -E193             ERR MSG- *STMT BRANCHES TO ITSELF* 
          SA1    EPOINT 
          SA2    X1 
          SPACE  1
 IFBRT.2  CALL   DOLABR            INFORM DO OF THE LABEL REF 
          SA7    IFTS2+1     SAVE THE HOLLERITH FORM OF THE LABEL 
          SA1    TRCFLG 
          NG     X1,IFBRT.2A       BRANCH IF NO FLOW TRACING
          MX0    60-L.TRO 
          LX2    60-P.TRO 
          BX7    -X0*X2            LABEL TABLE ORDINAL
          SA7    IFTS1             SAVE IN TEMPORARY
          EQ     IFBRT.3
          SPACE  1
 IFBRT.2A SA1    DOT
          MI     X1,IFBRT.3  IF CURRENT STATEMENT DO TERM.
          SA5    IFTS2+1     IF THE BRANCH LABEL IS THE SAME AS THE 
          SA3    NLABEL            LABEL OF THE NEXT STATEMENT THEN 
          BX6    X5-X3             REMOVE THE 'RSN' BIT FROM THE
          NZ     X6,IFBRT.3        LABEL ATTRIBUTES IF THIS WAS THE 
          SX0    B5                FIRST REFERENCE TO THE LABEL.  (THIS 
          LX0    P.RSN             WILL KEEP THE LABEL FROM BEING ACTIVE
          BX6    -X0*X2            WHILE NOT CAUSING THE LABEL TO APPEAR
          BX7    X6+X4             TO BE REFERENCED SINCE 'DOLABR'
          SA7    A2                WILL ALSO TURN ON THE 'DIN' BIT.)
          SPACE  1
IFBRT.3   SA1    BRANCHNO        INSERT THE 'IH' OF THE LABEL INTO THE
          SX7    B1                'PARAMS' BUFFER IN THE APPROPRIATE 
          SX6    X1+B5             POSITION.  INCREMENT THE BRANCH
          SA7    PARAMS-1+X1       NUMBER.
          SA6    BRANCHNO 
          SA4    DOT
          MI     X4,IFBRT.3A IF CURRENT STATEMENT DO TERM.
          SA4    TRCFLG 
          PL     X4,IFBRT.3A       BRANCH IF FLOW TRACING 
          SA5    NLABEL          RETURN WITH THE FOLLOWING INFORMATION: 
          SA4    IFTS2+1           X6-- 0 (LABEL = NEXT STATEMENT LABEL)
          IX6    X4-X5                  1 (LABEL = FIRST BRANCH LABEL)
          ZR     X6,IFBRT.5             2 (LABEL = SECOND BRANCH LABEL) 
IFBRT.3A  BX6    X6-X6                  3 (LABEL = THIRD BRANCH LABEL)
IFBRT.4   SA4    PARAMS+X6
          BX0    X7-X4
          SX6    X6+B5
          NZ     X0,IFBRT.4 
          SA4    TRCFLG 
          NG     X4,IFBRT.5        BRANCH IF NO FLOW TRACING
          SA3    N.GL 
          SX4    X6-1              COMPENSATE FOR BIAS
          SB6    X6                WILL BE RESTORED LATER 
          IX2    X3+X4             DEBUG GL FOR LABEL 
          SX0    X2+I.GL
          SA3    IFTS1             LABEL TABLE ORDINAL
          LX2    18 
          SX5    B1                ORIGINAL LABEL ORDINAL 
          BX4    X2+X3             GL AND LABTAB ORD
          LX5    36 
          BX7    X5+X4             ADD ORD FOR LABEL
          IX4    X1-X6
          BX6    X0 
          SA6    DBGAPL-1+X1       TEMPORARY BUFFER 
          SX6    B6 
          NZ     X4,IFBRT.5        BRANCH IF LABEL ALREADY IN LIST
          SA5    K2 
          SX3    X5-1              IS SECOND LABEL SAME AS FIRST
          NZ     X3,IFBRT.4A       BRANCH IF NOT
          SX4    B5 
          IX6    X0-X4             ADJUST GL NUMBER 
          LX4    18 
          IX7    X7-X4             ADJUST GL NUMBER 
          SA6    A6                SAVE ADJUSTED INFORMATION
          SX1    X1-1              ADJUST ARRAY POINTER 
          SX6    B6 
IFBRT.4A  SA7    IFTS1+X1          ADD INFORMATION TO LIST
          MX7    0
          SA7    A7+B5             ZERO WORD TO TERMINATE LIST
IFBRT.5   SA5    IFTS2             X7-- .EQ. 0 (LABEL FOLLOWED BY COMMA)
          BX7    X5                     .NE. 0 (LABEL FOLLOWED BY EOS)
          ZR     IFBRT           RETURN.
 IFL      TITLE  IFL - LOGICAL IF PROCESSING
**        IFL - PROCESS LOGICAL IF STMTS     IF(L) STMT 
  
 E175     =      175         STMT IN LOGICAL IF MAY BE ANY EXECUTABLE 
*                              OTHER THAN DO OR ANOTHER LOGICAL IF
 E176     =      176         EXPR IN LOGICAL IF IS NOT TYPE LOGICAL 
  
 IFL.ERR1 EERR   -E175
 IFL.ERR2 EERR   -E176
  
 IFL      ENTRY. **                ** ENTRY/EXIT ** 
          RJ     PIE               PROCESS *IF* EXPRESSION
          SA5    IFRELOP
          NZ     X5,IFL.0          IF A SINGLE RELATIONAL OP
          NZ     X6,IFL.ERR2       IF EXPR IN IF NOT LOGICAL
  
 IFL.0    SA1    TRCFLG 
          PL     X1,IFL.2    IF IN DEBUG MODE 
          SA1    LTYPE
          SA2    LELIST 
          SA3    X2 
          UX7    B1,X3
          SX0    X1-20
          NZ     X0,IFL.1    IF NOT  IF(L) RETURN 
          NZ     X7,IFL.2    IF RETURNS 
          SA3    PROGRAM
          UX2    B3,X3
          ZR     B3,IFL.2    IF A MAIN PROGRAM
          MX2    0
          RJ     =XDOLABR    INHIBIT OPTIMIZATION IF IN DO LOOP 
          SA1    =XO.CEP
          ADDREF X1,REF 
          SA3    =XEXIT.
          BX7    X3 
          SX6    B5 
          SA7    PARAMS      ORD(N1) = ORD(EXIT.) 
          EQ     IFL.1B 
  
 IFL.1    SX0    X1-15
          NZ     X0,IFL.2          IF NOT   IF(L) GOTO N
          NZ     B1,IFL.2          IF NOT A CONSTANT
          MX5    -3 
          AX7    45 
          BX5    -X5*X7 
          SX0    X5-T.INT 
          SA3    X2-1 
          UX7    X3,B1
          BX6    X2 
          SX5    B1-EL.EOS
          BX0    X0+X5
          SX7    B5 
          NZ     X0,IFL.2        (NOT A PROPER 'GO TO LABEL' OR LABEL 
                                   NOT FOLLOWED BY AN END-OF-STATEMENT.)
          SPACE  1
          SA6    EPOINT 
          SA7    BRANCHNO 
          RJ     IFBRT           CALL 'IFBRT' TO PROCESS THE LABEL
 IFL.1B   SA3    IFRELOP
          SX7    IFL               SET RETURN ADDR
          SA7    IFRETURN 
          SB7    B5 
          ZR     X6,IFL.1A         IF DEGENERATE CASE 
          NZ     X3,IFTWO7         IF SPECIAL PROCESSING IS NECESSARY 
 IFL.1A   SA6    K1                SAVE THE TRUE BRANCH INDICATOR.
          BX7    X7-X7
          SA7    A6+B5           SET THE FALSE BRANCH INDICATOR (AND THE
          SA7    A7+B5             UNUSED INDICATOR) TO SPECIFY THE NEXT
                                   STATEMENT. 
          SPACE  1
          SA7    PARAMS+1        CLEAR OUT THE UNUSED 'IH' ENTRIES IN 
          SA7    A7+B5
          EQ     IF.3              GO OUTPUT BRANCHS
          SPACE  2
 IFL.2    SA1    N.GL 
          SX7    X1+B5             NGLN = NGLN + 1
          SX6    X1+I.GL           IH = GL(NLGN)
          SA7    A1 
          SA6    PARAMS+1        STORE THE 'IH' FOR THE FALSE BRANCH
          BX7    X7-X7             INTO THE 'PARAMS' BUFFER AND CLEAR 
          SA7    A6-B5             THE OTHER BRANCH 'IH' INFORMATION. 
          SA7    A6+B5
          SA6    DBGAPL+1        SAVE IN TEMPORARY BUFFER FOR 
          SA7    A6-B5             POSSIBLE LATER USE IF IN 
          SA7    A6+B5             DEBUG MODE 
          SA6    LIFTS1          (SAVE THE FALSE BRANCH 'IH') 
          SX6    B5+B5
          SA6    K2              SET THE FALSE BRANCH INDICATOR TO 2
          SA7    A6-B5             (SECOND BRANCH) AND THE OTHER BRANCH 
          SA7    A6+B5             INDICATORS TO 0 (NEXT STATEMENT).
          SA3    IFRELOP
          SX6    IFL.3             SET RETURN ADDR
          SA6    IFRETURN 
          ZR     X3,IF.3           IF NO SPECIAL PROCESSING 
          SB7    B5+B5             SET BRANCH ORDINAL 
          EQ     IFTWO6            AND GO SPECIAL CASE
          SPACE  2
IFL.3     SA1    TRCFLG 
          NG     X1,IFL.3A         BRANCH IF NO FLOW TRACING
          MX7    0
          SX6    =8RBUGTRT
          SA7    DBGAPL            FORM ARGLIST TABLE 
          SA6    A7+B5
          SA1    A7 
          RJ     IGCALL            OUTPUT MACRO 
          SA1    =8RBUGTRT
          SB7    *+1
          EQ     SYMBOL            WILL ALWAYS RETURN TO FOUND ADDRESS
          SX6    T.CGS             PLACE TYPE CGS IN SYMTAB WORD
          LX6    P.TYP               SO THE REFE RENCE WONT APPEAR
          BX7    X6+X2             IN THE REFERENCE MAP 
          SA7    A2 
IFL.3A    SA5    ARLPT
          BX4    X4-X4
          RJ     DARLIST
          SA1    LELIST 
          SA2    LTYPE
          BX6    X1 
          LX7    X2 
          SA6    SELIST 
          SA7    TYPE 
          SX2    X2-12
          MI     X2,IFL.ERR1     IF THE STATEMENT IS NOT EXECUTABLE THEN
                                   GO TO 'IFL.ERR1' TO FLAG THE ERROR.
          IX2    X2+X2
          SB1    X2 
          JP     IFSTMTGO+B1     JUMP TO THE CORRECT STATEMENT PROCESSOR
          EJECT 
**        IFSTMTGO - IF STATEMENT JUMP TABLE
*         THIS JUMP TABLE PROVIDES THE DIRECTION FOR PROCESSING THE 
*         STATEMENT PROTION OF A LOGICAL IF.  UNLESS THE STATEMENT
*         IS ILLEGAL A PROCESSING ROUTINE IS CALLED AND THEN THE
*         PROCESSING OF THE LOGICAL IF RESUMES AT 'IFL.4'.
  
 STMT     MACRO  ROUTINE,KIND 
          LOCAL  BEGIN
EMPTY     IFC    EQ,  KIND
           RJ     =X_ROUTINE
           ZR     IFL.4 
EMPTY     ELSE
ERROR      IFC    EQ, KIND ERROR
 BEGIN      EERR   ROUTINE
           BSS     2+BEGIN-*
ERROR     ELSE
           ZR      IFL.4
           BSS     1
          ENDIF 
 STMT     ENDM
          SPACE 1 
          SPACE  2
 IFSTMTGO STMT   ARITH             ARITHMETIC REPLACEMENT STATEMENT   12
          STMT   -E175,ERROR       END                                13
          STMT   ASSIGN            ASSIGN                             14
          STMT   GOTO              GO TO                              15
          STMT   IFE               ARITHMETIC IF                      16
          STMT   -E175,ERROR       LOGICAL IF                         17
          STMT   -E175,ERROR       BAD STATEMENT                      18
          STMT   CALL              CALL                               19
          STMT   RETURN            RETURN                             20
          STMT   CONT        CONTINUE 
          STMT   STOPP             STOP                               22
          STMT   PAUSEP            PAUSE                              23
          STMT   -E175,ERROR       DO                                 24
          STMT   READ              READ                               25
          STMT   WRITE             WRITE                              26
          STMT   BUFIN             BUFFER IN                          27
          STMT   BUFOUT            BUFFER OUT                         28
          STMT   ENC               ENCODE                             29
          STMT   DEC               DECODE                             30
          STMT   REW               REWIND                             31
          STMT   BKSP              BACKSPACE                          32
          STMT   ENDFILE           ENDIFLE                            33
          STMT   PRINT             PRINT                              34
          STMT   PUNCH             PUNCH                              35
  
 IFL.4    SA5    LIFTS1 
          CALL   WLABM       #GL NNN LABEL DEF MACRO TO RLIST 
          SX6    17D
          SA6    TYPE        RESTORE STATEMENT TYPE FOR DO PROCESSOR
          EQ     IFL
          END 
