EXEC3
* /--- FILE TYPE = E
* /--- BLOCK EXTERNALS 00 000 79/08/25 16.48
IDENT EXEC3
TITLE TUTOR EXECUTION-INTERPRETER
*
* GET COMMON SYMBOL TABLE
*
CST
*
*
TITLE EXTERNALS
*
*
EXT BOUNDS,PROCESS,PROCO,PROC,PROC1
EXT UNITJ,DO=,DOS=,ARG=,JTABLE
EXT UNITGO
EXT RETRNZ (EXEC2)
EXT ILOC,ECSPRTY,COMPUSE,TOOMUCH
EXT POSTEXC,XSLICE,OUTFLOW
EXT PCHECK
EXT ERXJOIN ERROR EXIT, -EXEC2-
EXT ERXVAL,ERXMXLW,ERXMBED
EXT ERXHSEG
EXT LVLOAD (AUTLOAD)
EXT TSLERR
EXT XDATA,YDATA
EXT ERXROLV,ERXROLC (TUTORX)
EXT WINDOW (TUTOUT)
*
*
* /--- BLOCK CONSTANTS 00 000 80/01/25 13.02
*
* WORKING VARIABLES IN *TBINTSV*
*
* THESE DEFINES MUST MATCH IN DECKS
* *EXEC3*, *GRAFS*, *GRAFS2*
*
XMINUS EQU TBINTSV THESE MUST BE IN THIS ORDER'.
YMINUS EQU XMINUS+1
XPLUS EQU YMINUS+1
YPLUS EQU XPLUS+1
XORGIN EQU YPLUS+1
YORGIN EQU XORGIN+1
*
* /--- BLOCK JOIN 00 000 77/07/25 20.19
TITLE -JOIN- AND -JOIN*- COMMANDS
*
* -JOIN- AND -JOIN*- COMMANDS
*
* UNCONDITIONAL AND CONDITIONAL JOIN OF UNIT.
*
*
ENTRY JOINCX
JOINCX CALL CUNIT GET CONDITIONAL JOIN UNIT
*
ENTRY JOINX
JOINX NG X5,JARGS JUMP IF JOIN WITH ARGUMENTS
AX5 48 POSITION UNIT NUMBER
ZR X5,UNITJ JUMP IF UNIT -Q-
SA1 JOIN GET JOIN COUNTER
SX6 X1+1 ADD ONE TO JOIN COUNTER
SX2 X6-JOINLTH ALLOW 1 EXTRA FOR PAUSE / ARROW
PL X2,ERXJOIN ERROR IF TOO DEEP IN JOINS
SB3 B1 B3 = CONDITION INDEX
SA6 A1
SA4 ILESUN PRESENT LESSON AND UNIT
MX0 42
BX2 X0*X4 LESSON NUMBER
LX4 12
SB1 A5
SX3 B5-B1 COMMAND BIAS (12 BITS)
BX6 X4+X3
SX3 B3+1 X3 = CONDITION INDEX+1
LX3 -7
MX4 7
BX3 X3*X4
LX3 -5
BX6 X6+X3 X6 = JS ENTRY W/CONDITION
SA6 X1+JOINL STUFF INTO LIST
BX6 X6-X3 X6 = JS ENTRY WO/CONDITION
BX6 X5+X2 ADD LESSON NUMBER
SA6 A4 STORE IN -ILESUN-
SA1 TLVLESS
ZR X1,UNITGO IF NO LOCAL VARIABLES
*
CALL LVLOAD,-1 UNLOAD LOCAL VARS
CALL LVINCSP,1 INCREMENT LOCAL VAR STACK PTR
EQ UNITGO AND BEGIN TUTOR UNIT EXECUTION
*
*
* /--- BLOCK JOIN 00 000 77/07/25 20.19
*
* PROCESSING FOR -JOIN- WITH ARGUMENTS
*
JARGS SB3 B1 B3 = CONDITION INDEX
SA1 JOIN X1 = JOIN SP
SX6 X1+1
SX2 X6-JOINLTH ALLOW 1 EXTRA FOR PAUSE / ARROW
PL X2,ERXJOIN ERROR IF TOO DEEP IN JOINS
SA6 A1
SA4 ILESUN PRESENT LESSON AND UNIT
LX4 12
SB1 A5
SX3 B5-B1 COMMAND BIAS (12 BITS)
BX6 X4+X3
SX3 B3+1 SAVE CONDITION INDEX FOR RARGS
LX3 -7
MX2 7
BX3 X3*X2
LX3 -5
BX6 X6+X3
SA6 X1+JOINL STUFF INTO LIST
*
LX5 12 POSITION INDEX IN XSTOR
*
CALL PREARGS,1 SET UP ARGUMENTS
CALL LVLOAD,-1 UNLOAD LOCAL VARS
CALL LVINCSP,1 PUSH LV STACK
*
JGARGS BSS 0 ENTRY HERE FROM GOTOX
SA1 ILESUN GET LESSON NUMBER
MX0 42
BX6 X0*X1
BX6 X5+X6 PUT LESSON AND UNIT NUMBERS TOGETHER
SA6 A1 FOR THIS TIME
*
SB1 A1 SEE IF THIS NEXT UNIT HAS ARGS
SB2 ARWK ANY UNUSED VARIABLE
CALL HOLUNIT TO GET -UNAM- INFO WORD
LX1 1 GET BIT TELLING IF UNIT HAS ARGS
NG X1,UNITGO GO EXECUTE UNIT WITH ARGS
MX6 0 ELSE MARK NO ARGS IN HAND
SA6 INARGS
EQ UNITGO
*
TITLE -IEUEND- COMMAND
*
*
* -IEUEND-
* SPECIAL COMMAND INSERTED AT END OF INITIAL ENTRY
* UNIT TO EXECUTE ANY -IMAIN- UNIT SPECIFIED
*
*
ENTRY IEUENDX
IEUENDX SA1 TIMAIN SEE IF ANY -IMAIN- UNIT
ZR X1,PROC
SX5 X1 SET UP FOR -JOIN-
LX5 48
EQ JOINX DO A -JOIN- OF -IMAIN- UNIT
*
*
* /--- BLOCK LVINCSP 00 000 85/01/31 13.30
TITLE CHANGE LOCAL VAR STACK POINTER
*
* -LVINCSP- INCREMENT OR DECREMENT LOCAL VAR
* STACK POINTER.
*
* ENTER'; B1 = -1 DECREMENT, 1 INCREMENT
*
ENTRY LVINCSP
*
LVINCSP EQ *
SA1 LVUCNT CURRENT UNIT LOCAL VAR COUNT
SA2 TLVLESS GET STACK POINTER
ZR X1,LVINCSP LEAVE IF NO VARS TO PUSH/POP
ZR X2,LVINCSP SHOULD GET CAUGHT IN LVLOAD
SX6 X2 STACK POINTER IN LOWEST 18 BITS
SX0 B1 GET INCREMENT
AX0 1 MAKE -0 OR +0
BX1 X0-X1 NEGATE LOCAL VAR COUNT
IX6 X6+X1 INCREMENT / DECREMENT
NG X6,BADSP1 EXECERR - NEGATIVE SP
* AX2 2*18 MOVE ECS BUFFER LENGTH
* MX0 -18
* BX0 -X0*X2 X0 = LENGTH
* IX0 X6-X0
* SA2 A2 RESTORE *TLVLESS*
* SX0 X0-1 POSITIVE IF STACK OVERFLOW
* PL X0,BADSP2
MX0 -18
BX2 X0*X2 CLEAN OUT STACK POINTER
BX6 X6+X2 ADD IN NEW STACK POINTER
SA6 A2 STORE IT
EQ LVINCSP
*
BADSP1 BX1 X6 GET STACK POINTER VALUE
EXECERR 931 STACK POINTER WENT NEGATIVE
*
* /--- BLOCK JUMP 00 000 79/06/10 21.31
TITLE -JUMP- AND -JUMP*- COMMANDS
*
* -JUMP- AND -JUMP*- COMMANDS
*
* UNCONDITIONAL AND CONDITIONAL JUMP.
*
ENTRY JUMPXC
JUMPXC CALL CUNIT GET UNIT NUMBER IN X5
SB1 B7-XANSC CHECK FOR ANSWER-C
NZ B1,JXX2
BX6 X5 SAVE -X5-
SA6 TBINTSV+5
CALL ANSDAT OUTPUT STUDENT DATA
SA1 TBINTSV+5
BX5 X1 RESTORE -X5-
EQ JXX2
*
*
ENTRY JUMPXX
JUMPXX SB1 B7-XANSC CHECK FOR ANSWER-C
NZ B1,JXX2
CALL ANSDAT OUTPUT STUDENT DATA
SA5 A5 RESTORE -X5-
*
JXX2 PL X5,JXX3 JUMP IF NO ARGUMENTS
LX5 12
CALL PREARGS,1 SET UP ARGUMENTS
EQ JXX4
*
JXX3 AX5 48 POSITION UNIT NUMBER
JXX4 SA1 ILESUN
MX0 42
BX6 X0*X1 LESSON NUMBER
BX5 X5+X6 COMBINE WITH LESSON NUMBER
CALL PUNITE RETURNS IF UNIT DOES NOT EXIST
MX6 0
SA6 INARGS MARK NO ARGUMENTS IN HAND
EQ PROCESS THEN JUST IGNORE COMMAND
*
*
* /--- BLOCK GOTO 00 000 77/06/13 16.57
TITLE GOTO AND GOTO*
*
*
* -GOTO- AND -GOTO*- COMMANDS
*
* UNCONDITIONAL AND CONDITIONAL GOTO.
*
*
ENTRY GOTOCX
GOTOCX LX5 18 POSITION ADDRESS OF CODE
SB1 B5+X5 JUMP INTO COMPILED CODE
JP B1 RETURNS TO GOTOX VIA XGOTO
*
*
* UNCONDITIONAL -GOTO- COMES HERE
*
ENTRY GOTOX
GOTOX NG X5,GOTOXQ IF SPECIAL UNIT X OR Q
*
SA1 TLVLESS
ZR X1,GOTOX10 IF NO LOCAL VARIABLES
*
SB1 B7-XANSC CHECK FOR ANSWER-C
NZ B1,GOTOX10 IF NOT ANSWER-C
*
SA1 AJOIN
BX2 X1
AX2 18 X2 = ARROW UNIT LV SP
SA3 TLVLESS
SX3 X3 X3 = CURRENT UNIT LV SP
IX3 X3-X2
PL X3,GOTOX10 IF ARROW LVARS ALREADY PUSHED
*
SA1 X1+AJOIN
AX1 12 SHIFT OFF COMMAND BIAS
SA2 ILESUN
IX1 X1-X2
NZ X1,GOTOX10 IF NOT IN -ARROW- UNIT
*
CALL LVLOAD,-1 UNLOAD LOCAL VARIABLES
CALL LVINCSP,1 PUSH LOCAL VARIABLE STACK
GOTOX10 AX5 48 X5 = TOP 12 BITS
ZR X5,XG2 JUMP IF TO SAME UNIT
SA1 ILESUN PRESENT LESSON AND UNIT
MX0 42
BX3 X0*X1 PRESENT LESSON NUMBER
BX6 X5+X3 COMBINE WITH UNIT NUMBER
SA6 ILESUN ELSE SET PRESENT UNIT POINTER
EQ UNITGO START EXECUTING TUTOR UNIT
*
XG2 SA5 B5 SET UP COMMAND POINTER
EQ PROCESS
*
GOTOXQ LX5 12 POSITION UNIT NUMBER
MX0 -12
BX5 -X0*X5 MASK OFF UNIT NUMBER
SX0 X5-UNXNUM
ZR X0,PROCESS JUMP IF UNIT -X-
SX0 X5-UNQNUM
ZR X0,UNITJ JUMP IF UNIT -Q-
CALL PREARGS,1 SET UP ARGUMENTS
EQ JGARGS
*
* /--- BLOCK XGOTO 00 000 76/02/14 07.05
TITLE CONDITIONAL -GOTO- COMMAND
*
*
* -GOTO- COMMAND (CONDITIONAL)
*
* COMPILED GOTO CODE SETS UP---
* X1 = INDEX IN TABLE
* X2 = NUMBER OF ENTRIES IN TABLE
* B2 = ABSOLUTE ADDRESS OF TABLE
*
*
ENTRY XGOTO
*
XGOTO SX5 1 NEED CONSTANT ONE
IX1 X1+X5 60 BITS ONLY
MX0 -2
PL X1,XGOTO1 IF NEGATIVE, MAKE 0
MX1 0
XGOTO1 IX3 X1-X2 SEE IF NUMBER IN BOUNDS
NG X3,XGOTO2 JUMP IF OK
IX1 X2-X5 ELSE SET FOR LAST ENTRY
XGOTO2 BX2 -X0*X1 X2 = INTRA-WORD POSITION
BX3 X2
LX2 4 *16
IX3 X2-X3 *15
SB3 X3 B3 = SHIFT COUNT
AX1 2 GET WORD BIAS (4-15 BIT PACKS/WORD)
SA3 X1+B2 X3 = PACKED WORD
LX5 X3,B3 POSITION CORRECT 15 BIT PACKAGE AT TOP
LX5 3 ONLY 12 BITS OF UNIT INFO
EQ GOTOX
*
*
* -XGFTOI-
* FLOATING TO INTEGER CONVERSION ROUTINE CALLED
* BY -GOTO- COMMAND COMPILED CODE TO ROUND INDEX
* FOR INDEXED VARIABLE
*
*
ENTRY XGFTOI
*
XGFTOI EQ *
SA2 =.5 ROUND INDEX FOR INDEXED VARIABLE
PL X1,XGFI1
BX2 -X2 SUB .5 IF ARGUMENT NEGATIVE
XGFI1 RX1 X1+X2
UX1 X1,B1 FIX THE ARGUMENT
LX1 X1,B1
MX6 0
IX1 X1+X6 CHANGE -0 TO +0
EQ XGFTOI
* /--- BLOCK DO 00 000 73/00/00 00.00
TITLE DO, DO(L), DO*, AND DO*(L)
*
*
* -DO- COMMAND
*
* INITIALIZATION ENTRY FOR INTEGER INDEX DO.
*
ENTRY DOX
DOX LX5 12+18 POSITION -GETVAR- CODE
NGETVAR GET STARTING VALUE OF INDEX
BX6 X1
SA6 ILOC
SA5 A5
LX5 12+18 POSITION ADDR OF COMPILED CODE
SB1 X5+B5
SB3 DOXR1 SET UP RETURN ADDRESS
JP B1 JUMP INTO COMPILED CODE
*
* RETURNS WITH *COMPUSE(2)* = ENDING VALUE
* X1 = INCREMENT
*
DOXR1 SA2 ILOC X2 = INITIAL VALUE
SA3 COMPUSE+1 X3 = ENDING VALUE
PL X1,PDO JUMP IF POSITIVE INCREMENT
IX1 X2-X3
PL X1,OKDO OK IF STARTING VALUE .GE. END
*
NODO SA5 A5-1 SKIP FOLLOWING -DO(L)- COMMAND
EQ PROCESS
*
PDO IX1 X3-X2
NG X1,NODO EXIT IF INITIAL GT END
*
OKDO BX6 X2 MOVE INITIAL VALUE TO X6
SB3 DOXR2 SET UP RETURN ADDRESS
EQ DOLOC GO BACK INTO COMPILED CODE
*
DOXR2 SA5 A5 RESTORE COMMAND WORD
EQ DOJOIN
*
* /--- BLOCK DO 00 000 73/00/00 00.00
*
*
* -DO(L)- COMMAND
*
* INCREMENT AND LOOPING ENTRY FOR INTEGER INDEX DO.
*
ENTRY DOLX
DOLX LX5 12+18 POSITION ADDR OF COMPILED CODE
SB1 X5+B5
SB3 DOLR1 SET UP RETURN ADDRESS
JP B1 JUMP INTO COMPILED CODE
*
* RETURNS WITH *COMPUSE(1)* = VALUE OF INDEX
* *COMPUSE(2)* = ENDING VALUE
* X1 = INCREMENT
*
DOLR1 SA2 COMPUSE X2 = INDEX
IX6 X1+X2
SA3 COMPUSE+1 X3 = END VALUE
NG X1,NDOL JUMP IF INCREMENT NEGATIVE
IX3 X3-X6
NG X3,DOLFIN DONE IF INDEX .GT. END VALUE
SB3 DOLR2 SET UP RETURN ADDRESS
EQ DOLOC GO BACK INTO COMPILED CODE
*
NDOL IX3 X6-X3
NG X3,DOLFIN DONE IF INDEX .LT. END VALUE
SB3 DOLR2 SET UP RETURN ADDRESS
EQ DOLOC
*
DOLR2 SA5 A5+1 BACK UP TO PRECEEDING -DO-
EQ DOJOIN
*
DOLFIN SB3 PROCESS EXIT TO *PROCESS* AFTER STORE
EQ DOLOC TO COMPILED CODE FOR STORE
*
* /--- BLOCK DO 00 000 73/00/00 00.00
*
*
* -DO*- COMMAND
*
* INITIALIZATION ENTRY FOR FLOATING POINT INDEX DO.
*
ENTRY DOFX
DOFX LX5 12+18 POSITION -GETVAR- CODE
FGETVAR GET INITIAL VALUE OF INDEX
BX6 X1
SA6 ILOC
SA5 A5 RESTORE COMMAND WORD
LX5 12+18 POSITION ADDR OF COMPILED CODE
SB1 X5+B5
SB3 DOFR1 SET UP RETURN ADDRESS
JP B1 BRANCH INTO COMPILED CODE
*
* ON RETURN *COMPUSE(2)* = ENDING VALUE
* X1 = INCREMENT
*
DOFR1 SA2 ILOC X2 = STARTING VALUE
SA3 COMPUSE+1 X3 = ENDING VALUE
PL X1,PDOF JUMP IF POSITIVE INCREMENT
FX1 X2-X3
PL X1,OKDO JUMP TO BEGIN DO LOOP
EQ NODO
*
PDOF FX1 X3-X2
PL X1,OKDO
EQ NODO
*
* /--- BLOCK DO 00 000 73/00/00 00.00
*
*
* -DO*(L)- COMMAND
*
* INCREMENT AND LOOPING ENTRY FOR FLOATING INDEX DO
*
ENTRY DOFLX
DOFLX LX5 12+18 POSITION ADDR OF COMPILED CODE
SB1 X5+B5
SB3 DOFLR1 SET UP RETURN ADDRESS
JP B1 JUMP INTO COMPILED CODE
*
* ON RETURN *COMPUSE(1)* = VALUE OF INDEX
* *COMPUSE(2)* = ENDING VALUE
* X1 = INCREMENT
*
DOFLR1 SA2 COMPUSE X2 = INDEX
FX6 X1+X2
NX6 X6 NORMALIZE RESULT
SA3 COMPUSE+1 X3 = END VALUE
NG X1,NDOFL JUMP IF INCREMENT NEGATIVE
FX3 X3-X6
NG X3,DOLFIN DONE IF INDEX .GT. END VALUE
SB3 DOLR2 SET UP RETURN ADDRESS
EQ DOLOC
*
NDOFL FX3 X6-X3
NG X3,DOLFIN DONE IF INDEX .LT. END VALUE
SB3 DOLR2 SET UP RETURN ADDRESS
EQ DOLOC
*
*
ENTRY DOLOC
DOLOC EQ * COMPILED CODE COMES HERE
JP B3 RETURN TO CALLER
*
*
* /--- BLOCK DO 00 000 80/06/26 02.57
*
DOJOIN PL X5,JOINX JUMP IF NOT SPECIAL UNIT
MX0 3
BX1 X0*X5 CHECK CONDITIONAL ITERATED -DO-
BX1 X0-X1
NZ X1,JOINX JUMP IF NOT
MX0 -9
LX5 12 POSITION INDEX IN XSTOR
BX5 -X0*X5
SA1 X5+B5 LOAD TABLE INFO WORD
BX6 X1
SA6 ILOC
BX5 X1 SET UP FOR -GETVAR- CALL
*
NGETVAR
PL X1,CUNIT1 IF NEGATIVE, MAKE -1
ZR X1,CUNIT1 MAKE -0 = 0
SX1 -1
CUNIT1 SX7 1
IX1 X1+X7 MAKE SO GOES FROM 0 TO N-1
SA4 ILOC
MX0 48 SET FOR 12 BIT MASK
AX4 XCMNDL
BX2 -X0*X4 X2 = NUMBER OF ENTRIES
AX4 12
BX3 -X0*X4 X3 = RELATIVE START OF TABLE
SB2 B5+X3 B2 = ABSOLUTE START OF TABLE
MX0 -2
IX3 X1-X2 SEE IF NUMBER IN BOUNDS
NG X3,CUNIT2
SX1 X2-1 ELSE SET FOR LAST ENTRY
*
CUNIT2 BX2 -X0*X1 X2 = INTRA-WORD POSITION
BX3 X2
LX2 4 *16
IX3 X2-X3 *15
SB3 X3 B3 = SHIFT COUNT
AX1 2 GET WORD BIAS (4 BYTES/WORD)
SA3 X1+B2 X3 = PACKED WORD
LX5 X3,B3 POSITION CORRECT 15 BIT PACKAGE
LX5 3 ONLY 12 BITS OF UNIT INFO
PL X5,JOINX EXIT IF NORMAL UNIT
MX0 12
BX3 X0*X5 MASK OFF UNIT NUMBER
LX3 12
SX0 X3-UNXNUM
ZR X0,PROCESS JUMP IF SPECIAL UNIT -X-
SX0 X3-UNQNUM
NZ X0,JOINX EXIT IF NOT UNIT -Q-
SA5 A5-1 ADVANCE OUT OF -DO-
EQ PROCESS
*
*
* -RETURN- (COMMAND NUMBER ***)
*
* PASSES RETURN ARGUMENTS TO CALLING UNIT.
* DOES NOTHING IF -RETURN- ATTEMPTED IN UN-DO-NE
* UNIT.
*
ENTRY RETARGX
*
RETARGX BSS 0
SA1 JOIN GET JOIN DEPTH
ZR X1,PROCESS NO JOIN SO EXECUTE NEXT COMMAND
*
NG X5,=XUNJOIN NO ARGS TO RETURN
LX5 12 POSITION INDEX IN XSTOR
CALL PREARGS,-1 SET UP ARGUMENTS
EQ =XUNJOIN IN -GETUNIT-
*
* /--- BLOCK DO 00 000 80/05/13 16.36
*
* -DOR- AND -JOINR- COMMANDS
*
* THESE PSEUDO COMMANDS ARE PLACED AFTER ANY
* DO/JOIN COMMANDS THAT CONTAIN RETURN ARGUMENTS
*
ENTRY DORX,JOINRX
JOINRX SX1 =XJOINC=
EQ RARGS10
*
DORX SX1 =XDOC=
*
RARGS10 SA2 TBNARGS PRE-ZERO *ARGS*
MX0 -6
BX6 X0*X2
SA6 A2
*
SA2 INARGS X2 = ARGUMENTS PRESENT FLAG
ZR X2,PROCESS IF NO ARGUMENTS PRESENT
*
SA5 A5+1 LOOK AT PREVIOUS COMMAND
MX2 -9
BX2 -X2*X5 X2 = COMMAND NUMBER
IX2 X2-X1
NZ X2,RARGS20 IF UNCONDITIONAL DO/JOIN
*
SA1 JOIN X1 = JOIN STACK DEPTH
SA1 JOINL+X1 X1 = PREVIOUS JOIN STACK ENTRY
LX1 12 R.J. CONDITION INDEX
MX3 -7 7 BITS IN THE CONDITION
BX1 -X3*X1 ISOLATE CONDITION
CALL CUNIT1A X5 = ARGTYPE/XSTOR POINTER
*
* /--- BLOCK DO 00 000 80/05/27 22.31
*
RARGS20 LX5 1
PL X5,RARGS30 IF NO RETURN ARGUMENTS
*
LX5 11 ALREADY SHIFTED 1 AT RARGS20
MX0 -10
BX5 -X0*X5 X5 = BIAS TO EXTRA STORAGE
SA1 B5+X5 ARG WORD FOR PREVIOUS DO/JOIN
LX1 10 R.J. ARG COUNT
BX1 -X0*X1 X1 = INPUT ARG COUNT
SX1 X1+1 X1 = INT((NARGS+1)/3)+1
PX1 X1
NX1 X1
SA2 =.33333333333334
FX1 X1*X2
UX1 X1,B1
LX1 X1,B1
SX1 X1+1
IX1 X1+X5 X1 = XSTOR PTR TO RARGS PTR
SA1 B5+X1 X1 = XSTOR PTR TO RARGS
SA5 A5-1 RESET COMMAND POINTER
LX1 48 POSITION XSTOR POINTER
BX5 X5+X1 AND SIMULATE ARGUMENTED -UNIT-
MX6 2 REMOVE TOP BITS
BX5 -X6*X5
SA1 INARGS MAKE SURE ARGS ARE PASSED
ZR X1,PROCESS IF NO ARGS WERE PASSED
*
MX6 0 RESET INARGS
SA6 A1
SX6 46 SET EXECERR MESSAGE
EQ ARGX EXECUTE -ARGS- COMMAND CODE
*
RARGS30 SA5 A5-1 RESET COMMAND POINTER
MX6 0 MAKE SURE *INARGS* CLEARED
SA6 INARGS
EQ PROCESS
*
RARGCND BSS 1 RETURN ARGS CONDITION
* /--- BLOCK ARGS 00 000 81/01/28 04.14
*
TITLE -ARGS- COMMAND
*
* PASS ARGUMENTS TO A UNIT (PSEUDO-COMMAND)
*
* *VARBUF(0)* = NUMBER OF ARGUMENTS
* *VARBUF(N)* = -GETVAR- CODES
* *VARBUF(N+UARGMAX+1)* = ARGUMENT VALUES
* *NARGTR* = ARGUMENTS TO TRANSFER
*
*
* OR
*
* RETRIEVE -JUMPOUT- ARGUMENTS
*
* *JPARGS*
* 1 / FLAG AS ARGUMENTS PRESENT (SIGN BIT)
* 2 / UNUSED
* 9 / DESTINATION UNIT FOR PSEUDO-COMMAND XFER
* 9 / NUMBER OF ARGUMENTS
* 9 / NUMBER OF ARGUMENTS TO TRANSFER
* 30 / -GETVAR- CODE BITS (3 " 10)
* 1 - 1=BLANK ARGUMENT, 0=NON-BLANK
* 2 - UNUSED
* 3 - 1=FLOATING POINT, 0=INTEGER
*
* *JPARGBF* = UP TO TEN ARGUMENTS
*
* THESE ARE TRANSFERED TO APPROPRIATE *VARBUF* AND *NARGTR*
*
*
* -DOR- AND -JOINR- ENTER AT *ARGX* WITH X5
* MOCKED-UP AS AN -ARGS- COMMAND FOR LOCAL VARS
*
*
ENTRY ARGSX
ARGSX BX6 X5 SAVE COMMAND WORD
SA6 TBINTSV
SA1 INARGS CHECK FOR BRANCH-TYPE ARGUMENTS
ZR X1,JARGTST -- IF NONE, TRY -JUMPOUT- ARGS
MX6 0
SA6 A1 CLEAR FLAG
SX6 105 SET EXECERR MESSAGE
PL X5,ARGX JUMP IF PSEUDO COMMAND
*
* IF IT IS NOT, TRY FOR -JUMPOUT- ARGUMENTS ANYWAY;
* -ARGS- COMMAND SHOULD NOT ACCEPT BRANCH-TYPE ARGS
*
JARGTST SA1 JPARGS X1 = *JPARGS*
PL X1,ARGXNO BRANCH IF NO -JUMPOUT- ARGS
* /--- BLOCK ARGS 00 000 81/01/28 04.13
*
* VERIFY THAT ARGUMENTS SHOULD BE PASSED
*
NG X5,JPARGOK UPPER BIT 1 = REAL COMMAND
BX3 X1
AX3 48 GET DESTINATION UNIT
SA2 ILESUN GET CURRENT UNIT
MX0 -9
BX3 -X0*X3
BX2 -X0*X2
IX3 X3-X2 COMPARE
NZ X3,ARGXNO -- EXIT IF NOT SAME
*
* X1 = *JPARGS*
*
JPARGOK MX6 0 RESET *JPARGS*
SA6 JPARGS
MX6 59 PRESET *ZRETURN*
SA6 TRETURN
*
MX0 -9 SET MASK FOR ARGUMENT COUNTS
BX2 X1 SAVE COPY OF STATUS WORD
AX2 30 POSITION TRANSFER COUNT
BX6 -X0*X2
ZR X6,ARGXNO -- EXIT IF NONE TO TRANSFER
SA6 NARGTR
AX2 9 POSITION ARGUMENT COUNT
BX6 -X0*X2
SA6 VARBUF
SB2 X6 SAVE NUMBER OF ARGUMENTS
LX1 30 PREPARE POSITION FOR FLAG BITS
MX0 3 MASK FOR -GETVAR- FLAGS
SB1 0 INITIALIZE INDEX
*
JARGFL SA2 JPARGBF+B1 TRANSFER ARGUMENTS
SB1 B1+1 INCREMENT INDEX
BX6 X0*X1 TRANSFER FLAGS TO TOP 3 BITS
SA6 VARBUF+B1 OF *VARBUF* -GETVAR- CODES
LX1 3 AND POSITION NEXT FLAG
BX6 X2 TRANSFER ARGUMENT VALUES
SA6 VARBUF+UARGMAX+1+B1
LT B1,B2,JARGFL AND CONTINUE UNTIL FINISHED
SX6 105 SET CORRECT EXECERR MESSAGE
*
* /--- BLOCK ARGS 00 000 80/05/27 15.31
*
* BRANCH-TYPE -ARGS- REJOINS -JUMPOUT- -ARGS- HERE
*
* -DOR- AND -JOINR- ROUTINES ALSO ENTER HERE,
* WITH X5 MOCKED-UP TO BE AN -ARGS- COMMAND
* WORD POINTING TO THE VARIABLE LIST TO RECEIVE
* VALUES FROM THE -RETURN- COMMAND; THEREFORE
* X5 CANNOT BE RESTORED BY -SA5 A5-. SEE THE
* ROUTINES FOR -DOR- AND -JOINR- COMMANDS.
*
ARGX SA6 TBINTSV+1 SAVE EXECERR MESSAGE CODE
BX6 X5
SA6 TBINTSV
SA4 NARGTR CHECK WHETHER ANY ARGUMENTS
ZR X4,ARGXNO -- EXIT IF NONE TO TRANSFER
MX0 -6
SA2 TBNARGS
BX6 X0*X2 CLEAR OUT OLD ARGUMENT COUNT
BX6 X4+X6
SA6 A2 STORE NEW ARGUMENT COUNT
*
MX0 -10
LX5 12 POSITION INDEX IN XSTOR
BX5 -X0*X5
CALL ARGCODE,SHOWOUT
SA1 VARBUF NUMBER OF ARGUMENTS GIVEN
SA2 SHOWOUT NUMBER OF VARS TO PASS INTO
MX6 0
SA6 A2 INITIALIZE INDEX
IX0 X2-X1
PL X0,AXLP PROCEED IF ALL KOSHER
*
* OOPS -- MORE PIGEONS THAN PIGEONHOLES
*
SA3 TBINTSV EXAMINE COMMAND WORD
PL X3,AEXECER EXECUTION ERROR FOR -UNIT- ARGS
BX6 X1
SA6 TRETURN NUMBER ATTEMPTED TO PASS
BX6 X2
SA6 A1 SLOTS AVAILABLE TO PASS INTO
*
* /--- BLOCK ARGS 00 000 80/05/13 16.35
*
* TRANSFER ARGUMENTS
*
AXLP SA1 SHOWOUT INDEX IN -GETVAR- CODE BUFFERS
SX6 X1+1
SA6 A1 UPDATE INDEX
SA2 VARBUF
IX0 X1-X2 END TEST
PL X0,ARGXEND
SA3 X6+VARBUF GET ARGUMENT -GETVAR- CODE
NG X3,AXLP JUMP IF BLANK ARGUMENT
SA2 X6+VARBUF+UARGMAX+1
SA1 X6+SHOWOUT
BX5 X1 GET VARIABLE -PUTVAR- CODE
BX6 X2 GET VALUE OF ARGUMENT
LX3 XFBIT
NG X3,AVVAR JUMP IF FLOATING POINT
NPUTVAR
EQ AXLP
*
AVVAR FPUTVAR
EQ AXLP
*
*
ARGXEND SA1 TBINTSV RETRIEVE COMMAND WORD
NG X1,PROCESS EXIT IF EXPLICIT -ARGS-
*
ARGXIT SA1 TIMAIN GET ANY -IMAIN- UNIT NUMBER
PL X1,PROCESS
MX6 1
BX6 -X6*X1 CLEAR TOP BIT (SET BY *LOGIC*)
SA6 A1
SX5 X1 GET UNIT NUMBER
ZR X5,PROCESS
LX5 48 POSITION FOR -JOIN- EXECUTOR
EQ JOINX MOCK UP A JOIN OF IMAIN UNIT
*
*
* IF NO ARGUMENTS AVAILABLE
*
ARGXNO SA1 TBNARGS CLEAR OUT ARGUMENT COUNT
MX0 -6
BX6 X0*X1
SA6 A1
*
SA1 TBINTSV RETRIEVE COMMAND WORD
PL X1,ARGXIT EXIT FOR IMPLICIT -ARGS-
MX6 0 SET *ZRETURN* = 0
SA6 TRETURN
EQ PROCESS EXIT FOR EXPLICIT -ARGS-
*
* ERROR 46 FOR ATTEMPTING TO PASS TOO MANY ARGS
* ERROR 105 FOR ATTEMPTING TO RETURN TOO MANY VALUES
*
AEXECER SA3 TBINTSV+1
EXECERR X3
*
* /--- BLOCK PREARGS 00 000 77/04/23 16.57
TITLE -PREARGS-
*
*
* -PREARGS-
* SET UP FOR BRANCHING COMMAND WITH ARGUMENTS
*
* ON ENTRY - X5 = INDEX IN EXTRA STORAGE
*
* B1 = ARGUMENT DIRECTION FLAG
* -1/0/1 = RETURN/UNDEFINED/PASSING
*
PREARGS EQ *
SA1 INARGS
NZ X1,"CRASH" IF FLAG ALREADY SET
SX6 B1 STORE ARGUMENT DESTINATION FLAG
SA6 A1 (A1 = *INARGS*)
MX0 -10
BX5 -X0*X5 MASK OFF INDEX IN XSTOR
CALL ARGCODE,VARBUF
BX6 X5
SA6 ARWK1 SAVE -X5-
MX6 0
SA6 ARWK INITIALIZE INDEX
*
PALP SA1 ARWK
SX6 X1+1 ADVANCE INDEX
SA2 VARBUF
IX2 X2-X6 END TEST
NG X2,PREXIT
SA6 A1
SA1 X6+VARBUF LOAD -GETVAR- CODE
NG X1,PALP
BX5 X1
LX1 XFBIT POSITION I/F BIT
NG X1,PVVAR JUMP IF FLOATING POINT
NGETVAR
*
PALP1 BX6 X1 GET VALUE OF ARGUMENT
SA2 ARWK
SA6 X2+VARBUF+UARGMAX+1
EQ PALP
*
PVVAR FGETVAR
EQ PALP1
*
PREXIT SA1 ARWK1
BX5 X1 RESTORE -X5-
EQ PREARGS
*
*
ARWK BSS 1
ARWK1 BSS 1
*
*
* /--- BLOCK ARGCODE 00 000 79/03/13 01.36
TITLE -ARGCODE-
*
*
* -ARGCODE-
* UNPACK ARGUMENT -GETVAR- CODES TO SPECIFIED BUFFER
*
* ENTER WITH X5 = INDEX IN EXTRA STORAGE
* B1 = ADDRESS OF BUFFER
*
* RETURNS X5 = UNIT NUMBER
* BUFFER(0) = NUMBER OF ARGUMENTS
* BUFFER(N) = -GETVAR- CODES FOR ARGUMENTS
* *NARGTR* = NUMBER OF ARGS TO TRANSFER
*
*
ENTRY ARGCODE,NARGTR
*
ARGCODE EQ *
SA1 X5+B5
LX1 10 POSITION ARGUMENT COUNT
MX0 -10
BX6 -X0*X1
BX4 X6 INITIALIZE REAL ARGUMENT COUNT
SA6 B1
LX1 10 POSITION UNIT NUMBER
BX5 -X0*X1
ZR X6,ARGCEX EXIT IF NO ARGUMENTS
MX0 XCODEL MASK FOR -GETVAR- CODE
SB2 2 INITIALIZE CODES/WORD COUNT
SB3 B0 INITIALIZE BUFFER INDEX
*
ACLP BX7 X0*X1 MASK OFF NEXT -GETVAR- CODE
LX1 XCODEL
SB3 B3+1
SA7 B1+B3
+ PL X7,*+1 JUMP IF NON-BLANK ARGUMENT
SX4 X4-1 DECREMENT REAL ARGUMENT COUNT
+ SX6 X6-1 DECREMENT NUMBER OF CODES
ZR X6,ARGCEX
SB2 B2-1 DECREMENT CODES/WORD COUNT
NZ B2,ACLP
SA1 A1+1 LOAD NEXT WORD OF CODES
SB2 3 RE-INITIALIZE COUNT
EQ ACLP
*
ARGCEX BX6 X4 STORE REAL ARGUMENT COUNT
SA6 NARGTR
EQ ARGCODE
*
*
NARGTR BSS 1
*
*
* /--- BLOCK WINTRP 00 000 76/06/17 00.15
TITLE WRITE COMMAND INTERRUPT
*
*
*
* -WINTRP-
* INTERUPT ROUTINE FOR -WRITE- COMMAND OR OTHER
* COMMANDS WHICH MAY BE USED IN EMBEDDED -WRITE-
*
* THREE 18 BIT COUNTS IN SHARE+1, +2, +3 ARE SAVED
* OVER INTERRUPT
*
* ON ENTRY - SHARE+1 = CHARACTER COUNT
* SHARE+2 = POINTER TO TEXT
* SHARE+3 = TEXT WORD COUNT
*
*
ENTRY WINTRP
WINTRP EQ *
*
* PRESERVE 18 BIT QUANTITIES IN SHARE+1 - SHARE+3
*
MX0 -18
SA1 SHARE+2 GET POINTER TO TEXT
BX1 -X0*X1
LX1 60-18
SA2 SHARE+3 GET TEXT WORD COUNT
BX2 -X0*X2
LX2 60-18-18
BX6 X1+X2
SA1 SHARE+1 GET CHARACTER COUNT
BX1 -X0*X1
BX6 X6+X1
SA6 WRTSAV1
*
* CHECK IF PROCESSING EMBEDDED -WRITE-
*
SA1 INEMBED SEE IF IN EMBEDDED -WRITE-
NZ X1,WINT1
MX6 0 X6 = -EMBED- WORD = 0
SA6 WRTSAV2 CLEAR -EMBED- WORD
EQ WINT3
*
* SAVE EMBEDDED WRITE PARAMETERS
*
WINT1 MX0 18+18
BX6 X0*X1 DISCARD IRRELAVANT INFO
SX2 A5
BX6 X2+X6 SAVE -EMBED- COMMAND ADDRESS
SA6 WRTSAV2
SA5 X1 RESTORE A5 FOR -TFIN-
SA1 VARBUF
SX6 X1 X6 = EXIT COMMAND CODE
*
* SAVE RETURN ADDRESS
*
WINT3 MX0 18
SA1 WINTRP LOAD EXIT JUMP
LX1 12
BX1 X0*X1 MASK OFF RETURN ADDRESS
LX1 2*18
BX6 X1+X6 ATTACH WITH EMBED EXIT COMMAND
SA6 WRTSAV3
* /--- BLOCK WINTRP 00 000 77/07/25 23.03
*
* INTERRUPT
*
CALL TFIN END THIS TIME SLICE
*
* RESTORE SHARE+1 - SHARE+3 AFTER INTERRUPT
*
SA1 WRTSAV1
SX6 X1 RESTORE CHARACTER COUNT
SA6 SHARE+1
LX1 18
SX6 X1 RESTORE POINTER TO TEXT
SA6 SHARE+2
LX1 18
SX7 X1 RESTORE TEXT WORD COUNT
SA7 SHARE+3
*
* RESTORE EMBEDDED -WRITE- PARAMETERS
*
SA1 WRTSAV2 SEE IF -EMBEDDED- WRITE
ZR X1,WINT4
MX0 18+18
BX6 X0*X1
SX0 A5 ATTACH NEW COMMAND ADDRESS
BX6 X0+X6
SA6 INEMBED SET -EMBED- FLAG
SA5 X1 RESTORE -EMBED- COMMAND ADDRESS
LX6 18
SX0 X6 PICK OFF ECS BIAS
LX6 18
SB1 X6 PICK OFF ECS LENGTH
SX1 B1-VARBUFL+1
PL X1,WERXBIG CHECK LENGTH
SA1 ECSXSTO POINTER TO ECS XSTOR OF UNIT
IX0 X0+X1 INDEX INTO LESSON BINARY
SA0 VARBUF+1
+ RE B1 READ COMMANDS TO *VARBUF*
RJ ECSPRTY
SA1 WRTSAV3
SX6 X1 RESTORE EXIT COMMAND
SA6 VARBUF
*
WINT4 SA1 WRTSAV3 PICK UP RETURN ADDRESS
AX1 18
SB1 X1
JP B1 RETURN TO CALLING ROUTINE
*
*
WRTSAV1 EQU TBINTSV+9
WRTSAV2 EQU TBINTSV+10
WRTSAV3 EQU TBINTSV+8
*
WERXBIG SX1 B1
SX2 VARBUFL-1 MAX NO. EMBEDS
EQ ERXMBED
*
* /--- BLOCK STEP 00 000 82/06/28 11.59
TITLE -STEP- SINGLE COMMAND EXECUTION
*
*
* -STEP-
* PROCESSING FOR STEP MODE EXECUTION - ALLOWS AN
* AUTHOR TO STEP THROUGH HIS LESSON ONE COMMAND
* AT A TIME
*
*
ENTRY STEP
*
STEP FINISH ILLEGAL IN -FINISH- UNIT
SA1 TBNARGS GET -STEP- COMMAND COUNT
LX1 60-STEPCSF
MX0 -6 MASK FOR SIX BIT COUNTER
BX6 X0*X1
BX1 -X0*X1 MASK OFF COMMAND COUNT
ZR X1,STEP05
SX1 X1-1 DECREMENT COMMAND SKIP COUNT
BX6 X1+X6
LX6 STEPCSF REPOSITION WORD
SA6 A1
EQ PROC1 GO PROCESS THIS COMMAND
*
STEP05 SA1 INEMBED
NZ X1,PROC1 EXIT IF IN EMBEDDED -WRITE-
SA1 INARGS
NZ X1,PROC1 EXIT IF ARGUMENTS IN HAND
SA1 TBITS
LX1 BRKBIT
NG X1,PROC1 EXIT IF -NOBREAK-
CALL LIBTEST,TBLESAC CHECK FOR SYSTEM LIB LESSN
NG X6,PROC1 -- STEP-OFF IN SYSLIB LESSONS
MX0 -XCMNDL MASK FOR COMMAND CODE
*
SSKIP SA1 A5-1
BX6 -X0*X1 SAVE COMMAND NUMBER
SA2 X6+JTABLE LOAD COMMAND TABLE ENTRY
LX2 B7,X2 SHIFT TO PROPER CONTINGENCY BIT
NG X2,STEP10 JUMP IF LEGAL IN THIS STATE
SA5 A5-1
EQ SSKIP GO ON TO NEXT COMMAND
*
STEP10 SA6 VARBUF
SX6 B7 SAVE CONTINGENCY
SA6 VARBUF+1
SB1 A1 COMPUTE COMMAND BIAS
SX6 B5-B1
SA6 VARBUF+2 SAVE COMMAND BIAS
SA1 TUNAME
BX6 X1 SAVE MAIN UNIT NAME
SA6 VARBUF+3
SA1 TUNAMEC SAVE CURRENT UNIT NAME
LX1 12
MX6 48
BX6 X6*X1 SAVE CURRENT UNIT NAME
SA6 VARBUF+4
*
SA1 TBASE
ZR X1,STEP15 JUMP IF NO BASE UNIT
CALL HOLUNIT,TBASE,(VARBUF+5)
EQ STEP20
*
STEP15 SX6 1R0 0 = NO BASE UNIT
LX6 60-6
SA6 VARBUF+5
*
STEP20 CALL SYSLIB,(=5LSTEPX),-1
STOPCHK PROCESS -STOP1- KEY
EQ PROC1
*
* /--- BLOCK STEP 00 000 74/01/14 05.17
*
ENTRY POSTEP
* ANOTHER PIECE OF TRASH FROM HELL. A JUMP TO
* *POSTEP* IS PLANTED AT *EXECUTX* IN DECK LOGICX
* DURING TIME-SLICE INITIALIZATION IN *PINITX* IF
* THE USER IS IN STEP MODE. HOWEVER, THERE SEEM TO
* BE WAYS FOR COMMANDS TO RE-START EXECUTION W/O
* GOING THRU *PINITX* (LIKE -ARROW- WHEN A JKEY IS
* PRESSED) AND THUS WIND UP HERE W/O BEING IN STEP.
* THIS KLUDGE PREVENTS THE MESSAGE FROM BEING DIS-
* PLAYED, SORRY 'I DON'7T HAVE THE TIME TO FIX THE
* ROOT OF THE PROBLEM. HARKRADER 83/08/09.
*
POSTEP BSS 0 SEE LOGICX (PINITX AND PAUSE)
SA1 TBITS *** TRAP *** BE SURE IN -STEP-
LX1 STEPBIT
PL X1,POSTEXC -- NOT IN STEP, RETURN TO PROC.
RJ STEPXX PLOT *WAITING FOR KEY* MESSAGE
EQ POSTEXC
*
*
ENTRY STEPXX
STEPXX EQ *
RJ STEPAA ERASE BOTTOM OF SCREEN
TWRIT =3003,=19,(=19H WAITING FOR KEY )
RJ STEPBB
EQ STEPXX
*
*
STEPAA EQ *
SA1 NX SAVE CURRENT X POSITION
BX6 X1
SA6 ISAVE
SA1 NY SAVE CURRENT Y POSITION
BX6 X1
SA6 ISAVE+1
* SAVE -SIZE BOLD- STATUS.
SA1 FSTFLGS
LX1 60-SIZBOLD
BX6 X1
SA6 SAVESBF
CLRFBIT SIZBOLD
SX1 3 SET TO WRITE MODE
OUTPUT WEFCODE
CALL WHROUT,=3001
CALL ERSOUT,=64
CALL WHROUT,=3101
CALL ERSOUT,=64
CALL WHROUT,=3201
CALL ERSOUT,=64
EQ STEPAA
*
*
STEPBB EQ *
SA1 ISAVE
BX6 X1 RESTORE NX
SA6 NX
SA1 ISAVE+1
BX6 X1 RESTORE NY
SA6 NY
CALL WHRFOUT,ISAVE,ISAVE+1
MX0 -3
SA1 TBNARGS RESTORE AUTHORS W/E MODE
AX1 6
BX1 -X0*X1
OUTPUT WEFCODE
* RESTORE -SIZE BOLD-.
SA1 SAVESBF
PL X1,STEPBB IF NO -SIZE BOLD- IN EFFECT
SETFBIT SIZBOLD
EQ STEPBB
*
ISAVE BSS 2
SAVESBF BSS 1 1/SIZE BOLD FLAG, 59/UNUSED
*
*
* /--- BLOCK STEP 00 000 78/10/01 00.06
TITLE -STEP- COMMAND
*
*
*
* -STEP- COMMAND
* ACTIVATE/DEACTIVATE -STEP- MODE EXECUTION
*
*
* CHANGED TO ALLOW ALL USER TYPES TO USE STEP MODE
*
* 'MIKE 'VOLLMER 78/09/08
*
ENTRY STEPX
*
STEPX NGETVAR 0 = NORMAL MODE 1 = STEP MODE
MX6 1
LX6 -STEPBIT FORM MASK FOR STEP BIT
SA2 TBITS
ZR X1,STEPOFF EXIT FROM -STEP- MODE
BX3 X6*X2
NZ X3,PROC EXIT IF ALREADY IN -STEP- MODE
BX6 X2+X6
SA6 A2 BEGIN STEP MODE EXECUTION
EQ STEPX5
*
STEPOFF BX3 X6*X2 EXIT IF NOT IN -STEP- MODE
ZR X3,PROC
BX6 -X6*X2 CLEAR -STEP- BIT
SA6 A2
* CLEAR TEMP BUSY FLAG
SA1 STATION
SA2 AGROUP
IX0 X1+X2 EM ADDR OF ENTRY FOR THIS STAT.
MX6 1 FORM SINGLE BIT MASK
RX1 X0 READ FROM EM
LX6 2 SHIFT TO TEMP BUSY POSITION
BX6 -X6*X1 CLEAR IT
WX6 X0 WRITE TO EM
RJ STEPAA ERASE BOTTOM OF SCREEN
RJ STEPBB
*
STEPX5 MX6 -6 MASK FOR STEP COMMAND COUNT
LX6 STEPCSF
SA1 TBNARGS
BX6 X6*X1 CLEAR OUT COMMAND COUNT
SA6 A1
EQ XSLICE
*
*
* /--- BLOCK ADD1 00 000 74/03/12 23.55
*
*
* -ADD1- (CODE=104)
*
* ADD 1 TO SPECIFIED VARIABLE(S)
*
ENTRY ADD1X
ADD1X BX1 X5
LX1 XFBIT
PL X1,ADD1I JUMP IF INTEGER VARIABLE
FGETVAR X1 = FLOATING POINT VALUE
SA2 =1.0
FX6 X1+X2 ADD 1.0
NX6 X6
SA5 A5 RESTORE X5
LX5 XCODEL
FPUTVAR STORE INCREMENTED VALUE
EQ PROC
*
ADD1I NGETVAR X1 = INTEGER VALUE
SX2 1
IX6 X1+X2 ADD 1
SA5 A5 RESTORE X5
LX5 XCODEL
NPUTVAR STORE INCREMENTED VALUE
EQ PROC
*
*
* -SUB1- (CODE=105)
*
* SUBTRACT 1 FROM SPECIFIED VARIABLE
*
ENTRY SUB1X
SUB1X BX1 X5
LX1 XFBIT
PL X1,SUB1I JUMP IF INTEGER VARIABLE
FGETVAR X1 = FLOATING POINT VALUE
SA2 =1.0
FX6 X1-X2 SUBTRACT 1.0
NX6 X6
SA5 A5 RESTORE X5
LX5 XCODEL
FPUTVAR STORE DECREMENTED VALUE
EQ PROC
*
SUB1I NGETVAR X1 = INTEGER VALUE
SX2 1
IX6 X1-X2 SUBTRACT 1
SA5 A5
LX5 XCODEL
NPUTVAR STORE DECREMENTED VALUE
EQ PROC
*
TITLE OKWORD AND NOWORD
* -OKWORD- (CODE=223)
*
* SETS VARIABLE *TOKWORD* TO SPECIFIED CHARACTER
* STRING TO PLOT FOR -OK- JUDGMENTS.
*
ENTRY OKWORDX
*
OKWORDX AX5 XCMNDL
SA1 B5+X5 GET EXTRA STORAGE WORD
BX6 X1
SA6 TOKWORD
EQ PROC --- EXIT
*
*
*
* -NOWORD- (CODE=224)
*
* SETS VARIABLE *TNOWORD* TO SPECIFIED CHARACTER
* STRING TO PLOT FOR -NO- JUDGMENTS.
*
ENTRY NOWORDX
*
NOWORDX AX5 XCMNDL
SA1 B5+X5 GET EXTRA STORAGE WORD
BX6 X1
SA6 TNOWORD
EQ PROC --- EXIT
* /--- BLOCK SCOR-STATU 00 000 77/07/25 20.40
*
*
*
TITLE -SCORE- AND -STATUS- COMMANDS
*
* SCORE N1 PLACES VALUE OF N1 INTO RESERVED
* WORD -LSCORE-. VALUE MUST BE BETWEEN 0 AND 100
* BLANK TAG SETS LSCORE TO -1 ; NO SCORE FOR LESSON
*
ENTRY SCOREX
SCOREX NG X5,SCORB TEST FOR BLANK TAG
NGETVAR
NG X1,SCORB SET TO -NOT DONE-
SX2 100 EXECERR IS PASSED X1 AND X2
IX0 X2-X1
NG X0,SERXBIG CANT BE GREATER THAN 100
EQ SCORST
*
SERXBIG EXECERR 107 SCORE TOO BIG
*
*
SCORB MX1 1
LX1 8 SET UPPER BIT
SCORST SA2 TBSCORE
MX0 -8 SCORE IS IN LOWER 8 BITS
BX2 X0*X2 CLEAR OUT CURRENT SCORE
BX6 X1+X2 ADD IN NEW SCORE
SA6 TBSCORE
EQ PROC
*
*
* -STATUS- COMMAND FOR LONG-TERM RESTART INFO
ENTRY STLSTAT
STLSTAT NGETVAR
BX6 X1
SA6 LSTATUS
EQ PROC
*
* /--- BLOCK GRAFS 00 000 75/10/17 23.18
TITLE VARIOUS GRAPHING SUBROUTINES
* /--- BLOCK SCALXY 00 000 75/08/10 02.46
*
*
* SUBROUTINE TO CONVERT SCALED XDATA, YDATA VALUES
* TO RELATIVE DOTS IN XDOT,YDOT (+X3,X4),
* AND TO ABSOLUTE SCREEN DOTS IN X6,X7.
* (X6,7 ALSO MASKED TO 9BITS IN X1,2)
* MAY USE ALL AVAILABLE REGISTERS
*
ENTRY SCALXY,XDOT,YDOT
*
SCALXY EQ *
SA2 GDATA2
LX2 59 SHIFT POLAR FLAG TO TOP
NG X2,PSCAL JUMP IF POLAR FLAG SET
SCALXY2 RJ X2DOT X6=ROUNDED XDOT VALUE
UX7 B2,X6 FIX
LX7 B2,X7 TO INTEGER
SA7 XDOT SAVE IT
RJ Y2DOT X6=ROUNDED YDOT VALUE
UX7 B2,X6 INTEGER FIX
LX7 B2,X7
SA7 YDOT SAVE IT
BX4 X7 IN X4 TOO
SA1 GDATA GET GRAF DATA
MX0 51
LX1 20 POSITION YORG
BX2 -X0*X1 YORG
LX1 51
BX1 -X0*X1 XORG
SA3 XDOT
IX6 X1+X3 X+XORG
IX7 X7+X2 Y+YORG
BX2 -X0*X7
BX1 -X0*X6
EQ SCALXY
*
PSCAL SA1 YDATA IS ANGLE IN RADIANS
CALL TSINX SIN(ANGLE) INTO X1
BX7 X1
SA1 YDATA GET ANGLE AGAIN
SA7 A1 AND SAVE SINE
CALL TCOSX COS(ANGLE) INTO X1
SA2 YDATA SIN INTO X2
SA3 XDATA RADIUS IN X3
RX6 X3*X1 R COS A
RX7 X3*X2 R SIN A
SA6 A3 FOR X CONVERSION
SA7 A2 FOR Y CONVERSION
EQ SCALXY2
*
XDOT BSS 1
YDOT BSS 1
* /--- BLOCK X2DOT 00 000 76/01/23 23.01
EJECT
*
* SUBROUTINE TO CONVERT FLOATING X (IN XDATA)
* TO FLOATING DOT VALUE RELATIVE TO ORIGIN (IN X6)
* LEAVES (XMAX-XOFFSET) IN X2 FOR LABLXY
*
ENTRY X2DOT,X2DOT2
X2DOT EQ *
SA1 GDATA GET AXES INFO
NG X1,X2DOTL JUMP IF LOG SCALE
X2DOT2 LX1 60-2*PFIELD
AX1 60-PFIELD EXTEND SIGN OF (X+)
NZ X1,X2DOT5 USUALLY X+ IS NONZERO
SA1 GDATA IF NOT, USE X-
LX1 60-4*PFIELD
AX1 60-PFIELD
X2DOT5 PX1 X1
NX1 X1 FLOAT (X+)
SA2 GXMAX
SA3 XOFFSET
RX2 X2-X3 XMAX-XOFFSET
NX2 X2
RX2 X1/X2 (X+)/(XMAX-XOFFSET)
SA1 XDATA
RX1 X1-X3 X-XOFFSET
NX1 X1
RX6 X1*X2 (X-XOFFSET)(X+)/(XMAX-XOFFSET)
SA1 =.5
BX3 X6 ROUND ACCORDING TO SIGN
AX3 60
BX1 X1-X3 +.5 OR -.5
FX6 X6+X1 ROUND IT
NX6 X6
EQ X2DOT
*
*
X2DOTL SA1 XDATA
CALL TLOGX
BX7 X1
SA7 XDATA
SA1 GDATA
EQ X2DOT2
EJECT
*
* SUBROUTINE TO CONVERT FLOATING Y (IN YDATA)
* TO FLOATING DOT VALUE RELATIVE TO ORIGIN (IN X6)
* LEAVES (YMAX-YOFFSET) IN X2 FOR LABLXY
*
ENTRY Y2DOT,Y2DOT2
Y2DOT EQ *
SA1 GDATA GET (Y+)
LX1 1 CHECK LOG SCALE FLAG
NG X1,Y2DOTL JUMP IF LOG SCALE
AX1 1
Y2DOT2 LX1 60-PFIELD
AX1 60-PFIELD EXTEND SIGN
NZ X1,Y2DOT5 USUALLY Y+ IS NONZERO
SA1 GDATA IF Y+=0, USE Y-
LX1 60-3*PFIELD
AX1 60-PFIELD
Y2DOT5 PX1 X1
NX1 X1 FLOAT (Y+)
SA2 GYMAX
SA3 YOFFSET
FX2 X2-X3 YMAX-YOFFSET
NX2 X2
RX2 X1/X2 (Y+)/(YMAX-YOFFSET)
SA1 YDATA
FX1 X1-X3 Y-YOFFSET
NX1 X1
RX6 X1*X2 (Y-YOFFSET)(Y+)/(YMAX-YOFFSET)
SA1 =.5
BX3 X6 ROUND ACCORDING TO SIGN
AX3 60
BX1 X1-X3 +.5 OR -.5
FX6 X6+X1 ROUND IT
NX6 X6
EQ Y2DOT
*
*
*
Y2DOTL SA1 YDATA
CALL TLOGX
BX7 X1
SA7 YDATA
SA1 GDATA
EQ Y2DOT2
*
* /--- BLOCK NUSETX 00 000 78/04/04 18.32
TITLE GRAFS SUBROUTINES
*
*
*
* SUBROUTINE TO EXPAND GRAFDATA
* PUTS X-,Y-,X+,Y+,XORG,YORG INTO
* TBINTSV, TBINTSV+1, ......, TBINTSV+5
*
ENTRY GDATAX
GDATAX EQ *
SB1 1
MX0 51
SA1 GDATA
LX1 20 2 FLAG BITS AND ORIGIN
BX6 -X0*X1
SA6 YORGIN SAVE ORIGIN
LX1 51
BX6 -X0*X1
SA6 A6-B1 SAVE XORG
LX1 4*PFIELD+9 POSITION Y+ AT RIGHT
MX0 60-PFIELD
SB2 XMINUS SAVE X- THRU Y+ IN ORDER
GDLOOP BX6 -X0*X1 GET NEXT ARG
LX6 60-PFIELD
AX6 60-PFIELD EXTEND SIGN
SA6 A6-B1 PLANT
LX1 60-PFIELD
SB3 A6
GT B3,B2,GDLOOP
EQ GDATAX
*
*
* SUBROUTINE TO PUT OUT LINE FROM X1,X2,X3,X4
*
ENTRY LINIT
LINIT EQ *
ZR X0,LINIT1 JUMP IF NO WINDOWING
CALL WINDOW
NZ X0,LINIT JUMP IF LINE HAS BEEN DRAWN
LINIT1 MX0 51
BX1 -X0*X1
BX2 -X0*X2 MASK ALL X,Y TO 9 BITS
BX3 -X0*X3
BX4 -X0*X4
LX1 9
BX1 X1+X2 X1,Y1
OUTPUT WFCODE
BX1 X3
LX1 9
BX1 X1+X4 X2,Y2
OUTPUT LFCODE
BX6 X3
SA6 NX UPDATE X
BX7 X4
SA7 NY UPDATE Y
MX0 0 SIGNAL THAT LINE NOT WINDOWED
EQ LINIT
*
*
* SUBROUTINE TO PUT OUT LINER FROM X3,X4
*
ENTRY LINRIT
LINRIT EQ *
SA1 TBWNDOW
BX0 X1
SA1 NX
SA2 NY
ZR X0,LINRIT1 JUMP IF NO WINDOWING
CALL WINDOW
NZ X0,LINRIT JUMP IF LINE HAS BEEN DRAWN
LINRIT1 MX0 -9
BX3 -X0*X3
BX4 -X0*X4
BX1 X3
LX1 9
BX1 X1+X4 X2,Y2
OUTPUT LFCODE
BX6 X3
SA6 NX UPDATE X
BX7 X4
SA7 NY UPDATE Y
MX0 0 SIGNAL LINER WAS NOT WINDOWED
EQ LINRIT
*
* /--- BLOCK NUSETX 00 000 78/04/04 18.32
TITLE -SET- COMMAND EXECUTION ROUTINE
*
* SET ARRAY_ARG1,ARG2,ARG3,...
* SET ARRAY(R,C)_ARGI,ARGJ,ARGK,...
* SET V1_ARG1,ARG2,...
*
* FILLS CONSECUTIVE VARIABLES WITH ITEMS IN LIST
* BEGINNING AT FIRST ARGUMENT AND GOING UP
* GIVES ERROR MSG AT CONDENSE TIME (IF POSSIBLE)
* OR EXEC TIME IF LIST RUNS OVER PERMISSIBLE BOUNDS
* OF ARRAY OR STUDENT VARIABLES
*
ENTRY SETX
EXT ARAYFLG,ARAYERR,TOOMUCH
*
SETX LX5 XCODEL
MX0 -XCODEL GET NUMBER OF ARGUMENTS
BX6 -X0*X5
SX6 X6-3 NUMBER OF -SET- LIST ITEMS -1
SA6 ITEMS
*
LX5 XCODEL
BX7 -X0*X5
SA7 MAXADDR SAVE MAX BANK/ARRAY ADDR
*
LX5 60-2*XCODEL-XCMNDL
MX0 2*XCODEL+XCMNDL
BX6 -X0*X5 POINTER TO XTRA STORAGE
SA6 XPTR
SA2 B5+X6 1ST XSTOR WD HAS START GETVAR
BX5 X2
*
SX7 0
SA7 ARAYFLG PRESET ARRAY TEST
SB3 SETX02 SETUP
NGET EQ NGETVAR
SETX02 SX6 A1 INITIAL ADDRESS
SB1 A1 SAVE HERE FOR BANK LIMIT TEST
SA6 SADDR
* MODIFY LOOP FOR I/F TYPE OF RESULT
SX6 0
SA1 ARAYFLG
ZR X1,SETX04 JUMP IF NOT WHOLE ARRAY
SA2 X1 GET ARAY INFO WORD
LX2 3
PL X2,SETX03 JUMP IF NOT SEGMENTED
SA3 A2+1 GET 2D ARAY INFO WD
BX6 X3 NONZERO FOR SEGMENTED FLAG
LX3 1
PL X3,ERXHSEG NO HORIZ SEGMENTS YET
SETX03 LX2 60-XCODEL-3 ROTATE GETVAR TO TOP
EQ SETX06
SETX04 SA1 XPTR
SA2 B5+X1 1ST XSTOR WD HAS START GETVAR
SETX06 LX2 XFBIT PUT I/F BIT AT TOP
SA3 NGET
SA6 ARAYWRD SAVE SEGMENT FLAG
PL X2,SETX08
SA3 FGET
* /--- BLOCK NUSETX08 00 000 79/02/09 12.14
*
SETX08 BX6 X3 PLANT NGETVAR/FGETVAR
SA6 SETX30 IN EVALUATION LOOP
*
SX7 20
SA7 BYTE *CLS*20 TO GET NEXT GETVAR
SA2 MAXADDR
NZ X2,SETLOOP JUMP IF MAXADDR SET AT CONDEN
* MUST DETERMINE BANK LIMIT FROM START ADDRESS
SB2 STUDVAR
LT B1,B2,ARAYERR ERROR IF BELOW STUD BANK
SB2 STUDVAR+VARLIM
LT B1,B2,SETX15 JUMP IF IN STUD BANK
SB2 RVARBUF
LT B1,B2,ARAYERR ERROR IF BELOW ROUTER BANK
SB2 RVARBUF+RVARLIM
LT B1,B2,SETX15 JUMP IF IN ROUTER BANK
SB2 NCVRBUF NC VARS
LT B1,B2,ARAYERR ERROR IF BELOW COMMON BANK
SB2 NCVRBUF+NCVRLIM NC VARS
GE B1,B2,ARAYERR ERROR IF PAST COMMON LIMIT
SETX15 SX7 B2 COME HERE WITH B2=BANK LIMIT+1
SA7 MAXADDR SAVE FOR LIMIT TEST
*
* /--- BLOCK SETLOOP 00 000 78/04/04 18.32
*
SETLOOP SA1 ITEMS
NG X1,PROCESS QUIT WHEN ALL ITEMS GONE
SX7 X1-1 DECREMENT COUNT
SA7 A1
SA1 XPTR
SA2 BYTE
SB1 X2
SA3 X1+B5
LX5 X3,B1 PUT PROPER BYTE AT TOP OF X5
SB2 60
SB1 B1+20 INCREMENT BYTE
LT B1,B2,SETX25
SB1 B0 IF PROCESSED 3 BYTES IN WORD
SX1 X1+1 RESET BYTE AND INCREMENT XPTR
SETX25 SX7 B1
SA7 A2
SX6 X1 RESTORE BYTE AND XPTR
SA6 A1
SB3 SETX31 SETUP RETURN FROM GETVAR
SETX30 EQ NGETVAR (OR FGETVAR IF FLOATING RESULT)
*
SETX31 SA2 MAXADDR RETURN WITH X1=RESULT
SA3 SADDR
*
IX4 X3-X2
PL X4,ARAYERR JUMP IF INDEX EXCEEDS DOMAIN
BX6 X1 RESULT
SA2 ARAYWRD
ZR X2,SETX40 JUMP IF NOT SEGMENTED
MX0 -6 MUST PRESERVE A3,X3,X6=RESULT
AX2 42
BX5 -X0*X2 STARTBIT
AX2 6
BX4 -X0*X2 BITS/BYTE
SA1 X3 GET DESTINATION WORD
MX0 1
SB1 X4-1 BB-1
AX0 X0,B1 FORM BB MASK
IX7 X5+X4 SB+BB
BX7 -X7
SB1 X7+61 60-(SB-1)-BB=POSITION SHIFT
LX6 X6,B1 POSITION RESULT
SB1 B1+X4 ADD BB TO GET 60-(SB-1)
LX0 X0,B1 POSITION MASK
BX6 X0*X6 CLEAR OUT JUNK IN RESULT
BX1 -X0*X1 AND DESTINATION WORD
BX6 X1+X6 MERGE IN RESULT
SETX40 SA6 X3 STORE IT IN SADDR
SX7 X3+1 INCREMENT SADDR
SA7 A3
EQ SETLOOP
*
* SERXSEG EXECERR CALCERR,118 HORIZONTAL TYPE SEGMENT ILLEGAL
*
ITEMS EQU VARBUF
MAXADDR EQU VARBUF+1
SADDR EQU VARBUF+2
BYTE EQU VARBUF+3
XPTR EQU VARBUF+4
ARAYWRD EQU VARBUF+5
*
FGET EQ FGETVAR
*
* /--- BLOCK LSNX 00 000 78/10/12 17.33
TITLE -LESSON- COMMAND
*
* LESSON -COMPLETED-, -INCOMPLETE-, -NO END-
* SETS RESERVED WORD -LDONE- (ACTUALLY SOMEWHAT
* INDIRECTLY, BY SETTING A 5-BIT FIELD IN
* TBSCORE WHICH IS INTERPRETED WHEN LDONE
* IS REFERENCED)
*
*
ENTRY LSNCX
ENTRY LSNX
LSNCX CALL GETTAG GET TAG
LSNX MX0 XJDGL
BX0 X0*X5 EXTRACT RESULT
ZR X0,PROC -X-
LX0 XJDGL PLACE LOWER (VALUES 1,2,3)
SX0 X0-1 0 INCOMPLETE, 1 COMPLETED, 3 NO END
* (LDONE VALUES ARE 0 INCOMPLETE, -1 COMPLETED, 1 NO END)
*
* WOULD MAKE MORE SENSE TO USE XJDGL FOR POSITIONING OF
* LDONE INFO IN TBSCORE, BUT EXISTING DISK RECORDS FOR
* STUDENTS HAVE THE 5-BIT FORMAT --
SA1 TBSCORE
MX6 5
BX1 -X6*X1 CLEAR UPPER 5 BITS
LX0 -5 SHIFT TO UPPER 5 BITS
BX6 X1+X0
SA6 A1
EQ PROC
* /--- BLOCK KERMIT 00 000 79/02/12 17.08
*
* * * KERMIT COMMAND EXECUTION ROUTINE
*
ENTRY KERMITX
KERMITX SX6 -1
SA6 TRETURN
EQ PROC -- EXIT
*
* /--- BLOCK END 00 000 79/02/12 17.08
TITLE TRANSFR EXECUTION
*
* TRANSFR (FROM);(TO);LENGTH
* TRANSFERS DATA FROM THE (FROM) VARIABLES/ECS TO
* THE (TO) VARIABLES/ECS.
* 'ANY CENTRAL MEMORY LOCATIONS ARE GUARANTEED TO
* BE PROTECTED BY A CURRENT COMLOAD/STOLOAD.
*
TRLENG EQU SHOWOUT
TRTO EQU TRLENG+1
TRFROM EQU TRTO+1
*
ENTRY TRANSX
TRANSX BSS 0
NGETVAR 3 GET LENGTH
ZR X1,PROC ALL DONE IF ZERO
NG X1,ERXBADL DO NOT ALLOW NEGATIVE LENGTHS
BX6 X1
SA6 TRLENG STORE LENGTH
SA5 A5 RE-FETCH COMMAND
MX0 2*XCODEL+XCMNDL
AX5 XCMNDL
BX5 -X0*X5 GET EXTRA ARGUMENT POINTER
SA1 B5+X5 GET NEXT TWO ARGUMENTS
BX6 X1 SAVE IT LOCALLY
SA6 TRTO
BX5 X1 MOVE INTO PLACE
NGETVAR 1 GET -FROM- ARGUMENT
SA5 A5 GET COMMAND WORD AGAIN
LX5 2*XCODEL TO RIGHT END
MX0 -3
BX0 -X0*X5 GET TRANSFER TYPE (FROM)
SB1 X0
EQ B1,B0,TRANFM
BX6 X1 STORE VALUE OF ECS
SA6 TRFROM RELATIVE ADDRESS
SA1 TBCOMLS-1+B1
CALL SETSTOR INFO IN *STORWRD* AND X6
CALL ECSBNDS,TRFROM,TRLENG USES STORWRD
* AND RESETS TRFROM TO THE STARTING ECS ADD
EQ TRANSF2
*
* /--- BLOCK TRANSFER 00 000 78/07/05 01.23
TRANFM SX6 A1 SAVE CM -FROM-
SA6 TRFROM IN TRFROM
SA0 A1
SA1 TRLENG GET LENGTH
CALL BOUNDS ERRORS DO NOT RETURN
*
TRANSF2 SA1 TRTO GET EXTRA STORAGE ARGUMENTS
BX5 X1
LX5 XCODEL 4TH ARGUMENT (-TO-)
NGETVAR INC GET -TO-
SA5 A5 GET TRANSFER TYPE AGAIN
LX5 2*XCODEL-3
MX0 -3
BX0 -X0*X5 GET TRANSFER CODE (TO)
SB1 X0
EQ B1,B0,TRANTM
*
BX6 X1 REL ECS LOC
SA6 TRTO SAVED IN TRTO
SA1 TBCOMLS-1+B1
JP B1+*
*
+ EQ TRC COMMON
+ EQ TR10 STORAGE
+ NG X1,ERXROLV ROUTER/ READ ONLY VARIABLES
EQ TR10
+ EQ ERXROLV ROUTER VARS/ READ ONLY
*
TRC BX2 X1 CHECK READ-ONLY BIT
LX2 1
NG X2,ERXROLC ERROR IF READ-ONLY COMMON
*
TR10 CALL SETSTOR INFO IN *STORWRD* AND X6
*
CALL ECSBNDS,TRTO,TRLENG USES STORWRD;
* AND RESETS TRTO TO THE ECS ADDRESS
EQ TRANSXX
*
* /--- BLOCK TRANSFER 00 000 79/04/19 00.18
*
TRANTM SX6 A1 CM ADDRESS -TO-
SA6 TRTO
SA0 A1
SA1 TRLENG
CALL BOUNDS ERRORS DO NOT RETURN
*
TRANSXX SA5 A5 PICK UP TRANSFER TYPE AGAIN
LX5 2*XCODEL
MX0 -3
BX6 -X0*X5 (FROM)
AX5 3 (TO)
BX7 -X0*X5
IX0 X6+X7 ADD THEM TO TEST FOR ZERO
ZR X0,TRANMM CM TO CM
ZR X6,TRANMC CM TO ECS
ZR X7,TRANCM ECS TO CM
*
* REST ARE ECS TO ECS
*
* MUST UNLOAD ANY COMMON/STORAGE BEFORE DOING AN
* EM TO EM TRANSFER. MUST UPDATE EM COPY OF
* COMMON AND/OR STORAGE BEFORE TRANSFER, AND
* RELOAD AFTER TRANSFER TO UPDATE CM COPY.
*
CALL ULOADCS UNLOAD ANY COMMON/STORAGE
SA1 TRTO
SA2 TRFROM
SA3 TRLENG
MX7 -1 MARK NO ECS ERROR RECOVERY
CALL MVECS USES ENTIRE WORK BUFFER
CALL LOADCS RELOAD ANY COMMON/STORAGE
EQ PROC -- EXIT
*
* CM TO CM TRANSFER
*
TRANMM SA4 ATEMPEC ADDRESS OF TEMP BUFFER
BX0 X4 SET X0
SX6 1
SA6 ERXARGN SET EXECERR ARGUMENT NUMBER
SA1 TRTO
SA2 TRFROM
SA3 TRLENG
SA0 X2
SB1 X3 LENGTH INTO B1
RJ CSBNDS (INPUT A0,X3; SAVES X1-X3)
* NO RETURN IF ERRORS
SB2 B1-TEMPLTH-1 MUST FIT IN BUFFER
PL B2,TERXLNG
+ WE B1
RJ ECSPRTY
SX6 2
SA6 ERXARGN SET EXECERR ARGUMENT NUMBER
SA0 X1 -TO- ADDRESS
SB1 X3
RJ CSBNDS NO RETURN IF ERROR
+ RE B1
RJ ECSPRTY
EQ PROC TRANSFER DONE
*
TERXLNG SX1 B1
EQ ERXBADL
*
* /--- BLOCK TRANSFER 00 000 79/04/19 00.18
*
* THIS CORRESPONDS TO UNLOADC
*
* CM TO ECS TRANSFER
*
* MUST UNLOAD ANY COMMON/STORAGE BEFORE DOING AN
* CM TO EM TRANSFER. MUST UPDATE EM COPY OF
* COMMON AND/OR STORAGE BEFORE TRANSFER, AND
* RELOAD AFTER TRANSFER TO UPDATE CM COPY.
*
TRANMC CALL ULOADCS UNLOAD ANY COMMON/STORAGE
SX6 1 SET EXECERR ARGUMENT NUMBER
SA6 ERXARGN
SA1 TRTO
SA2 TRFROM
SA3 TRLENG
SA0 X2
SB1 X3
BX0 X1
RJ CSBNDS (INPUT A0,X3) NO RETURN IF ERR
*
+ WE B1 WRITE FROM A0 TO X0, FOR B1
RJ ECSPRTY
CALL LOADCS RELOAD ANY COMMON/STORAGE
EQ PROC -- EXIT
*
* THIS CORRESPONDS TO LOADC
*
* ECS TO CM TRANSFER
*
** FOLLOWING LINE ADDED SO THAT THE SOURCE
** OF DATA IS THE ',CURRENT', COPY
TRANCM CALL ULOADCS UNLOAD ANY COMMON/STORAGE
CALL LOADCS RELOAD ANY COMMON/STORAGE
SX6 2 SET EXECERR ARGUMENT NUMBER
SA6 ERXARGN
SA1 TRTO
SA2 TRFROM
SA3 TRLENG
SA0 X1
SB1 X3 LENGTH
BX0 X2 ECS ADDRESS
RJ CSBNDS (A0,X3 INPUT) NO RETURN IF ERR
+ RE B1 READ FROM X0 TO A0, FOR B1
RJ ECSPRTY
EQ PROC -- EXIT
*
*
*
*
* CSBNDS EXPECTS THE CM ADDRESS IN A0, AND THE
* LENGTH IN X3. B1 IS PRESERVED
*
*
CSBNDS EQ * USES B2,B3,A4,X4,X7
SB3 A0
SA4 LVUCNT
SB2 X4+LVARBUF
SB3 X3+B3
LE B3,B2,CSBNDS
SX7 5
SA4 TCOMSET
CKLP ZR X4,ENDLP
SB3 A0
SB2 X4
LT B3,B2,ENDLP
AX4 18+18
SB2 X4+B2 STO/COM LOAD LENGTH+START
SB3 X3+B3
LE B3,B2,CSBNDS
ENDLP SX7 X7-1
SA4 A4+1
PL X7,CKLP
* CHECK ERROR
EXECERR 61 *MUST BE COMLOADED/STOLOADED*
* /--- BLOCK MOVE 00 000 79/04/19 07.47
TITLE MOVE
* -MOVE-
*
* MOVE CHARACTERS A 60-BIT WORD AT A TIME VERSES
* CHARACTER BY CHARACTER
*
* COMMAND WORD HOLDS TWO 20 BIT CODES AND
* XTRA STORAGE POINTER.
*
* SINGLE XTRA STORAGE WORD HOLDS 2 20 BIT CODES,
* LEFT JUSTIFIED.
*
* PLUS FLAG FOR 4-ARGUMENT MOVE, LENGTH FOR 5-ARG.
* 1ST ARG = FROM WORD ADDRESS
* 2ND ARG = FROM CHAR POSITION
* 3RD ARG = TO WORD ADDRESS
* 4TH ARG = TO CHAR POSITION
* 5TH ARG = LENGTH , OR FLAG THAT LENGTH IS 1
*
* LONG MOVE (FIVE ARGUMENT MOVE)
* 5TH ARG = NUMBER OF CHARS TO MOVE
*
EXT WORDS
EXT PROCESS,PROCESX
*
EXT ERXLIT,ERXBADL ERROR EXITS, -EXEC2-
*
*
* CHECK -MOVE- PARAMETERS
ENTRY MOVEX
MOVEX NG X5,MOVLIT
NGETVAR 1 *FROM* ADDRESS
SX6 A1 INADD
EQ MOVE2
*
MOVLIT MX0 1
BX5 -X0*X5 REMOVE FLAG
MX6 -1 MARK *INFO* BUFFER USED
SA6 JJSTORE
NGETVAR 1
BX6 X1
SA6 SHOWVAL STORE HERE FOR THIS TIMESLICE
SX6 A6
*
MOVE2 SA6 FROMWRD RE-ENTER FOR NON-STORABLE
SA5 A5
LX5 XCODEL
NGETVAR 2 *FROM CHAR POSITION
SA5 A5 RETRIEVE ORIGINAL COMMAND WORD
* CHECK THAT INPOS BETWEEN 1 AND 10 (INCLUSIVE)
* FOR NON-STOREABLE FIRST ARG
PL X5,MOVE3 SKIP IF STOREABLE
SX0 X1-11
*NOTE'; X1 TO EXECERR
PL X0,ERXLIT IF GT 10, ERROR EXIT
SX0 X1-1 NOT LESS THAN 1
NG X0,ERXLIT
BX6 X0 0 TO N-1
EQ MOVE4
*
MOVE3 SA2 FROMWRD *FROM* BUFFER ADDRESS
SA0 X2 *FROM* BASE ADDRESS
RJ WORDS
SX7 B1-1 (B1) RETURNED END ADDRESS +1
SA7 FROMWRD SAVE IT
SX2 10
SX0 X0 CLEAN OUT EXPONENT
IX0 X0*X2
SX6 X1-1 *INTERNAL CHAR 0 TO N-1*
IX6 X6-X0 ACTUAL CHAR NUMBER
*
* /--- BLOCK MOVE 00 000 79/04/19 00.30
MOVE4 SA6 FROMCHR SAVE *FROM* CHAR
* GET EXTRA ARG POINTER
SA5 A5 RE-FETCH COMMAND WORD
MX0 2*XCODEL
BX5 -X0*X5 CLEAN OFF TWO -GETVAR- CODES
AX5 XCMNDL SHIFT OFF COMMAND CODE
SA1 B5+X5 X1 = 1ST EXTRA STORAGE WORD
BX6 X1
SA6 XFERLEN SAVE EXTRA WORD
BX5 X1
NGETVAR 3 *DESTINATION* ADDRESS
SX6 A1 INTO X6
SA6 TOWRD AND STORE
SA1 XFERLEN FETCH ARGS
BX5 X1
LX5 XCODEL
NGETVAR 4 GET *DESTINATION CHAR POSITION*
SA2 TOWRD FETCH DESTINATION ADDRESS IN X2
SA0 X2
RJ WORDS CHECK IN BOUNDS
SX7 B1-1 (B1) CONTAINS END ADDRESS +1
SA7 TOWRD FINAL *DESTINATION* ADDRESS
SX2 10
SX0 X0 CLEAN OUT EXPONENT (FROM WORDS)
IX0 X0*X2
SX6 X1-1 CHAR POSITION FROM 0 TO N-1
IX6 X6-X0 ACTUAL CHAR NUMBER
SA6 TOCHR *TO* CHAR POINTER
SA1 XFERLEN FETCH ARG. WORD AGAIN
LX1 2*XCODEL
NG X1,MOVE4A 4-ARGUMENT FLAG
BX5 X1
NGETVAR 5 LENGTH OF STRING TO BE MOVED
ZR X1,PROC QUIT IF MOVING NO CHARACTERS
EQ MOVE4B CHECK VALUE OF ARG 5
*
MOVE4A SX1 1 DEFAULT MOVE TO 1 CHARACTER
EQ MOVE4C GO SAVE LENGTH
*NOTE'; X1 TO EXECERR
MOVE4B NG X1,ERXBADL ERROR IF NEGATIVE LENGTH
SX0 5000
IX6 X6-X0
*NOTE'; X0,X1 TO EXECERR
ZR X6,MOVE4C IF EQUAL TO 5000, GO ON...
PL X6,MERXMAX ONLY MOVE 500 WORDS MAX
*
MOVE4C SX6 X1 SAVE LENGTH OF TRANSFER
SA6 XFERLEN
SA5 A5
PL X5,MOVE5 IF NOT LITERAL, GO CHECK *F*
SA1 FROMCHR FETCH *FROM* CHAR POSITION
IX1 X6+X1
SX0 11
IX1 X1-X0 (FROMCHR + LENGTH -11
PL X1,MERXL1 OUT OF SOURCE BOUNDS
EQ MOVE6
*
*CHECK LAST WORDS IN BOUNDS
MOVE5 SA1 FROMWRD *FROM* BUFFER ADDRESS
SA0 X1 SOURCE BASE ADDRESS
SA1 FROMCHR *FROM* CHAR POINTER
IX1 X1+X6 SOURCE CHARS
RJ WORDS CHECK LAST WORD *SOURCE*
*
* /--- BLOCK MOVE 00 000 79/04/19 00.30
MOVE6 SA1 TOWRD *TO* BUFFER ADDRESS
SA0 X1 DESTINATION BA
SA1 TOCHR *TO* CHAR POINTER
IX1 X1+X6
RJ WORDS
* SAVE *A5*, *B4*, *B5*, *B6*, AND *B7*
* (REQUIRED BY -EXEC1- SEE NOTES IN -EXEC1-)
SX6 A5 SAVE *A5* COMMAND WORD ADDRESS
SA6 MBSAVA5
SX6 B4 SAVE *B4* (STUD VARS V0 ADDR)
SA6 MBSAVB4
SX6 B5 SAVE *B5* (EXTRA STORAGE ADDR)
SA6 MBSAVB5
SX6 B6 SAVE *B6* (COMMON VARS V0 ADDR)
SA6 MBSAVB6
SX6 B7 SAVE *B7* CONTINGENCY FLAGS
SA6 MBSAVB7
* MOVE CHARACTERS
RJ MOVBITS MOVE CHARS
* RESTORE REQUIRED REGISTERS
SA1 MBSAVA5 GET ORIGINAL ADDRESS OF *A5*
SA5 X1 GET COMMAND WORD (RESTORE *A5*)
SA1 MBSAVB4 GET STUDENT VARS BASE ADDR
SB4 X1 RESTORE *B4*
SA1 MBSAVB5 GET EXTRA STORAGE BASE ADDR
SB5 X1 RESTORE *B5*
SA1 MBSAVB6 GET COMMON VARS BASE ADDR
SB6 X1 RESTORE *B6*
SA1 MBSAVB7 GET CONTINGENCY FLAGS
SB7 X1 RESTORE *B7*
SB1 1 *B1* MUST BE SET TO *1*
*
EQ PROC ALL DONE
*
MERXL1 BX1 X6
EQ ERXBADL
*
MERXMAX BX2 X0
EXECERR 73 TOO MANY CHARS TO MOVE
*
MVBUF EQU INFO
1 ERRPL 500-INFOLTH-1 INFO BUFFER TOO SMALL
*
FROMWRD BSS 1 *FROM* BUFFER ADDRESS
FROMCHR BSS 1 *FROM* CHAR POINTER
TOWRD BSS 1 *TO* BUFFER ADDRESS
TOCHR BSS 1 *TO* CHAR POINTER
XFERLEN BSS 1 LENGTH OF TRANSFER IN CHARS
MBSAVA5 BSS 1 SAVE *A5* ADDRESS
MBSAVB4 BSS 1 SAVE *B4* STUD VARS BASE ADDR
MBSAVB5 BSS 1 SAVE *B5* EXTRA STORAGE ADDR
MBSAVB6 BSS 1 SAVE *B6* COMMON VARS ADDR
MBSAVB7 BSS 1 SAVE *B7* CONTINGENCY FLAGS
*
* /--- BLOCK MOVBITS 00 000 79/04/19 00.09
MOVBITS SPACE 4,20
*** MOVBITS - MOVE BITS FROM ONE LOCATION TO ANOTHER
*
* USED BY -MOVE- COMMAND
*
* USES X - 0, 1, 2, 3, 4, 5, 6, 7.
* A - 1, 2, 3, 6, 7.
* B - 1, 2, 3, 4, 5, 6, 7.
*
* DO *NOT* CHANGE *A5*
*
*
MOVBITS PS ENTRY/EXIT
SA1 FROMWRD *FROM* BUFFER ADDRESS
SA2 FROMCHR STARTING CHARACTER IN LINE
RJ MBSETUP SET UP POINTERS
RJ MOVMASK SET UP WORD MASKING
SA1 B1 (A1) = FROM LINE ADDRESS
SA2 MVBUF-1 GET DATA IN *MVBUF*-1
BX6 X2 MOVE TO WRITE REGISTER
SA6 A2 SET *A6* AND RESTORE VALUE
SA2 XFERLEN GET LENGTH OF TRANSFER
SB5 X2 (B5) = LENGTH OF TRANSFER
SB4 0 (B4) = CHARS COPIED
SB2 B2+1 (B2) = STARTING CHAR WITHIN WD
MBFFULL BX6 X0*X1
LX6 B6 POSITION TO TOP OF WORD
SA6 A6+1 SAVE PARTIAL WORD
SA1 A1+1 GET NEXT WORD FROM *FROM*
SB4 B4+10 INCREMENT A WORD
SB4 B4-B2 COMPUTE NUMBER OF CHARS COPIED
GE B4,B5,MBXFER IF AT END, MOVE IT
ZR X0,MBFFULL FULL WORD TRANSFERRED
BX7 -X0*X1 GET TOP PART OF WORD
LX7 B6 POSITION TO LOWER PART OF WORD
BX6 X6+X7 ADD NEW CHARACTERS TO WORD
SA6 A6 SAVE OTHER PART OF WORD
SB4 B4+B2 ADD NUMBER OF CHARS COPIED
LT B4,B5,MBFFULL -- RELOOP
MBXFER SA1 TOWRD STARTING ADDRESS OF *TO* WORD
SA2 TOCHR STARTING CHARACTER IN LINE
RJ MBSETUP SET UP POINTERS
RJ MOVMASK SET UP WORD MASKING
SA1 B1 (A1) = FROM LINE ADDRESS
SA2 MVBUF (A2) = START ADDRESS OF COPY
LX2 B7 POSITION TO MATCH MASK
SA3 XFERLEN (X3) = LENGTH OF TRANSFER
SB5 X3 (B5) = LENGTH OF TRANSFER
SB3 -B2 (B2) = CHARS ON LEFT SIDE
SB3 B3+10 (B3) = CHARS ON RIGHT SIDE
* /--- BLOCK MOVBITS 00 000 79/04/19 00.09
MBMOVE SA1 A1 GET LASTEST COPY OF WORD
SB4 B5+B2 SEE IF MOVE IN MIDDLE OF WORD
SB1 10D SEE IF GREATER THAN 10 CHARS
LT B4,B1,MBSAME IF IN THE MIDDLE, DEVIATE
BX7 X0*X2 MASK OFF NEW CHARACTERS TO MASK
BX6 -X0*X1 MASK OFF CHARACTERS TO BE SAVED
BX6 X6+X7 ADD CHARACTERS
SA6 A1 REPLACE WORD WITH NEW CHARS
SB5 B5-B3 SUBTRACT CHARS MOVED
LE B5,B0,MOVBITS IF ALL CHARS MOVED, EXIT
GE B5,B2,MBLEFT IF MORE CHARS LEFT SIDE
SB4 B6 REMEMBER SHIFT COUNT
SA1 A1+1 ADVANCED TO NEXT WORD
BX2 -X0*X2 MASK OUT TOP PART OF WORD
SB2 10D CHARS/WORD
SB2 B2-B5 (SIZE OF MASK) * 6
RJ MOVMASK SET UP WORD MASKING
LX0 B6 LEFT JUSTIFY MASK
EQ MBFIN4
MBSAME BX2 X0*X2 MASK OFF NEW CHARACTERS TO MASK
LX2 B6 LEFT JUSTIFY THE DATA
SB4 B7 REMEMBER SHIFT COUNT
EQ MBFIN2
MBFIN1 BX2 X0*X2 MASK OUT LOWER PART OF WORD
LX2 B6 LEFT JUSTIFY THE DATA
MBFIN2 SB2 10D CHARS/WORD
SB2 B2-B5 (SIZE OF MASK) * 6
RJ MOVMASK SET UP WORD MASKING
SB4 B4-B7 COMPUTE NEW MASK POSITION
PL B4,MBFIN3 IF POSITIVE, CONTINUE
SB4 B4+60D MAKE POSITIVE
MBFIN3 LX0 B4 POSITION MASK TO CORRECT CHAR
LX2 B7 RIGHT JUSTIFY DATA
LX2 B4 POSITION WITH MASK
MBFIN4 BX2 X0*X2 MASK OUT JUST REQUIRED DATA
SA1 A1 RETRIEVE MODIFIED WORD
BX6 -X0*X1 GET REMAINING CHARACTERS
BX6 X6+X2 ADD NEW CHARACTERS
SA6 A1 REPLACE WORD
EQ MOVBITS END OF MOVE
MBLEFT BX7 -X0*X2 RETRIEVE LOWER CHARS FROM WORD
SA1 A1+1 ADVANCE TO NEXT WORD
BX1 X0*X1 MASK OFF LOWER PORTION OF WORD
BX7 X7+X1 UPDATE WORD
SA7 A1 REPLACE WORD
SB4 B7 REMEMBER SHIFT COUNT
SB5 B5-B2 SUBTRACT REMAINING CHARACTERS
SA2 A2+1 GET NEXT WORD OF *INFO* BUFFER
LX2 B7 POSITION TO MATCH MASK
ZR B5,MOVBITS IF ALL DONE, EXIT
LT B5,B3,MBFIN1 FINAL MOVE ROUTINE
GT B5,B0,MBMOVE IF MORE, GO TO IT
EQ MOVBITS -- EXIT
* /--- BLOCK MOVMASK 00 000 79/04/19 00.30
MOVMASK SPACE 4,20
*** MOVMASK - SETS UP MASK FOR -MOVBITS- ROUTINE
*
* DO *NOT* CHANGE *A5*
*
*
MOVMASK EQ * ENTRY/EXIT
SX4 6D BITS/CHARACTER
SX3 B2 STARTING CHARACTER POS (0-9)
IX5 X3*X4 NUMBER OF BITS TO SHIFT TO TOP
SB6 X5 (B6) = BITS TO SHIFT TO TOP
SB7 -B6
SB7 B7+60D (B7) = SIZE OF MASK
MX0 60 USE THE WHOLE WORD
ZR B7,MOVMASK -- IF FULL MASK, EXIT
MX0 59
LX0 59
AX0 B6 DROP OFF UNNECESSARY BITS
MX7 1 RESET MISSING BIT
LX7 B7 POSITION
BX0 X0+X7 SET MISSING BIT
EQ MOVMASK -- EXIT
MBSETUP SPACE 4,20
*** MBSETUP - SETS UP INPUT AND OUTPUT POINTERS
*
* DO *NOT* CHANGE *A5*
*
* *X1* = TO/FROM WORD ADDRESS
* *X2* = TO/FROM CHAR POINTER
*
*
MBSETUP EQ * ENTRY/EXIT
SB1 X1 COPY TO *B1* REGISTER
SB2 X2+1 CHANGE (0 TO N-1) TO (1 TO N)
SB3 10D CHARACTERS PER WORD
MBLOOP SB2 B2-B3 SUBTRACT 10 CHARACTERS
ZR B2,MBOUTL IF ON WORD BOUNDARY, OUTLOOP
NG B2,MBOUTL IF LESS THAN LIMIT
SB1 B1+1
EQ MBLOOP -- RELOOP
MBOUTL SB7 1
SB2 B2+B3 MAKE A POSITIVE NUMBER AGAIN
SB2 B2-B7 CALCULATE STARTING CHAR IN WORD
EQ MBSETUP -- RETURN
* /--- BLOCK COLOR 00 000 79/04/23 09.17
TITLE -COLOR- COMMAND EXECUTION
*
* -COLOR- COMMAND EXECUTION
*
* RETRIEVE COMMAND WORD
*
ENTRY COLORXX
COLORXX BSS 0
SX6 -1 PRESTORE ZRETURN WITH OK
SA6 TRETURN
SA5 A5
NGETVAR RETURN WITH VALUE IN X1
SB1 X1 0 = DEFINE, 1 = DISPLAY
JP B1+*+1
+ EQ CDEFINE
+ EQ CDISP
CDEFINE BSS 0
*
* -COLOR DEFINE-
*
* DEFINE A NEW COLOR GIVEN 3 COLOR INTENSITIES.
* INTENSITIES MUST BE IN THE RANGE 0..1 INCLUSIVE.
* IF AN OUT-OF-RANGE VALUE IS FOUND, SET *ZRETURN*
* TO 0 AND LEAVE.
*
AX5 XCMNDL SHIFT EXTRA STORAGE ADDRESS
MX0 -11D FORM ADDRESS MASK
BX1 -X0*X5 GET EXTRA STORAGE ADDRESS
SA1 X1+B5 READ GETVAR CODES
BX5 X1 MOVE TO X5 FOR FGETVAR
FGETVAR READ RED VALUE INTO X1
BX6 X1
LX5 XCODEL MOVE TO NEXT GETVAR CODE
SA6 REDVAL STORE FOR LATER
FGETVAR READ GREEN VALUE INTO X1
BX6 X1
LX5 XCODEL MOVE TO LAST GETVAR CODE
SA6 GRNVAL STORE FOR LATER
FGETVAR X1 = BLUE VALUE
SA3 REDVAL X3 = RED VALUE
SA4 GRNVAL X4 = GREEN VALUE
SA2 KONEP0 X2 = 1.0 FOR RANGE CHECK
FX5 X2-X1 CHECK BLUE .GT. 1.0
* /--- BLOCK COLOR 00 000 83/03/11 11.01
FX6 X2-X3 CHECK RED .GT. 1.0
FX7 X2-X4 CHECK GREEN .GT. 1.0
BX5 X5+X1 ADD BLUE + RANGED BLUE
BX6 X6+X3 ADD RED + RANGED RED
BX7 X7+X4 ADD GREEN + RANGED GREEN
BX5 X5+X6 ADD BLUE + RED
BX5 X5+X7 ADD BLUE, RED + GREEN
NG X5,BADCOLR --- ONE OF THE TAGS WAS OOR
SA2 K255 X2 - 255.0
FX1 X1*X2 SCALE BLUE TO 0..255
FX3 X3*X2 SCALE RED
FX4 X4*X2 SCALE GREEN
UX1 X1,B1 FIX BLUE
UX3 X3,B2 FIX RED
UX4 X4,B3 FIX GREEN
LX6 X1,B1 INTEGERIZE BLUE IN X6
LX3 X3,B2 INTEGERIZE RED
LX4 X4,B3 INTEGERIZE GREEN
LX3 16D MOVE RED TO POSITION
LX4 8D MOVE GREEN TO POSITION
BX6 X6+X3 ADD RED+BLUE
BX6 X6+X4 ADD RED, BLUE + GREEN
SA5 A5 RESTORE COMMAND WORD
LX5 XCODEL MOVE PUTVAR CODE TO POSITION
NPUTVAR STORE RESULTING RGB
EQ PROCESS --- FINISH COMMAND
BADCOLR SX6 0 0 = BAD COLOR INTENSITY
SA6 TRETURN SET *ZRETURN*
EQ PROCESS --- EXIT COMMAND
*
* EXECUTION FOR -COLOR DISPLAY-
* IF A NUMBER IS SPECIFIED THAT IS .GT. 24 BITS,
* SET *ZRETURN* TO 1 AND LEAVE.
*
CDISP BSS 0
*
* FIRST CHECK TO MAKE SURE 12 MOUT CODES WILL
* FIT IN THE MOUT BUFFER.
*
SA1 MOUTLOC
SX6 X1-MOUTLTH-12D CHECK FOR OVERFLOW
PL X6,RETRNZ --- BACK UP AND END TIMESLICE
SX7 -1 SET BOTH COLORS TO OMITTED
SA7 BGNDVAL
SA7 FGNDVAL
LX5 2*XCODEL MOVE GETVAR CODE TO LOW ORDER
MX0 -XCODEL
BX1 -X0*X5 X1 = FOREGROUND GETVAR CODE
LX5 11D MOVE EXTRA STORAGE ADDRESS
MX2 -11D
BX7 -X2*X5 X7 = EXTRA STORAGE ADDRESS
SA2 X7+B5 X2 = EXTRA STORAGE WORD
LX2 XCODEL MOVE GETVAR CODE TO LOW ORDER
SA7 GRNVAL SAVE EXTRA STORAGE ADDRESS
BX2 -X0*X2 X2 = BACKGROUND GETVAR CODE
MX0 1
LX0 XCODEL X0 = OMITTED FLAG
BX3 X0-X1 X3 = 0 IF FOREGROUND OMITTED
BX6 X0-X2 X6 = 0 IF BACKGROUND OMITTED
LX5 XCODEL+XCMNDL MOVE FOREGROUND GETVAR CODE
SA6 REDVAL SAVE BACKGROUND CODE FOR LATER
ZR X3,BGNDTAG --- FOREGROUND OMITTED
NGETVAR
MX0 -24
* /--- BLOCK COLOR 00 000 79/04/23 14.18
BX0 X0*X1 TEST FOR 24-BIT OVERFLOW
NZ X0,BADTAG --- VALUE .GT. 24 BITS
BX6 X1 SAVE FOREGROUND VALUE
SA6 FGNDVAL
BGNDTAG BSS 0
SA1 REDVAL X1 = BACKGROUND FLAG
ZR X1,COLROUT BACKGROUND OMITTED; SEND OUTPUT
SA1 GRNVAL X1 = EXTRA STORAGE ADDRESS
SA1 X1+B5 X1 = BACKGROUND GETVAR CODE
BX5 X1 MOVE GETVAR CODE TO X5
NGETVAR X1 = BACKGROUND COLOR VALUE
MX0 -24
BX0 X0*X1 TEST FOR 24-BIT OVERFLOW
NZ X0,BADTAG --- VALUE .GT. 24 BITS
BX6 X1 SAVE FOR OUTPUT CHECKS
SA6 BGNDVAL
COLROUT BSS 0
SA1 FGNDVAL X1 = FOREGROUND VALUE
NG X1,BGNDOUT --- FOREGROUND OMITTED
SA2 XCOLORS GET EXECUTOR COLOR SETTINGS
MX0 -24 SET MASK TO CLEAR OLD COLOR
BX6 X0*X2 CLEAR FOREGND COLOR
BX6 X6+X1 SET NEW COLOR
SA6 A2 RESTORE EXECUTOR COLORS
OUTCODE RBGCODE 12/0,24/COLOR,24/RBGCODE
BGNDOUT BSS 0
SA1 BGNDVAL X1 = BACKGROUND VALUE
NG X1,PROCO --- BACKGROUND OMITTED
SA2 XCOLORS GET EXECUTOR COLOR SETTINGS
MX0 -24 SET MASK TO CLEAR OLD COLOR
LX0 24 POSITION FOR BGND COLOR
BX6 X0*X2 CLEAR COLOR
BX0 X1 MAKE A COPY OF THE COLOR
LX0 24 POSITION TO BACKGND COLOR
BX6 X6+X0 SET NEW COLOR
SA6 A2 RESTORE EXECUTOR COLORS
MX0 1
LX0 25D X0 = BACKGROUND FLAG
BX1 X1+X0 ADD FLAG TO COLOR
OUTCODE RBGCODE 12/0,24/COLOR,24/RBGCODE
EQ PROCO --- COMMAND DONE
BADTAG SX6 1 1 = BAD COLOR VALUE
SA6 TRETURN SET *ZRETURN*
EQ PROCESS --- COMMAND DONE
K255 DATA 255.0
KONEP0 DATA 1.0
REDVAL BSS 1
GRNVAL BSS 1
BGNDVAL BSS 1
FGNDVAL BSS 1
* /--- BLOCK FONT 00 000 79/07/30 22.46
TITLE -FONT- COMMAND EXECUTION
*
* RETRIEVE COMMAND WORD
*
ENTRY FONTX
FONTX BSS 0
NGETVAR GET FONT SLOT NUMBER
SX6 X1 SET FONT TYPE
SA6 FONTTYP
SA5 A5 RESTORE COMMAND WORD
LX5 XCODEL SHIFT TO NEXT ARG
NGETVAR GET FONT SIZE
NG X1,FONTNOR IF NEGATIVE, USE NORMAL SIZE
ZR X1,FONTNOR IF ZERO, USE NORMAL SIZE
SX0 X1-77B-1 MAX FONT SIZE
PL X0,FONTNOR IF GREATER THAN LIMIT, DEFAULT
SX6 X1 SET FONT SIZE
EQ FCONT2
FONTNOR SX6 0 DEFAULT FONT SIZE
FCONT2 SA6 FONTSIZ
SA5 A5 RESTORE COMMAND WORD
AX5 XCMNDL SHIFT EXTRA STORAGE ADDRESS
MX0 -11D FORM ADDRESS MASK
BX1 -X0*X5 GET EXTRA STORAGE ADDRESS
SA1 X1+B5 READ GETVAR CODES
BX5 X1
NGETVAR GET FONT SLOT NUMBER
SX6 X1 SET FONT MODE
SA6 FONTMOD
SA5 A5 RESTORE COMMAND WORD
SA1 FONTTYP GET FONT TYPE
BX7 X1 FONT
LX7 12 POSITION
CALL CLIENT,5000B,X1 FONT TYPE CODE
SA1 FONTSIZ GET FONT SIZE
BX0 X1 FONT/0/0
LX0 6 POSITION
BX7 X7+X0 FONT/SIZE/0
MX6 1 SET/CLEAR NON-DEFAULT FONT BIT
LX6 21 POSITION TO CORRECT BIT LOCAL
ZR X1,SENDSIZ IF DEFAULT, CLEAR NON-DEFAULT
BX7 X7+X6 SET NON-DEFAULT BIT
SENDSIZ CALL CLIENT,5100B,X1 FONT SIZE CODE
SA1 FONTMOD GET FONT MODE
BX7 X7+X1 FONT/SIZE/MODE
CALL CLIENT,5200B,X1 FONT MODE CODE
MX0 18 SET MASK TO CLEAR FONT INFO
LX0 FNTINFO MOVE MASK START TO FONT INFO
SA1 CWSINFO GET TERMINAL WORD
BX1 -X0*X1 MASK OUT OLD FONT INFO
LX7 41 POSITION FONT INFO
BX7 X1+X7 ADD FONT INFO
SA7 A1 SAVE NEW FONT INFO
EQ PROCESS
*
FONTTYP BSS 1 TYPE OF FONT
FONTSIZ BSS 1 SIZE OF FONT
FONTMOD BSS 1 MODE OF FONT
*
* /--- BLOCK END 00 000 79/02/12 17.08
END