Retro1.org codex

COMPILE 
* /---   FILE TYPE = E
* /---   BLOCK      COMPILE    00 000   79/11/13  23.15 
          IDENT  COMPILE
          TITLE  COMPILE     TUTOR CALC COMPILER
* 
          CST                COMMON SYMBOL TABLE
* 
          EXT    LEXADD      ADDRESS OF LEX HOOK
          EXT    KEYTYPE     LEXICAL KEY LOOKUP ARRAY 
* 
*         ERROR HANDLING ROUTINES 
* 
          EXT    CHARERR,BADPAR,VARERR
          EXT    FORMERR,EQERR,TEMPERR
          EXT    ALFERR,INDXERR,SEGERR
          EXT    VARTERR,OPTERR,ASIGERR 
          EXT    COMPERR,LNGERR,LITERR
          EXT    UNITERR,MATERR,CPXERR
          EXT    TSTERR,NOAERR,SIZERR 
          EXT    MNYAERR,MINDERR
          EXT    FIPERR 
* 
 SYMLST   SET    2
* 
********************************************************* 
* KNOWN BUGS--
*       (1)  CANNOT SUPERSCRIPT CAPITAL LETTERS USING 
*            THE NON-LOCKING SUPERSCRIPT.  LOCKING
*            SUPERSCRIPT DOES PERMIT CAPITAL LETTERS
*            IN THE EXPONENT. 
*         'RELATED PROBLEM IS THAT SUB-SUP-SUP IS NOT THE 
*         SAME AS SUP...
*         'WOULD BE NICE FOR KG. TO BE TAKEN AS KG'.
*       (2)  SEARCH FOR LITERAL ALREADY IN UNIT MAY FIND
*            BRANCH-TABLE ENTRY WHICH WILL BE MODIFIED
*            LATER....IN WHICH CASE -CALC- USES WRONG LIT.
*       (3)  CANNOT USE MATRIX(I,J) AS A FUNCTION ARGUMENT. 
*            ALSO CANNOT SAY ',V+10&3', IF V IS A VECTOR. 
*       (4)  B',C', NEEDS IMPLIED MULTIPLY. 
* 
* QUIKNUM (2A), CHARSET/RESTART TAGS (2D), COMMA SEPARATOR
* IN MATRICES (3F), AND FLOATING-POINT NUMBER INTERPRETING
* (15E,F,G,16B,C) ALL USE ',1R'X', WHERE THEY SHOULD BE 
* USING (PERHAPS'.) SOME OPCODE COMPARISONS.....
********************************************************* 
* /---   BLOCK      PLATO      00 000   81/07/27  21.52 
*         POINTERS TO EXEC ROUTINES - DEFINED HERE FOR PLATO
*         PASSED TO THE CONDENSOR THROUGH ECS 
* 
 IFPLT    PLATO 
* 
          EXT    ERXINDX     ERROR EXIT, -GETVAR- 
          EXT    ALEXLOC
          EXT    SEGMNTI,SEGMNTO,ALOOPS 
          EXT    VECEL,MATEL,VECO,MATO
          EXT    ASVARS,ACVARS,ARVARS,ALVARS,AWVARS 
 INSTLNG  EQU    INFOLTH-ARAYLTH-2    COMPILE INST BUFF LGTH (500-258)
* 
          ENTRY  LLAERR,LLSEGI,LLSEGO 
          ENTRY  LLVECEL,LLMATEL,LLVECO,LLMATO
          ENTRY  LLALOOP,RVARL,LVARN
* 
 LLEXLOC  EQU    ALEXLOC
 LLAERR   VFD    60/ERXINDX 
 LLSEGI   VFD    60/SEGMNTI 
 LLSEGO   VFD    60/SEGMNTO 
 LLVECEL  VFD    60/VECEL 
 LLMATEL  VFD    60/MATEL 
 LLVECO   VFD    60/VECO
 LLMATO   VFD    60/MATO
 LLALOOP  VFD    60/ALOOPS
 RVARL    VFD    60/RVARLIM 
 LVARN    VFD    60/0 
* 
          LIST   X
*CALL     LEXTXT
          LIST   *
* 
 IFPLT    ENDIF 
* /---   BLOCK      COMMENTS   00 000   78/12/21  18.18 
          TITLE  COMMENTS 
* 
*WRITTEN BY BRUCE SHERWOOD 1971 
*SEGMENTS BY DAVE ANDERSEN 1972 
*ARRAYS   BY DON SHIRER 1974
* 
*COMPILES 6400 MACHINE CODE FROM AN INPUT SOURCE LINE.
****RETURNS MACHINE CODE IN INFO ARRAY
****AND GETVAR CODE IN X1.
****B1 RETURNED 0 IF OK TO STORE INTO EXPRESSION. 
* 
*THESE ROUTINES USE A0-A4, A6-A7, X0-X7, B1-B3. 
* 
*THE GENERATED MACHINE CODE USES X0-X7, A1,A2,A6,A7.
*B1 IS USED FOR INLINE SHIFT OPERATIONS.
*OUT-OF-LINE FUNCTIONS (FILES -GETVAR- AND -TFUNCT-)
*USE MANY REGISTERS BUT SAVE AND RESTORE THE ABOVE
*REGISTERS, AS WELL AS B3, WHICH HOLDS THE RETURN 
*ADDRESS FROM THE CALC---JP B3 TERMINATES THE CALC. 
* 
* 
*THE COMPILATION PROCEDURE IS ESSENTIALLY AS DESCRIBED IN 
*CHAPTER 8 OF -THE ANATOMY OF A COMPILER-,
*BY JOHN A. N. LEE. 
***A MODIFICATION OF THIS SCHEME IS THAT
*EACH OPERATOR HAS TWO DIFFERENT
*PRECEDENCE LEVELS--ONE WHEN IN HAND
*AND ONE WHEN IN THE STACK.  THIS IS
*DUE TO A SUGGESTION OF LOUIS 
*STEINBERG, AND VASTLY SIMPLIFIES 
*UNARY MINUS AND MULTIPLE ASSIGNMENTS.
* 
* 
*COMPILE CALLS LEX FOR THE NEXT LEXICAL 
*ITEM IN A ONE-PASS COMPILATION.  LEX 
*RETURNS IN OP THE OPERATOR NUMBER
*OR AN OPERAND IN ADTYPE, AS A GETVAR 
*CODE.  THIS CODE CONSISTS OF A BIT 
*TO SPECIFY MODE (0 I, 1 F), A 3-BIT
*TYPE CODE -- 0 SHORT LITERAL, 1 LONG 
*LITERAL, 2 STUDENT BANK, 3 COMMON, 
*4 CALC -- , AND XCODEAL=14 BITS OF 
*ADDRESS. 
*TYPE 4 IS NEVER RETURNED 
*BY LEX BUT IS USED INTERNALLY BY 
*COMPILE TO FLAG A COMPUTED INDEXED 
*ADDRESS. 
*WITH TYPE 4 (CALC) THE ADDRESS+B5 IS THE BEGINNING 
*ADDRESS OF THE CALC IN -EXTRA STORAGE-.
*OPERANDS ALREADY IN REGISTERS APPEAR 
* 
* /---   BLOCK      COMMENTS   00 000   78/12/21  18.18 
*IN THE ADS LIST AS (SIGN BIT, I/F BIT
*IN USUAL POSITION, REGISTER NUMBER IN
*BOTTOM OF WORD).  IF OPERAND CODE IS 
*NEGATIVE, OPERAND IS IN REGISTER.
* 
* LITERALS ARE SAVED IN *LITS* BY *LEX* IF IMMEDIATE (IE';
* '74.5'7 IN '7N1_4.5'7) AND THE 22ND BIT OF THEIR ADTYPES
* ARE SET TO DISTINGUISH THEM FROM LITERALS WHOSE ADTYPES 
* POINT INTO *TOKBUF*.  AT CODE GENERATION TIME, LITERALS 
* ARE RETRIEVED FROM EITHER *LITS* OR *TOKBUF* AND ARE
* PLANTED IN THE *INFO* BUFFER BY *LSEEK* WHICH ELIMINATES
* DUPLICATE LITERALS TO SAVE ON UNIT BINARY SPACE.  LITERALS
* ARE STORED EITHER AS I OR F, WHICH EVER IS MORE EFFICIENT.
* FOR EXAMPLE, 3.00 AND 3 ARE TREATED IDENTICALLY.
* 
* 
*VARIABLE NAMES MUST NOT START WITH A NUMBER. 
*EXPRESSIONS SUCH AS 45.3ALFA OR 34(-X)(3+X) ARE LEGAL. 
*THE ONLY PLACE WHERE AN EXPLICIT MULTIPLICATION SIGN 
*IS REQUIRED IS IN 3X*Y, WHERE X AND Y ARE DEFINED
*VARIABLES.  HOWEVER, IN STUDENT MODE (STORE, ANSV) EVEN
*THIS IS ALLOWED--- 3XY IS TAKEN AS 3*X*Y IF THERE IS NO
*VARIABLE XY .  ALSO, ALTHO AUTHORS MUST USE PARENS 
*AROUND FUNCTION ARGUMENTS -- SIN(3X) --, STUDENTS CAN
*WRITE -- SIN3X -- .  STUDENTS MAY REFER TO DEFINED 
*VARIABLES, BUT V(INDEX) IS TAKEN TO MEAN V*(INDEX).
* 
*OTHER SPECIAL FEATURES INCLUDE --- 
*MULTIPLE ASSIGNMENT -  X_3+Y_7+(Z_12)-W_34 . 
*RELATIONAL OPERATORS - <,>,=,^<,^>,^= FOR
*               $LT$,$GT$,$EQ$,$LE$,$GE$,$NE$ 
*TRUTH VALUE = -1 , FALSE VALUE = 0.
*COMBINE RELATIONS WITH $AND$ AND $OR$ WHICH GIVE -1 OR 0.
*PARENTHESES - ^[ AND [ EQUIVALENT TO ( 
*              ^] AND ] EQUIVALENT TO ) 
*^P IS PI, ^O IS PI/180 -- SIN(45^O) IS SIN(.785) . 
*MIXED MODE OK, WITH N1_V2_34.7 LEAVING V2=34.7, N1=35. 
*     NOTE ROUNDING WHEN SETTING AN INTEGER VARIABLE. 
*BIT OPERATIONS - $UNION$,$MASK$,$DIFF$,$ARS$,$CLS$ . 
*  (ARS IS ARITHMETIC RIGHT SHIFT, CLS IS CIR. LEFT SHIFT)
*SUPERSCRIPTS (LOCKING AND NON-LOCKING) INDICATE
*     EXPONENTIATION.  FOR INTEGER LITERAL EXPONENTS
*     BETWEEN -63 AND +63 THE MULTIPLIES ARE CODED
*     IN LINE RATHER THAN AS CALL TO EXPONENTIATION ROUTINE.
* 
* 
* 
* /---   BLOCK      COMMENTS   00 000   78/06/20  22.15 
* 
* ARRAYS ARE HANDLED AS FOLLOWS...
* 
* ARRAYS AND ARRAY ELEMENTS BOTH HAVE GETVAR CODE=6 
* 
* AN ARAYWORD IS STUCK IN EXTRA STORAGE DESCRIBING TYPE 
* AND SIZE OF EACH ARRAY USED IN A UNIT 
* THERE ARE 2 OF THESE WORDS IF ARRAY IS SEGMENTED OR 
* BASE IS REDEFINED 
* DESCRIPTIONS OF THESE ARRAY INFO WORDS ARE IN DEFINE, 
* BLOCK *ARRAY* 
* 
* ARRAY ELEMENTS ARE CONVERTED TO REGULAR SCALARS IN
* CONDENSOR IF HAVE LITERAL ARGUMENTS, IF NOT, COMPILATION
* IS FORCED TO EVALUATE INDICES THRU SUBROUTINES
* (VECEL, MATEL) AT EXECUTION TIME. 
*   'IN THIS CASE, CODE IS GENERATED TO SET B1 TO POINT TO
*   THE ARRAY DESCRIPTOR WORD (B5+N), X3 TO THE ROW, AND
*   X4 TO THE COLUMN. 
* 
* WHOLE ARRAYS ARE MARKED WHEN ENCOUNTERED BY SETTING 
* BIT 58 IN OPERAND ADTYPE
* 
* IF ANY WHOLE ARRAY IS ENCOUNTERED IN INITIAL LEXICAL
* PASS, SEARCH FOR ARRAY OPERATIONS IS TURNED ON
* 
* ELEMENT-BY-ELEMENT ARRAY OPERATIONS, INCLUDING MOST 
* BINARY OPERATIONS AND ASSIGNMENT USE STANDARD SCALAR
* CODE GENERATORS, BUT CODE IS PREFACED BY CALL TO -AINIT-
* AND FOLLOWED BY CALL TO -ALOOPS-...THESE EXECUTION
* ROUTINES DO THE INDEX LOOPING AND EXITS 
* 
* ALL WHOLE ARRAY OPERATION RESULTS ARE PUT INTO TEMPORARY
* STORAGE AT TOP OF *WORK* BEFORE ASSIGNMENT OPERATION
* IS CALLED, SO YOU CAN DO THINGS LIKE CALC V_V*V.
* 
* ASSIGNMENTS REQUIRING NO I/F CONVERSION COULD BE SPEEDED
* UP IN FUTURE BY USING ECS TRANSFER OPERATIONS 
* 
* ARRAYS ARE CHECKED FOR TYPE AND CONFORMALITY WHEN 
* OPERATION IS ENCOUNTERED,  ARRAY ELEMENTS ARE CHECKED 
* FOR IN-BOUNDS WHEN EVALUATED
* 
* MANY NON-STANDARD EXTENSIONS OF MATRIX OPERATIONS ARE 
* INCLUDED TO MAKE THESE USEFUL TO WIDER AUDIENCE 
* 
* THE DEFINE STRUCTURE INCLUDES PROVISIONS FOR FUTURE 
* COMPLEX, SEGMENTED, OR 3-DIMENSIONAL ARRAYS, BUT
* MACHINERY HAS NOT YET BEEN INCLUDED FOR THESE IN EITHER 
* THE CONDENSOR OR THE EXECUTOR 
* THEY NOW GIVE CONDENSE ERROR MESSAGES 
* 
* MORE ON ARRAY USAGE AND FUTURE PLANS IN LESSON -ARRAY-
* 
* 
* /---   BLOCK      COMPCOM    00 000   79/12/04  07.03 
          PLATO 
          TITLE  COMPCOM -- ENTRY POINT FOR -COMPUTE- 
 PUTCOMP  BSS    1           TO SATISFY REFERENCES
 COMPNAM  BSS    1           TO SATISFY REFERENCES
* 
          ENTRY  COMPCOM
 COMPCOM  EQ     *           SPECIAL ENTRY POINT FOR COMPUTE COMMAND
          SA1    COMPCOM
          BX6    X1 
          MX7    0
          SA6    COMPILE
          SX6    1           FLAG THAT CODE MUST BE GENERATED 
          SA6    COMPALL     EVEN FOR SIMPLE VARIABLE REF.
          SA7    COMPNAM
          SA7    CSYMADD     NO -COMPSYM- SYMBOL TABLE
          SA7    PUTCOMP     NOT A -PUTCOMP- CALL 
          MX7    1
          LX7    -OKASIGN    SET OKASSIGN BIT 
          SA7    COMSPEC     THIS CELL USED TO CHECK SPECS
          SX7    -2          NO UNIT DIMENSION STUFF
          SA7    NUNITS 
          EQ     CMPCOM2
* 
* QCMPCOM IS THE ENTRY POINT FOR THE 3-ARG -COMPUTE-
* 
          ENTRY  QCMPCOM
 QCMPCOM  EQ     *
          SA1    QCMPCOM
          MX7    1
          LX7    -OKASIGN    SET OKASSIGN BIT 
          SA7    COMSPEC     CELL CHECKED FOR SPECS VALUES
          BX6    X1 
          SA6    QUIKCMP     PLANT EQ FOR RETURN
          SX6    -2 
          SA6    NUNITS      NO UNIT DIMENSIONS ALLOWED 
          EQ     QUIK2       JUMP INTO QUIKCMP
* 
          ENDIF 
* 
* /---   BLOCK      CONTCOM    00 000   78/01/25  15.08 
          CONDEN
          TITLE  CONTCOM -- ENTRY POINT FOR CONTINUED CALCS 
*         CONTCOM IS THE ENTRY POINT FOR CONTINUED CALC 
* 
          ENTRY  CONTCOM
 CONTCOM  EQ     *
          SA1    CONTCOM     LOAD UP RJ WORD
          BX6    X1 
          SA6    COMPILE     TRANSFER IT
          SX6    1           FLAG THAT THIS IS A CALC COMMAND 
          SA6    CALC 
          MX7    0
          SA7    COMPNAM
          SA7    PUTCOMP     NOT A -PUTCOMP- CALL 
          SA7    CSYMADD     NO -COMPSYM- SYMBOL TABLE
          EQ     COMPIL2
* 
          TITLE  COMPNAM -- ALLOW UNDEFINED SYMBOLS 
* 
*         -COMPNAM- IS A SPECIAL ENTRY POINT USED BY
*         COMMANDS SUCH AS -MICRO- AND -CHARSET- WHERE
*         THE AUTHOR MAY WISH TO ENTER AN UNDEFINED NAME
*         AS THE ARGUMENT 
* 
          ENTRY  COMPNAM
 COMPNAM  BSSZ   1
          SA1    COMPNAM     SAVE RJ ADDRESS
          BX6    X1 
          SA6    COMPILE
          EQ     CMPLX
* 
          TITLE  COMPSYM -- ALLOW SPECIAL DEFINED SYMBOLS 
* 
*         -COMPSYM- IS A SPECIAL ENTRY USED BY COMMANDS 
*         THAT WISH TO ALLOW SPECIAL SYMBOLS ...SUCH AS 
*         -SLIDE  NOSLIDE-
* 
* 
          ENTRY  COMPSYM
 COMPSYM  EQ     *
          SA1    COMPSYM     PLANT RETURN ADDRESS 
          BX6    X1 
          SX7    B1          ADDRESS OF SYMBOL TABLE
          SA6    COMPILE
          SA7    CSYMADD
          SX6    B2          NUMBER OF SYMBOL(S)
          SA6    CSYMNUM
          MX7    0
          SA7    COMPNAM
          SA7    COMPALL     SET NO COMPILE OF SIMPLE VAR OR LIT
          SA7    PUTCOMP     NOT A -PUTCOMP- CALL 
          EQ     CMPCOM2
* 
* /---   BLOCK      PUTCOMP    00 000   78/01/25  15.14 
          TITLE  PUTCOMP -- GENERATE CODE TO STORE VALUE
* 
*         -PUTCOMP-          SPECIAL ENTRY TO GENERATE CODE 
*         TO STORE THE QUANTITY IN X6 
* 
          ENTRY  PUTCOMP
 PUTCOMP  EQ     *
          SA1    PUTCOMP     FIX UP ENTRY POINT 
          BX6    X1 
          MX7    1
          SA6    COMPILE
          SA7    RSULTX1     DONT NEED RESULT IN X1 
          MX7    0
          SA7    CALC        NOT A CALC 
          SA7    COMPALL
          SA7    COMPNAM
          SA7    CSYMADD     NO -COMPSYM- SYMBOL TABLE
          EQ     CMPCOM3
* 
          TITLE  PCOMP1 -- FORCE COMPILED CODE FOR PUTCOMP
* 
*         SAME AS -PUTCOMP- EXCEPT THAT COMPILED CODE IS
*         PRODUCED EVEN FOR SIMPLE VARIABLE REFERENCES
* 
          ENTRY  PCOMP1 
 PCOMP1   EQ     *
          SA1    PCOMP1      FIX UP ENTRY POINT 
          BX6    X1 
          MX7    1
          SA6    COMPILE
          SA6    PUTCOMP     MARK AS -PUTCOMP- CALL 
          SA7    RSULTX1     DONT NEED RESULT IN X1 
          SA7    COMPALL     MUST ALWAYS COMPILE CODE 
          SA7    CMOVFLG     DONT MOVE CODE TO EXTRA STORAGE
          MX7    0
          SA7    CALC        NOT A CALC 
          SA7    COMPNAM
          SA7    CSYMADD     NO -COMPSYM- SYMBOL TABLE
          EQ     COMPIL2
* 
          TITLE  GCOMP -- ENTRY POINT FOR -GOTO- AND -DO- 
* 
*         SPECIAL DRIVER FOR -COMPILE- USED BY GOTO AND DO
* 
* 
          ENTRY  GCOMP
 GCOMP    EQ     *
          SA1    GCOMP
          BX6    X1          PLANT RETURN ADDRESS 
          SA6    COMPILE
          RJ     GCOMP0 
          EQ     CMPCOM4     DECODE EXPRESSION
* 
* 
          ENTRY  GCOMP1 
 GCOMP1   EQ     *
          SA1    GCOMP1      SET UP EXIT ADDRESS
          BX6    X1 
          SA6    COMPILE
          RJ     GCOMP0 
          EQ     COMPIL2     LEAVE *NINST* ALONE
* 
* 
 GCOMP0   EQ     *
          SX6    1           ALWAYS COMPILED CODE 
          SA6    COMPALL
          SA6    CMOVFLG     DONT MOVE CODE TO EXTRA STORAGE
          MX7    0
          SA7    COMPNAM     NOT A -COMPNAM- CALL 
          SA7    CSYMADD     NO -COMPSYM- SYMBOL TABLE
          SA7    PUTCOMP
          SA7    RSULTX1     LEAVE RESULT IN X1 
          SA7    CALC        NOT A -CALC- COMMAND 
          EQ     GCOMP0 
* 
          ENDIF 
* /---   BLOCK      QUIKCMP    00 000   79/12/05  01.16 
          TITLE  QUIKCMP -- ENTRY POINT FOR LIKELY LITERALS 
* 
* 
*         -QUIKCMP- 
*         SPECIAL ENTRY FOR CASES WHERE THE INPUT IS LIKELY 
*         TO BE A LITERAL 
* 
* 
          ENTRY  QUIKCMP
 QUIKCMP  EQ     *
          PLATO 
          SA1    TSPECS      PULL IN -SPECS- BITS 
          BX6    X1 
          SA6    COMSPEC     COPY TO CELL CHECKED BY COMPILE
          ENDIF 
 QUIK2    SA1    WORDPT      POINTER TO FIRST CHARACTER 
          SA1    X1 
          SA2    X1+KEYTYPE 
          ZR     X2,QUIKNUM  JUMP IF FIRST CHARACTER NUMERIC
* 
          PLATO 
 QCOMP    SA1    QUIKCMP
          BX6    X1 
          SA6    COMPILE     PLANT RETURN 
          EQ     CMPCOM1     ENTER COMPILE AFTER COMSPEC SET
          ENDIF 
          CONDEN
 QCOMP    RJ     COMPILE     DO NORMAL COMPILE CALL 
          EQ     QUIKCMP     AND RETURN 
          ENDIF 
* /---   BLOCK      QUIKCMP    00 000   78/12/18  21.00 
* 
*         PROCESS NUMERIC CONSTANT
* 
 QUIKNUM  SX0    X1-1R.      CHECK FOR DECIMAL POINT
          ZR     X0,QCOMP 
          SX6    X1-1R0      SAVE FIRST NUMBER
          MX7    12          MASK FOR 48 BIT CHECK
          SB2    3
* 
 QNLP     SA1    A1+1        LOAD NEXT CHARACTER
          SA2    X1+KEYTYPE 
          NZ     X2,QUIKN10  JUMP IF NOT NUMERIC
          SX0    X1-1R. 
          ZR     X0,QCOMP    EXIT IF DECIMAL POINT
          LX4    X6,B2       MULTIPLY BY 8
          LX6    1           MULTIPLY BY 2
          IX6    X4+X6       MULTIPLY BY 10 
          SX1    X1-1R0      CONVERT CHARACTER TO NUMERIC 
          IX6    X1+X6
          BX1    X7*X6       SEE IF OVER 48 BITS LONG 
          ZR     X1,QNLP
          EQ     QCOMP       EXIT IF OVER 48 BITS 
* 
 QUIKN10  BX7    X1          SAVE LAST CHARACTER
          SA7    LASTKEY
          ZR     X1,QUIKN20  JUMP IF END-OF-LINE
          SX0    X2-OPCOMMA 
          NZ     X0,QCOMP    EXIT IF NOT COMMA
          SX7    A1+1 
          SA7    WORDPT      UPDATE *WORDPT*
          EQ     QUIKN25
* 
 QUIKN20  SX7    A1          POINTER TO LAST CHARACTER
          SA7    WORDPT      UPDATE *WORDPT*
* 
 QUIKN25  SB1    1           MARK NOT STOREABLE 
          MX0    -XCODEAL    CHECK FOR 14 BIT LITERAL 
          BX1    X0*X6
          NZ     X1,QUIKN30  JUMP IF LONG LITERAL 
          BX1    -X0*X6      SET UP -GETVAR- CODE 
          EQ     QUIKN90
* 
 QUIKN30  SA1    INX         GET XSTOR POINTER
          SA6    X1+INFO     STORE LONG LITERAL 
          SX6    X1+1 
          SA6    A1          UPDATE *INX* 
          SX6    1           1 = GETVAR TYPE FOR LONG LIT 
          LX6    XCODEAL
          BX1    X1+X6       LONG INTEGER LITERAL 
* 
 QUIKN90  MX6    0
          SA6    TOPCNT      CLEAR *OPCNT*
          SA6    TVARCNT     CLEAR *VARCNT* 
          SA2    NUNITS      CHECK FOR UNIT DIMENSIONS WANTED 
          SX2    X2+1 
          NG     X2,QUIKCMP  JUMP IF NO UNIT DIM WANTED 
          ZERO   UADS,NUMAX      MUST CLEAR *UADS*
          EQ     QUIKCMP     RETURN 
* /---   BLOCK      COMPILU    00 000   78/01/25  15.39 
          CONDEN
          TITLE  COMPILU -- ENTRY POINT FOR -ANSU- ARGUMENT 
          ENTRY  COMPILU
* 
* ENTRY POINT FOR CONDENSING FIRST ARG OF -ANSU- COMMAND
* 
 COMPILU  EQ     *
          SA1    COMPILU
          BX6    X1 
          MX7    0
          SA6    COMPILE
          SA7    COMPNAM
          SA7    COMPALL     SET NO COMPILE OF SIMPLE VAR OR LIT
          SA7    CSYMADD     NO -COMPSYM- SYMBOL TABLE
          SA7    PUTCOMP     NOT A -PUTCOMP- CALL 
          SA7    RSULTX1     SET TO LEAVE RESULT IN X1
          SA7    CALC        FLAG THAT THIS IS NOT A CALC COMMAND 
          SA7    CMOVFLG     SET TO MOVE CODE TO XTRA STOR AT END OF LIN
          SX6    INST 
          SA6    NINST       INSTRUCTION STREAM POINTER 
          SA7    X6          CLEAR FIRST INSTRUCTION WORD 
          SX7    X6+INSTLNG 
          SA7    NINSTLIM    LIMIT ON ADVANCE OF NINST
          SX7    -1          ALLOW UNITS
          SA7    NUNITS 
          EQ     COMPIL2B 
          ENDIF 
* /---   BLOCK      COMPILE    00 000   79/12/05  01.15 
          TITLE  COMPILE -- MAIN ENTRY POINT TO COMPILER
* 
*         -COMPILE- 
* 
*         PARSES EXPRESSION AT CURRENT POSITION IN THE
*         INPUT LINE AND RETURNS A GETVAR CODE FOR THE
*         RESULTING COMPILED CODE.
* 
* 
          ENTRY  COMPILE
 COMPILE  EQ     *
          PLATO 
          SA1    TSPECS      PICK UP -SPECS- BITS 
          BX7    X1 
          SA7    COMSPEC     AND PUT THEM HERE
          ENDIF 
 CMPCOM1  MX7    0
          SA7    COMPNAM
 CMPLX    MX7    0
          SA7    COMPALL     SET NO COMPILE OF SIMPLE VAR OR LIT
          SA7    CSYMADD     NO -COMPSYM- SYMBOL TABLE
          SA7    PUTCOMP     NOT A -PUTCOMP- CALL 
 CMPCOM2  MX7    0
          SA7    RSULTX1     SET TO LEAVE RESULT IN X1
          SA7    CALC        FLAG THAT THIS IS NOT A CALC COMMAND 
* 
 CMPCOM3  SA7    CMOVFLG     SET TO MOVE CODE TO XTRA STOR AT END OF LIN
* 
          CONDEN
 CMPCOM4  SX6    INST 
          ENDIF 
          PLATO 
 CMPCOM4  SX6    INFO+INFOX  COMPILE CODE INTO INFO BUFFER
*                (OFFSET INFOX TO LEAVE ROOM FOR LITERALS)
          ENDIF 
* 
          SA6    NINST       INSTRUCTION STREAM POINTER 
          MX7    0
          SA7    X6          CLEAR FIRST INSTRUCTION WORD 
          SX7    X6+INSTLNG 
          SA7    NINSTLIM    LIMIT ON ADVANCE OF NINST
          CONDEN
 COMPIL2  SX7    -2          SUPPRESS UNIT DIMENSION STUFF
          SA7    NUNITS      -1 TO USE COMPILE DIMENSIONS, -2 SUPPRESSES
          ENDIF 
 COMPIL2B BSS    0
*         USEFUL FOR DEBUGGING
* DMADBUG  CONDEN 
*          SA1    AZERBUF 
*          BX0    X1
*          SA0    SHARE 
*+         RE     ADSMAX      ZERO OUT ADS BUFFER 
*          RJ     ECSPRTY 
* DMADBUG  ENDIF
* /---   BLOCK      COMPILE    00 000   78/06/06  21.50 
          MX7    0           CLEAR COMPILE VARIABLES
          SA7    TVARCNT     COUNT NUMBER OF VARIABLE REFERENCES
          SA7    VSKMODE     SET -VSEEK- MODE 
          SA7    INHAND 
          SA7    PREVOPL
          SA7    ADS
          SA7    OPSL 
          SA7    RX          CLEAR REGISTER RESERVATIONS
          SA7    RX+1 
          SA7    RX+2 
          SA7    RX+3 
          SA7    RX+4 
          SA7    RX+5 
          SA7    RX+6 
          SA7    RX+7 
          SA7    NADS 
          SA7    TEMP        FLAG NO TEMPORARY STORAGE USED YET 
          SA7    NARGS       NO MULTIPLE ARGUMENTS EXPECTED 
          SA7    NARRAYS     PERMIT WHOLE ARRAY OPERATIONS
          SA7    TMPAFLG     CLEAR TEMP ARRAY INFO WORD 
          SA7    TMPASIZ     NO TEMP ARRAY WORDS USED 
          SA7    BUFCHK      NO ECS ARRAY BUFFER CHECK YET
          SA7    OPSL+1      BOL PRECEDENCE IS ZERO 
          SX7    -1 
          SA7    TOPCNT     INITIALIZE COUNT OF NUMBER OF OPERATORS 
          SA7    NUADS       FLAG NO UNIT OPERANDS
          SX7    1
          SA1    PUTCOMP     SEE IF -PUTCOMP- CALL
          ZR     X1,COMPILA 
          SA7    RX+6        RESERVE X6 
          MX1    1
          SX6    6           MARK QUANTITY TO STORE IN X6 
          BX6    X1+X6
          SA6    ADS
 COMPILA  SA7    NOPS 
          SA7    OPS+1
          SA7    LASTOP 
          CALL   INITDEF     GO INITIALIZE FOR -DEFINE- 
          CALL   INITLEX     INITIALIZE -LEX- PARAMETERS
          PLATO 
          SA1    NCOMPIL
          BX7    X1 
          SA7    COMPIL      BE SURE LOCATION COMPIL CONTAINS RJ LEX
          ENDIF 
* 
* /---   BLOCK      COMPNAM    00 000   75/08/20  02.01 
          TITLE  COMPNAM
* 
* 
*         DO PROCESSING FOR *COMPNAM* CALLS 
* 
          SA1    COMPNAM
          ZR     X1,COMPIL   JUMP IF NOT A -COMPNAM- CALL 
* 
*         DECIDE IF ALPHA STRING OR EXPRESSION
* 
          SA1    WORDPT      GET POINTER TO FIRST CHARACTER 
* 
 CMPN100  SA2    X1          LOAD NEXT CHARACTER
          SX0    X2-1R       STRIP OFF LEADING SPACES 
          NZ     X0,CMPN110 
          SX1    X1+1        ADVANCE CHARACTER POINTER
          EQ     CMPN100
* 
 CMPN110  SX0    X2-1R( 
          ZR     X0,COMPIL   EXPRESSION IF LEFT PAREN 
          SX0    X2-KLBRACK 
          ZR     X0,COMPIL   EXPRESSION IF LEFT BRACKET 
          SX0    X2-KUP 
          NZ     X0,CMPN120  ALPHA STRING IF NOT SHIFT CODE 
          SA2    A2+1        LOAD NEXT CHARACTER
          SX0    X2-1R, 
          ZR     X0,COMPIL   EXPRESSION IF DOUBLE QUOTE 
          SX0    X2-1R7 
          ZR     X0,COMPIL   EXPRESSION IF SINGLE QUOTE 
* 
*         COLLECT CHARACTERS OF ALPHA LITERAL 
* 
 CMPN120  SB1    60          INITIALIZE SHIFT 
          MX6    0           INITIALIZE WORD BUILDING 
          SA1    X1-1        INITIALIZE READ REGISTER 
* 
 CMPN130  SA1    A1+1        LOAD NEXT CHARACTER
          ZR     X1,CMPN140  CHECK IF END-OF-LINE 
          SA2    X1+KEYTYPE 
          SX0    X2-OPCOMMA  CHECK IF COMMA 
          ZR     X0,CMPN142 
          SB1    B1-6        DECREMENT SHIFT COUNT
          NG     B1,ALFERR
          LX1    X1,B1       POSITION NEXT CHARACTER
          BX6    X1+X6       MERGE WITH WORD BUILDING 
          EQ     CMPN130
* 
* /---   BLOCK      COMPNAM    00 000   78/12/18  21.01 
* 
 CMPN140  SX7    A1          UPDATE *WORDPT* FOR END-OF-LINE
          SA7    WORDPT 
          EQ     CMPN145
* 
 CMPN142  SX7    A1+1        UPDATE *WORDPT* FOR COMMA
          SA7    WORDPT 
* 
 CMPN145  ZR     X6,ALFERR   ERROR IF NO CHARACTERS 
          BX7    X1 
          SA7    LASTKEY     SET LAST CHARACTER 
          ZR     B1,CMPN160  JUMP IF FULL WORD
          SA1    IFILL
          ZR     X1,CMPN160  JUMP IF ZERO FILL
* 
 CMPN150  SB1    B1-6        COMPUTE SHIFT COUNT
          NG     B1,CMPN160 
          BX0    X1          GET FILL CHARACTER 
          LX0    X0,B1
          BX6    X0+X6       ADD TO WORD BUILDING 
          EQ     CMPN150
* 
*         SET UP -GETVAR- CODE AND RETURN INFO
* 
 CMPN160  SA1    INX         GET XSTOR POINTER
          SA6    X1+INFO     STORE LONG LITERAL 
          SX6    X1+1 
          SA6    A1          UPDATE *INX* 
          SX6    1           1 = GETVAR TYPE FOR LONG LIT 
          LX6    XCODEAL
          BX1    X1+X6       X1 = -GETVAR- CODE  (LONG LIT) 
          MX6    0
          SA6    TOPCNT      CLEAR *OPCNT*
          SA6    TVARCNT     CLEAR *VARCNT* 
          SB1    1           MARK NOT STOREABLE 
          SA2    NUNITS      CHECK UNIT DIMENSIONS NEEDED 
          SX2    X2+1 
          NG     X2,COMPNAM  EXIT IF NO UNITS NEEDED
          ZERO   UADS,NUMAX      MUST CLEAR *UADS*
          EQ     COMPNAM     EXIT 
* /---   BLOCK      COMPIL     00 000   78/06/06  21.38 
          TITLE  COMPIL -- MAIN LOOP FOR COMPILER 
* 
          PLATO 
*WHEN COLLECTING ARGUMENT FOR PARENS-LESS FUNCTION, 
*LOCATION COMPIL CONTAINS EQ SPECIAL. 
          ENDIF 
* 
* THERE IS A LOOK-AHEAD INSIDE -LEX- WHEN A MINUS IS
* ENCOUNTERED DURING EXECUTION, TO SEE WHETHER THE
* NEXT LEXICAL ITEM IS A UNIT SUCH AS METER, IN WHICH CASE
* OP IS RETURNED AS A MULTIPLICATION.  -COMPILE- MUST NOT 
* CHANGE -AD- OR -ADTYPE-, WHICH CONTAIN THE INFO ON THE
* LOOK-AHEAD ITEM, AND IT MUST USE -OP- AS THE TEST 
* FOR WHETHER THE ITEM IN HAND IS AN OP OR AN AD. 
* 
 COMPIL   CALL   LEX         GET NEXT LEXICAL ITEM
 COMPIL1  SA1    OP 
          ZR     X1,AD1      JUMP IF ADDRESS, NOT OP
 COMPILB  NG     X1,OP0      BYPASS SPL TEST IF OP IS NEG 
          SX2    X1-OPMULT   TEST FOR SPECIAL CASE OP 
          PL     X2,OP0      JUMP IF NOT
          SB1    X1 
          JP     B1+OPJMP    GO TO SPECIAL CASE ROUTINE 
 OPJMP    EQ     OP0         JUST IN CASE X1=0 ACCIDENTLY 
+         EQ     ISEOL       END OF LINE OP 
+         EQ     PLUS        CHECK FOR UNARY +
+         EQ     MINUS       CHECK FOR UNARY -
+         EQ     ISEOL       COMMA AS END-OF-LINE 
+         EQ     ISPIAD      CHECK IF PI IS OP OR AD
+         EQ     ISDEGR      DEGREE SIGN OPERATOR 
+         EQ     ISSEG       SEGMENT OP 
+         EQ     ISARRAY     MATRIX OP
+         EQ     ISARRAY     VECTOR OP
+         EQ     ISARRAY     SCALAR OP
 OP0      BX7    X1 
          SA7    LASTOP      SAVE FOR LATER UNARY- CHECK
 OP1      SA2    TOPCNT     COUNT OPERATORS ENCOUNTERED 
          SX7    X2+1        OPTOTAL COUNT USEFUL IN FORMULA JUDGING
          SA7    TOPCNT 
          SA3    PREVOPL     PREVIOUS OP LEVEL
          PLATO 
          NG     X1,NEEDPAR  JUMP IF FUNCTION NEEDS PARENS
          ENDIF 
          SA2    X1+PRECED   GET PRECEDENCE 
 OP2      SB1    X2          GET INHAND PRECEDENCE
          SB2    X3          PRECEDENCE OF TOP OF STACK 
          LT     B1,B2,FORCE FORCE COMPILE IF PRECEDENCE RIGHT
          MX7    30 
          BX7    -X7*X2      GET 2 PRECEDENCE LEVELS
          AX7    18          GET STACK PRECEDENCE 
          SA7    PREVOPL     UPDATE PREVIOUS PRECEDENCE LEVEL 
          SA2    NOPS 
          SX2    X2+1 
          SX0    X2-OPSMAX   SEE IF TOO MANY OPS
          PL     X0,LNGERR
          SA7    X2+OPSL     ADD OP LEVEL TO LIST 
          BX7    X1 
          SA7    X2+OPS      ADD OP TO LIST 
          BX7    X2 
          SA7    NOPS        UPDATE OP POINTER
          SX7    X1-OPASIGN  CHECK FOR ASSIGNMENT TO INDEXED VARIABLE 
          NZ     X7,COMPIL   JUMP IF NOT ASSIGNMENT 
* /---   BLOCK      COMPIL     00 000   79/12/04  00.30 
* 
* CHECK FOR SPECS OKASSIGN DURING EXECUTION.
* 
          PLATO 
          SA2    COMSPEC     GET SPECS BITS 
          LX2    OKASIGN     OKASSIGN BIT IN SIGN BIT 
          PL     X2,ASIGERR  JUMP IF NOT ALLOWED
          ENDIF 
* 
          SA2    NADS        CHECK FOR LAST AD BEING INDEXED
          ZR     X2,EQERR    JUMP IF NO ADDRESS TO STORE INTO 
          SA2    X2+ADS 
          BX7    X2          NOW EXAMINE AD 
          AX7    XCODEAL     POSTION TYPE CODE
          MX1    -3 
          BX7    -X1*X7      MASK OFF 3 BIT CODE
          SX7    X7-4        CHECK FOR INDEXED VARIABLE 
          NZ     X7,COMPIL   EXIT IF NOT
* 
*MOVE ABSOLUTE ADDRESS IN A1 TO AVAILABLE X-REGISTER
*TO USE LATER WHEN ASSIGNMENT OP IS PROCESSED.
* 
* 'I BELIEVE THAT THIS ROUTINE SHOULD USE -CHOOSEX- 
* INSTEAD OF THIS JUNK.  'HAVEN'7T GOTTEN INTO WHY IT 
* DOESN'7T YET. (THEY MIGHT TRY REGISTER X7 TOO)  M.MIDDEN
* 
* 'REASON IS THIS';  THE INDEX OF THE INDEXED VARIABLE IS 
* EVALUATED EARLY IN THE EXPRESSION (TO THE LEFT OF THE 
* ASSIGNMENT ARROW), AND WE WANT TO USE TYPICAL DESTINATION 
* REGISTERS IN THE EVALUATION OF THE RIGHT-HAND SIDE, 
* ENDING FINALLY WITH USING THE SAVED ADDRESS.   B. SHERWOOD
          SA1    RX+3        USE X3 IF AVAILABLE
          ZR     X1,PICKED   (RX+3) = 0 IF X3 NOT IN USE
          SA1    RX+4        IF X3 NOT AVAILABLE, TRY X4
          ZR     X1,PICKED
          SA1    RX+5        THEN TRY X5
          ZR     X1,PICKED
          SA1    RX+0        KEEP LOOKING 
          ZR     X1,PICKED
          EQ     MINDERR     CANT COMPILE IF NO REGISTER
 PICKED   SB1    A1-RX       CALC CHOSEN REGISTER NUMBER
          SX7    1
          SA7    A1          MARK IT TO BE IN USE 
          MX7    57 
          BX7    X7*X2       DISCARD ORIGINAL REGISTER NUMBER (X1)
          SX1    B1 
          BX7    X1+X7       MERGE NEW REGISTER NUMBER
          SA7    A2          WRITE BACK NEW AD ENTRY
          SX7    74010B      SXN  A1+B0 
          LX1    6           BUILD SXN  A1
          BX7    X7+X1
          RJ     SHORT
          SB1    1
          RJ     FREEX       FREE X1
          EQ     COMPIL 
* /---   BLOCK      NEEDPAR    00 000   78/06/06  21.40 
          PLATO 
          TITLE  NEED PARENTHESES 
* 
 NEEDPAR  SA2    JPSPEC      EQ SPECIAL INSTRUCTION 
          BX7    X2 
          BX1    -X1         MAKE OP CODE POSITIVE
          SA7    COMPIL      PLANT IN PLACE OF RJ LEX 
          SA2    NEEDPRL     GET PRECEDENCE LEVEL PARENLESS FUNCTION
          MX7    0
          SA7    PRELEX      PRELEX=0 MEANS NO LOOK-AHEAD LEX CALL YET
          BX7    X1          SAVE OPCODE IN LASTOP
          SA7    LASTOP 
          EQ     OP2
 NEEDPRL  VFD    30/0,12/60,18/95  INSTACK PRECEDENCE LT DIV AND MULT 
*ASSURES COLLECTION OF TERMS IN SUCH EXPRESSIONS AS SIN2PIX/L.
 JPSPEC   EQ     SPECIAL     REPLACES COMPIL RJ LEX WHEN COLLECTING 
*                            ARGUMENT OF PARENS-LESS FUNCTION.
 PRELEX   BSS    1           NONZERO IF PREOP AND PREAD HAVE INFO 
 PREOP    BSS    1           PRE-OP SET BY EXTRA LOOK-AHEAD CALL TO LEX 
 NCOMPIL  CALL   LEX         NORMAL CONTENTS OF LOCATION COMPIL 
* 
* 
*WHEN COLLECTING THE ARGUMENT OF A PARENS-LESS FUNCTION 
*LOCATION -COMPIL- IS ALTERED TO BRANCH HERE, WHERE WE
*LOOK AHEAD ONE LEXICAL ITEM IF NECESSARY.  IF OP IS
*MULTIPLY OR DIVIDE, WE CALL LEX AN EXTRA TIME TO SEE 
*WHETHER THIS OP IS FOLLOWED BY A FUNCTION, IN WHICH CASE 
*WE SET OP INHAND PRECEDENCE LOW TO FORCE COMPILATION OF
*THE PARENS-LESS FUNCTION.  THIS HANDLES SUCH STUDENT 
*STATEMENTS AS SINXCOSX AND SINX/COSX.
* 
 SPECIAL  SA1    PRELEX      CHECK FOR PREAD AND PREOP ALREADY SET
          ZR     X1,SPEC2    JUMP IF PREOP AND PREAD DO NOT HAVE INFO 
          NG     X1,LASTSP   JUMP IF LAST USE OF SPECIAL ROUTINE
          MX7    0
          SA7    A1          CLEAR PRELEX FLAG
          SA1    PREOP       USE ALREADY ACQUIRED PREOP AND PREAD 
          BX7    X1 
          SA7    OP 
          EQ     SPEC3       BYPASS REGULAR CALL TO LEX 
* 
 SPEC2    CALL   LEX         GET NEXT LEXICAL ITEM (OP AND AD)
 SPEC3    SA1    OP          CHECK FOR * OR / 
          ZR     X1,AD1      JUMP IF NOT AN OPERATOR
          SX2    X1-OPMULT
          ZR     X2,CHECKUP  JUMP IF *
          SX2    X1-OPDIV 
          ZR     X2,CHECKUP  JUMP IF /
          EQ     COMPILB     BACK TO MAINSTREAM 
* 
 LASTSP   SA2    NCOMPIL     RESTORE LOCATION COMPIL TO NORMAL FORM 
* /---   BLOCK      CHECKUP    00 000   78/06/06  21.40 
          BX7    X2 
          SA7    COMPIL 
          SA1    PREOP       MOCK UP RJ LEX 
          BX7    X1 
          SA7    OP 
          ZR     X1,AD1      JUMP IF OPERAND NOT OPERATOR 
          EQ     COMPILB
* 
 CHECKUP  BX7    X1          CHECK WHETHER NEXT LEXICAL ITEM IS FUNCTION
          SA7    PREOP       SAVE OP
          SA7    PRELEX      SET PRELEX NONZERO TO FLAG LOOK-AHEAD
          CALL   LEX         LOOK AHEAD ONE LEXICAL ITEM
          SA1    PREOP       PICK UP * OR / 
          SA2    OP 
          BX7    X2 
          SA7    A1          SAVE NEW OP IN PREOP 
          BX7    X1 
          SA7    A2          REPLACE OP WITH PREOP
          ZR     X2,COMPILB  JUMP IF OPERAND, NOT FUNCTION OR OPERATOR
          NG     X2,ISFUNCT  JUMP IF IT IS A FUNCTION (PARES-LESS)
          SX3    X2-OP(      CHECK FOR LEFT PARENS
          ZR     X3,ISFUNCT  EITHER ( OR FUNCTION TERMINATES ARGUMENT 
          SX3    X2-OPFCT    CHECK WHETHER OP CORRESPONDS TO A FUNCTION 
          NG     X3,COMPILB  JUMP IF NOT FUNCTION 
          SX3    X2-ARAYOP
          PL     X3,COMPILB  JUMP IF NOT FUNCTION 
* 
 ISFUNCT  MX7    1           NEGATIVE 
          SA7    PRELEX      SET NEGATIVE FOR LAST JUMP TO SPECIAL
          BX7    X1 
          SA7    LASTOP      DUPLICATE OPERATIONS AT LOCATION OP1 
          SA2    TOPCNT     COUNT OPERATORS ENCOUNTERED 
          SX7    X2+1 
          SA7    A2 
          MX2    0           SPECIAL PRECEDENCE TO FORCE
*                ALL OPERATIONS, BACK TO PRECEDING FUNCT. 
*                (CORRECT PRECEDENCE RESTORED AT CMPF3) 
          EQ     FORCE       FORCE COMPILATION
          ENDIF 
* 
* 
          TITLE  MINUS, PLUS, ISDEGR, ISPI, ENDINST 
* 
* 
 MINUS    SA2    LASTOP      NEED OLD LASTOP FOR UNARY CHECK
          BX7    X1          BUT SAVE MINUS OP IN LASTOP
          SA7    A2 
          RJ     UPLMIN      CHECK WHETHER UNARY OPERATION
          SX1    OPUSUB      LABEL AS UNARY MINUS 
          EQ     OP1
* 
 PLUS     SA2    LASTOP      NEED LASTOP FOR UNARY CHECK
          BX7    X1          BUT SAVE PLUS IN LASTOP
          SA7    A2 
          RJ     UPLMIN      CHECK WHETHER UNARY OPERATION
          EQ     COMPIL      IGNORE UNARY PLUS
* 
 ISDEGR   SX7    B0          DEGREE OPERATOR IS EFFECTIVELY AN ADDRESS
          SA7    LASTOP      SO CLEAR LASTOP
          EQ     OP1
* 
* 
*PI CAN EITHER BE AN OPERATOR, AS IN 3PI, WHERE IT MEANS
*GENERATE LITERAL -AND- A MULTIPLY INSTRUCTION, OR
*PI CAN BE AN ADDRESS (OPERAND) AS IN 3+PI. 
*THE SAME ROUTINE THAT CHECKS FOR UNARY PLUS OR MINUS 
*MAKES THE APPROPRIATE CHECKS FOR THE TWO KINDS OF PI.
* /---   BLOCK      ENDINST    00 000   78/01/25  15.46 
* 
 ISPIAD   SA2    LASTOP      NEED LASTOP FOR UNARY CHECK
          SX7    B0          CLEAR LASTOP SINCE BOTH KINDS OF PI ARE ADS
          SA7    A2 
          RJ     UPLMIN      UPLMIN RETURNS IF PI IS AN ADDRESS 
          SX0    B0          PI IS STORED AT LITS+0 
          RJ     LITREF      FORM LONG LITERAL REFERENCE
          EQ     COMPIL 
* 
 UPLMIN   EQ     *           CHECK FOR UNARY + OR - OPERATION 
*LASTOP MUST BE IN X2 
          ZR     X2,OP1      NOT IF PRECEDING ITEM NOT OP 
          SX7    X2-OP) 
          ZR     X7,OP1      NOT IF ) 
          SX7    X2-OPNAME   CHECK FOR PRECEDING SPECIAL NAME 
          PL     X7,OP1      EFFECTIVELY AN AD, NOT AN OP 
          EQ     UPLMIN 
* 
 ENDINSA  SA1    NARRAYS
          NZ     X1,ENDAINS  JUMP IF ARRAYS BEING PROCESSED 
 ENDINST  SA1    NOPS        END OF THIS INSTRUCTION
          SX7    X1-1 
          SA7    NOPS        DECREMENT NOPS 
          SA3    X1+OPS      SAVE LAST OPERATION PERFORMED
          BX6    X3 
          SA6    FINALOP
 ENDINS2  SA1    INHAND      RESTORE TO OP2 CONDITIONS
          SA2    INHANDL
          SA3    X7+OPSL     PREVIOUS LEVEL 
          EQ     OP2         AGAIN COMPARE LEVELS 
* 
 ENDAINS  PL     X1,ENDINST  EXIT IF NO ARRAY LOOP GOING ON 
          BX7    -X1         RESET +
          SX7    X7+1        INCREMENT NUMBER OF ARRAY OPS
          SA7    A1 
          SA1    TMPARAY     STORE IN TEMPORARY ARRAY 
          RJ     LDALOOP     GENERATE RJ ALOOPS, ETC. 
          RJ     AIFBIT      SET I/F BIT OF RESULT ARRAYWD
*          SB1    RAINTER 
*          RJ     LDASUB      GENERATE *RJ INTERRUPT TEST*
          RJ     LDAINTR     GENERATE *RJ AINTER* INTRUPTEST
          EQ     ENDINST
* 
 AIFBIT   EQ     *           SET I/F BIT OF RESULT ARRAYWD
          MX0    1
          LX0    XCODEAL+4   I/F BIT
          SA1    NADS 
          SA2    X1+ADS      GET ADTYPE OF RESULT 
          SA3    FLOAT
          BX7    -X0*X2      CLEAR I/F BIT
          ZR     X3,ENDAIN5  JUMP IF RESULT INTEGER 
          BX7    X7+X0       SET I/F BIT
 ENDAIN5  SA7    A2          RESTORE ADTYPE 
          EQ     AIFBIT 
* 
 LDALOOP  EQ     *           ENTER WITH STORE ADDRESS IN X1 
          SX7    6110B       CODE FOR SB1 
          LX7    18 
          BX7    X7+X1       GENERATE  SB1  STORADDRESS 
          RJ     LONGI
*****NEW CHANGE  MIGHT PUT SA6 X4+B1 HERE*****
          SA1    LLALOOP
          SX7    0100B       CODE FOR   RJ ** 
          LX7    18 
          BX7    X7+X1       GENERATE  RJ ALOOPS
          RJ     LONGI
          RJ     PAD         MAKE SURE START NEW WORD 
          SB1    6
          RJ     FREEX       RELEASE RESULT REGISTER
          EQ     LDALOOP
* /---   BLOCK      ISSEG      00 000   78/06/06  21.41 
          TITLE  SEGMENT AND ARRAY
* 
*         -SEGMENT- INVOLVES AN *OP* AND AN *AD*
*         SO DOES ARRAY/COMPLEX WHICH USES THIS TOO 
* 
 ISSEG    SA2    NUNITS      NO UNITS ALLOWED 
          PL     X2,UNITERR 
          SA2    NOPS 
          SX7    X2+1        INCREMENT *NOPS* 
          SX6    X7-OPSMAX-1
          PL     X6,LNGERR   EXIT IF TOO MANY OPS 
          SA7    A2 
          BX6    X1          STORE -SEG- OR -ARRAY- OP
          SA6    X7+OPS      AND IN OPS LIST
          SA3    X1+PRECED   GET PRECEDENCE OF SEG OR ARRAY 
          AX3    18          POSITION STACK PRECEDENCE
          MX0    -12
          BX6    -X0*X3      MASK OFF PRECEDENCE
          SA6    X7+OPSL
* 
          CALL   LEX         GET SEGMENT,ARRAY ADTYPE 
          SA1    OP 
          NZ     X1,SEGERR   ERROR IF OPERATOR
          SA2    NADS 
          SX7    X2+1 
          SX2    X7-ADSMAX   SEE IF TOO MANY ADS
          PL     X2,LNGERR
          SA7    A2          INCREMENT NADS 
          SA3    ADTYPE 
          MX0    -XCODEAL 
          BX1    -X0*X3      MASK OFF ADDRESS OF LIT
          AX3    XCODEAL
          MX0    -3          MASK FOR TYPE CODE 
          BX0    -X0*X3 
          SA2    NOPS 
          SA2    X2+OPS      GET LAST OP
          SX2    X2-OPSEG    IS EITHER ARRAY OR SEG OP
          NZ     X2,ISARY1   JUMP IF ARRAY
          SX3    X0-5        MUST BE 5 FOR -SEGMENT-
          NZ     X3,SEGERR
* 
          SA2    ATOKEN      ADDRESS OF *TOKBUF*
          IX0    X1+X2       ECS ADDR OF LITERAL
          SA0    LITEMP 
+         RE     1
          RJ     ECSPRTY
          SA1    LITEMP      GET LITERAL INTO X1
          BX6    X1 
          RJ     LSEEK       ADD LITERAL TO XSTOR 
          SX7    5
          LX7    XCODEAL
          BX6    X6+X7       FORM CODE WITH NEW ADDRESS 
          SA1    NADS 
          SA6    X1+ADS      ADD TO *ADS* LIST
          CALL   LEX         GET LEFT PAREN 
          SA1    OP 
          SX2    X1-OP(      ERROR IF NOT LEFT PAREN
          NZ     X2,BADPAR
          SA2    NOPS 
          SX7    X2+1        INCREMENT *NOPS* 
          SA7    A2 
          BX6    X1 
          SA6    LASTOP 
          SA6    X7+OPS 
          SA3    X6+PRECED
          AX3    18          PRECEDENCE OF LEFT PAREN 
          MX0    -12
          BX6    -X0*X3 
          SA6    PREVOPL     SAVE PRECEDENCE LEVEL
          SA6    X7+OPSL
          EQ     COMPIL      DONT FORCE COMPILATION 
* 
 LITEMP   BSS    1
 LITEMP2  BSS    1
* 
* /---   BLOCK      ISARRAY    00 000   78/01/26  21.34 
* 
 ISARRAY  EQU    ISSEG       SEE PREVIOUS BLOCK 
* 
* 
 ISARY1   SX3    X0-6        MUST BE 6 FOR -ARRAY-
          NZ     X3,MATERR
          SA3    ATOKEN      ADDRESS OF *TOKBUF*
          IX0    X1+X3       ECS ADDR OF LITERAL
          SA0    LITEMP 
+         RE     2
          RJ     ECSPRTY
          SA1    LITEMP      GET LITERAL INTO X1
          SX2    X2+OPSEG-OPSCAL
          ZR     X2,SCALEL   JUMP IF SCALAR ARRAY 
          BX6    X1          NOW MUST CHECK TO SEE IF 1OR2
          MX0    2           LITWORDS TO PUT IN XTRA STORAGE
          LX0    58          MASK FOR BASE/SEGMENT BITS 
          BX0    X0*X6       IS ZERO IF NO 2D ARAYWD
          SA0    A1          SAVE 1ST LIT ADDR
          ZR     X0,ISARY3   JUMP IF NO 2ND INFO WORD 
          SA1    A1+1        GET 2ND INFO WORD
          BX7    X1 
          RJ     LSEEK2      INFO WORDS IN X6 AND X7
          EQ     ISARY6 
 ISARY3   RJ     LSEEK
 ISARY6   SA2    A0          GET BACK ARAYWD
          MX0    1
          LX0    XCODEAL+4   MASK OFF I/F BIT 
          BX0    X0*X2
          SX7    6           CODE FOR ARRAY/COMPLEX 
          LX7    XCODEAL
          BX7    X7+X0       MERGE CODE, I/F BIT, 
          BX6    X6+X7       AND XSTOR ADDRESS
          SA1    NADS 
          SA6    X1+ADS      ADD TO *ADS* LIST
          CALL   LEX         GET NEXT LEXICAL ITEM
          SA1    OP 
*                CHECK FOR WHOLE ARRAY OR ARRAY ELEMENT 
          SX2    X1-OP(      ERROR IF NOT LEFT PAREN
          NZ     X2,WARRAY   IF NO ( MUST BE WHOLE ARRAY
          SA2    NOPS 
          SX7    X2+1        INCREMENT *NOPS* 
          SA7    A2 
          BX6    X1 
          SA6    LASTOP 
          SA6    X7+OPS 
          SA3    X6+PRECED
 ISARY8   AX3    18          PRECEDENCE OF LEFT PAREN 
          MX0    -12
          SA1    TOPCNT      INCREMENT TOTAL OP COUNT 
          SX6    X1+2 
          SA6    A1 
          BX6    -X0*X3 
          SA6    PREVOPL     SAVE PRECEDENCE LEVEL
          SA6    X7+OPSL
          SA1    X2+OPS      GET LAST OP
          SX1    X1-OPMAT 
          ZR     X1,ISMATR    JUMP IF MATRIX
          EQ     COMPIL      DONT FORCE COMPILATION 
* 
* /---   BLOCK      WARRAY     00 000   77/12/19  16.02 
 ISMATR   SA1    WORDPT 
          SX0    1R,         ONLY , AND EOL TERMINATE 
          CALL   PSCAN       FIND COMMA SEPARATING ARGUMENTS
          ZR     X1,FORMERR  ERROR IF EOL ENCOUNTERED FIRST 
          SX7    COPARGS     PUT ARGUMENT SEPARATOR CHARCTR 
          SA7    B1          INTO COMMA POSITION
          SX6    B1 
          SA6    NARGS       SAVE THIS POSITION 
          EQ     COMPIL 
* 
 WARRAY   SA1    NARRAYS     IS 0 IF NO ARRAYS FOUND YET
          NG     X1,NOAERR   NO ARRAYS ALLOWED IF - 
          NZ     X1,WARRAY2  IF ALREADY SET, DONT CHANGE
          SX6    1           THIS TURNS ON ARRAY OPS SEARCH 
          SA6    NARRAYS
 WARRAY2  MX0    1
          LX0    59          SET BIT 58 
          SA1    NADS 
          SA2    X1+ADS      GET ADTYPE 
          BX6    X2+X0       MERGE IN WHOLE ARRAY BIT 
          SA6    A2          AND RESTORE
          SA1    NOPS 
          SX7    X1-1        DECREMENT TO DISCARD ARRAY OP
          SA7    A1 
          SX7    B0 
          SA7    LASTOP      CLEAR IT FOR UNARY CHECKSJ 
          EQ     COMPIL1     HAVE NEXT OP OR ADTYPE ALREADY 
* 
*         NOTE, SEGMENTED SCALARS NOT ALLOWED 
*         SO ONLY REAL OR COMPLEX REAL SCALAR REACHES HERE
 SCALEL   BX3    X1          COPY OF ARRAYWD
          LX3    1           REAL/COMPLEX BIT AT LEFT 
          NG     X3,CPXERR   JUMP IF COMPLEX**FOR NOW 
          MX0    -XCODEAL-4 
          BX6    -X0*X1      ISOLATE GETVARCODE OF STARTLOC 
          SA6    ADTYPE      SAVE IT
          SA2    NOPS 
          SX7    X2-1        DECREMENT OPS TO DISCARD 
          SA7    A2          OPSCAL OP
          SA2    NADS 
          SX7    X2-1        DECREMENT NADS--WILL INCREMENT 
          SA7    A2          AGAIN IN AD1 
          EQ     AD1         PUT SCALAR GETVAR IN ADS LIST
* 
* 
*         ARGUMENT SEPARATOR FOR MATRICES, MULT.ARG.FUNCTS
 ARGSEP   SA1    TOPCNT      DONT COUNT AS OPERATOR 
          SX7    X1-1 
          SA7    A1 
          MX7    0
          SA7    LASTOP 
          SA4    NARGS
          SX7    1R,         REPLACE ARGSEP WITH , AGAIN
          SA7    X4 
          EQ     ENDINST     JUST DISCARD THIS OP NOW 
* 
* /---   BLOCK      ISEOL      00 000   74/07/13  05.03 
          TITLE  ISEOL, ADS, UNITS, FORCE, OPJUMP 
* 
 ISEOL    SA2    PUTCOMP     SEE IF *PUTCOMP* CALL
          ZR     X2,OP0 
          NG     X2,OP0 
* 
*         IF -PUTCOMP- CALL GENERATE CODE TO STORE X6 UNLESS
*         SIMPLE VARIABLE REFERENCE 
* 
          MX6    -1          RESET -PUTCOMP- FLAG 
          SA6    A2 
          SA2    COMPALL     SEE IF SHOULD ALWAYS COMPILE 
          NZ     X2,PUTCMP1 
          SA2    NOPS 
          SX2    X2-2        NOT SIMPLE IF MORE THAN 1 OP 
          PL     X2,PUTCMP1 
          SA2    NADS        CHECK FOR EXACTLY 1 ADTYPE 
          SX6    X2-1 
          NG     X6,EQERR 
          NZ     X6,PUTCMP1  JUMP IF NOT SIMPLEST CASE
          SA2    X2+ADS 
          NG     X2,PUTCMP1  JUMP IF IN REGISTER
          AX2    XCODEAL     POSITION -GETVAR- TYPE CODE
          MX6    -3 
          BX2    -X6*X2      MASK OFF TYPE CODE 
          SX6    X2-2 
          ZR     X6,OP0      EXIT IF TYPE 2  (STUDENT VAR)
          SX6    X2-3 
          ZR     X6,OP0      EXIT IF TYPE 3  (COMMON VAR) 
* 
 PUTCMP1  SX1    OPASIGN     RETURN OP CODE FOR ASSIGN
          BX7    X1 
          SA7    OP 
          SX7    PUTCMP2     NEXT CALL TO -LEX- WILL BRANCH 
          SA7    LEXADD      TO -PUTCMP2- 
          EQ     OP0
* 
 PUTCMP2  SX7    EOL         RETURN OP CODE FOR END-OF-LINE 
          SA7    OP 
          SA1    NADS        ALSO ADD TO ADDRESS STACK
          ZR     X1,FORMERR  ERROR IF NO ADTYPE TO STORE IN 
          SA2    X1+ADS 
          SX6    1
          LX6    XCODEAL+3   MASK FOR I/F BIT 
          BX6    X2*X6       SAVE I/F BIT 
          SX7    X1+1 
          SX1    X7-ADSMAX
          PL     X1,LNGERR   ERROR IF TOO MANY ADDRESSES
          SA7    A1 
          MX0    -3 
          SA1    ADS         GET CURRENT REGISTER NUMBER
          BX2    -X0*X1 
          MX1    1           MARK IN REGISTER 
          BX1    X1+X2
          BX6    X1+X6       ATTACH I/F BIT 
          SA6    X7+ADS      STORE ADTYPE 
          EQ     LEX         RETURN TO CALLER VIA -LEX- 
* 
* /---   BLOCK      RPAREN/AD  00 000   74/08/08  22.26 
* 
 RPAREN   SA1    TOPCNT      DECREMENT TOPCNT BY 2 (LEFT AND RIGHT PAR) 
          SX7    X1-2 
          SA7    A1 
          SA1    NOPS        TO PROCESS RT PAREN, 
          SX1    X1-1        JUST BACK UP STACK POINTER 
          SA2    X1+OPS      GET PREVIOUS OPERATOR
          SX7    X2-OP(      MUST BE LEFT PAREN 
          NZ     X7,BADPAR
          SX7    X1-1        BACK STACK POINTER OVER LEFT PAREN 
          SA7    NOPS 
          EQ     ENDINS2
* 
* 
 AD1      SX7    B0          ADDRESS, NOT OP IN HAND
          SA7    LASTOP      CLEAR LAST ITEM OPCODE 
          SA1    ADTYPE      GETVAR CODE
          NG     X1,VARERR   ADTYPE NEGATIVE IF UNRECOGNIZED NAME 
          SA3    NADS 
          SX7    X3+1 
          SX6    X7-ADSMAX   SEE IF TOO MANY ADS
          PL     X6,LNGERR
          SA7    A3          INCREMENT NADS 
          BX6    X1 
          SA6    X7+ADS      ADD ADDRESS TO ADS LIST
          SA2    NUNITS 
          NG     X2,COMPIL   JUMP IF NO UNITS 
* MOVE UADTYPE DIMENSION VECTOR INTO UADS BUFFER
          SB1    X2          NUMBER OF DIMENSIONS 
          SA1    ATEMPEC
          BX0    X1 
          SA0    UADTYPE
+         WE     B1 
          RJ     ECSPRTY
          SA1    NUADS
          PL     X1,AD2      JUMP IF NOT FIRST UNITS AD 
          DX1    X2*X3       CALC NUADS STARTING PLACE
          IX1    X1-X2
 AD2      SX7    X1-UADSMAX 
          PL     X7,LNGERR   JUMP IF TOO MANY UNIT ADS
          SX7    X1+B1
          SA7    A1          UPDATE NUADS 
          SA0    X7+UADS
+         RE     B1 
          RJ     ECSPRTY
          EQ     COMPIL 
* ENTER WITH X2=NUMBER OF UNITS, X1=CODE TO PLANT 
 DOUNITS  EQ     *           MANIPULATE UNIT COEFFS 
          SB2    X2          NUNITS IN X2, CODE IN X1 
          BX7    X1          OPERATION CODE IN X1 
          SA7    DOUNIOP     PLANT CODE 
          SB1    1           INDEX
          SA1    NUADS       NUADS STARTS AT ZERO 
          ZR     X1,UNITERR  MUST BE TWO OPERANDS 
          IX7    X1-X2       DECREMENT NUADS
          SA7    A1 
          SA2    X1+UADS-1   SECOND LIST (MINUS 1)
          SA1    A2-B2       FIRST LIST (MINUS 1) 
 DOUNIOP  EQ     *           PLANT CODE HERE
+         SA7    A1          STORE DIMENSION COEFF RESULT 
          SB2    B2-B1       COUNT
          GT     B2,B0,DOUNIOP
          EQ     DOUNITS
* 
 ADDEM    SA1    A1+B1       FROM FIRST LIST
          SA2    A2+B1       FROM SECOND LIST 
          FX7    X1+X2       ADD COEFFS IF MULTIPLYING UNITS
          NX7    X7 
* 
 SUBEM    SA1    A1+B1       FROM FIRST LIST
          SA2    A2+B1       FROM SECOND LIST 
          FX7    X1-X2       SUB COEFFS IF DIVIDING UNITS 
          NX7    X7 
* /---   BLOCK      DOUNITS    00 000   78/12/21  18.20 
* 
* ENTER WITH X2=NUMBER OF UNITS 
* 
 ZEROU    EQ     *           CHECK FOR ZERO UNITS COEFFS
          SB2    X2          NUNITS IN X2 
          SB1    1           INDEX
          SA1    NUADS       NUADS STARTS AT ZERO 
          SA1    X1+UADS-1   START OF DIMENSIONS (-1) 
 DOZEROU  SA1    A1+B1       PICK UP COEFF
          NZ     X1,UNITERR  JUMP IF COEFF NOT ZERO 
          SB2    B2-B1       COUNT
          GT     B2,B0,DOZEROU
          EQ     ZEROU
* 
* 
* ENTER WITH X2=NUMBER OF UNITS 
* 
 SAMEU    EQ     *           CHECK FOR UNITS BEING THE SAME 
          SB2    X2          NUNITS IN X2, CODE IN X1 
          SB1    1           INDEX
          SA1    NUADS       NUADS STARTS AT ZERO 
          ZR     X1,FORMERR  MUST BE TWO OPERANDS 
          IX7    X1-X2       DECREMENT NUADS
          SA7    A1 
          SA2    X1+UADS-1   SECOND LIST (MINUS 1)
          SA1    A2-B2       FIRST LIST (MINUS 1) 
 SAMEU1   SA1    A1+B1       FROM FIRST LIST
          SA2    A2+B1       FROM SECOND LIST 
          BX7    X1-X2       COMPARE COEFFS IF ADDING UNITS 
          NZ     X7,UNITERR  JUMP IF UNITS DO NOT MATCH 
          SB2    B2-B1       COUNT
          GT     B2,B0,SAMEU1 
          EQ     SAMEU
* 
* /---   BLOCK      DOUNITS    00 000   78/12/21  18.22 
* 
 UADZERO  EQ     *           CREATE ZERO UNITS COEFFS 
          SB2    X2 
          SA2    NUADS       POINTER IN UNIT STACK
          NG     X2,UNITERR  NUADS SHOULD NOT BE NEGATIVE 
          SX7    X2+B2       INCREMENT
          SX0    X7-UADSMAX 
          PL     X0,LNGERR   JUMP IF TOO MANY 
          SA7    A2 
          SA0    X7+UADS
          SX1    A0          MOVE TO *X1* BECAUSE OF -CALL- 
          ZERO   X1,B2       ZERO UNIT COEFFS FOR PI OR DEG 
          EQ     UADZERO
* 
* 3KG=3KG  OR  5KG $ARS$ 3KG --- DIMENSIONLESS RESULT 
 SAMEUZ   EQ     *           ARGS MUST HAVE SAME UNITS
          RJ     SAMEU       (AND ZERO UNITS RESULT)
          SA2    NUNITS 
          SB2    X2 
          SA2    NUADS
          SA0    X2+UADS
          SX1    A0          MOVE TO *X1* BECAUSE OF -CALL- 
          ZERO   X1,B2       ZERO REST OF UNIT
          EQ     SAMEUZ 
* 
* 
 FORCE    BX7    X1          SAVE IN HAND OP
          SA7    INHAND 
          BX7    X2          AND ITS LEVEL
          SA7    INHANDL
          SA1    NOPS 
          SA1    X1+OPS      GET FORCED OP
          SB1    X1 
 OPJUMP1  SX7    1
          SA7    NOTLITS     OPERANDS NOT LITERALS UNTIL PROVEN ELSEWISE
          SX7    B1 
          SA7    SAVEOP      SAVE OP NUMBER 
          JP     B1+OPJUMP   GO PROCESS 
* 
* /---   BLOCK      OPJUMP     00 000   75/06/28  03.29 
          TITLE  OPJUMP 
* 
*         *** WARNING *** 
*         IF THE ORDER OF THIS TABLE IS CHANGED 
*         THE XTEXT FILE FOR COMPILE (-LEXTXT-) 
*         MUST ALSO BE CHANGED
* 
          PURGMAC SYM 
 SYM      MACRO  NAM,P1,P2,JUMP 
+         EQ     JUMP 
-         VFD    12/P1,18/P2
          ENDM
* 
* 
 OPJUMP   BSS    1           TABLE OF JUMPS FOR PROCESSING OPS
 PRECED   EQU    OPJUMP      STACK AND INHAND PRECEDENCE LEVELS 
*                            IN LOWER PARTS OF JUMP TABLE ENTRIES 
+         EQ     ENDLINE     END OF LINE (0 AS TERMINATOR)
-         VFD    12/0,18/-1 
+         EQ     ADD
-         VFD    12/50,18/49
+         EQ     SUB
-         VFD    12/50,18/49
+         EQ     ENDLINE     COMMA AS TERMINATOR
-         VFD    12/0,18/-1 
+         EQ     PILIT       PI LITERAL 
-         VFD    12/64,18/63
+         EQ     DEGREE      DEGREE TO RADIAN 
-         VFD    12/64,18/63
+         EQ     SEGRAY      SEGMENT(I) 
-         VFD    12/96,18/95
+         EQ     MATRAY      REAL/COMPLEX MATRIX ELEMENT
-         VFD    12/96,18/95
+         EQ     VECTRAY     REAL/COMPLEX VECTOR ELEMENT
-         VFD    12/96,18/95
+         EQ     SCALRAY     REAL/COMPLEX SCALAR ELEMENT
-         VFD    12/96,18/95
+         EQ     MULT 
-         VFD    12/64,18/63
 DIVIDE   EQ     DIV
-         VFD    12/62,18/61
+         EQ     BADPAR 
-         VFD    12/2,18/99 
+         EQ     RPAREN      RIGHT PAREN
-         VFD    12/98,18/3 
+         EQ     ARGSEP      ARGUMENT SEPARATOR 
-         VFD    12/7,18/6
+         EQ     ASSIGN      ASSIGNMENT 
-         VFD    12/10,18/95
+         EQ     UMINUS      UNARY MINUS
-         VFD    12/54,18/95
+         EQ     DOTMULT     DOT MULTIPLY 
-         VFD    12/68,18/67
+         EQ     CRSMULT     CROSS MULTIPLY 
-         VFD    12/72,18/71
+         EQ     CHARERR     ILLEGAL CHARACTER
-         VFD    12/100,18/100  HIGH PRECEDENCE 
+         EQ     UNION       UNION
-         VFD    12/26,18/25
+         EQ     MASK        MASK 
-         VFD    12/28,18/27
+         EQ     DIFF        LOGICAL DIFFERENCE 
-         VFD    12/28,18/27
+         EQ     ARS         ARITHMETIC RIGHT SHIFT 
-         VFD    12/28,18/27
+         EQ     CLS         CIRCULAR LEFT SHIFT
-         VFD    12/28,18/27
 FSTFCT   EQ     COMPLOG     OR 
-         VFD    12/20,18/19
+         EQ     COMPLOG     AND
-         VFD    12/22,18/21
+         EQ     COMPLOG     GT 
-         VFD    12/24,18/23
+         EQ     COMPLOG     GE 
-         VFD    12/24,18/23
+         EQ     COMPLOG     LT 
-         VFD    12/24,18/23
+         EQ     COMPLOG     LE 
-         VFD    12/24,18/23
+         EQ     COMPLOG     EQ 
-         VFD    12/24,18/23
+         EQ     COMPLOG     NE 
-         VFD    12/24,18/23
* /---   BLOCK      OPJUMP     00 000   80/03/23  11.17 
+         EQ     EXPO        EXPONENTIATION (2 ARGUMENTS, LIKE GT)
-         VFD    12/68,18/69
          LIST   G,X
*CALL     LEXDEF
          LIST   *
* 
 NFUNCTS  EQU    *-FSTFCT    NUMBER OF FUNCTIONS / NAMES
* 
* /---   BLOCK      ADD        00 000   78/07/31  05.11 
          TITLE  ADD, SUB, MULT, DIVIDE 
* 
 ADD      SX7    36000B      INTEGER ADD
          SA7    IOP
          SX7    34000B      FLOAT ADD (RX) 
          SA7    FLOAT
          SA2    NUNITS      ARE THERE UNITS
          NG     X2,ADD1     JUMP IF NOT
          RJ     SAMEU       CHECK FOR SAME UNIT DIMENSIONS 
 ADD1     RJ     PREBIN      DETERMINE 'I/'F TYPE 
          NZ     B3,ADDJP    IF NOT BOTH INTEGER
          SA3    NOTLITS
          ZR     X3,ADDJP    WILL BE OPTIMIZED ELSEWISE 
          SA3    NARRAYS
          ZR     X3,NTADDAR  JUMP IF NO ARRAYS
          BX7    X1+X2       TEST WHOLE ARRAY FLAG
          LX7    1           IN BIT 58
          NG     X7,ADDJP    JUMP IF EITHER IS AN ARRAY 
 NTADDAR  MX7    0
          SA7    FLOAT       NOT FLOATING INSTRUCTION 
          MX7    57 
          BX3    X1          GETVAR CODE IN X1
          NG     X3,TRY2ND   1ST ARG IN REGISTER
          AX3    XCODEAL
          BX3    -X7*X3 
          ZR     X3,SMALAD   SMALL 1ST ARG
 TRY2ND   NG     X2,ADDJP    2ND ARG IN REGISTER
          BX4    X2 
          AX4    XCODEAL
          BX4    -X7*X4 
          NZ     X4,ADDJP    JUMP IF NEITHER SMALL INTEGER
          BX7    X1          SWITCH ORDER OF ADS
          SA7    A2 
          BX7    X2 
          SA7    A1 
          SA1    A1 
          SA2    A2 
 SMALAD   MX7    60-XCODEAL 
          BX7    -X7*X1      GET 14 BITS OF SMALL LITERAL 
          SX7    X7-1 
          NZ     X7,ADDJP    JUMP IF NOT 1
          SB1    1
*BECAUSE FUNCTIONS AND SEGMENTS PUT INTO X1'. 
          RJ     GENREAD     GET THE NON-ONE ARGUMENT 
          SX7    1
          SA7    B1+RX       RESERVE THAT REGISTER
          SA0    B1 
          SA1    NADS 
          IX7    X1-X7       GET TO OTHER ADS 
          SA7    A1 
          SB1    2
          RJ     CHEKRR 
          SX7    B1+430B     GENERATE -1
          LX7    6
          SX7    X7+59       MXN  60-1
          RJ     SHORT
          RJ     FREEX
          MX7    0           CLEAR FIRST REGISTER 
          SA7    A0+RX
          SB2    A0 
          SX0    B2 
          LX0    3
* /---   BLOCK      ADD        00 000   78/07/31  04.45 
          SX3    X0+B1       ORIGIN REGISTER
          RJ     PICKX       GET DESTINATION REGISTER 
          MX7    1           RESERVE IT 
          SA7    B1+RX
          SX7    B1 
          LX7    6
          BX7    X3+X7
          SX6    37000B      SUBTRACT INSTRUCTION 
          BX7    X6+X7
          RJ     SHORT
          EQ     ENDINSA
 ADDJP    LX0    1           FLAG FIRST OPERAND FOR CHANGE
          JP     B3+ADDS
 ADDS     EQ     IADD        I+I
          EQ     ADDIF       I+F
          EQ     ADDFI       F+I
          EQ     ADD2        F+F
* ADDIF    LX0    1           FLAG FIRST OPERAND FOR MODE CHANGE
 ADDIF    BX7    X1+X0       (PREBIN SET X0 TO I/F MASK)
          SA7    A1 
          EQ     ADD2 
* ADDFI    LX0    1           FLAG SECOND OPERAND FOR MODE CHANGE 
 ADDFI    BX7    X2+X0       (PREBIN SET X0 TO I/F MASK)
          SA7    A2 
          EQ     ADD2 
 IADD     SX7    B0 
          SA7    FLOAT
 ADD2     RJ     BINARY      READ TWO OPERANDS
          SA1    FLOAT       IS IT FLOATING 
          NZ     X1,ADDF     JUMP IF FLOATING 
          SA1    IOP         GET INTEGER OPERATION
          BX7    X1+X7       MERGE REGISTERS
          RJ     SHORT       ADD INSTRUCTION TO STREAM
          EQ     ENDINSA
 ADDF     BX7    X1+X7       MERGE FLOATING OPERATION WITH REGISTERS
          RJ     SHORT       ADD INSTRUCTION TO STREAMF 
 NORM     SA1    NOTLITS     SHORT LEAVES LITERAL IN X7 IF NOTLITS=0
          NZ     X1,NORM2    JUMP IF NOT LITERALS 
          NX7    X7          NORM THE LITERAL 
          SA7    A7          AND STORE AGAIN INTO LITS TABLE
          EQ     ENDINST
* 
 NORM2    SX2    B1          NORMALIZE, B1 IS REGISTER NUMBER 
          LX2    6           CONSTRUCT NXI  XI  INSTRUCTION 
          SX2    X2+B1
          SX7    X2+24000B   24 IS NORMALIZE
          RJ     SHORT
          EQ     ENDINSA
* 
 SUB      SX7    37000B      INTEGER SUB
          SA7    IOP
          SX7    35000B      FLOAT SUB (RX) 
          SA7    FLOAT
          SA2    NUNITS 
          NG     X2,SUB1
          RJ     SAMEU
 SUB1     RJ     PREBIN 
          LX0    1           FLAG FIRST OPERAND FOR MODE CHANGE 
          JP     B3+ADDS
* 
 MULT     SA2    NUNITS      CHECK FOR UNITS
          NG     X2,MULT1    JUMP IF NO UNITS 
          SA1    ADDEM       CODE FOR ADDING UNIT COEFFS
          RJ     DOUNITS
 MULT1    RJ     PREBIN      CHECK FOR I/F TYPE 
 MULT1B   SX7    41000B      FLOAT MULT (RX)
          SA7    FLOAT
          LX0    1           (PREBIN SET X0 TO I/F MASK)
          JP     MULTS+B3 
* /---   BLOCK      MULT       00 000   75/10/18  20.16 
 MULTS    EQ     IMULT       I * I
 +        BX7    X1+X0       I * F
          SA7    A1          FLAG 1ST OPERAND FOR MODE CHANGE 
          EQ     MULT2
 +        BX7    X2+X0       F * I
          SA7    A2          FLAG 2ND OPERAND FOR MODE CHANGE 
 MULT2    RJ     BINARY      MODE CHANGE BITS ARE NOW SET 
          SA1    FLOAT       GET INSTRUCTION CODE 
          BX7    X1+X7       MERGE REGISTER NUMBERS 
          RJ     SHORT       ADD INSTRUCTION TO STREAM
          EQ     ENDINSA
* 
*INTEGER MULTIPLY-----
 IMULT    SX7    B0          CLEAR FLOAT FOR INT MULT.
          SA7    FLOAT
          RJ     BINARY      GET OPERANDS INTO REGISTERS
          SX7    X7+42000B   INTEGER MULTIPLY 
          RJ     SHORT       ADD INSTRUCTION TO STREAM
          EQ     ENDINSA
* 
* 
 DIV      SX7    45000B      FLOAT DIV (RX) 
          SA7    FLOAT
          RJ     FLTBOTH     FLOAT BOTH OPERANDS
          SA2    NUNITS 
          NG     X2,MULT2    JUMP IF NOT UNITS
          SA1    SUBEM       CODE TO SUBTRACT UNIT COEFFS 
          RJ     DOUNITS
          EQ     MULT2
* 
 PILIT    SX0    B0          PI LITERAL STORED AT LITS+0
          RJ     LITREF      GENERATE LONG LITERAL REFERENCE
          EQ     MULT        GENERATE MULTIPLY INSTRUCTION
* 
* 
 DEGREE   SX0    1           PI/180 LITERAL IN LITS+1 
          RJ     LITREF      GENERATE LONG LITERAL REFERENCE
          SA1    TOPCNT      DO NOT COUNT AS AN OPERATION 
          SX7    X1-1 
          SA7    A1 
          EQ     MULT        GENERATE MULTIPLY INSTRUCTION
* 
* 
*LITREF CREATES ENTRY IN ADS LIST FOR FLOATING LONG 
*LITERAL AT LITS+(X0).  X0=0 FOR PI, X0=1 FOR PI/180. 
 LITREF   EQ     *           CREATE LONG LITERAL REFERENCE
          SA1    NLITS       INCREMENT NLITS SINCE GENREAD
          SX7    X1+1          WILL DECREMENT NLITS 
          SA7    A1 
          SA1    NADS        HANDLE DEGREE SIGN 
          SX7    X1+1        GENERATE REFERENCE TO DEGREE-RADIAN FACTOR 
          SX6    X7-ADSMAX
          PL     X6,LNGERR   ERROR IF TOO MANY ADS
          SA7    A1          UPDATE NADS
          SX6    11B         GETVAR CODE FOR FLOATING LIT 
          LX6    XCODEAL
          BX6    X6+X0
          SX2    1           SET *LITS* FLAG
          LX2    LITSHFT
          BX6    X6+X2
          SA6    X7+ADS      LITERAL IS PI OR PI/180
          SA2    NUNITS 
          NG     X2,LITREF   JUMP IF NO UNITS INVOLVED
          RJ     UADZERO
          EQ     LITREF 
* 
 MASK     RJ     PREBIN      INTEGER MASK 
          MX7    0
          SA7    FLOAT
          RJ     BINARY 
          SX7    X7+11000B
          RJ     SHORT
          SA2    NUNITS 
          NG     X2,ENDINSA 
* /---   BLOCK      MULT       00 000   75/10/18  20.16 
          RJ     SAMEUZ       MUST HAVE SAME UNITS
          EQ     ENDINSA
* /---   BLOCK      UNION      00 000   75/10/18  20.47 
* 
 UNION    RJ     PREBIN      INTEGER UNION
          MX7    0
          SA7    FLOAT
          RJ     BINARY 
          SX7    X7+12000B
          RJ     SHORT
          SA2    NUNITS 
          NG     X2,ENDINSA 
          RJ     SAMEUZ       MUST HAVE SAME UNITS
          EQ     ENDINSA
* 
 DIFF     RJ     PREBIN      LOGICAL DIFFERENCE 
          MX7    0
          SA7    FLOAT
          RJ     BINARY 
          SX7    X7+13000B   BXN  XA-XB 
          RJ     SHORT
          SA2    NUNITS 
          NG     X2,ENDINSA 
          RJ     SAMEUZ       MUST HAVE SAME UNITS
          EQ     ENDINSA
* 
 ARS      MX7    0           ARITHMETIC RIGHT SHIFT 
          SA7    SHIFTDN
          SX7    21000B      SHIFT WITH 2ND ARG CONSTANT
          SA7    IOP         STORE FOR POSSIBLE OPTIMIZATION
          RJ     PREBIN 
          RJ     LBINARY
          SA2    SHIFTDN
          ZR     X2,ARSB1 
          SA2    NOTLITS
          ZR     X2,ENDINSA 
          SA2    IOP
          BX7    X7+X2       UNION IN REGISTER
          EQ     ARSSTR 
 ARSB1    SX7    X7+23000B
 ARSSTR   RJ     SHORT
          EQ     ENDINSA
* 
 CLS      SX7    0           CIRCULAR LEFT SHIFT
          SA7    SHIFTDN     FLAG FOR SHIFT OPTIMIZED 
          SX7    20000B      SHIFT WITH 2ND ARG CONSTANT
          SA7    IOP         STORE FOR POSSIBLE OPTIMIZATION
          RJ     PREBIN      CHECK IF BOTH LITERALS 
          RJ     LBINARY
          SA2    SHIFTDN
          ZR     X2,CLSB1 
          SA2    NOTLITS
          ZR     X2,ENDINSA   DONE IF HAD LITERALS
          SA2    IOP
          BX7    X7+X2       UNION IN REGISTER
          EQ     CLSSTR 
 CLSB1    SX7    X7+22000B
 CLSSTR   RJ     SHORT
          EQ     ENDINSA
* 
* 
 SHIFTDN  BSS    1           CHECK TO SEE IF SHIFT OPTIMIZED
* 
* /---   BLOCK      DOTMULT    00 000   77/12/18  16.55 
          TITLE  ARRAY MULTIPLICATION 
* 
 DOTMULT  SX7    RDOTMUL     FLAG FOR DOT MULTIPLY
          SA7    IOP         SAVE IT
 ARAYMUL  SA2    NUNITS 
          NG     X2,DOTM01   JUMP IF NO UNITS 
          SA1    ADDEM       ADD UNIT COEFFS
          RJ     DOUNITS
 DOTM01   RJ     PREBIN      B3=I/F BIT INFO, CHK FOR 2 ADS 
*          SA3    IOP 
*          SB2    X3-RDOTMUL  SET B2=0 IF DOT PRODUCT 
          BX4    X1+X2
          LX4    1           EXAMINE WHOLE-ARRAY BIT
          PL     X4,MULT1B    IF NEITHER ARRAY,NORMAL MULTPY
          BX4    X1*X2
          LX4    1
          MX7    -XCODEAL 
          NG     X4,DOTM10   JUMP IF BOTH ARE ARRAYS
*          NE     B2,B0,SIZERR   NO SCALARS IN CROSSPRODUCT 
          SA3    IOP
          SX3    X3-RDOTMUL 
          NZ     X3,SIZERR   NO SCALARS IN CROSSPRODUCT 
          MX3    -9 
          BX4    X1 
          LX4    1
          NG     X4,DOTM02   JUMP IF 1ST OPERAND IS ARRAY 
          BX4    -X7*X2      GET ADDRESS AND
          SA4    X4+INFO     2D OPERAND ARAYWD
          AX4    36 
          BX4    -X3*X4      ISOLATE ROWS 
          NZ     X4,SIZERR   ROWS2 MUST BE 1 IF OP1 SCALAR
          EQ     MULT1B      DO REGULAR MULTIPLY
* 
 DOTM02   BX4    -X7*X1      GET ADDRESS AND
          SA4    X4+INFO     1ST OPERAND ARAYWD 
          AX4    27 
          BX4    -X3*X4      ISOLATE COLS 
          NZ     X4,SIZERR   COLS1 MUST BE 1 IF OP2 SCALAR
          EQ     MULT1B      DO REGULAR MULTIPLY
* 
* /---   BLOCK      DOTMULT    00 000   76/11/28  10.26 
 DOTM10   BX1    -X7*X1      ADDRESSES OF ARRAYWDS
          BX2    -X7*X2 
          SA3    X1+INFO     GET ARRAY WDS
          SA4    X2+INFO
          BX6    X3-X4
          LX6    1           EXAMINE REAL/COMPLEX BIT 
          NG     X6,CPXERR   ERROR UNLESS BOTH SAME TYPE
* 
          BX6    X3+X4
          LX6    3           TEST MERGED SEGMENT BITS 
          PL     X6,DOTM14   JUMP IF NEITHER SEGMENTED
          SX6    B3          SAVE IFTYPE
          SA6    FLOAT
          LX4    3
          PL     X4,DOTM12   JUMP IF 2D ARRAY NOT SEGMENTED 
          LX4    57 
          BX7    X4 
          SA7    ASIZE
          RJ     ARYPREP     CLEAR X1,X2,X6,CHECK SAVEBUFFER
          RJ     ASEGTMP     CONVERT 2D ARG TO TEMP ARRAY 
          SA1    NADS 
          SA1    X1+ADS-1    GET 1ST OPERAND ADTYPE 
          MX7    -XCODEAL 
          BX1    -X7*X1      ADDR OF ARAYWD 
          SA3    X1+INFO     GET 1ST ARAYWD 
 DOTM12   LX3    3
          PL     X3,DOTM13   JUMP IF 1ST NOT SEGMENTED
*          EQ     TSTERR      **THIS PART NOT FULLY TESTED**
          LX3    57 
          BX7    X3 
          SA7    ASIZE
          RJ     POPNADS     SET FOR FIRST OPERAND
          RJ     ARYPREP     CLEAR X1,X2,X6,CHECK SAVEBUFFER
          RJ     ASEGTMP     CONVERT 1ST ARG TO TEMP ARRAY
          SA1    NADS 
          SX7    X1+1        BACKUP TO 2D OPERAND 
          SA7    A1 
 DOTM13   SA1    NADS 
          SA2    X1+ADS 
          SA1    X1+ADS-1 
          MX7    -XCODEAL 
          BX1    -X7*X1      ADDRESS OF ARRAYWDS
          BX2    -X7*X2 
          SA3    FLOAT       GET SAVED B3 
          SB3    X3 
          SA3    X1+INFO     ARRAY INFO WORDS (NOW TEMPARAY)
          SA4    X2+INFO
*         NOW CHECK FOR CONFORMALITY
 DOTM14   MX0    2           MASK FOR DIMENSIONS
          BX5    X3+X4
          LX5    4           MERGED DIMENSIONS AT LEFT
          MX0    -9          MASK FOR SIZE FIELDS 
          LX3    24 
          LX4    24          GET ROWS AT RIGHT
          BX6    -X0*X3      ROWS1-1
          BX7    -X0*X4      ROWS2-1
          LX3    9
          LX4    9
          BX3    -X0*X3      COLS1-1
          BX4    -X0*X4      COLS2-1
*          NE     B2,B0,CRSMUL5   JUMP IF CROSSPRODUCT
          SA1    IOP
          SX1    X1-RDOTMUL 
          NZ     X1,CRSMUL5  JUMP IF CROSSPRODUCT 
*         CHECK CONFORMALITY OF VECTOR PROD SEPARATELY
          PL     X5,DOTM30   JUMP IF NEITHER ARE MATRICES 
 DOTM15   IX5    X3-X7       COLS1-ROWS2
          NZ     X5,SIZERR   INNER DIMENSIONS MUST MATCH
* /---   BLOCK      DOTMULT    00 000   78/01/25  16.08 
**LATER MUST CHECK FOR COMPLEX ARRAY..DOUBLE SIZE 
          SX0    X6+1        ROWS1
          SX5    X4+1        COLS2
          DX5    X0*X5       ROWS1*COLS2
          SX0    X5-1        SIZE-1 
          ZR     X0,DOTM21   JUMP IF RESULT SCALAR (SIZE=1) 
          SX0    X0-ARAYLTH+1 
          PL     X0,SIZERR   ERROR IF SIZE TOO BIG
*         RESULT IS MATRIX
 DOTM20   LX5    9
          BX5    X5+X6       SIZE,ROWS1 
          LX5    9
          BX0    X5+X4       SIZE,ROWS1,COL2
          LX0    27          =RESULT ARAYWD SIZE FIELDS 
* 
*         WHEN COMPLEX ADDED...INSERT CMPLX/REAL BIT HERE 
 DOTM21   LX7    9
          BX7    X7+X4       ROW2,COL2
          SA7    TMPARAY     SAVE TEMPORARILY 
          BX7    X0 
          SA7    ASIZE       RESULT SIZE FIELD (0 IF SCALAR)
          SX7    B3          IFBITS 
          SA7    FLOAT       SAVE FOR ADTYPE IN AIFBIT
          SX5    7110B       SX1 B0+... 
          LX5    18 
          LX6    9
          BX6    X6+X7       ROWS1/IFBITS 
          BX7    X5+X6       SX1 ROWS1/IFBITS 
**
          SA7    FFLT        SAVE TEMPORARILY 
          RJ     ARYPREP     CLEAR X1,2,6, FORM RJ ABUFCHK
          SA1    FFLT 
          BX7    X1          RESTORE X1 INFO
          RJ     LONGI       GENERATE    SX1 ROWS1/IFBITS 
* 
          SA1    TMPARAY     ROW2/COL2
          SX7    7120B       SX2 B0+... 
          LX7    18 
          BX7    X7+X1
          RJ     LONGI       GENERATE SX2 ROWS2/COLS2 
*         NOW GET ADDRESSES INTO B1,B2
          SA1    NADS 
          SA1    X1+ADS      GET 2D OPERAND IN X1 
          RJ     GETARAD     GET ACTUAL 2D ARAY ADDR IN X3
          SX7    6120B       SB2 B0+... 
          LX7    18 
          BX7    X7+X3
          RJ     LONGI       GENERATE SB2 (ARAY2 STARTLOC)
* 
          SA2    FLOAT       TYPE STORED HERE 
          SX3    X2-4 
          PL     X3,ISATRA   JUMP IF TYPE 4,5,6,7 ETC 
* 
          SA1    NADS 
          SA1    X1+ADS-1    GET 1ST OPERAND IN X1
          RJ     GETARAD
          SX7    6110B       SB1 B0+... 
          LX7    18 
          BX7    X7+X3
          RJ     LONGI       GENERATE SB1(ARAY1 STARTLOC) 
          RJ     POPNADS     DECREMENT NADS 
* 
 DOTM60   SB1    1           FORCE NEW TMPARAY
          RJ     CALCTMP
          SA1    TMPARAY     WHERE TO STORE 
          SX7    5100B
          LX7    18 
          BX7    X7+X1       GENERATE  SA0 TMPARAY
          RJ     LONGI
* 
* /---   BLOCK      CROSSMULT  00 000   76/06/20  05.34 
* 
 DOTM70   SA1    IOP         GET DISPLACEMENT 
          SB1    X1          FOR DOT/CROSS PROD 
          RJ     LDASUB      GENERATE RJ DOT/CROSS PROD 
* 
          RJ     TMPAD       CREATE TEMP ARRAYWD, ADTYPE
          RJ     AIFBIT      SET I/F BIT OF TEMP ARAYWD 
*          SB1    RAINTER 
*          RJ     LDASUB      GENERATE *RJ ARRAY INTERRUPT* 
          RJ     LDAINTR     GENERATE *RJ AINTER* INTRUPTEST
          SA1    NARRAYS
          SX7    X1+1        INCREMENT TO COUNT ARRAY OPS 
          SA7    NARRAYS
          EQ     ENDINST
* 
*         ENTER HERE IF BOTH OPERANDS VECTORS 
 DOTM30   IX5    X6-X7       TEST ROWS1-ROWS2 
          NZ     X5,SIZERR   MUST BE IDENTICAL LENGTH 
          MX6    0           MOCK UP ROW1=1 
          MX0    0           TO SET SIZE=0
          EQ     DOTM21 
* 
*         PATCH SO TRANSPOSE, REVERSE, ETC CAN USE DOTPROD
 ISATRA   SX7    66120B      SB1 B2+B0
          RJ     SHORT       ONLY ONE OPERAND ADDR FOR FUNCT
          SA1    NADS 
          SA2    X1+ADS 
          MX0    1
          LX0    XCODEAL+4   I/F BIT MASK 
          BX7    X0*X2
          SA7    FLOAT       I/F BIT OF OPERAND FOR AIFBIT
          SX7    RDOTMUL
          SA7    IOP         TRANSPOSE,REV USE DOT MUL
          EQ     DOTM60 
*         IF PUT TRACE IN HERE, SHOULD GOTO DOTM70
* 
* 
* 
*         ARRAY CROSS PRODUCT 
* 
 CRSMULT  SX7    RCRSMUL
          SA7    IOP         SAVE FLAG
          EQ     ARAYMUL
* 
 CRSMUL5  SB1    X7-1        CROSS MULT MUST HAVE 
          LE     B1,B0,SIZERR   3 OR MORE ELEMENTS
          PL     X5,CRSMUL7  JUMP IF BOTH VECTORS 
          NZ     X4,SIZERR   2D OPERAND MUST BE VECTOR
          IX0    X6-X3       AND 1ST OPERAND SQUARE ARRAY 
          NZ     X0,SIZERR   JUMP UNLESS ROWS1=COLS1
          BX0    X7          SAVE COLS2 TEMPORARILY 
          SX7    RDOTMUL     RESET FLAG SINCE ARRAY 
          SA7    IOP         CROSS MULT SAME AS DOT 
          BX7    X0 
          EQ     DOTM15      DO DOT MULTIPLY ON ARRAY.VECTOR
* 
 CRSMUL7  SX5    X7+1        SIZE=ROWS2 FOR VECTOR CROSSMULT
          EQ     DOTM20      NOTE ROW1 USED ONLY IN ASIZE 
* 
* /---   BLOCK      ENDLINE    00 000   78/12/18  21.07 
          TITLE  ENDLINE -- END OF EXPRESSION PROCESSING
* 
          PLATO 
 ENDLINE  SA1    OLDB5       -1 IF STUD DEF UNIT NOT IN CM
          NG     X1,ENDL
          CALL   POSTOR      RESTORE PRESENT UNIT 
          ENDIF 
          CONDEN
 ENDLINE  BSS    0
          ENDIF 
 ENDL     SA1    NUNITS 
          SX7    X1+1        CHECKING FOR NUNITS=-1 
          NZ     X7,ENDLIN2 
          ZERO   UADS,NUMAX     MUST CLEAR *UADS* 
 ENDLIN2  SA1    WORDPT      RETURN LAST KEY FOUND (0 OR COMMA) 
          SA2    X1-1 
          BX7    X2 
          SA7    LASTKEY
          NZ     X7,NOTEOL
          SX7    A2 
          SA7    A1          BACK UP WORDPT IF EOL
 NOTEOL   SA1    NADS        CHECK THAT THERE IS EXACTLY ONE OPERAND
          SA2    X1+ADS 
          MX7    1           SET NOTLITS FOR ANY ROUTINE
          SA7    NOTLITS     WHICH CALLS COMPILE AND USES SHORT 
          SX0    1           AND SAVE   I/F INFO
          LX0    XCODEAL+3   I/F BIT MASK 
          BX7    X0*X2
          SA7    FLOAT       SAVE FLOAT BIT 
          SX1    X1-1 
          NZ     X1,FORMERR  OTHERWISE ERROR IN FORM OF EXPRESSION
          SA1    COMPALL     IF THIS FLAG SET, COMPILE CODE EVEN
          NZ     X1,ENDL1    FOR SIMPLE VARIABLE OR LITERAL 
* 
* CHECK FOR SPECS NOOPS OR SPECS NOVARS 
* 
          PLATO 
          SA3    COMSPEC
          BX1    X3 
          LX1    NOOPS       CHECK FOR NOOPS SPECIFIED
          PL     X1,OPSOK 
          SA1    TOPCNT      NUMBER OF OPERATIONS 
          NZ     X1,OPTERR
* /---   BLOCK      ENDLINE    00 000   79/12/04  00.39 
 OPSOK    LX3    NOVARS      CHECK FOR NOVARS SPECIFIED 
          PL     X3,VARSOK
          SA1    TVARCNT     NUMBER OF VARIABLE REFERENCES
          NZ     X1,VARTERR 
          ENDIF 
* 
 VARSOK   SA1    CALC        CHECK WHETHER A CALC COMMAND 
          ZR     X1,NOTCALC  JUMP IF NOT A CALC COMMAND 
          SA1    FINALOP     LAST OPERATION IN CALC SHOULD BE ASSIGN
          SX1    X1-OPASIGN 
          NZ     X1,EQERR    JUMP IF NOT ASSIGN 
          SA3    NARRAYS
          ZR     X3,VARSOK2  JUMP IF NO ARRAYS USED 
          BX3    X2 
          LX3    1           CHECK WHOLE ARRAY BIT
          NG     X3,ENDARAY   SKIP GENREAD FOR ARRAYS 
 VARSOK2  PL     X2,SIMPLE   JUMP IF RESULT NOT IN REGISTER 
 ENDL1    SA1    RSULTX1     IF ZERO, MAKE SURE RESULT IN X1
          NZ     X1,ENDL2    AT END OF CALC 
          SB1    1           GENERATE A READ IF NECESSARY (EXPRESSION)
          RJ     GENREAD
          SB2    B1-1        CHECK FOR NOT IN X1
          ZR     B2,ENDL2    JUMP IF VALUE IN X1
          SX7    B1          B1 IS PRESENT REGISTER 
          LX7    3
          SX7    X7+10100B   CONSTRUCT    BX1 XN
          RJ     SHORT       ADD TO STREAM
 ENDL2    SX0    B0          CLEAR X0, IN CASE MOVCODE NOT CALLED 
          SA1    CMOVFLG     IF ZERO, COMPILE  CALC EXIT JUMP 
          NZ     X1,COMPEND  AND MOVE CODE GENERATED INTO EXTRA STORAGE 
* /---   BLOCK      COMPEND    00 000   76/06/17  16.06 
          SX7    23B
          LX7    21          COMPILE   JP  B3 
          RJ     LONGI       LAST INSTRUCTION 
          RJ     PAD         PAD OUT THE INSTRUCTION TO LEFT-ADJUST IT
          RJ     MOVCODE     AND MOVE CODE TO EXTRA STORAGE 
*MOVCODE SETS X0 TO EXTRA STORAGE LOCATION OF CODE. 
 COMPEND  SX1    4           FLAG CALC CODE 
          LX1    XCODEAL
          BX1    X0+X1       BRING IN EXTRA STORAGE POINTER 
*X0 IS ZERO IF MOVCODE WAS NOT CALLED, AS WITH -BRANCH- 
*COMMAND.  IN THIS CASE -BRANCH- SIMPLY NEEDS I/F INFO. 
          SA2    FLOAT       PICK UP I/F BIT
          BX1    X1+X2
          EQ     CHKSTOR
 SIMPLE   SA1    NADS        SIMPLE VARIABLE REFERENCE, NO CALC 
          SA1    X1+ADS 
 CHKSTOR  SB1    B0          FLAG FOR STORE-INTO-ABLE 
          BX3    X1          GETVAR CODE INTO X3
          AX3    XCODEAL     GET INITIAL BITS 
          MX0    57 
          BX3    -X0*X3      THROW AWAY I/F INFO
          SB2    X3          0SHORT,1LONG,2STUDENT,3COMMON,4CALC
          JP     B2+CHKSTR2 
 CHKSTR2  EQ     NOSTORE     SHORT LIT
          EQ     LONGLIT     LONG LIT 
          EQ     COMPILE     STUDENT
          EQ     COMPILE     COMMON 
          EQ     CHKSTR3     CALC 
          EQ     COMPERR     SEGMENT
          EQ     COMPERR     ARRAY/COMPLEX
          EQ     NOSTORE     -JUMP-TYPE GETVAR CODE 
* 
 CHKSTR3  SA2    ADS+1       PICK UP AD TO CHECK FOR INDEXED VARIABLE 
          AX2    XCODEAL     POSITION TYPE CODE 
          MX0    -3 
          BX2    -X0*X2      MASK OFF TYPE CODE 
          SX2    X2-4        TYPE 4 = INDEXED STORE 
          ZR     X2,COMPILE  JUMP IF CAN STORE INTO INDEXED VARIABLE
          SA2    PUTCOMP
          ZR     X2,NOSTORE  EXIT IF NOT -PUTCOMP- CALL 
          SA2    FINALOP     LAST OPERATION IN CALC SHOULD BE AN ASSIGN 
          SX2    X2-OPASIGN 
          NZ     X2,EQERR    JUMP IF NOT ASSIGN 
          SB1    1
          EQ     COMPILE
* /---   BLOCK      NOTCALC    00 000   76/06/17  16.11 
* 
 NOTCALC  SA3    NARRAYS
          NZ     X3,ARYUSED  JUMP IF WHOLE ARRAYS USED
 NOARAY   SX7    0
          SA7    ARAYFLG     INDICATE RESULT NOT ARRAY
          EQ     VARSOK2
* 
 ARYUSED  SA3    TMPAFLG     =0IF NO OPERATIONS PERFORMED 
          NZ     X3,NOAERR   NO ARRAY CALCS ALLOWED 
*         PROBLEM IS ARAY CALCS USE A0, ALSO USED BY GETVAR 
          BX3    X2          TEST ADTYPE
          LX3    1           ARAYBIT AT LEFT
          PL     X3,NOARAY   JUMP IF RESULT NOT WHOLE ARRAY 
          LX3    1           TEST TEMP ARAY BIT 
          NG     X3,TEMPERR  CANT USE TEMPARAY ***CHANGE*** 
          SA3    ARAYFLG     =1 IF ARAYS PERMITTED
          BX7    -X3         REVERSE SIGN TO
          SA7    A3          NOTIFY CALLING PGM ARRAYS FOUND
          SX3    X3-1 
          NZ     X3,NOAERR   NO ARRAYS PERMITTED
          MX0    -17
          BX1    -X0*X2      MASK OFF ARAY AND I/F BITS 
          SB1    0           CAN STORE INTO 1ST ELEMENT 
          EQ     COMPILE     EXIT WITH GETVAR=6 
* /---   BLOCK      NOSTORE    00 000   77/02/26  13.31 
* 
 NOSTORE  SB1    1           CANT STORE INTO THIS 
          SA2    PUTCOMP
          ZR     X2,COMPILE  EXIT IF NOT -PUTCOMP- CALL 
          EQ     EQERR
 LONGLIT  BSS    0
          RJ     RLLIT       (X6) = LONG LITERAL
          MX0    59          MASK OUT *LITS* BIT
          LX1    60-LITSHFT 
          BX1    X0*X1
          LX1    LITSHFT
          MX0    -XCODEAL 
          BX2    X6 
***SEE WHETHER LITERAL CAN BE EXPRESSED AS SHORT INTEGER
          NG     X6,LNGLIT2  SHORT LITERAL CANT BE NEGATIVE 
          BX3    X1          X1 HAS COMPLETE GETVAR CODE
          AX3    XCODEAL+3   GET I/F BIT
          ZR     X3,ILNGLIT  ZERO IF LONG INTEGER 
          UX2    X2,B1       FIX THE FLOATING LITERAL--MAY BE INTEGER 
          LX2    X2,B1
          PX3    X2 
          NX3    X3 
          BX3    X6-X3       COMPARE REFLOATED INTEGER WITH F LITERAL 
          NZ     X3,LNGLIT2  JUMP IF FRACTIONAL FLOATING LITERAL
          BX6    X2          CALL IT A LONG INTEGER 
          MX3    57-XCODEAL  DROP F BIT 
          BX1    -X3*X1 
 ILNGLIT  BX3    X0*X6       SEE WHETHER LONG INTEGER IS IN FACT SHORT
          NZ     X3,LNGLIT2  JUMP IF LONGER THAN XCODEAL BITS 
          BX1    X6          OTHERWISE, SHORT LITERAL HAS CODE 0
          EQ     NOSTORE
 LNGLIT2  BX0    X0*X1       SAVE CODE TYPE 
          RJ     LSEEK       PLANT LITERAL
          MX1    -XCODEAL 
          BX0    X0*X1
          BX1    X0+X6       X6 RETURNED WITH EXTRA STORAGE ADDRESS 
          EQ     NOSTORE
* 
 ENDARAY  SX0    B0          THIS IS LIKE ENDL2 
          SA1    CMOVFLG
          NZ     X1,COMPEND 
          SX7    23B
          LX7    21          COMPILE   JP  B3 
          RJ     LONGI       LAST INSTRUCTION 
          RJ     PAD
          RJ     MOVCODE     AND MOVE CODE TO EXTRA STORAGE 
          EQ     COMPEND     CREATE FINAL CALC CODE 
* 
* 
* /---   BLOCK      LOGICAL    00 000   78/01/25  13.49 
          TITLE  COMPILE LOGICAL EXPRESSIONS
* 
 COMPLOG  SX7    B0          CLEAR FLOAT FLAG 
          SA7    FLOAT
          SA2    NUNITS 
          NG     X2,CMPLG0
          RJ     SAMEUZ       LOGICAL OPERATIONS
* EXPONENTIATION JUMPS TO CMPLG0 WITH FLOAT SET.... 
 CMPLG0   RJ     PREBIN      FIND OUT MODES (I OR F)
          SX7    1           FLAG NOT LITERALS
          SA7    NOTLITS
          SX6    B3          SAVE FLOATING/INTEGER FLAG 
          SA6    FFLT 
          JP     B3+COMPL    B3=0,1,2,3 FOR II,IF,FI,FF ARGS
 COMPL    EQ     CMPLOG1     BOTH ARGUMENTS INTEGERS
          EQ     COMPIF      FIRST I, SECOND FLOATING 
          EQ     COMPFI      FIRST F, SECOND I
          EQ     COMPFF      BOTH ARGUMENTS FLOATING
 COMPIF   LX0    1           FLAG FIRST OPERAND FOR MODE CHANGE 
          BX7    X1+X0       (PREBIN LEAVES X0 WITH I/F MASK IN IT) 
          SA7    A1 
          EQ     COMPFF 
 COMPFI   LX0    1           FLAG SECOND OPERAND FOR MODE CHANGE
          BX7    X2+X0
          SA7    A2 
 COMPFF   SX7    1           FLAG FLOATING RESULT 
          LX7    XCODEAL+3
          SA7    FLOAT
 CMPLOG1  SA4    NARRAYS
          NZ     X4,ACMPLOG  JUMP IF ARRAY OPS IN PROGRESS
 CMPLGA1  SB1    2
          RJ     FORCEX      FORCE ARG INTO X2
          RJ     FREEX       THEN FREE THE REGISTER 
* (BECAUSE WE USE ITS CONTENTS IMMEDIATELY) 
 CMPLOG2  SA1    NADS        WORK ON FIRST ARGUMENT 
          SX7    X1-1 
          ZR     X7,FORMERR  ERROR IF NO OPERANDS 
          SA7    A1          BY DECREMENTING AD POINTER 
          EQ     CMPF31 
* 
*         HANDLE 2-ARG FUNCTIONS WITH ARRAY ARGUMENTS 
* 
 ACMPLOG  SA1    NADS 
          SA2    X1+ADS 
          SA3    A2-1        OPERAND ADS 1,2 IN X3,X2 
          BX7    X3+X2       TEST WHOLARRAY FLAG
          LX7    1           IN BIT 58
          PL     X7,CMPLGA1  EXIT IF NEITHER IS ARRAY 
*         UP TO HERE SHOULD BE INLINE CODE FOR SPEED
          RJ     BINARY      INITIALIZE AND LOAD ARRAYS 
          SA1    SAVEOP 
          SX0    X1-FUNCT0   GET FUNCTION NUMBER
          RJ     GENFCT      GENERATE RJ FUNCTIONSUBR 
          SX7    10611B 
          RJ     SHORT       GENERATE CODE FOR  BX6 X1
          EQ     ENDINSA     GENERATE RJ ALOOPS 
* 
* 
* /---   BLOCK      INTCMP     00 000   77/12/18  17.03 
          TITLE  FUNCTIONS AND SYSTEM VARIABLES 
* 
*         HANDLE -INT- FUNCTION 
* 
 INTCMP   RJ     FCCHK       CHECK FOR CONSTANT 
          ZR     X0,ICOMPF
        ZR      X2,INTIN        JUMP IF INTEGER 
          BX1    X3 
          RJ     TINTX       TAKE INTEGER PART OF CONSTANT
          MX4    0           RESULT IS INTEGER
* 
 INT10    SA2    NUNITS 
          PL     X2,ICOMPF   EXIT IF *UNITS* INVOLVED 
          NZ     X4,INTLONG  CHECK FOR FLOATING LITERAL 
 INTIN    MX0    -XCODEAL 
          BX0    X0*X1
          NZ     X0,INTLONG  STORE LONG LITERAL IN LIT TABLE
          BX7    X1          0 CODE = SHORT LITERAL CALC
          EQ     INTBOTH
* 
 INTLONG  BX6    X1          (X6) = LITERAL 
          SX1    X4+1        LONG INTEGER CALC
          RJ     SLLIT       (X6) = ADTYPE WITH ADDRESS 
          BX7    X6 
 INTBOTH  SA1    NADS 
          SA7    X1+ADS      STORE LONG LITERAL GETVAR CODE 
          EQ     CMPFCT3
* 
*         HANDLE -ROUND- FUNCTION 
* 
 RNDCMP   RJ     FCCHK       CHECK FOR CONSTANT 
          ZR     X0,ICOMPF
        ZR      X2,INTIN        JUMP IF INTEGER 
          BX1    X3 
          RJ     TRND        ROUND CONSTANT 
          MX4    0           RESULT IS INTEGER
          EQ     INT10
* 
*         HANDLE FRAC FUNCTION
* 
 FRACCMP  RJ     FCCHK       CHECK FOR CONSTANT 
          ZR     X0,COMPFCT 
          NZ     X2,FRACTK   JUMP IF FLOATING 
          SX1    0
          EQ     FRACBTH
 FRACTK   BX1    X3 
          RJ     TFRACX      FRACTIONAL PART OF CONSTANT
 FRACBTH  SX4    10B         RESULT IS FLOATING 
          EQ     INT10
* /---   BLOCK      L/R MASK   00 000   77/12/19  16.43 
          EJECT 
* 
*         HANDLE -LMASK- AND -RMASK- FUNCTIONS
* 
 LMSKCMP  RJ     FCCHK       CHECK FOR CONSTANT 
          ZR     X0,ICOMPF
          ZR     X2,LMSKCM1  JUMP IF INTEGER
          BX1    X3 
          RJ     TRND        CONVERT TO INTEGER 
 LMSKCM1  RJ     TLMASK      CREATE LMASK 
          MX4    0           RESULT IS INTEGER
          EQ     INT10
* 
 MASKERR  EQ     ICOMPF      IF ERROR, LET EXECUTOR GIVE IT.
* 
 RMSKCMP  RJ     FCCHK       CHECK FOR CONSTANT 
          ZR     X0,ICOMPF
          ZR     X2,RMSKCM1  JUMP IF INTEGER
          BX1    X3 
          RJ     TRND        CONVERT TO INTEGER 
 RMSKCM1  RJ     TRMASK      CREATE RMASK 
          MX4    0           RESULT IS INTEGER
          EQ     INT10
* /---   BLOCK      VARLOC     00 000   86/03/12  19.32 
* 
          EJECT 
* 
*         HANDLE -VARLOC- FUNCTION
* 
 VARLCMP  RJ     FCCHK       CHECK FOR CONSTANT 
          NZ     X0,VARCNST  IS A CONSTANT
          NG     X1,VARINRG  EXPRESSION/INDEXED VARIABLE
          SA1    FINDXED     FLAG FOR INDEXED VARIABLE
          ZR     X1,ICOMPF   INDEXED, CREATE CALL TO TVARLOC
* 
          SX4    X4-1 
          ZR     X4,VARL2    IF TYPE 3 GETVAR (COMMON)
          SX1    VARLIM+1 
          IX1    X3-X1
          NG     X1,VARL2    IF STUDENT VAR 
          SA1    ARVARS 
          SA4    ASVARS 
          IX1    X1-X4       X4 NOW BIAS TO NR1 
          IX1    X3-X1
          SX4    X1-RVARLIM-1 
          NG     X4,VARCMPT 
          SA1    ALVARS      TRY LOCAL VARS 
          SA4    ASVARS 
          IX1    X1-X4       X4 NOW BIAS TO NL1 
          IX1    X3-X1
          SX4    X1-LVARLIM-1 
          NG     X4,VARCMPT 
          EQ     ICOMPF 
 
 VARL2    BX1    X3          X3 = THE XCODEAL BITS, INDEX 
          EQ     VARCMPT
* 
 VARINRG  SA1    FINDXED     FLAG FOR IF INDEXED VARIABLE 
          ZR     X1,ICOMPF   INDEXED, CREATE CALL TO TVARLOC
* 
 VARCNST  MX1    0           CONSTANT/EXPRESSION
 VARCMPT  MX4    0           RESULT IS INTEGER
          EQ     INT10
* 
* 
          EJECT 
* 
*         HANDLE FIP FUNCTIONS
* 
 FIPCMP   RJ     FCCHK       CHECK FOR CONSTANT 
          NZ     X0,FIPERR   --- ERROR IF CONSTANT
          NG     X1,FIPCMP2  --- IF EXPRESSION/INDEXED VAR. 
          EQ     ICOMPF      --- CREATE FUNCTION CALL 
* 
 FIPCMP2  SA1    FINDXED     INDEXED VARIABLE FLAG
          NZ     X1,FIPERR   --- ERROR IF EXPRESSION
          EQ     ICOMPF      --- CREATE FUNCTION CALL 
* /---   BLOCK      ICMPNAM    00 000   76/12/11  01.11 
          EJECT 
* 
*         HANDLE INTEGER SPL NAMES LIKE -ANSOK- -WHERE- 
* 
 ICMPNAM  SX7    B0          FLAG INTEGER RESULT
          EQ     CMPNAMI
* 
*         HANDLE FLOATING SPL NAMES -SIZE-CLOCK-PROCTIM-
* 
 COMPNM   SX7    1           FLAG FLOATING RESULT 
          LX7    XCODEAL+3
 CMPNAMI  SA7    FLOAT
          SA1    NADS 
          SX7    X1+1        INCREMENT NADS TO CREATE REFERENCE TO X1 
          SX1    X7-ADSMAX
          PL     X1,LNGERR   ERROR IF TOO MANY ADS
          SA7    A1 
          SB1    1           CHECK THAT REGISTER X1 IS AVAILABLE
          RJ     CHEKRR      MOVE X1 ELSEWHERE IF NECESSARY 
          SA2    NUNITS 
          NG     X2,CMPFCT2  JUMP IF NO UNITS INVOLVED
          RJ     UADZERO     CLEAR UNITS COEFFS 
*          SA1    NARRAYS 
*          NZ     X1,NOAERR   NO ARRAY OPERATIONS ALLOWED YET 
          EQ     CMPFCT2
* 
* 
*I/F MODE OF ARG IRRELEVANT FOR ABS(X) OR COMP(X) 
 IFCOMP   RJ     IFIRR       SET FLOAT SPEC TO OPERAND MODE 
          SX7    B0          FLAG NOT ARRAY OPERATION 
          SA7    FFLT        SET AS INTEGER ARGUMENT
          EQ     CMPF3
* 
 IFIRR    EQ     *           I/F MODE IRRELEVANT
          SA1    NADS        GET OPERAND TYPE 
          SA1    X1+ADS 
          SX0    10B
          LX0    XCODEAL     I/F BIT
          BX7    X0*X1
          SA7    FLOAT       SAVE IN FLOAT FOR RESULT I/F TYPING
          EQ     IFIRR
* 
* 
 ICOMPF   MX7    0           INTEGER RESULT 
          SA7    FLOAT
          SX7    1           THEN PLACE I/F BIT MASK IN X7
          LX7    XCODEAL+3
          EQ     CMPF1
* 
* 
* PROCESS SQRT(X) 
 SQTFCT   SA2    NUNITS 
          NG     X2,COMPFCT  JUMP IF NO UNITS 
          SA3    =.5
          RJ     MULTEM      UNIT DIMENSIONS TIMES .5 
 SQTFCT2  SX7    1           ENTRY POINT FOR X**.5
          LX7    XCODEAL+3
          SA7    FLOAT
          SA1    NADS 
          SA2    X1+ADS      GET OPERAND TO CHECK FOR NEEDED MODE CHANGE
          BX6    X7*X2       GET FLOAT BIT
          SA6    FFLT        SAVE FLOAT BIT 
          EQ     CMPF3
* 
* 
 CONST    SA3    NADS 
          SX7    X3+1        INCREMENT NADS 
          SX6    X7-ADSMAX   ERROR IF TOO MANY ADS
          SA7    A3 
          MX6    0
          SA6    X7+ADS      ADD ADDRESS TO ADS LIST
          SA2    NUNITS 
          NG     X2,CONST1   SEE IF *UNITS* 
          RJ     UADZERO
          EQ     CONST1      'N'O'T'E'; CONSTANT CHECKED FOR SPECIAL'.
* 
* /---   BLOCK      ACMPF30    00 000   78/06/06  21.44 
*         HANDLE ONE-ARGUMENT FUNCTIONS WITH ARRAY OPERANDS 
 ACMPF30  SA1    NADS        ENTER WITH X4=NARRAYS
          SA2    X1+ADS      GETVAR CODE
          LX2    1           LOOK AT WHOLE-ARRAY BIT
          PL     X2,CMPF31   EXIT IF NOT ARRAY
          LX2    59          RESTORE GETVARCODE 
          MX0    -XCODEAL 
          BX2    -X0*X2      GET ARRAYWD ADDR 
          SA2    X2+INFO     GET ARRAYWD
          BX7    X2 
          SA7    ASIZE       SAVE FOR CALCTMP 
          BX6    -X4
          SA6    NARRAYS     - FOR ALOOPS FLAG
          SB1    0           REUSE TMPARRAY 
          RJ     CALCTMP
          RJ     ARYPREP     CLEAR X1,2,6, FORM RJ ABUFCHK
          SB1    RAINIT 
          RJ     LDAINIT     GENERATE ALOOP INITIALIZATION
          SB1    1
          RJ     LDARRAY     GENERATE LOAD OPERAND TO X1
          SA1    SAVEOP 
          SX0    X1-FUNCT0   GET FUNCTION NUMBER
          RJ     GENFCT      GENERATE RJ FUNCTION 
          SX7    10611B 
          RJ     SHORT       GENERATE CODE FOR  BX6 X1
          RJ     TMPAD       CHANGE ADTYPE TO TEMP ARRAY
          PLATO 
          SA1    PRELEX 
          NG     X1,ENDINSA  QUIT IF REGULAR LEX CALL 
          SA1    NCOMPIL     MAKESURE COMPIL HAS RJ LEX 
          BX7    X1 
          SA7    COMPIL 
          ENDIF 
          EQ     ENDINSA     GO DO ALOOP
* 
* 
*         HANDLE ONE-ARGUMENT FUNCTION CALLS
* 
 COMPFCT  SX7    1           FLAG AS FLOATING RESULT
          LX7    XCODEAL+3
          SA7    FLOAT
 CMPF1    SA1    NADS 
          SA2    X1+ADS      GET OPERAND TO CHECK FOR NEEDED MODE CHANGE
          BX6    X7*X2       GET FLOAT BIT
          SA6    FFLT        SAVE FLOAT BIT 
          SA2    NUNITS 
          NG     X2,CMPF3    JUMP IF NO UNITS 
          RJ     ZEROU       CHECK FOR ZERO UNIT COEFFS 
* 
 CMPF3    SA1    INHAND      RESTORE CORRECT INHAND PRECEDENCE LEVEL
          SA1    X1+PRECED   BECAUSE WE MAY BE COMPILING
          BX7    X1          A PARENS-LESS FUNCTION.
          SA7    INHANDL     (SEE -ISFUNCT- CODE ABOVE) 
          SA4    NARRAYS
          NZ     X4,ACMPF30  JUMP IF ARRAY OPS IN PROGRESS
 CMPF31   SB1    1
          RJ     FORCEX      FORCE ARG INTO X1
 CMPFCT2  RJ     SETAD       SET AD REFERENCE IN ADS LIST 
 CONST1   SA1    SAVEOP 
          SX0    X1-FUNCT0   GET FUNCTION NUMBER
          RJ     GENFCT      GENERATE CODE TO LOAD FN TO X1 
 CMPFCT3  BSS    0
          PLATO 
          SA1    PRELEX 
          NG     X1,ENDINST  JUMP IF PREAD AND PREOP CONTAIN INFO 
          SA1    NCOMPIL     ELSE INSURE LOCATION COMPIL CONTAINS RJ LEX
          BX7    X1 
          SA7    COMPIL 
          ENDIF 
          EQ     ENDINST
* /---   BLOCK      ARAYFN     00 000   77/12/19  16.51 
          EJECT 
* 
*         SCALAR RESULT ARRAY FUNCTIONS 
* 
 ARAYFN   SA1    NADS 
          SA2    X1+ADS      OPERAND ADTYPE 
          MX0    -XCODEAL 
          MX7    1
          LX7    XCODEAL+4   I/F BIT MASK 
          BX7    X7*X2       I/F BIT OF OPERAND 
          SA7    FLOAT       SAVE IT FOR SETAD
          BX6    -X0*X2 
          LX2    1
          PL     X2,NOTARFN 
          SA1    X6+INFO     GET ARRAYWD
          BX6    X1 
          SA6    ASIZE       SAVE IT
* 
          SA3    SAVEOP 
          SX6    X3-ASUMOP   GET RELATIVE ARAYFN NUMBER 
          IX6    X6+X6       INTEGER ARAYFN TYPE
          ZR     X7,ARAYF10  JUMP IF INTEGER TYPE 
          SX6    X6+1        ADD 1 TO TYPE NUM IF FLOATING
 ARAYF10  SA6    IOP         SAVE TYPE
          NG     X6,COMPERR 
          SX6    X6-12       ONLY ARAYFNTYPES 0-11 LEGAL YET
          PL     X6,COMPERR 
          RJ     ARYPREP     CLEAR X1,2,6, FORM RJ ABUFCHK
* /---   BLOCK      ARAYFN10   00 000   76/07/29  00.06 
          SA1    ASIZE       GET BACK ARRAYWD 
          LX1    3
          PL     X1,ARAYF20   JUMP IF NOT SEGMENTED ARRAY 
* 
          RJ     ASEGTMP     CHANGE SEG ARRAY TO REAL TEMP. 
* 
 ARAYF20  SA1    IOP         GET TYPE 
          SX7    6120B       SB2 B0+... 
          LX7    18 
          BX7    X7+X1
          RJ     LONGI       GENERATE  SB2 (ARAYFN TYPE)
* 
          SA1    NADS 
          SA1    X1+ADS      ARRAY ADTYPE 
          RJ     GETARAD     X3=ARAYSTART ADDR
* 
          SX7    5100B
          LX7    18 
          BX7    X7+X3
          RJ     LONGI       GENERATE SA0(ARAY ADDR)
          SA1    ASIZE       GET BACK ARRAYWORD 
          MX0    -9 
          AX1    45 
          BX1    -X0*X1      SIZE FIELD 
          SX7    6110B       SB1 B0+... 
          LX7    18 
          BX7    X7+X1
          RJ     LONGI       GENERATE SB1 SIZE
          SB1    RARAYFN
          RJ     LDASUB      GENERATE RJ ARAYFN 
          RJ     SETAD       RESULT LEFT IN X1
          SA1    NARRAYS
          SX7    X1+1 
          SA7    NARRAYS     INCREMENT NUMBER ARRAY OPNS
          EQ     CMPFCT3
* 
 NOTARFN  SB1    1           IS SCALAR OPERAND
          RJ     FORCEX      RETURN RESULT=OPERAND
          RJ     SETAD       IN X1
          EQ     CMPFCT3
* 
*  NEXT SUBROUTINE CONVERTS SEGMENTED TO TEMPORARY REALARRAY
* 
 ASEGTMP  EQ     *           (SET ASIZE=ARAYWD BEFORE ENTRY)
          SB1    RAINIT      GENERATE RJ AINIT
          RJ     LDAINIT
          SB1    1           GENERATE CODE TO LOAD AND
          RJ     LDARRAY     CONVERT SEG ARAY TO INTEGER
          SB1    1
          RJ     CALCTMP     FORCE NEW TMPARRAY ADDRESS 
          RJ     TMPAD       FORM NEW TMPARRAYWD AND ADTYPE 
          SX7    10611B      GENERATE   BX6 X1
          RJ     SHORT
          SA1    TMPARAY     STORE ADDRESS
          RJ     LDALOOP
*  NOTE...DONT HAVE TO RJ AIFBIT SINCE RESULT IS INTEGER
          RJ     LDAINTR     GENERATE TIMESLICE CHECK 
          EQ     ASEGTMP
* 
* /---   BLOCK      ARAYTRSP   00 000   76/07/29  01.19 
* 
 ATRANSP  SX7    4           'TRANSP('A) TYPE FOR DOTMULT 
          SA7    IOP         SAVE IT
 ATRA2    SA1    NADS 
          SA2    X1+ADS      OPERAND ADTYPE 
          LX2    1           TEST WHOLEARRAY BIT
          PL     X2,NOTATRA  JUMP IF SCALAR 
          LX2    59 
          MX0    -XCODEAL 
          BX1    -X0*X2 
          SA2    X1+INFO     ARRAY INFO WORD
**
          BX7    X2 
          LX7    3
          PL     X7,ATRA3    JUMP IF NOT SEGMENTED
          BX7    X2 
          SA7    ASIZE       SAVE IT FOR CALCTMP
          RJ     ARYPREP     CLEAR X1,X2,X6, FORM RJ ABUFCHK
          RJ     ASEGTMP     CONVERT SEG ARAY TO REAL TEMP
          SA2    ASIZE       RESTORE INFO 
**
 ATRA3    BX0    X2          SAVE IT
          MX6    -9 
          AX2    27 
          BX4    -X6*X2      COLS 
          AX2    9
          BX7    -X6*X2      ROWS 
          AX2    9
          BX6    -X6*X2      SIZE 
          MX3    -18
          LX3    27          ROWCOL MASK
          SB1    5
          SA1    IOP         FN TYPE
          SB3    X1 
          EQ     B3,B1,DOTM21   JUMP IF REV(X)
          BX0    X3*X0       CLEAR OUT ROW/COL
          BX1    X4 
          LX1    9
          BX1    X1+X7
          LX1    27 
          BX0    X1+X0       RESULT HAS COLS/ROWS REVERSED
          EQ     DOTM21      GENERATE CALL TO DOTPROD 
* 
 ATRACE   EQ     TSTERR      TRACE
* 
 AREVERS  SX7    5           'REV('A) TYPE FOR DOTPROD
          SA7    IOP         SAVE IT
          EQ     ATRA2
* 
 NOTATRA  MX0    1
          LX0    XCODEAL+4   I/F BIT MASK 
          LX2    59          RESTORE ADTYPE 
          BX7    X0*X2       OPERAND I/F TYPE 
          SA7    FLOAT       SAVE FOR SETAD 
          EQ     NOTARFN     RESULT=OPERAND 
* /---   BLOCK      INDEXEDVAR 00 000   78/09/19  20.26 
          TITLE  INDEXED VARIABLES
* 
*         DESPITE THE LABELS, THIS BLOCK OF CODE CONCERNS 
*         INDEXED VARIABLES, NOT REAL/COMPLEX ARRAYELEMENTS 
*         SEE *ISARRAY* *MATRAY* ETC FOR THOSE
* 
* 
 ARAYN    EQ     *           RETURN WITH LITERAL INDEX
          MX6    59 
          SA6    FINDXED     FLAG NON-INDEXED VARIABLE
*INDEX RETURNED IN X6 (NEGATIVE IF NOT LITERAL) 
          SA2    NUNITS 
          NG     X2,ARAYN1
          RJ     ZEROU       CHECK FOR ZERO UNIT COEFFS 
 ARAYN1   SA1    NADS        CHECK FOR LITERAL
          SA2    X1+ADS 
          BX6    X2          A COPY OF GETVAR CODE
          NG     X2,ARAYN3   NOT LITERAL IF IN REGISTER 
          AX2    XCODEAL     SHIFT OUT GETVAR ADDRESS 
          ZR     X2,ARAYN    IF SHORT LITERAL, EXIT WITH INDEX IN X6
          MX1    -4          ISOLATE TYPE CODE
          BX2    -X1*X2 
          SX7    X2-1 
          NZ     X7,ARAYN2   JUMP IF NOT LONG INTEGER 
          BX1    X6 
          RJ     RLLIT       (X6) = LITERAL 
          NG     X6,VARERR
          EQ     ARAYN
 ARAYN2   SX7    X2-11B      CHECK FOR FLOATING LITERAL 
          NZ     X7,ARAYN3   JUMP IF NOT FLOATING LITERAL 
          BX1    X6 
          RJ     RLLIT       (X6) = LONG LITERAL
          NG     X6,VARERR
          SA3    =.5         ROUND THE FLOATING LITERAL 
          FX6    X6+X3
          UX6    X6,B2       FIX THE FLOATING LITERAL 
          LX6    X6,B2       LEAVE IN X6
          EQ     ARAYN       RETURN INDEX IN X6 
 ARAYN3   LX6    1           WHOLE-ARRAY BIT AT TOP 
          NG     X6,NOAERR   INDEX CANT BE WHOLE-ARRAY
          MX6    59          SET X6 NEGATIVE TO SIGNAL NOT LITERAL
          EQ     ARAYN
* 
* 
 ARYII    RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA0    VARLIM      STUDENT VAR LIMIT
          SA1    ASVARS 
          BX7    X1          ADDRESS OF STUDENT BANK VARS 
          SA7    IOP
          NG     X6,IARRAY   JUMP IF NOT LITERAL INDEX
          SX7    2           STUDENT BANK INTEGER 
 ARYV     LX7    XCODEAL
          BX7    X7+X6
          SA7    A2          REPLACE ADS REFERENCE (A2 SET BY ARAYN)
          CALL   VBOUND      CHECK STUDENT BANK BOUNDS
          EQ     ENDINST     VBOUND WILL EXIT TO VARERR IF NO GOOD
* 
 ARYFI    RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA0    VARLIM      STUDENT VAR LIMIT
          SA1    ASVARS 
          BX7    X1          ADDRESS OF STUDENT BANK VARS 
          SA7    IOP
          NG     X6,FARRAY   JUMP IF NOT LITERAL INDEX
          SX7    12B         STUDENT BANK FLOATING
          EQ     ARYV 
* 
* /---   BLOCK      RARRAY     00 000   79/02/09  12.09 
* 
 ARYCII   RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA0    NCVRLIM     INDEX LIMIT
          SA1    ACVARS 
          BX7    X1          ADDRESS OF COMMON VARS 
          SA7    IOP
          NG     X6,IARRAY   JUMP IF NOT LITERAL INDEX
          SX7    3           COMMON INTEGER 
 ARYC     LX7    XCODEAL
          BX7    X7+X6
          SA7    A2          REPLACE ADS REFERENCE (A2 SET BY ARAYN)
          CALL   CBOUND      CHECK STUDENT BANK BOUNDS
          EQ     ENDINST     CBOUND WILL EXIT TO VARERR IF NO GOOD
* 
 ARYCFI   RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA0    NCVRLIM     INDEX LIMIT
          SA1    ACVARS 
          BX7    X1          ADDRESS OF COMMON VARS 
          SA7    IOP
          NG     X6,FARRAY   JUMP IF NOT LITERAL INDEX
          SX7    13B         COMMON FLOATING
          EQ     ARYC 
* 
* 
 RARRAY   RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA1    ARVARS 
          BX7    X1          ADDRESS OF R-VARIABLES 
          SA7    IOP
          SA1    RVARL       GET NUMBER OF R-VARIABLES
          SA0    X1 
          NG     X6,IARRAY   JUMP IF NOT LITERAL INDEX
          MX7    0
          SA7    FLOAT       MARK AS INTEGER
          SA7    FINDXED     FLAG EXECUTION TIME VARIABLE 
* 
 NRK      CALL   RBOUND      CHECK BOUNDS 
          SA1    ASVARS      COMPUTE BIAS TO R-VARS 
          SA3    ARVARS 
          IX1    X3-X1
          IX6    X1+X6       ADD BIAS TO INDEX
          SX7    2
          LX7    XCODEAL     TYPE 2 = STUDENT BANK
          SA1    FLOAT
          BX7    X1+X7       MERGE I/F BIT AND TYPE 
          BX7    X6+X7       ATTACH ADDRESS 
          SA1    NADS 
          SA7    X1+ADS      REPLACE ENTRY IN ADDRESS STACK 
          EQ     ENDINST
* 
 RFARRAY  RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA1    ARVARS 
          BX7    X1          ADDRESS OF R-VARIABLES 
          SA7    IOP
          SA1    RVARL       GET NUMBER OF R-VARIABLES
          SA0    X1 
          NG     X6,FARRAY   JUMP IF NOT LITERAL INDEX
          MX7    0
          SA7    FINDXED     FLAG EXECUTION TIME VARIABLE 
          SX7    1
          LX7    XCODEAL+3   MARK AS FLOATING 
          SA7    FLOAT
          EQ     NRK
 LARRAY   RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA1    ALVARS 
          BX7    X1          ADDRESS OF L-VARIABLES 
          SA7    IOP
          SA1    LVARN       X1 = NUMBER OF L-VARIABLES 
          SA0    X1 
          NG     X6,IARRAY   JUMP IF NOT LITERAL INDEX
* 
          MX7    0
          SA7    FLOAT       MARK AS INTEGER
          SA7    FINDXED     FLAG EXECUTION TIME VARIABLE 
* 
* /---   BLOCK      RARRAY     00 000   78/09/19  20.28 
 NLK      RJ     =XLBOUND    CHECK BOUNDS 
          SA1    ASVARS      COMPUTE BIAS TO L-VARS 
          SA3    ALVARS 
          IX1    X3-X1
          IX6    X1+X6       ADD BIAS TO INDEX
          SX7    2
          LX7    XCODEAL     TYPE 2 = N(I) REFERENCE
          SA1    FLOAT
          BX7    X1+X7       MERGE I/F BIT AND TYPE 
          BX7    X6+X7       ATTACH ADDRESS 
          SA1    NADS 
          SA7    X1+ADS      REPLACE ENTRY IN ADDRESS STACK 
          EQ     ENDINST
* 
 LFARRAY  RJ     ARAYN       CHECK FOR LITERAL INDEX
          SA1    ALVARS 
          BX7    X1          ADDRESS OF L-VARIABLES 
          SA7    IOP
          SA1    LVARN       X1 = NUMBER OF L-VARIABLES 
          SA0    X1 
          NG     X6,FARRAY   JUMP IF NOT LITERAL INDEX
* 
          MX7    0
          SA7    FINDXED     FLAG EXECUTION TIME VARIABLE 
          SX7    1           MARK AS FLOATING 
          LX7    XCODEAL+3
          SA7    FLOAT
          EQ     NLK
* 
* /---   BLOCK      IARRAY     00 000   79/02/09  12.10 
* 
 IARRAY   SX7    B0          INTEGER INDEXED VARIABLE 
          EQ     SCARRAY
 FARRAY   SX7    1           FLOATING INDEXED VARIABLE
          LX7    XCODEAL+3   FORM FLOAT BIT 
 SCARRAY  SA7    FLOAT       FLOAT=0/1 FOR I/F
          SB1    1           STUDENT OR COMMON ARRAY
          RJ     GENREAD     READ INDEX INTO X1 
          RJ     FREEX       FREE REGISTER WHICH NOW HOLDS INDEX
          MX6    0
          SA6    FINDXED     FLAG INDEXED VARIABLE IN X1
          SA1    NADS        DETERMINE WHETHER INDEX IS I OR F
          SA1    X1+ADS      GET OPERAND
          LX1    59-XCODEAL-3  SHIFT I/F BIT INTO SIGN BIT
          PL     X1,SCARAY2  JUMP IF INTEGER INDEX
          RJ     INDXFLT     ROUND INDEX
* 
 SCARAY2  SX7    B1          CONSTRUCT -SB1 XN- (INDEX IS IN XN)
          LX7    3
          SX7    X7+63100B   FORM SB1 XN+B0 
          RJ     SHORT       SHORT PRESERVES B1 
          SX7    A0          VARLIM OR NCVRLIM--INDEX LIMIT 
          SX6    612B        FORM SB2 VARLIM OR SB2 NCVRLIM 
          LX6    21 
          BX7    X6+X7       30-BIT INSTRUCTION 
          RJ     LONGI
          SA1    LLAERR      ADDRESS OF -ARAYERR- 
          SX6    0601B       GE B0,B1,ARAYERR 
          LX6    18 
          BX7    X1+X6
          RJ     LONGI
          SA1    LLAERR      ADDRESS OF -ARAYERR- 
          SX6    0721B       LT B2,B1,ARAYERR 
          LX6    18 
          BX7    X6+X1
          RJ     LONGI
          SA1    IOP         PICK UP BASE VARIABLE ADDRESS
          SX7    5111B
          LX7    18          FORM A  SA1  B1+K
          BX7    X1+X7
          RJ     LONGI
          SA1    FLOAT
          SX7    4           FLAG ARRAY AS TYPE 4 GETVAR CODE 
          LX7    XCODEAL
          BX7    X1+X7
          SA7    A1          SETAD WILL MERGE FLOAT WITH SIGN BIT 
          RJ     SETAD       SET AD REFERENCE 
          EQ     ENDINST
* 
* /---   BLOCK      SEGMENT    00 000   77/12/18  17.17 
          TITLE  SEGMENT INDEXING 
*         PRE-CHECK TO SEE IF SEGMENT WILL BE STORED INTO 
* 
 SEGRAY   SB2    SEGRAY1
          RJ     NESTCHK
          EQ     SEGPUT 
* 
*         SUBROUTINE TO CHECK IF NESTED SEG/ARRAY OPS 
*         B2 CONTAINS NESTED EXIT, B1 SAVES OP
 NESTCHK  EQ     *           EXITS HERE IF NOT NESTED 
          SA1    INHAND      LOAD FORCING OPERATOR
          SX7    X1-OPASIGN 
          NZ     X7,PARCHK   JUMP IF NOT ASSIGN 
          SA1    NOPS 
          SX1    X1-1        BACK UP TO PREVIOUS OP 
          ZR     X1,NESTCHK  ASSIGN INTO IF THIS IS LAST OP 
          SA1    X1+OPS 
          SX2    X1-OPSEG    CHECK FOR NESTING
          ZR     X2,NESTOUT  JUMP OUT IF NESTED ARRAY/SEG 
          SX2    X1-OPMAT 
          ZR     X2,NESTOUT 
          SX2    X1-OPVEC 
          ZR     X2,NESTOUT 
          SX2    X1-OPSCAL
          ZR     X2,NESTOUT 
          SX2    X1-ARAYOP
          ZR     X2,NESTOUT 
          SX2    X1-ARAYOP-1
          ZR     X2,NESTOUT 
          SX2    X1-CARAYOP 
          ZR     X2,NESTOUT 
          SX2    X1-CARAYOP-1 
          ZR     X2,NESTOUT 
          SX2    X1-RARAYOP 
          ZR     X2,NESTOUT 
          SX2    X1-RARAYOP-1 
          ZR     X2,NESTOUT 
          SX2    X1-LARAYOP 
          ZR     X2,NESTOUT 
          SX2    X1-LARAYOP-1 
          ZR     X2,NESTOUT 
          SB2    B0          FLAG TO MARK ASSIGNED INTO 
          EQ     NESTCHK
*                            CHECK FOR (SEG) OR (ARRAY) 
 PARCHK   SX7    X1-OP)      INSIDE NESTED PARENS 
          NZ     X7,NESTOUT  JUMP IF NO RT PAREN
          SA1    NOPS 
          SX1    X1-1        BACK UP TO PREVIOUS OPERATOR 
          ZR     X1,BADPAR   UNBALANCED PARENS IF NO OP 
          SA2    X1+OPS      LOAD PREVIOUS OPERATOR 
          SX2    X2-OP( 
          NZ     X2,NESTOUT  EXIT IF NOT LEFT PAREN 
          SX6    B1          OP WAS IN B1(ALSO IN SAVEOP) 
          SA6    X1+OPS      MOVE BACK -ARRAY- OPCODE 
          SA3    X1+OPSL+1   LOAD ARRAY PRECEDENCE
          BX6    X3 
          SA6    X1+OPSL     MOVE BACK ARRAY PRECEDENCE 
          SA6    PREVOPL
          BX7    X1          UPDATE *NOPS*
          SA7    A1 
          SA1    TOPCNT 
          SX6    X1-2        DECREMENT *OPCNT* FOR () 
          SA6    A1 
          MX6    0
          SA6    LASTOP      FOR UNARY + AND - CHECKS 
          EQ     COMPIL 
* 
 NESTOUT  JP     B2          GO COMPILE SEG/ARRAY 
* 
* /---   BLOCK      SEGMENT    00 000   78/09/15  17.05 
* 
*         COMPILE CODE TO LOAD SEGMENT TO X1
* 
 SEGRAY1  MX7    0           SET FOR INTEGER
          SA7    FLOAT
          SA1    NADS 
          SX7    X1-1        MUST BE TWO ADDRESSES
          NG     X7,SEGERR
          ZR     X7,SEGERR
          MX0    -XCODEAL 
          SA2    X7+ADS      LOAD ADTYPE OF INFO WORD 
          BX0    -X0*X2      MASK OFF ADDRESS OF LITERAL
          SA2    X0+INFO     LOAD SEGMENT INFO WORD 
          BX6    X2 
          SA6    SEGWD
          LX6    2           POSITION -VERTICAL- BIT
          NG     X6,SEGVERT 
* 
          CONDEN
          SA1    X1+ADS      LOAD INDEX ADTYPE
          BX2    X1 
          AX2    XCODEAL     POSITION TYPE CODE 
          ZR     X2,SCONST   TREAT CONSTANT INDEX SPECIALLY 
          ENDIF 
* 
 SEG05    SB1    1           READ INDEX TO X1 
          RJ     FORCEX 
          SA1    NADS 
          SX7    X1-1        BACK UP IN ADDRESS STACK 
          SA7    A1 
          SA1    X1+ADS      SEE IF INDEX IS I OR F 
          LX1    59-XCODEAL-3 
          PL     X1,SEG10    JUMP IF INTEGER INDEX
          RJ     INDXFLT     ROUND FLOATING TO INTEGER
* 
 SEG10    RJ     LDLITAD     GENERATE (SB1 SEG LITWD ADDR)
          SA1    LLSEGI      RJ ADDRESS 
          SX7    0100B
          LX7    18          POSITION RJ OPERATION CODE 
          BX7    X1+X7       GENERATE RJ SEGMNTI
          RJ     LONGI
          RJ     PAD
*         SCONST COMES HERE TOO...
 SEG20    SX7    1           SET UP GETVAR CODE FOR LITERAL 
          LX7    14 
          SA7    FLOAT
          RJ     SETAD       CHANGE SEGMENT ENTRY TO LITERAL
          MX6    0
          SA6    FINDXED     FLAG INDEXED VARIABLE *SIGH* 
          EQ     ENDINST
* /---   BLOCK      SEGMENT    00 000   77/12/18  17.19 
          TITLE  GENERATE CODE FOR CONSTANT INDEX CASE
* 
*         PRODUCE CODE FOR LOAD OF CONSTANT INDEX CASE
* 
          CONDEN
 SCONST   SA2    NADS 
          SX7    X2-1        BACK UP IN ADDRESS STACK 
          SA7    A2 
          SX1    X1-1        COMPUTE INDEX
          NG     X1,VARERR
          PX7    X1          CONVERT INDEX TO FLOATING
          NX7    X7 
          SA3    =0.01       AVOID ROUND-OFF ERROR
          FX3    X3+X7
          NX3    X3 
          SA2    SEGWD       LOAD SEGMENT INFO WORD 
          SX7    X2          PICK OFF BYTES/WORD
          PX6    X7 
          NX6    X6          CONVERT TO FLOATING
          FX3    X3/X6       COMPUTE WORD COUNT 
          UX3    X3,B2
          LX3    X3,B2       X3 = WORD COUNT
          DX7    X3*X7
          IX7    X1-X7       X7 = REMAINDER 
          SA7    SEGWD1 
          AX2    18          BIAS TO START OF ARRAY 
          SX6    X2 
          IX6    X3+X6       COMPUTE INDEX
          PL     X2,SCSVAR   STUDENT BANK OR ROUTER VARIABLE
          CALL   CBOUND      CHECK AGAINST COMMON BOUNDS
          SA1    ACVARS      BASE ADDRESS FOR COMMON
          EQ     SCSA1
* 
 SCSVAR   SB1    X2-VARLIM-1 CHECK BASE ADDRESS 
          PL     B1,SCRVAR   JUMP IF ROUTER VARIABLE
          CALL   VBOUND      CHECK STUDENT BANK BOUNDS
          EQ     SCSTUD 
* 
 SCRVAR   SA1    ASVARS      ADDRESS OF STUDENT VARIABLES 
          SA3    ARVARS      ADDRESS OF ROUTER VARIABLES
          IX1    X3-X1
          BX7    X6          SAVE ADDRESS REL TO STUDENT
          IX6    X6-X1       SUBTRACT OFF R-VARIABLE BIAS 
          SB1    X6-RVARLIM-1 CHECK BASE ADDRESS
          PL     B1,SCLVAR   JUMP IF LOCAL VARIABLE 
* 
          CALL   RBOUND      CHECK ROUTER VARIABLE BOUNDS 
          BX6    X7 
          EQ     SCSTUD 
* 
 SCLVAR   SA1    ASVARS      ADDRESS OF STUDENT VARIABLES 
          SA3    ALVARS      ADDRESS OF LOCAL VARIABLES 
          IX1    X3-X1
          BX6    X7          RESTORE ADDRESS REL TO STUDENT 
          IX6    X6-X1       X6 = LOCAL BANK INDEX
          RJ     =XLBOUND    CHECK LOCAL VARIABLE BOUNDS
          BX6    X7 
          EQ     SCSTUD 
* 
* 
* /---   BLOCK      SEGVERT    00 000   78/01/25  16.20 
* 
 SCSTUD   SA1    ASVARS      BASE ADDRESS FOR STUDENT/ROUTER
* 
 SCSA1    IX6    X1+X6       ABSOLUTE ADDRESS TO LOAD 
          SA6    IOP
          SB1    1           OBTAIN READ REGISTER 
          RJ     CHEKRR 
          SX7    1           MARK REGISTER IN USE 
          SA7    B1+RX
          SX6    B1          SAVE REGISTER NUMBER 
          SA6    FREG 
          LX6    3           POSITION REGISTER NUMBER 
          SX7    X6+5100B    GENERATE A  SAN  B0+K
          SA1    IOP
          LX7    18          POSITION INSTRUCTION CODE
          BX7    X1+X7       ATTACH ADDRESS PORTION 
          RJ     LONGI
* 
          SA1    SEGWD
          LX1    1           SIGNED BIT 
          NG     X1,SCSA2    SKIP IF SIGNED SEGMENT 
          SB1    2
          RJ     CHEKRR      RESERVE X2 FOR MASK
          SX7    1
          SA7    B1+RX       MARK BUSY
          SA1    SEGWD
          LX1    1           GET INFO WORD BACK 
 SCSA2    AX1    18+18+1
          SX3    X1          PICK OFF BITS/BYTE COUNT 
          SB2    X1 
          SA2    SEGWD1      LOAD BYTE INDEX
          DX6    X2*X3       SHIFT COUNT TO LEFT-JUSTIFY
          SB1    X6 
          EQ     SEGVER3     GENERATE CODE TO EXTRACT SEGMT 
* 
          ENDIF 
* /---   BLOCK      SEGVERT    00 000   78/01/25  14.09 
          TITLE  GENERATE CODE TO LOAD VERTICAL SEGMENT 
* 
*         COMPILE CODE TO LOAD VERTICAL SEGMENT 
* 
 SEGVERT  RJ     VSINDX      GENERATE CODE TO LOAD INDEX
          SA1    NADS 
          SX6    X1-1        BACK UP IN ADDRESS STACK 
          SA6    A1 
          SA1    SEGWD       LOAD SEGMENT INFO WORD 
          LX1    1           PUTS SIGNBIT AT LEFT 
          NG     X1,SEGVER2  SKIP IF SIGNED 
          SB1    2
          RJ     CHEKRR      RESERVE X2 FOR MASK
          SX7    1
          SA7    B1+RX       MARK BUSY
 SEGVER2  SA1    SEGWD       HERE WE GO AGAIN 
          SB1    X1-1        STARTBIT-1 = LEFTJUSTIFY SHIFT 
          LX1    1           PUTS SIGNBIT AT LEFT 
          AX1    18+18+1     POSITION BITS / BYTE COUNT 
          SB2    X1          BITS/BYTE
 SEGVER3  SA0    112B        SPECIFY MASKREG=X2, WORD REG=X1
* 
          RJ     VREAD       GENERATE VERTSEG EXTRACT CODE
* 
* HERE, IF THE SEGMENT WAS SIGNED, X2 DIDN'7T GET CHECKED.
* THIS MAY CAUSE A PROBLEM SOMEDAY, AND TRYING TO HELP... 
          SB1    2
          RJ     FREEX       RELEASE MASK REGISTER
          EQ     SEG20
* 
* /---   BLOCK      SVCONST    00 000   79/02/09  12.11 
          CONDEN
          TITLE  GENERATE CODE FOR CONSTANT VERTICAL SEGMENT
* 
*         PRODUCE CODE FOR CONSTANT INDEX VERTICAL SEGMENT
* 
 SVCONST  ZR     X2,VARERR   ERROR IF INDEX ZERO
          SB1    X2-1 
          SA3    SEGWD       LOAD SEGMENT INFO WORD 
          AX3    18          POSITION BASE ADDRESS
          SX6    X3+B1       INDEX + RELATIVE BASE ADDRESS
          NG     X3,SVCC     JUMP IF -NC- VARIABLE
          SA1    ASVARS 
          IX7    X1+X6       COMPUTE ABSOLUTE ADDRESS 
          SA7    SEGWD1 
          SB2    X3-VARLIM-1
          PL     B2,SVCR     JUMP IF -NR- VARIABLE
          SX1    VARLIM      SET END TEST 
          EQ     SVC100 
* 
 SVCR     IX3    X3+X1       CM ADDR OF BASE
          SA2    ARVARS      CM ADDR OF RVARS 
          IX2    X3-X2       NR INDEX 
          SB2    X2-RVARLIM-1 
          PL     B2,SVCL     IF COULD BE IN LOCAL VAR BANK
* 
          SA1    RVARL       X1 = MAX RVAR INDEX
          SX6    X2+B1       X6 = RVAR INDEX
          EQ     SVC100 
* 
 SVCL     SA2    ALVARS      CM ADDR OF LVARS 
          IX2    X3-X2       NL INDEX 
          SA1    LVARN       X1 = MAX LVAR INDEX
          SX2    X2 
          IX3    X1-X2
          NG     X3,VARERR
          SX6    X2+B1       X6 = LVAR INDEX
          EQ     SVC100 
* 
 SVCC     SA3    ACVARS 
          IX7    X3+X6       COMPUTE ABSOLUTE BASE ADDRESS
          SA7    SEGWD1 
          SX1    NCVRLIM     SET END TEST 
* 
 SVC100   IX0    X1-X6       CHECK IF INDEX IN BOUNDS 
          NG     X0,VARERR
 SVC110   SB1    1
          CALL   CHEKRR      OBTAIN REGISTER X1 FOR READ
          SX6    1
          SA6    RX+1        MARK REGISTER IN USE 
          SA1    SEGWD1 
          SX7    5110B       GENERATE  SA1  B0+ADDRESS
          LX7    18 
          BX7    X1+X7       ATTACH ABSOLUTE ADDRESS
          CALL   LONGI
          EQ     VSINDX 
* 
          ENDIF 
* 
* /---   BLOCK      SEGPUT     00 000   77/12/18  17.24 
          TITLE  SEGPUT 
* 
*         SWITCH SEGMENT AND INDEX ADTYPES FOR LATER
*         ASSIGNMENT OPERATION
* 
 SEGPUT   SA1    NADS 
          SX7    X1-1        BACK UP INDEX IN ADDRESS STACK 
          NG     X7,SEGERR
          ZR     X7,SEGERR
          SA3    X1+ADS      LOAD ADTYPE OF INDEX EXPRESSION
          SA2    X1+ADS-1    GET SEGMENT ADTYPE 
          BX6    X2 
          SA6    X1+ADS      MOVE ADTYPE DOWN IN STACK
          BX6    X3 
          SA6    X1+ADS-1    MOVE INDEX UP IN STACK 
          EQ     ENDINST
* /---   BLOCK      GETARY     00 000   77/12/18  17.22 
          TITLE  ARRAY/COMPLEX INDEXING 
* 
*         SUBROUTINE TO PUT ARAYWD IN X1, ARAYWD2 OR 0 IN X2
*         ENTER WITH NADS OF ARAYWD IN X7 (DONT CHANGE X6)
 GETARY   EQ     *
          SA1    X7+ADS      LOAD ARRAY ADTYPE
          MX0    -XCODEAL    MASK OUT ADDRESS 
          BX2    -X0*X1      OF INFO WORD 
          SA1    X2+INFO     GET ARRAYWD IN X1
          MX2    0
          BX7    X1 
          LX7    4
          MX0    -2 
          BX7    -X0*X7      MASK OFF BASE+SEG BITS 
          ZR     X7,GETARY   IF NO ARAYWD2, EXIT WITH X2=0
          SA2    A1+1        ARAYWD2 STORED AFTER ARAYWD
          EQ     GETARY 
* 
*         GETS ARAYWD AND PUTS IN X4   X7 HAS NADS
*         DONT TOUCH X1,X2,X3,X7
 GETARY4  EQ     *
          SA4    X7+ADS      LOAD ARRAY ADTYPE
          MX0    -XCODEAL    MASK OUT ADDRESS 
          BX4    -X0*X4      OF INFO WORD 
          SA4    X4+INFO     GET ARRAYWD IN X4
          EQ     GETARY4
* 
* /---   BLOCK      MATRAY     00 000   78/09/15  17.09 
          TITLE  ARRAY PROCESSING 
* 
*         PRE-CHECK TO SEE IF ARRAY WILL BE STORED INTO 
* 
 MATRAY   SB2    MATRAY1
          RJ     NESTCHK     SETS B2=0 IF ASSIGNED INTO 
* 
 MATRAY1  SA3    NADS        MUST HAVE 2INDEX + ARRAYWD 
          SX7    X3-3        SO CHECK FOR 3 ADS 
          NG     X7,MATERR
* 
          CONDEN
          SA1    X3+ADS      LOAD 2D INDEX AD (COL) TO X1 
          SA2    A1-1        AND 1ST INDEX AD (ROW) TO X2 
          BX7    X1 
          AX7    XCODEAL+1   POSITION UPPER 2 GETVAR BITS 
          NZ     X7,MATRAY3  JUMP IF NOT CONSTANT 
          BX7    X2 
          AX7    XCODEAL+1
          ZR     X7,MCONST   JUMP IF BOTH INDICES CONST 
          ENDIF 
* 
 MATRAY3  ZR     B2,MATPUT   JUMP IF ASSIGNED INTO
          SB1    4
          RJ     LOADIND     LOAD COL INDEX TO X4 
          RJ     POPNADS     BACK UP TO ROW INDEX 
          SB1    3
          RJ     LOADIND     LOAD ROW INDEX TO X3 
          RJ     POPNADS     BACK UP TO ARRAY ADTYPE
          RJ     LDLITAD     LOAD ARAYWD ADDR TO B1 
          SB1    1
          RJ     CHEKRR      CLEAR X1 FOR RESULT
          SB1    4
          RJ     FREEX       RELEASE X4 (RISKY'/) 
          SA1    LLMATEL     RJ ADDRESS 
 MATRAY5  SX7    0100B
          LX7    18          POSITION RJ OPERATION CODE 
          BX7    X1+X7       GENERATE RJ MATEL
          RJ     LONGI
          RJ     PAD
          SB1    3
          RJ     FREEX       RELEASE X3 
          SA1    IOP
          SA1    X1+INFO     GET ARAYWD(KEEP ADDR IN A1)
          MX0    1
          LX0    XCODEAL+4   MASK FOR I/F BIT 
          SX7    4           TYPE 4 CODE FOR INDEXED CALC 
          LX7    XCODEAL
          BX2    X0*X1       ADD I/F BIT FROM ARAYWD
          BX7    X2+X7       SETAD WILL ADD SIGN BIT
          LX1    3           CHECK FOR VERTICAL  SEGMENT
          SA7    FLOAT
          PL     X1,MATRAY9  JUMP IF NOT SEGMENTED
          SB1    1           GETVAR LEAVES IN X1
          RJ     MATVS       FORM CODE TO EXTRACT VERTSEGMT 
* 
 MATRAY9  RJ     SETAD       CHANGE OPERAND TO CALC IN X1 
          MX6    0
          SA6    FINDXED     FLAG INDEXED VARIABLE
          EQ     ENDINST     IN X1
* 
 MATPUT   SA1    NADS 
          SX7    X1-2        MUST BE AT LEAST 3 ADS 
          NG     X7,MATERR
          ZR     X7,MATERR
          SA2    X1+ADS      LOAD 2D INDEX AD 
          SA3    X1+ADS-1    LOAD 1ST INDEX AD
          SA4    X1+ADS-2    LOAD ARAYWD ADTYPE 
          BX6    X4          AND MOVE ARAYWD TO ENDOFSTACK
          SA6    A2          WHERE ASSIGN CAN FIND IT 
          BX6    X2 
          SA6    A3          THEN 2D INDEX BEFORE THAT
          BX6    X3 
          SA6    A4          THEN 1ST 
          EQ     ENDINST
* /---   BLOCK      VECTRAY    00 000   78/09/15  17.14 
          TITLE  ARRAY PROCESSING 
* 
 VECTRAY  SB2    VECTRA1
          RJ     NESTCHK     SETS B2=0 IF ASSIGNED INTO 
* 
 VECTRA1  SA3    NADS 
          SX7    X3-2        MUST BE TWO ADDRESSES
          NG     X7,MATERR
* 
          CONDEN
 VECTRA2  SA1    X3+ADS      LOAD INDEX ADTYPE
          BX7    X1 
          AX7    XCODEAL+1   POSITION UPPER 2 GETVAR BITS 
          ZR     X7,VCONST   TREAT CONSTANT INDEX SPECIALLY 
          ENDIF 
* 
 VECTRA3  ZR     B2,SEGPUT   IF ASSIGN, EXCHANGE ADTYPE,INDX
          SB1    3
          RJ     LOADIND     LOAD ROW INDEX TO X3 
          RJ     POPNADS     BACK UP TO ARRAY ADTYPE
          RJ     LDLITAD     LOAD ARAYWD ADDR TO B1 
          SB1    1
          RJ     CHEKRR      CLEAR X1 FOR RESULT
          SA1    LLVECEL     RJ ADDRESS 
          EQ     MATRAY5     GENERATE RJ VECEL
* 
* 
 SCALRAY  SB2    SCALRA1
          RJ     NESTCHK     SETS B2=0 IF ASSIGNED INTO 
* 
 SCALRA1  EQ     CPXERR      ONLY COMPLEX AT THIS POINT 
* 
* 
          CONDEN
*         CHANGE MATRIX ELEMENT INTO REGULAR VARIABLE 
*         IF IT HAS CONSTANT INDICES
 MCONST   SX7    X3-2        ENTER WITH R,C ADS IN X1,X2
          RJ     GETARY4      GET ARAYWD IN X4
          LX4    3           CHECK SEGMENT BIT
          NG     X4,MATRAY3  DONT DO SEGMENTED ARRAYS HERE
          SA7    A3          BACKUP NADS PAST INDICES 
          RJ     GETINDX     C (COL) IN X6
          SA6    SEGWD1      SAVE C 
          BX1    X2          ROW INDEX AD 
          RJ     GETINDX     R (ROW) IN X6
          RJ     GETARY      GET ARAYWDS IN X1,X2 
          RJ     ROWCHK      ADJUSTED ROW INDEX IN X7 
          SA3    SEGWD1      GET BACK C 
          RJ     COLCHK      ADJ COL IN X6, NUMCOL-1 IN X4
          SX4    X4+1 
          DX3    X4*X7       (R-ROW1)*COLS
          IX7    X3+X6       +(C-COL1)
          EQ     VCONST2
* 
* 
*         CHANGE VECTOR ELEMENT INTO REGULAR VARIABLE 
 VCONST   SX7    X3-1        BACKUP ADDR. STACK((NADS)IN X3)
          RJ     GETARY4      GET ARAYWD IN X2
          LX4    3           CHECK SEGMENT BIT
          NG     X4,VECTRA3  DONT DO SEGMENTED ARRAYS HERE
          SA7    A3          BACKUP NADS PAST INDEX(KEEP X7)
          RJ     GETINDX     EXTRACT INTEGER INDEX
          RJ     GETARY      GET ARAYWDS IN X1,X2 
          RJ     ROWCHK      GET ADJUSTED ROW INDEX 
 VCONST2  RJ     MERGAD      GET ELEMENT AD IN X6 
          SA1    NADS 
          SA6    X1+ADS      REPLACE ARRAY WITH EL ADTYPE 
          MX6    0
          SA6    FINDXED     FLAG INDEXED VARIABLE
          EQ     ENDINST
* 
          ENDIF 
* /---   BLOCK      UNARY      00 000   77/12/18  17.28 
          TITLE  UNARY OPS
* 
 UMINUS   SA1    TOPCNT      DO NOT COUNT UNARY MINUS AS AN OPERATION 
          SX7    X1-1 
          SA7    A1 
          SA1    NADS        CHECK FOR LITERAL UNARY MINUS
          SA4    NARRAYS
          NZ     X4,AUMINUS  JUMP IF ARRAYS OPS IN PROGRESS 
 UMINUS1  SA1    X1+ADS      GET OPERAND
          SB1    A1          SAVE ADTYPE ADDR IN B1 
          NG     X1,UMINUS2  JUMP IF IN REGISTER
          BX7    X1 
          AX7    XCODEAL+1   THROW AWAY BOTTOM GETVAR CODE BIT
          MX0    58          MASK OUT I/F BIT 
          BX7    -X0*X7      GET UPPER TWO BITS OF GETVAR CODE
          NZ     X7,UMINUS2  JUMP IF NOT LITERAL (0 OR 1 CODE)
          BX0    X1 
          AX0    XCODEAL     CHECK FOR SHORT OR LONG LITERAL
          SX6    X1          (X6)=SHORT LITERAL 
          ZR     X0,UMSHORT  JUMP IF SHORT LITERAL
* 
          BX2    X0          SAVE TYPE CODE 
          RJ     RLLIT       (X6) = LONG LITERAL
          BX0    X2          RESTORE TYPE CODE
          BX1    X6          (X0=1 OR 3 FOR I OR F LONG LITERAL)
 UMSHORT  BSS    0
          BX6    -X6         COMPLEMENT THE LITERAL 
          SX1    1           MAKE SURE LONG LIT GETVAR CODE 
          BX1    X0+X1       (X1) = TYPE CODE 
          RJ     SLLIT       STORE LIT AND (X6) = ADTYPE
          SA6    B1          AND CHANGE OPERAND IN ADS LIST 
          EQ     ENDINST
* 
 UMINUS2  RJ     IFIRR       UNARY MINUS, I/F IRRELEVANT
          SB1    1
          RJ     GENREAD     READ TO X1 IF NOT IN REGISTER
          SX0    B1          CONSTRUCT COMPLEMENT INSTRUCTION 
          SX1    14000B 
          BX3    X0+X1
          RJ     PICKX       PICK DESTINATION REGISTER
          SX7    B1          DESTINATION IN B1
          LX7    6
          BX7    X3+X7       COMPLETE COMPLEMENT INSTRUCTION
          RJ     SHORT       ADD TO INSTRUCTION STREAM
          EQ     ENDINST
* 
 AUMINUS  SA2    X1+ADS      ENTER FROM UMINUS WITH X1=NADS 
          LX2    1           LOOK AT WHOLE ARRAY BIT
          PL     X2,UMINUS1  EXIT IF NOT ARRAY
          LX2    59 
          MX0    -XCODEAL 
          BX3    -X0*X2 
          SA3    X3+INFO     GET ARRAYWD
          BX7    X3*X0
          SA7    ASIZE       AND SAVE 
          SB1    0           ALLOW RE-USE OF TMPARAY
          RJ     CALCTMP     GET ADDRESS OF TEMP STOR 
          RJ     ARYPREP     CLEAR X1,2,6, FORM RJ ABUFCHK
          SB1    RAINIT 
          RJ     LDAINIT     INITIALIZE FOR LOOP
          SB1    1
          RJ     LDARRAY
          SX7    14611B      CODE FOR BX6 -X1 
          RJ     SHORT
          RJ     TMPAD       CHANGE ADTYPE TO TEMP ARRAY
          MX0    1
* /---   BLOCK      UNARY      00 000   78/12/21  18.19 
          LX0    XCODEAL+4   I/F BIT MASK 
          BX7    X0*X2       I/F BIT OF OPERAND(LEFT IN X2) 
          SA7    FLOAT       ENDAINS WILL SET ADTYPE I/F
          SA1    NARRAYS
          BX7    -X1         SET - AS FLAG FOR LOOPING OP 
          SA7    A1 
          EQ     ENDINSA
* 
* /---   BLOCK      UEXPON     00 000   79/08/24  13.46 
* 
          TITLE  EXPONENTIATION 
* 
 EXPO     SA1    NOPS        FOR EXPONENTS, FIRST CHECK FOR PI
          SA2    X1+OPS-1    GET PRECEDING STACK OPERATOR 
          SX7    X2-OPPI
          NZ     X7,EXPOA    JUMP IF NOT PRECEDED BY PI OPERATOR
          SX7    OPMULT      CHANGE STACK PI TO MULT
          SA7    A2 
          SX0    B0          PI IS LITS+0 
          RJ     LITREF      ADD PI LITERAL TO ADS STACK
          SA1    NADS        SWITCH PI AND EXPONENT IN ADS STACK
          SX2    X1-2 
          NG     X2,FORMERR  MUST BE AT LEAST 2 OPERANDS
          SA2    X1+ADS      GET PI 
          SA1    A2-1        GET EXPONENT 
          BX7    X2 
          SA7    A1          SWITCH THEM
          BX7    X1 
          SA7    A2 
 EXPOA    SX7    1           HANDLE EXPONENTIATION
          LX7    XCODEAL+3
          SA7    FLOAT       FLOATING RESULT
          SX7    B0 
          SA7    RECIP       CLEAR RECIPROCAL FLAG
          SA1    NADS        CHECK FOR EXPONENT TYPE
          SX2    X1-2 
          NG     X2,FORMERR  MUST BE AT LEAST 2 OPERANDS
          SA3    X1+ADS      GET EXPONENT OPERAND 
          BX7    X3 
          SA7    POWER       SAVE EXPONENT
          SA4    NARRAYS
          ZR     X4,EXPOA1   JUMP IF NO ARRAYS
          BX2    X3          MUST PRESERVE X3,X7
          LX2    1           CHECK EXPONENT ADTYPE ARRAY BIT
          NG     X2,NOAERR   WHOLE ARRAYS NOT ALLOWED 
          SA2    A3-1        OPERAND ADTYPE 
          LX2    1
          NG     X2,NOAERR   NO ARRAYS...UNDEFINED OPERATION
 EXPOA1   SA2    NUNITS      CHECK FOR UNITS
          NG     X2,EXPOAA   JUMP IF NO UNITS 
          NG     X3,UNITERR  JUMP IF POWER IS IN REGISTER 
          AX7    XCODEAL
          ZR     X7,INTPOW   JUMP IF SHORT LITERAL
          MX0    57 
          BX0    -X0*X7 
          AX0    1
          NZ     X0,UNITERR  JUMP IF NOT LITERAL
          BX1    X3          (X1) = ADTYPE
          RJ     RLLIT       (X6) = LONG LITERAL
          BX3    X6 
          LX7    59-3        SIGN BIT = I/F BIT 
          NG     X7,GOTPOW   IF FLOATING LITERAL
* 
 INTPOW   PX3    X3 
          NX3    X3          ELSE FLOAT IT
 GOTPOW   RJ     ZEROU       CHECK THAT EXPONENT HAS NO DIMENSIONS
          SA2    NUNITS      NUNITS IN X2, EXPONENT IN X3 
          SA1    NUADS
          IX7    X1-X2       DECREMENT UADS POINTER 
          SA7    A1 
          RJ     MULTEM      MULTIPLY UNIT COEFFICIENTS 
          SA1    NADS        RESTORE A1 
          SA3    POWER       RESTORE X3 
* 
* /---   BLOCK      EXPO1      00 000   78/11/21  22.20 
* USED TO TREAT ZERO EXPONENT SPECIALLY, BUT THAT MEANT THAT
*  A&0 GAVE 1 INSTEAD OF 0/0 WHEN A=0.
 EXPOAA   ZR     X3,CMPLG0   NOT SPECIAL IF EXPONENT IS ZERO
          MX0    54          KEEP ALL BUT BOTTOM 6 BITS 
          BX0    X0*X3
          ZR     X0,EXPO1    JUMP IF POS EXPONENT LT 64 
          AX0    XCODEAL     CHECK FOR NEGATIVE EXPONENT
          MX7    57          SHOULD BE LONG LITERAL 
          BX7    -X7*X0      MASK FOR GETVAR CODE ID
          SX7    X7-1        WHICH SHOULD BE 1
          NZ     X7,CMPLG0   JUMP IF NOT LONG LIT 
          LX0    56          THEN CHECK FOR INT OR FLOAT
          MX7    60-XCODEAL  ACQUIRE LITERAL
          BX7    -X7*X3 
          SA4    X7+LITS     LITERAL IN X4
          PL     X0,EXPO0    JUMP IF NOT FLOATING 
          SA2    =.5         CHECK FOR X**.5
          BX7    X2-X4
          NZ     X7,CMPLG0   JUMP IF EXPONENT NOT .5
          NG     X7,CMPLG0   JUMP IF EXPONENT IS -.5
          SX7    X1-1 
          ZR     X7,FORMERR  JUMP IF NO BASE
          SA7    A1          DECREMENT NADS 
          SX7    1
          SA7    NOTLITS     FLAG ARG NOT LITERAL 
          SX7    OPSQRT 
          SA7    SAVEOP      SAVE OP CODE 
          EQ     SQTFCT2     GO DO SQRT 
* 
 EXPO0    PL     X4,CMPLG0   JUMP IF NOT NEGATIVE INTEGER 
          BX3    -X4         MAKE INT EXPONENT POSITIVE 
          MX0    54          CHECK FOR EXPONENT&lt;64
          BX0    X0*X3
          NZ     X0,CMPLG0   JUMP IF EXPONENT>64
          SX7    1           NEED TO TAKE RECIPROCAL
          SA7    RECIP
          BX7    X3          SAVE POWER 
          SA7    POWER
 EXPO1    SX7    X1-1        DECREMENT NADS 
          ZR     X7,FORMERR  ERROR IF NO OPERANDS LEFT
          SA7    A1 
          SX7    X3-1        CHECK FOR EXPONENT 1 
          ZR     X7,RECIPRO  NOTHING TO DO--X**1
          RJ     FLOTONE     FLOAT THE BASE IF REQUIRED 
          SB1    1           READ BASE INTO X1
          RJ     GENREAD     IF NOT IN A REGISTER 
          SX3    B1          GET REGISTER NUMBER
          LX3    3
          SX3    X3+B1
          LX3    3
          SX3    X3+B1       FORM NNN REFERENCE 
          SB1    X3          SAVE NNN 
          SA4    POWER       RESTORE POWER
          LX4    59 
          MX5    1           FORM SIGN BIT MASK 
          NG     X4,ODD      JUMP IF ODD POWER
* EVEN     SX7    B1+40000B    FORM FXN XN*XN TO SQUARE BASE
 EVEN     SX7    B1+41000B    (RX)
          RJ     SHORT       SQUARE THE BASE
          LX4    59          START WITH BASE**2 IN XN 
* /---   BLOCK      ODD        00 000   74/07/13  15.54 
          PL     X4,EVEN     JUMP BACK IF STILL NO BIT SET IN EXPONENT
          BX4    -X5*X4      THROW OUT SIGN BIT 
          ZR     X4,EXPOD    JUMP IF ALL DONE 
 ODD      AX3    3           MAKE NN REFERENCE
          SX7    X3+41200B   FORM RX2 XN*XN 
          RJ     SHORT
          LX3    3
          SB1    X3+2        FORM NN2 FOR USE IN FORMING FXN XN*X2
 EXPOC    BX4    -X5*X4      THROW OUT SIGN BIT 
          LX4    59          CHECK NEXT HIGHER BIT IN EXPONENT
          PL     X4,NOTON    JUMP IF BIT NOT ON 
          SX7    B1+41000B   FORM RXN  XN*X2 TO MULTIPLY UP 
          RJ     SHORT
          BX4    -X5*X4      THROW OUT SIGN BIT 
          ZR     X4,EXPOD    JUMP IF MULTIPLIES DONE
 NOTON    SX7    41222B      RX2 X2*X2 TO SQUARE AGAIN
          RJ     SHORT
          EQ     EXPOC       KEEP GOING 
 EXPOD    SX3    B1          GET FINAL REGISTER NUMBER
          AX3    6
          SX7    1
          SA7    X3+RX       TAG REGISTER IN USE
          BX7    X5+X3       TACK ON SIGN BIT TO INDICATE REGISTER
          LX5    XCODEAL+4   FORM FLOAT BIT 
          BX7    X7+X5
          SA1    NADS 
          SA7    X1+ADS 
          EQ     RECIPRO     CHECK FOR RECIPROCAL 
* 
* 
 RECIPRO  SA1    RECIP       CHECK FOR NEEDED RECIPROCAL
          ZR     X1,ENDINST  JUMP IF NO RECIPROCAL NEEDED 
          SA1    NADS        MOVE DIVIDEND UP 
          SX6    X1+1 
          SX7    X6-ADSMAX   SEE IF TOO MANY ADS
          PL     X7,LNGERR
          SA6    A1 
          SA2    X1+ADS 
          BX7    X2 
          SA7    A2+1 
          SX7    1           INSERT NUMERATOR (1) 
          SA7    A2          INTO ADS LIST
          SX7    45000B      FLOATING DIVIDE (RX) 
          SA7    FLOAT       NORMAL DIVIDE STUFF EXCEPT FOR UNITS 
          RJ     FLTBOTH        WHICH ARE ALREADY DONE
          EQ     MULT2
* 
* 
 FLOTONE  EQ     *           SET CHANGE BIT TO FLOAT OPERAND
          SA1    NADS        GET OPERAND
          SA1    X1+ADS 
          SX0    1           FORM I/F BIT MASK
          LX0    XCODEAL+3
          BX7    X0*X1       GET BIT
          NZ     X7,FLOTONE  DONE IF ALREADY FLOATED
          LX0    1           ELSE SET CHANGE BIT
          BX7    X1+X0
          SA7    A1 
          EQ     FLOTONE
* 
* ENTER MULTEM WITH X2=NUNITS, X3=EXPONENT
* 
 MULTEM   EQ     *           MULTIPLY UNITS BY EXPONENT 
          SB2    X2          NUNITS IN X2 
          SB1    1           INDEX
          SA1    NUADS       NUADS STARTS AT ZERO 
          SA1    X1+UADS-1   START OF DIMENSIONS (-1) 
 MULTEM2  SA1    A1+B1       PICK UP COEFF
          FX7    X1*X3       EXPONENT IN X3 
          SA7    A1 
          SB2    B2-B1       COUNT
          GT     B2,B0,MULTEM2
          EQ     MULTEM 
* /---   BLOCK      ASSIGN     00 000   77/12/18  17.29 
          TITLE  ASSIGNMENT OPERATION 
* 
 ASSIGN   RJ     PREBIN      ASSIGNMENT OPERATION 
          SA1    NOTLITS     BOTH OPERANDS LITERALS IF ZERO 
          ZR     X1,EQERR    CANT STORE INTO LITERAL
          SA3    NUNITS 
          PL     X3,UNITERR  CANT STORE IF UNITS INVOLVED 
          SA4    NARRAYS
          NZ     X4,AASSIGN   JUMP IF WHOLE ARRAYS FOUND
 ASSIGN1  JP     B3+ASSIGN2  B3=0 ITOI,  1 FTOI, 2 ITOF, 3 FTOF 
 ASSIGN2  EQ     ASSIGN3     I=I
          EQ     ASFTOI      I=F
          EQ     ASITOF      F=I
          EQ     ASSIGN3     F=F
 ASFTOI   SA1    NOPS        MOCK UP ROUND OPERATION
          SX7    X1+1 
          SX1    X7-OPSMAX   SEE IF TOO MANY OPS
          PL     X1,LNGERR
          SA7    A1          BY INCREMENTING NO. OF OPERATIONS
          SB1    RNDFIOP      AND JUMPING THRU OPJUMP TABLE 
          EQ     OPJUMP1
 ASITOF   LX0    1           FLAG MODE CHANGE FOR GENREAD 
          BX7    X2+X0       (PREBIN SET X0 TO I/F BIT) 
          SA7    A2          AND A2 IS ADDRESS OF SECOND OPERAND
* /---   BLOCK      ASSIGN     00 000   78/01/25  14.37 
 ASSIGN3  SB1    6           TRY TO GET IN X6 
          RJ     GENREAD
          SX0    B1-6        MUST BE IN X6 OR X7 TO STORE 
          PL     X0,ASSIGN4  JUMP IF IN X6 OR X7
          SX7    1
          SA7    B1+RX       MARK RESULT REGISTER IN USE
          SX7    B1          SAVE REGISTER
          SA7    IOP
          SB1    6
          RJ     CHEKRR      MOVE X6 SOMEPLACE
          SA1    IOP         GENERATE BX6 XN
          BX7    X1 
          LX7    3           POSITION REGISTER FOR BX INST. 
          SX7    X7+10600B   BX6 XN 
          MX6    0
          SA6    X1+RX       MARK REGISTER NO LONGER IN USE 
          RJ     SHORT       PUT BX6 XN INTO CALC CODE
 ASSIGN4  SA1    NADS        SET UP RESULT ADTYPE 
          SX7    X1-1 
          ZR     X7,FORMERR  JUMP IF NO OPERAND TO STORE INTO 
          SA7    A1          DECREMENT NADS 
*FLAG RESULT AS I OR F
          SA1    X7+ADS      RESULT ADDRESS 
          SX0    1
          LX0    XCODEAL+3   MASK FOR I/F BIT 
          BX2    X0*X1
          SX7    1           FLAG RESULT REGISTER IN USE
          SA7    RX+B1
          SX7    B1          RESULT REGISTER ASSIGNMENT 
          BX7    X7+X2       MERGE WITH I/F BIT 
          MX0    1
          BX7    X7+X0       AND FLAG AS BEING IN REGISTER
          SA7    A1          STORE ADTYPE 
* 
          MX0    60-XCODEAL 
          BX2    -X0*X1      GET ADDRESS OF STORE 
          AX1    XCODEAL     CODE TYPE
          MX0    57 
          BX1    -X0*X1      THROW AWAY I/F INFO
          SB2    X1 
          JP     B2+ASSIGN5 
 ASSIGN5  EQ     EQERR       CANT STORE INTO SHORT
          EQ     EQERR       OR LONG LITERAL
          EQ     ASTUD       STUDENT
          EQ     ACOM        COMMON 
          EQ     AINDEX      INDEXED VARIABLE 
          EQ     ASEG        SEGMENT
          EQ     AARRAYL     ARRAY
          EQ     EQERR       7
* /---   BLOCK      ASSIGN     00 000   76/07/07  01.59 
 ASTUD    SA1    ASVARS 
          IX2    X1+X2       ABSOLUTE ADDRESS 
 ASTUD2   SX7    B1+510B     SAN  B0+K
          LX7    18+3 
          BX7    X7+X2       ATTACH ADDRESS 
          RJ     LONGI
          EQ     ENDINST
 ACOM     SA1    ACVARS      COMMON VARIABLE ADDRESS
          IX2    X1+X2
          EQ     ASTUD2 
 AINDEX   SX7    B1+530B     SAN XM 
          LX7    3
          BX7    X7+X2
          LX7    3
          MX6    0           FREE THE X REGISTER
          SA6    X2+RX
          RJ     SHORT
          EQ     ENDINST
* 
* 
 AARRAYL  SA1    X2+INFO     GET ARRAYWORD
          MX0    1
          LX0    XCODEAL+4   I/F BIT MASK 
          SX7    A1          SAVE ARRAYWORD ADDR FOR ASEG22 
          SA7    TMPARAY
          BX7    X0*X1
          LX1    4           TOP DIM. BIT 
          SA7    SEGWD       SAVE I/F BIT 
          PL     X1,AVEC     JUMP IF NOT MATRIX 
          LX1    1           OTHER DIMEN BIT
          NG     X1,MATERR   NO 3-D YET 
          SX1    6115B       SB1 B5+**
          LX1    18 
          BX7    X1+X2       ATTACH ADDRESS 
          SA7    SEGWD1      SAVE 
          RJ     POPNADS     BACK UP TO COL ADTYPE
          SB1    4
          RJ     LOADIND     LOAD COL INDEX TO X4 
          RJ     POPNADS     BACK UP TO ROW ADTYPE
          SB1    3
          RJ     LOADIND     LOAD ROW INDEX TO X3 
          SA1    NADS 
          SX7    X1+2        RESULT NADS
          SA7    A1 
*          SB1    7           READ RESULT TO X7 
          SB1    6           READ RESULT TO X6 ***
          RJ     FORCEX 
          SA2    SEGWD1 
          BX7    X2          LOAD  SB1 B5+ARAYWD
          RJ     LONGI
          SA1    NADS 
          SX6    X1-2        X6 NEEDED LATER
          SA6    A1 
          SA3    SEGWD       I/F BIT
          SA1    LLMATO      RJ ADDRESS 
          EQ     ASEG20 
* 
* 
 AVEC     LX1    1
          PL     X1,CPXERR   NO COMPLEX YET 
          SX1    6115B
          LX1    18 
          BX7    X1+X2       GENERATE SB1 B5+ARAYWD 
          SA7    SEGWD1      SAVE IT
          RJ     POPNADS     BACK UP TO INDEX 
          SB1    3
          RJ     LOADIND     LOAD INDEX TO X3 
          SA1    NADS        ADVANCE TO RESULT
          SX7    X1+1 
          SA7    A1 
*          SB1    7           READ RESULT TO X7 
          SB1    6           READ RESULT TO X6
          RJ     FORCEX 
          SA2    SEGWD1 
          BX7    X2          LOAD SB1 B5+ARAYWD 
          RJ     LONGI
          SA1    NADS 
          SX6    X1-1        X6 USED LATER
          SA6    A1 
          SA3    SEGWD       I/F BIT
          SA1    LLVECO      RJ ADDRESS 
          EQ     ASEG22 
* /---   BLOCK      ASSIGN     00 000   78/01/25  16.36 
* 
*         ASSIGNMENT INTO SEGMENT 
* 
 ASEG     BX6    X2          SAVE ADDRESS OF SEGMENT LITERAL
          SA6    IOP
          MX6    0
          SA6    TMPARAY     FLAG FOR ARAY TEST IN ASEG22 
          SA1    X2+INFO     LOAD SEGMENT INFO WORD 
          BX6    X1 
          SA6    SEGWD       SAVE 
          LX6    2           POSITION -VERTICAL- OPTION BIT 
          NG     X6,ASEGV 
* 
          SB1    4           MUST BE SURE REGISTER X4 FREE
          RJ     CHEKRR 
          SX7    5145B       GENERATE CODE TO LOAD SEGMENT
          SA1    IOP         GET ADDRESS OF INFO WORD 
          LX7    18          INFO WORD TO X4
          BX7    X1+X7
          RJ     LONGI       ADD A   SA4  B5+K
          SX7    1
          SA7    RX+4        MARK X4 AS IN USE
          RJ     POPNADS     BACK UP TO INDEX ADTYPE
          SB1    3
          RJ     LOADIND     LOAD INDEX TO X3 
* 
 ASEG10   SA1    NADS        ADVANCE NADS AGAIN TEMPORARILY 
          SX7    X1+1 
          SA7    A1 
*          SB1    7           READ TO X7
          SB1    6           READ RESULT TO X6 ***
          RJ     FORCEX 
          SA1    NADS 
          SX6    X1-1        BACK UP ADTYPE POINTER AGAIN 
          SA6    A1 
          SA1    LLSEGO      RJ ADDRESS 
          MX3    0           SEGMENT I/F BIT ALWAYS 0 
 ASEG20   SB1    4           RELEASE X4 
          RJ     FREEX       DOES NOT CHANGE X1,X3,X6 
* 
 ASEG22   MX2    1           TOP BIT FOR IN REGISTER
*          SX7    7           FORM RESULT ADTYPE (BE IN X7) 
          SX7    6           FORM RESULT ADTYPE IN X6 *** 
          BX7    X3+X7       MERGE IN I/F BIT 
          BX7    X2+X7       AND REGISTER BIT 
          SA7    X6+ADS      REWRITE ADDRESS ENTRY
          SX7    0100B       BUILD AN RJ INSTRUCTION
          LX7    18 
          BX7    X7+X1       RJ ADDR IN X1
          RJ     LONGI       ADD CALL TO SEGMENT ROUTINE
          RJ     PAD
          SA1    TMPARAY
          NZ     X1,AMATSG   JUMP IF ARRAY TO TEST FOR SEGMT
 ASEG29   SB1    3           RELEASE X3 
          RJ     FREEX
          EQ     ENDINST
* 
* 
* /---   BLOCK      ASSIGN     00 000   77/12/18  17.30 
 ASEGV    RJ     POPNADS     BACK UP TO INDEX ADTYPE
          RJ     VSINDX      GENERATE CODE TO LOAD TO X1
          SA1    NADS 
          SX6    X1+1        ADVANCE TO QUANTITY TO STORE 
          SA6    A1 
          SB1    6           READ QUANTITY TO STORE TO X6 
          RJ     FORCEX 
          SB1    3           OBTAIN X3 FOR MASK 
          RJ     CHEKRR 
          SX7    1
          SA7    RX+3        MARK BUSY
          SB1    7           OBTAIN X7 FOR STORE
          RJ     CHEKRR 
          RJ     POPNADS     BACK UP TO INDEX AGAIN 
* 
          SA1    SEGWD       LOAD SEGMENT INFO WORD 
          SB1    X1-1        GET STARTING BIT POSITION
          AX1    18+18
          SB2    X1          GET NUMBER OF BITS PER BYTE
* 
          RJ     VSTORE      GENERATE CODE TO STORE VSEG
* 
          SB1    1
          CALL   FREEX       RELEASE X1 
          SB1    3
          CALL   FREEX       RELEASE X3 
*          SB1    7 
*          CALL   FREEX       RELEASE X7 (NEVER RESERVED'/) 
* 
          MX1    1           FORM RESULT ADTYPE 
          SX6    6           RESULT IS IN X6
          BX6    X1+X6
          SA1    NADS        LOAD POINTER IN ADDRESS STACK
          SA6    X1+ADS      STORE RESULT ADTYPE
          EQ     ENDINST
* /---   BLOCK      AASSIGN    00 000   77/12/18  17.33 
          TITLE  ARRAY ASSIGNMENT OPERATION 
* 
*                CHECK IF ASSIGNMENT TO WHOLE ARRAY 
 AASSIGN  SA1    NADS        ENTER WITH NARRAYS IN X4 
          SA2    X1+ADS 
          SA3    A2-1        OPERANDS IN X2,X3
          BX7    X3+X2
          LX7    1
          PL     X7,ASSIGN1  JUMP BACK IF NEITHER IS ARRAY
* 
          SB1    X4-2        TEST FOR NO MORE THAN 2ARAYOPS 
          SX7    1           RESET NARRAYS AFTER STORE IF OK
          LE     B1,B0,AASGN0   JUMP IF 2 OR 1 ARAYOPS
          PLATO 
          EQ     MNYAERR     ONLY ONE OPERATION IN COMPUTE
          ENDIF 
* 
*          SX7    1000B       FLAG FOR 2MANYARAYS IN ENDLIN 
 AASGN0   SA7    NARRAYS     RESTORE COUNT
          SX7    B3 
          SA7    IOP         SAVE I/F MODES OF OPERANDS 
          BX4    X3*X2
          LX4    1
          NG     X4,AASGN10  JUMP IF BOTH ARRAYS
          LX3    1
          PL     X3,EQERR    CANT STORE ARRAY INTO SCALAR 
          RJ     STORTMP     IS IN REGISTER, STORE IT 
          SA1    NADS 
          SX1    X1-1 
          SA2    X1+ADS      GET 1ST (ARRAY) OPERAND
          RJ     STORTMP     GET ASIZE
          EQ     AASGN20
 AASGN10  RJ     SIZCHK      CHECK IF ARRAYS ARE CONFORMAL
 AASGN20  RJ     ARYPREP     CLEAR X1,2,6, FORM RJ ABUFCHK
          SB1    RAINIT 
          RJ     LDAINIT     INITIALIZE LOOP
          SB1    1
          RJ     LDARRAY     GENERATE LOAD RESULT TO X1 CODE
          SA1    IOP         GET BACK OPERAND I/F TYPES 
          SB3    X1 
          JP     B3+AASGN22  =0 IF I=I, =1 IF I=F, ETC
 AASGN22  EQ     AASGN30     IS I=I 
          EQ     AASGN80        I=F 
          EQ     AASGN70        F=I 
 AASGN30  SX7    10611B         F=F 
          RJ     SHORT       GENERATE CODE FOR  BX6 X1
 AASGN40  RJ     POPNADS     DECREMENT ADS
          SA1    X7+ADS      GET ADTYPE 
          BX2    X1 
          LX2    2           SEE IF IS TMPARRAY 
          NG     X2,EQERR    CANT STORE INTO TMPARRAY 
          MX0    -XCODEAL 
          BX2    -X0*X1      GET ADDRESS OF ARRAYWD 
          SA3    X2+INFO     GET ARRAYWD FROM XTRA STORAGE
          BX1    -X0*X3      REL. ADDRESS OF ARRAY TO STORE 
          SA4    ASVARS 
          PL     X3,AASGN45  SIGN BIT=0 FOR STUD, =1 FOR COM
          SA4    ACVARS 
* /---   BLOCK      AASSIGN    00 000   76/07/17  04.13 
 AASGN45  IX1    X1+X4       ADD RELATIVE ADDR TO BASE
          LX3    3
          PL     X3,AASGN50 
          SA2    A3+1        GET 2D ARRAYWD 
          LX2    1
          PL     X2,MATERR   SEE AMATVS BELOW 
          LX2    11 
          MX0    -6 
          BX4    -X0*X2 
          SB2    X4 
          LX2    6
          BX4    -X0*X2 
          SB1    X4-1 
          BX6    X1 
          SA6    SEGWD       SAVE REL BASE ADDR 
          SX7    5214B       CODE FOR *SA1 X4+K*
          LX7    18 
          BX7    X7+X1       GENERATE *SA1 X4+BASEADDR* 
          RJ     LONGI       GET WD IN X1, RESULT IN X6 
          RJ     VSTORE      MASK IN X3, STORE FROM X7
***TEMP KLUDGE TO PREVENT OVERWRITING BY ALOOP
          SX7    10670B      MOCKUP BX6 X7 SO ALOOPS
          RJ     SHORT       STORES SEGMENTED WD AGAIN
          SA1    SEGWD       GET BACK BASE ADDR 
* 
 AASGN50  RJ     LDALOOP     GENERATE RJ ALOOPS, ETC
          RJ     LDAINTR     GENERATE *RJ AINTER* INTRUPTEST
* 
          EQ     ENDINST
* 
*                COME HERE TO FLOAT RESULT FOR F=I
 AASGN70  SX7    27601B      GENERATE CODE FOR PX6 X1 
          RJ     SHORT
          SX7    24606B      GENERATE CODE FOR NX6 X6 
          RJ     SHORT
          EQ     AASGN40     NOW STORE IT 
* 
*                COME HERE TO ROUND RESULT FOR  I=F 
 AASGN80  SX1    RNDFIOP     ROUNDING OPERATOR
          SX0    X1-FUNCT0   GET FUNCTION NUMBER
          SX6    1
          SA6    FFLT        SET FOR FLOATING ARGUMENT
          RJ     GENFCT      LOAD ROUNDED INTEGER TO X1 
          EQ     AASGN30     NOW PUT IN X6 AND STORE
* 
* 
 AMATSG   SA1    X1          GET ARRAYWD1 
          LX1    3           TEST SEGMENT BIT 
          PL     X1,ASEG29   EXIT IF NOT SEGMENTED
          SA2    A1+1        GET SECOND ARAYWD
          LX2    1
          PL     X2,MATERR   NO HORIZONTAL SEGMENTS YET 
* 
*         ASSIGN TO VERTICAL-SEGMENTED ARRAY ELEMENT... 
*         ARRAY STORE ROUTINE IN GETVAR, READS INSTEAD OF 
*         STORES IF ARRAY IS VERTICAL SEGMENT 
* 
          LX2    11 
          MX0    -6 
          BX3    -X0*X2 
          SB2    X3          EXTRACT BITS/BYTE
          LX2    6
          BX4    -X0*X2 
          SB1    X4-1          AND STARTBIT-1 
          RJ     VSTORE      GENERATE SEGMENT STORE CODE
          SX7    10722B 
          RJ     SHORT       FORM  BX7 X2 TO RESTORE X7 
          SX1    1
          SX7    5012B       FORM  SA1 A2+1 
          LX7    18 
          BX7    X7+X1
          RJ     LONGI
          SX1    2
          SX7    5022B       FORM  SA2 A2+2 
          LX7    18 
          BX7    X7+X1
          RJ     LONGI       TO RESTORE X1, X2
          EQ     ASEG29 
* 
* /---   BLOCK      PREBIN     00 000   77/12/19  16.12 
          TITLE  PREBIN -- DETERMINE TYPES OF OPERANDS
* 
*         -PREBIN-
* 
*         PREBIN CALLED BEFORE BINARY TO DETERMINE I/F TYPES
*         OF 2 OPERANDS.
* 
 PREBIN   EQ     *           PLACE IN B3 THE I/F TYPES OF THE 2 OPERANDS
          SX0    1           B3=0 II, 1 IF, 2 FI, 3 FF
          LX0    XCODEAL+3   I/F MASK 
          SA1    NADS 
          SX2    X1-2 
          NG     X2,FORMERR  MUST BE AT LEAST 2 OPERANDS
          SA2    X1+ADS      GET SECOND OPERAND 
          SA1    A2-1        GET FIRST OPERAND
          BX3    X0*X1       FIRST TYPE 
          BX4    X0*X2       SECOND TYPE
          LX3    1
          BX3    X3+X4       FIRST TYPE--SECOND TYPE  (2 BITS)
          AX3    XCODEAL+3
          SB3    X3 
*NEXT CHECK WHETHER BOTH ARE LITERALS 
          NG     X1,PREBIN   NOT IF IN REGISTER 
          NG     X2,PREBIN   NOT IF IN REGISTER 
          MX7    58 
          BX3    X1          FIRST ADTYPE 
          AX3    XCODEAL+1   DISCARD ADDRESS AND LIT BIT
          BX3    -X7*X3      UPPER TWO BITS OF TYPE CODE, NO I/F BIT
          NZ     X3,PREBIN   MUST BE STUDENT OR COMMON IF NZ
          BX3    X2          SECOND ADTYPE
          AX3    XCODEAL+1   DISCARD ADDRESS AND LIT BIT
          BX3    -X7*X3      UPPER TWO BITS OF TYPE CODE, NO I/F BIT
          NZ     X3,PREBIN   MUST BE STUDENT OR COMMON IF NZ
          SX7    B0 
          SA7    NOTLITS     0 IF LITERALS, NZ IF VARIABLES 
          EQ     PREBIN 
* 
          TITLE  FLTBOTH -- FLOAT BOTH OPERANDS 
* 
*         -FLTBOTH- 
* 
*         CONVERTS BOTH BINARY OPERANDS TO FLOATING POINT 
* 
* 
 FLTBOTH  EQ     *           FLOAT BOTH OPERANDS
          RJ     PREBIN      DETERMINE I/F TYPES
          BX7    X0*X1       PREBIN SET X0 TO I/F MASK
          BX7    X7-X0       COMPLEMENT BIT 
          LX7    1           SHIFT TO CHANGE MODE POSITION
          BX7    X1+X7       MERGE WITH ORIGINAL ADTYPE 
          SA7    A1 
          BX7    X0*X2       PREBIN SET X0 TO I/F MASK
          BX7    X7-X0       COMPLEMENT BIT 
          LX7    1           SHIFT TO CHANGE MODE POSITION
          BX7    X2+X7       MERGE WITH ORIGINAL ADTYPE 
          SA7    A2 
          EQ     FLTBOTH
* /---   BLOCK      BINARY     00 000   77/12/19  16.14 
          TITLE  BINARY -- PLACE 2 OPERANDS IN REGISTERS
* 
*         -BINARY-
* 
*         GENERATE CODE TO PUT 2 OPERANDS FROM THE TOP OF 
*         THE *ADS* STACK INTO REGISTERS FOR A BINARY 
*         OPERATION.
* 
* 
 BINARY   EQ     *           PLACE TWO OPERANDS IN REGISTERS
          SA1    NADS 
          SX2    X1-2 
          NG     X2,FORMERR  MUST BE AT LEAST 2 OPERANDS
          SA2    NARRAYS
          NZ     X2,ABINARY  JUMP IF ARRAYS BEING PROCESSED 
 BINARY1  SB1    2           READ SECOND OPERAND INTO X2
          RJ     GENREAD     GENERATE READ OF LAST OPERAND
          SX7    1
          SA7    B1+RX       RESERVE REGISTER TEMPORARILY 
          SA0    B1          SAVE REGISTER LOCATION 
          SA1    NADS 
          SX7    X1-1        DECREMENT NADS TO GET FIRST OPERAND
          SA7    A1 
          SB1    1           READ FIRST OPERAND INTO X1 
          SX7    A0          A0 GENREAD DESTROYS A0 
          SA7    BINA0
          RJ     GENREAD     GENERATE READ OF FIRST OPERAND 
          SA1    BINA0
          SA0    X1 
          MX7    0
          SA7    A0+RX       RELEASE FIRST REGISTER 
          SA1    NOTLITS     CHECK WHETHER LITERAL OPERANDS 
          NZ     X1,BINARY3  JUMP IF NOT LITERALS 
          SA1    FLOAT       IS RESULT FLOATING 
          ZR     X1,BINARY2  JUMP IF INTEGER
          SX1    10B         I/F BIT
 BINARY2  SX7    X1+1        1 FOR LONG LITERAL 
          LX7    XCODEAL
          SA1    NLITS       INCREMENT NUMBER OF LITERALS 
          SX6    X1+1        RESULT WILL BE PLACED THERE
          SA6    A1 
          SX1    X6-LITL
          PL     X1,LITERR   JUMP IF TOO MANY LITERALS IN THIS CALC 
          BX7    X7+X6       FORM RESULT ADTYPE 
          SA1    NADS        AND STORE IN ADS LIST
          SA7    X1+ADS 
          SX7    712B        LITERAL OPERATION FROM X1,X2 INTO X7 
          EQ     BINARY 
 BINARY3  SX0    B1          NOT LITERALS 
          LX0    3
          SB2    A0 
          SX3    X0+B2       ORIGIN REGISTERS 
          RJ     PICKX       PICK A DESTINATION REGISTER
 BINARY4  SX7    1
          SA7    B1+RX       RESERVE RESULT REGISTER
          SX7    B1          RETURNED IN B1 
          LX7    6
          BX7    X3+X7       ALL 3 REGISTERS
          EQ     BINARY      RETURNED IN X7 
* 
* /---   BLOCK      BINARY     00 000   78/01/23  21.44 
* 
*         COME HERE WHEN PROCESSING ARRAY ELEMENTS
*         INTIALIZE ARRAY ELEMENT BY ELEMENT LOOP 
* 
 ABINARY  SA2    X1+ADS      ENTER FROM BINARY WITH X1=NADS 
          SA3    A2-1        OPERAND ADS 1,2 IN X3,X2 
          BX7    X3+X2       TEST WHOLARRAY FLAG
          LX7    1           IN BIT 58
          PL     X7,BINARY1  EXIT IF NEITHER IS ARRAY 
*         UP TO HERE SHOULD BE INLINE CODE FOR SPEED
          BX4    X3*X2
          LX4    1           LOOK AT $AND$ OF W-ARRAY BITS
          NG     X4,ABIN10   JUMP IF BOTH ARE ARRAYS
*         ONE IS SCALAR...MAKE SURE NOT IN REGISTER 
* ROUTINE AINIT IN FILE GETVAR STORES REGISTERS X7,X4,X3. 
* 'THUS THESE REGISTERS MUST NOT CONTAIN THE SCALAR TO BE 
* ADDED TO THE ARRAY. 
* 
* X4 IS THE LOOP COUNTER, AND X3 IS THE ARRAYSEGV MASK. 
* X7 IS USED IN AINIT, BUT POSSIBLY SHOULDN'7T BE. 'INSTEAD 
* X6 SHOULD BE USED TO STORE X3 AND X4 INTO MEMORY. 
          RJ     STORTMP     CHK 2D OPERAND AND SET ASIZE 
          SA1    NADS 
          SX1    X1-1        GET 1ST ADTYPE 
          SA2    X1+ADS 
          RJ     STORTMP     CHK 1ST OPERAND
          EQ     ABIN20 
 ABIN10   RJ     SIZCHK      CHECK IF ARRAYS ARE  CONFORMAL 
* 
 ABIN20   RJ     ARYPREP     CLEAR X1,2,6, FORM RJ ABUFCHK
**
          SB1    RAINIT 
          RJ     LDAINIT     GENERATE ALOOP INITIALIZATION
          SB1    2
          RJ     LDARRAY     GENERATE LOAD 2D OPERAND TO X2 
          RJ     POPNADS     DECREMENT NADS 
          SB1    1
          RJ     LDARRAY     GENERATE LOAD 1ST OPERAND TO X1
*FORM RESULT ADTYPE 
          SB1    0           ALLOW RE-USE OF TMPARAY
          RJ     CALCTMP     GET LOC OF TMPARRAY BUFFER 
          RJ     TMPAD       FORM TEMP ARRAYWD AND ADTYPE 
          SA1    NARRAYS
          BX7    -X1         FLAG FOR ARRAY OP IN PROGRESS
          SA7    A1 
*SET REGISTER ASSIGNMENTS 
*          SX3    12B         ORIGIN REGISTERS
*          EQ     BINARY4 
          SB1    6           RESULT REGISTER
          SX7    612B        RESULT IN X6, BUT DONT RESERVE 
          EQ     BINARY 
 BINA0    BSS    1
* /---   BLOCK      TMPAD      00 000   77/12/19  16.19 
          TITLE  TMPAD -- FORMS ARRAYWORD/AD FOR *TMPARY* 
* 
*         -TMPAD- 
* 
*         FORMS ARRAYWORD AND *ADS* FOR OPERATIONS FROM 
*         *TMPARY*
* 
 TMPAD    EQ     *           FORMS ARRAYWD AND AD FOR TMPARY
          SA1    ASIZE       TEMPORARY ARRAY LITWORD
          SA2    TMPARAY     AND ADDRESS
          ZR     X1,TMPAD2   JUMP IF RESULT IS SCALAR 
          MX0    -18
          BX6    X0*X1       MASK OUT OLD AND ADD NEW 
          BX6    X6+X2       CM START ADDRESS (I/F BIT=0) 
          MX0    2
          LX0    58          ALL TMP ARRAYS ARE WHOLE WORDS 
          BX6    -X0*X6      SO MASK OUT BASE REDEF,SEG BITS
          RJ     LSEEK       PLANT X6 AS LITERAL
          MX0    2
          LX0    59          BITS 57,58 SET FOR TEMPARRAY 
          BX7    X6+X0       ADD ADDRESS OF LIT FROM LSEEK
          SX0    6
          LX0    XCODEAL     ARRAY CODE TYPE
          BX7    X7+X0       MERGE IN 
 TMPAD6   SA1    NADS 
          SA2    X1+ADS      ORIGINAL ADTYPE NEEDED 4 UMINUS
          SA7    X1+ADS      REPLACE 1ST OPERAND WITH 
          EQ     TMPAD       RESULT TEMP-ARRAY ADTYPE 
* 
* IF SCALAR FROM DOTMULT, RESULT STILL IN REGISTER X7 
 TMPAD2   MX0    1           IN-REGISTER BIT
          SX7    7           REGISTER NUMBER
          BX7    X7+X0       WILL ADD I/F BIT LATER 
          SX6    1
          SA6    RX+7        MARK REGISTER 7 IN USE 
          EQ     TMPAD6      AND PUT IN RESULT ADTYPE 
* /---   BLOCK      SIZCHK     00 000   77/12/19  16.21 
          TITLE  SIZCHK -- CHECKS ARRAYS FOR CONFORMALITY 
* 
*         -SIZCHK-
* 
*         CHECKS THE ARRAY BINARY OPERANDS TO MAKE SURE 
*         THEIR SIZES CONFORM.
* 
* 
 SIZCHK   EQ     *           CHECKS ARRAYS FOR CONFORMALITY 
          MX0    -XCODEAL 
          BX1    -X0*X3 
          BX2    -X0*X2      EXTRACT ADDRESSES FROM ADTYPES 
          MX0    36          MASK FOR SIZE+ROWS+COLS+PLANES 
          SA1    X1+INFO
          SA2    X2+INFO     GET ARRAYWD LITERALS 
          BX7    X1 
          SA7    ASIZE       SAVE TMPARRAY LITWORD
          LX0    54 
          BX3    X0*X1       EXTRACT SIZE,SHAPE INFO
          BX4    X0*X2
          IX7    X3-X4
          NZ     X7,SIZERR   ERROR IF NOT CONFORMAL 
          BX7    X1-X2       LOOK AT DIFFERENCE BETWEEN 
          LX7    1              REAL/COMPLEX BITS 
          PL     X7,SIZCHK   EXIT IF IDENTICAL
          EQ     CPXERR      ERROR IF NOT 
* 
          TITLE  GETARAD
* 
 GETARAD  EQ     *           ENTER WITH OPERAND ADS IN X1 
          MX0    -XCODEAL 
*          BX3    -X0*X1
          BX6    -X0*X1      ADDR OF ARRAY LIT WD 
*          SA3    X3+INFO 
          SA3    X6+INFO     ARAYWD INFO
          SA6    SEGWD       SAVE ADDR
          MX4    0           TEMP ARAY ADDR ALREADY ABSOLUTE
          LX1    2           PUT TEMP ARAY BIT AT LEFT
          NG     X1,GETARA5  JUMP IF TEMP ARAY
          SA4    ASVARS 
          PL     X3,GETARA5  JUMP IF IN STUDENT BANK
          SA4    ACVARS      MUST BE IN COMMON BANK 
 GETARA5  BX3    -X0*X3      EXTRACT RELATIVE START ADDR
          IX3    X4+X3       MAKE IT ABSOLUTE 
          EQ     GETARAD
* /---   BLOCK      LDAINTR    00 000   79/02/09  13.54 
          TITLE  LDAINTR -- CODE TO TEST FOR ARRAY INTERRUPT
*         -LDAINTR- 
*         GENERATE CODE TO TEST IF ARRAY INTERRUPT NEEDED 
* 
 LDAINTR  EQ     *
          SA1    TMPAFLG
          SX2    X1          GET TMPARAY ADDR 
          MX0    -9 
          LX1    15          POSITION SIZE CODE 
          BX1    -X0*X1 
          SA3    AWVARS      WORK-1 
          SX3    X3-ARAYLTH  START OF TEMPARAY
          IX6    X2-X3
          IX6    X1+X6       ADD SIZE TO GET TMP WORDS USED 
          BX6    -X0*X6      9BITLIMIT
          SX7    6110B       CODE FOR *SB1* 
          LX7    18 
          BX7    X7+X6
          RJ     LONGI       GENERATE *SB1 TMPASIZ* 
          SB1    RAINTER
          RJ     LDASUB      GENERATE *RJ AINTER* 
          EQ     LDAINTR
* 
          TITLE  ARYPREP
* 
*         THIS MUST BE DONE BEFORE ANY WHOLE-ARRAY PROCESS
*         CLEARS X1,X2,X6 FOR GETVAR ARRAY ROUTINES AND 
*         CALLS ECS INTERRUPT BUFFER AVAILABILITY ROUTINE 
* 
*'N'O'T'E'; THE ONLY REASON THIS WORKS IS THAT CHOOSEX DOES NOT 
*CHOOSE X1,X2,X6.  'THUSLY THE FOLLOWING DOESN'7T HAPPEN';
*CHEKRR FREES UP X1.  CHEKRR THEN MOVES X2 INTO X1. 
* 
 ARYPREP  EQ     *
          SB1    1           CLEAN OUT X1,X2,X6 FOR 
          RJ     CHEKRR      ARRAY LOOP ROUTINES
          SB1    2
          RJ     CHEKRR 
          SB1    6
          RJ     CHEKRR 
          SA2    BUFCHK      ZR IF NO INTERRUPT CALL YET
          NZ     X2,ARYPREP   EXIT IF DONE ALREADY THIS LINE
          MX7    -1          SET FLAG TO SHOW CHECK DONE
          SA7    A2             FOR ECS SAVE BUFFER 
          SB1    RBUFCHK
          RJ     LDASUB      GENERATE  *RJ ABUFCHK* 
          EQ     ARYPREP
* 
          TITLE  LDAINIT
* 
*         GENERATE CODE TO INITIALIZE SIZE,INDEX FOR ALOOPS 
*         ENTER WITH ENTRY OFFSET IN B1 (RAINIT, ETC) 
 LDAINIT  EQ     *
          SA1    ASIZE
          LX1    15 
          MX0    -9 
          BX1    -X0*X1      MASK OUT NO. OF ARRAY ELEMENTS 
          SX7    6110B       CODE FOR SB1 **
          LX7    18 
          BX7    X1+X7       GENERATE CODE FOR   SB1 SIZE 
          RJ     LONGI
          RJ     LDASUB      GENERATE RJ AINIT (ETC)
          EQ     LDAINIT
* 
          TITLE  LDASUB 
* 
 LDASUB   EQ     *           GENERATE  RJ ARRAY*SUBR*ADDR 
          SA2    LLALOOP     ENTRY REFERENCE ADDRESS
          SX7    B1          ENTER WITH RELATIVE ADDR IN B1 
          IX2    X2-X7       ABSOLUTE ADDR OF ARRAY SUBR
          SX7    0100B       CODE FOR  RJ **
          LX7    18 
          BX7    X7+X2       GENERATE  RJ **
          RJ     LONGI
          RJ     PAD         MAKE SURE START NEW INSTR WORD 
          EQ     LDASUB 
* /---   BLOCK      CALCTMP    00 000   79/02/09  13.54 
          TITLE  CALCTMP
* 
*         SUBROUTINE TO PUT ABSOLUTE ARRAY STARTING ADDRESS 
*                INTO X3
* 
 CALCTMP  EQ     *
          SA4    TMPAFLG      GET CURRENT TMPARAY INFO
          MX7    -XCODEAL 
          BX7    -X7*X4       EXTRACT 14BIT CURRENT ADDRESS 
          MX0    9
          LX0    54          POSITION SIZE FIELD MASK 
          SA3    ASIZE       GET CURRENT SIZE INFO
          ZR     X3,CLCTMP8  JUMP IF ONLY NEED SCALAR 
          BX3    X0*X3       EXTRACT SIZE 
          ZR     X7,CLCTMP2  JUMP IF NOT INITIALIZED YET
          NE     B1,B0,CLCTMP5   FORCE NEW TMPARAY IF B1=1
          SA2    AOPAD       2 OPERAND ADDR IN LOWER 36 BITS
          SX6    X2          GET ONE
          IX6    X6-X7       IF CURRENT TMPARRAY MATCHES ONE
          ZR     X6,CLCTMP3  CAN USE IT FOR RESULT AS WELL
          AX2    18 
          SX6    X2          TRY 2D 
          IX6    X6-X7
          NZ     X6,CLCTMP5   GET NEW TMPARAY IF NO MATCH 
 CLCTMP3  SA7    TMPARAY     SAVE ADDRESS FOR IMMED. USE
          BX7    X7+X3       MERGE ADDRESS, CURRENT SIZE
          SX3    X7          EXTRACT ADDRESS AGAIN
          SA7    TMPAFLG     RESTORE ARRAY FLAG 
          RJ     SVAOPAD     TEMPARAY WAS LAST OPERAND
          EQ     CALCTMP
* 
 CLCTMP2  BSS    0           MUST GET INITIAL TMPARAY ADDR
          SA4    AWVARS      LOC OF TOP OF WORK-1 
          SX7    ARAYLTH
          IX7    X4-X7       LOC OF START OF TEMP ARAY BUFFR
          EQ     CLCTMP3
* 
*         NEW TMPARAY NEEDED...SEE IF ROOM ENOUGH 
 CLCTMP5  BX6    X0*X4       EXTRACT CURRENT TMPARRAY SIZE
          AX6    45 
          BX4    X3*X0       COPY NEW SIZE FIELD
          AX4    45          POSITION NEEDED SIZE AT RIGHT
          IX7    X6+X7       LOC OF START OF NEXT TMPARRAY
          IX6    X7+X4       +SIZ = END 
          SA2    AWVARS 
          IX6    X2-X6       WORK-1 - END 
          NG     X6,MNYAERR  ERROR IF OVERFLOW
          SA7    TMPARAY     SAVE ADDRESS 
          BX7    X7+X3       MERGE IN NEW SIZE
          SA7    TMPAFLG     RESTORE NEW TMPAFLG
          EQ     CALCTMP
* 
 CLCTMP8  MX0    1
          BX7    X0+X4       SET TMPAFLG NONZERO FOR NOTCALC
          SA7    TMPAFLG
          SA2    TEMP        TEMP STORAGE POINTER 
          SX7    X2+1 
          SA7    A2          INCREMENT POINTER
          SX7    X7-TEMPLIM 
          PL     X7,TEMPERR  CHECK FOR TOO MANY TEMPS 
          SX7    X2+VARLIM+1    RELATIVE TEMP STORE ADDRESS 
          SA4    ASVARS      STUDVAR START
          IX7    X7+X4
          SA7    TMPARAY     ABSOLUTE TEMP STORE ADDR 
          EQ     CALCTMP
* /---   BLOCK      STORTMP    00 000   78/09/15  18.56 
          TITLE  STORTMP
* 
*         -STORTMP- 
* 
*         SUBROUTINE TO STORE REGISTER TO TEMP LOC
* 
 STORTMP  EQ     *           ENTER WITH NADS IN X1,AD IN X2 
          NG     X2,STORT2   IF SCALAR IN REGISTER, STORIT
          LX2    1           CHECK ARRAY FLAG 
          PL     X2,STORTMP  IF SCALAR IN MEMORY, EXIT
          MX0    -XCODEAL    IS ARRAY 
          LX2    59 
          BX2    -X0*X2      GET XSTOR ADDRESS
          SA2    X2+INFO     GET ARRAYWD INFO 
          BX7    X2 
          SA7    ASIZE       SAVE TMPARRAY INFO 
          EQ     STORTMP
 STORT2   SA0    X1          SAVE NADS
          MX0    -3          MASK FOR REGISTER NUMBER 
          BX1    -X0*X2      REGISTER NUMBER NOW IN 
*          SB1    X1
*          SB2    7 
*          EQ     B1,B2,STORT5    JUMP IF IN X7 
*          RJ     FREEX       FREE CURRENT REGISTER 
          SB2    X1 
          SB1    7
          EQ     B1,B2,STORT5    JUMP IF IN X7
          CALL   CHEKRR      B1=7, FREE UP REG 7
          SA2    A0+ADS      GET BACK ADS 
          MX0    -3 
          BX1    -X0*X2      REGISTER AGAIN IN X1 
          SB1    X1 
          RJ     FREEX       FREE CURRENT REGISTER
          SX7    1070B       CODE FOR BX7J
          BX7    X7+X1       X1 UNCHANGED BY FREEX
          LX7    3           BX7J0
          RJ     SHORT       ADD *BX7 XJ* TO INSTRUCTIONS 
 STORT5   SA1    A0+ADS      SET A1=ADDRESS OF ADTYPE 
          RJ     STR7TMP     STORE IN TMP AND RESET ADTYPE
          CALL   FREEX,7     RELEASE X7 
          EQ     STORTMP
* 
          TITLE  SVAOPAD
* 
*         SUBR TO SAVE ARRAY OPERAND ADDRESS
* 
 SVAOPAD  EQ     *           OP ADDR IN X3 ON ENTRY 
          SA1    AOPAD
          LX1    18          SHIFT PREVIOUS ONE OUT 
          MX0    -18
          BX6    X0*X1
          BX3    -X0*X3      LEAVE 18 BIT ADDR IN X3
          BX6    X3+X6       MERGE IN LATEST OPND ADDR
          SA6    A1 
          EQ     SVAOPAD
* /---   BLOCK      STORTMP    00 000   77/12/19  16.28 
          TITLE  LDARRAY -- LOAD ARRAY/SCALAR OPERANDS
* 
*         -LDARRAY- 
* 
*         SUBROUTINE TO LOAD ARRAY OR SCALAR OPERANDS 
* 
*         B1 = REGISTER NUMBER
* 
 LDARRAY  EQ     *           ENTER WITH DESIRED REG. IN B1
          SA1    NADS 
          SA1    X1+ADS      GET ADTYPE 
          NG     X1,MATERR   ERROR IF STILL IN REGISTER*****
*          SX2    B1          REGISTER NUMBER 
          LX1    1
*          RJ     FREEX       MAKE SURE REGISTER FREE 2 READ
          NG     X1,LDARAY2  JUMP IF IT IS ARRAY
          SX3    0           FLAG FOR NOT ARRAY 
          RJ     SVAOPAD     SAVE FOR CALCTMP CHECK 
          RJ     GENREAD     IS SCALAR, SO READ INTO X(B1)
          EQ     LDARRAY
* 
 LDARAY2  LX1    59          RESTORE OPERAND ADTYPE 
          RJ     GETARAD     RETURN ABS STARTLOC IN X3
* 
 LDARAY4  RJ     SVAOPAD     SAVE ARRAY ADDR FOR CALCTMP
          SX7    5204B       CODE FOR SA* X4+** 
          LX7    18 
          BX7    X7+X3       MERGE IN ADDRESS OF START
          SX2    B1          GET BACK REGISTER NUMBER 
          LX2    21          POSITION IT
          BX7    X7+X2       FORM  SAN X4+(STARTLOC)
          RJ     LONGI
          SA1    SEGWD       GET BACK ARRAYWD 
          SA1    X1+INFO
          LX1    3
          PL     X1,LDARAY5  SKIP IF NOT SEGMENT
          RJ     MATVS       FORM CODE TO EXTRACT SEGMNT
 LDARAY5  SA1    NADS 
          SA1    X1+ADS      GET BACK ADTYPE
          LX1    60-XCODEAL-5   PUT MODECHANGE BIT AT LEFT
          PL     X1,LDARRAY  EXIT IF NO MODECHANGE
          RJ     FLOATIT     GENERATE PACK AND NORMALIZE
          EQ     LDARRAY
* /---   BLOCK      LBINARY    00 000   77/12/19  16.29 
          TITLE  LBINARY -- PREPARE ARGUMENTS FOR SHIFTING
* 
*         -LBINARY- 
* 
*         PREPARE ARGUMENTS FOR SHIFT OPERATIONS
*            ALSO DO OPTIMIZING FOR CONSTANT 2ND ARG, 
*            AS WELL AS FOR BOTH ARGUMENTS CONSTANT.
* 
 LBINARY  EQ     *           PLACE 2 ARGUMENTS IN X1 AND B1 
          MX7    0
          SA7    FLOAT       CALL THE RESULT INTEGER TYPE 
          SA1    NADS 
          SX2    X1-2 
          NG     X2,FORMERR  MUST BE AT LEAST 2 OPERANDS
          SA4    NARRAYS
          NZ     X4,ALBINRY  JUMP IF ARRAY OPS IN PROGRESS
 LBINRY1  SA1    X1+ADS      SEE WHETHER SHIFT COUNT MUST BE FIXED
          SX0    1
          LX0    XCODEAL+3   I/F BIT
          BX0    X0*X1
          NZ     X0,ASFTOI   MOCK UP A ROUND F TO I FUNCTION
          SA2    NUNITS 
          NG     X2,LBINAR2 
          RJ     SAMEUZ      SAME UNIT, DIMENSIONLESS RESULT
 LBINAR2  SB1    1           READ SECOND OPERAND INTO X1
          SA2    NADS 
          SA2    X2+ADS 
          NG     X2,LBINA21   JUMP IF IN REGISTER 
          MX0    58 
          AX2    XCODEAL+1
          BX2    -X0*X2 
          ZR     X2,LBINAR5   JUMP IF 2ND ARG CONSTANT
* 
 LBINA21  RJ     GENREAD     GENERATE READ OF LAST OPERAND
          SX1    B1          REGISTER ASSIGNMENT
          SX7    X1+6310B    GENERATE SB1  XN 
          LX7    3
          RJ     SHORT
 GET1ST   SA1    NADS 
          SX7    X1-1        DECREMENT NADS TO GET FIRST OPERAND
          SA7    A1 
          SB1    1           READ FIRST OPERAND INTO X1 
          RJ     GENREAD
          SA2    NOTLITS     CHECK FOR BOTH CONSTANT
          ZR     X2,SHIFDO
          SA2    SHIFTDN
          NZ     X2,LBINAR6   JUMP IF 2ND ARG WAS CONSTANT
          SA0    B1+10B      ORIGIN REGISTERS (B1 AND XN) 
          RJ     PICKX       PICK A DESTINATION REGISTER
 LBINAR4  SX7    1
          SA7    B1+RX       RESERVE RESULT REGISTER
          SX7    B1          RETURNED IN B1 
          LX7    6
          SX0    A0          ORIGIN REGISTERS 
          BX7    X7+X0       X(DESINATION)--B1--X(ORIGIN) 
          EQ     LBINARY
* /---   BLOCK      LBINARY    00 000   78/01/20  15.00 
* 
 LBINAR6  SX7    1
          SA7    B1+RX       RESERVE REGISTER 
          SX7    B1 
          MX0    1
          BX6    X7+X0       FLAG REGISTER ADTYPE WITH SIGN BIT 
          LX7    6           POSITION REGISTER CORRECTLY
          SA1    NADS 
          SA6    X1+ADS      STORE ADTYPE OF RESULT 
          EQ     LBINARY
* 
 LBINAR5  SA2    NOTLITS
          BX7    X2 
          MX6    0
          SA6    A2          KLUGE NOTLITS SO GENREAD 
          SA7    SHIFTDN        RETURNS CONSTANT
          RJ     GENREAD     GET 2ND ARGUMENT 
          SA2    SHIFTDN
          BX7    X2 
          MX6    -6 
          SA7    NOTLITS     RESTORE NOTLITS
          SX7    1
          SA7    A2          SET SHIFTDN TO SAY 2ND ARG CONSTANT
          SA3    IOP
          SA2    ARGX1       LOAD 2ND ARGUMENT
          PL     X2,LBINAR7   NEGATIVE, SHIFT OTHER WAY 
          BX2    -X2
          SX4    X3-20000B
          ZR     X4,LBINA55 
          SX3    20000B 
          EQ     LBINAR7
 LBINA55  SX3    21000B 
 LBINAR7  BX6    -X6*X2      LIMIT CONSTANT TO SIX BITS 
          BX6    X6+X3       UNION CONSTANT INTO INSTRUCTION
          SA6    A3 
          EQ     GET1ST      GET 1ST ARGUMENT 
* 
* 
 SHIFDO   SX7    1           1 FOR LONG LITERAL 
          SA1    NLITS       INCREMENT NUMBER OF LITERALS 
          SX6    X1+1        RESULT WILL BE PLACED THERE
          SA6    A1 
          SX1    X6-LITL
          PL     X1,LITERR   JUMP IF TOO MANY LITERALS IN THIS CALC 
          LX7    XCODEAL     TURN CORRECT BIT ON
          BX7    X7+X6       FORM RESULT ADTYPE 
          SX1    1           INDICATE STORED IN *LITS*
          LX1    LITSHFT
          BX7    X7+X1
          SA1    NADS        AND STORE IN ADS LIST
          SA7    X1+ADS 
* 
*NOTE THAT INSTRUCTION HAS X7 SPECIFIED AS SHIFTING REGISTER
          SA1    =46000460004600000700B   THREE PASSES
          SA2    IOP
          BX7    X1+X2       PUT NOPS AND INST. TOGETHER
          SA7    EXECUTE     PLANT THE INSTRUCTION
          SA1    ARGX1       LOAD FIRST ARG 
          BX7    X1          PUT INTO X7
          RJ     EXECIT      EXECUTE THE PLANTED INSTRUCTION
          SA1    NLITS       RESULT IN X7 
*NLITS HAS BEEN ALREADY INCREMENTED ABOVE 
          SA7    X1+LITS     STORE IN LITS TABLE
          MX0    60-XCODEAL  CHECK TO SEE IF RESULT IS SHORT LITERAL
          BX0    X0*X7
          NZ     X0,LBINARY  LONG, ALREADY SET UP CORRECTLY 
          SA1    NADS 
          SA7    X1+ADS      CHANGE TO SHORT
          EQ     LBINARY
* 
* 
* /---   BLOCK      LBINARY    00 000   78/09/16  00.56 
* 
 ALBINRY  SA2    X1+ADS      ENTER FROM LBINARY WITH X1=NADS
          SA3    A2-1        OPERAND ADS 1,2 IN X3,X2 
          BX7    X3+X2       TEST WHOLARRAY FLAG
          LX7    1           IN BIT 58
          PL     X7,LBINRY1  EXIT IF NEITHER IS ARRAY 
*         UP TO HERE SHOULD BE INLINE CODE FOR SPEED
          BX4    X3*X2
          LX4    1
          NG     X4,ALBIN10  JUMP IF BOTH ARE ARRAYS
          BX0    X2 
          LX0    1           IS 2D OPERAND AN ARRAY 
          NG     X0,ALBIN05  JUMP IF IS, CHECK FLOAT LATER
          LX0    59-XCODEAL-4   CHECK I/F BIT OF SCALAR 
          NG     X0,ASFTOI   IF FLOATING,MOCK UP ROUNDING OP
          RJ     STORTMP     PUT FIXED SCALAR IN TMP STORAGE
****          EQ     ALBIN20   AND SET ASIZ IF ARRAY
          SA1    NADS        RESTORE AFTER STORTMP
          SA2    X1+ADS 
          SA3    A2-1 
 ALBIN05  SX1    X1-1        NADS-1=1ST OPERAND ADDR
          BX2    X3          1ST OPERAND
          RJ     STORTMP     STORE SCALAR, SET ASIZ IF ARRAY
          EQ     ALBIN20
 ALBIN10  RJ     SIZCHK      CHECK IF ARRAYS CONFORMAL
**
 ALBIN20  RJ     ARYPREP     CLEAR X1,2,6, FORM RJ ABUFCHK
          SB1    RAINIT 
          RJ     LDAINIT     GENERATE ALOOP INITIALIZATION
          SB1    1
          RJ     LDARRAY     LOAD 2D OPERAND TO X1
          SA1    NADS 
          SA2    X1+ADS      2D OPERAND 
*         NOTE SCALAR 2D OPERAND WAS FIXED ABOVE
          LX2    60-XCODEAL-4    CHECK I/F BIT
          NG     X2,ALBIN80  JUMP IF FLOATING 
 ALBIN30  SX7    63110B      SB1 X1 
          RJ     SHORT       GENERATE INSTRUCTION 
          RJ     POPNADS
          SB1    1
          RJ     LDARRAY     GENERATE SA1 1ST OPERAND 
          SB1    0           ALLOW REUSE OF TMPARAY 
          RJ     CALCTMP     GET LOC OF TMPARAY 
          RJ     TMPAD       FORM TEMPARAYWD AND OPERAND
          SA1    NARRAYS
          BX7    -X1         FLAG FOR ARRAY LOOP IN PROGRESS
          SA7    A1 
          SX7    611B        TAG FOR X6,B1,X1 SHIFT CODES 
          EQ     LBINARY     (DEST=X6, BUT X6 RESTORED LATER
*          SA0    11B         ORIGIN REGISTERS B1,X1
*          SB1    6           RESULT IN X6
*          EQ     LBINAR4 
* 
*         ROUNDS 2D OPERAND (IN X1) AND FIXES INTO X1 
 ALBIN80  SX1    RNDFIOP     ROUNDING OPERATOR
          SX0    X1-FUNCT0   GET FUNCTION NUMBER
          SX6    1
          SA6    FFLT        MARK FLOATING ARGUMENT 
          RJ     GENFCT      GENERATE ROUNDING RJ CODE
          EQ     ALBIN30
* 
* /---   BLOCK      MATVS      00 000   77/12/19  19.33 
          TITLE  MATVS
* 
*         EXTRACT VERTICALSEGMENT FROM WORD IN X1 
*         FOR ARRAY OPERATIONS
* 
*         A1 = ADDRESS OF ARRAY INFO WORDS
* 
 MATVS    EQ     *           ARRAY INFO WD ADDR IN A1 
          SA1    A1+1        GET 2D ARAYWORD
          LX1    1           CHECK VERTSEG BIT
          PL     X1,MATERR   DONT ALLOW HORIZSEG YET
          SX6    B1 
          SA6    MATB1       SAVE B1
          LX6    3
          SX6    X6+B1
          LX6    3           A0=(B1)(B1)4B INDICATING 
****          SA0    X6+4        WORD IN X(B1), MASK IN X4
          SA0    X6+3        WORD IN X(B1), MASK IN X3
          LX1    59          SIGNED BIT AT TOP
          AX1    42          POSITION STARTBIT
          MX0    -6 
          BX6    -X0*X1 
          SB1    X6-1        STARTBIT-1 
          AX1    6
          BX3    -X0*X1      BITS/BYTE
          SB2    X3 
* 
          RJ     VREAD       GENERATE VERTSEG EXTRACT CODE
* 
          SA1    MATB1       RESTORE B1 
          SB1    X1 
          EQ     MATVS
* 
 MATB1    BSS    1           SAVE B1
* 
* /---   BLOCK      GETINDX    00 000   77/12/19  20.04 
          CONDEN
          TITLE  GETINDX -- GET INTEGER INDEX 
* 
*         SUBROUTINE TO GET INTEGER INDEX INTO X6 
*         ENTER WITH INDEX GETVAR CODE IN X1
*         ABS(INDEX) MUST BE LESS THAN 13 BITS
*         MUST NOT CHANGE X7
 GETINDX  EQ     *
          MX0    -XCODEAL 
          BX6    -X0*X1      MASK OFF ADDRESS 
          AX1    XCODEAL-1   CHECK FOR 13BIT SHORT LITERAL
          ZR     X1,GETINDX  IF IS, EXIT WITH X6=LITERAL
          AX1    1           POSITION GETVAR TYPE 
          SX1    X1-1        CHECK FOR LONG INTEGER LIT TYPE
          NZ     X1,INDXERR  ONLY CALLED BY 0,1 TYPE
          SA1    X6+LITS     GET LONG LITERAL INDEX 
          BX6    X1 
          PL     X1,INDXERR  IF PLUS, IS GT 13 BITS 
          ZR     X1,GETINDX  -0 IS OK 
          BX1    -X1         GET ABS(INDEX) 
          MX0    -13
          BX1    X0*X1       CHECK FOR UPPER BITS 
          ZR     X1,GETINDX 
          EQ     INDXERR      ERROR IF GT 13 BITS 
* 
          ENDIF 
* /---   BLOCK      LOADIND    00 000   77/12/19  19.35 
          TITLE  LOADIND -- LOAD INDEX TO X(B1) 
* 
*         -LOADIND- 
* 
*         GENERATES CODE TO LOAD THE CURENT INDEX, ADS(NADS)
*         TO REGISTER(B1) AS IN INTEGER VALUE.
* 
*         ON ENTRY, 
*         B1 = REGISTER NUMBER TO BE LOADED 
* 
* 
 LOADIND  EQ     *           LOADS INDEX TO X(B1) 
          RJ     FORCEX 
          SA1    NADS 
          SA1    X1+ADS      SEE IF INDEX IS I OR F 
          LX1    59-XCODEAL-3 
          PL     X1,LOADIND  EXIT IF INTEGER INDEX
          RJ     INDXFLT     ROUND INDEX
          EQ     LOADIND
* /---   BLOCK      POPNADS    00 000   77/12/19  19.35 
          TITLE  POPNADS -- BACKUP NADS POINTER 
* 
*         -POPNADS- 
* 
*         BACKUP THE NADS POINTER TO THE PREVIOUS ENTRY 
*         IN THE ADS LIST.  THIS ESSENTIALLY POPS THE LAST
*         OPERAND OFF THE STACK.
* 
 POPNADS  EQ     *           BACKUP NADS POINTER
          SA1    NADS 
          SX7    X1-1        BACK UP TO INDEX GETVAR CODE 
          ZR     X7,INDXERR 
          NG     X7,INDXERR  ERROR IF NO INDEX ADTYPE 
          SA7    A1 
          EQ     POPNADS
* /---   BLOCK      ROW/COLCHK 00 000   77/12/19  20.05 
          CONDEN
          TITLE  ROW/COLUMN BOUNDS CHECKING 
* 
*         SUBROUTINE TO CHECK IF ROWS IN BOUNDS 
 ROWCHK   EQ     *           INDEX IN X6, ARAYWDS IN X1,X2
          SX7    1           DEFAULT ROW1 
          ZR     X2,ROWCHK2  JUMP IF NO ARAYWD2 
          BX7    X2          EXTRACT ROW1 FROM ARAYWD2
          LX7    18 
          AX7    46          EXTEND SIGN+PUT ROW1 AT RT 
 ROWCHK2  IX7    X6-X7
          NG     X7,INDXERR  ROW MUST BE GE ROW1
          BX3    X1          EXTRACT ROWS-1 FROM ARAYWD 
          LX3    6+2*9       POSITION ROWS-1 AT RIGHT 
          MX0    -9 
          BX3    -X0*X3      MASK OFF NUMROWS-1 
          IX3    X3-X7       (ROWS-1)-(INDEX-ROW1)
          NG     X3,INDXERR  ERROR IF TOO MANY ROWS 
          EQ     ROWCHK      EXIT WITH ADJUSTED INDEX IN X7 
* 
*         SUBROUTINE TO CHECK COLUMN BOUNDS 
*         DONT CHANGE X1,X2,X7  (SEE ROWCHK FOR DETAILS)
 COLCHK   EQ     *           ENTER WITH ARAYWDS IN X1,X2
          BX4    X1          AND COL INDEX IN X3
          LX4    6+3*9
          MX0    -9 
          BX4    -X0*X4      NUMCOLS-1 LEFT IN X4 
          SX6    1
          ZR     X2,COLCHK2 
          BX6    X2 
          LX6    32 
          AX6    46 
 COLCHK2  IX6    X3-X6       COL-COL1 
          NG     X6,INDXERR 
          IX3    X4-X6       (NUMCOLS-1)-(INDEX-COL1) 
          NG     X3,INDXERR 
          EQ     COLCHK      EXIT WITH  COL-COL1 IN X6
* 
*SUBROUTINE TO MERGE ADJUSTED INDEX (IN X7) WITH
*ARRAYWD START LOC AND I/F BIT (IN X1)
 MERGAD   EQ     *
          MX0    -XCODEAL 
          BX3    -X0*X1      EXTRACT ARRAY START ADDRESS
          IX6    X7+X3       ADD ADJUSTED ARRAY ELEMENT INDX
          MX0    1
          LX0    XCODEAL+4   POSITION MASK
          BX4    X0*X1       TO EXTRACT I/F BIT 
          BX6    X6+X4       AND MERGE IN 
          SX4    2           STUD BANK GETVAR TYPE
          PL     X1,MERGAD2  JUMP IF ARRAY IN STUD BANK 
          SX4    3           COMMON BANK GETVAR TYPE
 MERGAD2  LX4    XCODEAL     POSITION GETVAR TYPE 
          BX6    X6+X4       AND MERGE IN 
          EQ     MERGAD      EXIT WITH GETVAR CODE IN X6
* 
          ENDIF 
* /---   BLOCK      FCCHK      00 000   86/03/12  19.37 
          TITLE  FCCHK -- CHECK TYPE OF GETVAR CODE 
* 
* 
*         RETURNS X0 = -1 IF CONSTANT, 0 IF NOT 
*                 X1 = GETVAR CODE
*                 X2 = I/F TYPE 
*                 X3 = VALUE OF CONSTANT
*                 X4 = GETVAR TYPE - 2
*                      (USED BY *VARLOC*) 
* 
 FCCHK    EQ     *
          MX0    0           PRE-SET NOT CONSTANT 
          SA1    NADS        LOAD POINTER IN ADDRESS STACK
          SA1    X1+ADS      LOAD -GETVAR- CODE 
          SX2    1
          SX3    1
          LX3    LITSHFT     *LITS* BIT 
          BX4    -X3*X1      TURN OFF *LITS* BIT
          LX2    XCODEAL+3   POSITION I/F BIT 
          BX4    -X2*X4 
          BX2    X2*X1
          NG     X1,FCCHK    EXIT IF IN REGISTER
* 
          MX3    -XCODEAL 
          BX3    -X3*X1      MASK OFF ADDRESS PORTION 
          AX4    XCODEAL     POSITION TYPE CODE 
          SX4    X4-2        0 AND 1 = CONSTANT CODES 
          PL     X4,FCCHK    EXIT IF NOT CONSTANT 
          MX0    -1 
          SX4    X4+1        CHECK FOR SHORT LITERAL
          NZ     X4,FCCHK 
          RJ     =XRLLIT     X6 = LITERAL 
          BX3    X6 
        BX1     X3      X1 = LITERAL
          MX0    -1 
          EQ     FCCHK
* /---   BLOCK      TRND       00 000   77/12/19  16.40 
          TITLE  FUNCTIONS (FROM GETVAR)
* 
*         -TRND-
* 
*         ROUND VALUE IN X1 TO NEAREST INTEGER BOUNDARY 
* 
* 
 TRND     EQ     *
          SA2    =.5         ROUND TO NEAREST INTEGER 
          PL     X1,PLRND 
          BX2    -X2         SUBTRACT .5 IF NUMBER IS NEG 
 PLRND    RX1    X1+X2       ADD .5 
          UX1    X1,B1       TRUNCATE X1
          LX1    X1,B1
          MX2    0
          IX1    X1+X2       CHANGE -0 TO +0
          EQ     TRND 
* 
          EJECT 
* 
*         -TLMASK-
* 
*         MASK GENERATING FUNCTIONS (LEFT AND RIGHT)
* 
 TLMASK   EQ     *
          SX1    X1+0        CONVERT -0 TO +0 
          ZR     X1,TLMASK   +++ DONE 
          NG     X1,MASKERR  --- ERROR IF NEGATIVE COUNT
          SB1    X1-1 
          SX1    B1-BPW 
          PL     X1,MASKERR  --- ERROR IF OVER BITS PER WORD
          MX1    1
          AX1    X1,B1
          EQ     TLMASK 
* 
 TRMASK   EQ     *
          SX1    X1+0        CONVERT -0 TO +0 
          ZR     X1,TRMASK   +++ DONE 
          NG     X1,MASKERR  --- ERROR IF NEGATIVE COUNT
          SB1    X1-1 
          SX1    B1-BPW 
          PL     X1,MASKERR  --- ERROR IF OVER BITS PER WORD
          MX1    1
          AX1    X1,B1
          LX1    1
          LX1    X1,B1       RE-POSITION AT RIGHT 
          EQ     TRMASK 
* /---   BLOCK      TINTX      00 000   77/12/19  16.41 
          EJECT 
* 
          PLATO              USE ROUTINES FROM -GETVAR- 
          EXT    TINTX,TFRACX 
          ENDIF 
* 
          CONDEN             ROUTINES COPIED FROM -GETVAR-
 EQTOLER  DATA   1.0E-9      A=B IF ABS(A-B) LT EQTOLER 
* 
* 
*         -TINTX- 
* 
 TINTX    EQ     *
          SA2    EQTOLER     MUST ROUND ARGUMENT
          PL     X1,TINT1 
          BX2    -X2
 TINT1    FX1    X1+X2       ROUND
          NX1    X1 
          UX1    X1,B1
          SB2    B1-11
          PL     B2,TINT2    NUMBER IS TOO BIG
          LX1    X1,B1
          NZ     X1,TINTX 
          MX1    0           ELIMINATE -0 
          EQ     TINTX
 TINT2    NG     X1,TINT3    HUGE NEGATIVE NUMBER 
          MX1    -1 
          LX1    59          MAXIMUM POSITIVE NUMBER
          EQ     TINTX
 TINT3    MX1    1           MAXIMUM NEGATIVE NUMBER
          EQ     TINTX
* 
          EJECT 
* 
*         -TFRACX-
* 
 TFRACX   EQ     *
          NG     X1,NGFRAC   HANDLE NEGATIVE ARGUMENT SEPARATELY
          SA2    EQTOLER     ROUND BY FLOATING TOLERANCE
          FX2    X1+X2
          UX2    X2,B1
* 
          GT     B1,B0,ZRFRAC   CANNOT USE INTEGER > 48 BITS
* 
          LX2    X2,B1       TRUNCATE 
          PX2    X2 
          NX2    X2          REFLOAT
          FX1    X1-X2       SUBTRACT INTEGER PART FROM NUMBER
          NX1    X1 
          NG     X1,ZRFRAC   CONSIDER THE FRACTION TO BE ZERO 
          SA2    EQTOLER
          FX2    X1-X2       CHECK FOR FRACTION SMALLER THAN TOLER
          NG     X2,ZRFRAC   CONSIDER FRACTION TO BE ZERO 
          EQ     TFRACX 
 ZRFRAC   MX1    0           SET FRACTION ZERO
          EQ     TFRACX 
 NGFRAC   SA2    EQTOLER     ROUND BY TOLERANCE 
          FX2    X1-X2       ARG WAS NEGATIVE 
          UX2    X2,B1
          LX2    X2,B1       TRUNCATE 
          PX2    X2 
          NX2    X2          REFLOAT
          FX1    X1-X2       SUBTRACT OFF THE INTEGER PART
          NX1    X1 
          PL     X1,ZRFRAC   CONSIDER SMALL FRACTION ZERO 
          SA2    EQTOLER
          FX2    X1+X2
          PL     X2,ZRFRAC   CONSIDER SMALL FRACTION ZERO 
          EQ     TFRACX 
* 
* 
          ENDIF 
* /---   BLOCK      GENREAD    00 000   78/09/15  19.10 
          TITLE  GENERATE A READ INSTRUCTION
* 
*         -GENREAD- 
* 
*         GENERATE A READ INSTRUCTION 
* 
 GENREAD  EQ     *           GENERATE A READ IF NEEDED
          SA1    NADS        GET OPERAND
          ZR     X1,FORMERR 
          NG     X1,FORMERR  MUST BE AT LEAST ONE OPERAND 
          SA1    X1+ADS 
          NG     X1,GENR0    JUMP IF ALREADY IN REGISTER
          SX3    B1-6        SEE IF X6 OR X7
          NG     X3,GENR0    JUMP IF NOT
          BX3    X1 
          AX3    XCODEAL     SHIFT OFF ADDRESS PORTION
          ZR     X3,GENR0    JUMP IF SHORT I LITERAL
          SB1    1           ELSE RESET TO USE X1 
* 
 GENR0    MX3    1           MASK TO STRIP OFF SIGN BIT 
          BX2    X3          AND LITS/TOKBUF BIT
          LX2    LITSHF1
          BX3    X2+X3
          BX3    -X3*X1      SAVE IN X3 
          PL     X1,NOTINR   JUMP IF NOT ALREADY IN REGISTER
*****KLUGE FIXUP FOR THE CASE OF 3/SQRT(49) 
*****IN WHICH SQRT(49) IS IN X1 AND MUST BE MOVED 
          MX1    57 
          BX2    -X1*X3      REGISTER NUMBER--THROW AWAY I/F BIT
          SX1    B1-2 
          NZ     X1,GENR1    JUMP IF NOT SA2
          SX1    X2-1 
          NZ     X1,GENR1    JUMP IF NOT IN X1
          SX7    10210B      MOVE X1 TO X2
          RJ     SHORT
          SB1    1           AND FREE X1
          RJ     FREEX
          SX2    2           OPERAND IN X2
 GENR1    SB1    X2          FINAL REGISTER LOCATION
          RJ     FREEX       FREE IT
          MX6    -1 
          SA6    FINDXED     FLAG NOT INDEXED VARIABLE
          AX3    XCODEAL+4   CHECK FOR CHANGE MODE
          ZR     X3,GENREAD 
          RJ     FLOATIT     FLOAT THE INTEGER
          EQ     GENREAD
* 
***OPERAND NOT IN REGISTER--
 NOTINR   SA2    NOTLITS     IS THIS A LITERAL OPERATION
          ZR     X2,GENR2    JUMP IF LITERALS 
          RJ     CHEKRR      CHECK READ REGISTER AVAILIBILITY 
 GENR2    MX0    60-XCODEAL  MASK FOR ADDRESS PART OF CODE
          MX6    -1 
          SA6    FINDXED     FLAG NOT INDEXED VARIABLE
          BX6    -X0*X3 
          AX3    XCODEAL
          MX0    56 
          BX2    -X0*X3      SAVE 4-BIT TYPE
          SB2    X2 
          AX3    4           X3 NONZERO NOW MEANS CHANGE MODE 
          JP     B2+VTYPE 
* /---   BLOCK      GENREAD    00 000   78/07/28  03.26 
* 
 VTYPE    EQ     ISHORT 
          EQ     ILONG
          EQ     ISTUD
          EQ     ICOM 
          EQ     COMPERR     IMPOSSIBLE CODE TYPE 
          EQ     SEGERR 
          EQ     MATERR 
          EQ     COMPERR     IMPOSSIBLE CODE TYPE 
          EQ     COMPERR     NO SHORT F LITERALS
          EQ     FLONG
          EQ     ISTUD
          EQ     ICOM 
          EQ     COMPERR     IMPOSSIBLE CODE TYPE 
          EQ     COMPERR     IMPOSSIBLE CODE TYPE 
          EQ     COMPERR     IMPOSSIBLE CODE TYPE 
          EQ     COMPERR     IMPOSSIBLE CODE TYPE 
* 
 ISHORT   NZ     X3,ISHORT2  IF NO I TO F NEEDED, X3 ZERO 
          SA1    NOTLITS     IS IT LITERAL OPERATION
          ZR     X1,ITSLIT   JUMP IF ITS LITERALS 
          ZR     X6,ISHORT0  JUMP IF LITERAL = 0
 ITSHT1   SX7    B1+710B     CONSTRUCT   SXN LITERAL
          LX7    21 
          BX7    X7+X6       X6 HOLDS LITERAL 
          RJ     LONGI       ADD INSTUCTION TO STREAM 
          RJ     FREEX       FREE THE REGISTER
          EQ     GENREAD
* 
 ISHORT0  SX1    0
 ITMSK    SX7    B1+430B     MXN  0 
          LX7    6
          BX7    X7+X1
          RJ     SHORT       ADD INSTRUCTION TO STREAM
          RJ     FREEX
          EQ     GENREAD
* 
 ISHORT2  PX6    X6          NEED FLOATED, SO PLANT FLOATED LITERAL 
          NX6    X6 
 ISHORT3  SA1    NOTLITS     CHECK FOR LITERAL OPERATION
          NZ     X1,ISHORT4  JUMP IF NOT LITERALS 
 ITSLIT   SA6    ARG+B1      B1 IS 1 OR 2---STORE IN ARG1 OR ARG2 
          EQ     GENREAD
 ISHORT4  BSS    0
          ZR     X6,ISHORT0  -- LITERAL 0 CAN BE HANDLED
          SB2    B1          ELSE SAVE B1 
          RJ     LSEEK       PLANT LITERAL IN EXTRA STORAGE 
          SB1    B2          RESTORE B1 
          SX3    B0          CHANGE DONE
          SX0    5           LITERALS RELATIVE TO B5
 GENR3    SX7    B1+510B     CONSTRUCT   SAN BM+(ADDRESS) 
          LX7    3
          BX7    X7+X0       BRING IN B-REGISTER
          LX7    18 
          BX7    X7+X6       X6 CONTAINS ADDRESS
          RJ     LONGI       ADD INSTRUCTION TO STREAM
          RJ     FREEX       FREE REGISTER
          ZR     X3,GENREAD  ALL DONE IF NO FLOAT NEEDED
          RJ     FLOATIT     ADD IN FLOAT INSTRUCTIONS (PXN, NXN) 
          EQ     GENREAD
* 
* /---   BLOCK      GENREAD    00 000   78/07/28  03.39 
 ILONG    SA1    NADS        X1 = GETVAR CODE 
          SA1    X1+ADS 
          RJ     RLLIT       X6 = LITERAL 
          NZ     X3,ISHORT2  FLOAT IF NECESSARY 
*          EQ     ISHORT3 
          BX1    X6          SAVE LITERAL IN X6 
          AX1    17 
          NZ     X1,ISHORT3  NOT FIT IN 18 BITS 
          SA1    NOTLITS
          ZR     X1,ITSLIT   JUMP IF ITS LITERALS 
          PL     X6,ITSHT1   SHORT 18 BIT POSITIVE NUMBER 
          NZ     X6,FIXMNS   IT IS NEGATIVE 
          SX1    60          MINUS 0
          EQ     ITMSK
 FIXMNS   SX1    X6+1 
          ZR     X1,MNS1
          MX1    -18
          BX6    -X1*X6 
          EQ     ITSHT1      IT IS NOW 18 BITS LONG 
 MNS1     SX1    59 
          EQ     ITMSK       MINUS 1 = MXN 60-1 
* 
 ISTUD    MX0    0           NO B REGISTER NEEDED 
          SA1    ASVARS 
          IX6    X1+X6       FORM ABSOLUTE ADDRESS
          EQ     GENR3
 ICOM     MX0    0           NO B REGISTER NEEDED 
          SA1    ACVARS 
          IX6    X1+X6       FORM ABSOLUTE ADDRESS
          EQ     GENR3
 FLONG    SA1    NADS        X1 = GETVAR CODE 
          SA1    X1+ADS 
          RJ     RLLIT       X6 = LITERAL 
          EQ     ISHORT3
* /---   BLOCK      VREAD      00 000   77/12/18  17.20 
          TITLE  VREAD -- CODE TO READ VERTICAL SEGMENTS
* 
*         COMPILE CODE TO READ VERTICAL SEGMENT OUT OF
*         WORD IN X1 ... B1=STARTBIT-1, B2=BITS/BYTE
*         AND A0 HAS REGISTERS TO USE (*SHORT* SAVES THESE) 
* 
 VREAD    EQ     *
          NG     X1,VREADS   JUMP IF SIGNED SEGMENT 
          SX6    B1+B2       SB-1+BB = SHIFT TO RIGHTJUSTIFY
          MX0    -6 
          BX6    -X0*X6      PROTECTION 
          SX3    X6-60
          ZR     X3,VREAD2   CHECK FOR SHIFT = 60 
          SX2    A0 
          BX2    X0*X2       GET WORD REGISTER  N00B
          SX2    X2+20000B   ADD LX CODE
          BX7    X2+X6       AND SHIFT COUNT
          CALL   SHORT       FORM *LXN SHIFT* 
* 
 VREAD2   SX2    60 
          SX1    B2 
          IX1    X2-X1
          MX0    -6          PROTECTION 
          BX1    -X0*X1 
          MX0    -3 
          SX2    A0 
          BX2    -X0*X2      GET MASK REGISTER
          SX2    X2+430B     FORM MXK MASK
          LX2    6
          BX7    X2+X1
          CALL   SHORT
          SX7    A0+15000B   FORM BXN -XM*XN
          CALL   SHORT
          EQ     VREAD
* 
 VREADS   MX0    -6 
          SX6    B1          LEFT JUSTIFY SHIFT 
          BX6    -X0*X6      PROTECTION 
          SX1    A0 
          BX1    X0*X1       GET WORD REGISTER  N00B
          SA0    X1          AND SAVE IT
          SX7    X6+20000B   FORM AN  LXN  K
          BX7    X1+X7
          RJ     SHORT       ADD INSTRUCTION
          SB1    60 
          SX2    B1-B2       60-BB = RIGHTJUSTIFY SHIFT 
          SX1    A0          GET WORD REGISTER
          BX1    X1+X2
          SX7    X1+21000B   FORM AN  AXN  K
          RJ     SHORT
          EQ     VREAD
* /---   BLOCK      VSTORE     00 000   77/12/18  17.31 
          TITLE  VSTORE 
* 
*         VSTORE CALLED WITH B1=STARTBIT, B2=BITS/BYTE
*         GENERATE CODE TO SHIFT RESULT (IN X6), FORM 
*         MASK (IN X3), CLEAR OUT BYTE IN OLD WORD (IN X1)
*         AND STORE (FROM X7) BACK WITH NEW BYTE
* 
 VSTORE   EQ     *
          SX6    B1+B2       COMPUTE SHIFT TO RIGHT JUSTIFY 
          MX0    -6 
          BX6    -X0*X6      PROTECTION 
          SA0    X6          SAVE 
          SX0    X6-60       SKIP IF LX1 60 
          ZR     X0,VSTOR2
          SX7    20100B      FORM LX1 SHIFT 
          BX7    X6+X7
          CALL   SHORT
*                  NOTE SHORT SAVES B1,B2,A0
 VSTOR2   SB1    60 
          SX1    B1-B2       MASK SIZE
          MX0    -6 
          BX1    -X0*X1      PROTECTION 
          SX7    43300B      FORM   MX3  MASK 
          BX7    X1+X7
          CALL   SHORT
          SX7    11131B      FORM  BX1  X3*X1 
          CALL   SHORT
          SX7    15763B      GENERATE AN  BX7  -X3*X6 
          CALL   SHORT
          SX7    12717B      FORM   BX7  X1+X7
          CALL   SHORT
* 
          SB1    A0          LOAD RIGHT-JUSTIFY SHIFT 
          SB2    60 
          SX1    B2-B1       COMPUTE SHIFT TO RE-POSITION 
          ZR     X1,VSTOR4   SKIP IF SHIFT IS 0 
          SX7    20700B      GENERATE AN  LX7  SHIFT
          BX7    X1+X7
          CALL   SHORT
* 
 VSTOR4   SX7    54710B      GENERATE AN  SA7  A1+B0
          CALL   SHORT
          EQ     VSTORE      DONE 
* /---   BLOCK      VSINDX     00 000   77/12/18  17.20 
          TITLE  VSINDX -- CODE TO LOAD SEGMENT INFO WORD 
* 
*         -VSINDX-
*         GENERATE CODE TO LOAD VERTICAL SEGMENT WORD 
*         ON ENTRY -  *SEGWD* = SEGMENT INFO WORD 
*                     *NADS*  = POINTER TO INDEX
* 
 VSINDX   EQ     *
          CONDEN
          SA1    NADS        INDEX IN ADDRESS STACK 
          SA2    X1+ADS      LOAD INDEX ADTYPE
          MX0    -XCODEAL 
          BX3    X0*X2
          ZR     X3,SVCONST  JUMP IF CONSTANT INDEX 
          ENDIF 
* 
          SB1    1           READ INDEX TO X1 
          CALL   FORCEX 
          SA1    NADS        LOAD POINTER IN ADDRESS STACK
          SA1    X1+ADS      LOAD INDEX ADTYPE
          LX1    59-XCODEAL-3     POSITION I/F BIT
          PL     X1,VSEG10   JUMP IF INTEGER INDEX
          SB1    2
          CALL   CHEKRR      OBTAIN X2 FOR -INDXFLT-
          SB1    1           REGISTER NUMBER OF INDEX 
          CALL   INDXFLT     GENERATE CODE TO ROUND INDEX 
* 
 VSEG10   SX6    1           SET INDEX REGISTER NUMBER
          SA6    FREG 
          SX7    63110B      GENERATE A  SB1  X1+B0 
          CALL   SHORT
*          SX7    0601B       SET UP  GE  B0,B1,K 
*          LX7    18
*          SA1    LLAERR      ADDRESS OF -ARAYERR-
*          BX7    X1+X7 
*          CALL   LONGI       GE  B0,B1,ARAYERR 
          SA1    SEGWD       LOAD SEGMENT INFO WORD 
          AX1    18          POSITION BASE ADDRESS
          SX4    X1          PICK OFF BASE ADDRESS
          NG     X1,VSEGC    JUMP IF -NC- VARIABLE
          SA2    ASVARS      ADDRESS OF -N- VARIABLES 
          IX6    X2+X4
          SA6    SEGWD1      SAVE ABSOLUTE BASE ADDRESS 
          SX2    X4-VARLIM-1
          PL     X2,VSEGR    JUMP IF -NR- VARIABLE
* /---   BLOCK      VSINDX     00 000   79/02/09  13.55 
* 
          SX1    VARLIM      SET LIMIT FOR -N- VARIABLES
          EQ     VSEG30 
* 
 VSEGR    SA2    ARVARS      X2 = CM ADDR OF NR1
          IX4    X6-X2       X4 = RVAR BASE INDEX OF SEG
          SX3    X4-RVARLIM-1 
          PL     X3,VSEGL    IF -NL- VARIABLE 
* 
          SA1    RVARL
          ZR     X1,VARERR   SET LIMIT FOR -NR- VARIABLES 
          EQ     VSEG30 
* 
 VSEGL    SA2    ALVARS      X2 = CM ADDR OF NL1
          IX4    X6-X2       X4 = LVAR BASE ADDRESS OF SEG
          SA1    LVARN       X1 = LOCALS IN THIS UNIT 
          IX3    X2-X4
          NG     X3,VARERR   IF NOT INSIDE ANY VAR BANK 
* 
          EQ     VSEG30 
* 
 VSEGC    SA2    ACVARS      ADDRESS OF -NC- VARIABLES
          IX6    X2+X4
          SA6    SEGWD1      SAVE ABSOLUTE BASE ADDRESS 
          SX1    NCVRLIM    SET LIMIT FOR -NC- VARIABLES
* 
 VSEG30   IX1    X1-X4       SUBTRACT BASE ADDRESS
          NG     X1,VARERR
          SX1    X1+1        COMPUTE MAX LEGAL INDEX
          SX7    6120B       GENERATE A  SB2  B0+LIMIT
          LX7    18 
          BX7    X1+X7       ATTACH LIMIT 
          CALL   LONGI
* 
          SX7    0601B       SET UP  GE  B0,B1,K
          LX7    18 
          SA1    LLAERR      ADDRESS OF -ARAYERR- 
          BX7    X1+X7
          CALL   LONGI       GE  B0,B1,ARAYERR
* 
          SX7    0721B       GENERATE A  LT  B2,B1,ARAYERR
          LX7    18 
          SA1    LLAERR      ADDRESS OF -ARAYERR- 
          BX7    X1+X7
          CALL   LONGI       LT  B2,B1,ARAYERR
* 
          SX7    5111B       GENERATE A  SA1  B1+BASE 
          LX7    18 
          SA1    SEGWD1      LOAD ABSOLUTE BASE ADDRESS 
          SX1    X1-1        ADJUST (INDEX STARTS AT 1) 
          BX7    X1+X7
          CALL   LONGI       SA1  B1+BASE 
          EQ     VSINDX 
* /---   BLOCK      LDLITAD    00 000   77/12/19  19.24 
          TITLE  LDLITAD -- CODE TO GET ADDRESS OF INFO WORD
* 
*         -LDLITAD- 
* 
*         GENERATES CODE TO LOAD THE ADDRESS OF THE SEGMENT/
*         ARRAY LITERAL INFO WORD TO REGISTER B1. 
* 
* 
 LDLITAD  EQ     *           SUBROUT TO LOAD LITWD ADR TO B1
          SA1    NADS        LOAD SEGMENT/ARRAY ADTYPE
          SA1    X1+ADS 
          MX0    -XCODEAL 
          BX7    -X0*X1      MASK OFF ADDRESS OF INFO 
          SA7    IOP         SAVE FOR ARRAY 
          SX1    6115B       GENERATE A   SB1  B5+K 
          LX1    18 
          BX7    X1+X7       ATTACH ADDRESS 
          RJ     LONGI
          EQ     LDLITAD
* /---   BLOCK      GENFCT     00 000   77/12/19  16.50 
          TITLE  GENFCT -- GENERATE CODE TO CALL FUNCTION 
* 
*         -GENFCT-
* 
*         GENERATE CODE TO CALL FUNCTION AND RETURN RESULT
*         IN REGISTER X1. 
* 
* 
 GENFCT   EQ     *           GENERATE CODE TO GET FN RESULT 
          SA1    LLEXLOC     ADDRESS OF TABLE OF ADDRESSES
          IX0    X0+X1       ENTER WITH FN NUMBER IN X0 
          SA0    ITEMP
+         RE     1           READ TABLE ENTRY 
          RJ     ECSPRTY
          SA1    A0          LOAD ADDRESS AND CONSTANT BIT
          NG     X1,CMPKON   JUMP IF CONSTANT NOT FUNCTION
          BX0    X1 
          LX0    1           SEE IF FUNCTION HAS AN ARGUMENT
          NG     X0,CMPF20   JUMP IF NO ARGUMENT
          SA2    FFLT 
          ZR     X2,CMPF20   JUMP IF INTEGER ARGUMENT 
          SX1    X1-2        DECREMENT ADDRESS FOR FLOATING 
* 
 CMPF20   SX1    X1          PICK OFF ADDRESS PORTION 
          SX7    0100B
          LX7    18          SET UP -RJ- INSTRUCTION
          BX7    X1+X7
          RJ     LONGI       ADD -RJ- TO INSTRUCTION STREAM 
          RJ     PAD         FILL OUT REST OF WORD
          EQ     GENFCT 
* 
 CMPKON   BX0    X1 
          LX0    1           JUMP IF CONSTANT 
          NG     X0,CMPKON1  FALL THROUGH IF MEMORY FETCH 
          SX1    X1          GET ADDRESS PORTION
          SX7    5110B       GENERATE A  SA1  B0+K
          LX7    18 
          BX7    X1+X7       ATTACH ADDRESS 
          RJ     LONGI       ADD TO INSTRUCTION STREAM
          EQ     GENFCT 
 CMPKON1  MX0    2
          BX1    -X0*X1 
          MX4    0
          EQ     INTIN       CREATE INTEGER GETVAR
* /---   BLOCK      SETAD      00 000   77/12/19  16.48 
          TITLE  SETAD -- MARK *ADS* ENTRY NOW IN REGISTER
* 
*         -SETAD- 
* 
*         MARK ENTRY IN *ADS* LIST NOW IN REGISTER
* 
 SETAD    EQ     *           SET AD IN ADS LIST TO REGISTER ASSIGNMENT
          SX7    1           UPDATE AD REFERENCE
          SA7    RX+1        FLAG X1 IN USE 
          MX1    1           SIGN BIT FOR REGISTER
          BX7    X7+X1
          SA1    FLOAT       0 IF INTEGER RESULT OF FUNCTION
          BX7    X7+X1
          SA1    NADS 
          SA7    X1+ADS 
          EQ     SETAD
* /---   BLOCK      FLOATIT    00 000   77/12/19  19.37 
          TITLE  FLOATIT -- SET UP FLOAT INSTRUCTIONS 
* 
*         -FLOATIT- 
* 
*         GENERATE CODE TO CONVERT THE INTEGER CONTENTS OF
*         A REGISTER TO FLOATING POINT FORMAT.
* 
*         B1 = REGISTER NUMBER
* 
* 
 FLOATIT  EQ     *           SET UP FLOAT INSTRUCTIONS
          SX7    B1          B1 HAS REGISTER NO.
          LX7    6
          SX7    X7+B1       N0N
          SX7    X7+27000B   27 IS PXN
          RJ     SHORT
          SX7    B1          B1 HAS REGISTER NO.
          LX7    6
          SX7    X7+B1       N0N
          SX7    X7+24000B   24 IS NXN
          RJ     SHORT
          EQ     FLOATIT
* /---   BLOCK      INDXFLT    00 000   77/12/18  17.16 
          TITLE  INDXFLT -- GENERATE CODE TO ROUND INDEX
* 
*         -INDXFLT- 
*         GENERATE INSTRUCTIONS TO ROUND INDEX
*         B1 = REGISTER NUMBER OF INDEX 
* 
*         CODE PRODUCED WILL DESTROY X2 
* 
* 
 INDXFLT  EQ     *
          SX7    17174B      0.5 = 17174 00000 00000 00000
          SX6    712B        -SX2- OPERATION
          LX6    21 
          BX7    X6+X7       MERGE TO FORM -SX2 17174B- 
          RJ     LONGI       LONGI PRESERVES B1 
          SX7    20255B      -LX2 45- 
          RJ     SHORT       SX2 AND LX2 FORM 0.5 IN X2 
          SX7    B1          NEXT FORM  -FXN  X2+XN-
          LX7    6
          SX7    X7+B1       N0N
          SX7    X7+30020B   FORM -FXN X2+XN- 
          RJ     SHORT
          SX7    B1 
          LX7    6
          SX7    X7+B1
          SX7    X7+26010B   FORM -UXN  B1,XN-
          RJ     SHORT
          SX7    B1 
          LX7    6
          SX7    X7+B1
          SX7    X7+22010B   FORM -LXN  B1,XN-
          RJ     SHORT
          EQ     INDXFLT
* /---   BLOCK      FORCEX     00 000   78/01/31  23.21 
          TITLE  FORCEX -- READ ADTYPE TO SPECIFIED REGISTER
* 
*         -FORCEX-
* 
*         READ ADTYPE TO SPECIFIED REGISTER 
* B1 ENTERED WITH REGISTER TO GET.  EXITS THE SAME. 
* 
 FORCEX   EQ     *
          SX6    B1          SAVE DESIRED REGISTER NUMBER 
          SA6    FREG 
          RJ     GENREAD     TRY TO READ TO DESIRED REGISTER
          SA2    FREG 
          SB2    X2          SEE IF READ TO PROPER REGISTER 
          MX7    1
          SA7    B1+RX       MARK CURRENT REGISTER IN USE 
          EQ     B1,B2,FORCEX 
          SX6    B1          SAVE CURRENT REGISTER NUMBER 
          SA6    FREG 
          SB1    B2          GET DESIRED REGISTER NUMBER
          SA1    B1+RX
          ZR     X1,FCONT    DESIRED REGISTER IS FREE 
          SX6    X6-7 
          ZR     X6,PMIND    IS EXPRESSION TOO COMPLICATED
 PFCONT   RJ     CHEKRR      FREE DESIRED REGISTER
* B1 SAVED IN CHEKRR
 FCONT    SX7    1           MARK DESIRED REGISTER IN USE 
          SA7    B1+RX
          SX1    B1 
          SA2    FREG        CURRENT REGISTER NUMBER
          MX7    0           FREE CURRENT REGISTER
          SA7    X2+RX
          LX1    6           POSITION REGISTER NUMBERS
          LX2    3
          BX1    X1+X2
          SX7    X1+10000B   FORM A   BXN  XM 
          RJ     SHORT
          EQ     FORCEX 
* 
* BELOW IS FIX TO FIX 
 PMIND    SA1    RX+3        IS X3 AVAILABLE
          ZR     X1,PFCONT
          SA1    RX+4 
          ZR     X1,PFCONT
          SA1    RX+5 
          ZR     X1,PFCONT
          SA1    RX+0 
          ZR     X1,PFCONT
          EQ     MINDERR     EXPRESSION IS COMPLICATED
* 
 FREG     BSS    1
* 
* /---   BLOCK      CHEKRR     00 000   80/01/17  22.19 
          TITLE  CHEKRR -- CHECK READ REGISTER AVAILABLE
* 
*         -CHEKRR-
* 
*         CHECK IF A READ REGISTER IS AVAILABLE.  IF NOT, 
*         CODE IS GENERATED TO MAKE IT AVAILABLE BY SAVING
*         THE DESIRED REGISTER IN A TEMPORARY.
* 
* ENTER WITH B1 = REGISTER TO CHECK.  EXITS THE SAME. 
* 
* 
 CHEKRR   EQ     *           CHECK READ REGISTER AVAILABILITY 
          SA1    B1+RX       REQUESTED READ REGISTER NO. IN B1
          ZR     X1,CHEKRR   AVAILABLE
          SB2    B1          NOPE, SAVE DESIRED REGISTER NO. IN B2
          RJ     CHOOSEX     CHOOSE A REGISTER TO SEND X1 TO. 
          SX7    B0 
          SA7    B2+RX       FREE IT
          EQ     B1,B2,CHEKRR  AVOID  BX7 X7
          SX7    B2 
          SB3    1
          MX2    57          MASK FOR REGISTER NUMBER 
          SA1    ADS-1
 FINDXN   SA1    A1+B3       FIND THE REFERENCE TO IT 
          PL     X1,FINDXN   REGISTER REFERENCE HAS SIGN BIT LIT
          BX6    -X2*X1     REG. NO.
          BX6    X6-X7
          NZ     X6,FINDXN   MUST BE IN ADS LIST
***       ERROR PROTECTION
          SX6    OPS+OPSMAX 
          SX7    A1 
          IX6    X7-X6
          PL     X6,MINDERR  EXPRESSION TOO COMPLICATED 
*** 
          SX7    B1          DESTINATION REGISTER NO. 
          BX1    X2*X1       SAVE BITS OTHER THAN REGISTER NO.
          BX6    X1+X7       BRING IN NEW REG. NO.
          SA6    A1          CHANGE ADDRESS TO NEW REGISTER 
          SX7    X7+100B     BUILD BX(DESTINATION) ORIGIN 
          LX7    3
          SX7    X7+B2       ORIGIN REGISTER NO.
          LX7    3
          RJ     SHORT       ADD TO INSTRUCTION STREAM
          SB1    B2          RESTORE B1 
          EQ     CHEKRR 
* /---   BLOCK      PICKX      00 000   77/12/19  19.40 
          TITLE  PICKX -- PICK A RESULT REGISTER
* 
*         -PICKX- 
* 
*         CHOOSE A RESULT DESTINATION REGISTER.  THIS ALSO
*         UPDATES THE ADS ENTRY CORRESPONDING TO THE DESIRED
*         REGISTER. 
* 
*         B1 = REGISTER NUMBER
* 
* 
 PICKX    EQ     *           PICK A RESULT DESTINATION REGISTER 
***** 
*         ATTEMPT TO USE X1 FOR DESTINATION IF LAST OP. 
* 
*INHAND OP PRECEDENCE LEVEL FOR END OF LINE OR COMMA IS -1
          SA1    INHANDL     CHECK WHETHER LAST OPERATION 
          SX1    X1+B0       OP INHAND LEVEL IN LOW-ORDER BITS
          PL     X1,PICKXX   JUMP IF NOT END OF LINE OR COMMA 
          SA1    NOPS 
          SX1    X1-2        IF LAST OP, NOPS=2 (OPS(1) IS BEGIN LINE)
          NZ     X1,PICKXX   JUMP IF NOT LAST OP
          SB1    1           CHOOSE X1 DESTINATION
          EQ     PICKED2
 PICKXX   RJ     CHOOSEX     CHOOSE A VACANT REGISTER 
 PICKED2  SX7    B1          UPDATE OPERAND REFERENCE (B1 GIVES REG. NO)
          MX0    1           SIGN BIT 
          BX7    X7+X0       FLAG REGISTER ADTYPE WITH SIGN BIT 
          SA1    FLOAT       IS IT FLOATING RESULT
          ZR     X1,PICKED3  JUMP IF INTEGER RESULT 
          SX0    1
          LX0    XCODEAL+3   SET UP I/F BIT 
          BX7    X7+X0       MERGE
 PICKED3  SA1    NADS 
          SA7    X1+ADS      STORE ADTYPE OF RESULT 
          EQ     PICKX
* /---   BLOCK      CHOOSEX    00 000   77/12/19  19.42 
          TITLE  CHOOSEX -- CHOOSE A VACANT REGISTER
* 
*         -CHOOSEX- 
* 
*         CHOOSE ANY UNUSED REGISTER.  IF ALL REGISTERS ARE 
*         IN USE, CODE WILL BE GENERATED TO MAKE FREE X7 BY 
*         STORING THE VALUE INTO A TEMPORARY CM CELL. 
* 
*         ON EXIT,
*         B1 = UNUSED REGISTER NUMBER 
* 
* 
 CHOOSEX  EQ     *           CHOOSE A VACANT REGISTER 
          SA1    RX+7        USE X7 IF AVAILABLE
          ZR     X1,CHOSEN   (RX+7) = 0 IF X7 NOT IN USE
          SA1    RX+0        THEN TRY X0
          ZR     X1,CHOSEN
          SA1    RX+5        KEEP LOOKING 
          ZR     X1,CHOSEN
          SA1    RX+4 
          ZR     X1,CHOSEN
          SA1    RX+3 
          ZR     X1,CHOSEN
          SX7    7           NO REGISTER AVAILABLE, STORE X7 IN TEMPS 
          MX2    57          MASK FOR REGISTER NUMBER 
          SB1    1
          SA1    ADS-1
 FINDX7   SA1    A1+B1       FIND THE OPERAND NOW IN X7 
          PL     X1,FINDX7   REGISTER IS FLAGGED NEGATIVE 
          BX1    -X2*X1      GET REGISTER NUMBER
          BX1    X1-X7
          NZ     X1,FINDX7
          RJ     STR7TMP     PUT CONTENTS OF X7 IN TEMPSTOR 
          SB1    7           MARK REGISTER 7 CHOSEN 
          EQ     CHOOSEX
* 
 CHOSEN   SB1    A1-RX       CALC CHOSEN REGISTER NUMBER
          SX7    1
          SA7    A1          MARK IT TO BE IN USE 
          EQ     CHOOSEX
* /---   BLOCK      STR7TMP    00 000   77/12/19  19.43 
          TITLE  STR7TMP -- CODE TO STORE X7 IN TEMPORARY 
* 
*         GENERATES CODE TO STORE X7 IN TEMPSTOR LOC
*         AND UPDATES ADS LIST ACCORDINGLY. 
* 
*         ON ENTRY, 
*         A1 = ADDRESS OF ENTRY IN *ADS* LIST CORRESPONDING 
*              TO THE OPERAND IN REGISTER X7. 
* 
* 
 STR7TMP  EQ     *           ENTER WITH *ADS+NADS* IN A1
          SA2    TEMP        PICK UP PRESENT TEMP STACK PTR 
          SX7    X2+1        INCREMENT TEMP POINTER 
          SA7    TEMP 
          SX7    X7-TEMPLIM 
          PL     X7,TEMPERR  JUMP IF TOO MANY TEMPS USED
          SX2    X2+VARLIM+1   FIRST TEMP IS V(VARLIM+1)
          SX7    1           CONSTRUCT I/F MASK 
          LX7    XCODEAL+3
          SA1    A1          GET ADTYPE OF OPERAND IN X7
          BX7    X7*X1       GET I/F BIT
          BX7    X7+X2       BRING IN TEMP ADDRESS
          SX1    2           GETVAR CODE FOR STUDENT BANK 
          LX1    XCODEAL
          BX7    X7+X1       FORM COMPLETE GETVAR CODE
          SA7    A1          AND CHANGE STACK AD (WAS IN X7)
          SX7    5170B       GENERATE SA7 B0+** 
          LX7    18 
          SA1    ASVARS      GET BASE ADD FOR STUDENT VARS
          IX2    X1+X2
          BX7    X7+X2
          RJ     LONGI
          EQ     STR7TMP
* /---   BLOCK      FREEX      00 000   77/12/19  19.43 
          TITLE  RLLIT -- RETRIEVE LONG LITERAL 
* 
*         -RLLIT- 
*         RETRIEVE LONG LITERAL 
* 
*         (X6) = LONG LITERAL 
* 
*         ON ENTRY - (X1) = GETVAR CODE FOR LITERAL 
* 
*         ON EXIT - (X6) = LITERAL
*                   (X1) = GETVAR CODE W/LIST BIT RESET 
* 
*         USES A/X0,A/X6,A1 
* 
          ENTRY  RLLIT
 RLLIT    EQ     *
          MX0    60-XCODEAL  ADDRESS MASK 
          BX0    -X0*X1      ADDRESS OF LITERAL 
          BX6    X1          SAVE ADTYPE
          LX1    60-LITSHF1       *LITS* BIT = SIGN BIT 
          PL     X1,RLLIT10   IF LITERAL IS IN *TOKBUF* 
* 
          SA1    NLITS       LITS STACK POINTER 
          BX1    X1-X0       CHECK FOR TOP OF LITS STACK
          NZ     X1,RLLIT08  DO NOT DECREMENT IF NOT TOP
* 
          BX1    X6          SAVE ADTYPE
          SX6    X0-1        POP LITS STACK 
          SA6    A1 
          BX6    X1          SAVE ADTYPE
 RLLIT08  SA1    X0+LITS     GET LIT
*          MX0    59          TURN OFF *LITS* BIT 
*          LX1    60-LITSHFT
*          BX1    X0*X1 
*          LX1    LITSHFT 
          EQ     RLLIT20
* 
 RLLIT10  BSS    0           LITERAL IS IN *TOKBUF* 
          SA1    ATOKEN      ADDR OF TOKENS 
          IX0    X1+X0       ADDR OF LIT IN ECS 
          SA0    LLITEMP
          RE     1           LITERAL IS IN *LLITEMP*
          RJ     ECSPRTY
          SA1    LLITEMP     (X1) = LITERAL 
* 
 RLLIT20  BX0    X6          RESTORE (X1) AND SET (X6)
          BX6    X1 
          BX1    X0 
          EQ     RLLIT
* 
* 
          TITLE  SLLIT -- STORE LONG LITERAL
* 
*         -SLLIT- 
*         STORE LONG LITERAL
* 
*         ON ENTRY - (X6) = LONG LITERAL
*         (X1) = TYPE CODE
* 
*         ON EXIT - (X6) = ADTYPE WITH ADDRESS
* 
*         USES X0,A/X1,X6 
* 
          ENTRY  SLLIT
 SLLIT    EQ     *
          BX0    X1          SAVE TYPE CODE 
          SA1    NLITS
          SA6    LITS+1+X1   STORE LITERAL AND FREE X6
          SX6    X1+1 
          SA6    A1 
          SX1    X6-LITL     JUMP IF TOO MANY LITERALS
          PL     X1,LITERR
* /---   BLOCK      FREEX      00 000   77/12/19  19.43 
          LX0    XCODEAL     POSITION TYPE CODE 
          BX6    X0+X6       CREATE GETVAR CODE 
          SX0    1
          LX0    LITSHFT     POSITION *LITS* BIT
          BX6    X0+X6       FLAG LIT ADDR POINTS TO *LITS* 
          EQ     SLLIT
* 
 LLITEMP  BSS    1
          TITLE  FREEX -- FREE UP A REGISTER
* 
*         -FREEX- 
* 
*         MARK A REGISTER UNUSED
* 
*         B1 = REGISTER TO FREE UP
* 
* 
 FREEX    EQ     *           FREE REGISTER NO LONGER IN USE 
          SX7    B0          MUST NOT ALTER X1,X3,X6
          SA7    B1+RX       REGISTER SPECIFIED IN B1 
          EQ     FREEX
* /---   BLOCK      LSEEK      00 000   77/12/17  18.01 
          TITLE  LSEEK -- SEARCH FOR EXISTING LITERALS
* 
*         -LSEEK- 
* 
*      SUBROUTINE TO PLANT LITERAL IN XTRA STORAGE
*      MUST NOT CHANGE B2,X0,A0 OR X6,X1,A1 AS SET
*      RETURN B1=0 IF NEW LITERAL 
* 
 LSEEK    EQ     *           ADD ONE LITERAL
          MX2    0           FLAG ONLY ONE
          RJ     LSEEKA 
          EQ     LSEEK
* 
 LSEEK2   EQ     *           ADD TWO LITERALS 
          MX2    -1          FLAG TWO 
          RJ     LSEEKA      (X7 HAS 2ND LITERAL) 
          EQ     LSEEK2 
* 
 LSEEKA   EQ     *           SEEK LITERAL IN EXTRA STORAGE
          SA1    INX         GET EXTRA STORAGE POINTER
          SA6    X1+INFO     PLANT SEARCH ITEM
          SA1    INFO-1      INITIAL ADDRESS
          SB1    1
          SA7    A6+B1       PLANT 2ND LITERAL
 LSEEKB   SA1    A1+B1       GET NEXT ITEM
          BX1    X6-X1       COMPARE WITH X6
          NZ     X1,LSEEKB
          NG     X1,LSEEKB   PROTECT AGAINST (-0)-(0) 
          ZR     X2,LSEEKC   JUMP IF ONLY ONE LITERAL 
          SA3    A1+B1       GET 2ND LIT
          IX3    X3-X7
          NZ     X3,LSEEKB
          NG     X3,LSEEKB   PROTECT AGAINST (-0)-(0) 
 LSEEKC   SB1    INFO        COMPUTE LOCATION OF LITERAL
          SX6    A1-B1
          SB1    A6          CHECK FOR NEW OR OLD LITERAL 
          SB1    A1-B1       COMPARE FOUND AND PLANT ADDRESSES
          NZ     B1,LSEEKA   DONE IF OLD LITERAL
          SA1    INX         OTHERWISE ADVANCE INX
          SX7    X1+1 
          SA7    A1 
          ZR     X2,LSEEKA
          SX7    X7+1        TWO LITERALS 
          SA7    A7 
          EQ     LSEEKA 
* /---   BLOCK      MOVCODE    00 000   77/12/19  19.45 
          TITLE  MOVE CODE
* 
*         -MOVCODE- 
* 
*         MOVE CODE INTO *ARGUMENT STORAGE* 
*         EXITS WITH ARG STORAGE ADDRESS OF CODE IN X0
*         ALSO DESTROYS A1,X1,A2,X2,A7,X7,B1,A0 
* 
*         ****NOTE**** THIS ROUTINE IS NO LONGER
*         USED BY -CALCS- BECAUSE IT DOES NOT DO
*         PROPER END TESTS FOR POSSIBLE OVERFLOW
*         OF THE -INFO- BUFFER -- 'PHIL 8/3/76
* 
* 
          ENTRY  MOVCODE
 MOVCODE  EQ     *
          CONDEN
          SX2    INST        CONDEN 
          ENDIF 
          PLATO 
          SX2    INFO+INFOX  LOCATION OF CODE DURING EXEC 
          ENDIF 
* 
          SA0    X2 
          SA1    NINST       POINTER TO LAST WORD OF CODE PLUS 1
          IX2    X1-X2
          SB1    X2          COUNT OF CODE WORDS
          SA1    ATEMPEC     ECS WORK BUFFER POINTER
          BX0    X1 
+         WE     B1          SEND CODE TO ECS 
-         RJ     =XECSPRTY
          SA1    INX         INFO POINTER 
          SX7    X1+B1       INCREMENT INX
          SA7    A1 
          SA0    X1+INFO
+         RE     B1          MOVE CODE INTO INFO BUFFER 
-         RJ     =XECSPRTY
          BX0    X1          LOCATION OF CODE IN INFO 
          EQ     MOVCODE
* /---   BLOCK      PAD        00 000   78/01/25  13.50 
          TITLE  PAD OUT INSTRUCTION WORD WITH NO-OPS 
* 
*         -PAD- 
* 
*         -LABDEF- IN IDENT CALCS ASSUMES THAT -PAD-
*         DOES NOT DESTROY A4,B4,X4,A5,B5,X5,A7,B7,X7 
* 
* THIS ROUTINE DOES NOT CHANGE B1,B2,A0 
* 
          ENTRY  PAD
 PAD      EQ     *           PAD OUT AN INSTRUCTION WITH NO-OPS 
          SA1    NINST       GET CURRENT INSTRUCTION WORD 
          SA2    X1 
 PADX1    ZR     X2,PAD      NO NEED TO PAD IF WORD EMPTY 
          LX2    15          MAY HAVE 15 OR 30 BITS TO PAD
          MX0    15          CHECK FOR NEEDED PADDING TO LEFT-ADJUST
          BX6    X2*X0       EXAMINE LEFT-MOST INSTRUCTION
          SX0    46000B      SET UP NO-OP INSTRUCTION 
          NZ     X6,PAD2     IF BITS SET, NOW LEFT-ADJUSTED 
          BX2    X2+X0       NO-OP AT RIGHT 
          EQ     PADX1       LOOP 
 PAD2     BX6    X2+X0       STICK IN A NO-OP 
          SA6    A2          PUT BACK LEFT-SHIFTED
          SB3    PAD
* 
*     UPDATE INSTRUCTION WORD POINTER--- ASSUMES A1,X1,B3 SET AT ENTRY
*     DESTROYS X6,A6,X1,A2,X2 
*         DO NOT ALTER B1,B2,A0...A4,B4,X4,A5,B5,X5,A7,B7,X7
          ENTRY  UPNINST
 UPNINST  SX1    X1+1        INCREMENT INSTUCTION WORD POINTER AND
          SA2    NINSTLIM    LIMIT ON NINST 
          IX2    X1-X2
          PL     X2,LNGERR   TOO BAD, RAN OVER
          BX6    X1 
          SA6    A1          STORE NEW POINTER
          MX6    0
          SA6    X1          CLEAR OUT NEW INST WORD
          JP     B3          RETURN TO CALLER 
* /---   BLOCK      SHORT      00 000   78/01/20  14.58 
          TITLE  ADD SHORT INSTRUCTION TO STREAM
* 
*         -SHORT- 
* 
*         ADD A SHORT (15-BIT) INSTRUCTION TO THE OUTPUT
*         STREAM. 
* 
*         X7 = INSTRUCTION TO ADD (LOWER 15 BITS) 
* 
* 
*         DONT ALTER B1,B2,A0 IN THIS SUBROUTINE  (DLS) 
* 
          ENTRY  SHORT
 SHORT    EQ     *           ADD SHORT INSTRUCTION TO STREAM
          SA1    NOTLITS     IS IT LITERAL OPERATION
          NZ     X1,SHORT2   JUMP IF NOT LITERALS 
          SA1    =46000460004600000000B   THREE PASSES
          BX7    X1+X7       PLUS INSTRUCTION 
          SA7    EXECUTE     PLANT IT 
          SA1    ARGX1       LOAD FIRST ARG 
          SA2    ARGX2       LOAD SECOND ARG
          RJ     EXECIT      EXECUTE THE PLANTED INSTRUCTION
          SA1    NLITS       RESULT IN X7 
*NLITS HAS BEEN ALREADY INCREMENTED BY -BINARY-.
          SA7    X1+LITS     STORE IN LITS TABLE
          MX0    60-XCODEAL  CHECK TO SEE IF RESULT IS SHORT LITERAL
          BX0    X0*X7
          NZ     X0,SHORT3   IF LONG, SET LITS BIT
* 
          SA1    NADS 
          SA7    X1+ADS      CHANGE TO SHORT
          EQ     SHORT
 SHORT2   SA1    NINST       NOT LITERAL OPERATION
          SA2    X1          GET CURRENT WORD 
          LX2    15 
          BX7    X7+X2       MERGE NEW INSTRUCTION
          SA7    A2          STORE
          MX0    15 
          BX0    X7*X0       CHECK FOR FULL WORD
          ZR     X0,SHORT 
          SB3    SHORT
          EQ     UPNINST     UPDATE NINST, RETURN TO SHORT
* 
 SHORT3   SA2    NADS        INSERT *LITS* ADDRESS/BIT
          SA2    X2+ADS 
          AX2    XCODEAL
          LX2    XCODEAL
          BX6    X1+X2       ADDRESS
          SX1    1           INDICATE STORED IN *LITS 
          LX1    LITSHFT
          BX6    X1+X6
          SA1    NADS 
          SA6    X1+ADS 
          EQ     SHORT
* 
* 
* 
* THIS LITTLE THING IS DONE TO INSURE THAT THE INSTRUCTION
* STACK IS VOIDED.  'ON 'C'D'C MACHINES, A -RJ- INSTRUCTION 
* FORCES THE MACHINE TO RE-READ THE INSTRUCTIONS. 
* THIS ROUTINE IS REFERENCED FROM ',SHORT', AND ',LBINARY',.
* (ALL OPTIMIZATIONS ARE DONE IN SHORT BUT SHIFTS, AND THOSE
* ARE DONE IN LBINARY.) 
* 
 EXECIT   EQ     *
 EXECUTE  BSS    1           EXECUTE THE COMMAND
          EQ     EXECIT      RETURN FROM WHENCE IT CAME 
* 
* /---   BLOCK      LONGI      00 000   77/12/19  16.05 
          TITLE  ADD LONG INSTRUCTION TO STREAM 
* 
*         -LONGI- 
* 
*         ADD LONG INSTRUCTION TO OUTPUT STREAM.
* 
*         X7 = 30-BIT INSTRUCTION 
* 
* 
*         DO NOT ALTER B1,B2,A0,A5,B5,X5 IN THIS SUBROUTINE 
* 
          ENTRY  LONGI
 LONGI    EQ     *           ADD LONG INSTRUCTION TO STREAM 
          SA1    NINST
          SA2    X1          GET CURRENT WORD 
          MX0    30 
          BX0    X0*X2       CHECK FOR ENOUGH SPACE 
          ZR     X0,LONG2    JUMP IF SPACE
          LX2    15 
          SX6    46000B      SET UP PASS
          BX6    X6+X2
          SA6    A2          PUT IT AWAY
          SB3    LONG2A 
          EQ     UPNINST     INC NINST, RETURN TO LONG2A
 LONG2A   SA1    NINST       RELOAD IT
          MX2    0
 LONG2    LX2    30 
          BX7    X7+X2       BUILD WHOLE INSTRUCTION WORD 
          SA7    X1          STORE IT IN STREAM 
          MX0    15          CHECK FOR FULL WORD
          BX0    X0*X7
          ZR     X0,LONGI 
          SB3    LONGI
          EQ     UPNINST     INC INST POINTER, RETURN TO LONGI
* /---   BLOCK      STORAGE    00 000   78/09/15  19.13 
          TITLE  STORAGE DEFINITIONS
* 
* *       STORAGE DEFINITIONS 
* 
* 
 PREVOPL  BSS    1           PREVIOUS OP LEVEL
 LASTOP   BSS    1           LAST ITEM OPCODE, FOR UNARY - CHECK
 FINALOP  BSS    1           LAST OPERATION COMPILED
 CALC     BSS    1           1 IF CALC, 0 IF NOT A CALC COMMAND 
 INHAND   BSS    1           OP IN HAND 
 INHANDL  BSS    1           OP LEVEL IN HAND 
 IOP      BSS    1           SAVE INSTRUCTION CODE
 SAVEOP   BSS    1           SAVE OP
 FFLT     BSS    1           FLOATING ARGUMENT FLAG 
 POWER    BSS    1           SAVE EXPONENTIATION POWER
 FLOAT    BSS    1           SAVE FLOATING-PT INSTRUCTION CODE
 TEMP     BSS    1           TEMP STACK POINTER 
          ENTRY  NOTLITS
 NOTLITS  BSS    1           NZ IF OPERANDS NOT BOTH LITERALS 
 RECIP    BSS    1           RECIPROCAL FLAG (0 IF NOT NEEDED)
 ARGX1    BSS    2           LITERAL ARGUMENTS
 ARGX2    EQU    ARGX1+1
 ARG      EQU    ARGX1-1
 SEGWD    BSS    1           TEMP VARIABLES USED
 SEGWD1   BSS    1           BY SEGMENT, ARRAY ROUTINES 
 BUFCHK   BSS    1           NZ IF HAVE CHEKED ECS AVAILABLE
 ASIZE    BSS    1           TEMP-ARRAY SIZE,TYPE 
          ENTRY  ARAYFLG
 ARAYFLG  BSS    1           SET=1 BY CALLER IF EXPECTS ARAY
 TMPASIZ  BSS    1           TEMP ARRAY STORAGE USED
 TMPAFLG  BSS    1           TEMPORARY ARRAY INFO 
 AOPAD    BSS    1           SAVE ARRAY OPERAND ADDRESSES 
 TMPARAY  BSS    1           TEMPORARY ARRAY ADDRESS
 NARGS    BSS    1           NO. OF COMMAS IN MULTIPLE-ARGUMENT FUNCTION
 NARRAYS  BSS    1           NO. OF WHOLE ARRAYS ENCOUNTERED
 RX       BSS    8           REGISTER RESERVATIONS
*                ZERO IF NOT IN USE, 1 IF IN USE
          ENTRY  CSYMADD,CSYMNUM
 CSYMADD  BSS    1           SYMBOL TABLE ADDRESS 
 CSYMNUM  BSS    1           NUMBER OF SYMBOLS IN TABLE 
          CONDEN
 TOPCNT   BSS    1           NUMBER OF OPERATORS ENCOUNTERED
          ENTRY  TVARCNT
 TVARCNT  BSS    1           NUMBER OF VARIABLES REFERENCED 
          ENDIF 
* 
 FINDXED  BSS    1           0=INDEXED VARIABLE, IF IN REG. 
*SEE VARLOC OPTIMIZATION FOR EXAMPLE USEAGE 
* /---   BLOCK      END        00 000   77/12/16  15.14 
* 
          END