Retro1.org codex

EXEC2 
* /---   FILE TYPE = E
* /---   BLOCK      EXEC2      00 000   74/10/08  23.11 
          IDENT  EXEC2
          TITLE  TUTOR EXECUTION-INTERPRETER
* 
*         GET COMMON SYMBOL TABLE 
* 
          CST 
* 
* 
* /---   BLOCK      ENTRY/EXT  00 000   78/12/18  21.20 
          TITLE  ENTRY/EXTERNAL 
* 
* 
          EXT    ECSPRTY     ECS PARITY ERROR RECOVERY
          EXT    BOUNDS,WORDS,PROCESS,PROCO,PROC,RCTOXY,GETN
          EXT    PROCESX
          EXT    VARCNT,GETCODX,ILOC
          EXT    VARADD,EXECSAV 
          EXT    GET2,CUNIT 
          EXT    XSLICE 
          EXT    FSTOTOA     FOR *OTOA * COMMAND (TUTSUB) 
          EXT    TFIN 
          EXT    WINDOW 
          EXT    CLRFIO      CLEAR FILE ACTIVITY MARKER 
          EXT    ERROROF
          EXT    ERXMXL 
          EXT    ERXSTU 
          EXT    ERXFVAL
          EXT    ERXVAL 
          EXT    ERXHSEG
          EXT    TOOMUCH
          EXT    ERXOUTP
          EXT    ERXSTOL
          EXT    ERXBADL
          EXT    DEVSYS 
* 
* 
          ENTRY  DRAWX,RDRAWX,GDRAWX
          ENTRY  BLOCKX 
          ENTRY  CODOUTX
          ENTRY  TABX 
          ENTRY  COPYX,JKEYX,DATEX,CLOCKX 
          ENTRY  PLAYX,MIKEX
          ENTRY  ENABLEX,DISABLX
          ENTRY  DELAYX,AFONTX
          ENTRY  CHECKX,NAMEX,GROUPX,DAYX,ZEROX,ZEROXX
          ENTRY  EDITX
          ENTRY  BUMPX,CODEX
          ENTRY  SYSLESX
          ENTRY  RETRNX,ZFILLX,CPULIMX
          ENTRY  RETRN
* /---   BLOCK      DRAW       00 000   80/05/17  17.25 
          TITLE  -DRAW- COMMAND 
* 
* 
*         EXECUTION ROUTINE FOR -DRAW- COMMAND
* 
* 
 DRAWX    SA1    MOUTLOC     SEE IF MOUT BUFFER TOO FULL
          SX1    X1-MOUTLTH+133   TEMP FIX BY KELSO/S 
*                                 5/17/80 
          NG     X1,DRAWX2   IF ROOM
          SA5    A5+1        BACK UP COMMAND POINTER
          EQ     XSLICE      END THIS TIME SLICE
* 
 DRAWX2   SA1    TBWNDOW       WINDOWING IS SLOW AND
          NZ     X1,DRAWINDO   CANT USE THIS ROUTINE. 
          BX6    X5          ALL PACKED UP FLAG=BIT 58
          LX6    1
          NG     X6,SFDRAW   IF CONSTANT, NON WINDOWED DRAW 
          AX6    1+60-XCODEL GET NO. OF VARS TO DECODE
          SX6    X6+1        ADD 1 TO INCLUDE COUNT ITSELF
          RJ     GETCODX     GETVAR CODES IN VARBUF 
          SA2    VARCNT 
          SX7    X2-1 
          SA7    A2          CORRECT VARCNT 
* 
*  MOUT HEADER SHOULD ALWAYS BE CORRECT, IN CASE THERE
*  IS AN EXEC ERROR IN EVALUATING A TAG, AND THE EXEC 
*  ERROR ROUTINE DOESN'7T ZERO THE MOUT COUNT.
* 
          SA1    MOUTLOC
          SX7    10000B+SKPCODE   LENGTH + HEADER CODE
+         PL     X5,*+1      IF NOT CONTINUED 
          SX7    10000B+CDWCODE   CONTINUED DRAW HEADER 
+         SA7    MOUT+X1     OUTPUT HEADER
          SX6    A7 
          SA6    ILOC        ILOC -> HEADER FOR UPDATING
          SX6    X1+1        INCREMENT MOUT POINTER 
          SA6    A1 
          SX6    0           1ST ARGUMENT 
          SA6    ERXARGN     SET EXECERR ARGUMENT NUMBER
          SX1    VARBUF+1    FIRST VARIABLE ADDRESS 
* 
* GET NEXT GETVAR CODE  ---  X1-> THE GETVAR CODE 
* 
 DRAWX5   SA2    ERXARGN     INC EXECERR ARG NUMBER 
          SX6    X2+1 
          SA6    A2 
          SA2    X1          X2 = THIS GETVAR CODE
          SX6    X1+1        -> NEXT GETVAR CODE
          SA6    VARADD 
          MX6    2           MASK AND SKIP FLAG 
          BX5    -X6*X2      GETVAR CODE IN TOP OF X5 
          BX2    X6*X2       TYPE OF CODE BITS IN X2
          LX2    2
          SB2    X2          00=COARSE, 01=FINE,
          JP     *+1+B2      10=PACKED FINE, 11=SKIP
+         EQ     CGDRAW      COARSE GRID VERTEX 
+         EQ     FGDRAW      FINE GRID VERTEX 
+         MX0    XCODEL      PACKED FINE GRID 
          BX6    X0*X5       ONLY WANT X/Y
+         LX6    18+2        POSITION SKIP AND PACKED FINE
          EQ     DRAWX6 
* 
* COARSE GRID VERTEX ---
 CGDRAW   NGETVAR            ROW-COLUMN ARGUMENT IN X1
          CALL   RCTOXY 
          MX0    -9 
          BX6    -X0*X6 
          LX6    9
          BX7    -X0*X7 
          BX6    X6+X7
          EQ     DRAWX6 
* /---   BLOCK      DRAW       00 000   78/05/17  20.53 
* 
* FINE GRID VERTEX ---
 FGDRAW   NGETVAR            GET X VALUE
          BX6    X1 
          SA6    ILOC+1      SAVE X VALUE 
          SA1    VARCNT      DECREMENT VARIABLE COUNT 
          SX6    X1-1 
          SA6    A1 
          SA1    VARADD      X1 = CURRENT *VARBUF* ADDRESS
          SA2    X1          X2 = -GETVAR- CODE FOR Y-COORD 
          SX6    X1+1        X6 -> NEXT -GETVAR- CODE 
          SA6    A1 
          BX5    X2 
          NGETVAR            GET Y VALUE
          MX0    -9 
          BX7    -X0*X1 
          SA1    ILOC+1      RETREIVE X VALUE 
          BX6    -X0*X1 
          LX6    9
          BX6    X6+X7       PUT X AND Y TOGETHER 
*         EQ     DRAWX6 
* 
*  X6= X/Y COORD, OR SKIP INDICATOR 
 DRAWX6   SA1    MOUTLOC     CURRENT OUTPUT POINTER 
          SA6    MOUT+X1     STORE X/Y
          SX7    X1+1        UPDATE MOUTLOC POINTER 
          SA7    A1 
          SA1    ILOC        X1 -> MOUT HEADER
          SA1    X1          X1 = MOUT HEADER 
          SX7    10001B      ADD TO BOTH COUNTS 
          LX7    12 
          IX7    X1+X7
          SA7    A1 
          SA1    VARCNT      UPDATE COUNT OF VARIABLES LEFT 
          SX7    X1-1 
          ZR     X7,DRAWX9   IF ALL DONE
          SA7    A1 
          SA1    VARADD      X1->NEXT GETVAR CODE 
          EQ     DRAWX5      AND GET NEXT GETVAR CODE 
* 
*  DONE WITH DRAW, X6=LAST X/Y POINT (MAY NOT BE SKIP)
* 
 DRAWX9   MX0    -9          UPDATE NX/NY 
          BX7    -X0*X6 
          LX6    -9 
          BX6    -X0*X6 
          SA6    NX 
          SA7    NY 
          EQ     PROCESX
* 
************************************************************
* /---   BLOCK      SFDRAW     00 000   75/10/17  23.15 
          EJECT 
* 
* * *     SUPER FAST DRAW --- JUST OUTPUT AND SET NX,NY 
*         PRE EXECUTION FOR DRAW GUARANTEES NO MOUT OVERFLOW
* 
* OUTPUT MOUT HEADER AND COUNT OF CODES --- 
* 
 SFDRAW   BX1    X5 
          LX1    XCODEL 
          SX1    X1          X1 = COUNT 
          SX0    SFDCODE     HEADER CODE
          LX1    24 
          BX0    X0+X1       COMBINE COUNT WITH HEADER CODE 
          LX1    -24         SHIFT BACK TO POSITION 
          SA4    MOUTLOC     X4 = POINTER INTO MOUT BUFFER
          SX2    X4+1        ADVANCE MOUT POINTER 
          BX6    X5 
          LX6    2*XCODEL    FIRST TAG IN LOW 20 BITS 
*         CONTINUED DRAW FLAG=TOP BIT IN MIDDLE 20
          SX1    X1+2-1      PRETEND 3 POINTS IN FIRST WORD 
          LX5    -XCMNDL
          MX7    2*XCODEL+XCMNDL
          BX5    -X7*X5      X5 = EXTRA STORAGE POINTER 
* 
* WORDS FOLLOWING HEADER CONTAIN PACKED UP DRAW POINTS
* 
 SFDRAW1  SA6    MOUT+X2     OUTPUT NEXT SET OF WORDS 
          SX2    X2+1        AND ADVANCE MOUT POINTER 
          SX1    X1-3 
          NG     X1,SFDRAW2 
          SA3    B5+X5       NEXT EXTRA STORAGE WORD
          BX6    X3 
          SX5    X5+1 
          EQ     SFDRAW1
* 
 SFDRAW2  BX7    X2          UPDATE MOUT POINTER
          SA7    A4 
          IX2    X2-X4       COMBINE COUNT OF WORDS 
          LX2    12 
          BX7    X0+X2       WITH MOUT HEADER 
          SA7    MOUT+X4     AND STORE OUTPUT HEADER
          SB1    X1+3        FIND WHERE IN WORD LAST TAG IS 
          JP     *+1+B1 
+         LX6    -XCODEL     WAS IN TOP, NOW IN MIDDLE
+         LX6    -XCODEL     WAS IN MIDDLE, 
+         MX0    -9          NOW IN BOTTOM
          BX7    -X0*X6      NEW NY 
          LX6    -9 
          BX6    -X0*X6      NEW NX 
          SA7    NY 
          SA6    NX 
          EQ     PROCESS
* /---   BLOCK      WINDBUF    00 000   86/12/08  08.36 
          TITLE  WINDBUF - OUTPUT WINDOWED LINES
* 
*  WINDBUF --- OUTPUT A WHOLE BUFFER OF WINDOWED LINES
* 
* ON ENTRY--- 
*   TOP BIT OF X5 SET IF CONTINUED DRAW 
*   X1 -> FIRST WORD OF BUFFER TO OUTPUT
*   X2 = NUMBER OF WORDS IN BUFFER
*   END POINTS OF LINES ARE IN PAIRS OF WORDS  (X,Y)
*   -SKIP- IS INDICATED BY TOP TWO BITS 1, REST 0 
* ON EXIT --- 
*   LINES ARE PLACED IN THE MOUT BUFFER, MOUTLOC UPDATED
*   NX, NY UPDATED TO END OF DRAWN LINES
* 
*         CALLED FROM LINCHR AND DRAWS
* 
          ENTRY  WINDBUF
* 
 WINDBUF  EQ     *
          ZR     X2,WINDBUF 
          NG     X2,WINDBUF 
          BX6    X1          SAVE -> BUFFER 
          BX7    X2          SAVE COUNT OF ENTRIES
          SA6    WINDA
          SA7    WINDB
          NG     X5,FIGF1    IF -AT- NOT NEEDED 
* 
 FIGF0    SA1    WINDA
          SX7    X1+2        INCREMENT POINTER
          SA7    A1 
          SA1    X1 
          BX6    X1 
          SA6    NX          SET BEGINNING X
          SA2    A1+1 
          BX6    X2 
          SA6    NY          SET BEGINNING Y
          MX7    -9 
          BX1    -X7*X1      MASK TO 9BITS
          BX2    -X7*X2 
          MX4    2           CHECK FOR REDUNDANT -SKIP- 
          BX4    X1-X4
          ZR     X4,FIGF1.1  IF -SKIP-
          LX1    9
          BX1    X1+X2       PACK UP X AND Y
          OUTCODE WFCODE     OUTPUT FINE WHERE
          SA2    WINDB
          SX7    X2-2 
          SA7    A2 
          ZR     X7,WINDBUF 
* 
* /---   BLOCK      WINDBUF    00 000   86/12/08  08.38 
 FIGF1    SA1    WINDA       GET POINTER
          SX7    X1+2        INCREMENT POINTER
          SA7    A1 
          SA3    X1          GET NEXT VALUE 
          MX4    2           CHECK FOR -SKIP- OPTION
          BX4    X3-X4
          NZ     X4,FIGF1S
 FIGF1.1  BSS    0
          SA2    WINDB
          SX7    X2-2        GOING TO SKIP
          SA7    A2 
          NZ     X7,FIGF0 
          EXECERR 115        CANNOT END WITH -SKIP- ('/'/)
* 
 FIGF1S   SA4    A3+1 
          SA1    TBWNDOW     GET WINDOWING FLAG 
          BX0    X1          X0 = WINDOW INFO 
          SA1    NX          BEGINNING X
          SA2    NY          BEGINNING Y
          BX6    X3 
          SA6    A1          UPDATE X 
          BX6    X4 
          SA6    A2          UPDATE Y 
          RJ     WINDOW 
          NZ     X0,FIGF3    JUMP IF WINDOWED LINE DRAWN
* 
          LX3    9
          BX1    X3+X4       PACK UP X AND Y
          OUTCODE LFCODE      OUTPUT FINE LINE
 FIGF3    SA2    WINDB       GET COUNT
          SX7    X2-2 
          SA7    A2          DECREMENT COUNT
          NZ     X7,FIGF1    LOOP 
          EQ     WINDBUF
* 
 WINDA    BSS    1
 WINDB    BSS    1
* 
* /---   BLOCK      SINCOS     00 000   75/11/21  18.58 
          TITLE  SINCOS 
* 
*         FIND SIN AND COS OF AN ANGLE
* 
*         ON ENTRY -- 
*            X6 = ANGLE (IN RADIANS)
* 
*         ON EXIT --
*           X6 = SINE OF ANGLE
*           X7 = COSINE OF ANGLE
* 
*         CALLED FROM LINWRT AND DRAWS
* 
          ENTRY  SINCOS 
 
 SINCOS   EQ     *
          SA6    SINCOSA     SAVE ANGLE 
          BX1    X6          TSIN EXPECTS ARG IN X1 
          CALL   TSINX
          BX7    X1          SINE COMPUTED
          SA1    SINCOSA     RESTORE ANGLE
          SA7    A1          SAVE SINE
          CALL   TCOSX
          BX7    X1          X7 = COSINE
          SA1    SINCOSA
          BX6    X1          X6 = SINE
          EQ     SINCOS 
* 
 SINCOSA  BSS    1           TEMPORARY WORD 
* 
* /---   BLOCK      RDRAW      00 000   85/01/31  13.30 
          TITLE  -RDRAW- / -GDRAW- COMMANDS 
* 
* * *     -RDRAW- COMMAND 
* 
 RDRAWX   MX6    -1          FLAG -RDRAW- 
          EQ     DRAWIN1
* 
* * *     -GDRAW- COMMAND 
* 
 GDRAWX   SX6    1           FLAG -GDRAW- 
 DRAWIN1  SA1    MOUTLOC     SEE IF MOUT BUFFER TOO FULL
          SX1    X1-MOUTLTH+70   63 ARGS MAX
          NG     X1,DRAWIN2  IF ROOM
          SA5    A5+1        BACK UP COMMAND POINTER
          EQ     XSLICE      END THIS TIME SLICE
* 
* * *     WINDOWED DRAW CANT USE THE FAST DRAW ROUTINE
* 
 DRAWINDO SX6    0           FLAG -DRAW-
 DRAWIN2  SA6    OVARG1      (ALREADY CHECKED FOR MOUT ROOM)
          EXEC   DRAWS,NDRAWOV
* 
* /---   BLOCK      BLOCK      00 000   78/07/05  01.16 
          TITLE  BLOCK
*         -BLOCK-  (CODE=102) 
* 
*         TRANSFER BLOCK OF VARIABLES 
*         TRYING TO TRANSFER MORE THAN
*         TEMPLTH VARIABLES CAUSES AN 
*         EXECUTION ERROR.
*            GETS LENGTH FIRST TO AVOID PHONY ARRAY 
*         BOUNDS ERRORS WHEN LENGTH IS 0. 
* 
* 
 BLOCKX   AX5    XCMNDL 
          MX0    -XSPTRL
          BX5    -X0*X5 
          SA1    B5+X5       GET XTRA WORD
          BX5    X1 
          NGETVAR 
          ZR     X1,PROCESS  --- DONE IF LENGTH = 0 
          SB1    X1          LENGTH 
          SB2    B1-TEMPLTH-1 
          PL     B2,BERXBIG  WILL IT FIT
          SA5    A5 
          BX6    X1 
          SA6    ILOC        SAVE LENGTH
          NGETVAR 
          SX6    A1 
          SA6    ILOC+1      SAVE FROM ADDRESS
          SA5    A5 
          LX5    XCODEL 
          NGETVAR 
          SX2    A1          (X2) = TO ADDRESS
          SA1    ILOC        (X1) = LENGTH
          SA0    X2 
          RJ     BOUNDS      CHECK LEGALITY OF TO ADDRESSES 
          SA3    ILOC+1      (X3) = FROM ADDRESS
          SA0    X3 
          RJ     BOUNDS      CHECK LEGALITY OF ADDRESSES
          SA4    ATEMPEC     ADDRESS OF ECS TEMPORARY BUFFER
          BX0    X4 
          SB1    X1          LENGTH (A0=FROM ADDRESS) 
          WE     B1 
          RJ     ECSPRTY
          SA0    X2          TO CENTRAL ADDRESS 
          RE     B1 
          RJ     ECSPRTY
          EQ     PROCESS     --- DONE 
* 
 BERXBIG  SX2    TEMPLTH
          EXECERR 116 
* /---   BLOCK      ZERO       00 000   78/12/21  18.27 
* 
          TITLE  ZERO, ADD1, SUB1 
*         -ZERO-
* 
*         ZERO SPECIFIED VARIABLE 
* 
 ZEROX    MX6    0
          NPUTVAR            STORE A ZERO IN SPECIFIED VAR
          EQ     PROC 
* 
* 
*         -ZERO- COMMAND
*         USES ZEROED ECS BUFFER TO CLEAR A BLOCK 
* 
 ZEROXX   NGETVAR 
          SX6    A1          SAVE STARTING ADDRESS
          SA6    EXECSAV
          SA5    A5 
          LX5    XCODEL      POSITION NEXT -GETVAR- CODE
          NGETVAR 
          ZR     X1,PROC     --- EXIT IF LENGTH=0 
          SA2    EXECSAV
          SA0    X2          ADDRESS OF FIRST VAR TO ZERO 
          RJ     BOUNDS 
          SB3    X1          LENGTH MUST BE CONST OR *B* REG
          SX1    A0          MOVE TO *X1* BECAUSE OF -ZERO- 
          ZERO   X1,B3       CLEAR OUT VARIABLES
          EQ     PROC 
* /---   BLOCK      CODEOUT    00 000   76/08/02  23.06 
          TITLE  CODEOUT, WINDOW
*         -CODEOUT-  (CODE=112) 
* 
*            THE TAG SPECIFIES THE 6 BIT CODE TO BE OUTPUT
*         AFTER AN UNCOVER CODE.
* 
 CODOUTX  NGETVAR            ROUNDS TO INTEGER IN X1
          OUTPUT CODCODE
          EQ     PROC 
* 
* /---   BLOCK      RETURN     00 000   80/02/15  22.12 
          TITLE  -BREAK-
* 
*         -BREAK-    (CODE=268) 
* 
          ENTRY  RETRNZ 
 RETRNZ   SA5    A5+1        BACK-UP COMMAND POINTER
* 
 RETRNX   BSS    0           ENTRY POINT FOR -BREAK-
 RETRN    SA1    SCOMFLG
          PL     X1,RTX2     JUMP IF NO STATISTICS
          CALL   POSTCMS     TAKE COMMAND STATISTICS
* 
 RTX2     CALL   TFIN        END THIS TIME SLICE
          CALL   USV         UPDATE SCREEN VARIABLES
          EQ     PROCESS
          TITLE  -TABSET- COMMAND 
* 
* 
*         -TABSET-    (CODE=269)
* 
 TABX     NGETVAR            GET THE TABSETS
          BX6    X1 
          SA6    TBTAB       STORE
          EQ     PROC 
* /---   BLOCK      COPY       00 000   77/10/20  20.23 
          TITLE  -COPY- 
*         -COPY-  (CODE=130)
* 
*         ENABLE COPY KEY.
*         COPY UP TO COUNT SET BY SECOND ARGUMENT 
*         OR UNTIL A ZERO IS FOUND. 
* 
 COPYX    NGETVAR            GET THE COPY STRING ADDRESS
          SX6    A1 
          SX7    STUDVAR+VARLIM 
          IX7    X6-X7
          PL     X7,ERXSTU   ERROR IF NOT IN STUDENT VARS 
          SA6    ILOC        SAVE ADDRESS 
          SA5    A5          RESTORE
          LX5    XCODEL 
          NGETVAR            GET NUMBER OF CHARS
          ZR     X1,PROC
          SA3    ILOC        RETRIEVE ADDRESS 
          SA0    X3          SET UP FOR -WORDS- 
          CALL   WORDS       DO BOUNDS CHECK
          LX3    18          SHIFT ADDRESS
          BX6    X1+X3
          LX6    18 
          SA6    TBCOPY      THEN STORE AWAY IN TBCOPY
          EQ     PROC 
          TITLE  -JKEY- COMMAND 
* 
* 
*         -JKEY-  (CODE=131)
* 
*     SET BITS TO SPECIFY WHICH KEYS MAY INITIATE JUDGING 
* 
 JKEYX    MX7    60-XCMNDL   DISCARD COMMAND BITS 
          BX7    X7*X5
          SA1    TJKEYS      PICK UP PRESENT SETTING
          ZR     X7,JKEYX1   CLEAR IF BLANK COMMAND 
          BX7    X1+X7
 JKEYX1   SA7    TJKEYS      SET TERMINAL BANK WORD 
          EQ     PROC 
* /---   BLOCK      BUMP       00 000   75/10/01  17.29 
          TITLE  BUMP 
*         -BUMP-  (CODE=133)
* 
*         THE LOGIC OF THIS COMMAND IS--
*         X5 HOLDS CHARS OF TAG L-JUS, ZEROS RIGHT. 
*         COMMAND SEARCHES FOR MATCHES OF TAG CHARS 
*         THROUGH JUDGE BUFFER.  TAG CHARS ARE SHIFTED
*         CIRCULARLY, AND NEVER REQUIRE A MEMORY FETCH. 
* 
 BUMPX    MX7    48 
          BX5    X5*X7       8 CHARS MAX, 0 FOR END TEST
          SB1    1           UNIVERSAL INCREMENT CONSTANT 
          SB2    B0          INDEX FOR LOADING
          SB3    B0          INDEX FOR STORING
          MX0    -6          MASK FOR CHAR
          BX4    X5          X4 = TAG CHARS FOR TESTING 
* 
 BMP1     SA1    JUDGE+B2    NEXT CHAR FROM ANSWER
          ZR     X1,BMP5     IF END OF ANSWER 
* 
 BMP2     LX4    6           GET NEXT TAG CHAR
          BX6    -X0*X4 
          ZR     X6,BMP3     IF END OF TAG CHARS
          BX6    X6-X1       CHECK CHAR 
          NZ     X6,BMP2     IF NO MATCH, TRY NEXT CHAR 
          SB2    B2+B1       INCREMENT LOAD INDEX 
          BX4    X5          RESTORE ORIGINAL TAG 
          EQ     BMP1 
* 
 BMP3     EQ     B2,B3,BMP4  IF NOTHING FOUND YET 
          SA2    JJCHAR+B2
          BX6    X1 
          BX7    X2 
          SA6    JUDGE+B3 
          SA7    JJCHAR+B3
 BMP4     SB2    B2+B1       INCREMENT LOAD INDEX 
          SB3    B3+B1       INCREMENT STORE INDEX
          BX4    X5          RESTORE ORIGINAL TAG 
          EQ     BMP1        GET NEXT CHAR OF ANSWER
* 
*         END OF ANSWER 
* 
 BMP5     EQ     B2,B3,PROCESS  --- RETURN IF NO CHANGE 
          MX6    -1 
          MX7    0
          SA6    JJSTORE     TO TELL -STORE- COMMAND TO RECOMPILE ANSWER
          SA7    JJFBUF      MARK ANSWER MODIFIED 
          MX6    0
          SX7    B3 
          SA6    JUDGE+B3    SET 0 FOR END TEST 
          SA7    TJCOUNT     RESET ANSWER LENGTH
          EQ     PROCESS     --- RETURN 
* /---   BLOCK      EDIT       00 000   77/07/20  17.05 
          TITLE  -EDIT- 
*         EDIT COMMAND
*            THE AUTHOR ASSIGNS A BUFFER TO BE USED BY
*         STUDENT UPON PUSHING THE EDIT KEY.
*         NO ARG OPTION CLEARS THE FLAG TO NO ACTION. 
*         ARG OPTION SETS ACTIVE AND POINTS TO BUFFER 
*         IN TUTOR VARIABLES. 
* 
 EDITX    PL     X5,EDITX1   SEPARATE CASES 
          MX6    0
          SA6    TBEDIT      CLEAR TO INACTIVE
          EQ     PROC 
 EDITX1   NGETVAR            GET THE EDIT BUFFER ADDRESS
          SX6    A1 
          SX7    STUDVAR+VARLIM  LAST LEGAL ADDRESS + 1 
          IX7    X6-X7
          PL     X7,ERXSTU  JUMP IF OUT OF STUDENT BANK 
          LX6    36          SHIFT UP 
          SA6    TBEDIT      AND STORE FOR USE DURING EDIT OPTION 
          EQ     PROC 
* /---   BLOCK      DATE       00 000   80/06/10  14.16 
          TITLE  -DATE- 
*         -DATE-  (CODE=136)
* 
*            STORES THE CURRENT DATE (AS READ FROM NOS
*           LOWCORE ) IN THE SPECIFIED VARIABLE.
* 
 DATEX    NGETVAR            A1 = VARIABLE STORAGE ADDRESS
          SX6    A1 
          SA6    ILOC 
          CALL   S=TDATE,ITEMP     READ TIME/DATE 
          SA1    ITEMP+1
          SA2    ILOC 
          BX6    X1 
          SA6    X2          STORE DATE 
          EQ     PROCESS     --- RETURN 
          TITLE  -CLOCK- COMMAND
* 
* 
* 
*         -CLOCK-  (CODE=137) 
* 
 CLOCKX   NGETVAR            A1 = VARIABLE STORAGE ADDRESS
          SX6    A1 
          SA6    ILOC 
          CALL   S=TDATE,ITEMP     READ TIME/DATE 
          SA1    ITEMP
          SA2    ILOC 
          BX6    X1 
          SA6    X2          STORE TIME 
          EQ     PROCESS     --- RETURN 
          TITLE  -DAY- COMMAND
* 
* 
*                -DAY-
* 
* 
*         DAY   RETURNS THE NUMBER OF ELAPSED DAYS
*         FROM JAN. 1, 1973';  2400 HOURS DEC 31,1972 
*         MARKS THE BEGINNING OF DAY 0. 
* 
*         THE NUMBER OF ELAPSED DAYS + FRACTIONAL DAYS
*         IS STORED IN THE ADDRESS PROVIDED BY THE CALL.
* 
* 
* 
 DAYX     CALL   JULIAN      GET JULIAN DATE TO X6
          FPUTVAR            STORE WHERE NEEDED, IN REQUIRED TYPE (I/F) 
          EQ     PROCESS
* 
* 
* 
*         -JULIAN-
*         RETURNS JULIAN DATE IN X6 (FLOATING)
* 
*         USES   A - 2, 3, 4. 
*                X - 2, 3, 4, 6.
* 
* 
          ENTRY  JULIAN 
 JULIAN   EQ     *
          SA2    MSCLCK0     *SYSCLOCK* VALUE AT LOAD TIME
          SA4    SYSCLOK     GET MS CLOCK 
          MX3    24D
          BX4    -X3*X4      MASK CLOCK TO 36 BIT INTEGER 
          IX4    X4-X2
          PX4    X4          FLOAT
          NX4    X4          AND NORMALIZE
          SA2    MSPDAY 
          SA3    DAY0        *DAY* AS CALCULATED AT LOADTIME
          FX4    X4/X2       MS TO DAYS 
          FX6    X4+X3       UPDATE (DAY) 
          EQ     JULIAN 
* 
* 
 MSPDAY   DATA   86400000.   MILLISECONDS PER DAY 
* /---   BLOCK      PLAY       00 000   84/01/09  16.55 
          TITLE  -PLAY-   -RECORD-
*         -PLAY-  (CODE=140)
* 
*         PLAYS AUDIO MESSAGE STARTING AT TRACK/SECTOR
*         GIVEN BY 3D TAG FIELD 
* 
 PLAYX    SX6     3           DECODE 3 TAGFIELDS
          RJ      GETN        GET VALUES IN VARBUF(N-1) 
          SX3     40000B      PLAYBACK CODE 
 PLAYX2   SA1     VARBUF      GET STARTING TRACK AND
          SA2     VARBUF+1    SECTOR NUMBER INTO X1,X2
          MX0     55
          BX2     -X0*X2      MAKESURE ONLY 5BIT SECTOR 
          MX0     53
          BX1     -X0*X1      AND 7BIT TRACK FIELD
          LX1     5           SHIFT TRACK PAST SECTOR 
          BX1     X1+X2       COMBINE TRACK,SECTOR, AND 
          BX1     X1+X3       CODE INTO X1
          OUTCODE AUDCODE     SEND OUT AUDIO START WORD 
          SA1     VARBUF+2    GET LENGTH TAG
          MX0    46           ALLOW BOTTOM 14 BITS IN SECOND WORD 
          BX1     -X0*X1
          SX0    1           AND KILL BIT 8 FOR SOME NEW AUDIOS 
          LX0    7
          BX1    -X0*X1 
          OUTCODE AUDCODE     SEND OUT AUDIO LENGTH WORD
          EQ      PROCESS 
* 
* 
* 
*         -RECORD-  (CODE=141)
* 
*         RECORDS AUDIO MESSAGE AT STARTING TRACK/SECTOR
* 
 MIKEX    SX6    3           DECODE 3 TAGFIELDS 
          RJ     GETN        GET VALUES IN VARBUF(N-1)
          SX3    60000B      RECORD CODE
          EQ     PLAYX2      SEND AUDIO START+LENGTH WORD 
* /---   BLOCK      ENABLE     00 000   77/11/11  00.16 
          TITLE  -ENABLE-   -DISABLE- 
* 
* 
* 
*         -ENABLE- AND -DISABLE- COMMANDS 
* 
 ENABLEX  MX6    3           CHOOSE ENABLE FUNCTION BITS
          BX1    X5*X6
          ZR     X1,ENA100   JUMP IF NEITHER TOUCH/EXT
          PL     X1,ENA050   -- IF NOT -ORIENTAL- 
          SA2    STFLAGS
          LX2    60-ORIBIT   MOVE ORIENTAL MODULE TO SIGN 
          PL     X2,PROC     -- IGNORE IF SHOULDN'7T ENABLE 
 ENA050   LX1    ENABLO-24   POSITION BITS IN *ENABLBS* 
          OUTCODE SETCODE 
* 
 ENA100   SA5    A5 
          LX5    3           MOVE *EXTMAP* BIT TO SIGN
          PL     X5,PROC     EXIT IF  *EXTMAP* NOT SELECTED 
          MX6    1
          LX6    EXTMBIT     POSITION *EXTMAP* BIT
          SA1    STFLAG1
          BX6    X1+X6       SET BIT IN /STATION/ WORD
          SA6    A1 
          EQ     PROC 
* 
* 
 DISABLX  MX6    3           CHOOSE DISABLE FUNCTION BITS 
          BX1    X5*X6
          ZR     X1,DISA100  JUMP IF NEITHER TOUCH/EXT
          LX1    ENABLO-24   POSITION BITS IN *ENABLBS* 
          OUTCODE CLRCODE 
* 
 DISA100  SA5    A5 
          LX5    3           MOVE *EXTMAP* BIT TO SIGN
          PL     X5,PROC     EXIT IF  *EXTMAP* NOT SELECTED 
          MX6    1
          LX6    EXTMBIT     POSITION *EXTMAP* BIT
          SA1    STFLAG1
          BX6    -X6*X1      CLEAR BIT IN /STATION/ WORD
          SA6    A1 
          EQ     PROC 
* 
* /---   BLOCK      DELAY      00 000   78/04/25  20.18 
          TITLE  DELAY
*         -DELAY-  (CODE=181) 
* 
*         SENDS NUMBER OF NO-OP CODES REQUIRED TO MAKE UP 
*         SPECIFIED DELAY TIME
* 
* 
 DELAYX   FGETVAR            DELAY IN SECONDS 
          BX6    X1          SAVE THE ARG FOR EXECERR 
          SA6    DLYSAVE
          SA2    =57.1429    TERMINAL WORDS / SECOND
          FX1    X1*X2       COMPUTE NUMBER NO-OPS REQUIRED 
          SA2    =.5
          FX1    X1+X2       ROUND
          NX1    X1 
          UX1    X1,B1
          LX1    X1,B1
          NG     X1,DERXVAL  --- ERROR EXIT IF COUNT IS NEGATIVE
*** NOTE';  IF YOU CHANGE THE TIME LIMIT, YOU MUST CHANGE 
*** THE EXECUTION ERROR MESSAGE 
          SX2    64          SLIGHTLY OVER 1 SECOND 
          IX2    X1-X2
          PL     X2,DLERXLNG ---   LONG DELAYS ARE ILLEGAL
          SA2    DELAYED
          IX6    X1+X2       ACCUMULATE DELAY 
          SA6    A2 
          OUTCODE NOPCODE 
          SA1    DELAYED
          SX2    X1-228      SEE IF FOUR SECONDS OR MORE
          NG     X2,PROCO 
          EQ     RETRNX      WAIT FOR OUTPUT TO FINISH
* 
* 
          ENTRY  DELAYED
 DELAYED  BSS    1           TOTAL DELAY THIS TIME-SLICE
* 
 DLYSAVE  BSS    1           FOR EXECUTION ERRORS 
* 
 DLERXLNG SA1    DLYSAVE
          EXECERR 94         DELAY TOO LONG 
* 
 DERXVAL  SA1    DLYSAVE
          EQ     ERXFVAL     DELAY TOO SHORT
* /---   BLOCK      ALTFONT    00 000   84/01/09  16.57 
          TITLE  -ALTFONT-
* 
* 
* 
*         -ALTFONT-  (CODE=201) 
* 
*            SETS *CSET* SO ALL FOLLOWING WRITING OCCURS
*         FROM ALTERNATE FONT (1) OR NORMAL FONT (0). 
* 
* 
          ENTRY  AFONTX 
* 
 AFONTX   NGETVAR 
          SX0    1
          LX0    3+7+18      FORM ALTFONT BIT FOR SIZE WRITE
          SA2    TBWRITE
          NZ     X1,AF100    JUMP IF -ALTFONT ON- 
          BX6    -X0*X2      CLEAR ALTFONT BIT
          EQ     AF200
* 
 AF100    BX6    X0+X2       SET ALTFONT BIT
 AF200    SA6    A2 
          OUTCODE AMSCODE     0=NORMAL, 1=ALTERNATE 
          EQ     PROC 
* 
* 
* /---   BLOCK      CODE       00 000   85/01/31  13.30 
          TITLE  -CODE- AND -CHECK- 
* 
*         -CODE- COMMAND
* 
 CODEX    NGETVAR 
          BX6    X1 
          SA6    TAUCODE     SAVE FOR REST OF SESSION 
          EQ     PROC 
* 
* /---   BLOCK      CHECK      00 000   81/06/15  23.03 
* 
*         CHECK COMMAND 
* 
*         CHECK (BLANK) RETURNS A VALUE OF -1 TO X
*         IN *ERROR* DEPENDING ON THE GROUP OF THE USER.
*         *ZRETURN* IS SET THE SAME AS *ERROR*. 
* 
*         CHECK (ARG) RETURNS -1 IN *ERROR* IF THE USERS
*         CODEWORD, GROUP, OR ACCOUNT AGREES WITH THE 
*         ARGUMENT; *ZRETURN* IS SET TO -1 ALSO.
*         IF THERE IS NO AGREEMENT, A LIST OF SPECIAL 
*         STATIONS IS SEARCHED.  IF THIS STATION IS FOUND 
*         IN THE LIST, *ZRETURN* IS SET TO 0 AND *ERROR*
*         IS SET AS IN THE NO ARGUMENT CASE.  IF THE STATION
*         IS NOT FOUND, *ZRETURN* IS 0 AND *ERROR* IS 100.
* 
* 
 CHECKX   NG     X5,CKNOARG  BRANCH IF NO ARGUMENT
          NGETVAR 
* 
          RJ     CHECODE     CODE IS IN X1
          ZR     X6,CHECK3   IF NO MATCH
* 
          SX6    -1 
          SA6    TERROR 
          SA6    TRETURN
          EQ     PROC 
* 
* 
* IF NO MATCH, SEE IF AT A SPECIAL STATION. 
* ZSSLST IS START OF SPECIAL STATIONS BIT TABLE IN ECS
* ONE SITE PER WORD, MSB = STATION ZERO.
* 
 CHECK3   MX6    0
          SA6    TRETURN     SET ZRETURN 0
* 
          SA1    STATION
          SX2    X1-LSTUD 
          ZR     X2,CKSCHK   CONSOLE IS ALWAYS SPECIAL
          MX2    -5 
          BX2    -X2*X1      GET STATION IN X2
          AX1    5           AND SITE IN X1 
          SA3    AZSSLST     START OF BIT TABLE IN ECS
          IX0    X3+X1
          RX3    X0          (-RXX- 1 WD READ, MAY CHG *A3*)
          SX6    100         ASSUME NOT SPECIAL 
          SB2    X2          STATION NUMBER 
          LX3    X3,B2
          PL     X3,CKSCHK2  NOPE, RETURN *ERROR* = 100 
 CKSCHK   CALL   SYSCOR      ELSE CHECK FOR SYSTEM GROUP
 CKSCHK2  SA6    TERROR      ZRETURN ALREADY SET TO 0 
          EQ     PROC 
* 
*         BLANK-TAG -CHECK- 
*         -- LOOK FOR SYSTEM GROUP
* 
 CKNOARG  CALL   SYSCOR      CHECK FOR SPECIAL GROUP
          SA6    TERROR 
          SA6    TRETURN
          EQ     PROC 
* 
* /---   BLOCK      CHECODE    00 000   79/04/07  00.40 
          TITLE  CHECK EDITING CODE 
* 
**        ROUTINE CHECODE 
* 
*         CHECKS CODE IN X1 AGAINST AUTHORS EDITING CODE, 
*         HIS GROUP, AND ACCOUNT. 
* 
*         ON EXIT --
*            X6 = -1 IF MATCH 
*                  0 IF NO MATCH
* 
*         'USES X0,X1,X2,X3,X6;A0,A2,A3 
* 
          ENTRY  CHECODE
* 
 CHECODE  EQ     *
          ZR     X1,CKX1     BRANCH IF BLANK CODE 
          SA2    TAUCODE     PICK UP AUTHORS EDITING CODE 
          MX6    6
          BX6    X6*X2
          ZR     X6,CKX2     DON'7T ALLOW LEADING ZERO CODES
          BX3    X1-X2
          NZ     X3,CKX2
          NG     X3,CKX2     CATCH COMPLEMENT CASE
* 
 CKX1     SX6    -1          MATCH
          EQ     CHECODE
* 
 CKX2     RJ     CHEKGRP     CHECK FOR GROUP CODEWORD 
          EQ     CHECODE
* 
* 
* 
*         CHEKGRP 
* 
*            'THIS ROUTINE CHECKS THE CODEWORD SPECIFIED
*         TO SEE IF IT IS AN ACCEPTABLE GROUP CODEWORD--
*         GROUP OR ACCOUNT OF USER (THE ACCOUNT NAME IS 
*         RIGHT SHIFTED 18 BITS, THE GROUP NAME 12 BITS). 
* 
*         'ON ENTRY --
*            X1 = CODEWORD
* 
*         'ON EXIT -- 
*            X6 = -1 IF MATCH 
*                  0 IF NO MATCH
* 
*         'USES X0,X1,X2,X3,X6;A0,A2,A3 (X4 ASSUMED NOT USED) 
* 
* 
          ENTRY  CHEKGRP
* 
 CHEKGRP  EQ     *
          SX6    0           PRESET TO NO MATCH 
          MX0    6
          BX2    X0*X1       CHECK TOP CHAR OF CODE 
          NZ     X2,CHEKGRP  --- MUST BE 0 IF GROUP CODEWORD
          LX1    12          SEE IF GROUP 
          BX2    X0*X1       MASK TOP CHAR
          ZR     X2,CHKACC   IF ZERO, MAYBE ACCOUNT NAME
          SA3    STATION     GET GROUP OF USER
          SA2    AGROUP 
          IX0    X3+X2
          RX3    X0          (-RXX- 1 WD READ, MAY CHG *A3*)
          MX0    -12
          BX2    X0*X3       MASK TO GET JUST GROUP NAME
          BX2    X2-X1       COMPARE WITH (SHIFTED) CODEWORD
          NZ     X2,CHEKGRP  --- EXIT IF NO MATCH 
 CHKOK    SX6    -1          MARK OK
          EQ     CHEKGRP     --- EXIT 
* 
 CHKACC   SA3    TACCNAM     PICK UP ACCOUNT NAME OF USER 
          LX1    6           TOTAL SHIFT NOW = 18 
          BX2    X3-X1
          ZR     X2,CHKOK 
          EQ     CHEKGRP     --- EXIT IF NO MATCH 
* /---   BLOCK      SYSCOR     00 000   78/11/14  08.10 
          TITLE  -SYSCOR-    CHECK FOR SPECIAL GROUP
* 
* 
* 
          ENTRY  SYSCOR 
 SYSCOR   EQ     *
          SA1    STATION
          SA2    AGROUP 
          IX0    X1+X2
          RX1    X0          (-RXX- 1 WD READ, MAY CHG *A1*)
          SB1    1
          MX2    -12
          BX6    X1*X2
          ZR     X6,CKCON    IF NO GROUP, CHECK FOR CONSOLE 
          SA6    CHKFIND     PLANT USER GROUP AS LAST ENTRY 
          SA2    CKTYPE-1 
 CKLL     SA2    A2+B1
          BX3    X6-X2
          NZ     X3,CKLL
          SB1    A2 
          SB2    CKTYPE+1 
          SX6    B1-B2
          EQ     SYSCOR 
* 
 CKCON    SA1    STATION     CHECK FOR CONSOLE
          SX2    X1-LSTUD 
          NZ     X2,CKNOTC   NOT THE CONSOLE
 
* 
* * *     SET CONSOLE PRIVILEDGES 
          SX6    -1          GROUP S FOR DEVELOPMENT SYSTEMS
          SA2    DEVSYS      GET *DEVSYS* 
          NZ     X2,SYSCOR   IF DEV SYSTEM, RETURN
          SX6    1           GROUP O FOR NON-DEV SYSTEMS
          EQ     SYSCOR      RETURN 
 
* 
 CKNOTC   SX6    CKLAST-CKTYPE-1  HIGHER THAN ANY SYS GROUP 
          EQ     SYSCOR 
* 
* 
 CKTYPE   DATA   1LS
          DATA   1LP
          DATA   1LO
          DATA   1LM
          DATA   6LCOSERV 
          DATA   1RX         $$ WAS ETSC
          DATA   3LPSO       PRODUCT SERVICE ORGANIZATION 
 CHKFIND  CON    0           REQUIRED TO END SEARCH LOOP
* 
 CKLAST   EQU    CKTYPE+7    (CKTYPE + NUMBER ENTRIES)
* 
* /---   BLOCK      NAME AND C 00 000   79/10/04  03.52 
          TITLE  -NAME- AND -GROUP- COMMANDS
*         THE NAME IS 18 CHARS + 12 BITS OF DISK BLOCK
 NAMEX    NGETVAR            A1=STARTING STORAGE ADDRESS
          SA2    TNAME
          BX6    X2 
          SA6    A1 
          SA3    TNAME1 
          MX7    48 
          BX7    X7*X3       MASK TO 8 CHARACTERS 
          SA0    A1 
          SX1    2
          RJ     BOUNDS      SEE THE 2ND WORD IN BOUNDS 
          SA7    A1+1 
          EQ     PROC 
* 
*         THE GROUP IS 8 CHARS NAME PLUS 12 BITS OF FLAGS 
* 
 GROUPX   NGETVAR 
          SA2    AGROUP      ECS ADDRESS OF GROUP BUFFER
          SA3    STATION     ADD BIAS OF THIS STATION 
          IX0    X2+X3
          SA0    A1 
+         RE     1           READ GROUP ENTRY INTO USERS WORD 
          RJ     ECSPRTY
          SA1    A1 
          MX7    48 
          BX7    X7*X1       MASK TO 8 CHARACTERS 
          SA7    A1 
          EQ     PROC 
* /---   BLOCK      MODESET    00 000   78/10/27  09.31 
          TITLE  MODESET AND BITSOUT
*         -MODESET-  (CODE=241) 
* 
*            OUTPUTS SPECIFIED MODE (0-7).  INTENDED TO 
*         PERMIT INVESTIGATION OF NEW MODES VIA PDP-11
*         SIMULATED TERMINAL. 
* 
* 
          ENTRY  MODESEX
* 
 MODESEX  NGETVAR 
          OUTCODE MODCODE 
          CALL   ASMBIT      SET ASSEMBLY PROGRAM BIT 
          EQ     PROC 
* 
* 
* 
*         -BITSOUT-  (CODE=249) 
* 
*            OUTPUTS AN 18 BIT DATA WORD.  USEFUL ONLY
*         IN TESTING NEW MODES (4-7), DATA IS NOT SENT
*         IF IN A STANDARD MODE (0-3).
* 
* 
          ENTRY  BITSOUX
* 
 BITSOUX  NGETVAR 
          OUTCODE BITCODE 
          EQ     PROC 
* 
***** 
* 
          TITLE  ASCII
* 
*         -ASCII- 
* 
*         OUTPUTS AN ASCII CHARACTER.  USEFUL ONLY
*         ON ASCII TERMINALS. 
* 
          ENTRY  ASCIIX 
 
 ASCIIX   BSS    0
          SA1    STFLAG1     GET TERM TYPE WORD 
          MX0    -TTBTN      SET MASK FOR TERM TYPE FIELD 
          LX1    TTBTN-TTBTS  POSITION TERM TYPE FIELD
          BX0    -X0*X1      GET TERM TYPE
          SX0    X0-ASCTYPE  SEE IF ASCII TERM (ZTTTYPE=12) 
          NZ     X0,PROC    NOT ASCII TERM, DO NOT EXECUTE
* 
 ASEND    BSS    0
          NGETVAR            GET BYTE TO BE SENT
          OUTCODE ASCCODE 
          EQ     PROC 
* 
* /---   BLOCK      -SYSLESS   00 000   80/07/02  10.13 
          TITLE  SYSLESS
* 
*         -SYSLESS-  (CODE=288) 
*         ONE ARGUMENT = LESSON TO BE CHECKED 
* 
*         RETURNS ERROR = -1 IF A SYSTEM LESSON 
*                          0 IF NOT 
* 
 SYSLESX  SX6    2
          CALL   GETCODX     UNPACK GETVAR CODES TO VARBUF
          CALL   ACCFILE,VARBUF,VARBUF,0
          CALL   PROSRCH,VARBUF 
          LX2    ZSLDSHF     GET SYSTEM LESSON BIT
          MX6    0
          PL     X2,SYSLEXT   0 = NON-SYSTEM LESSON 
          SX6    -1          -1 = SYSTEM LESSON 
 SYSLEXT  SA6    TERROR 
          SA6    TRETURN
          EQ     PROC 
* 
* 
* /---   BLOCK      SYSTEST    00 000   85/01/31  13.30 
          TITLE  SYSTEM LESSON LIST SEARCHES
* 
*         SYSTEST 
* 
*         RETURNS X6 = -1 FOR SYSTEM LESSON 
*                       0 FOR NON-SYSTEM
*         ALSO RETURNS X2 = LESSON DESCRIPTOR BITS
* 
* 
          ENTRY  SYSTEST
* 
 SYSTEST  EQ     *
          CALL   PROSRCH,TBLESAC
          LX2    ZSLDSHF     GET SYSTEM LESSON BIT
          NG     X2,SYST1    IF YES 
          LX2    -ZSLDSHF    RESTORE BITS 
          MX6    0
          EQ     SYSTEST
* 
 SYST1    SX6    -1          -1 = SYSTEM LESSON 
          LX2    -ZSLDSHF    RESTORE BITS 
          EQ     SYSTEST
* 
* 
* /---   BLOCK      AIDSLES    00 000   81/01/23  13.51 
* 
*         CHECK TO SEE IF CURRENT LESSON IS AN AIDS LESSON. 
* 
*         THE FILE NAME OF ALL AIDS LESSONS BEGINS WITH 
*         THE LETTER -A- FOLLOWED BY A DIGIT (0-9). 
* 
*         EXIT   (X1) NEGATIVE IF AIDS LESSON 
*                     POSITIVE IF NOT 
* 
*         USES   A - 1
*                X - 1, 2 
 
          ENTRY  AIDSLES
 
 AIDSLES  EQ     *
          SA1    TBLESAC     (X1) = ACCOUNT OF CURRENT LESSON 
          LX1    42          SHIFT TO OLD-STYLE FLAG
          PL     X1,AIDSLES  IF NOT OLD-STYLE 
          SA1    TBLESSN     (X1) = CURRENT LESSON NAME 
          SX2    7777B
          LX1    12          POSITION 1ST 2 CHARS AT BOTTOM 
          BX2    X2*X1       (X2) = FIRST 2 CHARACTERS
          SX1    X2-2RA+     SEE IF GREATER THAN -A9- 
          PL     X1,AIDSLES  IF SO, NOT AN AIDS LESSON
          SX1    X2-2RA0     SEE IF -A0- OR GREATER 
          BX1    -X1
          EQ     AIDSLES
* 
* 
* /---   BLOCK      STOPCHK    00 000   81/12/05  05.02 
          EJECT 
**        STOPCHK - CHECK FOR SPECIAL STOP1 PROCESSING
* 
*         THIS ROUTINE CHECKS TO SEE IF THE LESSON
*         SPECIFIED BY *TBLESSN* IS ONE OF THE SPECIAL
*         SYSTEM LESSONS THAT DOES ITS OWN STOP1 KEY
*         PROCESSING. 
* 
*         IF PST1BIT IN STFLAG1 IS SET INDICATING A PRIORITY
*         STOP1, THEN STOP1 PROTECTION FOR THE LESSON IS
*         OVERRIDDEN (EXCEPT FOR LESSON SYSLIB).
* 
*         THE ST1BIT IN STFLAGS IS CLEARED IF THIS LESSON 
*         IS A SPECIAL STOP1 LESSON.
* 
*         EXIT   (X2) = 0 IF SPECIAL, NON-ZERO OTHERWISE. 
* 
*         USES   A - 2. 
*                B - NONE.
*                X - 2. 
* 
*         OTHER REGISTERS ARE USED BUT RESTORED.
* 
*         CALLS  PROSRCH, SAVE0167, REST0167. 
* 
*         MACROS NONE.
 
 
          ENTRY  STOPCHK
 
 STOPCHK  EQ     *
 
          RJ     SAVE0167    SAVE REGISTERS 
          SA0    B1          SAVE ORIGINAL (B1) 
          SB1    TBLESAC
          RJ     PROSRCH
          SB1    A0          RESTORE (B1) 
          ZR     X2,NOSTOP   IF LESSON NOT FOUND
          LX2    ZPLDSHF
          PL     X2,NOSTOP
 
          SA2    STFLAG1
          LX2    60-PST1BIT  CHECK FOR PRIORITY STOP1 
          PL     X2,STOPC2   JUMP IF NO SPECIAL PRIORITY
          CALL   LIBTEST,TBLESAC
          PL     X6,NOSTOP   -- IF NOT IN SYSLIB LESSON 
 
 STOPC2   SA1    STFLAGS     CLEAR ST1BIT SINCE THIS IS A 
          MX6    1             STOP1 INHIBITED LESSON 
          LX6    ST1BIT 
          BX6    -X6*X1 
          SA6    A1 
 
          RJ     REST0167    RESTORE REGISTERS
          MX2    0           STOP1 OK 
          EQ     STOPCHK
 
 NOSTOP   RJ     REST0167    RESTORE REGISTERS
          MX2    59 
          EQ     STOPCHK
* /---   BLOCK      SYSLES     00 000   81/12/05  05.03 
          EJECT 
**        SYSLES - CHECK FOR NON-DELETABLE SYSTEM LESSONS 
* 
*         THIS ROUTINE SEARCHES THE PROTECTED LESSON TABLE
*         FOR A LESSON AND CHECKS TO SEE IF IT IS A SYSTEM
*         LESSON WITH DELETION PROTECTION.
* 
*         ENTRY  (B1) = ADDR OF 2-WORD LESSON NAME TO CHECK.
* 
*         EXIT   (X3) = 0  IF LESSON IS NOT A SYSTEM LESSON,
*                          OR IS A SYSTEM LESSON WITH NO
*                          DELETION PROTECTION. 
*                     = 1  IF LESSON IS NEVER TO BE DELETED 
*                          (HAS *D1* ATTRIBUTE).
*                     = 2  IF LESSON CANNOT BE DELETED WHILE
*                          IN USE (HAS *D2* ATTRIBUTE). 
*                     = 3  IF LESSON HAS *D3* ATTRIBUTE, AND
*                          *SYSDL* = *ON*.
* 
*         USES   A - 2, 3.
*                B - NONE.
*                X - 2, 3.
* 
*         OTHER REGISTERS ARE USED BUT RESTORED.
* 
*         CALLS  PROSRCH, REST0167, SAVE0167. 
* 
*         MACROS NONE.
 
 
          ENTRY  SYSLES 
 
 SYSLES   EQ     *
 
          RJ     SAVE0167    SAVE REGISTERS 
          RJ     PROSRCH     SEARCH SYSTEM LESSON LIST
          ZR     X2,NOSYSL   IF LESSON NOT FOUND
          SX3    X2          (X3) = TYPE CODE 
          SX7    SYSDL       (X7) = 0 IF OFF
          ZR     X7,SYS20    IF *SYSDL* = *OFF* 
          LX2    ZD3SHF      (X2) = 1/*D3* BIT, 59/OTHER
          PL     X2,SYS20    IF NO *D3* ATTRIBUTE 
          SX3    3           INDICATE *D3* ACTIVE 
* 
 SYS20    RJ     REST0167    RESTORE REGISTERS
          EQ     SYSLES      RETURN 
* 
 NOSYSL   RJ     REST0167 
          SX3    0           (X3) = 0 = DELETABLE 
          EQ     SYSLES 
* /---   BLOCK      SYSLES1    00 000   78/11/12  21.30 
          EJECT 
**        SYSLES1 - CHECK DELETION PROTECTION AND ECS CHARGE
* 
*         THIS ROUTINES SEARCHES THE SYSTEM LESSON LIST AND 
*         RETURNS INFO ABOUT THE ECS CHARGE FOR A SYSTEM
*         LESSON AND WHETHER OR NOT IT CAN BE DELETED.
* 
*         ENTRY  (B1) = ADDRESS OF 2-WORD LESSON NAME.
* 
*         EXIT   (X2) = 0  IF LESSON IS NOT A SYSTEM LESSON,
*                          OR IS A SYSTEM LESSON WITH NO
*                          DELETION PROTECTION. 
*                     = 1  IF LESSON IS NEVER TO BE DELETED 
*                          (HAS *D1* ATTRIBUTE).
*                     = 2  IF LESSON CANNOT BE DELETED WHILE
*                          IN USE (HAS *D2* ATTRIBUTE). 
*                     = 3  IF LESSON HAS *D3* ATTRIBUTE, AND
*                          *SYSDL* = *ON*.
*                (X3) = ECS CHARGE. 
* 
*         USES   A - 2, 3.
*                B - NONE.
*                X - 2, 3.
* 
*         OTHER REGISTERS ARE USED BUT RESTORED.
* 
*         CALLS  PROSRCH, REST0167, SAVE0167. 
* 
*         MACROS NONE.
 
 
          ENTRY  SYSLES1
 
 SYSLES1  EQ     *
 
          RJ     SAVE0167    SAVE REGISTERS 
          RJ     PROSRCH     SEARCH SYSTEM LESSON LIST
          ZR     X2,NOSYSL1  IF LESSON NOT FOUND
          BX3    X2          SAVE OVER CALL TO *REST0167* 
          SX7    SYSDL       (X7) = 0 IF OFF
          ZR     X7,SYSL20   IF *SYSDL* = *OFF* 
          LX2    ZD3SHF      (X2) = 1/*D3* BIT, 59/OTHER
          PL     X2,SYSL20   IF NO *D3* ATTRIBUTE 
          MX0    -18         CLEAR DELETE PROTECT FIELD 
          BX7    X0*X3       (X7) = 42/FLAGS, ETC., 18/0
          SX3    3
          BX3    X3+X7       (X3) = 42/FLAGS, ETC., 18/3
* 
 SYSL20   RJ     REST0167    RESTORE REGISTERS
          SX2    X3          (X2) = PROTECTION TYPE 
          AX3    18 
          SX3    X3          (X3) = ECS CHARGE
          EQ     SYSLES1
 
 NOSYSL1  RJ     REST0167    RESTORE REGISTERS
          MX2    0           (X0) = NO PROTECTION 
          MX3    -1          (X3) = NORMAL ECS CHARGE 
          EQ     SYSLES1
 
* /---   BLOCK      /SAVEREG/  00 000   81/12/05  05.04 
          EJECT 
          QUAL   SAVEREG
* 
**        SAVE0167 - SAVE A0, A1, A6, A7, X0, X1, X6, X7
* 
*         THIS ROUTINE SAVES SEVERAL REGISTERS THAT WERE
*         FORMERLY UNUSED IN ROUTINES WHICH DID A SEQUENTIAL
*         SEARCH OF THE PROTECTED LESSON TABLE WHEN IT WAS
*         CM-RESIDENT.
* 
*         ENTRY  NONE.
* 
*         EXIT   A0, A1, A6, A7, X0, X1, X6, X7 ARE SAVED.
* 
*         USES   A - 2, 6, 7. 
*                B - NONE.
*                X - 2, 6, 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
 
 
 SAVE0167 EQ     *+400000B
 
          SA2    A6          PRESERVE (A6) AND ((A6)) 
          SA6    SAVE.X6     SAVE (X6)
          SX6    A2 
          SA6    SAVE.A6     SAVE (A6)
          BX6    X2 
          SA6    SAVE.A6X    SAVE ((A6))
          SA2    A7          PRESERVE (A7) AND ((A7)) 
          SA7    SAVE.X7     SAVE (X7)
          SX7    A2 
          SA7    SAVE.A7     SAVE (A7)
          BX7    X2 
          SA7    SAVE.A7X    SAVE ((A7))
          SX6    A0 
          BX7    X0 
          SA6    SAVE.A0     SAVE (A0)
          SA7    SAVE.X0     SAVE (X0)
          SX6    A1 
          BX7    X1 
          SA6    SAVE.A1     SAVE (A1)
          SA7    SAVE.X1     SAVE (X1)
 
          EQ     SAVE0167 
* /---   BLOCK      /SAVEREG/  00 000   81/12/05  05.04 
 REST0167 SPACE  5,20 
**        REST0167 - RESTORE A0, A1, A6, A7, X0, X1, X6, X7 
* 
*         THIS ROUTINE RESTORES SEVERAL REGISTERS THAT WERE 
*         FORMERLY UNUSED IN ROUTINES WHICH DID A SEQUENTIAL
*         SEARCH OF THE PROTECTED LESSON TABLE WHEN IT WAS
*         CM-RESIDENT.
* 
*         ENTRY  NONE.
* 
*         EXIT   A0, A1, A6, A7, X0, X1, X6, X7 RESTORED. 
* 
*         USES   A - 0, 1, 2, 6, 7. 
*                B - NONE.
*                X - 0, 1, 2, 6, 7. 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
 
 
 REST0167 EQ     *+400000B
 
          SA2    SAVE.X0
          BX0    X2          RESTORE (X0) 
          SA2    SAVE.A0
          SA0    X2+         RESTORE (A0) 
          SA2    SAVE.A1
          SA1    X2          RESTORE (A1) 
          SA2    SAVE.X1
          BX1    X2          RESTORE (X1) 
          SA2    SAVE.A6X 
          BX6    X2 
          SA2    SAVE.A6
          SA6    X2          RESTORE (A6) AND ((A6))
          SA2    SAVE.X6
          BX6    X2          RESTORE (X6) 
          SA2    SAVE.A7X 
          BX7    X2 
          SA2    SAVE.A7
          SA7    X2          RESTORE (A7) AND ((A7))
          SA2    SAVE.X7
          BX7    X2          RESTORE (X7) 
 
          EQ     REST0167 
* /---   BLOCK      /SAVEREG/  00 000   81/12/05  04.20 
 
*         DEFINE CELLS USED BY *SAVE067* AND *REST067*
 
 SAVE.A0  BSS    1           FOR SAVING (A0)
 SAVE.A1  BSS    1           FOR SAVING (A1)
 SAVE.A6  BSS    1           FOR SAVING (A6)
 SAVE.A7  BSS    1           FOR SAVING (A7)
 SAVE.X0  BSS    1           FOR SAVING (X0)
 SAVE.X1  BSS    1           FOR SAVING (X1)
 SAVE.X6  BSS    1           FOR SAVING (X6)
 SAVE.X7  BSS    1           FOR SAVING (X7)
 SAVE.A6X BSS    1           FOR SAVING ((A6))
 SAVE.A7X BSS    1           FOR SAVING ((A7))
 
          QUAL   *
 
 SAVE0167 EQU    /SAVEREG/SAVE0167
 REST0167 EQU    /SAVEREG/REST0167
* /---   BLOCK      PROSRCH    00 000   79/01/16  14.05 
          EJECT 
**        PROSRCH - SPECIAL SEARCH LESSON DESCRIPTOR TABLE
* 
*         THIS ROUTINE PERFORMS A BINARY CHOP SEARCH
*         OF THE SPECIAL LESSON DESCRIPTOR TABLE. 
* 
*         ENTRY  (B1) = ADDR OF 2-WORD LESSON NAME TO CHECK.
* 
*         EXIT   (X1) = NAME OF LESSON. 
*                (X2) = DESCRIPTOR WORD (0 IF NOT FOUND). 
* 
*         USES   A - 1, 2, 3. 
*                B - NONE.
*                X - 0, 1, 2, 3, 4, 6, 7. 
* 
*         OTHER REGISTERS ARE USED BUT RESTORED.
*         (X0, A1/X1, A2/X2, X7 ARE NOT RESTORED) 
* 
*         CALLS  NONE.
* 
*         MACROS NONE.
 
 
          ENTRY  PROSRCH
 
 PROSRCH  EQ     *+400000B
 
          QUAL   PROSRCH
 
          SA1    A6          PRESERVE (A6) AND (CM VALUE) 
          SX6    A1 
          SA6    PROS.A6     SAVE (A6)
          BX6    X1 
          SA6    PROS.X6X    SAVE VALUE AT ADDR *A6*
          BX6    X3 
          SA6    PROS.X3     SAVE (X3)
          BX6    X4 
          SA6    PROS.X4     SAVE (X4)
          SX6    A0 
          SA6    PROS.A0     SAVE (A0)
          SX6    A3 
          SA6    PROS.A3     SAVE (A3)
 
          SA1    B1+1        (X1) = LESSON NAME 
          BX6    X1          COPY TO *X6* 
          SA6    ORIGLSN     SAVE ORIGINAL LESSON NAME
 
          SA2    B1          (X2) = ACCOUNT NAME
          LX2    42          SHIFT TO OLD-STYLE FLAG
          PL     X2,PROSZ    IF NOT OLD-STYLE 
 
          SX6    1           LOOP COUNTER 
          SA6    SRCHCNT     SAVE IT
 
          MX4    60          CHECK ENTIRE WORD FOR LSN NAME 
 
 PROS0    SA2    SYSLST 
          BX6    X2          (X6) = EM ADDR OF TOP OF TABLE 
          SA2    SYLEND 
          BX7    X2          (X7) = EM ADDR OF END OF TABLE 
 
 PROS1    IX3    X7-X6       GET DIFFERENCE 
          AX3    2           TO DROP ONES BIT - 2 WORD CHOP 
          LX3    1
          IX0    X6+X3       ADDRESS OF NEXT WORD 
          RX2    X0          (X2) = NEXT LESSON NAME
          BX2    X4*X2       MASK OFF ANY UNNECESSARY CHARS 
          IX2    X2-X1       SEE IF THE SAME
          NZ     X2,PROS2    NO MATCH 
          SX2    1
          IX0    X0+X2       (X0) = ADDR OF DESCRIPTOR WORD 
          RX2    X0          (X2) = DESCRIPTOR WORD 
          EQ     PROS5       MATCH FOUND
 
 PROS2    ZR     X3,PROS4    RUN OUT OF WORDS 
          NG     X2,PROS3    IF IN TOP HALF 
          BX7    X0          RESET BOTTOM 
          EQ     PROS1
 
* /---   BLOCK      PROSRCH    00 000   79/01/04  14.32 
 PROS3    BX6    X0          RESET TOP
          EQ     PROS1
 
 PROS4    SX2    0           NO FIND
          SA3    SRCHCNT     SEE IF ANOTHER SEARCH NEEDED 
          ZR     X3,PROS7    NO MORE SEARCHING
          MX6    0           END SEARCH AFTER THIS LOOP 
          SA6    A3          SAVE IT
* 
* * *     CHECK TO SEE FILE STARTS WITH ',N',.  IF SO,
* * *     IT MAY BE AN ',N', VERSION FOR A SYSTEM LESSON
* * *     (SYSTEM OR LOCAL).  IF FILE STARTS WITH ',N',,
* * *     SEE IF THERE IS AN ENTRY WITHOUT THE ',N',. 
* 
          MX0    6           SET MASK FOR FIRST CHAR
          BX6    X0*X1       MASK OFF 1ST CHAR
          LX6    6           RIGHT JUSTIFY IT 
          SX6    X6-16B      SEE IF EQUAL TO ',N',
          NZ     X6,PROS7    IF NOT ',N', FILE, END SEARCH
          LX1    6           MOVE ',N', TO END OF WORD
          MX4    54          SET MASK FOR 9 CHARS 
          BX1    X4*X1       MASK OFF THE ',N', 
          EQ     PROS0
 
 PROS5    SA3    SRCHCNT     GET SEARCH COUNT 
          NZ     X3,PROS7    FOUND ORIGINAL LSN, SAVE 
          BX3    X2          COPY TO *X3* 
          LX3    ZNVSHF      POSITION BIT TO TOP
          MX0    1           SET MASK TO TEST TOP BIT 
          BX6    X0*X3       SEE IF *NV* SET
          NG     X6,PROS5A   IF SET, SET TO NVER SPECS
          SA3    DEVSYS      GET *DEVSYS* STATUS
          ZR     X3,PROSZ    IF NOT DEV SYSTEM, ZERO
          BX3    X2          COPY TO *X3* 
          LX3    ZSNVSHF     POSITION BIT TO TOP
          BX6    X0*X3       SEE IF *SYSNV* SET 
          ZR     X6,PROSZ    IF NOT SET, SET TO NO MATCH
 
 PROS5A   MX0    1           SET MASK TO ZERO *BIN* BIT 
          BX2    -X0*X2      KEEP EVERYTHING BUT *BIN* BIT
          MX0    42          SET MASK TO ZERO *DEL* FIELD 
          BX2    X0*X2       ZERO LAST 18 BITS
          SX3    2           SET *DEL* FIELD TO 2 
          IX2    X2+X3       STORE IT 
 
          BX7    X2          SAVE COPY OF *X2*
          SA1    ORIGLSN     GET ORIGINAL LESSON
          SA2    NPLATO      CHECK FOR LESSON -NPLATO-
          IX3    X1-X2       SEE IF IT IS =NPLATO=
          ZR     X3,PROS6    HANDLE DIFFERENTLY 
 
          SX3    -1          SET EM CHARGE TO FULL CHARGE 
          BX3    X0*X3       KEEP ONLY BOTTOM 18 BITS 
          LX3    18          POSITION TO *EM* PORTION 
          LX0    18          POSITION 0'7S OVER 18 SPOTS
          BX2    X0*X7       ZERO EM CHARGE 
          IX2    X2+X3       SET *EM* FIELD TO -1 
          EQ     PROS7       GO RETURN SYSTEM LESSON INFO 
 
* /---   BLOCK      PROSRCH    00 000   79/01/16  14.10 
* 
* * *     TURN OFF *S1P* BIT SO CAN SHIFT-STOP OUT OF LESSON
* * *     (LEAVE EM CHARGE AT 0)
* 
 PROS6    MX0    1           SET MASK FOR *S1P* BIT 
          LX0    60-ZPLDSHF  POSITION MASK FOR THAT BIT 
          BX2    -X0*X7      TURN OFF *S1P* BIT 
          EQ     PROS7       CONTINUE 
 
 PROSZ    SX2    0           NO SYSTEM PRIVILEDGES
 
 PROS7    BX7    X2          SAVE DESCRIPTOR WORD 
          SA1    PROS.X6X 
          SA2    PROS.A6
          BX6    X1 
          SA6    X2          RESTORE (A6) AND (CM VALUE)
          SA1    PROS.A0
          SA0    X1          RESTORE (A0) 
          SA1    PROS.A3
          SA3    X1          RESTORE (A3) 
          SA1    PROS.X3
          BX3    X1          RESTORE (X3) 
          SA1    PROS.X4
          BX4    X1          RESTORE (X4) 
          SA1    ORIGLSN     RETURN (X1) = FILE NAME
          BX6    X1          STORE IT THERE (JUST IN CASE)
          BX2    X7          RETURN (X2) = DESCRIPTOR WORD
          EQ     PROSRCH
 
 PROS.A0  BSS    1           FOR SAVING (A0)
 PROS.A3  BSS    1           FOR SAVING (A3)
 PROS.A6  BSS    1           FOR SAVING (A6)
 PROS.X6X BSS    1           FOR SAVING (CM VALUE OF *A6*)
 PROS.X3  BSS    1           FOR SAVING (X3)
 PROS.X4  BSS    1           FOR SAVING (X4)
 
 SRCHCNT  BSS    1           NUMBER OF SEARCHES 
 ORIGLSN  BSS    1           ORIGINAL LESSON NAME 
 NPLATO   DATA   0LNPLATO    NPLATO LESSON NAME 
 
          QUAL   *
* /---   BLOCK      PROLIST    00 000   81/12/05  03.53 
 
          ENTRY  PROLIST,SYSLST,SYLEND
 
 PROLIST  BSS    1
 SYSLST   EQU    PROLIST
 
 SYLEND   BSS    1
* /---   BLOCK      ZFILL      00 000   78/05/01  22.21 
          TITLE  -ZFILL- COMMAND
* 
* 
*         -ZFILL- COMMAND 
*         CONVERTS ARGUMENT TO LEFT-JUSTIFIED ZERO-FILL 
* 
* 
 ZFILLX   NGETVAR            GET ARGUMENT TO X1 
          CALL   LJUST,(1R ),0
          BX6    X1 
          SA6    A1 
          EQ     PROC 
* 
* 
          TITLE  -CPULIM- COMMAND 
* 
* 
*         -CPULIM- COMMAND
*         ALLOWS USERS TO CHANGE CPU MILLISECONDS PER 
*         SECOND LIMITS WITH BOUNDS UP TO -MSLIMIT- 
*         WHICH IS CURRENTLY 10 
* 
 CPULIMX  NGETVAR            GET DESIRED MSEC/SEC 
          NG     X1,ERXVAL   BAD VALUE, EXECERR USES X1 
          ZR     X1,ERXVAL   BAD VALUE, EXECERR USES X1 
**
          SA2    STFLAGS
          LX2    60-FINBIT   CHECK FOR IN-FINISH-UNIT 
          NG     X2,PROC
**
          SX2    MSLIMIT     MAXIMUM PERMISSIBLE
          IX3    X2-X1       CHECK IF MSEC/SEC TOO HIGH 
* 
          NG     X3,CPERXUL  EXECERR IF ABOVE 10 TIPS 
*                            EXECERR USES X1
 CPUX2    SX2    X1-3        MAKE SURE AT LEAST 3 
          PL     X2,CPUX3    TO GET PEOPLE FINALLY OUT OF 
          SX1    3           FINISH UNIT
 CPUX3    PX1    X1 
          NX1    X1          CONVERT TO FLOATING POINT
          SA2    =1000.0
          FX6    X2/X1       1000/CPU LIMIT 
          UX6    X6,B1
          LX6    X6,B1
          SA6    TCPUMAX     SET MAXIMUM MSEC/SEC 
          EQ     PROC 
* 
* 
 CPERXUL  SX2    MSLIMIT
          SA3    =70247011702070230000B   'T'I'P'S
          EQ     ERXMXL 
* /---   BLOCK      SHOWT      00 000   75/07/09  00.10 
          TITLE  SHOWT
*          -SHOWT- COMMAND
* 
*            SHOWS TUTOR VARIABLE (CONVERTED TO FLOATING POINT FORMAT)
*         DEFAULT FORMAT IS 4.3 IF THE
*         VARIABLE IS FLOATING POINT AND 8.0 IF IT IS INTEGER.
*         ADDITIONS FOR -SHOW ARRAY- BY SHIRER 7/8/75 
* 
          EXT    ARAYFLG
* 
          ENTRY  SHOWT
 SHOWT    BSS    0
          SX7    0
          SA7    ARAYFLG     GETVAR SETS NONZERO IF ARRAY 
          FGETVAR            EVALUATE 1ST ARGUMENT
          BX7    X1 
          SA7    SHOWVAL     SAVE IT
          SA5    A5          RESTORE COMMAND
          LX5    XCODEL      LEFT-ADJUST 2ND ARG CODE 
          NG     X5,SHOWT2   DEFAULT IF NEGATIVE
          FGETVAR            DO THE CALC TO GET THE FORMAT
          SA2    =.05        ROUND NUMBER OF DECIMAL PLACES 
          RX1    X1+X2
          UX6    X1,B1       GET INTEGER PART 
          LX6    X6,B1       FIX IT 
          SA6    NCHAR
          SA5    A5          REFETCH COMMAND WORD 
          LX5    2*XCODEL 
          PL     X5,SHOWT3A  FOR THREE ARG SHOW 
          PX2    X6          REFLOAT IT 
          NX2    X2 
          RX1    X1-X2       SUBTRACT FROM ORIGINAL FORMAT
          SA2    =10. 
          RX6    X1*X2       MULTIPLY UP THE DECIMAL PLACE SPECIFIER
          UX6    X6,B1
          LX6    X6,B1       FIX IT 
 SHOWT1   SA6    NDECPL      STORE NUMBER OF DEC. PLACES
          EQ     SHOWT3 
****
 SHOWT2   SX6    4           DEFAULT FORMAT 4.3 
          SX7    3           DEFAULT NDECPL (FLOATING)
          SA5    A5          RETRIEVE ORIGINAL COMMAND WORD 
          LX5    XFBIT
          NG     X5,SHOWT4    JUMP IF FLOATING POINT
          MX7    0           NDECPL=0 FOR INTEGER 
          LX6    1           GET AN 8 
 SHOWT4   SA6    NCHAR
          SA7    NDECPL 
 SHOWT3   SA1    ARAYFLG
          NZ     X1,ASHOWT   JUMP IF ARRAY SHOW**DEBUG**
 SHOWT5   RJ     =XTSHOW
 SHOWFIN  CALL   XYFIX       A1, X1 SET BY SHOW SUBROUTINE
          CALL   TUTWRT      B1,B2 SET BY SHOW SUBROUTINE 
          EQ     PROCO
* 
 SHOWT3A  MX0    2*XCODEL+XCMNDL  FLAG BIT NOT SET IF GET HERE
          LX5    60-2*XCODEL-XCMNDL POSITION ADDRESS
          BX5    -X0*X5 
          SA1    B5+X5       FETCH 3RD ARG
          BX5    X1 
          NGETVAR 
          MX6    0           REMOVE -0
          IX6    X6+X1
          EQ     SHOWT1        RE-ENTER NORMAL FLOW 
* 
* 
* /---   BLOCK      NUASHOW    00 000   77/07/26  21.58 
*         ARRAY SHOW PREPARATION
*         ENTER WITH X1=ARAYFLG=ADDR OF XSTOR ARAYWRD 
* 
          ENTRY  ASHOWIN,ASHOW1,ASHOW2
          ENTRY  ASHOWEF
* 
 MAXSCOLS EQU    64          MAX NUM COLUMNS TO SHOW
 MAXSROWS EQU    16          MAX  NUM ROWS TO SHOW
* 
 ASHOWT   SA3    SHOWT5      PLANT RJ=XTSHOW IN LOOP
          SX6    0           FGETVAR TYPE 
 ASHOWIN  SA6    ASHOTYP     KEEP TYPE IN X6 FOR LATER TEST 
          BX7    X3 
          SA7    ASHOW1 
          SA3    NX 
          BX7    X3 
          SA7    ASHOWNX     SAVE STARTING NX 
* 
*         ARRAY SHOW ROUTINE USED FOR -SHOWT- AND -SHOWE- 
* 
 ASHOW00  SA2    X1          GET ARAYWD IN X2 
          BX7    X2 
          SA7    ARAYWRD
          MX0    -9 
          AX2    27          (LATER WILL NEED PLANES TOO) 
          BX7    -X0*X2 
          SA7    ASHOWC      COLUMNS-1
          SX7    X7-MAXSCOLS
          PL     X7,SERXRC   *JUMP IF COLS OVER LIMIT*
*                             EXECERR USES X2 
          AX2    9
          BX7    -X0*X2 
          SA7    ASHOWR      ROWS-1 
          SX7    X7-MAXSROWS
          PL     X7,SERXRC   *LIMIT TO 16 ROW DISPLAY*
*                            EXECERR USES X2
          LX2    3+9+27 
          PL     X2,ASHOW1   JUMP IF NOT SEGMENTED
* 
          SA5    A5 
          NGETVAR            RE-EVALUATE INTEGER 1ST VALUE
          SA2    ARAYFLG
          SA2    X2+1        X2=2D ARAYWD 
          RJ     GETASEG     EXTRACT SEGMENT FROM 1ST WORD
          SA2    ASHOTYP
          BX7    -X2         NEGATIVE TYPE INDICATES SEGMENT
          SA7    A2 
          NZ     X2,ASHOW04  JUMP IF SHOWA OR SHOWO 
          PX6    X6 
          NX6    X6          SHOWT, SHOWE NEED FLOATING VALU
 ASHOW02  SB1    SHOWVAL
          EQ     ASHOW08
* 
 ASHOW04  SX2    X2-1        JUMP IF -SHOWO-
          ZR     X2,ASHOW02 
          BX6    X1          LEFT ADJSTD STRING FRM GETASEG 
          SB1    STRING 
* 
 ASHOW08  SA6    B1          STORE 1ST SHOW VALUE 
* 
*         ARRAY SHOW LOOP 
* 
* /---   BLOCK      NUASHOW    00 000   77/07/22  23.15 
 ASHOW1   RJ     =XTSHOW     CONVERT FLOAT TO ALPHA 
 ASHOW2   SA2    ASHOWR      =0 IF LAST ROW 
          NZ     X2,ASHOW3   IF NOT, SKIP OVER XYFIX
          CALL   XYFIX
 ASHOW3   CALL   TUTWRT        WRITE THE STRING 
 ASHOW4   SA2    ASHOWC      =0 IF LAST COLUMN
          NZ     X2,ASHOW8   IF NOT,DECREMENT COLUMN
          SA2    ASHOWR      =0 IF LAST ROW 
          ZR     X2,PROCO    EXIT IF DONE 
*         *NEW ROW*          *
          SA1    ARAYWRD     RESET COLUMN INFO FOR NEW ROW
          AX1    27 
          MX0    -9 
          BX7    -X0*X1      EXTRACT MAX COLS AGAIN 
          SA7    ASHOWC      AND RESTORE
          SA3    NY          SCREEN Y POSITION
          SX7    X3-32
          PL     X7,ASHOW5   JUMP IF ON SCREEN
          SX7    X7+512      IF NOT WRAP-AROUND 
 ASHOW5   SA7    NY          RESTORE NEW VALUE
* 
* /---   BLOCK      NUASHOW5   00 000   80/04/22  01.01 
* 
          SA1    ASHOWNX
          BX6    -X0*X1 
          SA6    NX          RESET WHEREX TO MARGIN 
          LX6    9
          BX1    X6+X7       MERGE NX,NY
          OUTCODE WFCODE     FINE WHERE TO START NEW ROW
* 
          SA1    XSLCLOK     GET RUNNING MS CLOCK 
          SA2    MAXCLOK
          IX1    X1-X2
          PL     X1,SINTRUP 
* 
          SA1    MOUTLOC
          SX1    X1-MOUT150 
          PL     X1,SINTRUP 
* 
 ASHOW6   SA2    ASHOWR      RESTORE ROW FOR DECREMENT
 ASHOW8   SX4    1
          IX7    X2-X4       DECREMENT ROW/COL
          SA7    A2          RESTORE IT 
* 
 ASHOW9   SA1    ARAYWRD
          IX7    X1+X4       INCREMENT GETVAR ADDRESS 
          SA7    A1          AND RESTORE IT 
          MX0    -18
          BX5    -X0*X7      GETVAR CODE OF NEXT ELEMENT
          LX5    60-XCODEL    LEFT JUSTIFY
          SA2    ASHOTYP
          NG     X2,ASHOW70  JUMP IF SEGMENTED
          NZ     X2,ASHOW95  JUMP IF SHOWO
          FGETVAR            EVALUATE NEXT ARRAY ELEMENT
 ASHOW99  BX6    X1 
          SA6    SHOWVAL
          EQ     ASHOW1      AND SHOW IT
* 
 ASHOW95  SX2    X2-2 
          ZR     X2,ASHOW96  JUMP IF SHOWA
 ASHOW94  NGETVAR            GET NEXT SHOWO VALUE 
          EQ     ASHOW99
 ASHOW96  NGETVAR 
          SB1    A1          NEXT SHOWA ADDRESS 
          EQ     ASHOW1 
* 
 ASHOW70  NGETVAR            WORD CONTAINING SEGMENT IN X1
          SA2    ARAYFLG     ADDR OF INFO WD
          SA2    X2+1        GET 2D ARAY INFO WD
          RJ     GETASEG     EXTRACT SEGMENT
          SA2    ASHOTYP
          NZ     X2,ASHOW76  JUMP IF SHOWA OR SHOWO 
          PX6    X6 
          NX6    X6          FLOAT
 ASHOW74  SA6    SHOWVAL
          EQ     ASHOW1 
* 
 ASHOW76  SX2    X2+1        X2 WAS -1 IF SHOWO 
          ZR     X2,ASHOW74  JUMP IF -SHOWO-
          BX6    X1          LEFT-JUSTIFY SEGMENT 
          SA6    STRING 
          SB1    A6 
          EQ     ASHOW1 
* 
 STRING   BSS    1
 ASHOWR   BSS    1           ARRAY ROW/COL INDICES
 ASHOWC   BSS    1
 ASHOWNX  BSS    1           STARTING NX VALUE
 ASHOTYP  BSS    1           T,E=TYPE0, O=TYPE1 
 ASHOWEF  BSS    1           SHOWE FORMAT 
 ARAYWRD  BSS    1           SEGMENTED ARAYWD 
* 
* /---   BLOCK      NUASHOWE   00 000   78/04/04  18.25 
* 
* 
*         ARRAY SHOWE PREPARATION 
* 
 ASHOWE   SA3    SHOWE5      PLANT   EQ SHOWE6  IN LOOP 
          SA6    ASHOWEF     SAVE FORMAT WHICH WAS IN X6
          SX6    0           TYPE=0 FOR FGETVAR 
          EQ     ASHOWIN
* 
 SHOWE5   EQ     SHOWE6 
* 
 SHOWE6   SA1    ASHOWEF
          BX7    X1          RECOVER FORMAT 
          MX6    0
          SA6    SHOWOUT     REQUEST LEADING BLANK/SIGN 
          SA7    NCHAR
          RJ     =XESHOW
          CALL   TUTWRT 
          SA1    NX 
          SA2    NY 
          SA3    ASHOWEF     NUMB CHARS 
          SX3    X3+10       +SPACE FOR EXPONENT,SIGN,ETC 
          LX3    3           TIMES 8 FOR EQUIVALENT DOTS
          IX6    X1+X3       NX FOR NEXT WRITE
          SA6    A1          STORE NEW NX 
          MX0    -9 
          BX1    -X0*X6 
          BX2    -X0*X2 
          LX1    9
          BX1    X1+X2       FORM OUTPUT NX,NY
          OUTCODE WFCODE     SEND OUT -WHERE- 
          EQ     ASHOW4      SKIP PAST TUTWRT 
* 
 GETASEG  EQ     *           ENTER WITH X1=WORD,X2=ARAYWD1
          LX2    1           EXAMINE TYPE 
          PL     X2,ERXHSEG  HORIZONTAL TYPE SEGMENT ILLEGAL
          LX2    59          RESTORE SIGN 
          MX0    -6 
          AX2    42 
          BX3    -X0*X2      STARTBIT POSITION
          AX2    6
          BX4    -X0*X2      BITS/BYTE
          SB1    X3-1          SB-1 = LEFT JUSTIFY SHIFT
          SB2    X4-1          BB-1 = MASK SHIFT
          RJ     GETSEG 
          EQ     GETASEG
* 
* 
*  SUBROUTINE TO EXTRACT SEGMENT FROM WORD IN X1
*         ENTER WITH B1 = LEFT-JUSTIFY SHIFT, X2 HAS SIGNBIT
 GETSEG   EQ     *           AND B2=BITS/BYTE - 1 
          LX1    X1,B1       LEFT-JUSTIFY SEGMENT 
          MX0    1
          AX0    X0,B2       FORM MASK
          BX1    X0*X1
          NG     X2,GETSEG2  JUMP IF SIGNED SEGMENT 
          SB2    B2+1        BITS/BYTE
          LX6    B2,X1       RIGHT JUSTIFY
          EQ     GETSEG 
* 
 GETSEG2  SB1    59 
          SB1    B1-B2       60-BB
          AX6    X1,B1       RIGHT-JUSTIFY, EXTENDING SIGN
          EQ     GETSEG 
* 
 SERXRC   MX0    -9 
          SA2    ARAYWRD
          AX2    27          (LATER WILL NEED PLANES TOO) 
          BX1    -X0*X2      NUMBER COLUMNS SPECIFIED 
          AX2    9
          BX2    -X0*X2      NUMBER ROWS SPECIFIED
          SX1    X1+1        MAKE CARDINAL
          SX2    X2+1        MAKE CARDINAL
          SX3    MAXSCOLS 
          SX4    MAXSROWS 
          EXECERR 120 
* /---   BLOCK      NUSINTRUP  00 000   79/12/21  22.12 
 SINTRUP  SA1    TBITS       ARRAY SHOW INTERRUPT ROUTINE 
          LX1    BRKBIT 
          NG     X1,TOOMUCH  JUMP IF AUTOBREAK SUPPRESSED 
          SA1    INEMBED
          NZ     X1,ERROROF  ERROR IF IN EMBEDDED WRITE 
          FINISH ERXOUTP     NO OUTPUT ALLOWED IN -FINISH-
          SA1    ARAYFLG
          SA2    ASHOWR 
          BX6    X1 
          BX7    X2 
          SA6    TBINTSV
          SA7    TBINTSV+1
          SA1    ASHOWC 
          SA2    NDECPL 
          BX6    X1 
          BX7    X2 
          SA6    TBINTSV+2
          SA7    TBINTSV+3
          SA1    NCHAR
          SA2    ASHOW1 
          BX6    X1 
          BX7    X2 
          SA6    TBINTSV+4
          SA7    TBINTSV+5
          SA1    SHOWOUT
          SA2    SUPPFLG
          BX6    X1 
          BX7    X2 
          SA6    TBINTSV+6
          SA7    TBINTSV+7
          SA2    ASHOWNX
          SA3    ASHOWEF
          MX0    -9         KEEP ONLY 9 BITS OF NX
          BX7    -X0*X2 
          BX3    -X0*X3      AND FORMAT 
          LX7    20 
          BX7    X7+X3       MERGE IN ASHOWEF 
          SA7    TBINTSV+8
          SA1    ARAYWRD
          BX6    X1 
          SA6    TBINTSV+9
          SA1    =XWHATSIN+0   CURRENT OVERLAY NUMBER 
          BX7    X1 
          SA7    TBINTSV+10 
          SA1    ASHOTYP
          BX6    X1 
          SA6    TBINTSV+11 
* 
          RJ     TFIN        GO DO INTERRUPT
* 
          SA1    TBINTSV+10  RESTORE ANY OVERLAY FIRST
          SA2    =XWHATSIN+0
          BX7    X1 
          RJ     =XLOADOV 
* 
          SA1    TBINTSV
          SA2    TBINTSV+1   RESTORE VALUES 
          BX6    X1 
          BX7    X2 
          SA6    ARAYFLG
          SA7    ASHOWR 
          SA1    TBINTSV+2
          SA2    TBINTSV+3
          BX6    X1 
          BX7    X2 
          SA6    ASHOWC 
          SA7    NDECPL 
          SA1    TBINTSV+4
          SA2    TBINTSV+5
          BX6    X1 
          BX7    X2 
          SA6    NCHAR
          SA7    ASHOW1 
          SA1    TBINTSV+6
          SA2    TBINTSV+7
          BX6    X1 
          BX7    X2 
          SA6    SHOWOUT
          SA7    SUPPFLG
          SA1    TBINTSV+8
          SX6    X1 
          AX1    20 
          SA6    ASHOWEF
          SX7    X1 
          SA7    ASHOWNX
          SA1    TBINTSV+9
          BX6    X1 
          SA6    ARAYWRD
          SA1    TBINTSV+11 
          BX6    X1 
          SA6    ASHOTYP
          EQ     ASHOW6 
* 
* 
* /---   BLOCK      SHOW       00 000   78/04/04  19.23 
          TITLE  SHOW 
*         -SHOW-
* 
*         SHOWS TUTOR VARIABLE IN (STANDARD) NOTATION,
*         THE SECOND ARGUMENT SPECIFIES THE NUMBER OF 
*         SIGNIFICANT FIGURES DESIRED.
*         'THE THIRD ARGUMENT SPECIFIES THE FLOOR 
*         (=10&-&9 AS DEFAULT). 
* 
* 
          ENTRY  SHOW 
* 
 SHOW     BSS    0
          FGETVAR            EVALUATE 1ST ARGUMENT
          BX7    X1 
          SA7    SHOWVAL     SAVE IT
          SA5    A5          RESTORE COMMAND
          LX5    XCODEL      LEFT-ADJUST 2ND ARG CODE 
          SX6    4           DEFAULT SHOW WIDTH 
          NG     X5,SHOW1    IF SHOULD USE DEFAULT
          NGETVAR            DO THE CALC TO GET THE FORMAT
          BX6    X1 
          ZR     X6,PROCESS  OUT IF NOTHING TO DO 
 SHOW1    SA6    NCHAR       SAVE DISPLAY WIDTH 
          SA5    A5          RETRIEVE ORIGINAL COMMAND
          LX5    XFBIT
          MX6    60          NEG 0 IF INTEGER 
          PL     X5,SHOW4    JUMP IF INTEGER
          LX5    2*XCODEL-XFBIT 
          PL     X5,SHOW5    CHECK FOR THIRD ARGUMENT 
          SA1    =XEQTOLER   GET DEFAULT TOLERANCE
 SHOW2    SA2    SHOWVAL     GET X
          BX6    X2          GET
          AX6    60          ABSOLUTE 
          BX2    X2-X6       VALUE OF X 
          FX7    X2-X1       ABS(X)-FLOOR 
          MX6    0           SET X=0 OR FLAG F.P. 
          PL     X7,SHOW4 
          SA6    SHOWVAL
          MX6    60          SET FOR INTEGER
 SHOW4    SA6    SHOWOUT     INTEGER/FLOATING FLAG IN SHOWOUT 
          SX7    1           SET TO SEE ZEROES
          BX7    X6*X7
          SA7    SUPPFLG     SET ZERO SUPPRESSION FLAG
          SA2    NCHAR       GET NSIG 
          SX3    4
          IX7    X2+X3       NSIG+4 
          SA7    SUPPFLG+1    RANGE N 
          SX7    3
          SA7    SUPPFLG+2   RANGE M
          SX7    1
          SA7    SUPPFLG+3   ALLOW TRANSFER TO -SHOWE-
          SX7    0
          SA7    STARFLG     FORCE SUP/SUB FORMAT, NOT ** 
* 
          RJ     =XZSHOW
          EQ     SHOWFIN
* 
 SHOW5    AX5    2*XCODEL+XCMNDL AND SIGN BIT WAS OFF 
          SA1    B5+X5       GET EXTRA STORAGE WORD 
          BX5    X1 
          FGETVAR            GET TOLERANCE
          PL     X1,SHOW5B   OK IF PLUS 
          NZ     X1,ERXSTOL  ERROR IF NEGATIVE
          MX1    0           SET TO ZERO
 SHOW5B   SA2    =1.         GET A ONE
          FX2    X2-X1       MUST BE LESS THAN OR EQUAL ONE 
          PL     X2,SHOW2 
          EQ     ERXSTOL
* /---   BLOCK      SHOWZ      00 000   78/01/19  01.07 
          TITLE  SHOWZ
*         -SHOWZ- 
* 
*         SHOWS TUTOR VARIABLE IN (STANDARD) NOTATION,
*         THE SECOND ARGUMENT SPECIFIES THE NUMBER OF 
*         SIGNIFICANT FIGURES DESIRED.
* 
* 
**
          ENTRY  SHOWZ
* 
 SHOWZ    SX7    1           FLAG TO SEE TR. ZEROES 
          SA7    SHOWOUT
          FGETVAR            EVALUATE 1ST ARGUMENT
          BX7    X1 
          SA7    SHOWVAL     SAVE IT
          SA5    A5          RESTORE COMMAND
          LX5    XCODEL      LEFT-ADJUST 2ND ARG CODE 
          SX6    4           DEFAULT SIGNIFICANT DIGITS 
          NG     X5,SHOWZ3   IF SHOULD USE DEFAULT
          NGETVAR            DO THE CALC TO GET THE FORMAT
          ZR     X1,PROCESS  OUT IF NOTHING TO DO 
          BX6    X1 
          AX6    6           CATCH IF GREATER THAN 64 
          NZ     X6,ERXBADL 
          SX6    X1          SET NUMBER OF SIG FIGS 
 SHOWZ3   SA5    A5          RETRIEVE ORIGINAL COMMAND
          LX5    XFBIT
          SA6    NCHAR       STORE NSIG FIGS
          MX6    60          NEG 0 IF INTEGER 
          SX7    1           TURN OFF ZERO-SUPPRESSOR 
          PL     X5,SHOWZ4   JUMP IF INTEGER
          MX6    0           +0 IF FLOATING POINT 
          SA1    SHOWOUT
          BX7    X1          SET TO PRESET VALUE
* 
* 
 SHOWZ4   SA6    SHOWOUT     INTEGER/FLOATING FLAG IN SHOWOUT 
          SA7    SUPPFLG     ZERO SUPPRESS FLAG 
          SA2    NCHAR       GET NSIG 
          SX3    4
          IX7    X2+X3       NSIG+4 
          SA7    SUPPFLG+1    RANGE N 
          SX7    3
          SA7    SUPPFLG+2   RANGE M
          SX7    1
          SA7    SUPPFLG+3   ALLOW TRANSFER TO -SHOWE-
          SX7    0
          SA7    STARFLG     FORCE SUP/SUB FORMAT, NOT ** 
* 
          RJ     =XZSHOW
          EQ     SHOWFIN
* 
          ENTRY  ASHOWE,SHOWFIN,ASHOW3,ASHOWIN
*         ABOVE ENTRIES ARE DUE TO OVERLAYING OF
*         -SHOWE-, -SHOWO- AND -SHOWH-
* /---   BLOCK      -ZERO-     00 000   79/01/03  13.35 
 ZEROSAV  SPACE  5,11 
**        ZEROSAV - SAVE REGISTERS *X4* AND *A4*
 
          ENTRY  ZEROSAV
 
 ZEROSAV  PS
 
          SA0    A7          SAVE *A7*
          SA7    ZBSAVX7     SAVE CURRENT *X7*
          BX7    X4 
          SA7    ZBSAVX4     SAVE *X4*
          SX7    A4 
          SA7    ZBSAVA4     SAVE *A4*
          SA4    A0          GET DATA AT *A7* 
          BX7    X4 
          SA7    A0          WRITE IT BACK AND RESET *A7* 
          SA4    ZBSAVX7     GET ORIGINAL *X7*
          BX7    X4          RESET *X7* 
          EQ     ZEROSAV     -- EXIT
 
 ZERORST  SPACE  5,11 
**        ZERORST - RESTORE *X4* AND *A4* AFTER -ZERO-
* 
*         RESTORE *X4*, *A4* -- *X0* LOST 
 
          ENTRY  ZERORST
 
 ZERORST  PS
 
          SA4    ZBSAVX4     GET *X4* 
          BX0    X4          HOLD *X4*
          SA4    ZBSAVA4     GET *A4* 
          SA4    X4          RESET *A4* 
          BX4    X0          RESET *X4* 
          EQ     ZERORST     RETURN 
* 
 ZBSAVX7  BSS    1
 ZBSAVX4  BSS    1
 ZBSAVA4  BSS    1
* 
 
* /---   BLOCK      END        00 000   78/09/01  21.41 
* 
* 
          END