plato:source:plaopl:deflex
Table of Contents
DEFLEX
Table Of Contents
- [00006] INTERPRETATION OF DEFINE
- [00034] DEFNLEX
- [00079] PROCESS PRIMITIVE DEFINE
- [00276] PROCESS NORMAL DEFINE
- [00418] PROCESS FUNCTION DEFINE
- [00759] DEFINE INFO STORAGE / RETRIEVAL
- [01150] -VSEEK- IDENTIFY DEFINED NAME
Source Code
- DEFLEX.txt
- 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
plato/source/plaopl/deflex.txt · Last modified: 2023/08/05 18:54 by Site Administrator