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