TITLE 'CODEXEQ-B00,08/22/73,DWG702985'
SYSTEM SIG7F
CSECT 1
PCC 0 CONTROL CARDS NOT PRINTED.
CODEXEQ@ RES 0 ORIGIN OF CODESTRING EXEC. MODULE.
*
* REF'S AND DEF'S
*
DEF CODEXEQ@ = START OF 'CODEXEQ' MODULE.
DEF CX CODESTRING EXECUTION ENTRY PT.
SPACE 2
DEF XEQEMPTY RETURN PT WHEN AN 'EXECUTE' IS OK,
* BUT PRODUCED NO CODESTRING, E.G.
* A SUCCESSFUL COMMAND EXECUTION.
DEF LOBRNCK ENTERED FOR ERR-CTRL BRANCH.
DEF OBSERVED RESUME AFTER AN OBSERVATION.
DEF RESQQUAD RESUME AFTER QUOTE-QUAD INPUT.
DEF QDBDONE RESUME AFTER QUAD-ZERO INPUT.
DEF QOUTRET RESUME AFTER QUAD-ZERO OUTPUT.
DEF RETURNMX RETURN FROM MONADIC-OP EXECUTION.
DEF RETURNDX DYADIC-OP EXECUTION.
DEF RETURNNI NILADIC INTRINSIC FUNC.
DEF RETURNSX SUBSCRIPT EXECUTION.
DEF RETURNAX ASSIGNED-INDEXING EXEC.
SPACE 3
* REFS TO PROCEDURE:
REF F2I FLOATING-TO-INTEGER CONVERSION.
REF CTEST TRIES TO GET MORE COMMON
REF ALOCBLK ALLOCATE DATA BLOCK.
REF ALOCHNW ALLOCATE HEADER PLUS N WDS.
REF ALOCRS ALLOCATE RESULT DATA BLOCK.
REF ALOCTRES ALLOCATE TEXT TYPE RESULT DATA BLK.
REF DREF DEREFERENCE A DATA BLOCK.
REF MAYDREF DEREFERENCE A DATA BLOCK, IF ANY.
REF ERDOMAIN DOMAIN ERROR.
REF ERRANK RANK ERROR.
REF ERLENGTH LENGTH ERROR.
REF SYSTERR SYSTEM ERROR HANDLER (TOTALLY LOST).
REF OPBREAK STARTS TBL OF ERROR ENTRY PTS.
REF SICLR% CLEAR STATE INDICATOR TO GO-STATE.
REF BREAKFLG BREAK FLAG (NZ IF BRK OR HANG-UP).
REF MXDRIVER MONADIC OPERATOR EXECUTION DRIVER.
REF DXDRIVER DYADIC OPERATOR EXECUTION DRIVER.
REF SXDRIVER SUBSCRIPTING EXECUTION DRIVER.
REF AXDRIVER INDEXED ASSIGNMENT EXECUTION DRIVER.
REF INNER INNER PRODUCT EXECUTION DRIVER.
REF OUTER OUTER PRODUCT EXECUTION DRIVER.
REF REDUCE REDUCTION OPERATOR EXECUTION DRIVER.
REF SCAN SCAN OPERATOR EXECUTION DRIVER. U19-0004
REF NINTRIN NILADIC OPERATOR EXECUTION DRIVER.
REF MINTRIN MONADIC OPERATOR EXECUTION DRIVER.
REF DINTRIN DYADIC OPERATOR EXECUTION DRIVER.
REF INPDIR REQUESTS DIRECT INPUT.
REF INPEVAL REQUESTS EVALUATED INPUT.
REF INPQQUAD REQUESTS QUOTE-QUAD INPUT.
REF INPXEQ DOES INPUT-TRANS. FOR EXECUTE OPER.
REF INPBLIND REQUESTS BLIND INPUT.
REF QZIN QUAD-0 (GRAPHICS) INPUT START PT.
REF QZOUT QUAD-0 (GRAPHICS) OUTPUT START PT.
REF MIXEDOUT STMT DISPLAYER (MIXED OUTPUT).
REF SINGOUT DISPLAY SINGLE DATA BLOCK VALUE.
REF BLINDOUT OUTPUTS BLINDLY
REF SHOWSTOP DISPLAYS STOPPED-FUNC.NAME & LINE #.
REF FUNLDISP DISPLAYS FUNC.NAME & LINE NUMBER.
REF OBSERVER DISPLAYS AN OBSERVATION.
* REFS TO CONTEXT:
REF OPER DBLWD TEMP FOR OPERATOR INFO.
REF CXDTEMP DBLWD TEMP USED BY CODESTRING EXEC.
REF FDEFPTR (DB PTR) FUNCTION DESCRIPTOR.
REF XTEMP (DB PTR) INDEX OR COORD.
REF NILCK (DB PTR)
REF LFARG (DB PTR) LEFT ARG.
REF RTARG (DB PTR) RIGHT ARG.
REF RESULT (DB PTR) RESULT.
REF CURRCS PTS AT CURRENT CODESTR. DATA BLK +2.
REF RSSIZE HOLDS NO.OF ELEMENTS FOR RESULT D.B.
REF RSTYPE USED TO HOLD TYPE OF RESULT DATA BLK
REF RSRANK USED TO HOLD RANK OF RESULT DATA BLK
REF BRNVAL BRANCH VALUE.
REF GOSTATE GO-STATE FOR STATE INDICATOR CLEARS.
REF CATCHTBL CATCH TABLE.
REF OBSFLAG OBSERVE-CMD FLAG (0=NO & -1=YES).
REF OBSERVE OBSERVATION SETTING (0=NO & -1=YES).
REF STATEPTR PTS AT TOP STATE-ENTRY IN STACK.
REF TOPOSTAK OFTEN PTS AT TOP OF EXECUTION STACK.
REF ORGADJ VALUE USED IN ADJUSTING TO ORIGIN 1.
REF OFFSET OCCAS. USED TO SAVE CURR. CS OFFSET.
REF CXSCRTCH SCRATCH AREA FOR CODESTRING EXEC.
REF INBUF INPUT BUFFER.
REF IMAGE INTERNAL IMAGE OF INPUT LINE.
REF SYMT PTS AT 1ST WD OF SYMBOL TABLE.
REF NAMEPTR PTS TO REF-INDIC WD FOR A VAR. NAME.
REF BLINBUF BLIND INPUT BUFFER
REF STKLIMIT CURRENT LIMIT TO EXEC.STACK.
REF LOCNEED LOC (+1) NEEDED FOR COMMON INCREASE.
* REFS TO CONSTANTS:
REF X1FFFF X'1FFFF'
REF XFF0000 X'FF0000'
REF BITPOS 32-WD TBL OF BITS (BITPOS-K CONTAINS
* A WD HAVING A 1 ONLY IN BIT POS K)
REF FUNTYPES RANGE OF FUNCTION TYPES.
*
* EQU'S RELATED TO THE CONTEXT REF'S.
*
OPERHOLD EQU CXDTEMP HOLDS OPER INFO TILL OTHER OP EXECD.
XPARAMS EQU CXDTEMP INDEX SEQUENCE PARAMETERS--
XADD EQU XPARAMS ADDITIVE FACTOR.
XMULT EQU XPARAMS+1 MULTIPLICATIVE FACTOR.
DENTRY EQU BITPOS-4 DY. FUN CAT.OF EXEC.STACK ENTRY.
BENTRY EQU BITPOS-5 BRACKET CAT.OF EXEC.STACK ENTRY.
OENTRY EQU BITPOS-6 OPERATOR CAT.OF EXEC.STACK ENTRY.
COORD1 EQU BITPOS-7 COORDINATE-1 (FOR OPS LIKE %RV1).
PTRITEM EQU LFARG FOR PTR SCANITEM.
LINKX EQU CXSCRTCH+0 LINK TO 'SUBEX'.
LINKMX EQU CXSCRTCH+0 LINK TO 'MONEX'.
ACFLAG EQU CXSCRTCH+0 ASSIGNMENT-COMPLETED FLAG.
XSIZE EQU CXSCRTCH+0 EXECUTION STACK SIZE FOR FUN.CALL.
STSET EQU CXSCRTCH+0 STOP OR TRACE BIT SETTING.
SCANTEMP EQU CXSCRTCH+1 SCAN ITEM HOLDER.
NFL4ST EQU CXSCRTCH+1 NO.OF FUN LINES FOR STOP OR TRACE.
OFFSETR EQU CXSCRTCH+2 OFFSET FOR RE-SCAN OF DESIGNATOR.
LINKT EQU CXSCRTCH+2 LINK HOLDER FURING TRACED SHOW SET.
FDLPTR EQU CXSCRTCH+2 FUN DESCRIPTOR LINE-PTR PTR.
OPCURRBY EQU CXSCRTCH+3 CURR.BYTE HOLDER FOR OPWRAP.
*
* STANDARD EQU'S
* REGISTERS
R1 EQU 1
R2 EQU 2
R3 EQU 3
R4 EQU 4
R5 EQU 5
R6 EQU 6
R7 EQU 7
R8 EQU 8
R9 EQU 9
R10 EQU 10
R11 EQU 11
R12 EQU 12
R13 EQU 13
R14 EQU 14
R15 EQU 15
*
* EXECUTION STACK CATEGORIES
*
CATV EQU 0 (NOT USED MUCH) VALUE PTR.
CATAPRYM EQU 1 ASSIGNMENT (COMPLETED).
CATO EQU 2 OPERATOR.
CATX EQU 3 INDEX (LIST PTR).
CATB EQU 4 BRACKETED.
CATP EQU 5 PARENTHESIZED.
CATS EQU 6 STMT.
CATQ EQU 7 QUAD-STATE (FOR EVAL-INPUT).
CATD EQU 8 DYADIC FUNC. (WITHOUT LEFT ARG).
CATA EQU 9 ASSIGNMENT (NOT YET COMPLETED).
CATF EQU 10 FUNCTION-STATE.
*
* SCAN ITEM INDICATORS:
*
SCANPTR EQU 0 (NOT USED MUCH) PTR
SCANVN EQU 1 VN
SCANBRN EQU SCANVN+1 BRN
SCANBOS EQU SCANBRN+1 BOS
SCANLP EQU SCANBOS+1 LP
SCANLB EQU SCANLP+1 LB
SCANSEMI EQU SCANLB+1 SEMI
SCANOPM EQU SCANSEMI+1 OPM
SCANOP EQU SCANOPM+1 OP
*
* DATA BLOCK TYPES:
*
TYPELOGL EQU 1 LOGICAL
TYPETEXT EQU 2 TEXT
TYPEINTG EQU 3 INTEGER
TYPEREAL EQU 4 REAL
TYPELIST EQU 6 LIST
TYPENFN EQU 8 FUNC.DESCR, NILADIC & NO RESULT.
TYPEMFN EQU X'A' FUNC.DESCR, MONADIC & NO RESULT.
TYPEDI EQU X'E' DYADIC INTRINSIC
TYPEMI EQU X'F' MONADIC INTRINSIC
TYPENI EQU X'10' NILADIC INTRINSIC
*
* OTHER EQU'S
* OFFSETS INTO A FUNCTION DESCRIPTOR DATABLK
*
XSIZOFF EQU 2 EXEC. STACK SIZE FOR THE FUNCTION.
RESOFF EQU XSIZOFF+1 RESULT NAME PTR.
LFOFF EQU RESOFF+1 LEFT ARGUMENT NAME PTR.
FNOFF EQU LFOFF+1 FUNCTION-NAME NAME PTR.
RTOFF EQU FNOFF+1 RIGHT ARGUMENT NAME PTR.
NFLOFF EQU RTOFF+1 NO.OF FUNCTION LINES.
LINSTART EQU NFLOFF+1 LINE PTRS START HERE.
* CODESTRING DESIGNATIONS.
QZCODE EQU 25 QUAD-0
Q1CODE EQU 26 QUAD-1
QUADCODE EQU 35 QUAD
STOPNMCD EQU 21 STOPNAME
COMMACOD EQU 87 COMMA OPERATOR (FOR LAMINATION).
BOSCODE EQU 37 BEGINNING-OF-STMT.
SEMICODE EQU 38 SEMICOLON
SMOCODE EQU 46 SMALL CIRCLE
SCAN1COD EQU 118 SCAN OPERATOR (ON 1ST COORD) U19-0006
XEQCODE EQU 120 EXECUTE OPERATOR (EPSILON).
DUMMYCD EQU 138 CODE FOR DUMMY-USED FOR SPACER
* MISC.
STOPBIT EQU X'40000' POS.OF STOP FLAG BIT.
TRACEBIT EQU X'20000' POS.OF TRACE FLAG BIT.
FLINFLG EQU X'10000' FUNCTION-LINE FLAG BIT (IN S-ENTRY).
DYINFLAG EQU X'200' DYADIC INTRINSIC OPERATOR FLAG (IN
* O-ENTRY -- OPTYPE'S HI BYTE).
PENDFLAG EQU X'8000' PENDENT FLAG BIT (IN F OR Q ENTRY).
EFLAG EQU X'10000' MARKS 'EXECUTE' TYPE OF Q-ENTRY.
NEWLINE EQU X'15' END-OF-INPUT CHARACTER.
LBLFLAG EQU X'20000' LABEL FLAG BIT (IN SYM TBL REFERENT
* INDICATOR WD).
TOPRANK EQU 63 MAXIMUM POSSIBLE RANK.
DYADIC EQU 80 1ST DYADIC OP CODESTRING DESIGNATION
MONADIC EQU 50 1ST MON. OPER CODESTRING DESIGNATION
*
* DOUBLEWORD CONSTANTS
*
BOUND 8
DYSCLRS DATA 91,111 RANGE OF DYADIC SCALAR CODE DESIGS.
MDYSCLRS DATA 91,101 MONADIC DYSCLRS.
MONRANGE DATA 50,101 POSS. MONADIC OPERATOR CODE DESIGS.
DYRANGE DATA 80,120 DYADIC OPERATOR CODESTR. DESIGNAT'S.
REDRANGE DATA X'100'+91,X'100'+111 RANGE OF REDUCTION OP-TYPES.
S2XRANGE DATA SCAN1COD,XEQCODE SCAN-THRU-EXECUTE OPERATOR RANGE. U19-0008
CATO2D DATA CATO,CATD RANGE OF CATEGORIES -- O THRU D.
STMASKS DATA STOPBIT,-STOPBIT-1 FLAG & MASK FOR -- STOP VECTOR.
DATA TRACEBIT,-TRACEBIT-1 -- TRACE VECTOR.
*
* CONSTANTS
*
PENTRY DATA X'5000000' PAREN-CATEGORY OF STACK ENTRY.
SENTRY DATA X'6000000' STMT-CATEGORY OF STACK ENTRY.
FSENTRY DATA X'6010000' FUN-STMT-CATEGORY OF STACK ENTRY.
QPENTRY DATA X'7008000' QUAD-STATE CAT. OF STACK ENTRY
* (PENDENT).
AENTRY DATA X'9000000' ASSIGNMENT-CAT. OF STACK ENTRY (NOT
* YET COMPLETED ASSIGNMENT).
FPENTRY DATA X'A008000' FUNC-STATE CAT. OF STACK ENTRY
* (PENDENT).
PAGE
************************************************************************
* *
* STACKUP -- PUSHES THE STACK UP 1 WD & VERIFIES THAT THIS IS BELOW *
* THE STACK LIMIT (I.E. ROOM FOR 2 WDS IF NEEDED). *
* REGS: R1 -- (ENTRY) CURRENT TOP OF STACK. *
* (EXIT) NEW TOP OF STACK (UNFILLED). *
* R4 -- LINK, EXIT VIA 0,R4. *
* R8 IS VOLATILE. *
* *
STACKUP AI,R1 -1 ADD 1 WD TO EXECUTION STACK.
CW,R1 STKLIMIT IS THIS STILL BELOW THE LIMIT.
BG 0,R4 YES, EXIT.
STW,R1 LOCNEED NO, SAVE THE LOCATION NEEDED.
AI,R1 1 RESTORE STACK PTR IN CASE WS FULL.
BAL,R8 CTEST TRY TO GET MORE COMMON...
B CXERWS NO LUCK -- WS FULL.
B 0,R4 OK, EXIT.
PAGE
************************************************************************
* *
* GENLIST -- GENERATES A LIST TYPE OF DATA BLOCK USING NILCK AND THE *
* N V-ENTRIES CONTAINED IN THE SERIES (FOR EXAMPLE, B-ENTRY) *
* AT THE TOP OF THE EXECUTION STACK. *
* REGS: R11 (ENTRY) CONTAINS N. *
* R13 LINK, EXIT VIA *R13. *
* R4,R5,R11,R12,R14 ARE VOLATILE; SEE ALSO ALOCRS. *
* R1 (EXIT) PTS AT EXECUTION STACK ENTRY AFTER THE *
* N-TH V-ENTRY. *
* *
SPACE
LOCAL GENLIST1,GENLIST2
SPACE
GENLIST LI,R12 1 NOTE: ASSUME RANK OF A LIST IS 1;
STW,R12 RSRANK (SEE ALSO DELTA-FMT).
LI,R12 TYPELIST FOR LIST TYPE DATA BLOCK.
STW,R12 RSTYPE
AI,R11 2 ACCOUNT FOR NILCK AND TRACKING WD.
STW,R11 RSSIZE
STW,R1 TOPOSTAK SAVE STACK PTR. IN CASE WS FULL.
STW,R3 OPER+1 SAVE OFFSET IN CASE WS FULL OCCURS.
BAL,R14 ALOCRS ALLOCATE 'RESULT' DATA BLOCK.
STW,R4 PTRITEM SAVE LOC OF DATA BLOCK AS PTR ITEM.
LW,R5 RSSIZE = NO.OF DATA PTRS IN THE LIST
AI,R5 -1 BUT NOT COUNTING THE TRACKING WD
STW,R5 2,R4 (I.E. LENGTH OF LIST).
LW,R12 NILCK GET 1ST DATA PTR (OR NIL).
B GENLIST2
GENLIST1 LI,R12 0
XW,R12 0,R1 GET NEXT DATA PTR (OR NIL).
GENLIST2 AI,R4 1 INCR PTR INTO THE DATA BLOCK.
STW,R12 2,R4 FILL IN A DATA PTR.
AI,R1 1 PT AT NEXT ENTRY IN EXECUTION STACK.
BDR,R5 GENLIST1
STW,R5 3,R4 NOTE--LIST LENGTH MUST NOT START OUT ZERO;
* ZERO THE TRACKING WD.
B *R13
PAGE
************************************************************************
* *
* NUMSV -- CHECK NUMERIC SCALAR OR VECTOR DATA BLOCK. *
* REGS: R7 LINK, EXIT VIA 0,R7 FOR SCALAR OR *
* 1,R7 FOR VECTOR. *
* R4 (ENTRY) PTS TO DATA BLOCK HEADER. *
* (EXIT) PTS AT DATA BLOCK HEADER + 3. *
* R6 (EXIT) CONTAINS NUMERIC TYPE INDICATOR: *
* 1 FOR LOGL *
* 2 FOR INTG *
* 3 FOR REAL *
* 4 FOR XSEQ (INDEX SEQUENCE) *
* R13 (EXIT) = 0. *
* R12 (VECTOR EXIT) CONTAINS LENGTH OF VECTOR *
* (SCALAR EXIT) CONTAINS 'LENGTH' = 1. *
* *
SPACE
LOCAL NUMTCK,RNKCK
SPACE
NUMSV LB,R6 *R4 GET TYPE OF DATA BLOCK
NUMTCK B NUMTCK,R6 @ VECTOR ON THE TYPE -- 0 IMPOSSIBLE.
B RNKCK @ 1 -- LOGL (NUMERIC TYPE 1)
B NUMCKNIL @ 2 -- TEXT, MAYBE EMPTY VECTOR.
BDR,R6 RNKCK @ 3 -- INTG (NUMERIC TYPE 2)
BDR,R6 RNKCK @ 4 -- REAL (NUMERIC TYPE 3)
BDR,R6 RNKCK @ 5 -- XSEQ (NUMERIC TYPE 4)
B CXERDOM @ 6 -- LIST -- DOMAIN ERROR.
RNKCK LW,R13 0,R4 DATA BLOCK'S HEADER WORD.
AI,R4 3 PT AT DATA BLK HDR + 3.
LI,R12 1 IF SCALAR, PREPARE LENGTH = 1.
AND,R13 XFF0000 CK THE RANK...
BEZ 0,R7 0, TAKE SCALAR EXIT.
LW,R12 -1,R4 NZ, GET LENGTH WORD.
AI,R13 -X'10000' VERIFY THAT RANK = 1...
BEZ 1,R7 OK, TAKE VECTOR EXIT.
B CXERRANK NO -- RANK ERROR.
NUMCKNIL LI,R13 -X'0201' MINUS(TYPE 2 RANK 1).
AH,R13 *R4 = 0 IF TEXT VECTOR...
BNEZ CXERDOM NOT VECTOR -- DOMAIN ERROR.
AI,R4 3 PT AT DATA BLK HDR + 3.
LW,R12 -1,R4 GET LENGTH...
BEZ 1,R7 EMPTY VECTOR (ASSUME INTG) -- EXIT
B CXERDOM OOPS -- DOMAIN ERROR.
PAGE
************************************************************************
* *
* SHADOW -- PLACES A NEW REFERENT INDICATOR IN A GIVEN SYMBOL TABLE *
* ENTRY, PUSHES THE OLD REFERENT INDICATOR INTO THE EXECUTION *
* STACK, AND PUSHES THE SYMBOL TABLE ENTRY OFFSET (I.E. THE *
* NAME POINTER) INTO THE STACK. *
* REGS: R6 -- LINK, EXIT VIA 0,R6. *
* R4 -- (ENTRY) CONTAINS NEW REFERENT INDICATOR. *
* R7 -- (ENTRY) CONTAINS THE NAME POINTER. *
* R1 -- (ENTRY) PTS AT EXECUTION STACK LOC. *
* (EXIT) PTS AT EXECUTION STACK LOC OF NAME PTR. *
* R4 IS VOLATILE. *
* *
SHADOW XW,R4 *SYMT,R7 GET OLD, PLACE NEW REFERENT-INDIC.
STW,R4 -1,R1 PUSH OLD REF-IND.
STW,R7 -2,R1 PUSH NAME PTR.
AI,R1 -2 UPDATE STACK PTR.
B 0,R6 EXIT.
PAGE
************************************************************************
* *
* SUSPCLR -- ENTERED FOR SUSPENSION-CLEAR AND DIRECT INPUT REQUEST. *
* *
SUSPCLR LI,R3 PENDFLAG = PENDENT FLAG.
LW,R4 STATEPTR PT AT TOP STATE ENTRY.
SUSPCLRP LI,R5 X'7FFF'
AND,R5 0,R4 EXTRACT 'NEXT' FIELD...
BEZ SUSPCLRF ZERO = FINAL STATE ENTRY.
AW,R4 R5 PT AT NEXT STATE ENTRY.
CW,R3 0,R4 IS IT PENDENT...
BANZ SUSPCLRP YES, KEEP HUNTING.
SUSPCLRF STW,R4 GOSTATE PT AT STATE TO CLEAR DOWN TO AND
LI,R14 INPDIR REQUEST DIRECT INPUT AFTER
B SICLR% CLEARING THE STATE INDICATOR.
PAGE
CXBREAK BAL,R2 INTERR BRK DETECTED BY CODEXEQ. @
CXLSERR BAL,R2 INTERR @
CXERSYN BAL,R2 INTERR @
CXERUND BAL,R2 INTERR @
CXERNOR BAL,R2 INTERR @
CXERIO BAL,R2 IOERR @
CXERDOM BAL,R2 INTERR @
CXERRANK BAL,R2 INTERR @
CXERLEN BAL,R2 INTERR @
CXERWS BAL,R2 INTERR @
INTERR STW,R1 TOPOSTAK SAVE CURRENT TOP OF STACK.
IOERR STW,R3 OPER+1 SAVE CURRENT BYTE OFFSET IN CODESTR.
B OPBREAK-CXBREAK-1,R2 GOTO APPR. ERROR-ENTRY PT.
PAGE
A38 STW,R1 TOPOSTAK SAVE STACK PTR.
LW,R4 1,R1 GET DATA BLK PTR (I.E. V-ENTRY).
AI,R6 -QZCODE CHECK FOR QUAD-ZERO...
BE QZOUTSET YES -- SET FOR GRAFIX OUTPUT.
LI,R14 QOUTRET-1 NORMAL RETURN FROM OUTPUT IS QOUTRET
AI,R6 QZCODE-QUADCODE NOT QUAD-ZERO, WHICH IS IT...
BGEZ SINGOUT QUAD OR QUOTE-QUAD (SINGLE D.B.).
AI,R6 QUADCODE-Q1CODE+1 BLIND, GET QUAD NUMBER.
LI,R5 TYPETEXT
CB,R5 *R4 VERIFY DATA BLK IS TEXT TYPE.
BE BLINDOUT OK.
B CXERDOM OOPS -- DOMAIN ERROR.
QZOUTSET STW,R3 OPER+1 SAVE CS OFFSET TO THE QUAD CODE.
STW,R4 RTARG SET PTR TO ARG.
MTW,1 1,R4 BUMP ITS REF-COUNT.
LW,R5 BREAKFLG TEST FOR BREAK...
BEZ QZOUT NO -- DO GRAFIX OUTPUT.
B CXBREAK YES.
B CXERIO @ ERROR RETURN FOR QUAD-OUT -- I/O ERR
QOUTRET LW,R1 TOPOSTAK @ RESTORE STACK PTR.
LI,R2 CATAPRYM SET TOP CAT = A-PRIME.
STB,R2 *R1
BDR,R3 NXTSCAN
A25 AI,R6 -QUADCODE WHICH TYPE OF QUAD...
BEZ A25EVAL EVALUATED-INPUT.
STW,R1 TOPOSTAK (SAVE STACK PTR).
BLZ A25Q BLIND OR QUAD-ZERO.
B INPQQUAD QUOTE-QUAD INPUT;
RESQQUAD LW,R1 TOPOSTAK RESUME AFTER QUOTE-QUAD INPUT TRY.
AI,R13 0 AFTER PTING AT TOP OF STACK, CK FOR:
BGZ DCSSUSP O-U-T, DROP CS & CLR SUSPENSION.
BLZ CXBREAK HANGUP, BREAK CODESTR.EXECUTION.
AI,R11 -1 NORMAL, DROP END-OF-INPUT CHAR.
LI,R2 BA(IMAGE) PT AT IMAGE BUFFER
QDB STW,R11 RSSIZE SAVE LENGTH OF INPUT.
LI,R4 TYPETEXT
STW,R4 RSTYPE SET FOR TEXT TYPE OF DATA BLK.
LI,R4 1 ASSUME VECTOR RANK.
CW,R4 RSSIZE BUT IF LENGTH IS 1, USE SCALAR RANK.
BNE QDBRANK
LI,R4 0
QDBRANK STW,R4 RSRANK
STW,R1 TOPOSTAK SAVE STACK PTR. IN CASE WS FULL.
STW,R3 OPER+1 SAVE OFFSET IN CASE WS FULL OCCURS.
BAL,R14 ALOCTRES ALOC TEXT RESULT DATA BLK.
LW,R11 RSSIZE
STW,R11 2,R4 SET LENGTH WORD IN CASE OF VECTOR.
BEZ QDBDONE 0, EMPTY VECTOR.
AI,R4 3 PT AT 1ST VALUE WD FOR A VECTOR.
SLS,R4 2 USE BYTE LOC.
CI,R11 1 IS IT A VECTOR...
BNE QDBFILL YES.
AI,R4 -4 NO, BACK UP 1 WD.
QDBFILL LB,R5 0,R2
STB,R5 0,R4
AI,R2 1 MOVE TEXT CHARS INTO THE DATA BLK.
AI,R4 1
BDR,R11 QDBFILL
QDBDONE LI,R4 0 MOVE RESULT INTO PTRITEM.
XW,R4 RESULT
STW,R4 PTRITEM
B QRESCAN
A25Q AI,R6 QUADCODE-QZCODE CHECK FOR QUAD-ZERO...
BNEZ A25BLIND BLIND INPUT.
STW,R3 OPER+1 QUAD-ZERO, SAVE CS OFFSET TO IT.
LW,R5 BREAKFLG TEST FOR BREAK...
BEZ QZIN NO -- DO GRAFIX INPUT.
B CXBREAK YES.
A25BLIND RES 0 R6 HAS THE QUAD NUMBER.
BAL,R14 INPBLIND @ DO BLIND INPUT.
B CXERIO @ ERROR RETURN -- I/O ERROR.
LW,R1 TOPOSTAK @ NORMAL RETURN, RESTORE STACK PTR.
LI,R2 BA(BLINBUF) PT AT BLIND INPUT BUFFER.
B QDB
A25EVAL LI,R13 0 (NO E-FLAG)
LI,R14 INPEVAL SET TO REQUEST EVALUATED INPUT.
STACKQE BAL,R4 STACKUP ADD A WD TO EXECUTION STACK.
LI,R6 0
XW,R6 CURRCS MOVE CURRENT CODESTRING DATA BLK PTR
STW,R6 0,R1
SLS,R3 17 AND CURRENT BYTE POSITION
STS,R3 0,R1 INTO THE STACK.
AI,R1 -1 PT AT WD TO RECEIVE Q-ENTRY.
STW,R1 TOPOSTAK SAVE STACK PTR.
XW,R1 STATEPTR UPDATE STATE PTR.
SW,R1 TOPOSTAK CALC OFFSET TO NEXT STATE ENTRY.
OR,R1 QPENTRY SET Q CATEGORY, PENDENT STATE.
STW,R1 *TOPOSTAK
STS,R13 *TOPOSTAK SET E-FLAG VALUE.
B *R14 DO EVAL-INPUT OR EXECUTE-TRANSLAT'N.
SORXV B CKSCANOP @ SCAN OPERATOR (ON 1ST COORD). U19-0010
B CKSCANOP @ SCAN OPERATOR. U19-0011
* B XEQCK @ EXECUTE OPERATOR. U19-0012
XEQCK LW,R4 RTARG @ U19-0013
LI,R5 1 SET FOR 1 ELEM (& FOR RANK TEST).
LI,R6 NEWLINE GET END-OF-INPUT CHAR.
LB,R13 *R4,R5 GET RANK...
BEZ XEQCKS SCALAR
AI,R13 -1 ARRAY, VERIFY VECTOR...
BNEZ ERRANK OOPS -- RANK ERROR.
LW,R5 2,R4 GET NO.OF ELEMS...
BEZ XEQCKL NONE, JUST USE END-OF-INPUT CHAR.
CI,R5 512 VERIFY NOT TOO MANY...
BG ERLENGTH OOPS -- LENGTH ERROR.
AI,R4 3 PT AT 1ST VALUE WD.
XEQCKTYP LB,R13 *RTARG
AI,R13 -TYPETEXT VERIFY TEXT VECTOR OR SCALAR...
BEZ XEQCKBUF OK, START MOVING CHARS (RT TO LF).
B ERDOMAIN OOPS -- DOMAIN ERROR.
XEQCKS AI,R4 2 PT AT VALUE WD.
B XEQCKTYP
XEQCKC LB,R6 *R4,R5 GET CHAR.
XEQCKBUF STB,R6 INBUF,R5 PUT CHAR IN INPUT BUFFER.
BDR,R5 XEQCKC LOOP TILL REACHING LEFTMOST CHAR.
LB,R6 *R4 PUT IT IN.
XEQCKL STB,R6 INBUF
LI,R4 0
XW,R4 RTARG DEREFERENCE RT ARG.
BAL,R7 DREF
LI,R4 0
XW,R4 XTEMP TEST FOR COORD TO LEFT OF XEQ-OPER.
BEZ XEQCKR NO, LEAVE NIL ENTRY IN STACK.
STW,R4 0,R1 YES, PUT X-ENTRY IN STACK.
XEQCKR LW,R3 OFFSETR PT TO DESIGNATOR TO BE RE-SCANNED
* WHEN EXECUTE IS COMPLETED.
LI,R13 EFLAG SET E-FLAG.
LI,R14 INPXEQ SET TO ENTER 'INPUT' TRANSLATOR FOR
B STACKQE EXECUTE & STACK Q-ENTRY.
REQUIN STW,R1 TOPOSTAK SAVE STACK PTR.
B INPEVAL DO EVALUATED INPUT AGAIN.
A6 LB,R6 *CURRCS,R3 LOOK AT ITEM BEFORE BRANCH ARROW.
AI,R6 -BOSCODE SHOULD BE BEGINNING-OF-STMT CODE.
BNEZ CXERSYN OOPS -- SYNTAX ERROR.
AI,R3 1 OK, RESTORE PTR IN CASE OF ERROR.
LW,R6 NILCK CK FOR BRANCH VALUE...
BEZ DCSSUSP NONE,DROP CS & SUSPENSION-CLEAR
B CXERSYN OOPS -- SYNTAX ERROR
* YOU CAN'T BRANCH FROM EVAL-INPUT
A9 LI,R4 0 ELIMINATE THE REFERENCE TO THE
XW,R4 CURRCS CODESTRING DATA BLK THAT BROUGHT
AI,R4 -2 THE EVALUATED INPUT.
BAL,R7 DREF
LI,R4 0
XW,R4 NILCK MOVE VALUE ACQUIRED, IF ANY...
BNEZ A9VAL VALUE IS PRESENT.
QETEST LI,R4 EFLAG NO VALUE, CK Q-ENTRY...
CW,R4 0,R1
BAZ REQUIN EVAL-INPUT, RE-REQUEST IT.
STW,R1 TOPOSTAK SAVE STACK PTR IN CASE WS FULL.
XEQEMPTY LW,R1 TOPOSTAK
LI,R11 4
BAL,R7 ALOCBLK ALLOCATE FOR EMPTY VECTOR.
LI,R11 (TYPEINTG**8)+1 TYPE=INTG & RANK=1.
STH,R11 *R4
LI,R11 0 LENGTH=0.
STW,R11 2,R4
A9VAL STW,R4 PTRITEM SET PTR TO VALUE DATA BLK.
LI,R4 X'7FFF' SET STATE PTR TO AIM AT NEXT STATE-
AND,R4 0,R1 ENTRY IN EXECUTION STACK.
AWM,R4 STATEPTR
LI,R3 X'1FFFF' RESTORE CURRENT CODESTRING DATA BLK
AND,R3 1,R1 PTR THAT HAD THE EVAL-INPUT QUAD.
STW,R3 CURRCS
LW,R3 1,R1 RESTORE THAT BYTE OFFSET.
SLS,R3 -17
AI,R1 2 DROP THE Q-ENTRY FROM EXEC. STACK.
LI,R11 EFLAG WAS IT EVAL-INPUT OR EXECUTE...
CW,R11 -2,R1
BAZ QRESCAN EVAL-INPUT.
BAL,R14 QOBS (QUERY OBSERVE SETTING)
LI,R4 0 EXECUTE.
XW,R4 PTRITEM MOVE VALUE PTR OUT OF PTRITEM, AND
XW,R4 0,R1 REPLACE X OR NIL ENTRY...
BEZ A9XEQEND NIL.
AI,R1 -1 X-ENTRY (COORD FOR OPER UP NEXT)
STW,R4 0,R1 PUSH IT BACK INTO STACK.
A9XEQEND LB,R2 *R1 GET TOP CATEGORY (X OR V).
B NXTSCAN RESCAN WHERE EXECUTE ORIGINATED.
QRESCAN LI,R4 0 SET 'PTR' TYPE OF SCAN ITEM.
LB,R2 *R1 GET NEW TOP CAT SURFACED.
B CXPTR,R2 VECTOR ON THAT CATEGORY.
A16 STD,R6 OPER SAVE OPERATOR INFORMATION.
LI,R14 NXTSCAN RETURN TO RESUME SCANNING AFTER
BDR,R3 MONEX MONADIC OPERATOR EXECUTION.
A37 LD,R10 STMASKS-STOPNMCD-STOPNMCD,R6 SET BIT & MASK FOR
* STOP OR TRACE.
LI,R2 CATAPRYM CONVERT TOP CAT TO A-PRIME.
STB,R2 *R1
LW,R4 1,R1 GET V-ENTRY, I.E. DATA BLK PTR.
LI,R7 1
LB,R7 *R4,R7 IS ITS RANK = 2...
AI,R7 -2
BNEZ A37ST NO, CK STOP OR TRACE VECTOR.
AI,R10 -STOPBIT YES, CK SIDETRACK TBL.
BNEZ CXERRANK OOPS -- RANK ERR (TRACE TBL).
LW,R11 3,R4 GET 2ND LENGTH WD...
BEZ A37ECLR ZERO, CLEAR OUT ERR-CTRL TABLE.
AI,R11 -2
BNEZ A37EQ1Z NOT 0 OR 2, 1ST LENGTH WD MUST = 0
LW,R11 2,R4 TWO, GET 1ST LENGTH WD...
BEZ A37ECLR ZERO, CLEAR OUT ERR-CTRL TABLE.
LB,R6 *R4 NZ, GET TYPE OF DATA BLK.
CI,R6 TYPEINTG
BE A37EINTG INTEGER TYPE.
STW,R5 FDEFPTR NON-INTG TYPE, SAVE PTR TO &
MTW,1 1,R5 BUMP REF-CNT OF FUNCT.DESCRIPTOR.
SLS,R11 1 = # WDS FOR INTG VERSION OF TABLE.
AI,R11 4 + 2-WD HDR O 2 LENGTH WDS.
BAL,R7 ALOCBLK ALLOC DATA BLK FOR INTG TYPE TABLE.
STW,R4 RESULT SAVE PTR TO IT.
LI,R7 (TYPEINTG**8)+2
STH,R7 *RESULT SET TYPE = INTEGER & RANK = 2.
LW,R10 1,R1 GET PTR TO NON-INTG TABLE AGAIN.
LI,R11 2
STW,R11 3,R4 SET 2ND LENGTH WD = 2.
AI,R10 2 PT AT NON-INTG TABLE'S 1ST LENGTH WD
LW,R11 *R10 AND GET THAT LENGTH IN ORDER TO
STW,R11 2,R4 SET 1ST LENGTH WD OF INTG TBL.
SLS,R11 1 GET # ELEMENTS FOR ERR-CTRL TBL.
AI,R4 4 PT AT 1ST INTG ELEMENT POSITION.
AI,R6 -TYPEREAL TEST TYPE OF NON-INTG TBL...
BEZ A37EREAL REAL.
AI,R6 TYPEREAL-TYPELOGL
BNEZ CXERDOM ROTTEN -- DOMAIN ERR.
AI,R10 1 LOGL, PT AT LAST LENGTH WD.
A37ELWD LI,R13 32 32 LOGL BITS PER WD.
AI,R10 1
LW,R7 *R10 GET NEXT WD OF LOGL DATA.
A37ELBIT LI,R6 0
SLD,R6 1 GET NEXT LOGL VALUE -- 1 OR 0.
STW,R6 0,R4 SET INTEGER VALUE.
AI,R4 1 PT AT NEXT WD OF INTG DATA BLK.
AI,R11 -1 IS INTG ERR-CTRL TBL READY YET...
BEZ A37ERDY YES.
BDR,R13 A37ELBIT NO, LOOP TILL LOGL WD EXHAUSTED
B A37ELWD THEN GET ANOTHER. BULL-POOP.
A37EREAL AI,R10 2 PT AT NEXT REAL VALUE.
LD,R6 *R10 GEDDIT.
BAL,R5 F2I @ CONVERT FL.PT VALUE TO INTEGER...
B CXERDOM @ WON'T -- DOMAIN ERR.
STW,R7 0,R4 @ OK, SET INTEGER VALUE.
AI,R4 1 PT AT NEXT WD OF INTG DATA BLK.
BDR,R11 A37EREAL LOOP TILL INTG ERR-CTRL TBL READY.
A37ERDY LI,R5 0 REMOVE REF TO FUNCTION DESCRIPTOR &
XW,R5 FDEFPTR SET R5 TO PT AT IT AGAIN.
MTW,-1 1,R5
LI,R4 0 MOVE PTR TO INTG ERR-CTRL TABLE
XW,R4 RESULT INTO R4.
B A37ESET
A37EINTG MTW,1 1,R4 BUMP REF-CNT OF ERR-CTRL TBL.
A37ESET XW,R4 XSIZOFF,R5 INSTALL PTR TO ERR-CTRL IN XSIZE WD.
LI,R7 X'E0000' DID THE ERR-CTRL FUNCTION HAVE AN
AND,R7 R4 OLD ERR-CTRL TABLE...
BEZ A37ENEW NO.
STS,R7 XSIZOFF,R5 YES, SET XSIZE VALUE BACK IN.
A37EOLD LI,R7 NXTSCANU RESUME CODESTRING SCAN AFTER
B DREF DEREFERENCING OLD ERR-CTRL TBL.
A37ENEW LW,R7 R4 GET XSIZE VALUE.
SLS,R7 17 MOVE IT UP ABOVE ADDR.FIELD.
STS,R7 XSIZOFF,R5 SET XSIZE VALUE BACK IN THERE.
BDR,R3 NXTSCAN RESUME CODESTRING SCAN.
A37EQ1Z LW,R11 2,R4 IS 1ST LENGTH WD ZERO...
BNEZ CXERLEN NO, 2ND LENGTH WD BAD -- LENGTHERR
A37ECLR LW,R4 XSIZOFF,R5 GET OLD XSIZE WD FOR FUN.DESCRIPTOR.
CI,R4 X'E0000' CK FOR PTR TO ERR-CTRL TBL...
BAZ NXTSCANU NO (ALREADY CLEARED) RESUME SCAN.
SLS,R4 -17 YES,GET XSIZE VALUE ONLY.
XW,R4 XSIZOFF,R5 REPLACE OLD XSIZE WD &
B A37EOLD DEREF OLD ERR-CTRL TBL.
A37ST BAL,R7 NUMSV @ CK NUMERIC SCALAR OR VECTOR...
AI,R4 -1 @ SCALAR, PT AT HEADER + 2.
* @ VECTOR.
A37CLR STW,R10 STSET SAVE STOP OR TRACE FLAG SETTING.
LI,R10 X'10000' IS THIS A LOCKED FUNCTION...
CW,R10 0,R5
BANZ NXTSCANU YES, RESUME SCAN.
LI,R10 0 CLEAR FOR SELECTIVE LOADS, BELOW.
LW,R13 NFLOFF,R5 NO.OF FUN LINE PTRS; R5 = FUNDEF PTR
BEZ NXTSCANU NO LINES, RESUME SCAN.
STW,R13 NFL4ST SAVE IT FOR STOP OR TRACE BOUND CK.
AI,R5 LINSTART-1 PT JUST BEFORE LINE 1 AND
STW,R5 FDLPTR SAVE THAT LOC.
AI,R5 1 PT AT LINE 1.
A37CLREM LS,R10 0,R5 CLEAR OLD STOP OR ELSE TRACE
STW,R10 0,R5 FLAGS.
AI,R5 1
BDR,R13 A37CLREM
AI,R12 0 TEST FOR EMPTY VECTOR.
BEZ NXTSCANU YES, RESUME SCAN.
LW,R10 STSET NO, GET STOP OR ELSE TRACE FLAG.
A37VT B A37VT,R6 @ VECTOR ON NUMERIC TYPE:
B A37LOGL @ 1 -- LOGL
B A37INTG @ 2 -- INTG
B A37REAL @ 3 -- REAL
* B A37XSEQ @ 4 -- INDEX SEQUENCE
A37XSEQ LI,R7 A37X @ SET RETURN TO A37X, SEE ALSO A37DECR
STW,R7 RSTYPE
LW,R6 0,R4 GET INDEX PARAMETERS
LW,R7 1,R4 AND
STD,R6 XPARAMS SAVE THEM.
LI,R4 1 START INDEX SEQUENCE
A37X LW,R7 R4
MW,R7 XMULT CALCULATE CORRESPONDING VALUE.
AW,R7 XADD
B A37Z CK VALUE AS A LINE NO.
A37REAL LI,R7 A37R SET RETURN TO A37R, SEE ALSO A37DECR
STW,R7 RSTYPE
AI,R4 1 PT AT 1ST DBLWD (ODD OR EVEN IS OK).
SLS,R4 -1 = DBLWD LOC OF 1ST VALUE.
A37R LD,R6 0,R4 GET REAL VALUE FOR CONVERSION.
BAL,R5 F2I CONVERT FLOATING TO INTEGER...
B CXERDOM NO -- DOMAIN ERROR.
B A37Z YES, CHECK LINE NO.
A37INTG LI,R7 A37I SET RETURN TO A37I, SEE ALSO A37DECR
STW,R7 RSTYPE
A37I LW,R7 0,R4 GET INTEGER VALUE.
A37Z BLEZ A37DECR NEG OR ZERO IS IGNORED, AND SO ARE
CW,R7 NFL4ST
BG A37DECR VALUES ABOVE LAST LINE NO.
AWM,R10 *FDLPTR,R7 OK, SET THAT FLAG BIT.
A37DECR AI,R4 1 PT AT NEXT VALUE.
BDR,R12 *RSTYPE LOOP BACK ACCORDING TO TYPE OF DATA.
BDR,R3 NXTSCAN RESUME SCAN.
A37LOGL AWM,R6 FDLPTR PTS AT LINE 1'S ENTRY NOW.
A37WD LI,R5 32 32 BITS PER WORD.
LW,R13 0,R4 GET LOGICAL VALUE(S).
BGEZ A37LDECR 1ST BIT NOT A 1.
A37L1 AWM,R10 *FDLPTR SET STOP OR TRACE FLAG FOR LINE 1.
BDR,R3 NXTSCAN RESUME SCAN.
A37SHIFT SLS,R13 1 TEST NEXT BIT...
BOV A37L1 1, LINE 1 IS TO BE FLAGGED.
A37LDECR AI,R12 -1 DECR ELEMENT COUNT...
BEZ NXTSCANU 0, RESUME SCAN; NO TRACE OR STOP.
BDR,R5 A37SHIFT DECR BIT COUNT...
AI,R4 1 0, USE NEXT DATA WORD.
B A37WD
A8 LI,R7 A8SHOW RETURN FROM 'STMTV' TO 'A8SHOW'
STMTV LI,R5 0 MOVE NILCK INTO R5.
XW,R5 NILCK
BEZ 0,R7 EXIT IF NIL.
LW,R12 ACFLAG NON-NIL (V-ENTRY), IF AN ASSIGNMENT
BEZ STMTADD WASN'T JUST COMPLETED PUT V IN
* THE S-ENTRY.
STMTTRCK LW,R12 OBSERVE DID WE OBSERVE...
BNEZ STMTDREF YES, SKIP TRACE CHECK.
LI,R12 TRACEBIT IS THIS STMT BEING TRACED...
CW,R12 0,R1
BANZ STMTADD YES, PUT V-ENTRY IN THE S-ENTRY.
STMTDREF LW,R4 R5 NO, PT AT V-ENTRY'S DATA BLK.
B DREF DEREFERENCE IT (DREF EXITS 'STMTV'
* SINCE DREF ALSO USES R7 AS LINK).
STMTADD XW,R5 0,R1 POP S-ENTRY AND PUSH V-ENTRY.
AI,R5 1 INCR S-ENTRY'S COUNT.
BAL,R4 STACKUP ALLOC 1 MORE WD FOR EXEC. STACK.
STW,R5 0,R1 PUSH NEW S-ENTRY CATEGORY WD.
B 0,R7 EXIT.
A8SHOW LI,R6 A8WRAPCS RETURN FROM 'STMTSHOW' TO 'A8WRAPCS'
STMTSHOW LI,R13 X'FFFF' TEST S-ENTRY'S COUNT.
AND,R13 0,R1
BEZ NOSHOW ZERO, NO STMT DISPLAY, NO DEREF-ING.
LW,R4 OBSERVE DID WE OBSERVE THIS LINE...
BEZ STMTSHOM NO.
CI,R13 1 YES, SINGLE VALUE...
BE DONTSHOW YEP, ITS BEEN SHOWN ALREADY.
STMTSHOM STW,R1 TOPOSTAK SAVE STACK PTR.
LI,R3 0 PRESET COLUMN INDICATOR.
LI,R12 TRACEBIT IS THIS A TRACED LINE...
CW,R12 0,R1
BAZ SHOWEM NO.
AI,R4 0 YES, BUT WAS IT OBSERVED...
BNEZ SHOWEM YEP, JUST SHOW MIXED OUTPUT.
STW,R6 LINKT SAVE LINK.
LW,R1 STATEPTR YES, PT AT ITS F-ENTRY.
BAL,R14 FUNLDISP DISPLAY FUNC.NAME & LINE NUMBER.
LW,R6 LINKT RESTORE LINK.
LW,R1 TOPOSTAK PT AT THE S-ENTRY AND
INT,R13 0,R1 GET ITS COUNT AGAIN.
SHOWEM BAL,R14 MIXEDOUT @ STMT DISPLAY (MIXED OUTPUT).
B CXERIO @ ERR RETURN -- I/O ERROR.
LW,R1 TOPOSTAK @ OK RETURN, RESTORE STACK PTR.
DONTSHOW LW,R12 0,R1 SAVE S-ENTRY CATEGORY WORD.
AI,R1 1 PT AT 1ST V-ENTRY UNDER S-ENTRY.
SENTDREF LI,R4 0 MOVE V-ENTRY'S
XW,R4 0,R1 DATA BLK PTR INTO R4.
BAL,R7 DREF DEREFERENCE.
AI,R1 1 PT AT NEXT WD IN EXECUTION STACK.
BDR,R13 SENTDREF
B 0,R6 EXIT, R1 PTS AT F-ENTRY.
NOSHOW LW,R12 0,R1 SAVE S-ENTRY.
AI,R1 1 PT AT F-ENTRY.
B 0,R6 EXIT.
A8WRAPCS LI,R6 SCANBOS SCAN ITEM WAS BEGINNING-OF-STMT.
WRAPCS LI,R4 0 MOVE CODESTRING DATA BLK PTR
XW,R4 CURRCS INTO R4.
AI,R4 -2 PT AT ITS HEADER.
BAL,R7 DREF DEREFERENCE.
AI,R6 -SCANBOS WHICH SCAN ITEM...
BEZ NONBRN BEGINNING OF STMT.
LI,R7 X'FFFF' BRANCH ARROW.
AND,R7 0,R1 IS F-ENTRY THE FINAL ENTRY...
BNEZ LOBRNCK NO, FUNCTION-STATE.
CXTHRU STW,R1 TOPOSTAK SAVE STACK PTR.
B INPDIR GO TO DIRECT INPUT HANDLER.
LOBRNCK LW,R7 BRNVAL GET BRANCH VALUE--
BGZ GFL ABOVE ZERO, TRY TO GET FUNC LINE.
B FEXIT TOO LOW, EXIT THE FUNCTION.
NONBRN CI,R12 FLINFLG WAS STMT A FUNC LINE...
BANZ NXTFLIN YES, TRY TO GET NEXT FUNC LINE.
B CXTHRU NO.
NXTFLIN LW,R7 1,R1 GET CURRENT LINE NO.
SLS,R7 -17
AI,R7 1 INCR IT.
GFL LI,R6 0 MOVE CURRLINO AND FDEFPTR INTO R6...
XW,R6 1,R1
BNEZ GF NZ, WE'VE GOT A GOOD F-ENTRY.
B SUSPCLR 0, NO GOOD (I.E. SI DAMAGE).
GF CW,R7 NFLOFF,R6 DOES LINE NO. EXCEED HIGHEST ONE...
BLE FLINE NO, WE'VE GOT A FUNC. LINE.
B FXRES YES, START EXIT FROM FUNCTION.
FEXIT LI,R6 0 MOVE CURRLINO AND FDEFPTR INTO R6...
XW,R6 1,R1
BEZ SUSPCLR 0 IF F-ENTRY HAS HAD SI DAMAGE.
FXRES LW,R5 RESOFF,R6 GET NAME PTR FOR RESULT.
BLZ FXCALL (NONE, LEAVE PTRITEM = ZERO.)
LI,R3 X'1FFFF'
AND,R3 *SYMT,R5 EXTRACT REFERENT (DBPTR OR NIL).
STW,R3 PTRITEM
BEZ FXCALL (NIL)
MTW,1 1,R3 IF DBPTR, INCR DATA BLK REF COUNT.
FXCALL LI,R3 X'1FFFF' EXTRACT CALLPTR FROM F-ENTRY AND
AND,R3 2,R1 RESTORE CURRCS TO PT AT THE OLD
STW,R3 CURRCS CODESTRING DATA BLK (+2).
LI,R3 0 CLEARING EXTRA REF, GET CALLBYTE--
XW,R3 2,R1 RESTORING R3 TO THE BYTE OFFSET
SLS,R3 -17 EXISTING WHEN THE CALL OCCURRED.
LI,R14 X'7FFF' EXTR OFFSET TO NEXT STATE-ENTRY
AND,R14 0,R1 AND SET STATE POINTER TO PT AT
AWM,R14 STATEPTR THAT ENTRY AGAIN.
LW,R14 OBSFLAG IS OBSERVE-CMD IN EFFECT...
BEZ FXDEREFF NO.
LW,R4 STATEPTR YES, PT AT CALLING STATE ENTRY.
LI,R2 CATF
FXFINDF CB,R2 *R4 LOOK FOR AN F-STATE...
BE FXF OK.
LI,R5 X'7FFF' NOPE, TRY NEXT.
AND,R5 0,R4
AW,R4 R5
B FXFINDF
FXF LI,R5 PENDFLAG PENDENT OR SUSPENDED...
CW,R5 0,R4
BAZ FXOBSERV SUSPENDED -- OBSERVE DIRECT LINE.
LI,R5 TRACEBIT PENDENT.
CW,R5 -1,R4 WAS THIS A TRACED LINE...
BANZ FXOBSERV YES -- OBSERVE TRACED FUN.LINE.
LI,R14 0 NO, DON'T OBSERVE THIS LINE.
FXOBSERV STW,R14 OBSERVE OBSERVATION SETTING.
FXDEREFF MTW,-1 1,R6 DECR REF-COUNT OF FUNDEF DATA BLK.
AI,R1 4 POP DOWN TO WD FOLLOWING THE COUNT--
LW,R14 -1,R1 NO.OF SHADOW PAIRS.
BEZ FPOPPED NONE, F-ENTRY IS POPPED.
LI,R7 FUND RETURN FROM 'DREF' TO 'FUND'.
FUNSHAD LW,R5 0,R1 GET SHADOWED NAME PTR.
LI,R4 0
XW,R4 1,R1 GET SHADOWED REFERENT INDICATOR.
AI,R1 2 POP THAT SHADOW PAIR.
XW,R4 *SYMT,R5 UNSHADOW.
AND,R4 X1FFFF EXTR. DBPTR (IF ANY) FOR LOCAL.
BNEZ DREF DEREFERENCE DBPTR (REMOVES LOCAL).
FUND BDR,R14 FUNSHAD
FPOPPED LI,R4 0 CLAIM CURRENT SCAN ITEM = PTR
LB,R2 *R1 SET TOP CAT FOR ENTRY SURFACED.
LW,R14 PTRITEM TEST FOR FUNCTION RESULT...
BNEZ CXPTR,R2 YES, DO CONTEXT ANALYSIS FOR IT.
B NORESULT,R2 NO, VECTOR ON THE TOP CAT.
LOOKY LB,R6 *CURRCS,R3 CK ITEM TO LEFT OF FUNCTION CALL...
CI,R6 BOSCODE
BE CXBOS BEGINNING OF STMT, OK.
CI,R6 SEMICODE
BE CXSEMI SEMICOLON, OK (EMPTY SUBSTMT VALUE).
CI,R6 DUMMYCD CHECK FOR DUMMY CODE
BNE CXERNOR NO RESULT-ERROR
BDR,R3 LOOKY SKIP DUMMY AND KEEP LOOKING
NORESULT B CXERNOR @ V
B NXTSCANU @ A-PRIME (JUST RETURNED FROM A CATCH)
B CXERNOR @ O
B CXERNOR @ X
B CXERNOR @ B
B CXERNOR @ P
BDR,R3 LOOKY @ S -- LOOK AHEAD FOR BOS OR SEMI.
BDR,R3 LOOKY @ Q -- LOOK AHEAD FOR BOS (SEMI FAILS)
B CXERNOR @ D
* B CXERNOR @ A (CAN'T GET HERE FROM THERE)
*
* NOTE-- R12 CONTAINS A FLAG-BIT (FLINFLG) = 1 IF FLINE IS REACHED VIA
* A STMT WITHIN THE FUNCTION OR VIA INVOKING THE FUNCTION.
* IT IS 0 IF FLINE IS REACHED VIA A DIRECT BRANCH STMT.
*
FLINE SLS,R6 -1 (FDEFPTR IS EVEN, SO THIS IS OK).
STH,R7 R6 PUT NEW LINE NO. IN PLACE OF CURRENT
SLS,R6 1 LINE NO. AND PUT THE NEW
STW,R6 1,R1 'CURRLINO,FDEFPTR' WD IN F-ENTRY.
FLINE1 AW,R7 R6 GET THAT LINE PTR ENTRY FROM THE
LW,R7 LINSTART-1,R7 FUNCTION DESCRIPTOR.
CI,R7 STOPBIT IS ITS STOP FLAG SET...
BAZ FGO NO.
CI,R12 FLINFLG YES, OVERRIDE THE STOP...
BAZ FGO YEP, DIRECT BRANCH DOESN'T STOP.
LI,R5 -PENDFLAG-1 NOPE, GET 1'S COMPLEMENT OF THE
AND,R5 0,R1 PENDENT FLAG-- I.E. TO MAKE THIS
STW,R5 0,R1 F-ENTRY A STOPPED FUNCTION.
STW,R1 TOPOSTAK SAVE STACK PTR.
B SHOWSTOP DISPLAY THE STOP, R1 PTS AT F-ENTRY.
FGO LI,R13 PENDFLAG SET F-ENTRY TO BE PENDENT.
STS,R13 0,R1
LI,R2 0 SET FOR NO OBSERVATION.
LI,R12 TRACEBIT EXTRACT TRACE FLAG FROM LINE PTR
AND,R12 R7 ENTRY...
BEZ FLSETOBS O--NO OBSERVATION OF THIS LINE.
LW,R2 OBSFLAG NZ--USE OBSERVE-CMD SETTING.
FLSETOBS STW,R2 OBSERVE =0 IF NO OBSERVATION & =-1 IF YES.
OR,R12 FSENTRY COMPOSE S-ENTRY FOR FUN.LINE (CNT=0)
STW,R12 -1,R1 PUT S-ENTRY ABOVE F-ENTRY IN STACK.
AND,R7 X1FFFF EXTR. PTR TO CODESTRING DATA BLK +2.
STW,R7 CURRCS THAT IS LOC OF CURRENT CODESTR. NOW.
MTW,1 -1,R7 INCR REF-COUNT OF CODESTRING DATA BK
LH,R3 *CURRCS GET OFFSET TO RTMOST CODE DESIGNATOR
LI,R2 CATS TOP CAT IS AN S-ENTRY.
AI,R1 -1 SET STACK PTR TO AIM AT NEW S-ENTRY
LW,R6 BREAKFLG TEST FOR BREAK...
BEZ NXTSCAN NO -- START SCANNING.
B CXBREAK YES -- BREAK OR HANG-UP.
A5 LB,R4 *CURRCS,R3 GET ITEM TO LEFT OF BRANCH ARROW...
AI,R4 -BOSCODE
BEZ A5NILCK BEGINNING OF STMT, OK.
AI,R4 BOSCODE-SEMICODE
BEZ A5NILCK SEMICOLON, OK.
B CXERSYN ELSE -- SYNTAX ERROR.
A5NILCK AI,R3 1 BACK TO BRANCH ARROW IN CASE ERROR.
LW,R4 NILCK TEST NILCK...
BNEZ A5C23 NON-NIL, A5 CASE 2 OR 3.
BAL,R6 STMTSHOW IF NEC. DISPLAY STMT VALUES, POP THE
* S-ENTRY, AND DEREFERENCE VALUES.
DCSSUSP LI,R4 0
XW,R4 CURRCS DEREFERENCE CURRENT CODESTRING D.B.
AI,R4 -2
LI,R7 SUSPCLR AND THEN DO SUSPENSION-CLEAR.
B DREF
A5C23 BAL,R7 NUMSV @ CK NUMERIC SCALAR OR VECTOR...
BDR,R4 A5C3 @ SCALAR -- DEFINITELY NON-EMPTY.
AI,R12 0 @ VECTOR -- EMPTY...
BEZ A5C2 YES.
A5C3 LI,R5 A5BSET-1 NO, SET LINK TO IVAL SO THAT
* NON-INTEGER EXIT WILL GIVE ERROR
* AND INTEGER EXIT WILL BE TO A5BSET
IVAL B IVAL,R6 @ VECTOR ON NUMERIC TYPE:
B ILOGL @ 1 -- LOGL
B IINTG @ 2 -- INTG
B IREAL @ 3 -- REAL
* B IXSEQ @ 4 -- XSEQ (INDEX SEQUENCE)
IXSEQ LW,R7 0,R4 @ JUST ADD THE 2 PARAMETERS.
AW,R7 1,R4
B 1,R5 INTEGER EXIT.
IREAL AI,R4 1 PT AT VALUE WD (EVEN OR ODD WD OK).
SLS,R4 -1 PT AT VALUE DBLWD.
LD,R6 0,R4 GET VALUE FOR FLOAT-TO-INTG CONV.,
B F2I IF NON-INTEGER, F2I EXITS 0,R5
* IF INTEGER (WITHIN FUZZ) EXIT 1,R5
ILOGL LI,R7 0 ASSUME VALUE IS 0.
LW,R6 0,R4 GET LOGICAL.
BGEZ 1,R5 IT IS 0, INTEGER EXIT.
LI,R7 1
B 1,R5 NO, USE 1, INTEGER EXIT.
IINTG LW,R7 0,R4 GET INTEGER
B 1,R5 INTEGER EXIT.
B CXERDOM @ NON-INTEGER BRANCH -- DOMAIN ERROR.
A5BSET STW,R7 BRNVAL @ SAVE BRANCH VALUE.
LI,R5 0
XW,R5 NILCK MOVE NILCK INTO R5.
BAL,R7 STMTTRCK HANDLE TRACE CHECK.
LI,R6 WRAPCS RETURN TO CODESTRING WRAP-UP FROM
B STMTSHOW STMT DISPLAY AND DEREFER--
* NOTE THAT R6 WILL NOT = SCANBOS.
A5C2 LI,R4 0
XW,R4 NILCK MOVE NILCK INTO R4.
LI,R7 NXTSCAN RESUME SCAN AFTER
BDR,R3 DREF DEREFING THE EMPTY VECTOR.
A31 B A31VORP,R4 VECTOR ON SCANITEM VN OR PTR:
A31VORP B A31NILCK @ 0 -- PTR.
* B A31VN @ 1 -- VN.
A31VN AND,R5 X1FFFF @ EXTR. DATA BLK PTR FROM REF-IND. WD.
STW,R5 PTRITEM
MTW,1 1,R5 INCR REF COUNT OF THAT DATA BLOCK.
A31NILCK BAL,R14 QNILCK QUERY SUBSCRIPTING.
DYFUN LW,R5 0,R1 PULL D-ENTRY. USE A30 TO DROP IT
* FROM THE EXECUTION STACK.
MTW,-1 1,R5 DEREFERENCE IT TEMPORARILY.
A30 AI,R1 1 DROP A-PRIME (OR D) ENTRY.
A29 LW,R7 0,R1 PULL V-ENTRY.
STW,R7 RTARG SAVE AS RIGHT ARGUMENT.
AI,R1 1 DROP V-ENTRY FROM EXECUTION STACK.
A26 AND,R5 X1FFFF EXTR. FUNDEF PTR FROM REF-IND. WD
* OR FROM PULLED D-ENTRY.
MTW,1 1,R5 INCR REF COUNT OF FUNDEF DATA BLK.
STW,R5 FDEFPTR
LW,R8 XSIZOFF,R5 GET XSIZE WD.
CI,R8 X'E0000' DOES IT CONTAIN AN ERR-CTRL TBL PTR
BAZ FXSIZE NO.
SLS,R8 -17 YES, SHIFT XSIZE DOWN.
FXSIZE STW,R8 XSIZE SAVE EXEC.STACK SIZE FOR FUN.CALL.
SW,R1 XSIZE ALLOC EXEC.STACK SPACE FOR F-ENTRY.
CW,R1 STKLIMIT DOES IT FIT...
BG FBUILD YES, BUILD F-ENTRY.
STW,R1 LOCNEED SAVE LOC NEEDED.
AW,R1 XSIZE RESTORE STACK PTR IN CASE WS FULL.
BAL,R8 CTEST GET ENUF MORE COMMON, IF POSSIBLE.
B CXERWS WS FULL.
FBUILD LW,R5 FDEFPTR PT AT FUNCTION DESCRIPTOR DATA BLK.
AW,R1 XSIZE RESTORE STACK POINTER (BEFORE THE
STW,R1 TOPOSTAK F-ENTRY) AND SAVE THAT LOC.
LW,R7 RESOFF,R5 GET RESULT NAME POINTER...
BLZ FLF NO RESULT.
LI,R4 0 RESULT, USE NO REFERENT.
BAL,R6 SHADOW
FLF LW,R7 LFOFF,R5 GET LF DUMMY NAME POINTER...
BLZ FRT NO LF DUMMY.
LI,R4 0 LF DUMMY, USE AS REFERENT
XW,R4 LFARG THE LEFT ARGUMENT.
BAL,R6 SHADOW
FRT LW,R7 RTOFF,R5 GET RT DUMMY NAME POINTER...
BLZ FNFL NO RT DUMMY.
LI,R4 0 RT DUMMY, USE AS REFERENT
XW,R4 RTARG THE RIGHT ARGUMENT.
BAL,R6 SHADOW
FNFL AW,R5 NFLOFF,R5 PT AT THE FUNDEF WORD THAT FOLLOWS
AI,R5 LINSTART+1 THE 'LOCALS AND LABELS' WORD.
LW,R8 -1,R5 GET LOCALS AND LABELS COUNTS.
BEZ FNSHAD NO LOCALS OR LABELS.
LI,R9 X'FFFF'
AND,R9 -1,R5 GET NO.OF LABELS.
BEZ FLCLS NONE, TRY LOCALS.
LI,R6 FLBL RETURN FROM 'SHADOW' TO 'FLBL'.
FLBL AI,R5 2 PT AT WD AFTER SHADOW PAIR.
LW,R7 -2,R5 GET NAME POINTER
LW,R4 -1,R5 GET REFERENT INDICATOR FOR LABEL.
MTW,1 1,R4 INCR REF COUNT OF LABEL'S DATA BLK.
BDR,R9 SHADOW
BAL,R6 SHADOW SHADOW LAST LABEL
FLCLS LH,R9 R8 GET NO.OF LOCALS.
BEZ FNSHAD NO LOCALS.
LI,R6 FLCL RETURN FROM 'SHADOW' TO 'FLCL'.
AI,R9 1 FAKE AN EXTRA LOCAL FOR LOOPING.
SLS,R5 1 USE HALFWORD RESOLUTION.
FLCL LI,R4 0 NO REFERENT FOR LOCAL SHADOWING.
LH,R7 0,R5 GET LOCAL NAME PTR (EXCEPT LAST TRY)
AI,R5 1 PT AT NEXT HALFWORD.
BDR,R9 SHADOW
FNSHAD LW,R13 TOPOSTAK CALC. NO.OF SHADOW WORDS IN STACK.
SW,R13 R1
SLS,R13 -1 USE NO.OF SHADOW PAIRS.
STW,R13 -1,R1 PUT IT IN STACK.
SLS,R3 17 MOVE CALLBYTE TO PROPER FIELD.
STS,R3 CURRCS OR IT INTO CALLPTR WORD.
LI,R13 0
XW,R13 CURRCS MOVE CALLBYTE--CALLPTR
STW,R13 -2,R1 INTO THE STACK.
LI,R6 0
XW,R6 FDEFPTR MOVE FDEFPTR
AI,R6 X'20000' AND CURRLINO (=1)
STW,R6 -3,R1 INTO THE STACK.
AI,R1 -4 PT AT TOP OF F-ENTRY.
STW,R1 TOPOSTAK SAVE IT.
LW,R13 STATEPTR GET OLD STATE PTR.
SW,R13 TOPOSTAK CALC. OFFSET FROM F-ENTRY TO NEXT
* STATE-ENTRY.
OR,R13 FPENTRY FUNCTION-STATE CATEGORY, PENDING.
STW,R13 0,R1 SET F-ENTRY.
STW,R1 STATEPTR UPDATE STATE PTR TO NEW F-ENTRY.
LI,R12 FLINFLG FAKE S-ENTRY SO STOP ON 1 WILL WORK.
LI,R7 1 SET LINE NO. = 1.
LW,R13 NFLOFF,R6 GET NO.OF FUNC LINES...
BGZ FLINE1 OK, GET LINE 1.
STW,R13 PTRITEM ZERO, SET PTRITEM NIL.
B FXCALL EXIT THIS FUNCTION CALL.
A14 INT,R11 0,R1 EXTR COUNT FROM THE B-ENTRY.
BAL,R13 GENLIST GENERATE THE LIST DATA BLOCK.
LI,R2 CATX SET X CATEGORY.
STB,R2 PTRITEM
LI,R12 0
STW,R12 NILCK ELIMINATE EXTRA REFS
STW,R12 RESULT
AI,R3 -1 SET TO RESUME CODESTRING SCAN.
CXPUSHDP CW,R1 STKLIMIT IS THERE ROOM FOR 1 MORE WD...
BG CXPUSHIT YES.
STW,R1 LOCNEED NO, SAVE LOC NEEDED (ABOVE LIMIT).
BAL,R8 CTEST GET MORE COMMON, IF POSSIBLE.
B CXERWS WS FULL.
CXPUSHIT XW,R12 PTRITEM CLEAR & GET DB PTR & ITS CATEGORY.
STW,R12 -1,R1 STACK IT.
BDR,R1 NXTSCAN FIX STACK PTR & GO SCAN.
A15 LW,R12 NILCK GET V-ENTRY...
BNEZ A15OK OK.
B CXERSYN NIL -- SYNTAX ERROR.
A15OK LI,R11 X'FFFF' EXTRACT THE COUNT FIELD OF
AND,R11 0,R1 THE P-ENTRY.
BEZ A15ONE IF 0, USE ONE VALUE PTR (IN NILCK).
LI,R13 A15LIST NZ, USE LIST DATA BLOCK PTR.
B GENLIST GENERATE THE LIST DATA BLOCK.
A15ONE STW,R12 PTRITEM SET PTR ITEM.
AI,R1 1 PT AT ENTRY IN EXEC. STACK AFTER P.
A15LIST LB,R2 *R1 GET NEW TOP-OF-STACK CATEGORY.
A15PAREN BAL,R6 CXPVSET SET UP AND RESCAN FOR PTR ITEM.
CXDOT CI,R2 CATO TOP CAT AN O...
BNE CXERSYN NO -- SYNTAX ERROR.
INT,R13 0,R1 YES, EXTRACT OPTYPE FROM O ENTRY.
CLM,R13 DYSCLRS IS IT ONE DYADIC SCALAR...
BCS,9 CXERSYN NO -- SYNTAX ERROR.
AI,R3 -1 YES -- BACK UP TO NEXT SCAN ITEM.
LB,R6 *CURRCS,R3 GET IT.
CLM,R6 DYSCLRS IS IT A DYADIC SCALAR...
BCR,9 A21 YES, ENTER ACTION ROUTINE.
CI,R6 SMOCODE NO, IS IT A SMALL CIRCLE...
BNE CXERSYN NO -- SYNTAX ERROR.
A21 SLS,R6 8 OK, PUT IT IN UPPER BYTE OF
AWM,R6 0,R1 OPTYPE FIELD OF THE O ENTRY.
BDR,R3 NXTSCAN RESUME CODESTRING SCAN.
CXAP B A4 BRN -- A-PRIME ENTRY @
B A10 BOS -- A-PRIME ENTRY @
B A4 LP -- A-PRIME ENTRY @
B A4 LB -- A-PRIME ENTRY @
* B A10 SEMI-- A-PRIME ENTRY @
A10 STW,R4 ACFLAG SET ACFLAG NON-NIL. @
A4 AI,R1 1 DROP A-PRIME ENTRY.
A3 LI,R12 0
XW,R12 0,R1 PICK OUT THE V-ENTRY AND
STW,R12 NILCK PUT IT IN NILCK.
AI,R1 1 DROP IT FROM THE EXECUTION STACK.
LB,R2 *R1 GET SURFACED CATEGORY, I.E. TOP CAT.
B ZRESCAN,R2 RESCAN FOR TERMINATOR CLASS ITEM.
CXBE B CXERSYN BRN -- B ENTRY @
B CXERSYN BOS -- B ENTRY @
B CXERSYN LP -- B ENTRY @
B A14 LB -- B ENTRY @
* B A11 SEMI-- B ENTRY @
A11 LW,R12 NILCK GET V ENTRY OR NIL @
CXPLENT XW,R12 0,R1 EXCHANGE (I.E. POP,SAVE, AND PUSH)
LI,R13 0
STW,R13 NILCK ELIMINATE ANY EXTRA REF TO NEW V.
AI,R12 1 INCR COUNT.
AI,R3 -1 SET TO RESUME CODESTRING SCAN.
CXPUSHC CW,R1 STKLIMIT IS THERE ROOM FOR 1 MORE WD...
BG CXPUSHOK YES.
STW,R1 LOCNEED NO, SAVE LOC NEEDED (ABOVE LIMIT).
BAL,R8 CTEST GET MORE COMMON, IF POSSIBLE.
B CXERWS WS FULL.
CXPUSHOK STW,R12 -1,R1 STACK THE WD.
BDR,R1 NXTSCAN FIX STACK PTR & GO SCAN.
CXPE B CXERSYN BRN -- P ENTRY @
B CXERSYN BOS -- P ENTRY @
B A15 LP -- P ENTRY @
B CXERSYN LB -- P ENTRY @
* B A12 SEMI-- P ENTRY @
A12 LW,R12 NILCK GET V ENTRY... @
BNEZ CXPLENT YES, PUSH LIST ENTRY.
B CXERSYN NO -- SYNTAX ERROR.
CXSE BDR,R3 A5 BRN -- S ENTRY (LOOK AHEAD NEXT) @
B A8 BOS -- S ENTRY @
B CXERSYN LP -- S ENTRY @
B CXERSYN LB -- S ENTRY @
* B A13 SEMI-- S ENTRY @
A13 LI,R7 NXTSCAN RESUME SCANNING AFTER @
BDR,R3 STMTV HANDLING THE SUBSTMT VALUE.
CXQE BDR,R3 A6 BRN -- Q ENTRY (LOOK AHEAD NEXT) @
B A9 BOS -- Q ENTRY @
B CXERSYN LP -- Q ENTRY @
B CXERSYN LB -- Q ENTRY @
B CXERSYN SEMI-- Q ENTRY @
A17 EQU CXOPAP
A20 EQU CXOPAP
CXOPAP AI,R1 1 DROP A-PRIME ENTRY.
B CXOPVE-SCANOPM,R4 VECTOR ON SCAN ITEM.
CXOPVE B A16 ENTER ACTION ROUTINE. @
A19 BAL,R4 STACKUP ADD 1 WD TO EXEC. STACK. @
STW,R7 0,R1 PUT 2ND OPER WD.
OR,R6 OENTRY SET O-ENTRY CATEGORY.
STW,R6 -1,R1 PUT 1ST (CATEGORY) OPER WD.
LI,R2 CATO SET TOP CAT.
AI,R1 -1 PT AT NEW TOP-O-STACK.
BDR,R3 NXTSCAN RESUME SCAN.
CXOPV B CXOPVE-SCANOPM,R4 V VECTOR ON SCAN ITEM. @
B CXOPAP A-PRIME @
B A7 O @
B A18,R5 X VECTOR ON COORD ALLOWANCE.@
B CXERSYN B @
B CXERSYN P @
B CXERSYN S @
B CXERSYN Q @
B CXERSYN D @
B CXERSYN A @
* NOTE -- A18 MUST BE LOCATED 1 WD AFTER A 'B CXERSYN', COORD DISALLOWD
A18 STD,R6 OPERHOLD HOLD CURRENT OPERATOR INFO. @
LB,R6 OPERHOLD+1 DOES IT ALREADY HAVE A COORDINATE...
BNEZ CXERSYN YES -- SYNTAX ERROR.
STW,R4 SCANTEMP OK, SAVE SCANOPM OR SCANOP.
LI,R4 0
XW,R4 0,R1 SAVE THE X-ENTRY.
STW,R4 XTEMP
AI,R1 1 DROP THE X-ENTRY.
LB,R2 *R1 NEW TOP CAT A V-ENTRY...
BEZ A18X YES.
CI,R2 CATO NO, AN O-ENTRY...
BNE CXERSYN NAY -- SYNTAX ERROR.
BAL,R14 CXPOPMON AYE, POP AND EXECUTE IT MONADIC.
A18X LW,R4 XTEMP PT AT THE LIST DATA BLK OF X-ENTRY.
LW,R14 2,R4 CK THAT IT IS A LIST OF LENGTH = 1.
AI,R14 -1
BNEZ CXERRANK NO -- RANK ERROR.
LW,R4 3,R4 YES, PT AT THE INDICATED DATA BLK.
BEZ CXERSYN NO COORD GIVEN -- SYNTAX ERROR.
BAL,R7 NUMSV @ CK NUMERIC SCALAR OR VECTOR...
BDR,R4 A18VAL @ SCALAR, PT AT DATA BLK HDR + 2.
AI,R12 -1 @ VECTOR, VERIFY LENGTH = 1.
BNEZ CXERRANK OOPS -- RANK ERROR.
A18VAL BAL,R5 IVAL @ GET INTEGER VALUE...
B A18LAMCK @ NON-INTEGER, TRY LAMINATE ON FLOOR
A18ORG AW,R7 ORGADJ @ ADJUST INTEGER TO INT. ORIGIN OF 1.
BLEZ CXERRANK OOPS -- RANK ERROR.
CI,R7 TOPRANK IS RANK RIDICULOUSLY HIGH...
A18HICK BG CXERRANK OOPS -- RANK ERROR.
STB,R7 OPERHOLD+1 OK, SET COORD (MAYBE LAMINATE BIT).
LI,R4 0
XW,R4 XTEMP DEREFERENCE THE LIST DATA BLK.
BAL,R7 DREF
LD,R6 OPERHOLD GET THE OPERATOR INFORMATION.
LW,R4 SCANTEMP GET SCANOPM OR SCANOP.
B A18EXIT-SCANOPM,R4 EXIT ACCORDINGLY:
A18EXIT B A16 OPM @
B A19 OP @
A18LAMCK AW,R7 ORGADJ ADJUST TO INTERNAL ORIGIN OF 1.
BLZ CXERRANK OOPS -- RANK ERROR.
AI,R7 X'40' SET LAMINATE BIT.
LI,R5 COMMACOD VERIFY THAT THIS IS A COMMA OPERATOR
CB,R5 *CURRCS,R3
BNE CXERRANK OOPS -- RANK ERROR.
CI,R7 TOPRANK+X'40' OK, VERIFY RANK ISN'T TOO HIGH.
B A18HICK
CXOP1 LI,R4 SCANOP SET 'OP' SCAN ITEM.
CXCOORD1 LW,R7 COORD1 COORDINATE-1 OPERATION.
OR,R7 R3 = 2ND OPER WORD.
LI,R5 -1 TO DISALLOW FURTHER COORD SPECIFCTN.
STW,R3 OFFSETR SAVE OFFSET TO OPERATOR DESIGNATOR.
B CXOPV,R2 CONTEXT ANALYSIS START FOR OP OR OPM
CXOPM1 LI,R4 SCANOPM SET 'OPM' SCAN ITEM.
B CXCOORD1
CXOP LI,R4 SCANOP SET 'OP' SCAN ITEM.
CXNCOOR3 STW,R3 OFFSETR SAVE OFFSET TO OPERATOR DESIGNATOR.
CXNCOORD LI,R5 -1 TO DISALLOW COORDINATE SPECIFICATION
LW,R7 R3 = 2ND OPER WORD.
B CXOPV,R2 CONTEXT ANALYSIS START FOR OP OR OPM
CXOPM LI,R4 SCANOPM SET 'OPM' SCAN ITEM.
B CXNCOOR3
CXCOP LI,R4 SCANOP SET 'OP' SCAN ITEM.
CXCOK LI,R5 0 TO ALLOW COORDINATE SPECIFICATION.
LW,R7 R3 = 2ND OPER WORD, SO FAR.
STW,R3 OFFSETR SAVE OFFSET TO OPERATOR DESIGNATOR.
B CXOPV,R2 CONTEXT ANALYSIS START FOR OP OR OPM
CXCOPM LI,R4 SCANOPM SET 'OPM' SCAN ITEM.
B CXCOK
CXREDSET OR,R7 R3 = 2ND OPER WD, PTS AT DYADIC SCALAR.
AI,R6 X'100' SET THE 'REDUCTION' FLAG.
B CXOPV,R2 CONTEXT ANALYSIS FOR THIS OPM.
CXCRED LI,R5 0 TO ALLOW COORDINATE SPECIFICATION.
LI,R7 0 START WITH NO COORDINATE.
CXRED LI,R4 SCANOPM SET 'OPM' SCAN ITEM.
STW,R3 OFFSETR SAVE OFFSET TO REDUCE-OP DESIGNATOR.
AI,R3 -1 GET THE CODESTRING DESIGNATOR TO THE
LB,R6 *CURRCS,R3 LEFT OF THE REDUCTION SLASH.
CLM,R6 DYSCLRS IS IT A DYADIC SCALAR...
BCR,9 CXREDSET YES, SET FOR REDUCTION.
AI,R6 DYADIC-MONADIC NO, MAYBE IT WAS CODESTRUNG AS AN
CLM,R6 MDYSCLRS OPM. TEST BIASED VERSION...
BCR,9 CXREDSET NOW ITS A DYADIC SCALAR.
B CXERSYN OOPS -- SYNTAX ERROR.
CXRED1 LI,R5 -1 TO DISALLOW FURTHER COORD SPECIFCTN.
LW,R7 COORD1 COORDINATE-1 REDUCTION.
B CXRED
CKSCANOP LI,R4 1 PUT OFFSET TO LEFT-MOST OPERATOR U19-0015
STH,R3 OPER+1,R4 IN 'CURRBYTE' IN CASE ERROR. U19-0016
MTW,-1 OFFSETR UPDATE SAVED OFFSET FOR A7 RETURN. U19-0017
LB,R6 *CURRCS,R3 GET CURRENT CODESTRING DESIGNATOR. U19-0018
CLM,R6 DYSCLRS IS IT A DYADIC SCALAR... U19-0019
BCR,9 CKSCANOK YES, SET FOR SCAN-OPERATOR EXEC. U19-0020
AI,R6 DYADIC-MONADIC NO, BUT MIGHT BE MONADIC VERSION. U19-0021
CLM,R6 MDYSCLRS NOW IS IT A DYADIC SCALAR... U19-0022
BCS,9 CXERSYN NOPE -- SYNTAX ERROR. U19-0023
CKSCANOK STW,R6 OPER USE THAT OP FOR OPER TEMPS. U19-0024
B SCAN U19-0025
A7R STW,R3 OFFSETR SAVE OFFSET TO SCAN ITEM DESIGNATOR.
A7 BAL,R14 CXPOPMON HANDLE STACKED OP MONADICALLY.
LW,R3 OFFSETR RESTORE SAVED OFFSET.
B NXTSCAN
CXSEMI LI,R4 SCANSEMI SET 'SEMI' SCAN ITEM.
CXACFLAG LI,R13 0 CLEAR ACFLAG, I.E. SET NIL.
STW,R13 ACFLAG
CXZCLASS LI,R13 0 (TERMINATOR CLASS OF ITEM)
STW,R13 NILCK CLEAR NILCK, I.E. SET NIL.
B ZRESCAN,R2 CONTEXT ANALYSIS START FOR Z-CLASS.
ZRESCAN B A3 TOP-CAT = V @
B CXAP-SCANBRN,R4 A-PRIME VECTOR ON SCAN ITEM. @
B A7R O @
B CXERSYN X @
B CXBE-SCANBRN,R4 B VECTOR ON SCAN ITEM. @
B CXPE-SCANBRN,R4 P VECTOR ON SCAN ITEM. @
B CXSE-SCANBRN,R4 S VECTOR ON SCAN ITEM. @
B CXQE-SCANBRN,R4 Q VECTOR ON SCAN ITEM. @
B CXERSYN D @
B CXERSYN A @
CXBRN LI,R4 SCANBRN SET 'BRN' SCAN ITEM.
B CXZCLASS
CXBOS LI,R4 SCANBOS SET 'BOS' SCAN ITEM.
B CXACFLAG
CXLP LI,R4 SCANLP SET 'LP' SCAN ITEM.
B CXZCLASS
CXLB LI,R4 SCANLB SET 'LB' SCAN ITEM.
B CXZCLASS
CXRB CI,R2 CATAPRYM TOP CAT AN A-PRIME...
BNE A1 NO.
A2 AI,R1 1 YES, DROP A-PRIME ENTRY.
A1 LW,R12 BENTRY GET B-ENTRY WITH COUNT = 0.
CXPCNXT LB,R2 R12 SET TOP CAT FOR NEXT
BDR,R3 CXPUSHC CATEGORY AND SCAN AFTER PUSHING.
A34 LW,R12 AENTRY GET A-ENTRY.
B CXPCNXT
A24 LW,R12 PENTRY GET P-ENTRY.
B CXPCNXT
A28 AI,R1 1 DROP A-PRIME ENTRY.
A27 LI,R12 X'1FFFF' OBTAIN LOC OF FUNCTION DESCRIPTOR
AND,R12 *SYMT,R4 DATA BLOCK.
OR,R12 DENTRY D ENTRY CATEGORY (DYADIC FUNC).
LI,R2 CATD SET NEW TOP CAT.
XW,R12 PTRITEM SAVE D-ENTRY & CLEAR R12.
MTW,1 1,R5 INCR REF COUNT OF FUNDEF DATA BLK.
BDR,R3 CXPUSHDP PUSH D-ENTRY & RESUME SCAN.
CXQUAD CLM,R2 CATO2D TOP CAT FOR QUAD...
BCR,9 A25 OK, INPUT.
BCS,8 A38 OK, OUTPUT.
B CXERSYN BAD -- SYNTAX ERROR.
CXRP CLM,R2 CATO2D TOP CAT OK FOR RIGHT PAREN...
BCR,9 A24 OK.
B CXERSYN NO -- SYNTAX ERROR.
CXASS CI,R2 CATO TOP CAT OK FOR ASSIGN ARROW...
BL CXASSV,R2 OK, HIT A34 OR A35.
BE A7R MAYBE, HIT A7.
B CXERSYN BAD, SYNTAX ERROR.
CXASSV B A34 @
A35 LI,R2 CATA CONVERT A-PRIME TO A ENTRY @
STB,R2 *R1 AT TOP OF STACK.
BDR,R3 NXTSCAN
A36 CI,R5 LBLFLAG TRYING TO ASSIGN TO A LABEL...
BAZ AOK NO.
B CXERSYN YES -- SYNTAX ERROR.
AOK LW,R7 NILCK IS THIS AN INDEXED ASSIGNMENT...
BEZ ASIMPLE NO, SIMPLE ASSIGNMENT.
STW,R1 TOPOSTAK YES, SAVE STACK PTR.
STW,R3 OPER+1 SAVE CURRENT CODESTRING OFFSET.
LW,R6 1,R1 GET V-ENTRY.
STW,R6 RTARG IT IS THE RT. ARGUMENT FOR ASS.
MTW,1 1,R6 INCR REF COUNT OF ITS DATA BLK.
LW,R3 NAMEPTR PT TO REF-INDIC. WD FOR VN.
LI,R4 X'1FFFF'
AND,R4 *SYMT,R3 GET REFERENT DATA BLK PTR.
MTW,1 1,R4 BUMP ITS REF-COUNT
STW,R4 LFARG MOVE IT INTO LF. ARG. PTR.
B AXDRIVER ENTER INDEXED-ASSIGNMENT EXECUTION
* DRIVER, IT WILL RETURN TO RETURNAX
RETURNAX LW,R1 TOPOSTAK RESTORE STACK PTR; (R3 SET).
LI,R4 0
XW,R4 RTARG DE-REF. (THE EXTRA REF) TO RTARG.
BAL,R7 DREF U19-0027
LI,R4 0
XW,R4 LFARG DE-REF. OLD DATA BLK FOR VN.
BAL,R7 DREF U19-0029
LW,R5 NAMEPTR PT TO REF-INDICATOR FOR VN.
LW,R4 *SYMT,R5 GET OLD DATA BLK REFERENCE.
LI,R7 X'1FFFF'
LI,R6 0
XW,R6 RESULT MOVE NEW DATA BLK PTR INTO SYM TBL.
STS,R6 *SYMT,R5
LI,R7 A36DONE GO TO 'A36DONE' AFTER
B DREF DE-REFING OLD DATA BLK.
ASIMPLE LW,R6 NAMEPTR PT TO REF-INDIC. WD FOR VN.
LI,R4 X'E0000'
AND,R4 *SYMT,R6 COMBINE FLAG-BITS AND NEW DATA BLK
OR,R4 1,R1 PTR (V-ENTRY).
MTW,1 1,R4 INCR REF-COUNT OF THAT DATA BLK.
XW,R4 *SYMT,R6 INSERT NEW REFERENT-INDICATOR WD.
BAL,R7 MAYDREF DEREFERENCE THE OLD (UNLESS NIL).
A36DONE LI,R2 CATAPRYM SET TOP CAT TO BE A-PRIME (I.E.
STB,R2 *R1 ASSIGNMENT-COMPLETED).
LW,R4 CATCHTBL IS A CATCH IN EFFECT...
BLZ NXTSCANU NO, RESUME SCAN.
CW,R4 NAMEPTR YES, FOR THIS VN...
BNE A36CATC2 NO, TRY OTHER CATCH.
LW,R6 CATCHTBL+1 YES, GET FUN.NAME PTR.
A36CATCH LI,R5 X'1FFFF' EXTRACT REF-PTR FOR FUN.NAME...
AND,R5 *SYMT,R6
BEZ NXTSCANU NONE, RESUME SCAN.
LB,R6 *R5 GET DATA BLK TYPE.
AI,R6 -TYPENFN VERIFY NILADIC FUNC., NO RESULT...
BNEZ NXTSCANU NOPE, RESUME SCAN.
B A26 OK, EXECUTE CATCH FUNCTION.
A36CATC2 LW,R4 CATCHTBL+2 IS 2ND CATCH IN EFFECT...
BLZ NXTSCANU NO, RESUME SCAN.
CW,R4 NAMEPTR YES, FOR THIS VN...
BNE NXTSCANU NO, RESUME SCAN.
LW,R6 CATCHTBL+3 YES, GET FUN.NAME PTR.
B A36CATCH
A32 B A32VORP,R4 VECTOR ON SCANITEM VN OR PTR:
A32VORP B A32NILCK @ 0 -- PTR.
* B A32VN @ 1 -- VN.
A32VN AND,R5 X1FFFF @ EXTR. DATA BLK PTR FROM REF-IND. WD.
STW,R5 PTRITEM
MTW,1 1,R5 INCR REF COUNT OF THAT DATA BLOCK.
A32NILCK LI,R14 CXPUSHV SET TO EXIT TO CXPUSHV.
QNILCK LW,R7 NILCK IS THERE A SUBSCRIPT...
BNEZ SUBEX YES.
QOBS LW,R7 OBSERVE NO, OBSERVE SET...
BEZ *R14 NOPE -- EXIT.
AI,R6 -A15PAREN-1 YEP.
BEZ *R14 (EXIT IF VIA PAREN -- REDUNDANT).
STW,R3 OFFSET SAVE CS POS. FOR OBSERVE'S MARKER.
LW,R6 PTRITEM PT AT OPERAND'S DATA BLK.
B OBSERVER OBSERVE THAT VALUE,
OBSERVED B *R14 RESUME HERE.
SUBEX STW,R3 OPER+1 SAVE CURRENT CODESTRING OFFSET.
STW,R1 TOPOSTAK SAVE EXECUTION STACK PTR.
STW,R14 LINKX SAVE LINK TO SUBEX.
LW,R6 BREAKFLG TEST FOR BREAK...
BEZ SXDRIVER NO -- ENTER SUBSCRIPTING DRIVER,
B CXBREAK
* IT WILL RETURN TO RETURNSX.
RETURNSX LW,R1 TOPOSTAK RESTORE STACK PTR; (R3 SET).
LI,R4 0
XW,R4 RTARG DE-REF. RTARG (WAS LFARG WHEN
* ENTERING 'SXDRIVER').
BAL,R7 DREF
LI,R5 0
XW,R5 RESULT MOVE RESULT INTO PTRITEM.
STW,R5 PTRITEM
LW,R14 LINKX SET TO EXIT VIA SAVED LINK (SUBEX)
B QOBS AFTER QUERY OBSERVE SETTING.
CXPUSHV BAL,R4 STACKUP ADD 1 LOC TO EXECUTION STACK.
LI,R5 0 GET PTR OUT OF PTRITEM
XW,R5 PTRITEM = V ENTRY FOR NEW STACK LOC.
STW,R5 0,R1 FILL IT WITH V-ENTRY.
LI,R2 CATV TOP CAT IS FOR V-ENTRY.
BDR,R3 NXTSCAN RESUME SCAN.
A23 B A23VORP,R4 VECTOR ON SCANITEM VN OR PTR:
A23VORP B A23NILCK @ 0 -- PTR.
* B A23VN @ 1 -- VN.
A23VN AND,R5 X1FFFF @ EXTR. DATA BLK PTR FROM REF-IND. WD.
STW,R5 PTRITEM
MTW,1 1,R5 INCR REF COUNT OF THAT DATA BLOCK.
A23NILCK BAL,R14 QNILCK QUERY SUBSCRIPTING.
DYEX STW,R3 OFFSET SAVE CODESTRING OFFSET
LI,R6 X'FFFF' GET OPTYPE
AND,R6 0,R1 AND
LW,R7 1,R1 2ND OPER. INFO WD.
STD,R6 OPER SAVE BOTH.
STW,R7 OPCURRBY (SAVE CURR.BYTE FOR OPWRAP).
AI,R1 2 DROP O-ENTRY FROM EXECUTION STACK.
LI,R14 0 PULL THE
XW,R14 0,R1 V-ENTRY AND
STW,R14 RTARG MAKE IT THE RT ARGUMENT.
* LFARG (LEFT ARG) IS IN 'PTRITEM'
* LFARG AND PTRITEM ARE SAME CELL.
STW,R1 TOPOSTAK HOLD TOP-O-STACK, RESULT WILL FILL.
LW,R5 BREAKFLG TEST FOR BREAK...
BEZ DRANGECK NO -- RANGE CHECK THE OPER.
B CXBREAK YES.
DRANGECK CLM,R6 DYRANGE CK FOR ORDINARY DYADIC OP.
BCR,9 DXDRIVER YES, ENTER DYADIC EXECUTION DRIVER,
* IT WILL RETURN TO RETURNDX.
LI,R5 2 GET MOST SIGNIFICANT BYTE OF THE
LB,R5 OPER,R5 OPTYPE FIELD.
CI,R5 SMOCODE CK FOR SMALL CIRCLE...
BG INNER HI -- INNER PRODUCT...
BE OUTER ON -- OUTER PRODUCT...
AI,R6 -DYINFLAG (REMOVE DYADIC-INTRINSIC FLAG)
B DINTRIN LO -- DYADIC INTRINSIC...
* NOTE--THEY ALL RETURN TO RETURNDX.
RETURNDX LW,R1 TOPOSTAK RESTORE STACK PTR; (R2=0, I.E. CATV)
LW,R3 OFFSET RESTORE CODESTRING OFFSET.
LI,R4 0
XW,R4 LFARG DEREFERENCE LEFT ARG.
BAL,R7 DREF
LI,R14 NXTSCANU SET TO EXIT TO NXTSCANU.
OPWRAP LI,R4 0 WRAP UP OPERATOR.
XW,R4 RTARG
BAL,R7 DREF DEREFERENCE RIGHT ARG.
LI,R6 0
XW,R6 RESULT MOVE RESULT DB PTR INTO TOP-O-STACK.
STW,R6 0,R1
LW,R7 OBSERVE IS OBSERVE SET...
BEZ *R14 NO -- EXIT.
INT,R7 OPCURRBY YES,SAVE CURR.BYT TO OPERATOR.
STW,R7 OFFSET RESUME FOR EXIT AT OBSERVED AFTER
B OBSERVER DISPLAYING THE OBSERVATION.
A33 LW,R7 NILCK IS ITEM ALREADY TO BE INDEXED...
BEZ A33N NO.
B A33VORP,R4 YES, VECTOR ON SCANITEM VN OR PTR:
A33VORP B A33X @ 0 -- PTR.
* B A33VN @ 1 -- VN.
A33VN AND,R5 X1FFFF @ EXTR. DATA BLK PTR FROM REF-IND. WD.
STW,R5 PTRITEM
MTW,1 1,R5 INCR REF COUNT OF THAT DATA BLOCK.
A33X BAL,R14 SUBEX EXECUTE SUBSCRIPTING (ONCE).
LI,R4 0 SET SCANITEM FOR PTR (NOT VN).
A33N LI,R7 0
XW,R7 0,R1 PULL X-ENTRY OUT OF TOP-O-STACK
STW,R7 NILCK AND SAVE IT IN NILCK (NON-NIL).
AI,R1 1 POP AND GET
LB,R2 *R1 NEW TOP CAT.
B CXPTR,R2 CONTEXT ANALYSIS FOR VN OR PTR.
CXNMV LI,R4 0
STW,R4 NILCK CLEAR NILCK FLAG, I.E. SET NIL.
LI,R4 SCANVN SET 'VN' SCAN ITEM.
B CXPTR,R2 CONTEXT ANALYSIS FOR VN.
CXNMNI CLM,R2 CATO2D TOP CAT OK FOR NILADIC INTRINSIC...
BCS,9 CXERSYN NO -- SYNTAX ERROR.
LH,R2 *R5 YES, EXTRACT INTRINSIC'S NO.
AI,R2 -(TYPENI**8)
STD,R2 OPER SAVE I AND SAVE OFFSET TO CODESTRING
STW,R1 TOPOSTAK SAVE STACK PTR.
LW,R4 BREAKFLG TEST FOR BREAK...
BEZ NINTRIN NO -- EXEQ NILADIC INTRINSIC & GO
B CXBREAK
* TO RETURNNI AFTER 'RESULT' SET.
RETURNNI LW,R1 TOPOSTAK RESTORE STACK PTR (NOTE--R4 = 0).
XW,R4 RESULT MOVE RESULT INTO PTRITEM.
STW,R4 PTRITEM
B FPOPPED ASSUME WE'VE POPPED AN F-ENTRY.
CXNMMI CI,R2 CATO IS AN OPERATOR AT TOP OF STACK...
BE A22 YES -- IT IS MONADIC.
LH,R6 *R5 NO, EXTRACT MONADIC-INTRINSIC'S
AI,R6 -(TYPEMI**8) 'OPERATOR' NO.
LI,R4 SCANOPM SET 'OPM' SCAN ITEM.
B CXNCOORD
CXNMDI CI,R2 CATO IS AN OPERATOR AT TOP OF STACK...
BE A22 YES -- IT IS MONADIC.
LH,R6 *R5 NO, EXTR. DYADIC-INTRIN'S 'OPER.'
AI,R6 -(TYPEDI**8)+DYINFLAG NO. AND FLAG IT.
LI,R4 SCANOP SET 'OP' SCAN ITEM.
B CXNCOORD
CXNMNF CLM,R2 CATO2D TOP CAT OK FOR NILADIC FUNCTION...
BCR,9 A26 YES, ENTER ACTION ROUTINE.
B CXERSYN NO -- SYNTAX ERROR.
CXNMDF CI,R2 CATO TOP CAT OK FOR DYADIC FUNCTION...
BLE CXNMDFV,R2 YES, HIT PROPER ACTION ROUTINE.
B CXERSYN NO -- SYNTAX ERROR.
CXNMDFV B A27 @
B A28 @
B A22 @
CXNMMF CI,R2 CATO TOP CAT OK FOR MONADIC FUNCTION...
BLE CXNMMFV,R2 YES, HIT PROPER ACTION ROUTINE.
B CXERSYN NO -- SYNTAX ERROR.
CXNMMFV B A29 @
B A30 @
A22 BAL,R14 CXPOPMON HANDLE STACKED OP MONADICALLY.
LW,R4 NAMEPTR RESTORE PTR TO FUNCTION NAME.
B CXNRESC RESCAN FOR THAT NAME.
CXPOPMON LI,R6 X'FFFF' GET OPTYPE
AND,R6 0,R1 AND
LW,R7 1,R1 2ND OPER. INFO WD.
STD,R6 OPER SAVE BOTH.
AI,R1 2 DROP O-ENTRY FROM EXECUTION STACK.
MONEX STW,R14 LINKMX SAVE LINK.
STW,R3 OFFSET SAVE CODESTRING OFFSET.
STW,R7 OPCURRBY (SAVE CURR.BYTE FOR OPWRAP).
LI,R14 0 PULL THE
XW,R14 0,R1 V-ENTRY AND
STW,R14 RTARG MAKE IT THE RT ARGUMENT.
STW,R1 TOPOSTAK HOLD TOP-O-STACK, RESULT WILL FILL.
LW,R5 BREAKFLG TEST FOR BREAK...
BEZ MRANGECK NO -- RANGE CHECK THE OPER.
B CXBREAK YES.
MRANGECK CLM,R6 MONRANGE CK FOR ORDINARY MONADIC OP.
BCR,9 MXDRIVER YES, ENTER MONADIC EXECUTION DRIVER,
* IT WILL RETURN TO RETURNMX.
BCS,1 MINTRIN NO, (LO) TRY INTRINSIC MONADIC, IT
* TOO WILL RETURN TO RETURNMX.
CLM,R6 REDRANGE NO, (HI) CK FOR REDUCTION RANGE.
BCR,9 REDUCE OK, REDUCE WILL RETURN TO RETURNMX
CLM,R6 S2XRANGE NO, CK FOR SCAN OR EXECUTE CASE... U19-0031
BCR,9 SORXV-SCAN1COD,R6 YES, VECTOR ACCORDING TO WHICH. U19-0032
B CXERSYN OOPS -- SYNTAX ERROR
RETURNMX LW,R1 TOPOSTAK RESTORE STACK PTR; (R2=0, I.E. CATV)
LW,R3 OFFSET RESTORE CODESTRING OFFSET.
LW,R14 LINKMX SET TO EXIT VIA SAVED LINK (MONEX)
B OPWRAP AFTER WRAPPING UP THE OPERATION.
CXSLOGL1 LI,R6 -1 PUT A 1 IN BIT POSITION ZERO.
CXSLOGL0 LI,R13 TYPELOGL LOGICAL TYPE DATA BLOCK.
B CXGENWD GEN LOGICAL SCALAR DATA BLOCK.
CXSIBYTE LB,R6 *CURRCS,R3 GET BYTE-FORM OF INTEGER.
CXSI09 LI,R13 TYPEINTG FOR INTEGER TYPE OF DATA BLOCK.
CXGENWD LI,R11 2 ASK FOR 2 WDS PLUS HEADER.
STW,R1 TOPOSTAK SAVE STACK PTR. IN CASE WS FULL.
STW,R3 OPER+1 SAVE OFFSET IN CASE WS FULL OCCURS.
BAL,R7 ALOCHNW ALLOCATE DATA BLOCK.
CXSTWD STW,R6 2,R4 FILL IN VALUE WORD.
STW,R4 PTRITEM SAVE LOC OF DATA BLOCK FOR PTR ITEM.
STB,R13 *PTRITEM FILL IN DATA BLOCK TYPE.
LI,R4 0 SET 'PTR' SCAN ITEM.
STW,R4 NILCK CLEAR NILCK FLAG, I.E. SET NIL.
B CXPTR,R2 CONTEXT ANALYSIS FOR PTR.
CXPTR B CXERSYN V -- SYNTAX ERROR. @
B CXERSYN A-PRIME -- SYNTAX ERROR. @
B A23 O @
B A33 X @
B A32 B @
B A32 P @
B A32 S @
B A32 Q @
B A31 D @
B CXVORP,R4 A -- IS SCAN ITEM PTR OR VN... @
CXVORP B CXERSYN @ PTR -- SYNTAX ERROR.
B A36 @ VN, ENTER ACTION ROUTINE.
CXSIWORD SLS,R3 -2 WORD OFFSET TO INTEGER VALUE.
LW,R6 *CURRCS,R3 GET INTEGER.
SLS,R3 2 OFFSET TO LEFTMOST BYTE OF INTEGER.
B CXSI09
CXSREAL SLS,R3 -2 WORD OFFSET TO 2ND REAL WD.
LW,R13 *CURRCS,R3 GET 2ND REAL WD.
AI,R3 -1 OFFSET TO 1ST REAL WD.
LW,R6 *CURRCS,R3 GET 1ST REAL WD.
SLS,R3 2 OFFSET TO LEFTMOST BYTE OF REAL PAIR
LI,R11 2 ASK FOR 2 WDS PLUS HEADER.
STW,R1 TOPOSTAK SAVE STACK PTR. IN CASE WS FULL.
STW,R3 OPER+1 SAVE OFFSET IN CASE WS FULL OCCURS.
BAL,R7 ALOCHNW ALLOCATE DATA BLOCK.
STW,R13 3,R4 FILL IN 2ND REAL WD.
LI,R13 TYPEREAL FOR REAL TYPE OF DATA BLOCK.
B CXSTWD FILL IN 1ST REAL WD AND SET PTR.
CXSTEXT LB,R6 *CURRCS,R3 GET TEXT SCALAR BYTE.
SCS,R6 -8 PUT IT IN BYTE ZERO.
LI,R13 TYPETEXT FOR TEXT TYPE OF DATA BLOCK.
B CXGENWD GEN THAT DATA BLOCK.
CXVINTG LI,R6 TYPEINTG FOR INTEGER TYPE OF DATA BLOCK.
CXVLEN LB,R11 *CURRCS,R3 GET LENGTH BYTE
CXVALOC STW,R11 RSSIZE = NO.OF ELEMENTS OF TYPE.
STW,R6 RSTYPE TYPE OF DATA BLOCK.
LI,R14 1 RANK IS 1 FOR VECTOR.
STW,R14 RSRANK
STW,R1 TOPOSTAK SAVE STACK PTR. IN CASE WS FULL.
STW,R3 OPER+1 SAVE OFFSET IN CASE WS FULL OCCURS.
BAL,R14 ALOCRS ALLOCATE 'RESULT' DATA BLOCK.
STW,R4 PTRITEM SAVE LOC OF DATA BLK FOR PTR ITEM.
AI,R4 2 PT AT LENGTH WD OF DATA BLK.
LW,R5 RSSIZE GET LENGTH AGAIN.
STW,R5 0,R4 PUT IT IN DATA BLK.
BEZ CXPVSET EMPTY VECTOR.
CXFILLV B CXFILLV,R6 TYPE... (0 IS IMPOSSIBLE)
B CXFLOGL @ 1 FILL IN LOGICAL VALUES.
B CXFTEXT @ 2 FILL IN TEXT VALUES.
B CXFINTG @ 3 FILL IN INTEGER VALUES.
* B CXFREAL @ 4 FILL IN REAL VALUES.
CXFREAL AI,R4 1 @ WD AFTER LENGTH IS GARBAGE, WE NEED
SLS,R5 1 EVEN BNDRY. 2 WDS PER ELEMENT.
STW,R5 RSSIZE SET SIZE IN WORDS, NOT DBLWDS.
CXFINTG AW,R4 RSSIZE PT AT LAST VALUE WD OF DATA BLK.
SLS,R3 -2 WD OFFSET TO LENGTH BYTE IN CODESTR.
CXFWORD AI,R3 -1 FILL IN WORD VALUES,
LW,R10 *CURRCS,R3 FROM LAST
STW,R10 0,R4 TO FIRST.
AI,R4 -1
BDR,R5 CXFWORD
SLS,R3 2 OFFSET TO LEFTMOST BYTE OF 1ST WD.
CXPVSET LI,R4 0 SET UP FOR PTR ITEMS OF VECTOR CLASS
STW,R4 RESULT ELIMINATE THE EXTRA REF TO DATA BLK.
STW,R4 NILCK CLEAR NILCK FLAG, I.E. NIL.
B CXPTR,R2 CONTEXT ANALYSIS FOR PTR.
CXFLOGL AI,R5 7 CALC. NO.OF BYTES
SLS,R5 -3 FOR LOGICAL VALUES
STW,R5 RSSIZE
CXFTEXT SLS,R4 2 PT AT BYTE IN DATA BLOCK THAT
AI,R4 3 PRECEDES 1ST VALUE BYTE SPOT.
AW,R4 RSSIZE PT AT LAST VALUE BYTE TO FILL.
CXFBYTE AI,R3 -1 FILL IN BYTE VALUES,
LB,R10 *CURRCS,R3 FROM LAST
STB,R10 0,R4 TO FIRST.
AI,R4 -1
BDR,R5 CXFBYTE
B CXPVSET FINISH POINTING AT LEFTMOST VAL BYTE
CXVLOGL LI,R6 TYPELOGL FOR LOGICAL TYPE DATA BLOCK.
B CXVLEN
CXVREAL LI,R6 TYPEREAL FOR REAL TYPE DATA BLOCK.
B CXVLEN
CXVTEXT LI,R6 TYPETEXT FOR TEXT TYPE DATA BLOCK.
B CXVLEN
CXVTEXTL LB,R11 *CURRCS,R3 GET LO BYTE OF LONG-TEXT LENGTH.
SCD,R10 -8 HOLD IT.
AI,R3 -1 OFFSET TO HI BYTE.
LB,R11 *CURRCS,R3 GET IT.
SCD,R10 8 FORM LENGTH HALFWORD, IN R11.
LI,R6 TYPETEXT FOR TEXT TYPE DATA BLOCK.
B CXVALOC PREPARE TO ALLOCATE IT.
CXCOMMNT LB,R6 *CURRCS,R3 GET LENGTH OF COMMENT.
SW,R3 R6 OFFSET TO 1ST COMMENT CHAR, IF ANY.
BDR,R3 NXTSCAN FORGET IT.
CXSTORTR LB,R4 *CURRCS,R3 GET RIGHT BYTE OF NAME POINTER.
SLD,R4 -8 SAVE IT.
AI,R3 -1 GET LEFT BYTE.
LB,R4 *CURRCS,R3
SLD,R4 8 = THE NAME POINTER.
LI,R5 X'1FFFF' EXTRACT REFERENT, I.E.
AND,R5 *SYMT,R4 DATA BLOCK PTR.
BEZ CXERUND OOPS, NONE -- UNDEFINED.
LB,R10 *R5 OK, GET ITS TYPE.
CLM,R10 FUNTYPES VERIFY THAT ITS A FUNCTION NAME.
BCS,9 CXERSYN GOOF -- SYNTAX ERROR.
CI,R2 CATA IS TOP-O-STACK CATEGORY AN A...
BE A37 YES, ENTER ACTION ROUTINE.
B CXERSYN NO, SYNTAX ERROR
CXNAME STW,R3 OFFSETR SAVE OFFSET TO NAME DESIGNATOR.
AI,R3 -1
LB,R4 *CURRCS,R3 GET RIGHT BYTE OF NAME POINTER.
SLD,R4 -8 HOLD IT.
AI,R3 -1 GET LEFT BYTE.
LB,R4 *CURRCS,R3
SLD,R4 8 = THE NAME POINTER.
STW,R4 NAMEPTR
CXNRESC LW,R5 *SYMT,R4 GET ITS REFERENT INDICATOR WORD.
CI,R5 X'1FFFF' IS THERE A REFERENT...
BANZ CXNAMFND YES.
CI,R2 CATA NO, IS THIS AN ASSIGNMENT...
BE CXNMV YEP, GO AHEAD.
B CXERUND NOPE -- UNDEFINED.
CXNAMFND LB,R6 *R5 GET TYPE OF DATA BLK REFERENCED.
B CXNAMTYP,R6
CXNAMTYP BAL,R15 SYSTERR @ 0 -- SHOULD BE IMPOSSIBLE.
B CXNMV @ 1 -- LOGL VARIABLE
B CXNMV @ 2 -- TEXT VARIABLE
B CXNMV @ 3 -- INTG VARIABLE
B CXNMV @ 4 -- REAL VARIABLE
B CXNMV @ 5 -- INDEX SEQUENCE VARIABLE
B CXNMV @ 6 -- LIST VARIABLE
BAL,R15 SYSTERR @ 7 -- CODESTRING -- MAYBURY'S ERROR
B CXNMNF @ 8 -- NILADIC FUNC, NO RESULT.
B CXNMNF @ 9 -- NILADIC FUNC, RESULT.
B CXNMMF @ 10-- MONADIC FUNC, NO RESULT.
B CXNMMF @ 11-- MONADIC FUNC, RESULT.
B CXNMDF @ 12-- DYADIC FUNC, NO RESULT.
B CXNMDF @ 13-- DYADIC FUNC, RESULT.
B CXNMDI @ 14-- DYADIC INTRINSIC.
B CXNMMI @ 15-- MONADIC INTRINSIC.
B CXNMNI @ 16-- NILADIC INTRINSIC.
B CXERSYN 17-- GROUP -- SYNTAX ERROR.
CXBADCD EQU SYSTERR -- CRASH IF BAD CODE; SOMETHING IS HAYWIRE.
CXV B CXSLOGL0 0@ 0 LOGICAL SCALAR CONSTANT
B CXSLOGL1 1@ 1 LOGICAL SCALAR CONSTANT
B CXSI09 2@ 2 SCALAR CONSTANT
B CXSI09 3@ 3 SCALAR CONSTANT
B CXSI09 4@ 4 SCALAR CONSTANT
B CXSI09 5@ 5 SCALAR CONSTANT
B CXSI09 6@ 6 SCALAR CONSTANT
B CXSI09 7@ 7 SCALAR CONSTANT
B CXSI09 8@ 8 SCALAR CONSTANT
B CXSI09 9@ 9 SCALAR CONSTANT
BDR,R3 CXSIBYTE 10@ INTEGER BYTE SCALAR CONSTANT
BDR,R3 CXSIWORD 11@ INTEGER WORD SCALAR CONSTANT
BDR,R3 CXSREAL 12@ REAL SCALAR CONSTANT
BDR,R3 CXSTEXT 13@ TEXT SCALAR CONSTANT
BDR,R3 CXVLOGL 14@ LOGICAL VECTOR CONSTANT
BDR,R3 CXVINTG 15@ INTEGER VECTOR CONSTANT
BDR,R3 CXVREAL 16@ REAL VECTOR CONSTANT
BDR,R3 CXVTEXT 17@ TEXT VECTOR CONSTANT
BDR,R3 CXVTEXTL 18@ LONG TEXT VECTOR CONSTANT
B CXLSERR 19@ ERROR (DURING LINE SCAN)
BDR,R3 CXCOMMNT 20@ COMMENT
BDR,R3 CXSTORTR 21@ STOPNAME
BDR,R3 CXSTORTR 22@ TRACENAME
B CXNAME 23@ NAME
BAL,R15 CXBADCD 24@ *
B CXQUAD 25@ QUAD-0
B CXQUAD 26@ QUAD-1
B CXQUAD 27@ QUAD-2
B CXQUAD 28@ QUAD-3
B CXQUAD 29@ QUAD-4
B CXQUAD 30@ QUAD-5
B CXQUAD 31@ QUAD-6
B CXQUAD 32@ QUAD-7
B CXQUAD 33@ QUAD-8
B CXQUAD 34@ QUAD-9
B CXQUAD 35@ QUAD
B CXQUAD 36@ QUOTE-QUAD
B CXBOS 37@ BEGINNING-OF-STMT
B CXSEMI 38@ SEMICOLON
B CXLB 39@ LEFT BRACKET
B CXRB 40@ RIGHT BRACKET
B CXLP 41@ LEFT PAREN
B CXRP 42@ RIGHT PAREN
B CXBRN 43@ BRANCH ARROW
B CXASS 44@ ASSIGN ARROW
B CXDOT 45@ DOT
BAL,R15 CXBADCD 46@ SMALL CIRCLE
BAL,R15 CXBADCD 47@ *
BAL,R15 CXBADCD 48@ *
BAL,R15 CXBADCD 49@ *
B CXOPM 50@ DOMINO MONADIC USE
B CXOPM 51@ ROLL MONADIC USE
B CXOPM 52@ T-BAR MONADIC USE
B CXRED1 53@ REDUCE ON 1ST COORD MONADIC USE
B CXCRED 54@ REDUCE MONADIC USE
B CXOPM 55@ IOTA MONADIC USE
B CXOPM 56@ RHO MONADIC USE
B CXOPM 57@ RAVEL MONADIC USE
B CXOPM1 58@ REVERSE ON 1ST COORD MONADIC USE
B CXCOPM 59@ REVERSE MONADIC USE
B CXOPM 60@ TRANSPOSE MONADIC USE
B CXOPM 61@ IDENTITY MONADIC USE
B CXOPM 62@ MINUS MONADIC USE
B CXOPM 63@ SIGNUM MONADIC USE
B CXOPM 64@ RECIPROCAL MONADIC USE
B CXOPM 65@ EXPONENTIAL MONADIC USE
B CXOPM 66@ NATURAL LOG MONADIC USE
B CXOPM 67@ PI TIMES MONADIC USE
B CXOPM 68@ CEILING MONADIC USE
B CXOPM 69@ FLOOR MONADIC USE
B CXOPM 70@ ABSOLUTE MONADIC USE
B CXOPM 71@ FACTORIAL (GAMMA) MONADIC USE
BAL,R15 CXBADCD 72@ *
BAL,R15 CXBADCD 73@ *
B CXOPM 74@ I-BEAM
B CXOPM 75@ GRADE UP
B CXOPM 76@ GRADE DOWN
B CXOPM 77@ NOT
BAL,R15 CXBADCD 78@ *
BAL,R15 CXBADCD 79@ *
B CXOP 80@ DOMINO
B CXOP 81@ ROLL OR DEAL
B CXOP 82@ T-BAR
B CXOP1 83@ COMPRESS ON 1ST COORD
B CXCOP 84@ COMPRESS
B CXOP 85@ IOTA
B CXOP 86@ RHO
B CXCOP 87@ COMMA
B CXOP1 88@ REVERSE OR ROTATE ON 1ST COORD
B CXCOP 89@ REVERSE OR ROTATE
B CXOP 90@ TRANSPOSE
B CXOP 91@ PLUS
B CXOP 92@ MINUS
B CXOP 93@ TIMES
B CXOP 94@ DIVIDE
B CXOP 95@ EXPONENT
B CXOP 96@ LOG
B CXOP 97@ CIRCLE
B CXOP 98@ MAX OR CEILING
B CXOP 99@ MIN OR FLOOR
B CXOP 100@ ABSOLUTE OR RESIDUE
B CXOP 101@ EXCLAMATION PT
B CXOP 102@ LESS THAN
B CXOP 103@ LESS THAN OR EQUAL
B CXOP 104@ GREATER THAN
B CXOP 105@ GREATER THAN OR EQUAL
B CXOP 106@ NOT EQUAL
B CXOP 107@ EQUAL
B CXOP 108@ AND
B CXOP 109@ OR
B CXOP 110@ NAND
B CXOP 111@ NOR
BAL,R15 CXBADCD 112@ *
BAL,R15 CXBADCD 113@ *
B CXOP 114@ DECODE
B CXOP 115@ ENCODE
B CXOP 116@ TAKE
B CXOP 117@ DROP
B CXOP1 118@ EXPAND OR SCAN ON 1ST COORD U19-0034
B CXCOP 119@ EXPAND OR SCAN U19-0035
B CXOP 120@ EPSILON
BAL,R15 CXBADCD 121@ *
BAL,R15 CXBADCD 122@ *
BAL,R15 CXBADCD 123@ DIERESIS
BAL,R15 CXBADCD 124@ NEGATIVE SIGN
BAL,R15 CXBADCD 125@ UNDERSCORE
BAL,R15 CXBADCD 126@ DOLLAR SIGN
BAL,R15 CXBADCD 127@ ALPHA
BAL,R15 CXBADCD 128@ OMEGA
BAL,R15 CXBADCD 129@ DEL
BAL,R15 CXBADCD 130@ LOCKED DEL
BAL,R15 CXBADCD 131@ LEFT CUP
BAL,R15 CXBADCD 132@ RIGHT CUP
BAL,R15 CXBADCD 133@ CAP
BAL,R15 CXBADCD 134@ CUP
BAL,R15 CXBADCD 135@ COLON
BAL,R15 CXBADCD 136@ *
BAL,R15 CXBADCD 137@ *
NXTSCANU AI,R3 -1 138@ DUMMY -- PT AT NEXT CODESTR.DESIG.
NXTSCAN LB,R6 *CURRCS,R3 GET CODESTRING DESIGNATOR.
B CXV,R6 VECTOR TO THAT CD'S PRELIM PROCESSOR
CX LH,R3 *CURRCS OFFSET TO RIGHTMOST ITEM OF CODESTR.
LW,R1 TOPOSTAK PT AT TOP OF EXECUTION STACK.
LB,R2 *TOPOSTAK GET TOP CATEGORY.
CI,R2 CATQ CK FOR Q-ENTRY (EVALUATED-INPUT REQ)
BE NXTSCAN YES, START SCANNING.
LW,R12 SENTRY NO, PUSH AN S-ENTRY (COUNT = 0)
LI,R2 CATS SET TOP CAT TO S-ENTRY.
LW,R8 OBSFLAG SET OBSERVATION SETTING FOR THIS
STW,R8 OBSERVE DIRECT LINE: 0=NO & -1=YES.
B CXPUSHC PUSH CATEGORY WD AND START SCAN.
PAGE
************************************************************************
SPACE 2
Z SET %-CODEXEQ@
SPACE
Z SET Z+Z/10*6+Z/100*96+Z/1000*1536 SIZE IN DECIMAL.
SPACE 2
END