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