Retro1.org codex

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