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<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