DEFLEX
* /--- FILE TYPE = E
* /--- BLOCK DEFNLEX 00 000 78/12/18 21.16
IDENT DEFLEX
***NOTE THERE IS ANOTHER IDENT VSEEK IN THIS FILE....
TITLE INTERPRETATION OF DEFINE
*
*
* -DEFNLEX-
* CALLED BY -VSEEK- WHEN A DEFINED NAME IS FIRST
* RECOGNIZED .. -DEFNLEX- IDENTIFIES THE TYPE OF
* DEFINE (PRIMITIVE,NORMAL OR FUNCTION) AND PASSES
* TO THE PROPER INTERPRETATION ROUTINE
*
*
CST
*
*
IFPLT PLATO
EXT WHATSIN
*
*CALL LEXTXT
*
IFPLT ENDIF
*
EXT CHARERR,BADPAR,DECERR,VARERR
EXT LOGERR,FORMERR,EQERR,OCTERR
EXT ALFERR,INDXERR,DEFERR,SEGERR,MATERR
EXT COMPERR,LNGERR,LITERR,TEMPERR
EXT ALLERR,ECSPRTY,TSTERR
EXT LEX,LEXADD,KEYTYPE
*
* /--- BLOCK DEFNLEX 00 000 78/12/18 21.17
TITLE DEFNLEX
*
*
ENTRY DEFNLEX
DEFNLEX ZERO UADTYPE,NUMAX ZERO *UADTYPE*
SA3 ADTYPE *GETVAR* CODE
NG X3,ERR6
MX0 60-XCODEAL
BX1 -X0*X3 MASK OFF ADDRESS
AX3 XCODEAL
MX7 -4 4 BIT MASK
BX2 -X7*X3 MASK OFF TYPE AND I/F BIT
SB1 X2
JP B1+*+1
*
* SEPARATE NORMAL / PRIMITIVE DEFINES
*
+ EQ ADDRDEF SHORT LITERAL
+ EQ LITDEF LONG LITERAL
+ EQ ADDRDEF STUDENT
+ EQ ADDRDEF COMMON
+ EQ NORMDEF NORMAL (OR FUNCTION) DEFINE
+ EQ SEGDEF SEGMENT
+ EQ ARAYDEF ARRAY/COMPLEX
+ EQ ERR6 IMPOSSIBLE CODE TYPE
*
+ EQ UNITDEF UNIT
+ EQ LITDEF LONG LITERAL
+ EQ ADDRDEF STUDENT
+ EQ ADDRDEF COMMON
+ EQ ERR6 IMPOSSIBLE CODE TYPE
+ EQ ERR6 IMPOSSIBLE CODE TYPE
+ EQ ERR6 IMPOSSIBLE CODE TYPE
+ EQ ERR6 IMPOSSIBLE CODE TYPE
*
*
* SEPARATE FUNCTION / NORMAL DEFINES
*
NORMDEF RJ SETDEF SET POINTERS TO DEFINE INFO
RJ GETDEF GET NUMBER OF ARGUMENTS
ZR X1,DEFINIT NORMAL IF NO ARGUMENTS
EQ FUNDEF
*
*
* /--- BLOCK PRIMITIVE 00 000 77/02/25 03.55
TITLE PROCESS PRIMITIVE DEFINE
*
*
* RETRIEVE LONG LITERAL
*
LITDEF BSS 0
RJ LITRAL PUT LITERAL IN X7
SA1 ADTYPE
BX6 X1
EQ ADDRDEF
*
*
* ROUTINE TO ADD LITERAL TO LIT TABLE
* RETURNS X1,X7 WITH LIT, X6 WITH ADDRESS
* DO NOT DESTROY X3 OR A0
*
* LITRAL SEEMS UNUSED OUTSIDE (BAS 1/26/77)
* ENTRY LITRAL USED IN DEFINE/SEGMENT/ARRAY
*
LITRAL EQ *
SA2 ATOKEN ADDRESS OF TOKEN TABLE
IX0 X1+X2 ECS ADDRESS OF LITERAL
SX2 A0 SAVE -A0-
SA0 IWK
+ RE 1 READ LITERAL FROM ECS
RJ ECSPRTY
SA0 X2 RESTORE -A0-
BX6 X1 (X6) = ADDRESS OF LITERAL
SA1 IWK LOAD LITERAL
BX7 X1 (X7) = LITERAL
EQ LITRAL
*
* /--- BLOCK SEGMENT 00 000 78/12/12 23.17
*
* PROCESS SEGMENT DEFINE
*
SEGDEF BSS 0
RJ LITRAL (X7) = SEGMENT WORD, (X6) =ADDR
SA7 SEGLIT SAVE LITERAL
SX1 5
LX1 XCODEAL TYPE 5 = SEGMENT
BX6 X6+X1
SA6 SEGADD SAVE
SX6 OPSEG
SA6 OP ALSO RETURN OP CODE
LX7 3
NG X7,SEGD3 IF SEGMENTF
SEGD2 SA1 LASTKEY
NG X1,ERR7
SA1 X1+KEYTYPE
SX2 X1-OP( MUST BE INDEXED
NZ X2,ERR7
SEGD3 SA1 LEXADD MUST SAVE BRANCH ADDRESS
BX6 X1
SA6 LEADDSV
SX6 SEGD1 LEX WILL BRANCH TO -SEGD1-
SA6 LEXADD
EQ LEX RETURN
*
SEGD1 SA1 SEGADD RESTORE *ADTYPE*
SA2 SEGLIT FETCH LITERAL
BX6 X1
LX2 3
NG X2,SEGF1 IF SEGMENTF
SA1 LEADDSV
BX7 X1 RESTORE -LEXADD-
SA7 LEXADD
EQ ADRET RETURN
*
* PROCESS SEGMENTF
*
SEGF1 SX7 SEGF2 SET NEXT RETURN POINT
SA7 LEXADD
EQ ADRET
*
SEGF2 SX6 OP( RETURN A (
SX7 SEGF3
SA7 LEXADD SET NEXT RETURN POINT
EQ OPRET
*
SEGF3 SX6 1 RETURN A *1* AS A SHORT LITERAL
SX7 SEGF4
SA7 LEXADD SET NEXT RETURN POINT
EQ ADRET
*
SEGF4 SX6 OP) RETURN A )
SA1 LEADDSV RESTORE *LEXAD*
BX7 X1
SA7 LEXADD
SA6 OP SAVE OPERATOR TYPE
MX6 0
SA6 ADTYPE CLEAR ADDRESS TYPE
EQ IMMULT CHECK FOR IMPLIED MULTIPLY
* /--- BLOCK ARRAY 00 000 78/12/12 00.30
*
* PROCESS ARRAY/COMPLEX DEFINE
*
ARAYDEF SA0 X1 SAVE LITERAL ADDRESS
RJ LITRAL (X7) = LITERAL, (X6) = ADDRESS
SX4 6 6=GETVARTYPE FOR ARRAY/COMPLEX
LX4 XCODEAL
BX6 X6+X4 MERGE CODE AND LITERAL ADDRESS
SA6 SEGADD SAVE FOR NEXT LEX PASS
LX1 6 ISOLATE DIMENSIONS
MX2 58
BX1 -X2*X1
BX6 X6-X6 CLEAR SEGLIT FOR RE-ENTRY
SA6 SEGLIT
SX6 OPSCAL MARK AS SCALAR
ZR X1,ARAYD0 JUMP IF SCALAR
SX1 X1-2
SX6 OPMAT MARK AS MATRIX
ZR X1,ARAYD0 JUMP IF MATRIX
PL X1,MATERR NO 3-D ALLOWED YET
SX6 OPVEC IS VECTOR
ARAYD0 SA6 OP RETURN PROPER ARRAY OPCODE
LX7 4
MX0 58
BX0 -X0*X7
ZR X0,SEGD3 JUMP IF NO ARAYWD2,SETUP RETURN
SX1 A0+1 GET DEFLIT ADDR OF 2D LITERAL
RJ LITRAL (X7) = SECOND 2D DESCRIPTOR WD
EQ SEGD3 SETUP RETURN FROM -LEX-J
*
* /--- BLOCK PRIMITIVE 00 000 78/12/18 21.18
*
* PROCESS UNIT (DIMENSION) DEFINE
*
UNITDEF RJ UNITD PROCESS UNIT DEFINE
EQ ADDRDEF
*
*
UNITD EQ *
SA1 UDMODE SEE IF SHOULD INTERPRET UNIT
ZR X1,UNITD
SA1 NLITS
SX6 X1+1 INCREMENT COUNT
SX2 X1-LITL CHECK FOR BUFFER FULL
PL X2,LITERR NO ROOM FOR NEW LIT
SA6 A1
SA2 =1.0 VALUE OF UNIT IS 1.0
BX7 X2
SA7 X6+LITS STORE LITERAL
MX6 -1 MARK UNIT ENCOUNTERED
SA6 UAD
ZERO UADTYPE,NUMAX PRE-CLEAR *UADTYPE*
SA1 NUNITS
PL X1,UD100 JUMP IF PROCESSING UNITS
SX2 X1+2
ZR X2,UD200 EXIT IF UNITS NOT DESIRED
SA2 NDEFU
BX6 X2 SET *NUNITS* = UNITS DEFINED
SA6 A1
ZERO UADS,UADSMAX PRE-CLEAR *UADS* BUFFER
*
UD100 MX0 -XCODEAL MASK FOR ADDRESS PORTION
SA1 ADTYPE
BX1 -X0*X1 MASK OFF INDEX IN *UADTYPE*
SA7 X1+UADTYPE STORE 1.0 IN *UADTYPE*
*
UD200 SX6 411B LONG FLOATING LIT IN *LITS*
LX6 XCODEAL CODE FOR LONG FLOATING LITERAL
SA3 NLITS
BX6 X3+X6 ATTACH INDEX IN *LITS*
SA6 ADTYPE
EQ UNITD
*
* /--- BLOCK PRIMITIVE 00 000 74/03/06 17.52
*
ADDRDEF MX6 0
SA6 OP CLEAR OP FOR ADDRESS
IMMULT SA1 LASTKEY
NG X1,LEX JUMP IF LASTKEY NOT AVAILABLE
SX2 X1-1R( CHECK FOR IMPLIED MULT
ZR X2,MULTY GO INSERT A *
SX2 X1-KLBRACK
ZR X2,MULTY
SA2 X1+KEYTYPE
ZR X2,MULTY JUMP IF NUMBER
NG X2,MULTY JUMP IF ALPHA
EQ LEX RETURN
*
MULTY SA1 LEXADD MUST SAVE BRANCH ADDRESS
BX6 X1
SA6 LEADDSV
SX6 MULT LEX WILL BRANCH TO -MULT-
SA6 LEXADD
EQ LEX RETURN
*
MULT SA1 LEADDSV
BX6 X1 RESTORE -LEXADD-
SA6 LEXADD
SX6 OPMULT RETURN A *
EQ OPRET
*
*
* /--- BLOCK EXPRESSION 00 000 74/02/24 04.45
TITLE PROCESS NORMAL DEFINE
*
*
* BEGIN PROCESSING OF NORMAL DEFINE
*
DEFINIT SA1 LEXADD MUST SAVE BRANCH ADDRESS
BX6 X1
SA6 OLDADD
SX6 DEFLEX LEX WILL CALL DEFLEX
SA6 LEXADD
MX6 1
LX6 XCODEAL FORM MASK FOR *UNIT* BIT
SA1 ADTYPE
BX1 X6*X1 SEE IF THIS DEFINE INVOLVES
ZR X1,DEFI10 A UNIT (DIMENSION)
MX6 -1
SA6 UAD FLAG *UNIT* ENCOUNTERED
*
DEFI10 SX6 OP( START WITH LEFT PAREN
EQ OPRET
*
* /--- BLOCK EXPRESSION 00 000 78/12/18 21.18
*
* -DEFLEX- PROCESS NORMAL DEFINE
*
DEFLEX RJ GETDEF GET NEXT ITEM OF DEFN
NG X1,DFLADD JUMP IF ADDRESS
SX2 X1-EOL
ZR X2,EXIT JUMP IF END OF LINE
BX6 X1
*
OPRET SA6 OP RETURN OPCODE
MX6 0 CLEAR *ADTYPE*
SA6 ADTYPE
EQ LEX RETURN TO *LEX*
*
DFLADD ZERO UADTYPE,NUMAX ZERO *UADTYPE*
MX0 60-XCODEL+1
BX6 -X0*X1 CLEAR EXTENDED SIGN
MX0 -4
AX1 XCODEAL POSITION I/F BIT AND TYPE
BX1 -X0*X1
SB1 X1
JP B1+*+1 JUMP BY TYPE CODE
*
+ EQ ADRET SHORT LITERAL
+ EQ DLLIT LONG LITERAL
+ EQ ADRET STUDENT
+ EQ ADRET COMMON
+ EQ ERR6 IMPOSSIBLE
+ EQ SEGAD SEGMENT
+ EQ ARAYAD ARRAY
+ EQ ERR6 IMPOSSIBLE
*
+ EQ UNITAD UNIT
+ EQ DLLIT LONG LITERAL
+ EQ ADRET STUDENT
+ EQ ADRET COMMON
+ EQ ERR6 IMPOSSIBLE
*+ EQ SEGAD SEGMENT REPLACED BY FOLLOWING LINE - BAS
+ EQ ERR6 IMPOSSIBLE
+ EQ ERR6 IMPOSSIBLE
+ EQ ERR6 IMPOSSIBLE
*
* /--- BLOCK EXPRESSION 00 000 78/12/12 23.17
*
DLLIT BSS 0
MX0 -XCODEAL
BX1 -X0*X6 FORMER ADDRESS
BX7 X1 (X7) = NEW ADDR SAME AS OLD
SA2 ATOKEN POINTER TO TOKEN BUFFER
IX0 X1+X2
SA0 IWK
+ RE 1 READ LITERAL FROM ECS TABLE
RJ ECSPRTY
SA1 A0 LOAD LITERAL
MX0 -XCODEAL
BX2 X0*X6 THROW AWAY ADDRESS
BX6 X2+X7 CODE + ADDRESS
*
ADRET SA6 ADTYPE RETURN *GETVAR* CODE
ADRET1 MX6 0
SA6 OP CLEAR *OP* FOR ADDRESS
EQ LEX
*
SEGAD MX0 -XCODEAL MASK OFF ADDRESS
BX1 -X0*X6
RJ LITRAL (X7) = SEG DESCRIPTOR,(X6)=ADDR
SX7 5
LX7 XCODEAL TYPE 5 = SEGMENT
BX6 X6+X7
EQ ADRET
*
ARAYAD MX0 -XCODEAL MASK OFF ADDRESS
BX1 -X0*X6
SA0 X1 SAVE LIT ADDRESS
RJ LITRAL GET LITERAL ARRAY WORD
LX7 4 CHECK FOR NEEDING 2ND INFO WD
MX0 58
BX0 -X0*X7
ZR X0,ARAYAD1 ONLY ONE INFO WORD
SX1 A0+1
RJ LITRAL GET 2ND WORD
SX6 X6-1 BACK UP NLITS POINTER
ARAYAD1 SX7 6
LX7 XCODEAL TYPE 6 = ARRAY
BX6 X6+X7
EQ ADRET
*
UNITAD SA6 ADTYPE PRE-SET *ADTYPE*
RJ UNITD PROCESS *UNIT*
EQ ADRET1
*
EXIT SA2 LASTKEY
NG X2,EXIT2 JUMP IF LASTKEY NOT AVAILABLE
SX1 X2-1R( CHECK FOR LEFT PARENS
ZR X1,MULTYD THEN NEED *
SX1 X2-KLBRACK CHECK FOR LEFT BRACKET
ZR X1,MULTYD
SA1 X2+KEYTYPE
NG X1,MULTYD NEED * IF ALPHA
ZR X1,MULTYD NEED * IF NUMBER
*
EXIT2 SA1 OLDADD
BX6 X1 RESTORE *LEX*
SA6 LEXADD
SX6 OP) END WITH RIGHT PAREN
EQ OPRET
*
MULTYD SX6 MULTD INSERT IMPLICIT *
SA6 LEXADD
SX6 OP) END DEFINE WITH RIGHT PAREN
EQ OPRET
*
MULTD SA1 OLDADD
BX6 X1 RESTORE
SA6 LEXADD
SX6 OPMULT RETURN A *
EQ OPRET
*
*
* /--- BLOCK FUNDEF 00 000 77/01/30 11.52
TITLE PROCESS FUNCTION DEFINE
*
*
* FUNCTION DEFINES ARE HANDLED BY A TWO PASS
* PROCEEDURE - IN THE FIRST PASS -LEX- IS DRIVEN
* TO CONVERT THE RAW SOURCE OF THE FUNCTION
* ARGUMENT(S) TO TOKENS - THE SECOND PASS RETURNS
* THE TOKENS OF THE FUNCTION THROUGH -LEX- AND
* INSERTS THE ARGUMENT TOKENS WHEN NEEDED
*
*
* -FUNDEF-
* BEGIN PROCESSING OF FUNCTION DEFINES
*
FUNDEF SA1 LEX SAVE RJ ADDRESS OF LEX
BX6 X1
SA6 LEXSAV
*
PLATO
FBFL SET MAXLEV*LEVLTH
1 ERRPL FBFL-LV0LTH+1 BUFFER TOO SMALL
MX7 -1 LEVEL 0 OVERLAY BUFFER USED
* (LEVEL 1 OVERLAY CONTAINS ANSV, ETC., OR COMPUTE)
SA7 WHATSIN+0
****
SA1 65B ADDRESS OF BLANK COMMON
SX7 X1+LV0ADD+1 ADDRESS FOR BUFFERS
ENDIF
*
CONDEN
SX7 DEFNBUF
ENDIF
*
SA7 DEFNCM SAVE ADDRESS OF BUFFER
SX6 1
SA6 VSKMODE DONT EXPAND FUNCTION DEFINES
MX6 0
SA6 UDMODE NO INTERPRETATION OF *UNITS*
SA6 LEXADD SET LEX TO NORMAL MODE
SA6 DEPTH CLEAR NESTING LEVEL
SA1 DEFNCM
BX7 X1 ADD OF WORK AREA IN UNIT BUFF
SA7 FUNLST FIRST FUNCTION ADDRESS
SB1 B0
SB2 MAXLEV
*
PRECLR SA7 B1+LOCS INITIALIZE POINTERS
SX7 X7+LEVLTH
SA7 B1+LIMS SET END TEST FOR LEVEL
SB1 B1+1
LT B1,B2,PRECLR
SB1 B0 INITIALIZE DEPTH
RJ PREFUN INITIALIZE FIRST FUNCTION
SX1 EOL
RJ PREPUT ADD AN END OF LINE CODE
SX6 1
SA6 DEPTH ADVANCE DEPTH FOR ARGS
*
*
* -PREPASS-
* PERFORM LEXICAL ANALYSIS OF FUNCTION ARGUMENTS
* ANALYSES NESTING OF FUNCTIONS
*
PREPASS RJ LEX GET NEXT LEXICAL ITEM
SA1 DEPTH FUNCTION NESTING LEVEL
SB1 X1
SA1 OP
ZR X1,PREADD JUMP IF ADDRESS
SX2 X1-OPCOMMA CHECK FOR COMMA
ZR X2,PRECOMA
SX2 X1-OPDEFN CHECK FOR FUNCTION DEFINE
ZR X2,PRENEST
SX2 X1-EOL CHECK FOR END OF LINE
ZR X2,ERR3
* /--- BLOCK PREADD 00 000 74/09/02 11.50
RJ PREPUT STORE OP CODE
SX2 X1-OP( CHECK FOR LEFT PAREN
ZR X2,PRELP
SX2 X1-OP) CHECK FOR RIGHT PAREN
ZR X2,PRERP
EQ PREPASS
*
PREADD SA1 ADTYPE GETVAR CODE
NG X1,PREARG
MX2 1
BX1 X1+X2 SET SIGN BIT FOR ADDRESS
RJ PREPUT STORE CODE
EQ PREPASS
*
PREARG SX1 OPARG UNDEFINED NAME ASSUMED ARG
RJ PREPUT
SX1 -1
RJ PREPUT
SA1 AD STORE ARGUMENT NAME
RJ PREPUT
EQ PREPASS
*
PRECOMA SX7 -1 KILL *LASTKEY*
SA7 LASTKEY
SX1 OP) INSERT PAREN
RJ PREPUT
SX1 EOL INSERT AN END OF LINE CODE
RJ PREPUT
SA1 B1+NUMARGS-1 CURRENT ARGUMENT COUNT
SX2 X1-MAXARG SEE IF TOO MANY ARGS
PL X2,ERR1
SX6 X1+1 INCREASE COUNT
SA6 A1
SA2 B1+LOCS ADDRESS OF ARGUMENT
SA1 B1+FUNLST-1 ADDRESS OF ARGUMENT TABLE
IX1 X1+X6 INDEX INTO TABLE BY ARG NUM
BX6 X2
SA6 X1 STORE ADDRESS OF ARGUMENT
SX1 OP(
RJ PREPUT START NEXT ARG WITH L PAREN
EQ PREPASS
*
PRENEST SX1 B1+1-MAXLEV
PL X1,ERR2 TOO DEEP IN FUNCTIONS
SA1 B1+LOCS ADDRESS OF FUNCTION OP CODE
BX6 X1
SA6 B1+FUNLST SAVE ADDR OF FUNCTION
RJ PREFUN INITIALIZE ARGUMENT INFO
SX6 B1+1
SA6 DEPTH ONE LEVEL DEEPER
EQ PREPASS
*
PREXPN1 MX6 0
SA6 LEXADD RESTORE LEX TO NORMAL
SX6 1R(
SA6 LASTKEY RESTORE -LASTKEY-
SA1 DEPTH
SB1 X1 PICK UP NESTING DEPTH
*
PREFUN EQ *
SA1 LASTKEY
SA2 X1+KEYTYPE MUST BE LEFT PAREN
SX2 X2-OP(
NZ X2,ERR3
SX6 -1 KILL -LASTKEY-
SA6 A1
SX1 OPDEFN STORE OP CODE FOR DEFINE
RJ PREPUT
SA1 B1+LOCS+1
RJ PREPUT STORE ADDR OF FIRST ARG
SA1 B1+LOCS
SX6 X1+MAXARG-1 RESERVE SPACE FOR ARG TABLE
* /--- BLOCK PREXPAN 00 000 74/09/02 21.16
SA6 A1
MX6 0 INITIALIZE PAREN COUNT
SA6 B1+PARENS
SX6 1 INITIALIZE ARGUMENT COUNT
SA6 B1+NUMARGS
SX1 OP( START WITH L PAREN
RJ PREPUT
SX6 PREXPN1 RETURN TO -PREXPN1-
SA6 OLDADD
SX6 DEFLEX
SA6 LEXADD LEX WILL CALL -DEFLEX-
SA1 ADTYPE
RJ SETDEF SET POINTERS TO THIS FUNCTION
RJ GETDEF NUMBER OF ARGUMENTS
SA2 DEPTH
BX6 X1
SA6 X2+DEFARGS STORE EXPECTED ARGUMENT COUNT
*
PREXPAN RJ LEX GET NEXT ITEM OF FUNCTION
SA1 DEPTH FUNCTION NESTING LEVEL
SB1 X1
SA1 OP SEE IF OP OR ADD
SX2 X1-OPARG
ZR X2,PREXARG JUMP IF ARGUMENT OF FUNCTION
NZ X1,PREXPN
SA1 ADTYPE
MX2 1 SET SIGN BIT FOR ADDRESS
BX1 X1+X2
*
PREXPN RJ PREPUT
EQ PREXPAN
*
PREXARG RJ PREPUT STORE OP CODE FOR ARGUMENT
RJ GETDEF GET ARGUMENT NUMBER
SA2 DEPTH
SB1 X2 RESET B1
RJ PREPUT
EQ PREXPAN
*
PRELP SA1 B1+PARENS-1 GET CURRENT PAREN COUNT
SX6 X1+1
SA6 A1 INCREMENT FOR L PAREN
EQ PREPASS
*
PRERP SA1 B1+PARENS-1 GET PAREN COUNT
SX6 X1-1 DECREMENT FOR R PAREN
NG X6,ERR3 UNBALANCED PARENS
SA6 A1
NZ X6,PREPASS NOT YET BALANCED
SX1 EOL
RJ PREPUT INSERT AN END OF LINE CODE
SA2 B1+NUMARGS-1 ARGUMENT COUNT
SA3 B1+DEFARGS-1 DEFINE READIN ARGUMENT COUNT
BX3 X3-X2
NZ X3,ERR4 UNREFERENCED OR UNDEFINED ARG
SX6 B1-1
SA6 DEPTH BACK OUT ONE LEVEL
ZR X6,ENDPASS ALL DONE IF NO LONGER NESTED
EQ PREPASS
*
ENDPASS SA1 LEXSAV RESTORE RJ ADDRESS
BX6 X1
SA6 LEX
* GENREAD IN COMPILE DECREMENTS NLITS IF A LITERAL IS
* AT THE TOP OF THE LITS STACK. SO WE MUST INCREMENT NLITS
* TO PREVENT CLOBBERING AN ARGUMENT LIT USED MORE THAN ONCE
SA1 NLITS
SX6 X1+1
SA6 A1
SA1 DEFNCM GET ADDRESS OF TOKEN BUFFER
SX6 X1+1 INITIALIZE PROCESSING ADDRESS
SA6 LOCS
MX6 0
SA6 VSKMODE RESET -VSEEK- MODE
SX6 1
SA6 UDMODE RESET *UNITS* MODE
*
*
* /--- BLOCK FUNLEX 00 000 78/12/18 21.18
* -FUNLEX-
* RETURNS RESULTS OF LEXICAL ANALYSIS OF FUNCTION AND AGUMENTS
*
FUNLEX SA1 DEPTH CURRENT NESTING DEPTH
SA2 X1+LOCS ADDRESS OF FUNCTION
SX6 X2-1
SA6 X1+FUNLST ADD TO FUNCTION LIST
SX6 X2+MAXARG
SA6 A2 STARTING ADD OF TOKENS
SX6 FUNLX
SA6 LEXADD LEX WILL CALL -FUNLX-
*
*
* -FUNLX-
* CALLED BY LEX TO GET NEXT ITEM OF FUNCTION
*
FUNLX RJ GETFUN GET NEXT ITEM OF FUNCTION
NG X1,FUNADD JUMP IF ADDRESS
SX2 X1-OPARG
ZR X2,FUNARG JUMP IF ARGUMENT
SX2 X1-OPDEFN
ZR X2,FUNLEX JUMP IF NESTED FUNCTION
SX2 X1-EOL
ZR X2,EXITF DONE IF END OF LINE
BX6 X1
EQ OPRET RETURN OP CODE
*
FUNADD MX0 60-XCODEL+1
MX6 59 SAVE ONLY GETVAR AND *LITS* BIT
LX6 LITSHFT
BX0 X0*X6
BX6 -X0*X1 CLEAR UPPER BITS
SA6 ADTYPE
MX0 -4 MASK FOR I/F BIT AND TYPE
AX6 XCODEAL
BX0 -X0*X6 MASK OFF TYPE CODE
SX0 X0-10B
NZ X0,FUNADD1 JUMP IF NOT *UNIT*
CALL UNITD PROCESS *UNIT*
EQ ADRET1
*
FUNADD1 ZERO UADTYPE,NUMAX ZERO *UADTYPE*
EQ ADRET1
*
* /--- BLOCK FUNARG 00 000 76/12/09 16.56
*
FUNARG RJ GETFUN GET ARGUMENT NUMBER
NG X1,FUNARG1 JUMP IF IN -DEFINE- COMMAND
SA2 DEPTH CURRENT NESTING LEVEL
SA3 X2+FUNLST ADDRESS OF FUNCTION INFO
SB1 X3+1
SA3 X1+B1 ADDRESS OF ARGUMENT
BX6 X3
SA6 X2+LOCS+1 SET PROCESSING ADDRESS
SX6 X2+1
SA6 A2 ONE LEVEL DEEPER
EQ FUNLX
*
FUNARG1 RJ GETFUN
BX6 X1 GET UNRECOGNIZED NAME
SA6 AD
SX6 -1 NEGATIVE = NOT FOUND
EQ ADRET
*
EXITF SA1 DEPTH SEE HOW DEEP IN ARGS
NZ X1,EXIT1
MX6 0 RESTORE LEX TO NORMAL
SA6 LEXADD
EQ LEX+1 CONTINUE PROCESSING
*
EXIT1 SX6 X1-1 BACK UP ONE LEVEL
SA6 A1
EQ FUNLX CONTINUE PROCESSING
*
* /--- BLOCK ERR 00 000 77/08/07 19.37
PLATO
*
ERR1 COMPERR 671,64 (MORE THAN 6 ARGS)
*
ERR2 COMPERR 672,17 TOO DEEP IN FUNCTION ARGUMENTS
*
ERR3 EQ BADPAR
*
ERR4 COMPERR 673,18 WRONG NUMBER OF FUNCTION ARGS
*
ERR5 COMPERR 674,64 TOO MANY FUNCTION TOKENS
*
ERR6 COMPERR 675,64 DEFINE (SYSTEM) FAILURE
*
ERR7 EQ ERR4 NO INDEX IN SEGMENT REF.
ENDIF
*
CONDEN
ERR1 SB1 35 MANY ARGS
EQ =XERR
*
ERR2 SB1 36 TOO DEEP
EQ =XERR
*
ERR3 EQ BADPAR
*
ERR4 SB1 37 IMPROPER NUMBER OF FUNCT. ARGS.
EQ =XERR
*
ERR5 SB1 38 BUFF FULL
EQ =XERR
*
ERR6 SB1 39 DEFN FAIL
EQ =XERR
*
ERR7 SB1 40 NO INDEX
EQ =XERR
ENDIF
* /--- BLOCK PREPUT 00 000 75/05/28 21.17
TITLE DEFINE INFO STORAGE / RETRIEVAL
*
*
PREPUT EQ *
SA2 B1+LOCS POINTER TO NEXT FREE WORD
SA3 B1+LIMS END TEST
SX6 X2+1 ADVANCE POINTER
IX3 X6-X3
PL X3,ERR5 TOO MANY TOKENS
SA6 A2 STORE UPDATED POINTER
BX6 X1
SA6 X2 STORE THE TOKEN
EQ PREPUT
*
GETFUN EQ *
SA1 DEPTH CURRENT NESTING LEVEL
SA1 X1+LOCS BUFFER POSITION
SX6 X1+1 ADVANCE POINTER
SA6 A1
SA1 X1 GET NEXT WORD
EQ GETFUN
*
* /--- BLOCK SETDEF 00 000 75/02/10 21.31
*
*
ENTRY SETDEF
SETDEF EQ *
MX6 60-XCODEAL+1
BX6 -X6*X1 MASK OFF ADDRESS PORTION
SA1 ATOKEN POINTER TO ECS TOKEN BUFFER
IX6 X1+X6 FORM ABSOLUTE ADDRESS
SA6 TWORD SET WORD POINTER
SX6 60
SA6 TSHIFT SET SHIFT COUNT
EQ SETDEF
*
*
*
ENTRY GETDEF
GETDEF EQ *
SA1 TSHIFT GET SHIFT COUNT
SA2 TWORD POINTER TO CURRENT WORD
BX0 X2
SB1 X1-12
PL B1,GETDEF1 JUMP IF DONT NEED NEW WORD
SX6 1
IX0 X0+X6 ADVANCE TO NEXT WORD
SB1 48 INITIALIZE SHIFT COUNT
*
GETDEF1 SA0 TWW
+ RE 1 READ CURRENT TOKEN WORD
RJ ECSPRTY
SA3 A0 LOAD TOKEN WORD
AX1 X3,B1 POSITION BYTE
LX1 48
AX1 48 EXTEND BIT 12
PL X1,GETDEF3 JUMP IF ONLY ONE BYTE
*
SB1 B1-12 COMPUTE SHIFT COUNT
PL B1,GETDEF2 JUMP IF DONT NEED NEW WORD
*
SX6 1
IX0 X0+X6 ADVANCE TO NEXT WORD
+ RE 1 READ NEXT TOKEN WORD
RJ ECSPRTY
SA3 A0 LOAD NEW WORD
SB1 48 REINTIALIZE SHIFT COUNT
*
GETDEF2 AX2 X3,B1 POSITION SECOND BYTE
LX1 12 POSITION FIRST BYTE
MX3 -12 ISOLATE BYTES FOR BOOL. +
BX1 X3*X1 HIGH ORDER WITH EXTENDED SIGN
BX2 -X3*X2 LOW ORDER
BX1 X1+X2 FORM COMPLETE ADTYPE
BX3 X1 SAVE ADTYPE
LX3 60-LITSHF1 22ND BIT IN SIGN POSITION
PL X3,GETDEF3 IF NOT IMMEDIATE LITERAL, EXIT
*
SX6 1
LX3 1 MOVE BIT TO 2**0TH POSITION
BX1 X3-X6 TURN *LITS* FLAG OFF
LX1 LITSHFT RESTORE SHIFT POSITION
IX0 X0+X6 POINT TO NEXT WORD
SB1 B0 INDICATE NO BITS AVAILABLE HERE
*
GETDEF3 SX6 B1 STORE CURRENT SHIFT COUNT
SA6 TSHIFT
BX6 X0 STORE CURRENT WORD ADDRESS
SA6 A2
EQ GETDEF
* /--- BLOCK FINDSET 00 000 75/02/11 03.55
*
*
*
* -FINDSET-
* SEARCHES THE DEFN GROUP LIST FOR THE NAME IN X6
* B1 IS RETURNED WITH THE INDEX OF THE NAME IN THE
* GROUP TABLES OR -1 IF THE NAME WAS NOT FOUND
*
ENTRY FINDSET
FINDSET EQ *
SB1 MAXSET-1 LENGTH TO SEARCH
*
FINDS1 SA1 B1+SETNAMS GET NEXT GROUP NAME
BX1 X1-X6 SEE IF MATCHES
ZR X1,FINDSET FOUND A MATCH
SB1 B1-1
PL B1,FINDS1 KEEP LOOKING / EXIT
EQ FINDSET
*
CONDEN
*
* -GETSET-
* READS FROM ECS THE DEFINE SET INDICATED BY
* THE INDEX CONTAINED IN B1
*
* /--- BLOCK GETSET 00 000 79/03/06 23.04
*
* -GETSET -
* MOVE OPEN SPACE BETWEEN TOKENS AND NAMES
* OF DSET (B1) AND MAKE DSET READY FOR PROCESSING
*
* ON ENTRY - (*DSET*) = CURRENTLY OPEN SET
* (B1) = SET TO OPEN
* ON EXIT - (*DSET*) = NEW OPEN SET
* *NAMADDS*/*TOKADDS* UPDATED
* *SETSET* EXECUTED
*
ENTRY GETSET
GETSET EQ *
SA1 DSET CURRENT DSET
SB2 X1 (B2) = OLD DSET
NG B2,OPNS10 IF NULL SET WAS OPEN
*
RJ RTOKNAM RETURN ODSET TOK/NAM PARMS
OPNS10 BSS 0
SX6 B1 (B1) BECOMES
SA6 DSET CURRENT DSET
EQ B1,B2,OPN30 IF SAME SET, ALREADY OPEN
*
GT B1,B2,OPN10 IF MV OPEN SPACE TO HIGHER ADDR
*
* MOVE OPEN SPACE TO LOWER ADDR
SA1 NAMADDS+B1 START OF MOVE***
SA2 TOKADDS+B2 OLD TOKEN ADDR
SA3 TOKLENS+B2 OLD TOKEN LEN
IX3 X3+X2 END ADDR OF MOVE +1
IX3 X3-X1 LEN OF MOVE***
SA2 NAMADDS+B2 END OF DESTINATION OF MOVE + 1
IX2 X2-X3 DESTINATION OF MOVE***
SB3 B1 DSET INDEX
SB4 B2 END DSET
RJ UPDNT UPDATE *NAMADDS*/*TOKADDS*
EQ OPN20
*
OPN10 BSS 0 MOVE OPEN SPACE TO HIGHER ADDR
SA1 NAMADDS+B2 START LOC OF MOVE***
SA2 TOKADDS+B2 TOKEN ADDR OF OLD SET
SA3 TOKLENS+B2 TOKEN LENGTH OF OLD SET
IX2 X2+X3 DESTINATION OF MOVE***
SA3 TOKADDS+B1 ADDR OF NEW DSET TOKENS
SA4 TOKLENS+B1 LENGTH OF NEW DSET TOKENS
IX3 X3+X4 END LOC OF MOVE +1
IX3 X3-X1 LENGTH OF MOVE***
SB3 B2 (B3) = DSET INDEX
SB4 B1 (B4) = END DSET
RJ UPDNT UPDATE *NAMADDS*/*TOKADDS*
*
OPN20 BSS 0 OPEN NEW/CLOSE OLD
SA0 VARS MOVE BUFFER LOC
SB1 VARLONG MOVE BUFFER LEN
RJ =XMVECS DO THE MOVE
OPN30 RJ SETSET SET UP THE DSET IN CM
EQ GETSET
*
* /--- BLOCK RTOKNAM 00 000 79/03/06 22.28
*
* -RTOKNAM-
* RETURN LOCAL TOKEN/NAME PARAMETERS
*
* ON ENTRY - *DSET* = DEFINE SET TO RETURN PARMS TO
* USES A/X1, B2, A/X6
*
ENTRY RTOKNAM
RTOKNAM EQ *
SA1 DSET
SB2 X1 (B2) = *DSET*
SA1 ATOKEN UPDATE *TOKADDS*
BX6 X1
SA6 TOKADDS+B2
SA1 AVAR UPDATE *NAMADDS*
BX6 X1
SA6 NAMADDS+B2
SA1 TOKWRD UPDATE *TOKLENS*
BX6 X1
SA6 TOKLENS+B2
SA1 NDEFN UPDATE *NAMLENS*
BX6 X1
SA6 NAMLENS+B2
SA1 NDEFU UPDATE *UNTLENS*
BX6 X1
SA6 UNTLENS+B2
EQ RTOKNAM
*
* -UPDTN-
* UPDATE *TOKADDS* AND *NAMADDS*
* FOR ALL BUFFERS MOVED
*
* ON ENTRY - (B3) = SET TO BEGIN AT
* (B4) = SET TO QUIT AT
* (X1) = START OF MOVE, (X2) = DESTINATION OF MOVE
*
* MUST PRESERVE X1-3
*
ENTRY UPDNT
UPDNT EQ *
IX4 X2-X1 (X4) = DISPLACEMENT OF MOVE
UNT10 BSS 0 UPDATE *TOKADDS*/*NAMADDS*
SA5 NAMADDS+B3 UPDATE *NAMADDS*
IX6 X5+X4
SA6 A5
SB3 B3+1 POINT TO NEXT DSET TO UPDATE
SA5 TOKADDS+B3 UPDATE *TOKADDS*
IX6 X5+X4
SA6 A5
NE B3,B4,UNT10 IF NOT ALL NAM/TOK ADDRS DONE
*
EQ UPDNT
* /--- BLOCK SETSET 00 000 79/02/28 11.05
*
* -SETSET-
* SET UP LOCAL PARAMETERS FOR DEFINE SET PROCESSING
*
* ON ENTRY - *DSET* ASSUMED TO BE OPEN
* ON EXIT - *ATOKEN*, *TOKWRD*, *AVAR*
* *NDEFN*, *NDEFU*
* SET
* *GPGTBL* AND *READNM* EXECUTED
*
ENTRY SETSET
SETSET EQ *
SA1 DSET
SB1 X1
SA1 NAMLENS+B1
BX6 X1
SA6 NDEFN INITIALIZE NUMBER OF DEFNS
SA1 TOKLENS+B1
BX6 X1
SA6 TOKWRD INITIALIZE NUMBER OF TOKENS
SA1 UNTLENS+B1
BX6 X1
SA6 NDEFU INITIALIZE NUMBER OF DEFD UNITS
SA1 TOKADDS+B1
BX6 X1
SA6 ATOKEN INITIALIZE ADDRESS OF TOKBUF
SA1 NAMADDS+B1
BX6 X1
SA6 AVAR INITIALIZE ADDRESS OF DEFNS
RJ GPGTBL UPDATE *PGTBL*
RJ READNM READ IN PAGE1
EQ SETSET
*
* /--- BLOCK GPGTBL 00 000 79/02/20 11.30
*
* -GPGTBL-
* PUT CONTENTS OF LAST NAME IN EACH PAGE INTO
* *PGTBL*
*
* ON ENTRY - *SETSET* DATA ASSUMED INTACT
*
ENTRY GPGTBL
GPGTBL EQ *
SA0 PGTBL
SB2 VARLONG
SA1 NDEFN NUMBER OF DEFINED NAMES
SA2 AVAR ECS ADDR OF NAME TABLE
IX1 X1+X2 ADDRESS OF LAST NAME + 1
BX0 X2 INDEX INTO NAME TABLE
SX3 B2-1 OFFSET TO LAST NAME IN PAGE1
IX0 X0+X3 ADDR OF LAST NAME OF PAGE1
SX3 B2 (X3) = VARLONG (PAGE INCREMENT)
GPT10 IX4 X0-X1
PL X4,GPGTBL IF NO MORE FULL PAGES
+ RE 1 READ UP LAST NAME IN PAGE
RJ ECSPRTY
SA0 A0+1 NEXT PAGE
IX0 X0+X3
EQ GPT10
*
* /--- BLOCK READNM 00 000 79/02/20 11.36
*
* -READNM-
* READS THE FIRST PAGE OF THE CURRENT DEFINE
* SET NAME TABLE INTO ECS
*
* ON ENTRY - DSET MUST BE OPEN AND SET
* (*PVARS*) = ADDR OF CM NAME TABLE
* ON EXIT - CM CONTAINS DEFN PAGE 1
* *VLOBEC*, *VUPBEC* AND *VUPBCM* SET
*
* USES - X0, A/B/X1, B2, A/X6
*
ENTRY READNM
READNM EQ *
MX6 0
SA6 VARS0 ZERO OUT IN CASE OF NO NAMES
SA1 AVAR ADDRESS OF DEFN PAGE 1
BX0 X1
SA0 VARS CM ADDRESS TO PUT NAME PAGE
SA1 NDEFN NUMBER OF DEFINED NAMES
SB1 X1
SB2 VARLONG
LE B1,B2,RNM10 IF ALL FITS IN ONE PAGE
*
SB1 B2
RNM10 RE B1 READ IN NAMES
RJ ECSPRTY
SX6 A0+B1 ADDR OF LAST NAME IN PAGE + 1
SX6 X6-1 ADDR OF LAST NAME IN PAGE
SA6 VUPBCM
BX6 X0 ADDRESS OF LOW CM NAME IN ECS
SA6 VLOBEC
SX0 B1-1 ADDRESS OF HI CM NAME IN ECS
IX6 X6+X0
SA6 VUPBEC
EQ READNM
*
ENDIF
* /--- BLOCK INITDEF 00 000 79/02/20 12.23
*
* -INITDEF-
* INITIALIZES DEFINE VARIABLES AND BRINGS IN THE
* PROPER DEFINE SET FROM ECS
*
ENTRY INITDEF
INITDEF EQ *
MX6 -1
SA6 UDMODE INTERPRET *UNITS*
MX6 0
SA6 VSKMODE SET VSEEK MODE
SA6 PFRST
*
PLATO
RJ GETNDFU GET NDEFU INTIALIZED
EQ INITDEF
ENDIF
*
CONDEN
SX6 VARS
SA6 PVARS POINTER TO DEFN NAME LIST
RJ =XSETSET BRING IN CURRENT DEFN SET
EQ INITDEF
*
ENDIF
*
*
PLATO
*
* -GETNDFU-
* GETS NUMBER OF UNITS DEFINED
* SETS NDEFN,NDEFU
*
ENTRY GETNDFU
GETNDFU EQ *
SA1 LESSCM+LDEFNWD
SX6 X1
SA6 NDEFN NUMBER OF DEFINITIONS
AX1 18+18 POSITION NUMBER OF UNITS
SX6 X1
SA6 NDEFU SET NUMBER OF UNITS
EQ GETNDFU
ENDIF
*
*
*
LEADDSV BSS 1
OLDADD BSS 1
LEXSAV BSS 1
*
SEGADD BSS 1
SEGLIT BSS 1
*
TWORD BSS 1 WORD COUNT
TSHIFT BSS 1 SHIFT COUNT
TWW BSS 1 CURRENT WORD
*
IWK BSS 1
*
*
* /--- BLOCK VSEEK 00 000 81/07/27 21.51
*
TITLE -VSEEK- IDENTIFY DEFINED NAME
*
* -VSEEK-
* SEARCHES THE DEFINED NAME TABLE FOR THE
* NAME HELD IN X6 (AND IN -AD- IF IN EXEC MODE)
*
* *ADTYPE* IS RETURNED WITH THE *GETVAR* CODE
* OR -1 IF THE NAME IS NOT FOUND
*
* *VSKMODE* CONTROLS ACTION WHEN A NAME IS FOUUND
* - = OP RETURNED WITH THE OPCODE FOR DEFINE
* 0 = OP UNCHANGED (0 IF CALLED FROM -LEX-)
* + = OP SET TO *OPDEFN* FOR FUNCTION DEFINE ONLY
*
* IF NO EXACT MATCH IS FOUND IN EXEC MODE IMPLIED
* MULTIPLICATION IS ASSUMED IF A PARTIAL MATCH
* CAN BE FOUND (SEE DESCRIPTION IN -LEX-)
*
*
.IFVSK PLATO
*CALL LEXTXT
.IFVSK ENDIF
*
CONDEN
EXT TVARCNT (LOCAL TO LEX FOR CONDEN)
ENDIF
*
*
EXT ECSPRTY
EXT LEX
*
* /--- BLOCK VSEEK 00 000 81/07/27 21.51
ENTRY VSEEK
VSEEK EQ *
PLATO
EQ VSEEK1
ENDIF
*
CONDEN
MX0 42 SEVEN CHAR MASK
BX6 X0*X6 MASK TO 7 CHARS
*
*
* SET UP FOR BINARY CHOP
*
LX6 60-18 RIGHT JUSTIFY NAME
SB1 1 (B1) = 1
SB7 -B1 (B7) = -1
SA2 VUPBCM ADDR OF HI CM VARNAME
SA3 X2 HI VAR NAME/GETVAR
BX3 X0*X3 ISOLATE NAME
LX3 60-18 RIGHT JUSTIFY NAME
IX3 X3-X6
NG X3,PAGENM1 IF KEY.GT.HICMNAME, PAGE ECS
*
SB2 A3 (B2) = HI
SA3 VARS LO VARNAME/GETVAR
BX3 X0*X3 ISOLATE NAME
LX3 60-18 RIGHT JUSTIFY NAME
IX3 X6-X3
NG X3,PAGENM IF KEY.LT.LOCMNAME, PAGE ECS
*
SB3 A3 (B3) = LO
*
* BINARY CHOP TO FIND VAR NAME IN X6
* IN ALPHABETICALLY ORDERED TABLE IN CM
* ON EXIT'; IF FOUND'; *ADTYPE* = GETVAR
* IF NOT FOUND'; *ADTYPE* = -1 AND
* (X7) = ECS LOC TO INSERT NEW NAME AT
*
VBCHOP SX7 B2+B3 I = HI+LO
AX7 B1 I = INT(I/2)
SA1 X7 (X1) = NAME/GETVAR
BX2 X0*X1 ISOLATE NAME
LX2 60-18 RIGHT JUSTIFY NAME
IX4 X6-X2 NEGATIVE IF KEY.LT.NAME
ZR X4,VFOUND IF KEY = NAME, FOUND
*
LE B2,B3,NOFIND IF HI = LO, SEARCH END, NOFIND
*
PL X4,TOOLO IF LO TOO LOW
*
TOOHI SB2 X7+B7 HI = I-1
EQ VBCHOP
*
TOOLO SB3 X7+B1 LO = I+1
EQ VBCHOP
*
* /--- BLOCK VSEEK 00 000 79/02/18 13.23
*
NOFIND SX6 -1 SET ADTYPE = -1
SA6 ADTYPE
SX1 VARS
IX7 X7-X1 MAKE INSERT LOC RELATIVE
AX4 60 FORM A -1 IF KEY.LT.NAME
MX6 59
BX4 X6*X4
IX7 X7+X4 IF KEY.LT.NAME, I = I-1
SA1 VLOBEC
IX7 X7+X1 X7 = ABS ECS LOC TO INSERT NAME
EQ VSEEK
*
ENDIF
*
VFOUND BX6 -X0*X1 ISOLATE GETVAR CODE
SA6 ADTYPE
VFOUNDB SA2 TVARCNT
SX7 X2+1 COUNT VARIABLE REFERENCES
SA7 A2
SA1 VSKMODE SEE IF MUST EXPAND DEFINE
ZR X1,DEFNLEX GO PROCESS DEFN
PL X1,VFOUND1
SX6 OPDEFN
SA6 OP RETURN OP CODE FOR DEFINE
EQ VSEEK
* /--- BLOCK VFOUND1 00 000 76/12/02 10.44
*
VFOUND1 BX1 X6 TRANSFER DEFINE ADDRESS
AX6 XCODEAL SHIFT OFF ADDRESS
MX0 57 3 BIT MASK
BX6 -X0*X6
SX6 X6-4 SEE IF TYPE 4 (CALC)
NZ X6,DEFNLEX CANT BE FUNCTION IF NOT CALC
RJ SETDEF SET POINTERS TO DEFINE
RJ GETDEF NUMBER OF ARGUMENTS
ZR X1,DEFNLEX NOT A FUNCTION
SX6 OPDEFN
SA6 OP RETURN OP CODE FOR DEFINE
EQ VSEEK
*
CONDEN
*
* (X6) IS NOT IN RANGE OF VARNAMES IN CM
* SO FIND CORRECT PAGE AND MOVE IT TO CM
* IF CORRECT PAGE DOES NOT EXIST, RETURN NOT FOUND
*
PAGENM1 BX3 -X3 KEY-NAME
PAGENM BSS 0
SB2 VARLONG (B2) = LENGTH OF CM NAME BUFFER
SA2 NDEFN
SB4 X2 (B4) = LENGTH OF ECS NAME TABLE
LE B4,B2,PNOFIND
*
SB4 B4+B7 (B4) = NDEFN-1
*
SB2 B0 (B2) = INDEX INTO PAGE TABLE
SB3 VARLONG-1 (B3) = PAGE POINTER
*
* SEARCH DEFINE NAME PAGE TABLE TO FIND WHICH
* PAGE, IF ANY, SHOULD BE SEARCHED VIA *VBCHOP*
* AND PULL IT INTO CM
*
PAGELP BSS 0
SA1 PGTBL+B2 HI NAME/GETVER IN PAGE(B2)
BX1 X0*X1 ZERO OUT GETVAR
LX1 60-18 RIGHT JUSTIFY NAME
IX2 X1-X6
PL X2,PGFND0 IF HI NAME IS.GE.KEY, THIS PAGE
*
SB3 B3+VARLONG POINT TO NEXT PAGE
GT B3,B4,LASTPG IF PAGE POINTER.GT.NDEFN-1
*
SB2 B2+B1 POINT TO NEXT ENTRY IN PAGE TBL
EQ PAGELP
*
PGFND0 SB4 VARLONG-1
PGFND SX0 B3-B4 (X0) = REL. ECS ADDR OF PAGE
SA1 AVAR (X1) = ECS ADDR OF NAME TABLE
IX0 X0+X1 (X0) = ECS ADDR OF PAGE
SA0 VARS (A0) = CM ADDR OF PAGE
RE B4+1 READ IN NEW PAGE
RJ ECSPRTY
BX7 X0
SA7 VLOBEC STORE ECS ADDR OF LOWER BOUNDS
SX7 A0+B4
SA7 VUPBCM STORE CM ADDR OF HI BOUNDS
SB2 X7
SB3 VARS
MX0 42 RESTORE MASK FOR *VBCHOP*
EQ VBCHOP
*
PNOFIND SB4 B4+B7 (B4) = NDEFN-1
SB3 B4
EQ PGFND
*
LASTPG SB3 B4 (B3) POINTS TO HIGHEST ECS NAME
EQ PGFND0
*
ENDIF
* /--- BLOCK VFOUND 00 000 79/02/12 11.08
*
*
* COMES HERE IF IN -EXEC- MODE
*
PLATO
EXT VARTERR VAR FOUND WITH SPECS NOVARS
EXT SEEKFCT IN FILE LEX
*
VSEEK1 SA1 LASTKEY SAVE ORIGINAL LASTKEY
BX7 X1
SA7 SAVELK
SA1 WORDPT SAVE ORIGINAL WORDPT
BX7 X1
SA7 SAVEWP
RJ SEEKFCT MAY BE FUNCTION
SA1 OP NON-ZERO IF FOUND SOMETHING
BX7 X1
SA7 SAVOP
MX7 0
SA7 A1 CLEAR OP
SA1 WORDPT POINTS AT 2 IN SIN2X
SA2 SAVEWP ORIGINAL WORDPT
BX7 X1
SA7 A2
BX7 X2
SA7 A1
SA1 LASTKEY IN COS(X), LASTKEY IS (
SA2 SAVELK ORIGINAL LASTKEY
BX7 X1
SA7 A2
BX7 X2
SA7 A1 RESTORE ORIGINAL LASTKEY
MX7 59 -1
SA7 ADTYPE PRESET TO NOT FOUND
SA1 AD RESTORE NAME STRING
BX6 X1
RJ VSEEKX LOOK FOR DEFINED NAME
SA1 SAVOP SEEKFCT OP
SA2 ADTYPE -1 IF NOT FOUND
NG X2,NODEF JUMP IF NO DEFINED NAME
ZR X1,VFOUNDB DEFINED NAME, NO SYSTEM FUNCT
* BOTH -- FIND WHICH IS LONGER, DEFINED NAME OR SYSTEM FUNCT
SA2 WORDPT POINTER AFTER VSEEKX
SA3 SAVEWP POINTER AFTER SEEKFCT
IX7 X2-X3
PL X7,VFOUNDB VSEEK NAME LONG OR LONGER THAN SEEKFCT NAME
*
NODEF ZR X1,VSEEK NEITHER SYSTEM FUNCT NOR DEFINED NAME
BX7 X1
SA7 OP
SA1 SAVEWP RESTORE WORDPT TO WHERE SEEKFCT LEFT IT
BX7 X1
SA7 WORDPT
SA1 SAVELK
BX7 X1
SA7 LASTKEY
EQ VSEEK
*
SAVOP BSS 1 SAVE OP FOUND BY SEEKFCT
SAVEWP BSS 1 SAVE WORDPT AT END OF SEEKFCT
SAVELK BSS 1 SAVE LASTKEY AT END OF SEEKFCT
*
* /--- BLOCK VSEEKX 00 000 79/12/04 00.23
VSEEKX EQ * EXEC-TIME NAME LOOKUP
SA2 COMSPEC LOAD SPECS BITS
LX2 NOVARS SEE IF -SPECS NOVARS-
PL X2,VSEEKX2 JUMP IF VARS ALLOWED
SA2 SAVOP SEE WHETHER SEEKFCT FOUND SOMETHING
ZR X2,VARTERR NO VARS ERROR (IF SEEKFCT FAILED TOO)
EQ VSEEKX
VSEEKX2 SA2 NDEFN NUMBER OF DEFINITIONS
ZR X2,VSEEKX
SA2 PFRST SEE IF UNIT ALREADY IN
NZ X2,VSK100
SB1 A5
SX7 B5-B1 SAVE COMMAND BIAS
SA7 OLDB5
SX5 1 DEFINE UNIT = UNIT 1
CALL GETUNIT
BX2 X0 X2 = ECS ADDRESS OF DEFINE SET
SX6 B5+1
SA6 PFRST ADDRESS OF DIRECTORY
SA6 PVARS ADDRESS OF DEFINED NAMES
SA1 B5 HEADER WORD
SB2 X1 *NDEFN*
SX1 B2+1 RELATIVE ADDR OF TOKEN BUFFER
IX6 X2+X1
SA6 ATOKEN ECS ADDRESS OF TOKENS
SA1 AD RESTORE DEFN NAME
BX6 X1
VSK100 BSS 0
SB1 B0 BEGINNING OF SEARCH
SA2 B5
SB2 X2 END OF SEARCH
SA1 PVARS
SA0 X1 BASE OF SEARCH
MX0 42 7 CHAR MASK
BX4 X0 INITIALIZE
*
* /--- BLOCK VLOOP1 00 000 76/12/09 16.35
VLOOP1 GE B1,B2,VSK300
SA1 B1+A0 GET NEXT NAME AND CODE
SB1 B1+1
BX2 X0*X1 MASK OFF NAME
BX3 X6-X2 COMPARE NAMES
ZR X3,VEXACT JUMP IF EXACT MATCH
BX3 -X6*X2 QUICK CHECK
NZ X3,VLOOP1 NOT A POSSIBLE MATCH
MX3 6 ONE CHAR MASK
SB3 B0 CHARACTER COUNT
*
VLOOP2 SB3 B3+1 INCREMENT CHAR COUNT
BX7 -X3*X2 BUILD A MASK FOR THIS NAME
ZR X7,VSK200 JUMP IF HAVE COMPLETE MASK
AX3 6 EXTEND BY ONE CHAR POSITION
EQ VLOOP2
*
VSK200 BX7 X6*X3 TRUNCATE OBJECT NAME
BX7 X2-X7 SEE IF MATCHES
NZ X7,VLOOP1
SX3 B3
IX7 X4-X3 SEE WHICH MATCH IS BEST
PL X7,VLOOP1
BX4 X3 SAVE CHAR COUNT
BX5 X1 SAVE NAME + CODE
EQ VLOOP1
*
* IF EXACT MATCH, DO NOT HAVE TO CALL -ADVANCE-
VEXACT BX6 -X0*X1 MASK OFF GETVAR CODE
SA6 ADTYPE
EQ VSEEKX
*
VSK300 NG X4,VSEEKX NO IMPLIED MULT POSSIBLE
BX6 -X0*X5 MASK OFF GETVAR CODE
SA6 ADTYPE
SB1 X4
CALL ADVANCE ADVANCE B1 CHARS ACROSS FOUND STRING
SX7 1R*
SA7 LASTKEY FAKE UP MULTIPLY
EQ VSEEKX
*
*
*
ENDIF
*
*
*
END