DEFINE
* /--- FILE TYPE = E
* /--- BLOCK DEFINE 00 000 81/07/13 01.10
IDENT DEFINE
LCC OVERLAY(1,1)
*
TITLE -DEFINE- COMMAND
TITLE
*
*
CST
*
*
DEFINE$ OVFILE
*
*
EXT ECSPRTY,COMPNAM,CSYMADD
EXT KEYTYPE,ERRORC,NXTC,COMCONT,HOLDEFN
EXT SEGREAD,UNSREAD,SEGFLG
EXT CHARERR,BADPAR,DECERR,VARERR
EXT LOGERR,FORMERR,EQERR,OCTERR
EXT ALFERR,INDXERR,DEFERR,SEGERR
EXT COMPERR,LNGERR,LITERR,TEMPERR
EXT KLOCAL
*
*
* /--- BLOCK DEFINE 00 000 76/06/07 15.09
TITLE READIN FOR -DEFINE- COMMAND
*
* -DEFREAD-
* READIN ROUTINE FOR -DEFINE- COMMAND
*
* USE OF BUFFERS -
*
* *VARS* CONTAINS SEVEN CHARACTER DEFINE
* NAMES WITH 18 BIT GETVAR CODES LOWER IN ORDER
* BY FIRST CHARACTER
*
* *TOKBUF* (ECS RESIDENT TABLE)
* CONTAINS 12 BIT TOKENS ASSOCIATED WITH NON
* PRIMITIVE DEFINES
** ADTYPES REQUIRE TWO 12 BIT BYTES - THE FIRST
* BYTE HAS THE UPPER BIT SET TO INDICATE ADTYPE
** UNNAMED LONG LITERALS REQUIRE A WHOLE WORD
* FOLLOWING THEIR ADTYPES - THE FIRST BYTE OF THEIR
* ADTYPES HAVE THE SECOND TO THE UPPER BIT SET
** NAMED LONG LITERALS REQUIRE A WHOLE WORD
*
*
* ECS DATA STRUCTURE
*
* THE ECS DEFINE BUFFER IS PARTITIONED INTO PAIRS OF
* NAME AND TOKEN BUFFERS. THE DEFINE SET THAT IS CURRENTLY
* ACTIVE HAS ALL THE UNUSED SPACE IN THE DEFINE BUFFER
* LOCATED BETWEEN THE END OF ITS TOKEN BUFFER AND THE
* BEGINNING OF ITS NAME BUFFER. FOR EXAMPLE;
*
* START OF ECS DEFINE BUFFER
* TOKENS FOR DEFINE SET A
* NAMES FOR DEFINE SET A
* TOKENS FOR DEFINE SET B
* NAMES FOR DEFINE SET B
* TOKENS FOR DEFINE SET C
* UNUSED SPACE
* NAMES FOR DEFINE SET C
* END OF ECS DEFINE BUFFER
*
* WHEN ANOTHER DEFINE SET IS ACTIVATED, THE TOKEN AND
* NAME BUFFERS ARE MOVED SO THAT THE UNUSED SPACE IS BETWEEN
* THAT DEFINE SETS TOKEN AND NAME BUFFER. FOR EXAMPLE;
*
* START START
* TOKEN A TOKEN A
* NAME A NAME A
* TOKEN B TOKEN B
* NAME B UNUSED SPACE -DEFINE- SET B IS NOW ACTIVE
* TOKEN C NAME B
* UNUSED SPACE TOKEN C
* NAME C NAME C
* END END
*
* AS A -DEFINE- COMMAND IS PROCESSED, THE STARTING LOCATION
* OF THE NAMES DECREASES AS NAMES ARE ADDED AND THE ENDING
* LOCATION OF THE TOKENS INCREASES AS TOKENS ARE ADDED UNTIL
* THERE IS NO UNUSED SPACE, AT WHICH TIME A CONDENSE ERROR
* IS ISSUED AND NO MORE DEFINES ARE PROCESSED UNTIL ONE
* OR MORE DEFINE SETS ARE PURGED.
*
*
* NAME BUFFER
*
* THE NAME BUFFER CONTAINS AN ALPHABETICAL LIST OF ALL
* SYMBOLS GIVEN DEFINITIONS IN THE DEFINE SET SO FAR.
* EACH SYMBOL IS LEFT JUSTIFIED IN A WORD, USING A MAXIMUM
* /--- BLOCK DEFINE 00 000 76/06/07 15.09
* OF 7 CHARACTERS. THE BOTTOM 3 CHARACTERS CONTAIN INFO
* DESCRIBING THE FUNCTION OF THE SYMBOL, CALLED THE SYMBOLS
* GETVAR CODE. THIS CODE CONSISTS OF 4 BITS OF TYPE
* INFORMATION AND 14 BITS OF ADDRESS INFORMATION. FOR ALL
* EXCEPT SIMPLE VARIABLE TYPES OR LITERAL TYPES OF LESS THAN
* 15 BITS, THE ADDRESS INFORMATION POINTS TO THE WORD IN
* THE TOKEN BUFFER WHERE A DESCRIPTION OF THE DEFINE BEGINS
* (SEE DISCUSSION OF TOKENS BELOW). THE ADDRESS INFORMATION
* FOR SIMPLE VARIABLES INDICATES THE NUMBER OF THE VARIABLE
* BEING REFERENCED; FOR 14 BIT LITERALS, THE LITERAL ITSELF
* IS THE ADDRESS.
*
* TOKEN BUFFER
*
* THE TOKEN BUFFER CONTAINS COMPLEX DEFINITIONS OF SYMBOLS
* IN THE NAME TABLE. FOR ALL EXCEPT LITERALS OF MORE THAN
* 14 BITS, THESE DEFINITIONS ARE OF THE FORM;
*
* <NUMBER OF ARGUMENTS> <CHARACTER STRING ANALOG> <EOL>
*
* FOR 60 BIT LITERALS, ALL THAT IS STORED IS THE LITERAL
* ITSELF.
* THE NON60-BIT LITERAL ELEMENTS OF THE TOKEN BUFFER ARE
* 12 BIT OR 24 BIT BYTES, PACKED FROM HIGH TO LOW ORDER
* BITS OF WORDS. THE <NUMBER OF ARGUMENTS> IS ALWAYS LEFT
* JUSTIFIED SO THAT THE GETVAR CODE ASSOCIATED WITH THE
* SYMBOL MAY POINT DIRECTLY TO THE FIRST WORD OF THE
* SYMBOLS DEFINITION. FOR ALL EXCEPT THE ARGUMENT COUNT,
* 12 BIT TOKENS CORRESPOND TO LEXICAL ELEMENTS OF THE
* DEFINITION CALLED OPERATORS. INCLUDED IN THIS CATEGORY ARE
* SEPARATORS SUCH AS PARENTHESIS, COMMAS, END OF LINES, ETC.
* AS WELL AS SYSTEM DEFINED SYMBOLS (INT, ZRECS, +, -, ^O,).
* 24 BIT TOKENS ARE OF TWO TYPES; 1) ARGUMENT TOKENS, THE
* TOP 12BIT BYTE OF WHICH HAS A UNIQUE VALUE NOT CORRESPOND-
* ING TO ANY OPERATOR, AND THE BOTTOM 12 BIT BYTE THE NUMBER
* OF THE ARGUMENT AS IT APPEARS IN THE ARGUMENT LIST;2)
* ADTYPE TOKENS, WITH THE 2**LITSHFT BIT SET AND THE BOTTOM 18
* BITS CONTAINING A GETVAR CODE FOR A SIMPLE VARIABLE OR
* LITERAL. 60 BIT LITERALS THAT APPEAR IN THE DEFINITION OF
* A SYMBOL THAT IS NOT REDUCABLE TO A SINGLE LITERAL ITSELF,
* HAVE THE 2**LITSHFT BIT SET INDICATING THAT THE REST
* OF THE CURRENT TOKEN WORD IS IRRELEVANT, THE LITERAL
* APPEARS IN THE NEXT WORD IN THE TOKEN BUFFER AND THE NEXT
* TOKEN WILL BE LEFT JUSTIFIED IN THE WORD AFTER THE
* LITERAL. *** WARNING *** IN ALL OTHER CONTEXTS, THE
* 2**LITSHFT BIT SET IN AN ADTYPE MEANS THAT THE LONG LITERAL
* RESIDES IN *LITS* (THE LITERAL STACK GENERATED BY *LEX*
* AND *DEFLEX*. *** WARNING ***
*
* /--- BLOCK DEFINE 00 000 80/03/27 23.09
* WHEN THE DEFINITION OF A SYMBOL CONTAINS A PREVIOUSLY
* DEFINED SYMBOL, THE TOKEN BUFFER REPRESENTATION OF
* THE DEFINITION CONTAINS THE TOKENS FOR THE PREVIOUSLY
* DEFINED SYMBOL ENCLOSED BY PARENTHESIS TOKENS.
*
*
* EXAMPLE DEFINE SET NAME AND TOKEN BUFFERS
*
* DEFINE ABC=7
* DEF=N1
* VECT(X)=N(X+100)
* LIT='7ABCDEF'7+1
* FUNCT(X,Y)=SIN(Y+LIT-VECT(X)"DEF+'7GEHI'7)
*
* TOKEN BUFFER (* INDICATES START OF WORD)
* *0001 0077 0015 03760000 *0002 40000144 0016 0001
* *01020304050600000001
* *0002 0051 0015 03760001 *0002 40040002 0003 0015 *0077
* 0015 0015 03760000 *0016 0002 40000144 0016 *0016
* 0013 40100001 0002 *60040011 *07051011000000000000
* *0016 0001
*
* NAME BUFFER
* <NAME> <GETVAR>
* ABC 000007
* DEF 100001
* FUNCT 200003
* LIT 040002
* VECT 200000
*
*
* CM NAME PAGING
*
* A CM BUFFER IS USED DURING BINARY CHOP SEARCHES FOR
* DEFINED NAMES. IN DEFINE SETS WITH NAME BUFFERS LARGER
* THAN THE CM BUFFER, THE ECS NAME BUFFER IS DIVIDED UP INTO
* PAGES THE SAME SIZE AS THE CM BUFFER. THESE PAGES ARE
* READ INTO CM AS NEEDED FOR THE BINARY CHOP.
* CM TABLES
*
* *TOKADDS* CONTAINS THE ECS LOCATIONS OF TOKEN BUFFERS
* *NAMADDS* CONTAINS THE ECS LOCATIONS OF NAME BUFFERS
* (TOKADDS(N)) IS ALWAYS LESS THAN OR EQUAL TO (TOKADDS(N+1))
* (NAMADDS(N)) IS ALWAYS LESS THAN OR EQUAL TO (NAMADDS(N+1))
* *TOKLENS* CONTAINS THE LENGTHS OF TOKEN BUFFERS
* *NAMLENS* CONTAINS THE LENGTH OF NAME BUFFERS
* *SETNAMS* CONTAINS THE NAMES OF DEFINE SETS
*
* THERE IS AN ENTRY IN EACH TABLE WITH AN INDEX OF -1. THESE
* ENTRIES DESCRIBE THE NULL DEFINE SET WHICH IS OPENED WHEN
* NO DEFINE SET IS ACTIVE. THIS MAKES MUCH OF THE CODE MORE
* ELEGANT AND EFFICIENT BY AVOIDING SPECIAL CASES.
*
* *PGTBL* CONTAINS THE LAST NAME OF EACH PAGE IN THE NAME
* BUFFER. THIS IS TO SPEED UP THE PROCESS OF FINDING
* WHICH PAGE SHOULD BE CM RESIDENT IF THE PAGE IN ECS COULD
* NOT CONTAIN THE NAME BEING SEARCHED FOR.
*
*
* AT THE END OF CONDENSATION THE DEFINE SET NAMED
* *STUDENT* IS APPENDED TO THE LESSON BINARY - OTHER
* DEFINES ARE NOT AVAIABLE IN STUDENT MODE
*
*
DEFOV OVRLAY
SA1 OVARG1 X1 = CALL TYPE
SB1 X1
JP B1+DEFJMP JUMP TO DEFINE OPTION
*
DEFJMP EQ DEFNIN BEGIN DEFINE SET
+ EQ PURGELU PURGE LOCAL DEFINE SET FOR NEW
+ EQ ELN1 RETURN FROM SEGOV
+ EQ PURGELD PURGE LOCAL DEFINE SET FOR GBL
*
* /--- BLOCK DEFINE 00 000 80/05/19 22.16
DEFNIN CALL SETSET SET TO CURRENT DEFINE SET
SX6 VARS
SA6 PVARS POINTER TO DEFN NAME LIST
SX7 -2 *UNITS* NOT ACTIVE
SA7 NUNITS
MX6 0
SA6 UDMODE NO INTERPRETATION OF *UNITS*
SA6 COMPNAM
SA6 CSYMADD
SA1 COMMAND
SA2 COMCONT SEE IF CONTINUED COMMAND
BX2 X1-X2
ZR X2,DEFRD JUMP IF CONTINUED
* /--- BLOCK D050 00 000 80/03/23 08.25
*
SA1 LOCAL
ZR X1,D025 IF NOT LOCAL SET
*
*+ EQ *
+ SA1 KLOCAL X1 = LOCAL SET NAME
BX6 X1
SA6 KBLANK LOCAL SET HANDLING LIKE BLANK
SX6 60 NO BITS LEFT IN 0TH WORD
SA6 LSHIFT
SA6 LBYTES LOCAL BYTE SIZE
MX6 0 0TH WORD
SA6 LVARN
SA6 MERGEL ASSUME MERGE OPTION NOT USED
SX6 100000B LOCAL TYPE IS INTEGER
SA6 LTYPE
SX6 1 SIGNED
SA6 LSIGN
SA1 DSET SAVE CURRENT SET NUMBER
BX6 X1
SA6 GSET GLOBAL SET NUMBER
* SAVE UNIT TAG
SA1 WORDPT
BX6 X1
SA6 LWRDPT
SA0 TAG
SA1 ATEMPEC X1 = ADDR OF TEMP ECS
BX0 X1
WE TAGLTH+1 WRITE OUT -UNIT- W/ARGS
RJ ECSPRTY
SA0 LUNIT SAVE -UNIT- COMMAND W/ARGS
RE TAGLTH+1
RJ ECSPRTY
RJ =XGETLINE
D025 SA1 WORDPT SAVE WORDPT
BX6 X1
SA6 OLDPT
CALL GETNAME,9 GET NAME OF DEFINE SET **
ZR X6,DEFR0 JUMP IF NO NAME=BLANK SET
SX7 DEFNAML NUMBER OF NAMES TO SEARCH
SA1 LOCAL
IX7 X7+X1 IF LOCAL SET, INCLUDE *MERGE*
RJ DEFNAMS CHECK FOR SPECIAL NAME
NZ X7,D170 JUMP IF SPECIAL NAME FOUND
*
*
SB2 7
GT B1,B2,ERR7 ERROR IF NAME OVER 7 CHARS
*
SA1 LOCAL
NZ X1,D100 IF LOCAL SET
*
*
* SPECIAL NAMES= SEGMENT(SEGFLG=1), SEGMENTV(3), UNITS(4),
* ARRAY(4), ARRAYSEG(5), ARRAYSEGV(6), COMPLEX(7),
* SEGMENTF(8), PURGE(9)
*
SX0 X2-OPCOMMA IF TERMINATOR IS COMMA
ZR X0,DEFR1 JUMP , THIS IS SET NAME
D050 SA1 LOCAL
NZ X1,D100 IF LOCAL SET, NO NAMED SETS
*
SX3 X2-EOL
ZR X3,DEFR1 IF SETNAME EOL
*
ZR X3,DEFR1 JUMP IF SETNAME(EOL)
D100 SA1 OLDPT THIS IS DEFINE NAME
BX6 X1 RESET -WORDPT-
SA6 WORDPT
* /--- BLOCK D050 00 000 80/03/23 08.25
EQ DEFR0 USE BLANK SET
*
D170 SA1 LOCAL
ZR X1,D171 IF NOT LOCAL SET
*
SX0 X7-DEFNAML-1
ZR X0,DEFL0 IF LOCAL MERGE OPTION
*
EQ D100 TREAT AS NORMAL DEFINE LINE
*
* /--- BLOCK D050 00 000 80/03/23 06.44
D171 SX0 X7-DEFNAML
ZR X0,PURGE JUMP IF PURGE OPTION
SX3 X2-OPCOMMA ZERO IF ENDS WITH COMMA
** FOLLOWING IS CAUSED BY DIFF BETWEEN TREATMENT OF
** SEGMENT AND UNITS/ARRAY/COMPLEX * MAYBE SHOULD CHANGE
ZR X3,D172 IF IT DOES, IS SPECIAL NAME
SX0 X7-1 ZERO IF SEGMENT
NZ X0,D050 JUMP IF NOT, ALLOW UNITS=V1
EQ ERR8 SEGMENT MUST END WITH COMMA
D172 SA1 KBLANK
BX6 X1 ASSUME BLANK SET
RJ =XFINDSET
PL B1,DSEG1 JUMP IF SET EXISTS
RJ NEWSET
*
DSEG1 RJ =XGETSET BRING IN THE SET
SA1 SEGFLG
SX1 X1-3
ZR X1,UNSREAD JUMP IF -UNITS-
EQ SEGREAD JUMP IF SEGMENT/ARRAY/COMPLEX
*
DEFL0 SX6 1
SA6 MERGEL FLAG MERGE OPTION SELECTED
*
DEFR0 SA1 KBLANK BLANK NAME (UNNAMED SET)
BX6 X1
*
DEFR1 BX7 X2 SAVE TERMINATOR CODE
SA7 ENDKEY
RJ =XFINDSET SEE IF SET ALREADY EXISTS
PL B1,DEFR2 JUMP IF ALREADY EXISTS
RJ NEWSET INITIALIZE A NEW SET
RJ =XGETSET OPEN IT UP AND BRING IT IN
SA1 LOCAL
ZR X1,DEFL5 IF NOT LOCAL SET
*
SA1 MERGEL
ZR X1,DEFRD IF NO MERGED SET, BEGIN SET
*
CALL GETNAME,8
BX7 X2 SAVE ENDKEY
SA7 ENDKEY
SA3 GSET X3 = PREVIOUS GLOBAL SET NUM
SB1 X3 B1 = PREVIOUS GLOBAL SET NUM
SA1 KPREVN X1 = *PREVIOUS* KEYWORD
BX1 X1-X6
ZR X1,DEFL10 IF PREVIOUS SET TO BE MERGED
SA1 KGLOBAL X1 = *GLOBAL* KEYWORD
BX1 X1-X6
NZ X1,DEFL05 IF NAME IS NOT *GLOBAL*
PL B2,DEFL05 IF NAME IS NOT *GLOBAL';*
SX7 EOL SET TERMINATING CHAR
SA7 ENDKEY
EQ DEFL10 DO THE MERGE
*
DEFL05 SX3 X2-EOL
ZR X3,DEFR1A ANOTHER SETNAME IF EOL
*
SX3 X2-OPCOMMA
NZ X3,ERR8 IF BAD TERMINATION
*
EQ DEFR1A
*
MERGEL DATA 0 MERGE OPTION FLAG FOR LOCAL SET
*
DEFL5 BSS 0
SA1 ENDKEY
SX2 X1-OPCOMMA
NZ X2,ENDLIN CONTINUE IF NOT COMMA
CALL GETNAME,7 GET NEXT NAME
SX3 X2-EOL
ZR X3,DEFR1A ANOTHER SET NAME IF EOL
SX3 X2-OPCOMMA
NZ X3,DEFRDA ANOTHER DEFINE IF NOT COMMA
* /--- BLOCK DEFR1A 00 000 75/02/11 20.31
*
DEFR1A SX7 X2 SAVE TERMINATOR
SA7 ENDKEY
ZR X6,ERR8 ERROR EXIT IF NO SET
RJ =XFINDSET SEARCH FOR OLD SET
DEFL10 NG B1,ERR8 ERROR IF NO SET
SX7 B1
SA7 ODSET SAVE OLD SET NUMBER
SA1 DSET
SB2 X1
SA1 UNTLENS+B1 *NDEFU*
BX7 X1
SA7 UNTLENS+B2
SA2 B2+TOKADDS (X2)=ECS ADDR OF NEW SET TOKENS
SA1 B1+TOKADDS (X1)=ECS ADDR OF OLD SET TOKENS
SA3 B1+TOKLENS (X3)=ECS LENG OF OLD SET TOKENS
IX4 X2+X3 MUST BE LESS THAN OR EQUAL TO
SA5 NAMADDS+B2
IX4 X5-X4
NG X4,ERR4 IF NOT ENOUGH ROOM IN BUFFER
BX7 X3
SA7 B2+TOKLENS
SA0 VARS (A0)=ADDR OF MOVE BUFFER
SB1 VARLONG (B1)=LENGTH OF MOVE BUFFER
RJ =XMVECS MOVE TOKENS TO NEW DEFINE SET
SA1 ODSET
SB1 X1
SA1 DSET
SB2 X1
SA2 B2+NAMADDS (X2)=ECS ADDR OF NEW SET NAMES
SA1 B1+NAMADDS (X1)=ECS ADDR OF OLD SET NAMES
SA3 B1+NAMLENS (X3)=ECS LENG OF OLD SET NAMES
IX2 X2-X3 (X2)=NEW ADDR OF NEW SET NAMES
SA4 TOKADDS+B2 SEE IF ENOUGH ROOM IN BUFFER
SA5 TOKLENS+B2
IX4 X4+X5 MUST NOT BE GT NAMADDS+B2
IX4 X2-X4
NG X4,ERR4 IF NOT ENOUGH ROOM
BX7 X2
SA7 B2+NAMADDS
BX7 X3
SA7 B2+NAMLENS
SA0 VARS (A0)=ADDR OF MOVE BUFFER
SB1 VARLONG (B1)=LENGTH OF MOVE BUFFER
RJ =XMVECS MOVE NAMES TO NEW DEFINE SET
SA1 DSET
SB1 X1
RJ =XSETSET BRING IN NEW DEFINE SET
SA1 ENDKEY
EQ ENDLIN
*
* /--- BLOCK DEFR2 00 000 80/03/23 06.50
ODSET BSS 1
*
DEFR2 RJ =XGETSET BRING IN THE SET
*
DEFR3 SA1 ENDKEY
EQ ENDLIN SEE IF NEED NEW LINE
*
DEFRD CALL GETNAME,9 GET NAME OF DEFINE
* FOLLOWING CHECKS FOR -DEFINE- ENDING IN COMMA
* AND TRAILING BLANKS
SX7 X2-EOL CHECK FOR EOL TERMINATOR
BX7 X7+X6 AND NO NAME
ZR X7,ELN1 END-OF-LINE OK
DEFRDA ZR X6,ERR7 ERROR IF NO NAME
SA6 DEFNAME
SX7 DEFNAML-1 DO NOT LOOK FOR *PURGE*
RJ DEFNAMS CHECK FOR SPECIAL NAMES
ZR X7,DEFRDAB JUMP IF NOT
SX0 X7-3
NG X0,SEGREAD JUMP IF SEGMENT
SX1 X2-OPCOMMA CHECK IF TERMINATOR=COMMA
NZ X1,DEFRDB IF NOT, MUST BE UNITS=V1 ETC.
ZR X0,UNSREAD REMOTE EXIT IF UNITS
SX0 X7-DEFGNML-1
NG X0,SEGREAD IF ARRAY/COMPLEX
*
SA1 LOCAL
ZR X1,DEFRDB IF NOT LOCAL SET
*
* CONDENSING LOCAL DEFINE SET ',X,Y,S';', FORM
* X = (INTEGER,FLOATING)
* Y = SEGMENT SIZE (INTEGER ONLY)
* S = SIGNED SEGMENT IF PRESENT
*
SX6 100000B X6 = PRESET N GETVAR TYPE
SX0 X0-1
NG X0,DEFL20 IF INTEGER DECLARATION
*
SX6 5B X6 = V GETVAR TYPE
LX6 15
DEFL20 SA6 TLTYPE TEMPORARY LTYPE
RJ COLON X0 = -1 IF COLON IS LAST CHAR
NG X0,DEFL100 IF FULL WORD DECLARATION
*
RJ SAVEO SAVE WORDPT ETC.
RJ =XRTOKNAM MAKE READY FOR *INITDEF*
RJ =XCOMPILE
MX0 -XCODEAL
BX0 X0*X1 MUST BE SHORT LITERAL
BX6 X1
SA2 OLDINX RESTORE INX
BX7 X2
SA7 INX
ZR X0,DEFL30 IF X6 IS SHORT LITERAL
*
DEFL25 RJ RESTO BACK UP POINTERS TO KEYWORD AND
SA2 WORDPT SET X2 TO CORRECT ENDKEY
SA2 X2-1
SA2 X2+KEYTYPE
EQ DEFRDB ASSUME IT A DEFINE NAME
*
DEFL30 SA6 TLBYTES TEMPORARY LOCAL BYTE SIZE
RJ COLON X0 = -1 IF COLON LAST CHAR
NG X0,DEFL110 IF UNSIGNED DECLARATION
*
CALL GETNAME,7 X6 = SIGN OPTION
ZR X6,DEFL25 ASSUME ITS A DEFINED NAME
*
SA3 KSIGN CHECK FOR SIGNED SEGMENT
BX3 X6-X3
* /--- BLOCK DEFR2 00 000 80/03/23 06.50
ZR X3,DEFL40 IF SIGNED DECLARATION
*
SA3 KS CHECK FOR ABBREVIATED SIGN
BX3 X6-X3
NZ X3,DEFL25 IF NOT ,S ASSUME DEFINED NAME
*
DEFL40 RJ COLON
PL X0,DEFL25 MUST END IN COLON
*
SX6 1
SA6 TLSIGN TEMPORARY LOCAL VAR SIGN
EQ DEFL120 BEGIN INTEGRITY CHECK
*
* /--- BLOCK DEFR2 00 000 80/03/23 06.47
DEFL100 SX6 60 60 BIT DECLARATION
SA6 TLBYTES
SX6 1 HAS TO BE SIGNED
SA6 TLSIGN
EQ DEFL200 SET DECLARATION PARAMETERS
*
DEFL110 SX6 0 UNSIGNED
SA6 TLSIGN
*
DEFL120 SA1 TLBYTES CHECK BYTE SIZE
NG X1,BADCNT IF BYTE SIZE LT 0
ZR X1,BADCNT IF BYTE SIZE EQ 0
*
SX2 61
IX1 X1-X2
PL X1,BADCNT IF BYTE SIZE GT 60
*
SA2 TLTYPE
SX2 X2-100000B
ZR X2,DEFL200 IF INTEGER, EVERYTHING OK
*
SX1 X1+1
NZ X1,BADCNT IF FLOATING BYTE SIZE NE 60
*
DEFL200 SA1 TLTYPE TYPE OF LOCAL VAR
BX6 X1
SA6 LTYPE
SA1 TLBYTES LENGTH OF BYTE
BX6 X1
SA6 LBYTES
SA1 TLSIGN UN/SIGNED
BX6 X1
SA6 LSIGN
EQ DEFRD CONTINUE SINCE MORE TO COME
*
*
TLTYPE DATA 0
TLBYTES DATA 0
TLSIGN DATA 0
* /--- BLOCK DEFR2 00 000 80/03/23 06.49
*
* -COLON-
*
* LOOK AT LAST TWO CHARACTER CODES TO CHECK FOR
* A COLON
*
* ON RETURN X0 = -1 IF COLON, 0 IF NOT
*
COLON EQ *
SX0 B0 PRESET X0 TO NOT COLON
SA2 WORDPT
SA2 X2-1
SX2 X2-77B LAST CHAR - ;
NZ X2,COLON IF NOT COLON
*
SA2 A2-1
SX2 X2-70B LAST CHAR - SHIFT
NZ X2,COLON IF NOT COLON
*
SX0 -1 IT WAS A COLON
EQ COLON
*
*
* -SAVEO-
*
* SAVE ALL INFORMATION NECESSARY TO DO A COMPILE
* LOOK AHEAD IN THE *OLD* BUFFER
*
SAVEO EQ *
SA2 WORDPT SAVE WORDPT
BX6 X2
SA6 OWORDPT
SA2 INX SAVE INX
BX6 X2
SA6 OLDINX
SA2 LASTKEY SAVE LASTKEY
BX6 X2
SA2 OLDLAST
EQ SAVEO
*
*
* -RESTO-
*
* RESTORE INFORMATION SAVED BEFORE LOOK AHEAD
* FROM *OLD* BUFFER
*
RESTO EQ *
SA2 OWORDPT RESTORE WORDPT
BX6 X2
SA6 WORDPT
SA2 OLDINX RESTORE INX
BX6 X2
SA6 INX
SA2 OLDLAST RESTORE LASTKEY
BX6 X2
SA6 LASTKEY
EQ RESTO
*
*
DEFRDAB NG B2,BADTYP IF ILLEGAL TYPE DECLARATION
*
DEFRDB SX7 X2 SAVE TERMINATOR
SA7 ENDKEY
* /--- BLOCK DEFR2 00 000 76/08/01 23.59
SA1 DSET CURRENT SET NUMBER
NG X1,ERR9
MX6 0
SA6 NARGS CLEAR ARGUMENT COUNT
SA6 NADS CLEAR ADTYPE COUNT
SA6 NOPS CLEAR OPERATION COUNT
SX3 X2-OPASIGN OK IF ASSIGNMENT ARROW
ZR X3,DNAME
SX3 X2-OP= OK IF EQUAL SIGN
ZR X3,DNAME
SX3 X2-OP( OK IF L PAREN (FUNCTION)
ZR X3,DNAME
SA1 LOCAL X1 = LOCAL SET FLAG
ZR X1,ERR1 IF NOT PROCESSING LOCAL SET
*
SX3 X2-OPCOMMA COMMA LEGAL IN LOCAL SET
ZR X3,DNAME IF COMMA
*
SX3 X2-EOL EOL LEGAL IN LOCAL SET
NZ X3,ERR1 OTHERWISE, ILLEGAL CHARACTER
*
*
DNAME CALL SYMCHK,DEFNAME
SX7 -1 SET VSEEK TO NO EXPANSION
SA7 VSKMODE
MX6 0
SA6 UDMODE NO INTERPRETATION OF *UNITS*
SA1 DEFNAME
BX6 X1 PUT NAME IN X6 FOR CALL
RJ =XVSEEK SEE IF NAME ALREADY DEFINED
SA1 ADTYPE
PL X1,ERR6 ERROR IF DUPLICATE NAME
SA7 DEFNLOC STORE LOCATION TO INSERT DEFN
RJ =XINITLEX SETUP FOR PROGRAM -LEX-
SA1 ENDKEY
SX2 X1-OP( CHECK TERMINATOR KEY
NZ X2,DEFIN JUMP IF NOT FUNCTION DEFINE
*
* /--- BLOCK ARGDO 00 000 77/01/26 20.37
*
*
SA1 LOCAL
ZR X1,ARGDO IF NOT LOCAL SET
*
RJ SAVEO SAVE COMPILATION LOCATION
RJ =XRTOKNAM
RJ =XLEX IS NEXT LEXICAL ITEM DEFINED
SA1 OP
NZ X1,DEFL280 IF AN OPERATOR, ASSUME CONSTANT
*
SA1 ADTYPE
NG X1,DEFL290 IF UNDEFINED, ASSUME AN ARG
*
DEFL280 RJ RESTO RESTORE TO PRE-LEX CONDITION
SA1 WORDPT POINT TO LEFT PAREN
SX6 X1-1
SA6 A1
RJ =XCOMPILE
SA2 OLDINX RESTORE INX
BX6 X2
SA6 INX
MX0 -XCODEAL
BX0 X0*X1 X0 = GETVAR W/ZEROED ADDRESS
ZR X0,DEFL300 IF A SHORT LITERAL
*
DEFL290 RJ RESTO RESTORE COMPILATION
SX7 -1 SET VSEEK TO NO EXPANSION
SA7 VSKMODE
MX6 0
SA6 UDMODE
RJ =XINITLEX
EQ ARGDO CONTINUE WITH ARGUMENTS
*
DEFL300 BSS 0
*
*
* ADD LOCAL VECTOR DEFINE
*
SA2 LBYTES X2 = BYTE SIZE
SX3 X2-60
NZ X3,DEFL500 IF HORIZONTAL SEGMENT
*
* FULL WORD VECTOR
*
SA2 LVARN X2 = NUMBER OF LOCALS SO FAR
IX6 X1+X2 INDEX OF LAST VAR IN THIS ARRAY
BX7 X1 SAVE VECTOR LENGTH
RJ =XLBOUND CHECK ITS BOUNDS
SA6 A2 STORE NEW NUMBER OF LOCALS
BX6 X2 SAVE OLD NUMBER OF LOCALS
SA6 OLVARN
*
* SIMULATE ',ARRAY,XXX(YYY)=NL(ZZZ)', WHERE ',XXX', IS
* DEFINE NAME AND ',YYY', IS THE VECTOR LENGTH
* AND ZZZ IS THE BASE LOCATION OF THE VECTOR
*
SX6 X7-1 X6 = VECTOR SIZE - 1
SX5 1 SET ARRAY DIMENSIONS TO 1
LX5 9
BX7 X5+X7
LX7 9 X7 = ARRAY WORD W/NUM WORDS
BX7 X6+X7 NUMBER OF ROWS - 1
LX7 36 BY-PASS PLANES FOR 3D MATRIX
SA1 OLVARN RESTORE PREVIOUS LVARN
SX1 X1+1 VECTOR BEGINS AT NEXT WORD
* /--- BLOCK ARGDO 00 000 77/01/26 20.37
SA2 ASVARS X2 = ADDR OF STUDENT VARS
SA3 ALVARS X3 = ADDR OF LOCAL VARS
IX3 X3-X2 OFFSET TO LOCAL VARS
IX1 X1+X3 OFFSET TO LOCAL VECTOR
SA2 LTYPE X2 = TYPE GETVAR
BX7 X7+X2 ADD GETVAR OF FIRST ELEMENT
BX1 X7+X1
RJ =XSTUFLIT
SA2 TOKWRD
RJ =XAPTWD
SX4 6 INDICATE AN ARRAY TYPE DEFINE
EQ DEFL530 TREAT LIKE SEGMENT NOW
*
*
* /--- BLOCK ARGDO 00 000 77/01/26 20.37
* ADD LOCAL SCALAR DEFINE
*
DEFL400 BSS 0
SA1 WORDPT SET LASTKEY FOR EOL TEST
SA1 X1-1
BX7 X1
SA7 LASTKEY
SA1 LBYTES X1 = BITS PER BYTE
SX2 X1-60
NZ X2,DEFL410 IF SEGMENTED SCALAR
*
* FULL WORD SCALAR
*
SX6 60 ALL BITS USED IN NEW WORD
SA6 LSHIFT
SA2 LVARN X2 = NUMBER OF LOCAL VARS
SX6 X2+1
RJ =XLBOUND CHECK BOUNDS
SA6 A2 NEW NUMBER OF LOCALS
SA1 ASVARS ADDRESS OF STUDENT VARS
SA3 ALVARS ADDRESS OF LOCAL VARS
IX6 X3+X6 ADDRESS OF LOCAL VAR
IX6 X6-X1 BIAS TO LOCAL VAR
SA1 LTYPE GETVAR TYPE CODE
BX4 X6+X1 X4 = NL/VL GETVAR CODE
EQ ADNAM ADD LOCAL VAR TO DEFINE TABLE
*
* ADD LOCAL SCALAR SEGMENT DEFINE
*
DEFL410 SA2 LSHIFT X2 = BITS USED IN CURRENT WORD
SA3 LSIGN X3 = 1 IF SIGNED
SA4 LVARN X4 = VARLOC OF SEGMENTF
LX3 2 POSITION SIGN BIT
SX3 X3+3 INDICATE SEGMENTF
LX3 20
BX3 X3+X1 NUMBER OF BITS PER BYTE
IX6 X2+X1 INCREMENT BITS USED
SX7 X6-61 - BITS LEFT IN WORD
NG X7,DEFL420 IF CAN FIT IN THIS WORD
*
BX6 X1 BITS USED IN NEW WORD
MX2 0 START OF NEW BYTE
SX4 X4+1 INCREMENT LVARN
DEFL420 SA6 A2 STORE NEW NUMBER OF BITS USED
BX6 X4 STORE NEW LVARN
RJ =XLBOUND CHECK BOUNDS ON LOCAL INDEX
SA6 A4
SA1 ASVARS ADDRESS OF STUDENT VARS
SA4 ALVARS ADDRESS OF LOCAL VARS
IX6 X4+X6 ADDRESS OF LOCAL VAR
IX6 X6-X1 BIAS TO LOCAL VAR
LX3 18
BX3 X3+X6 BIAS TO SEGMENTF
LX3 18
SX2 X2+1 BIT POSITION OF SEGMENTF
BX1 X2+X3
RJ =XSTUFLIT STORE SEGMENT DESCIPTOR
SA2 TOKWRD IN ECS TOKEN BUFFER
* /--- BLOCK ARGDO 00 000 77/01/26 20.37
RJ =XAPTWD
SX4 5 X4 = TYPE CODE FOR SEGMENT
LX4 XCODEAL POSITION TYPE CODE
SA1 TOKWRD
SX1 X1-1 X1 = TOKEN ADDR OF SEG LIT
BX4 X4+X1 X4 = COMPLETE GETVAR
EQ ADNAM
*
*
* ADD LOCAL VECTOR SEGMENT DEFINE
*
DEFL500 EQ NOTYET NO SEGMENTED VECTOR LOCALS YET
PX3 X2 X3 = FLOAT(BYTESIZE)
NX3 X3
SA4 K60 X4 = 60.0
* /--- BLOCK ARGDO 00 000 77/01/26 20.37
RX3 X4/X3 X3 = 60/BYTESIZE
UX3 X3,B1
LX3 X3,B1 X3 = BYTES PER WORD
PX3 X3
NX3 X3
PX4 X1 X4 = FLOAT(BYTES)
NX4 X4
RX4 X4/X3 X4 = BYTES/BYTESPERWORD
UX4 X4,B4
LX4 X4,B4 X4 = NUMBER OF FULL WORDS USED
UX3 X3,B3
LX3 X3,B3 X3 = BYTES/WORD
IX5 X3*X4 X3 = BYTES RESIDING IN FULL WDS
IX5 X1-X5 X5 = BYTES IN LAST WORD
IX7 X5*X2 X7 = BITS USED IN LAST WORD
SA7 LSHIFT
BX5 X3 SAVE BYTES PER WORD
SA3 LVARN X3 = WORDS USED SO FAR
ZR X7,DEFL510 IF ALL BITS USED IN LAST WORD
*
SX4 X4+1 X4 = NUMBER OF WORDS INVOLVED
EQ DEFL520
*
DEFL510 IX6 X2*X5 ALL BYTES USED IN LAST WORD
SA6 LSHIFT
DEFL520 IX6 X4+X3 HIGHEST VARLOC IN SEGMENT
RJ =XLBOUND MAKE SURE WITHIN RANGE
SA6 LVARN
SA1 LSIGN X1 = UN/SIGNED SEGMENT
LX1 22
BX1 X1+X2 BYTE SIZE
LX1 18
SA2 ASVARS ADDRESS OF STUDENT VARS
SA4 ALVARS ADDRESS OF LOCAL VARS
SX3 X3+1 VARLOC OF FIRST BYTE
IX4 X3+X4 ADDRESS OF LOCAL VAR
IX4 X4-X2 BIAS TO LOCAL VAR
BX1 X1+X4 BIAS TO SEGMENT
LX1 18
BX1 X1+X5 NUMBER OF BYTES PER WORD
RJ =XSTUFLIT
SA2 TOKWRD
RJ =XAPTWD
SX4 5 X4 = SEGMENT TYPE
DEFL530 LX4 XCODEAL POSITION TYPE
SA1 TOKWRD
BX4 X4+X1 INCLUDE ADDRESS
SX4 X4-1 X4 = GETVAR CODE
EQ ADNAM
*
*
ARGDO CALL LEX GET NEXT ITEM
SA1 OP
ZR X1,GOTARG JUMP IF ARG NOT SEPERATOR
SX2 X1-OPDEFN
ZR X2,ERR6 DEFINE NAME USED AS ARGUMENT
SX2 X1-OP)
ZR X2,ENDARGS DONE WITH ARGS IF PAREN
SX2 X1-OPCOMMA
* /--- BLOCK ARGDO 00 000 77/01/26 20.37
NZ X2,ERR1 ERROR IF NOT SEPERATOR
SX7 -1
SA7 LASTKEY CLEAR LASTKEY
EQ ARGDO
*
GOTARG SA1 ADTYPE MUST BE UNRECOGNIZED NAME
PL X1,ERR12
SA2 NARGS CURRENT NUMBER OF ARGUMENTS
SX6 X2+1
SX0 X2-MAXARG CHECK TOO MANY ARGS
PL X0,ERR5
SA6 A2
SA1 AD GET NAME OF ARGUMENT
BX6 X1
SA6 X2+ARGLIST SAVE NAME OF ARGUMENT
* /--- BLOCK ARGDO 00 000 77/01/26 20.37
EQ ARGDO
*
ENDARGS SA2 NARGS
ZR X2,ERR13 JUMP IF ZERO ARGUMENTS F()
RJ =XLEX GET NEXT ITEM
SA1 OP
SX2 X1-OP= LAST CODE MUST BE =
ZR X2,DEFIN
SX2 X1-OPASIGN OR ASSIGNMENT
NZ X2,ERR1
*
DEFIN MX6 0 RIGHT SIDE OF A DEFINITION
SA6 VSKMODE RESET MODE FOR VSEEK
SA6 UREF CLEAR *UNIT* ENCOUNTERED FLAG
SA6 UDMODE NO INTERPRETATION OF *UNITS*
SA1 TOKWRD
BX6 X1 SAVE BEGINNING ADDRESS
SA6 DEFLOC
SX6 60 INITIALIZE SHIFT COUNT
SA6 TOKSHF
MX6 0 CLEAR NEXT TOKEN WORD
SA6 TWD
SA6 DNVAR CLEAR NUMBER VARIABLES
MX6 -1 ASSUME CONSTANT OR SIMPLE
SA6 DCONST
SA1 WORDPT
BX6 X1 SAVE *WORDPT*
SA6 IWORDPT
SA2 LOCAL
ZR X2,DEFIN10 IF NOT PROCESSING LOCAL SET
*
SA1 ENDKEY X1 = TERMINATOR/DELIMITER
SX2 X1-OPCOMMA
ZR X2,DEFL400 IF SCALAR LOCAL DEFINE
*
SX2 X1-EOL
ZR X2,DEFL400 IF SCALAR LOCAL DEFINE
*
DEFIN10 BSS 0
SA1 NARGS NUMBER OF ARGS IS FIRST TOKEN
RJ STUFF
* /--- BLOCK DLEX 00 000 77/02/25 03.58
*
* NOW INTERPRET DEFN
*
DLEX BSS 0
SX7 1 INITIALIZE LITS POINTER
SA7 NLITS
RJ =XLEX GET NEXT OP/ADD
SA1 OP
ZR X1,ADDR JUMP IF ADDRESS
SX2 X1-OPCOMMA
ZR X2,ENDDEF
SX2 X1-EOL
ZR X2,ENDDEF END OF DEFINE
*
RJ STUFF
SA2 NOPS
SX6 X2+1 COUNT OPS
SA6 A2
EQ DLEX
*
* PROCESS ADDRESS
*
ADDR SA1 NADS
SX6 X1+1 INCREMENT ADDRESS COUNT
SA6 A1
SA1 ADTYPE
NG X1,ARGLOOK UNRECOGNIZED - CHECK ARGLIST
BX2 X1
AX2 XCODEAL SHIFT OFF ADDRESS
MX0 -4 MASK FOR I/F BIT AND TYPE CODE
BX2 -X0*X2
SB1 X2
JP B1+*+1 JUMP BY TYPE
*
+ EQ ADDR1 SHORT LITERAL
+ EQ ADRLIT LONG LITERAL
+ EQ ADDRV STUDENT VARIABLE
+ EQ ADDRV COMMON VARIABLE
+ EQ ERR11 IMPOSSIBLE
+ EQ ADRSEG SEGMENT
+ EQ ADRARY ARRAY
+ EQ ERR11 IMPOSSIBLE
*
+ EQ ADUNIT UNIT
+ EQ ADRLIT LONG LITERAL
+ EQ ADDRV STUDENT VARIABLE
+ EQ ADDRV COMMON VARIABLE
+ EQ ERR11 IMPOSSIBLE
+ EQ ERR11 IMPOSSIBLE
+ EQ ERR11 IMPOSSIBLE
+ EQ ERR11 IMPOSSIBLE
*
*
ADDRV SA2 DNVAR INC NUMBER VARS ENCOUNTERED
SX6 X2+1
SA6 A2
*
ADDR1 RJ STUFADR *STUFF* BOTTOM 24(X1) IN TOKENS
EQ DLEX
* /--- BLOCK ADRSEG 00 000 77/02/25 04.19
*
* PROCESS LONG LITERAL
*
* SEGMENT HAS A LITERAL ASSOCIATED -- A 60-BIT WORD
* DESCRIBING THE SEGMENTATION. SIMILARLY, ARRAYS HAVE
* AN INFO WORD (AND BASE-BIAS OR SEGMENTED ARRAYS HAVE TWO)
*
ADRARY BSS 0
MX6 0 MARK NOT ALL CONSTANT/SIMPLE
SA6 DCONST
EQ ADDR1 PREVIOUSLY DEFINED
*
ADRSEG MX6 0 MARK NOT ALL CONSTANT/SIMPLE
SA6 DCONST
EQ ADDR1 PREVIOUSLY DEFINED
*
ADRLIT BSS 0
LX1 60-LITSHF1
NG X1,IMMLIT IF IMMEDIATE LITERAL
*
LX1 LITSHF1
EQ ADDR1 PREVIOUSLY DEFINED
*
IMMLIT LX1 LITSHF1
RJ STLIT1 LITERAL IMMEDIATELY FOLLOWS ADT
EQ DLEX
*
ADUNIT MX6 1 MARK UNIT ENCOUNTERED
LX6 XCODEAL
SA6 UREF
MX6 0 MARK NOT ALL CONSTANTS
SA6 DCONST
EQ ADDR1
*
* /--- BLOCK ARGLOOK 00 000 76/02/17 20.05
*
ARGLOOK SA1 NARGS NUMBER OF ARGUMENTS
SA2 AD GET NAME TO SEARCH FOR
MX6 0 MARK NOT ALL CONSTANTS
SA6 DCONST
*
ASEEK1 SX1 X1-1 DECREMENT INDEX
NG X1,ERR3 JUMP IF NAME NOT FOUND
SA3 X1+ARGLIST
BX6 X3-X2 SEE IF NAMES MATCH
NZ X6,ASEEK1
BX7 X1 SAVE INDEX
SX1 OPARG INSERT CODE FOR ARG
RJ STUFF
BX1 X7
RJ STUFF INSERT ARG NUMBER
SA1 LASTKEY
SX2 X1-1R( CHECK FOR IMPLIED MULTIPLY
ZR X2,ARGMULT
SX2 X1-KLBRACK
NZ X2,DLEX
ARGMULT SX1 OPMULT INSERT MULTIPLY
RJ STUFF
EQ DLEX
*
* /--- BLOCK ENDDEF 00 000 76/02/24 19.36
*
* FINAL PROCESSING
* CHECK FOR PRIMITIVE DEFN
*
ENDDEF SX1 EOL INSERT AN EOL
RJ STUFF
SA2 TOKWRD
RJ APTWD WRITE OUT CURRENT *TWD*
SA1 NARGS CHECK IF FUNCTION
NZ X1,ENDD50
SA1 DCONST CHECK IF MAY BE ALL CONSTANTS
ZR X1,ENDD50 OR SIMPLE VARIABLES
SA1 DNVAR
SX1 X1-2 CHECK IF MORE THAN ONE VARIABLE
PL X1,ENDD50 ENCOUNTERED
*
SA1 WORDPT SAVE *WORDPT*
BX6 X1
SA6 OWORDPT
SA1 INX SAVE *INX*
BX6 X1
SA6 OLDINX
SA1 IWORDPT RE-SET *WORDPT* TO BEGIN OF
BX6 X1 EXPRESSION
SA6 WORDPT
SA1 LASTKEY
BX6 X1 SAVE *LASTKEY*
SA6 OLDLAST
RJ =XRTOKNAM MAKE READY FOR *INITDEF*
RJ =XCOMPILE EVALUATE EXPRESSION
SA2 OWORDPT
BX6 X2 RESTORE *WORDPT*
SA6 WORDPT
SA2 OLDINX
BX6 X2 RESTORE *INX*
SA6 INX
SA2 OLDLAST
BX6 X2 RESTORE *LASTKEY*
SA6 LASTKEY
BX4 X1 X4 = -GETVAR- CODE
AX1 XCODEAL POSTION -GETVAR- CODE TYPE
MX0 -3
BX1 -X0*X1
SB1 X1 PICK UP CODE TYPE
JP B1+*+1
*
+ EQ ENDD40 SHORT LITERAL
+ EQ ENDD20 LONG LITERAL
+ EQ ENDD40 STUDENT VARIABLE
+ EQ ENDD40 COMMON VARIABLE
+ EQ NORMAL EXPRESSION
+ EQ NORMAL UNUSED
+ EQ NORMAL ARRAY
+ EQ NORMAL SPECIAL JUMP
*
* /--- BLOCK ENDD20 00 000 76/02/19 02.45
*
ENDD20 BSS 0
SA1 DEFLOC RE-SET TOKEN POINTER
BX6 X1
SA6 TOKWRD
MX0 -XCODEAL
BX2 -X0*X4 ISOLATE ADDRESS
SA2 X2+INFO LOAD LITERAL
BX6 X2
SA6 TWD
MX6 0
SA6 TOKSHF INDICATE NO BITS LEFT
BX4 X0*X4 ZERO ADDRESS
BX4 X4+X1 INSERT ADDR(LIT IN TOKBUFF)
RJ ENDDTWD
EQ ADNAM
*
ENDD40 BSS 0
MX6 0
SA6 TWD
SA1 DEFLOC RE-SET TOKEN POINTER
BX6 X1
SA6 TOKWRD
SX6 60 ALL BITS AVAILABLE
SA6 TOKSHF
EQ ADNAM
*
ENDD50 SA1 NADS NUMBER OF ADDRESSES
SX1 X1-1
NZ X1,NORMAL JUMP IF NOT SIMPLE
SA1 NOPS NUMBER OF OPERATIONS
NZ X1,NORMAL JUMP IF NOT SIMPLE
SA1 DEFLOC ADDRESS OF DEFN
RJ =XSETDEF
RJ =XGETDEF NUMBER OF ARGUMENTS
NZ X1,NORMAL
RJ =XGETDEF GET FIRST ITEM
MX0 42 (X0) = GETVAR MASK
BX4 -X0*X1 SAVE *GETVAR* CODE
EQ ADNAM ADD DEFN NAME TO TABLE
*
* -ENDDTWD-
* ADD THE LAST TOKEN WORD TO *TOKBUF*
*
ENDDTWD EQ *
BX6 X4 SAVE GETVAR CODE
SA6 GVSAVE
SA2 TOKWRD
RJ APTWD
SA4 GVSAVE
EQ ENDDTWD
*
GVSAVE BSS 1
* /--- BLOCK NORMAL 00 000 75/02/11 02.52
*
NORMAL SX4 4 USE CODE FOR CALC
LX4 XCODEAL POSITION CODE
SA1 UREF
BX4 X1+X4 ATTACH *UNIT* BIT
SA1 DEFLOC
BX4 X4+X1 ATTACH ADDRESS
* SA1 TOKWRD
* SX6 X1+1 ADVANCE TO NEXT FREE WORD
* SA1 ATOKEN
* IX5 X1+X6 ECS ADDRESS OF NEXT TWD
* SA2 AVAR ECS ADDRESS OF FIRST NAME
* IX1 X5-X2
* PL X1,ERR4 BUFFER FULL
* SA6 TOKWRD
*
ADNAM BSS 0
CALL ADDNAM,DEFNAME
* /--- BLOCK ENDLIN 00 000 81/07/16 04.21
SA1 LASTKEY CHECK IF MORE TO LINE
SA1 X1+KEYTYPE
SX2 X1-OPCOMMA
NZ X2,ELN1 JUMP IF NOT COMMA
SA1 WORDPT
SA2 X1 SEE IF END-OF-LINE
ZR X2,ELN1
EQ DEFRD CONTINUE IF MORE
*
ENDLIN SX2 X1-EOL SEE IF END OF LINE CODE
ZR X2,ELN1 JUMP IF END-OF-LINE
EQ DEFRD
*
ELN1 RJ =XRTOKNAM FOR CONDITIONAL CSTOP/CSTART
RJ =XGETLINE
SA1 COMMAND CHECK FOR BLANK COMMAND
SA2 COMCONT
BX2 X1-X2 BLANK FOR CONTINUED COMMAND
ZR X2,DEFRD JUMP IF CONTINUED
SA3 LOCAL SEE IF LOCAL SET PROCESSING
ZR X3,ELN5 NEXT COMMAND IF GLOBAL SET
*
RJ =XSAVETAG SAVE THE NEXT LINES TAG
SA0 LUNIT RESTORE -UNIT- TAG FOR ARG
SA1 ATEMPEC
BX0 X1
WE TAGLTH+1
RJ ECSPRTY
SA0 TAG
RE TAGLTH+1
RJ ECSPRTY
*
SA1 LWRDPT POINT TO ARGUMENTS LIST
BX6 X1
SA6 WORDPT
EXEC JOINOV,14 RE-ENTER -UNIT PROCESSING
*
ELN5 BSS 0
SA2 HOLDEFN
IX2 X1-X2 CHECK FOR ANOTHER -DEFINE-
ZR X2,DEFNIN
*
EQ NXTC
NOSET SB1 11 NO SET
SA2 KE1
EQ ERRX
*
NAMERR SB1 12 BAD NAME
SA2 KE2
EQ ERRX
*
DUPNAM SB1 13 DUPLICATE
SA2 KE3
EQ ERRX
*
BADVAR SB1 14 BAD VAR
SA2 KE4
EQ ERRX
*
BADFORM SB1 15 BAD FORM
SA2 KE5
EQ ERRX
*
BADCNT SB1 16 BAD COUNT
SA2 KE6
EQ ERRX
*
BADSIZ SB1 17 BAD SIZE
SA2 KE7
EQ ERRX
*
BADTYP1 MX6 0 RESET LOCALS FLAG
SA6 LOCAL
BADTYP SB1 18 ARRAY TYPE
SA2 KE8
* /--- BLOCK ENDLIN 00 000 80/03/23 08.26
EQ ERRX
*
LITFULL SB1 19 MANY LITS
SA2 KE9
EQ ERRX
*
NAMFULL SB1 20 MANY NAMES
SA2 KE10
EQ ERRX
*
UFULL SB1 21 MANY UNITS
SA2 KE11
EQ ERRX
*
NOTYET SB1 22 NOT YET IN
SA2 KE12
EQ ERRX
*
*
*
* /--- BLOCK ENDLIN 00 000 80/03/23 08.25
ERR1 EQ CHARERR
*
ERR2 EQ LITERR
*
ERR3 SB1 25 UNDEFINED
SA1 KERR3
*
ERRX BX7 X1
SA7 CERROR1 STORE MESSAGE
ERRXX SX7 11 CODE FOR DEFINE ERROR
SA7 TFORMOK
SA3 LOCAL
ZR X3,=XERR IF NOT PROCESING LOCAL SET
*
SA1 DSET
SA1 SETNAMS+X1 X1 = NAME OF CURRENT SET
SA2 KLOCAL X2 = NAME OF LOCAL SET
IX3 X1-X2
ZR X3,=XERR IF LOCAL SET PROCESSING OK
*
MX6 0 NO LOCAL SET IN EFFECT
SA6 A3 ZERO LOCAL FLAG
EQ =XERR
*
ERR4 SB1 26 TOO MUCH
SA1 KERR4
EQ ERRX
*
ERR5 SB1 27 MANY ARGS
SA1 KERR5
EQ ERRX
*
ERR6 SB1 28 DUPLICATE
SA1 KERR6
EQ ERRX
*
ERR7 SB1 29 BAD NAME
SA1 KERR7
EQ ERRX
*
ERR8 SB1 30 BAD SET
SA1 KERR8
EQ ERRX
* /--- BLOCK ERR9 00 000 80/03/23 07.50
*
LIST X
*CALL DEFTEXT
LIST *
* /--- BLOCK ERR9 00 000 80/03/23 07.50
*
ERR9 SB1 31 NO SET
SA1 KERR9
EQ ERRX
*
ERR10 EQ FORMERR
*
ERR11 SB1 32 SYS ERR 1
SA1 KERR11
EQ ERRX
*
ERR12 SB1 33 ARG MUST BE UNRECOGNIZED NAME
EQ ERRXX
*
ERR13 SB1 34 CAN'7T HAVE ZERO ARGUMENTS F()
EQ ERRXX
*
* /--- BLOCK PURGE/ALL 00 000 79/02/18 17.47
*
PURGE SX3 X2-EOL
ZR X3,PURGALL PURGE ALL DEFINE SETS
CALL GETNAME,7 GET NAME OF SET TO PURGE
SX3 X2-EOL ERROR IF NOT END-OF-LINE
NZ X3,ERRORC
RJ =XFINDSET SEE IF SET EXISTS
NG B1,ERRORC
*
RJ PURGSET PURGE DSET B1
EQ PNXTLN
*
PURGALL BSS 0
RJ ALLPURG SUBROUTINE SINCE USED ELSEWHER
EQ PNXTLN
*
*
* *PURGSET*
*
* PURGE DEFINE SET
* ON ENTRY B1 = DSET TO PURGE
* DSET = CURRENTLY OPEN SET
*
* ON EXIT DSET = -1 IF ACTIVE SET PURGED
*
PURGSET EQ *
SX6 B1 SAVE DSET TO BE PURGED
SA6 PSET
SA1 DSET SEE IF IT IS CURRENT SET
SB2 X1
NE B1,B2,NOCLOSE IF NOT PURGING ACTIVE DSET
*
SX1 -1 NULL SET TO BE ACTIVE
NOCLOSE BX6 X1 SAVE ACTIVE DSET
SA6 ODSET
SB1 -1 GET NULL SET
RJ =XGETSET
SA1 PSET B1 = SET TO PURGE
SB1 X1
SA1 TOKADDS+B0 SOURCE OF MOVE
SA2 TOKLENS+B1
SA3 NAMLENS+B1
IX2 X2+X3
IX2 X2+X1 DESTINATION OF MOVE
SA3 TOKADDS+B1
IX3 X3-X1 LENGTH OF MOVE
SB4 B1 SET TO END UPDATE
SB3 -1 SET TO BEGIN UPDATE
RJ =XUPDNT UPDATE TOK/NAMADDS
MX6 0 NO TOKENS OR DEFNAMS
SA6 SETNAMS+B1
SA6 NAMLENS+B1
SA6 TOKLENS+B1
SA4 TOKADDS+B1
BX6 X4
SA6 NAMADDS+B1
SA0 VARS
SB1 VARLONG
RJ =XMVECS DELETE ECS COPY OF DSET
SA1 ODSET
SB1 X1
RJ =XGETSET
SA1 PSET RESTORE B1
SB1 X1
EQ PURGSET
PSET BSS 1
* /--- BLOCK ALLPURG 00 000 81/07/16 04.20
*
ALLPURG EQ *
SB1 B0 BEGIN WITH DSET 0
PURGLP SA1 SETNAMS+B1 DO NOT PURGE STUDENT DEFINE SET
SA2 KSTUD X2 = STUDENT SET NAME
IX1 X1-X2
ZR X1,NOPURG IF STUDENT SET, DO NOT PURGE
*
RJ PURGSET
NOPURG BSS 0
SB1 B1+1
SB2 MAXSET
NE B1,B2,PURGLP IF MORE TO PURGE
EQ ALLPURG
*
PURGEL EQ *
RJ =XSETSET SET UP LOCAL DEFINE SET PARMS.
SA1 KLOCAL X1 = NAME OF LOCAL SET
BX6 X1
RJ =XFINDSET B1 = SET NUMBER OF SET X6
NG B1,LPERR IF NO LOCAL SET
*
RJ PURGSET PURGE SET NUMBER B1
EQ PURGEL
*
PURGELU RJ PURGEL
SA1 GSET REACTIVATE GLOBAL DEFINE SET
SB1 X1
RJ =XGETSET
EXEC JOINOV,15 RE-ENTRY TO -UNIT- PROCESSING
*
PURGELD RJ PURGEL
EQ =XDFRD10
*
LPERR EQ "CRASH" LOCAL SET DIDNT EXIST
*
*
*
PNXTLN RJ =XGETLINE
SA1 COMMAND CHECK FOR BLANK COMMAND
SA2 COMCONT
BX2 X1-X2 BLANK FOR CONTINUED COMMAND
ZR X2,ERRORC ERROR IF CONTINUED
EQ NXTC
*
* /--- BLOCK NEWSET 00 000 75/05/29 04.20
*
*
* -NEWSET-
* INITIALIZES A DEFINE GROUP FOR THE NAME IN X6
* ON RETURN B1 CONTAINS THE INDEX OF THE GROUP
*
NEWSET EQ *
SA6 SAVEDNM SAVE THE SET NAME
NW1 MX6 0 0 NAME IS EMPTY SLOT
RJ =XFINDSET LOOK FOR EMPTY SLOT
GE B1,B0,NW2 IF EMPTY SLOT FOUND, INITIALIZE
*
RJ ALLPURG PURGE ALL BUT -STUDENT-
EQ NW1 THIS TIME IT WILL FIND IT
*
NW2 BSS 0
SA1 SAVEDNM
BX6 X1
SA6 SETNAMS+B1 STORE THE SET NAME
EQ NEWSET
*
* /--- BLOCK STUFF 00 000 75/02/11 03.16
*
*
* -STUFF-
* STORES THE 12 BIT BYTE IN LOWER X1 IN THE NEXT
* BYTE POSITION OF *TOKBUF*
*
STUFF EQ *
SA2 TOKWRD WORD COUNT
SA3 TOKSHF SHIFT COUNT
SB1 X3-12
PL B1,STUF1 JUMP IF DONT NEED NEW WORD
*
RJ APTWD WRITE OUT CURRENT TOKEN WORD
SA3 TOKSHF
SB1 48 DECREMENT *TOKSHF*
STUF1 MX0 48 12 BIT MASK
BX1 -X0*X1
SA2 TWD LOAD CURRENT WORD
LX1 X1,B1 POSITION NEW BYTE
LX0 X0,B1
BX6 X2*X0 CLEAR NEW BYTE POSITION
BX6 X6+X1 ATTACH NEW BYTE
SA6 A2 STORE NEW *TWD*
SX6 B1 STORE NEW *TOKSHF*
SA6 A3
EQ STUFF
*
*
* SET THE TOP BIT OF THE FIRST 12 BIT BYTE
* OF AN ADDRESS *ADTYPE* TO INDICATE THE
* FOLLOWING BYTE CONTAINS FURTHER INFORMATION
* AND PUT BOTH BYTES IN THE TOKEN BUFFER
* ON ENTRY (X1) = ADTYPE
*
STUFADR EQ *
BX7 X1
AX1 12 STORE FIRST 12 BITS
SX2 4000B SET 12TH BIT OF 1ST BYTE
BX1 X1+X2
RJ STUFF
BX1 X7 RESTORE
RJ STUFF STORE 2ND 12 BITS
BX1 X7 RESTORE
EQ STUFADR
*
* /--- BLOCK STLIT1 00 000 79/02/20 21.04
*
* LITERAL IS IMMEDIATE SO IT ADDS IT TO THE
* TOKEN BUFFER IN THE FIRST WHOLE WORD AFTER ITS
* ADTYPE WITH THE 22ND BIT OF THE ADTYPE SET
* TO INDICATE IMMEDIACY TO *GETDEF*
* ON ENTRY (X1) = GETVAR CODE
* ADDRESS OF GETVAR CODE POINTS INTO *LITS*
*
STLIT1 EQ *
SA2 TOKSHF PREDICT ADDR OF LIT
SA3 TOKWRD
SX4 X2-24
PL X4,NXTWD IF LIT CAN BEGIN AT NEXT WORD
*
SX3 X3+1 MUST BEGIN ONE WORD AFTER THAT
NXTWD SX3 X3+1 POINT TO NEXT WORD
MX0 -XCODEAL
BX2 -X0*X1 GET ADDRESS OF LIT IN *LITS*
SA2 LITS+X2 GET LITERAL
BX6 X2
SA6 LIT
BX1 X0*X1 ZERO OUT ADDRESS
BX1 X1+X3 ENTER LIT ADDR IN TOKEN BUFF
RJ STUFADR STUFF BOTH BYTES OF (X1)
SA1 LIT (X1) = LITERAL
RJ STUFLIT WRITE OUT LITERAL TO TOKENS
* IN NEXT AVAILABLE WORD
EQ STLIT1
* /--- BLOCK CONSTANTS 00 000 80/03/23 07.51
* SUBROUTINE TO CHECK LIST OF SPECIAL NAMES
LUPDUN SA7 SEGFLG SET SPECIAL DEFINE TYPE
DEFNAMS EQ * ENTER WITH MAX NO NAMES IN X7
LUPNAM SA3 X7+DEFNAM-1 GET SPL NAME IN X3
IX3 X3-X6 NAME IS IN X6
ZR X3,LUPDUN QUIT IF FOUND
SX7 X7-1
NZ X7,LUPNAM
EQ LUPDUN
*
* LIST OF SPECIAL DEFINE TYPE NAMES
*
DEFNAM DATA 7LSEGMENT
DATA 8LSEGMENTV
DATA 5LUNITS
DATA 5LARRAY
DATA 8LARRAYSEG
DATA 9LARRAYSEGV
DATA 7LCOMPLEX
DATA 0LSEGMENTF
DEFGNML EQU *-DEFNAM
DATA 7LINTEGER
DATA 8LFLOATING
DEFLNML EQU *-DEFNAM
DATA 5LPURGE ONLY ACTIVE ON FIRST LINE
DEFNAML EQU *-DEFNAM
DATA 5LMERGE ONLY ACTIVE IN LOCAL SET, LN 1
*
K60 DATA 60.0
KVERT DATA 0LVERTICAL
KSIGN DATA 0LSIGNED
KS DATA 0LS
KE1 DATA 10LNO SET
KE2 DATA 10LBAD NAME
KE3 DATA 10LDUPLICATE
KE4 DATA 10LBAD VAR
KE5 DATA 10LBAD FORM
KE6 DATA 10LBAD COUNT
KE7 DATA 10LBAD SIZE
KE8 DATA 10LARRAY TYPE
KE9 DATA 10LMANY LITS
KE10 DATA 10LMANY NAMES
KE11 DATA 10LMANY UNITS
KE12 DATA 10LNOT YET IN
*
KPREVN DATA 8LPREVIOUS
KGLOBAL DATA 0LGLOBAL
*
*
KBLANK DATA 10L BLANKS
KSTUD DATA 7LSTUDENT
*
*
KERR3 DATA 10LUNDEFINED
KERR4 DATA 10LTOO MUCH
KERR5 DATA 10LMANY ARGS
KERR6 DATA 10LDUPLICATE
KERR7 DATA 10LBAD NAME
KERR8 DATA 10LBAD SET
KERR9 DATA 10LNO SET
KERR11 DATA 10LSYS ERR 1
*
*
SAVEDNM BSS 1
DEFNAME BSS 1
DEFLOC BSS 1
ENDKEY BSS 1
UREF BSS 1
DCONST BSS 1
DNVAR BSS 1
IWORDPT BSS 1
OWORDPT BSS 1
INDLIT BSS 1
OLDINX BSS 1
OLDLAST BSS 1
NARGS BSS 1
ARGLIST BSS MAXARG
*
*
ENDOV
*
*
OVTABLE
*
*
END DEFINE$
* /--- BLOCK SEGMENT 00 000 81/07/13 01.10
IDENT SEGMENT
LCC OVERLAY(1,1)
*
TITLE SEGMENT/ARRAY/UNITS
TITLE
*
*
CST
*
*
SEGMNT$ OVFILE
*
*
EXT CHARERR,BADPAR,DECERR,VARERR
EXT LOGERR,FORMERR,EQERR,OCTERR
EXT ALFERR,INDXERR,DEFERR,SEGERR
EXT COMPERR,LNGERR,LITERR,TEMPERR
EXT ECSPRTY
*
EXT COMCONT,DEFREAD,NXTC
EXT KEYTYPE,SEGFLG
*
*
SEGOV OVRLAY
SA1 OVARG1 GET OVERLAY ARGUMENT
SB1 X1
JP B1+*+1
*
+ EQ SEGRD -SEGMENT-
+ EQ UNSRD -UNITS-
*
*
* /--- BLOCK SEGMENT 00 000 73/00/00 00.00
TITLE READ-IN FOR -SEGMENT- COMMAND
*
*
* -SEGREAD-
* READ-IN ROUTINE FOR -SEGMENT- COMMAND
* ADDS THE NAME OF THE SEGMENT TO THE DEFINED
* NAME TABLE AND ADDS A LITERAL CONTAINING THE
* SEGMENT INFO TO THE DEFINED TOKEN TABLE
*
* FORMAT OF SEGMENT INFO WORD -
*
* SIGN BIT = 0 FOR STUDENT, 1 FOR COMMON
* NEXT BIT = 0 IF UNSIGNED, 1 IF SIGNED
* NEXT BIT = 0 IF HORIZONTAL, 1 IF VERTICAL
* NEXT BIT = 1 IF SEGMENTF
* NEXT 2 BITS = UNUSED
* NEXT 18 BITS = NUMBER OF BITS PER BYTE
* NEXT 18 BITS = BIAS TO START OF ARRAY
* NEXT 18 BITS = NUMBER OF BYTES PER WORD (HORIZ)
* BIT POSITION OF BYTE (VERT)
*
* /--- BLOCK SEGRD 00 000 76/08/02 00.06
*
SEGRD SA1 DSET MUST HAVE DEFINE SET
NG X1,NOSET
SA1 WORDPT
SA1 X1-1 BACK UP TO PREVIOUS CHARACTER
SA2 X1+KEYTYPE
SX1 X2-OPCOMMA SEE IF ENDED WITH COMMA
NZ X1,BADFORM
MX6 -1 SET MODE FOR -VSEEK- SEARCH
SA6 VSKMODE
CALL GETNAME,8 GET NAME OF SEGMENT/ARRAY
ZR X6,NAMERR
SA6 SEGNAM
SB2 B1-8 CHECK HOW MANY CHARACTERS
NG B2,SEG005
SA3 KVERT
BX3 X3-X6 CHECK FOR SEGMENT,VERTICAL
ZR X3,VERTSEG
EQ NAMERR 8 CHARACTER NAME NOT LEGAL
*
SEG005 SA3 SEGFLG IS 1,2 IF SEGMENT,SEGMENTV
SX3 X3-3
NG X3,SEG008 IF SEGMENT/SEGMENTV
SX3 X3-8+3
NZ X3,ARAYDEF IF NOT SEGMENTF
SEG008 SX1 X2-OPCOMMA CHECK FOR COMMA
ZR X1,SEG010
SX1 X2-OP= CHECK FOR =
ZR X1,SEG010
SX1 X2-OPASIGN CHECK FOR ASSIGNMENT
NZ X1,BADFORM
*
SEG010 RJ =XVSEEK SEE IF ALREADY DEFINED
SA1 ADTYPE
PL X1,DUPNAM EXIT IF DUPLICATE NAME
SA7 DEFNLOC SAVE LOCATION OF DEFINITION
CALL SYMCHK,SEGNAM
RJ =XRTOKNAM MAKE READY FOR *INITDEF*
RJ =XCOMPILE STARTING VARIABLE OF ARRAY
MX0 -XCODEAL MASK FOR ADDRESS PORTION
BX6 -X0*X1
LX6 18 POSITION ADDRESS
AX1 XCODEAL POSITION -GETVAR- CODE TYPE
MX0 -3
BX1 -X0*X1 MASK OFF 3 BIT TYPE CODE
SX2 X1-2
ZR X2,SEG100 OK IF STUDENT BANK
SX2 X1-3
NZ X2,BADVAR ERROR IF NOT COMMON
MX7 1
BX6 X6+X7 SET SIGN BIT FOR COMMON
SEG100 SA6 SEGWORD SAVE TYPE BIT AND ADDRESS
SA1 SEGFLG
SX1 X1-1 CHECK FOR SEGMENT
NZ X1,VSEG20 IF SEGMENTV/F
* /--- BLOCK SEG200 00 000 75/05/29 04.25
*
RJ =XRTOKNAM MAKE READY FOR *INITDEF*
RJ =XCOMPILE
MX0 -XCODEAL
BX6 X0*X1 MUST BE SHORT LITERAL
NZ X6,BADCNT
ZR X1,BADCNT
SX6 X1-60 CHECK IF BYTE TOO BIG
PL X6,BADCNT
PX6 X1
NX6 X6 CONVERT TO FLOATING
SA2 K60
FX6 X2/X6 COMPUTE BYTES PER WORD
UX6 X6,B1
LX6 X6,B1 BACK TO INTEGER
LX1 18+18
BX6 X1+X6 COMBINE BIT AND BYTE COUNTS
SA1 SEGWORD
BX6 X1+X6 COMBINE WITH INFO WORD
SA6 A1
*
SEG200 SA2 LASTKEY LOAD LAST CHARACTER
ZR X2,ADDLIT JUMP IF END-OF-LINE
SA2 X2+KEYTYPE
SX6 X2-OPCOMMA CHECK FOR COMMA
NZ X6,BADFORM
*
* CHECK FOR SIGNED SEGMENT OPTION
*
CALL GETNAME,7 GET OPTION NAME
ZR X6,NAMERR
NZ X1,BADFORM ERROR IF NOT END-OF-LINE
SA3 KSIGN CHECK FOR SIGNED SEGMENT
BX3 X6-X3
ZR X3,SIGNSEG
SA3 KS ALLOW ABBREVIATION
BX3 X6-X3
NZ X3,NAMERR ERROR IF NOT -S-
*
SIGNSEG MX6 1
LX6 59 POSITION FOR SECOND BIT
SA1 SEGWORD
BX6 X1+X6 SET SECOND BIT
SA6 A1
EQ ADDLIT
*
* /--- BLOCK VERTSEG 00 000 76/08/02 00.10
*
* PROCESS SEGMENT,VERTICAL CASE
*
VERTSEG SA3 SEGFLG CHECK TYPE FLAG
SX3 X3-1
NZ X3,NAMERR ERROR IF NOT -SEGMENT-
SX1 X2-OPCOMMA
NZ X1,BADFORM ERROR IF DID NOT END WITH COMMA
CALL GETNAME,7 GET NAME OF SEGMENT
ZR X6,NAMERR
SA6 SEGNAM
SX7 2
SA7 SEGFLG SET SEGMENTV
EQ SEG008
*
VSEG20 RJ =XRTOKNAM MAKE READY FOR *INITDEF*
RJ =XCOMPILE EVALUATE STARTING BIT POSITION
ZR X1,BADCNT EXIT IF BAD BIT POSITION
MX0 -XCODEAL
BX0 X0*X1 MASK ALL BUT ADDRESS PORTION
NZ X0,BADCNT EXIT IF NOT A SHORT LITERAL
SX0 X1-61
PL X0,BADCNT EXIT IF ILLEGAL BIT POSITION
SA2 SEGWORD
BX6 X1+X2 MERGE BIT POSITION WITH INFO
SA6 A2
*
RJ =XRTOKNAM MAKE READY FOR *INITDEF*
RJ =XCOMPILE EVALUATE LENGTH OF BYTE
ZR X1,BADCNT EXIT IF BAD BYTE SIZE
MX0 -XCODEAL
BX0 X0*X1 MASK ALL BUT ADDRESS PORTION
NZ X0,BADCNT
SX0 X1-60
PL X0,BADCNT EXIT IF BAD BYTE SIZE
SA2 SEGWORD
SX0 X2-1 PICK UP BIT POSITION
IX0 X0+X1 ADD LENGTH OF BYTE
SX0 X0-61
PL X0,BADCNT EXIT IF BYTE SIZE TOO BIG
LX1 18+18 POSITION LENGTH OF BYTE
BX6 X1+X2
MX0 1
LX0 58 POSITION VERTICAL BIT
BX6 X0+X6
SA1 SEGFLG CHECK IF SEGMENTF
SX1 X1-8
NZ X1,VSEG30 IF NOT SEGMENTF
LX0 -1
BX6 X0+X6
VSEG30 SA6 A2 UPDATE SEGMENT INFO WORD
EQ SEG200
*
*
* /--- BLOCK ADDLIT 00 000 81/07/16 04.20
*
* ADD SEGMENT INFO WORD TO DEFINED LITERAL TABLE
* ARRAY USES THIS IF HAS ONLY ONE LITERAL WORD
*
ADDLIT BSS 0
SA1 SEGWORD
RJ =XSTUFLIT STORE SEGMENT DESCRIPTOR
SA2 TOKWRD IN ECS TOKEN BUFFER
RJ =XAPTWD
SA2 TOKWRD ADDRESS OF LITERAL IN TOKENS
SB1 X2-1
SA1 SEGFLG CHECK TYPE
SX1 X1-3
NG X1,SEG400 JUMP IF -SEGMENT-
ZR X1,SEG400 IN CASE -UNITS- USES THIS LATER
SX1 X1-8+3
ZR X1,SEG400 IF SEGMENTF
*
SEG310 SX4 6 6=CODE FO ARRAY IN *DEFNLEX*
EQ SEG410
*
SEG400 SX4 5 5=SEGMENT
SEG410 LX4 XCODEAL POSITION TYPE
SX1 B1
BX4 X4+X1 FORM GETVAR CODE
CALL ADDNAM,SEGNAM
*
ENDSEG EXEC DEFOV,2 RETURN FROM SEGOV
*
* /--- BLOCK SEGERRS 00 000 76/06/30 02.59
*
NOSET SB1 11 NO SET
SA2 KE1
EQ ERRX
*
NAMERR SB1 12 BAD NAME
SA2 KE2
EQ ERRX
*
DUPNAM SB1 13 DUPLICATE
SA2 KE3
EQ ERRX
*
BADVAR SB1 14 BAD VAR
SA2 KE4
EQ ERRX
*
BADFORM SB1 15 BAD FORM
SA2 KE5
EQ ERRX
*
BADCNT SB1 16 BAD COUNT
SA2 KE6
EQ ERRX
*
BADSIZ SB1 17 BAD SIZE
SA2 KE7
EQ ERRX
*
BADTYP SB1 18 ARRAY TYPE
SA2 KE8
EQ ERRX
*
LITFULL SB1 19 MANY LITS
SA2 KE9
EQ ERRX
*
NAMFULL SB1 20 MANY NAMES
SA2 KE10
EQ ERRX
*
UFULL SB1 21 MANY UNITS
SA2 KE11
EQ ERRX
*
NOTYET SB1 22 NOT YET IN
SA2 KE12
EQ ERRX
*
ERRX BX6 X2 PLANT ERROR MESSAGE
SA6 CERROR1
SX7 11 DEFINE ERROR
SA7 TFORMOK
EQ =XERR NEW CONDENSE ERROR PROCESSING
*
*
SEGNAM BSS 1
USNAM EQU SEGNAM
*
SEGWORD BSS 1
ARAYWD EQU SEGWORD
ARAYWD2 BSS 1
*
*
* /--- BLOCK ADDNAM 00 000 75/02/10 20.14
LIST X
*CALL DEFTEXT
LIST *
*
ERR4 SB1 26 TOO MUCH
SA1 KERR4
BX7 X1
SA7 CERROR1 STORE MESSAGE
SX7 11 CODE FOR DEFINE ERROR
SA7 TFORMOK
EQ =XERR
*
KERR4 DATA 10LTOO MUCH
* /--- BLOCK ARAYDEF 00 000 76/07/02 01.12
*
*
TITLE ARRAY DEFINE
*
* READIN FOR -ARRAY- AND -COMPLEX-
*
* PERMISSABLE FORMS FOR ARRAY DEFINE...
* ARRAY,NAME=V1 (SCALAR ARRAY WITH ROWS=COLS=1)
* ARRAY,NAME(ROWS)=N1 (VECTOR WITH COLS=1)
* ARRAY,NAME(ROWS,COLS)=VC1 (MATRIX)
* ARRAY,NAME(ROW1;ROWS)=V1 (VECTOR BASE REDEFN)
* ARRAY,NAME(ROWS,COLS;ROW1,COL1)=N1 (BASE REDEFN)
* ARRAY,..ANY ABOVE FORM..=N1,6,S (SEGMENTED ARRAY)
* COMPLEX,...ANY REAL NON-SEGMENTED SPEC ABOVE OK
*
* FORMAT OF ARRAY/COMPLEX INFO WORD
*
* BIT 59 = 0 FOR STUDVAR, 1 FOR COMMON
* BIT 58 = 0 FOR REAL, 1 FOR COMPLEX ARRAY
* BIT 57 = 0 FOR BASE INDEX OF 1, =1 FOR OTHER
* BIT 56 = 0 FOR WORD, 1 FOR SEGMENTED ARRAY
* IF BITS 56OR57 ON, NEXT LITWORD HAS DETAILS
* BITS 55,54 HAVE ARRAY DIMENSIONS, 0 IS SCALAR,
* 1 FOR VECTOR, 2 FOR MATRIX, 3-D NOT IMPLEMENTED
* NEXT 9 BITS ARE SIZE = ROWS"COLS (MAX 511)
* NEXT 9 BITS ARE NUMBER OF ROWS-1
* NEXT 9 BITS ARE NUMBER OF COLS-1
* NEXT 9 BITS ARE NUMBER OF PLANES-1 (FOR 3-D)
* LOWER 18 BITS ARE GETVAR CODE OF FIRST ELEMENT
* I/F BIT,3 TYPEBITS(2=STUD,3=COMM),14BITS REL ADDR
*
* ARAYWD2 (2D LITWORD) FORMAT USED FOR
* SEGMENTED AND BASE-REDEFINED ARRAYS
*
* BIT 59 SET IF SIGNED SEGMENT
* BIT 58 SET IF VERTICAL SEGMENT, 0 IF HORIZONTAL
* NEXT 4 BITS UNUSED
* NEXT 6 BITS ARE (BITS/BYTE) FOR SEGMENT
* NEXT 6 ARE (BYTES/WD) (0-63) FOR HORIZ SEG
* OR ARE (BIAS TO START OF SEG) IF VERTICAL
* NEXT 14 ARE ROW BASE INDEX
* NEXT 14 ARE COL BASE INDEX
* LAST 14 ARE PLANE BASE INDEX
*
*
ARAYDEF SX7 1 INITIALIZE
SA7 NROW
SA7 NCOL
SA7 ROW1
SA7 COL1
MX7 0
SA7 ARAYWD
SA7 ARAYWD2
SA7 DIMEN
BX7 X2
SA7 SIZ SAVE TERMINATOR
*
* /--- BLOCK ARAYNAM 00 000 76/06/30 03.00
* DETERMINE ARRAY NAME AND ANALYZE DIMENSIONS
RJ =XVSEEK SEE IF ALREADY DEFINED
SA1 ADTYPE
PL X1,DUPNAM ERROR IF DUPLICATE NAME
SA7 DEFNLOC SAVE ECS LOC TO INSERT DEFN
CALL SYMCHK,SEGNAM CHECK FOR REDEFN WARNING
SA2 SIZ RESTORE TERMINATOR
SX1 X2-OP= CHECK FOR =
ZR X1,ARAYLOC IS SCALAR
SX1 X2-OPASIGN CHECK FOR ASSIGNMENT
ZR X1,ARAYLOC IS SCALAR
SX7 1
SA7 DIMEN
SX1 X2-OP( CHECK FOR (SIZE) IN PAREN
NZ X1,BADFORM
RJ SIZFIL GET 1ST SIZE FIELD
SA6 NROW AND SAVE IT
SX3 X2-OP) CHECK FOR ONLY ONE FIELD
ZR X3,ARAYNUL JUMP IF VECTOR
SX3 X2-OPCOMMA CHECK FOR COMMA OR SEMICOLON
NZ X3,BADFORM
SX3 X1-56B CHECK FOR COMMA
ZR X3,ARAYMAT JUMP IF MATRIX
SA6 ROW1 IS VECTOR BASE IF SEMICOLON
RJ SIZFIL GET ROWS
SA6 NROW
SX3 X2-OP)
NZ X3,BADFORM MUST BE )
EQ ARAYNUL VECTOR DONE
*
ARAYMAT SX6 2
SA6 DIMEN DIMEN=2 FOR MATRIX
RJ SIZFIL GET COLS
SA6 NCOL
SX3 X2-OP) CHECK FOR LAST FIELD
ZR X3,ARAYNUL JUMP IF IS
SX3 X1-77B TEST FOR SEMICOLON TERMINATOR
NZ X3,BADFORM ERROR IF ISNT
SA6 COL1 REDEFINE BASE INDICES
SA3 NROW
BX7 X3
SA7 ROW1
RJ SIZFIL GET ROWS
SA6 NROW
SX3 X1-56B TEST FOR COMMA
NZ X3,BADFORM ERROR IF NOT
RJ SIZFIL GET COLS
SA6 NCOL
SX3 X2-OP) CHECK IF LAST FIELD
NZ X3,BADFORM ERROR IF NOT
*
* /--- BLOCK ARAYNUL 00 000 76/08/02 03.34
*
* CHECK FOR = OR _ FOLLOWING )
*
ARAYNUL CALL GETNAME,7 VECTOR,MATRIX ENTER HERE
NZ X6,BADFORM NEXT NAME SHOULD BE BLANK
SX3 X2-OP=
ZR X3,ARAYLOC TERMINATOR SHOULD BE =
SX3 X2-OPASIGN OR ASSIGN ARROW
NZ X3,BADFORM
*
* GET STARTLOC AND CHECK IF IN BOUNDS
*
ARAYLOC RJ =XRTOKNAM MAKE READY FOR *INITDEF*
RJ =XCOMPILE GET STARTLOC ADTYPE IN X1
BX6 X1
AX1 XCODEAL POSITION CODETYPE
MX3 -3
BX3 -X3*X1 GETVAR CODE TYPE
MX4 0 STUD/COM BIT OFF
SX2 X3-2 CHECK STARTING VARIABLE TYPE
ZR X2,ARAYSTB JUMP IF STUDENT BANK
SX2 X3-3 MUST BE COMMON
NZ X2,BADVAR ERROR IF NOT
MX4 1 SET COMMON BIT
ARAYSTB BX6 X4+X6 MERGE IN
SA6 ARAYWD SAVE IT
SA2 LASTKEY
ZR X2,ARAYSTD JUMP IF E.O.L (NOT SEGMENT)
*
* HANDLE SEGMENTED ARRAY ARGUMENTS
*
SA2 X2+KEYTYPE GET KEYTYPE
SX3 X2-OPCOMMA
NZ X3,BADTYP MUST BE COMMA IF SEGMENTED
MX0 1 SEE BELOW
**ALLOW EITHER V OR N TYPE
SA1 DIMEN
ZR X1,BADTYP ERROR IF SEGMENTED SCALAR
LX0 57
BX6 X6+X0 SET SEGMENT BIT 56 ON
LX0 3+XCODEL-XFBIT I/F BIT OFF SINCE
BX6 -X0*X6 ALL SEGMENTS ARE INTEGERS
SA6 ARAYWD SAVE TEMPORARILY
*
RJ SIZFIL GET 1ST SEGMENT ARGUMENT
ZR X6,BADCNT CANNOT BE ZERO
NG X6,BADCNT OR NEGATIVE
SX3 X6-61 CHECK IF BYTE TOO BIG
PL X3,BADCNT
SA6 ATEMP SAVE TEMPORARILY
***
SA3 SEGFLG
SX0 X3-6
ZR X0,ARAYVER JUMP IF VERTICAL SEGMENT
SX0 X3-5
NZ X0,BADFORM ERROR IF NOT HORIZ SEGMENT
ZR X1,ARAYSEG IF E.O.L. SIGNBIT(X1)=0
SX3 X2-OPCOMMA
NZ X3,BADFORM MUST BE ,SIGNED
*
CALL GETNAME,7
ZR X6,NAMERR
NZ X1,BADFORM MUST BE E.O.L.
MX1 1 SET SIGNBIT
EQ SIGNCHK
*
ARAYSTD SA3 SEGFLG IF NO TAGS AFTER LOCATION
SX0 X3-6 IT CANNOT BE SEGMENTED ARRAY
ZR X0,BADFORM
SX0 X3-5 CHECK BOTH SEGMENT,SEGMENTV
ZR X0,BADFORM
EQ ARAYSIZ
* /--- BLOCK ARAYVER 00 000 76/08/02 03.43
*
* GET VERTICAL SEGMENT BYTESIZE
*
ARAYVER SX3 X2-OPCOMMA
NZ X3,BADFORM MUST BE , BETWEEN START,BYTE
RJ SIZFIL GET SEGMENT BYTESIZ
ZR X6,BADCNT CANT BE ZERO
NG X6,BADCNT OR NEGATIVE
SA3 ATEMP = STARTBIT
IX7 X3+X6
SX7 X7-62
PL X7,BADCNT IS .GT.61
LX6 6
BX6 X6+X3 BYTESIZ/STARTBIT
SA6 SIZ SAVE AGAIN IN SIZ
BX3 X1 SAVE TERMINATOR
MX1 1
LX1 59 SET VERTICAL,NONSIGNED BITS
ZR X3,ARAYSEG JUMP IF E.O.L.
*
* CHECK FOR SIGNED OPTION
SX3 X2-OPCOMMA
NZ X3,BADFORM ERROR IF TERMINATOR NOT COMMA
CALL GETNAME,7
ZR X6,NAMERR
NZ X1,BADFORM ERROR IF NOT E.O.L.
MX1 2 SET SIGN,VERTICAL BITS
SIGNCHK SA3 KSIGN
BX3 X6-X3 CHECK FOR SIGNED SEGMENT
ZR X3,ARAYSEG
SA3 KS ALLOW ABBREVIATION
BX3 X6-X3
NZ X3,NAMERR ERROR IF NO S AFTER COMMA
*
* /--- BLOCK ARAYSEG 00 000 78/02/11 00.12
*
* HORIZONTALLY SEGMENTED ARRAYS
*
ARAYSEG SA2 ARAYWD2
BX6 X1+X2 ADD SIGNED+VERT SEGMENT BITS
*
SA2 SIZ GET BACK SEGMENT SIZE
LX1 1
****
* EQ NOTYET **USE THIS TO TURN OFF VERTSEG
****
NG X1,ARAYVSG JUMP IF VERTICAL SEG
*****
EQ NOTYET **THIS TURNS OFF HORIZ SEG
*****
PX7 X2
NX7 X7 FLOAT BITS/BYTE
SA3 K60 =60.0
FX7 X3/X7 COMPUTE BYTES/WORD
UX7 X7,B1
LX7 X7,B1 AS INTEGER
LX2 6
BX2 X7+X2 COMBINE BIT/BYTE COUNT
ARAYVSG LX2 42
BX6 X6+X2 MERGE WITH ARAYWD2
SA6 ARAYWD2 AND SAVE
*
*
* CALCULATE ARRAY SIZE
*
ARAYSIZ SA1 NROW GET LAST,FIRST ROW,COL
SA2 NCOL
SA3 ROW1
SA4 COL1
IX6 X1-X3 NUMBER OF ROWS-1, COLS-1
IX7 X2-X4 = COLS-1
BX5 X6+X7 BOTH SHOULD BE POSITIVE
NG X5,BADSIZ
SX1 X6+1 NUMROWS
SX2 X7+1 NUMCOLS
DX4 X1*X2 NUMROWS*NUMCOLS
* IF COMPLEX MUST DOUBLE SIZE
SA3 SEGFLG
SX3 X3-7
SX0 0 BIT 58 OFF FOR REAL
SA2 ARAYWD
NZ X3,ARAYPAK JUMP IF NOT COMPLEX
IX4 X4+X4 DOUBLE SIZE
LX2 60-XCODEL+XFBIT CHECK I/F BIT
PL X2,BADTYP ERROR IF COMPLEX INTEGER TYPE
SX0 20B SET REAL/COMPLEX BIT ON
*****
EQ NOTYET ***TURNS OFF COMPLEX ARRAYS***
*****
*
* START BUILDING ARRAY INFORMATION WORD(S)
*
* ARAYPAK SX3 X4-ARAYLTH MAX SIZE OF ARRAY (256)
ARAYPAK SX3 ARAYLTH MAX SIZE OF ARRAY (255)
IX3 X4-X3
PL X3,BADSIZ ERROR IF >256
SB1 X4-1 SAVE SIZE -1
SA3 DIMEN START BUILDING ARAYWD
BX3 X0+X3 MERGE REAL/CMPLX BIT AND DIMEN
LX3 9
BX3 X3+X4 MERGE THIS WITH SIZE
LX3 9 THEN MERGE IN
BX6 X3+X6 NUMROWS-1,
LX6 9
BX6 X7+X6 NUMCOLS-1,
LX6 9 N PLANES-1 = 0 FOR NOW
LX6 XCODEAL+4 ROOM FOR GETVAR CODE(18BITS)
SA2 ARAYWD
BX6 X6+X2 MERGE SHAPE,GETVAR,COM+SEG BITS
*
* AT THIS POINT X6=ARAYWD, X2 HAS GETVAR, X4=SIZE
*
* NOW GET START LOCATION AND CHECK LENGTH IN BOUNDS.
*
* /--- BLOCK ARAYCHK 00 000 82/10/06 17.19
MX5 -XCODEAL
BX7 -X5*X2 MASK OFF ADDRESS INTO X7
LX2 3 SEGMENT BIT AT LEFT
PL X2,ARAYCHK JUMP IF NOT SEGMENTED
*
* REPLACE SEGMENTED ARRAY SIZE WITH NUMBER OF WORDS USED
*
SA1 ARAYWD2
LX1 1
MX2 -6
NG X1,ARAYCHK JUMP IF VERTICAL SEGMENT
LX1 17
BX1 -X2*X1 BYTES/WD
SX4 X4-1 SIZE-1
PX4 X4
NX4 X4 FLOAT SIZE
PX1 X1
NX1 X1 FLOAT BYTES/WD
FX4 X4/X1 (SIZE-1)/(BYTES/WD)
UX4 X4,B2
LX4 X4,B2 +1=
SX4 X4+1 NUMBER OF WORDS USED BY SEGARAY
*
ARAYCHK SX4 X4-1 SIZE-1
IX4 X7+X4 X4=LAST ARRAY ELEMENT INDEX
PL X6,ARAYSTU JUMP IF IN STUDENT BANK
SX1 X4-NCVRLIM-1 (LAST ELEMENT)-(LIM+1)
PL X1,BADSIZ ERROR IF LAST EL NOT IN BOUNDS
EQ ARAYOK
*
ARAYSTU SX2 X4-VARLIM-1 (LAST)-(LIM+1)
NG X2,ARAYOK JUMP IF ALL INSIDE STUD BANK
SX2 X7-VARLIM-1 COULD BE ROUTER ARRAY
NG X2,BADSIZ JUMP IF START LOC NOT ROUTER
SA1 ARVARS
SA2 ASVARS
IX1 X1-X2 BIAS TO ROUTER VARS
SA2 RVARL (X2) = NUMBER OF RVARS ALLOWED
IX1 X1+X2 OFFSET TO LAST ROUTER VAR
SX1 X1+1 LIMIT FOR ROUTER VARS
IX2 X4-X1 CHECK IF INDEX IS TOO LARGE
NG X2,ARAYOK INSIDE ROUTER VAR LIMIT
IX2 X7-X1 CHECK IF BASE WAS ROUTER VAR
NG X2,BADSIZ IF SO, INDEX WAS TOO LARGE
*
* AT THIS POINT, MUST BE A LOCAL VAR OR AN ERROR. THIS
* DEPENDS ON THE FACT THAT THE CM ADDRESSES FOR STUDENT
* VARS, ROUTER VARS AND LOCAL VARS (WHICH UNFORTUNATELY
* ALL HAVE THE SAME GETVAR CODE -- GRR) ASCEND IN THE
* ABOVE ORDER.
*
SA1 ASVARS ADDRESS OF STUDENT VARS
SA3 ALVARS ADDRESS OF LOCAL VARS
BX0 X6 PRESERVE X6 OVER FOLLOWING
IX6 X1-X3 OFFSET INTO LOCAL VARS
IX6 X6+X4 OFFSET OF LAST ELEMENT + 1
RJ =XLBOUND CHECK IN BOUNDS (A1/X1 USED)
SA1 LVARN NUMBER OF LOCALS USED SO FAR
IX3 X6-X1 NUMBER NEEDED - NUMBER AVAIL.
NG X3,LVOK MORE THAN ENOUGH AVAILABLE
ZR X3,LVOK JUST ENOUGH AVAILABLE
SA6 A1 MAKE NUMBER NEEDED NEW NUM USED
BX6 X1 SAVE THE OLD NUMBER USED SO FAR
SA6 OLVARN
*
* /--- BLOCK ARAYOK 00 000 82/10/06 17.20
LVOK BX6 X0 RESTORE X6 = ARAYWD
ARAYOK SA6 ARAYWD SAVE ARRAY INFO WORD
*
* ADD BASE REDEFINITION INFO TO ARAYWD2
*
SA1 ARAYWD2 CONTAINS SEGMENT INFO SO FAR
SA2 ROW1
SA3 COL1
SX4 1 SET PLANE1=1 FOR NOW
BX2 -X5*X2 X5 STILL = -XCODEAL 14BIT MASK
BX3 -X5*X3
BX4 -X5*X4
LX2 XCODEAL
BX2 X2+X3 ROW1,COL1
LX2 XCODEAL
BX2 X2+X4 ROW1,COL1,PLANE1
SA4 RCPCHK SUBTRACT 1,1,1
IX7 X2-X4
ZR X7,ARAYDUN JUMP IF NO BASE REDEFINITION
MX7 1
LX7 58 POSITION FOR BIT 57
*
ARAYDUN BX6 X6+X7 MERGE BASEREDEF BIT INTO ARAYWD
SA6 ARAYWD WHICH IS NOW COMPLETE
BX7 X2+X1 MERGE SEGMENT + BASEREDEF INFO
SA7 ARAYWD2 AND SAVE IT
MX0 2
LX6 2
BX6 X0*X6
ZR X6,ADDLIT JUMP IF NO ARAYWD2 INFO
SA1 ARAYWD
RJ =XSTUFLIT
SA1 ARAYWD2
RJ =XSTUFLIT
SA1 TOKWRD
RJ =XAPTWD
SA1 TOKWRD ADDRESS OF SECOND LITERAL
SB1 X1-2 POINT TO FIRST LIT
EQ SEG310
*
* EXIT TO ADDLITS PUTS ARAYWD INTO TOKEN TABLE
* AND PUTS ARRAY NAME INTO DEFINED NAMES TABLE.
* EXIT TO SEG310 JUST DOES LATTER.
*
* /--- BLOCK SIZFIL 00 000 80/03/23 07.51
*
* SUBROUTINE TO GET SIZE INDEX IN X6
* TERMINATOR IS IN *LASTKEY* AND X1
* RETURN TERMINATOR KEYTYPE IN X2
* INDEX MUST BE + OR - 13BIT MAXIMUM
*
*
SIZFIL EQ *
MX7 0
MX6 59
SA6 VSKMODE SET -1...DONT EXPAND DEFINE
SA7 SIZ SET 0 FOR +, -0 FOR -
RJ =XINITLEX
SIZFIL2 RJ =XLEX GET SIZE ELEMENT
SA1 ADTYPE
SA2 OP
ZR X2,SIZFIL8 JUMP IF PURE NUMBER IN X1
SX2 X2-OPSUB
ZR X2,SIZFIL4 JUMP IF UNARY MINUS
SX2 X2+OPSUB-OPADD
ZR X2,SIZFIL2 IGNORE UNARY PLUS
SX2 X2+OPADD-OPDEFN
ZR X2,SIZFIL5 JUMP IF DEFINE
EQ BADFORM NO OTHER OPS ALLOWED
*
SIZFIL4 SA2 SIZ
BX7 -X2 TOGGLE SIGN
SA7 A2
EQ SIZFIL2
*
SIZFIL5 MX0 -XCODEAL
BX6 X0*X1
NZ X6,BADSIZ JUMP IF NOT SHORT LITERAL IN X1
*NOTE...NO USE TRYING LONGLITS, - NUMBERS ARE COMPILED..UGH
*
SIZFIL8 SA2 SIZ
BX6 X1-X2 COMPLEMENTS ADTYPE IF SIZ=-0
BX1 X6
AX1 59 SIGN
BX1 X6-X1 ABS VALUE
AX1 13 CHECK FOR 13BIT MAXIMUM SIZE
NZ X1,BADSIZ ERROR IF GREATER
SA1 LASTKEY EXIT WITH TERMINATOR IN X1
SA2 X1+KEYTYPE TERM. KEYTYPE IN X2
EQ SIZFIL AND INTEGER SIZE ELEMENT IN X6
*
*
NROW BSS 1
NCOL BSS 1
ROW1 BSS 1
COL1 BSS 1
DIMEN BSS 1
SIZ BSS 1
ATEMP BSS 1
RCPCHK DATA 2000040001B
SIGNED VFD 42/6LSIGNED,1/1,17/0 SPECIAL GETVAR FOR
VFD 42/1LS,1/1,17/0 COMPSYM CHECK
*
* /--- BLOCK UNITS 00 000 76/07/21 20.54
TITLE READ-IN FOR -UNITS- COMMAND
*
*
*
* -UNSREAD-
* READ-IN ROUTINE FOR -UNITS- COMMAND - ADDS TO THE
* DEFINED NAME TABLE AND TO THE TOTAL UNITS COUNT
* (DIMENSIONALITY COUNT)
*
*
UNSRD SA1 DSET MUST HAVE DEFINE SET
NG X1,NOSET
SA1 WORDPT
SA1 X1-1 BACK UP TO PREVIOUS CHARACTER
SA2 X1+KEYTYPE
SX1 X2-OPCOMMA SEE IF ENDED WITH COMMA
NZ X1,BADFORM
MX6 -1 SET MODE FOR -VSEEK- SEARCH
SA6 VSKMODE
SA6 ENDFLG MARK NOT END-OF-LINE YET
*
UNS100 CALL GETNAME,7 GET NAME OF NEXT *UNIT*
ZR X6,NAMERR
SA6 USNAM
SX1 X2-OPCOMMA CHECK FOR COMMA
ZR X1,UNS120
SX1 X2-EOL CHECK FOR END-OF-LINE
NZ X1,BADFORM
MX7 0 MARK END-OF-LINE ENCOUNTERED
SA7 ENDFLG
*
UNS120 RJ =XVSEEK SEE IF ALREADY DEFINED
SA1 ADTYPE
PL X1,DUPNAM EXIT IF DUPLICATE NAME
SA7 DEFNLOC SAVE ECS LOC TO INSERT NAME
CALL SYMCHK,USNAM
SA1 NDEFU GET NUMBER OF *UNITS* DEFINED
SX6 X1-NUMAX SEE IF TOO MANY *UNITS*
PL X6,UFULL
SX6 X1+1
SA6 A1
SX4 8 8=SHORT FLOATING LITERAL
LX4 XCODEAL
BX4 X4+X1 X4=GETVAR CODE
CALL ADDNAM,USNAM ADD TO DEFINE TABLES
SA1 ENDFLG
NZ X1,UNS100 CONTINUE IF NOT END-OF-LINE
EQ ENDSEG
*
*
ENDFLG BSS 1
*
K60 DATA 60.0
KVERT DATA 0LVERTICAL
KSIGN DATA 0LSIGNED
KS DATA 0LS
KE1 DATA 10LNO SET
KE2 DATA 10LBAD NAME
KE3 DATA 10LDUPLICATE
KE4 DATA 10LBAD VAR
KE5 DATA 10LBAD FORM
KE6 DATA 10LBAD COUNT
KE7 DATA 10LBAD SIZE
KE8 DATA 10LARRAY TYPE
KE9 DATA 10LMANY LITS
KE10 DATA 10LMANY NAMES
KE11 DATA 10LMANY UNITS
KE12 DATA 10LNOT YET IN
*
*
ENDOV
*
*
OVTABLE
*
*
END SEGMNT$