*DECK BASERRS 
          IDENT  BASERRS
          TITLE  BASERRS - EXECUTION CONTROL
*CALL COPYRITE
          IPARAMS 
*CALL LCORE 
*CALL LIPARAM 
*CALL ERMNUM
          EXT    BASCIO=
          EXT    BASSYS=
 CIO=     EQU    BASCIO=
 SYS=     EQU    BASSYS=
          EXT    ERRSTRT
          EXT    PDWORD 
          EXT    CODSTRT,CODEND 
          EXT    BASEGEN
          EXT    ASCII
          EXT    DATAXXX
          EXT    GOSUBXX
          EXT    ER126
          EXT     ER170                    ILLEGAL LABEL ERROR
          ENTRY  BASESRT           EXECUTION INITIALIZATION 
          EXT    RECOVER           RPV PROCESSOR
          EXT    UCNTRLE
          EXT    ONERLBL
          EXT    VALESL,VALESM,VALEST,VALNXL
          EXT    DB.SW
          EXT    SAVEBR 
          EXT    PDSAVE 
          EXT    STRFMT 
          EXT    ATLIST,ERLIST
          EXT    DBUGON            CID MODE FLAG
          EXT    ERBLOCK,ATBLOCK   DBUG.FN PARAM BLOCKS 
          EXT    ATNPROC,BASERR.   DBUG.FN RECOVERY PROCS 
          EXT    ER170
          ENTRY  BASEJMP,BATEJMP
          ENTRY  BASERRS,BATERRS
          ENTRY  BASERSS,BATERSS
          ENTRY  GETNXTL
          ENTRY  BASETRC,BASETCP,BASETON,BASETOF
          ENTRY  BASEESL,BATEESL
          ENTRY  BASEESM,BATEESM
          ENTRY  BASENXL,BATENXL
          ENTRY  BASACLK,BATACLK
          ENTRY  BASCLCK,BATCLCK
          ENTRY  BASDATE,BATDATE
          ENTRY  BASUSRN,BATUSRN
          ENTRY  BASATTN,BATATTN
          ENTRY  BASATNN,BATATNN
          ENTRY  BASEASL,BATEASL
          ENTRY  BAAESRT
          EXT    BASCOLL,BASANSI,BASICNB
          EXT    ATTN 
          EXT    INTRFLG
          EXT    PRTFLG 
          EXT    UCNTRLA
          EXT    ONATNLB
          EXT    VALASL 
          EXT    RPVBLK 
          EXT    BASATIM,STIME
          EXT    SETDGTS
          EXT    RNBLOCK,RNLIST,DBUGON
* 
          IFC    EQ,,"OS.NAME",KRONOS,
          SST 
          ELSE
 ACTR     EQU    64B
 LWPR     EQU    65B
          ENDIF 
          SYSCOM             DEFINE INTERFACE SYMBOLS.
 SETA0    EQU    510B 
 DEFPD    DATA   1LS
* 
* 
 LBLCHK   MACRO  LABEL
          NG     X5,LABEL 
          SA1    MAXLN
          FX1    X1-X5
          NG     X1,LABEL 
          UX5    B6,X5
          LX5    B6,X5
          ENDM
* 
 MOVEREG  MACRO  XX,YY
          IFNE   XX,YY,1
          BX.YY  X.XX        MOVE XX TO YY
          ENDM
* 
* 
 UV       EQU    5
          IFC    EQ,,"OS.NAME",KRONOS,
 OPL      XTEXT  COMCMAC
          ENDIF 
          TITLE  ERROR MESSAGES 
* 
*         ERROR-MESSAGES
* 
 ERM100   DATA   C* TIME LIMIT EXCEEDED * 
 ERM101   DATA   C* ECS OR CY170 PARITY ERROR * 
 ERM102   DATA   C* PPU ABORT * 
 ERM103   DATA   C* XXX NOT IN PPLIB *
 ERM104   DATA   C* PP CALL ERROR * 
 ERM105   DATA   C* OPERATOR DROP OR KILL * 
 ERM106   DATA   C* IO TIME LIMIT * 
 ERM107   DATA   C* CPU ERROR EXIT 00 * 
 ERM108   DATA   C* CPU ERROR EXIT 01 * 
 ERM109   DATA   C* INFINITE OPERAND *
 ERM110   DATA   C* CPU ERROR EXIT 03 * 
 ERM111   DATA   C* CPU ERROR EXIT 04 * 
 ERM112   DATA   C* CPU ERROR EXIT 05 * 
 ERM113   DATA   C* CPU ERROR EXIT 06 * 
 ERM114   DATA   C* CPU ERROR EXIT 07 * 
 ERM115   DATA   C* OPERATOR RERUN *
 ERM116   DATA   C* AUTO RECALL STATUS MISSING *
 ERM117   DATA   C* HUNG IN AUTO RECALL * 
 ERM118   DATA   C* MASS STORAGE LIMIT *
 ERM170   DATA   C* ILLEGAL LABEL * 
* 
* 
* 
          SPACE  4
          DATA      10HBASRCHK
 BASRCHK  DATA      0                  CHECK FOR WRONG DATA TYPE IN READ
          MX7       42
          BX7       X7*X6 
          ZR        X0,BNUM 
          ZR     X6,ER126    *BAD DATA IN READ* 
          NZ     X7,ER126 
          JP        BASRCHK 
BNUM      ZR        X6,BASRCHK         ZERO OK
          NZ        X7,BASRCHK         HAS EXPONENT OK
          JP     ER126             BR, *BAD DATA IN READ* 
          ENTRY  BAARCHK
 BAARCHK  BSSZ   1
          BX7    X6 
          AX7    18 
          NZ     X0,BAARCHK2 IF STRING, BR
          ZR     X6,BAARCHK3 NUMBER IS ZERO 
          ZR     X7,ER126    NOT A NUMBER 
 BAARCHK3 SA1    DATAXXX     BYPASS STRING THAT 
          SX7    X1+1        FOLLOWS
          SA7    A1 
          EQ     BAARCHK
 BAARCHK2 ZR     X6,BAARCHK4 NUMBER FOUND, GO BYPASS
          ZR     X7,BAARCHK  IS A STRING, RETURN
 BAARCHK4 SA1    DATAXXX     BYPASS THE NUMBER
          SX7    X1+1 
          SA7    A1 
          SA1    X1 
          SB7    X1+B4       PICK UP THE STRING 
          EQ     BAARCHK
* 
 MAXLN    DATA   99999.            MAXIMUM VALID LINE NO
          TITLE  BASESRT - BASIC INITIALIZATION PROCEDURE 
 LWORD    DATA   0                 STS STATUS WORD
 DB.ON    EQU    34                DEBUG ON BIT IN W.CPLDR1 
 STRPTR   BSSZ   1                 DUMMY STRING POINTER 
RJCHKDL   RJ     =XCHKDLMT         DUMMY RJ-S TO STORE ELSEWHERE
RJBASGS   RJ     =XBASGSTR         DUE TO INABILITY TO LINK FORWARD 
RJBSPRT   RJ     =XBASOPRT         DUMMY RJ 
* 
*         INITIALIZATION-ROUTINE
* 
          DATA   10HBAAESRT 
 BAAESRT  BSSZ   1                 ANSI ENTRY POINT 
          LX6    1                 MOVE ASCII FLAG TO BIT 0 
          BX5    X5+X6
          SA6    ASCII             STORE ASCII SWITCH 
          SA7    DB.SW             STORE DEBUG SWITCH 
          BX6    X5 
          SA6    BASCOLL           SAVE COLLATE FLAG
          SX6    6
          SA6    SETDGTS           FORCE SETDIGITS=6 FOR ANSI DEFAULT 
          BX6    X4 
          SA6    BASICNB           SAVE INPUT CONVERSION BUFFER LOCATION
          MX6    1
          SA6    BASANSI           SET ANSI FLAG
          EQ     BASESR1
 BASESRT  BSSZ   1                 PREANSI ENTRY POINT
          LX6    1                 MOVE ASCII FLAG TO BIT 0 
          SA6    ASCII       STORE ASCII SWITCH 
          SA7    DB.SW       DEBUG SWITCH 
 BASESR1  BSS    0
          SX6    B0 
          MX7    59 
          SA6    STRFMT      TURN STR-FUNCTION-FORMAT FLAG OFF
          SA6    UCNTRLE
          SA6    FIELDLG     CLEAR RUNTIME FL SIZE INDICATOR
          SA6    UCNTRLA           CLEAR USER CONTROL OF T.I. 
          SA6    INTRFLG           CLEAR T.I. FLAG
          SA7    ONERLBL          INITIALISE ERROR CONTROL FUNCTIONS
          SA7    VALESL 
          SA7    VALESM 
          SA7    VALNXL 
          SA7    ONATNLB          INITIALIZE ON ATTN TARGET LABEL 
          SA7    VALASL            INITIALIZE ON ATTN STMT LINE NO. 
          MX7    42 
           SA1   BASESRT           FETCH BASESRT RETURN ADDRESS 
          SA2    BAAESRT
          BX1    X2+X1
           LX1   30 
           SB5   =YBASSRT.        CHECK FOR CID MODE
           NG    B5,NOCID         BR, NOT CID MODE
           SA1   B5               USE BASSRT. IN CID MODE 
 NOCID     BSS   0
          SX6   X1
          SA6    CODSTRT           BEGINNING OF CODE
          SX6    B4-2 
          SA6    CODEND            END OF CODE
          SX6    B2                SAVE B2 AND B4 
          SX7    B4 
          SA6    SAVEBR 
          SA7    SAVEBR+1 
          SX6    B1                INITIALIZE DATA AND GOSUB POINTERS 
          SX7    B3 
          SA6    DATAXXX
          SA6    DATAXXX+1         SECOND VALUE IS POS. FOR REWIND
          SA7    GOSUBXX
          SX6    B7 
          SA6    PDSAVE            SAVE PDOPTION SWITCH 
          SA1    LWORD
          MX6    59 
          BX6    X6*X1
          SA6    A1 
* 
*         INSURE THAT DEBUG IS REALLY ON
* 
          SX6    B0          PRESET DEBUG OFF 
          SX1    =YDBUG.FN
          NG     X1,NOCID1   BR, DEBUG. MODULE NOT LOADED 
          SX1    =YDBUG.OM   DOUBLE CHECK 
          NG     X1,NOCID1   BR, DEBUG. MODULE NOT LOADED 
          GETLC LWORD 
          SA1    LWORD
          LX1    59-DB.ON          GET DEBUG ON BIT 
          MX6    1
          BX6    X6*X1             ISOLATE DEBUG ON BIT 
 NOCID1   BSS 
          SA6    DBUGON            SAVE BASIC DEBUG FLAG
          RJ   BASATIM             CURRENT CP TIME IN X5
          BX6    X5                SAVE START TIME
          SA6    STIME
          SA1    RJBSPRT           PICK UP DUMMY RJ INSTRUCTION 
          BX6    X1 
          SA6    =XTABCNVX         SET RJ =XBASOPRT IN BASRTS 
          SA1    RJCHKDL           PICK UP RJ INSTRUCTIONS
          BX6    X1 
          SA6    =XBASCDT1         SET RJ =XCHKDLMT IN BASICON
          SA6    =XBASCDT2         SET RJ =XCHKDLMT IN BASICON
          SA6    =XBASCDT3
          SA1    RJBASGS
          BX6    X1 
          SA6    =XBASXGST         SET RJ =XBASGSTR IN BASXCHR
          SA6    =XBASCGST         SET RJ =XBASGSTR IN BASOCON
          SA1       B4                  REL ADDRESS OF FIRST CHANNEL
          MX5    42 
          SA2    ACTR        NUMBER OF PARAMETERS 
          SB5    X2 
          SX2    X2-3 
          NG   X2,BASES97          0, 1, OR 2 PARAMS
          EQ   BASES98             TREAT MORE AS TWO
 BASES97  JP     BASES99+B5 
 BASES99  BSS    0
          EQ     BASES01
          EQ     BASES07
 BASES98  BSS    0
          SA2    IOPTION
          BX2    X2*X5
          ZR     X2,BASES07  NO NEW KFILE 
          SX6    1
          BX6    X6+X2
          SA6    X1+B4       NEW KFILE
 BASES07  BSS    0
          SA2    EOPTION
          BX2    X2*X5
          ZR     X2,BASES01  NO NEW JFILE 
          SX6    1
          BX6    X2+X6
          SX2    X1+B4
          SA2    X2+FETCHAN 
          SX2    X2 
          NG     X2,BASES01  NO J FILE
          SA6    X2+B4
 BASES01  SB5       X1+B4               B5 = CHANNEL-ADDRESS
          SA1       B5+FETFRST
          SA2       B5+FETIN
          SX6       X1+B2 
          SX7       X2+B2 
          MX3    1
          LX3    19 
          BX6       X6+X3 
          SA6       A1                  MAKE FIRST AND IN 
          SA7       A2                  ABSOLUTE
          SA1       B5+FETOUT 
          SA2       B5+FETLIMT
          SX6       X1+B2 
          SX7       X2+B2 
          SA6       A1                  MAKE OUT AND LIMIT
          SA7       A2                  ABSOLUTE
          SX7    B0 
          SA7    FETSETV+B5        CLEAR SET FILE VALUE AND 
          SA7    A7+2              CLEAR LOF , LOC ENTRIES
          SA7    FETROI+B5         CLEAR RSA,IN,OUT (RANDOM USAGE)
  
          SA1    B5                CHECK IF DUMMY FET 
          LX1    18 
          SX1    X1 
          ZR     X1,BASES10        JUMP IF DUMMY FET
          OPEN   B5,ALTERNR,R 
          SA1    B5                CLEAR STATUS BITS IN FET 
          MX2    17 
          LX2    18 
          BX6    -X2*X1 
          SA6    B5                RESTORE NAME INTO FET
BASES10   BSS    0
* 
          SA1    B5+FETFRST        GET DEVICE TYPE
          MX2    DEVTYPL
          BX1    X1*X2
          LX1    DEVTYPL
          SB6    X1 
          SB7    DEVTYP3
          NE     B6,B7,BASES02
          SA1    B5+FETSTAT   IT IS A TERMINAL
          MX6    1
          LX6    19 
          BX6    X6+X1       TURN INTERACTIVE BIT ON
         SA6       A1 
          IFC    EQ,,"OS.NAME",SCOPE ,
          SA1    ASCII
          ZR     X1,BASES02  NOT ASCII SO BYPASS
          SA1    B5+FETSETV 
          MX6    1
          LX6    23          BIT 22=ASCII-95 MODE 
          BX7    X6+X1
          SA7    A1 
          SA1    B5+FETFRST 
          LX6    20                BIT 42 FOR ASCII MODE
          BX7    X6+X1
          SA7    A1 
          ENDIF 
BASES02  SA1       B5+FETCHAN           GET NEXT CHANNEL
         SX1       X1 
         PL        X1,BASES01           LOOP IF NOT LAST CHANNEL
  
**        FIX BASESRT TO CORRECTLY SET POINTERS 
  
**        THE ASSUMPTION IS MADE THAT THE FIRST TWO 
*         FILES DECLARED ARE
*         *OUTPUT* (DMPFILE WILL HOLD POINTER) AND
*         *INPUT* (DMPFILE+1 WILL HOLD POINTER).
* 
*         THE POINTERS ARE MOVED TO RA+2 AND RA+3 AT
*         THE END OF INITIALIZATION SO THAT AUTOMATIC 
*         *OUTPUT* DUMP BEFORE INPUT WILL WORK.  ADDRESS
*         RA+4 IS SET TO ZERO.
* 
  
          MX5    42 
          SA2    B4          B4 HAS ADDRESS OF FIRST FET POINTER
          SX2    X2+B4       ABSOLUTE ADDRESS OF *OUTPUT* FET 
          IFNE   FETFILE,0
          SA1    FETFILE+X2 
          ELSE
          SA1    X2 
          ENDIF 
          BX6    X5*X1
          BX6    X6+X2             MERGE FILENAME AND ADDRESS 
          SA6    KOPTION
          SA6    EOPTION
          SA1    X2+FETSTAT 
          LX1    59-18
          NG     X1,BASES06  FILE IS TERMINAL 
          SA1    PDWORD 
          NZ     X1,BASES06  PDWORD ALREADY OUTPUT
          SA4    PDSAVE            PDOPTION SWITCH
          ZR     X4,BASES06  NO PDOPTION
          LX4    54 
          SA3    DEFPD
          BX6    X3 
          SA6    PDWORD      SET PDWORD TO DEFAULT PD 
          SA3    X2+FETIN 
          BX6    X4          OUTPUT PDOPTION
          IFC    EQ,,"OS.NAME",SCOPE ,
          SA2    ASCII
          ZR     X2,BASES00 
          SX2    1
          BX6    X6+X2
          LX6    54 
 BASES00  BSS    0
          ENDIF 
          SA6    X3            WORD 
          SX6    X3+1 
          SA6    A3          RESET FETIN
 BASES06  BSS    0
* 
          SA2    X2+FETCHAN  GET CHAIN TO NEXT FET
          SX2    X2+B4
          IFNE   FETFILE,0
          SA1    FETFILE+X2 
          ELSE
          SA1    X2 
          ENDIF 
          BX6    X5*X1
          BX6    X6+X2       MERGE FILENAME AND ADDRESS 
          SA6    KOPTION+1
          SA6    3
          MX7    0
          SA7    4           INDICATE END OF POINTERS 
* 
          SA1    DBUGON            FETCH BASIC DEBUG FLAG 
          ZR     X1,SYSRPV         BR, CID DISABLED - NORMAL MODE 
          SX1    STRPTR            FETCH DUMMY STRING POINTER ADDR
          SX2    1                 X2 = LENGTH OF DUMMY STRING
          RJ     =XBASGSTR
*                                  TO INITIALIZE STRING SPACE 
          SA3    B0                INSURE REGS ARE CLEAR
          SA4    B0 
          SA5    B0 
          SA1    BAAESRT
          NZ     X1,BAAESRT 
          EQ     BASESRT           EXIT 
 SYSRPV   BSS    0
          SYSTEM RPV,R,RPVBLK,1    REQUEST ERROR RECOVERY 
          SA3    B0          ENSURE A REG VALUES ARE IN FL
          SA4    B0 
          SA5    B0 
        SA1    BAAESRT          CHECK FOR BASIC 3.5 CALL
        NZ     X1,BAAESRT        EXIT FROM BAAESRT
          EQ   BASESRT
  
  
* 
*         END INITIALIZATION
* 
* 
          TITLE  BASEJMP
* 
* 
* 
          DATA   10HBASEJMP 
 BASEJMP  BSS    0
* 
* 
*                PURPOSE: TO CHECK AND TRANSFER TO (IF POSSIBLE) THE
*                         LABEL SPECIFIED IN A -JUMP- STATEMENT.
* 
* 
*                ENTRY: X5 CONTAINS THE LABEL VALUE 
* 
* 
*                USES: X0  1       B6 
          JP     0
          SA1    BASANSI
          ZR     X1,JMP1
          BX1    X1-X1
          PX1    X1 
          RX5    X5+X1
          NX5    X5 
 JMP1     BSS    0
          LBLCHK ER170       CHECK AND UNFLOAT THE SPECIFIED LABEL
          RJ     FINDLBL           SEARCH FOR IT THRU THE GENERATED CODE
          NG     X3,ER170    *ILLEGAL LABEL*
          SB6    X1 
          JP     B6                JUMP TO IT (AS SPECIFIED)
* 
* 
* 
* 
 FINDLBL  BSS    0
* 
* 
*                PURPOSE: TO SEARCH THE GENERATED CODE FOR THE ADDRESS
*                         OF A SPECIFIED LINE NUMBER. 
* 
* 
*                ENTRY: X5 CONTAINS THE LINE VALUE
* 
* 
*                EXIT: X3 .LT. 0 IMPLIES THE LINE NUMBER NOT FOUND
*                      X1 CONTAINS THE LINE NO ADDRESS (IF X3 .GE.0)
* 
* 
*                USES: X0  1  2  3  5  6
* 
* 
          JP     0
          MX0    9                 FORM MASK FOR OPCODES
          SA1    CODSTRT           X1: START ADDRESS OF GENERATED CODE
          SA2    CODEND            X2: END ADDRESS OF GENERATED CODE
* 
 LBLOOP   BSS    0
* 
          RJ     GETNXTL           GET NEXT LABEL 
          NG     X3,FINDLBL        EXIT: NONE LEFT
          IX6    X5-X3             CHECK AGAINST THE TARGET LABEL 
          ZR     X6,FINDLBL        EXIT (X1 HAS THE ADDRESS)
          SX1    X1+1              ADVANCE OBJECT CODE POINTER
          EQ     LBLOOP            GO TRY NEXT LABEL
* 
* 
* 
 GETNXTL  BSS    0
* 
* 
*                PURPOSE: TO FIND THE NEXT LABEL IN THE OBJECT CODE 
* 
* 
*                ENTRY: X1 POINTS TO THE NEXT WORD OF OBJECT CODE 
*                       X2 HAS THE OBJECT CODE END ADDRESS
*                       X0 HAS THE (OPCODE) MASK (BITS 51-59) 
* 
* 
*                EXIT: X3 .LT. 0 IMPLIES NO NEXT LABEL EXISTS. ELSE X3
*                      CONTAINS THE NEXT LABEL (AS AN INTEGER)
*                      X1 HAS THE OBJECT CODE ADDRESS CORRESPONDING 
*                      TO THE LABEL MET.
* 
* 
*                USES: X0  1  3  6
* 
* 
          JP     0
 NXTLOOP  BSS    0
          SA3    X1                LOAD NEXT WORD OF GENERATED CODE 
          BX6    X0*X3             PICK OFF OPCODE BYTE 
          LX6    9                 SHIFT AROUND (RIGHT ADJUST)
          SX6    X6-SETA0          TEST FOR -SA0- (LABEL SETUP CODE)
          NZ     X6,NOTLBL         SKIP IF NOT
          BX3    -X0*X3            ELSE DROP OPCODE 
          AX3    60-30             ISOLATE THE LABEL
          EQ     GETNXTL           EXIT 
* 
* 
 NOTLBL   BSS    0
          SX1    X1+1              ADVANCE OBJECT CODE POINTER
          IX3    X2-X1             CHECK IF OBJECT CODE EXHAUSTED 
          PL     X3,NXTLOOP        IF NOT TRY NEXT WORD 
          EQ     GETNXTL           ELSE EXIT (X3 .LT. 0)
* 
* 
* 
 BATEJMP  BSS    0
* 
          TITLE  BASERRS AND BASERSS
* 
         DATA      10HBASERRS 
BASERRS  BSS       0
          JP     0
* 
* 
*                NOTE THAT THE LOCATION FOLLOWING THE GENERATED CALL ON 
*                BASERR CONTAINS THE TARGET LABEL TRANSFER SPECIFIED
*                BY THE ASSOCIATED -ON ERROR GOTO-
* 
* 
* 
          SA1    DBUGON            GET CID MODE FLAG
          ZR     X1,ERCONT         BR, CID DISABLED 
          SX6    BASERR.           RECOVERY ADDRESS 
          SA6    ERBLOCK+2
          SA1    ERLIST            FETCH DBUG.FN PARAM LIST 
          RJ     =YDBUG.FN         INITIALIZE DBUG.FN 
 ERCONT   BSS    0
         SA1       BASERRS
          AX1    30                DROP LOWER (NO-OPS)
          SA1    X1                LOAD THE (TRANSFER-TO-ERROR-LABEL) 
          SB6    A1                RETAIN ITS ADDRESS (USED LATER)
          AX1    30                DROP LOWER (NO-OPS)
          MX7    42 
          BX7    -X7*X1            PICK OFF ERROR ADDRESS 
          SA7    ONERLBL          DUMP IT 
          SX7    1
          SA7    UCNTRLE           SET USER-CONTROLS-ERRORS FLAG
         MX7     59 
         SA7     VALESL                RESET TO -1
         SA7     VALESM 
          JP     B6+1              EXIT (SKIP OVER THE ERR LBL TRANSFER)
* 
* 
BATERRS  BSS       0
* 
* 
* 
         DATA      10HBASERSS 
BASERSS  BSS       0
          JP     0
* 
* 
          SA1    DBUGON            CHECK FOR CID MODE 
          ZR     X1,CON02          BR, NOT IN CID MODE
          SX6    BASERR.           CLEAR DBUG ERROR TRAP
          BX6    -X6
          SA6    ERBLOCK+2
          SA1    ERLIST            DBUG.FN APLIST 
          RJ     =YDBUG.FN         DO IT
 CON02    BSS    0
          SX7    B0 
          SA7    UCNTRLE           SET SYSTEM-CONTROLS-ERRORS FLAG
          MX7    59 
          SA7    VALESL            RESET TO -1
          SA7    VALESM 
         EQ        BASERSS
* 
* 
BATERSS  BSS       0
* 
* 
          TITLE  BASETRC - EXECUTION TRACE
          EJECT 
          DATA   10HBASETCP 
 BASETCP  DATA   0
          SA1    UCNTRLE
          SX7    B0          TEMPORARY TURN OFF 
          SA7    A1          USER CONTROL 
          BX7    X1 
          SA7    TRCTEMP
          SB7    TRACE       SEND TRACE MESSAGE 
          RJ     BASEGEN
          SA1    TRCTEMP
          BX7    X1          RESTORE USER CONTROL 
* 
          SA7    UCNTRLE
          EQ     BASETCP
* 
          DATA   10HBASETRC 
 BASETRC  DATA   0
          SA1    DB.SW
          PL     X1,BASETRC  TRACE NOT ON 
          SA1    UCNTRLE
          SX7    B0          TEMPORARY TURN OFF 
          SA7    A1          USER CONTROL 
          BX7    X1 
          SA7    TRCTEMP
          SB7    TRACE       SEND TRACE MESSAGE 
          RJ     BASEGEN
          SA1    TRCTEMP
          BX7    X1          RESTORE USER CONTROL 
          SA7    UCNTRLE
          EQ     BASETRC
* 
* 
          DATA   10HBASETON 
 BASETON  DATA   0
          SA1    DB.SW
          NG     X1,BASETON  TRACE ALREADY ON 
          MX7    1           SET SW ON
          BX7    X7+X1
          SA7    A1 
          EQ     BASETON
* 
* 
          DATA   10HBASETOF 
 BASETOF  DATA   0
          SA1    DB.SW
          PL     X1,BASETOF  TRACE ALREADY OFF
          MX7    1
          BX7    -X7*X1      TURN SW OFF
          SA7    A1 
          EQ     BASETOF
* 
* 
 TRACE    DATA   C$ *$
 TRCTEMP  BSS    1           TEMPORARY STORAGE FOR USER CONTROL WORD
* 
          TITLE  BASACLK, BASATIM,BASACLCK AND BASDATE
* 
*         CLK(X)
* 
         DATA      10HBASACLK 
BASACLK   DATA      0 
          CLOCK  TIME 
          SA2       TIME
          SA1       CLKMSK
          IX2       X2-X1 
          AX2       6 
          SX0       77B 
          BX5       X0*X2 
          AX2       6 
          BX3       X0*X2 
          BX6       X3
          LX6       1 
          LX3       3 
          IX6       X6+X3              10 TIMES X3
          IX5       X5+X6              TOTAL SECONDS
          PX5       B0,X5 
          NX5       B0,X5 
          SA3       SEC2HRS 
          RX5       X5/X3 
          AX2       12
          BX3       X0*X2 
          AX2        6
          BX4       X0*X2 
          BX6       X4
          LX6       3 
          LX4       1 
          IX6       X4+X6              10 TIMES X4
          IX6       X6+X3              TOTAL SECONDS
          PX6       B0,X6 
          NX6       B0,X6 
          SA4       MIN2HRS 
          RX6       X6/X4 
          RX5       X5+X6              MINUTES+SECONDS
          NX5       B0,X5 
          AX2       12
          BX3       X0*X2 
          AX2       6 
          BX2       X2*X0 
          BX4       X2
          LX4       3 
          LX2       1 
          IX4       X4+X2              TOTAL HOURS
          IX4       X4+X3 
          PX4       B0,X4 
          NX4       B0,X4 
          RX5       X4+X5              TOTAL TIME 
          NX5       B0,X5 
          MOVEREG   5,UV
          JP        BASACLK 
TIME      DATA      0 
CLKMSK    DATA      00333300333300333300B 
SEC2HRS   DATA      3600. 
MIN2HRS   DATA       60.
 RPVTI    VFD    24/237B,24/0,12/0   SET RPV FOR TERMINAL INTRRPTS
 RPVRSET  VFD    36/0,12/31B,11/1,1/0   RPV SET-UP
BATACLK   BSS       0 
* 
*         END  CLK(X) 
* 
*                                  BASRTS.3026
* 
          DATA   10HBASCLCK 
 BASCLCK  DATA   0
          CLOCK  DATIME 
          SX2    10          X2 = LENGTH OF RESULT STRING 
          RJ     FIXRETN     GO MOVE RESULT TO STRING AND SET UP B7 
          EQ     BASCLCK           EXIT WITH B7 POINTING AT TIME STRING 
* 
 FIXRETN  DATA   0
          SX1    DATIPTR     X1 = ADR OF STRING POINTER WORD
          RJ     =XBASGSTR   GO GET (X2) CHARACTERS OF STRING SPACE 
          SA3    DATIME      GET TIME/DATE STRING 
          BX6    X3 
          SA6    X1          STORE RESULT IN STRING 
          SX2    X2-9 
          NG     X2,FIXRETN1    SKIP IF LESS THAN 9 CHARS IN STRING 
          MX6    0           STORE ZERO BYTE DELIMITER IN NEXT WORD 
          SA6    A6+1         IF RESULT WAS EXACTLY 10 CHARS
 FIXRETN1 SB7    DATIPTR
          SX6    B7-B2
          SA6    DATIME      SAVE POINTER ADDRESS-B2
          SB7    A6          B7 = ADR OF WORD CONTAING ADDRESS-B2 
          EQ     FIXRETN
* 
 DATIME   DATA   0                 TIME/DATE STRINGS
 DATIPTR  DATA   0           POINTER WORD FOR STRING. INITIALLY 0 
* 
* 
* 
 BATCLCK  BSS    0
* 
* 
          DATA   10HBASDATE 
 BASDATE  DATA   0
          DATE   DATIME 
          SX2    10          X2 = LENGTH OF RESULT STRING 
          RJ     FIXRETN     GO CREATE STRING AND SET UP B7 
          EQ     BASDATE           EXIT 
* 
* 
 BATDATE  BSS    0
* 
* 
* 
          DATA   10HBASUSRN 
 BASUSRN  DATA   0                 USER NUMBER
          IFC    EQ,,"OS.NAME",KRONOS,
          SYSTEM   CPM,RECALL,DATIME,32B*100B 
           ENDIF
           SA1      DATIME          FETCH RETURNED USER NUMBER
           NZ       X1,USRN.0       BR, VALID USER NUMBER RETURNED
           SA2      USRN            SUPPLY STRING USERNUM 
           BX6      X2
           SA6      A1
 USRN.0    BSS      0 
          SX2    11          INITIALIZE COUNT OF CHARS IN RESULT
          MX0    54 
          SA1    DATIME 
 USRN.A   SX2    X2-1        X2 = CALCULATED LENGTH OF RESULT STRING
          BX6    -X0*X1      LOOK FOR TRAILING ZEROS
          AX1    6
          ZR     X6,USRN.A   LOOP IF CHAR WAS A ZERO
          RJ     FIXRETN     GO CREATE STRING AND SET UP B7 
          EQ   BASUSRN
 USRN     DATA   7LUSERNUM
 BATUSRN  BSS    0
* 
          TITLE  BASEESL AND BASEESM
*                ESL(X) 
          DATA   10HBASEESL 
 BASEESL  BSS    0
          JP     0
          SA5    VALESL            PICK UP LINE NO IN ERROR 
          PX5    B0,X5
          NX5    B6,X5             NORMALIZE
          EQ     BASEESL           EXIT 
* 
* 
 BATEESL  BSS    0
* 
* 
          DATA   10HBASEESM 
 BASEESM  BSS    0
          JP     0
          SA5    VALESM            PICK UP ERROR NO 
          PX5    B0,X5
          NX5    B6,X5             NORMALIZE
          EQ     BASEESM           EXIT 
* 
* 
 BATEESM  BSS    0
* 
          TITLE  BASENXL
* 
          DATA   10HBASENXL 
 BASENXL  BSS    0
* 
*                PURPOSE: TO PROVIDE THE LINE NUMBER OF THE NEXT
*                         STATEMENT IN SEQUENCE AFTER THE SPECIFIED 
*                         LINE NUMBER 
* 
* 
*                ENTRY: (X5)=SPECIFIED LINE NUMBER
* 
* 
*                EXIT:  (X5)=LINE NUMBER OF THE NEXT STATEMENT IN ORDER 
*                            (CONTAINS -1 IF NONE EXISTS) 
* 
* 
*                CALLS: FINDLBL,GETNXTL 
* 
          JP     0
          SA1    =XBASANSI
          ZR     X1,NXL2
          BX1    X1-X1
          PX1    X1 
          RX5    X5+X1       ROUND THE ARGUMENT 
 NXL2     BSS    0
          LBLCHK ER170       CHECK AND UNFLOAT THE LINE NUMBER
* 
          RJ     FINDLBL           FIND IT IN THE GENERATED CODE
          NG     X3,ER170    *ILLEGAL LABEL*
          SX1    X1+1              ADVANCE THE OBJECT CODE POINTER
* 
          RJ     GETNXTL           FIND THE NEXT LINE IN SEQUENCE 
          NG     X3,NONXTL         SKIP IF NONE THERE 
  
* THIS CODE WAS ADDED TO ENSURE THAT THE NXL FUNCTION DOES IN FACT
* RETURN THE NEXT LINE NUMBER AFTER THE NUMBER PASSED TO IT.
* IF IT IS THE SAME, THEN IT MUST BE RETURNING THE *SA0  LINNUM*
* INSTRUCTION THAT IS GENERATED AFTER A CALL TO A USER-DEFINED FUNCTION.
* THEREFORE, WE WILL CALL *GETNXTL* ONE MORE TIME TO GET THE REAL NEXT
* LINE NUMBER.
  
          IX5    X5-X3       CHECK IF THIS IS A REDUNDANT SA0 LINUM INST
          NZ     X5,PAKLBL   BR, THIS IS A NEW LINE NUMBER. 
  
* THE LINE NUMBER RETURNED WAS THE SAME AS THE LINE NUMBER PASSED IN GO 
* GET THE NEXT LINE NUMBER. 
  
          SX1    X1+1        ADVANCE THE OBJECT CODE POINTER
          RJ     GETNXTL     FIND THE REAL NEXT LINE NUMBER 
  
 PAKLBL   BSS    0
          PX3    B0,X3             FLOAT THE INTEGER (LABEL)
          NX5    B6,X3             NORMALIZE
          EQ     BASENXL           EXIT 
* 
 NONXTL   BSS    0
          MX3    59 
          EQ     PAKLBL 
* 
* 
 BATENXL  BSS    0
          TITLE  BASATTN - TERMINAL INTERRUPTS CONTROL
* 
          DATA   10HBASATTN 
 BASATTN  BSS    0
* 
          JP     0
          SA1    INTRFLG           FETCH INTERRUPT FLAG 
          NG     X1,ATTN           BR, PROCESS TERMINAL INTERRUPT 
* 
*         BASATTN - INITIALIZATION CALL 
* 
*  NOTE:  THE LOCATION FOLLOWING THE GENERATED CALL TO
*         BASATTN CONTAINS THE TARGET LABEL TRANSFER ADDRESS
*         SPECIFIED BY THE ASSOCIATED ON ATTENTION GOTO LN
* 
          SA1    DBUGON            GET CID MODE FLAG
          ZR     X1,ATCONT0  BR, CID NOT ACTIVE 
          SX6    ATNPROC            RECOVERY ADDRESS
          SA6    ATBLOCK+2
          SA1    ATLIST          FETCH DBUG.FN PARAM LIST 
          RJ     =YDBUG.FN         INITIALIZE DBUG.FN 
          EQ     ATCONT      BR, CONTINUE ATTN PROC 
* 
 ATCONT0  BSS    0
* 
*   ISSUE RPV CALL TO REPRIEVE FROM TERMINAL INTERRUPTS 
* 
*   RPV ERROR MASK = 237B 
* 
          SA1    RPVTI       FETCH RPV ERR MASK 
          SA2    RPVRSET     FETCH RPV SET-UP 
          BX6    X1 
          BX7    X2 
          SA7    RPVBLK      STORE SET-UP CALL
          SA6    RPVBLK+3    AND NEW ERR MASK 
          SA6    =XRPVMASK   SAVE FOR LATER USE IN BASEGEN
          SYSTEM   RPV,R,RPVBLK,1     ESTABLISH RPV CONDITIONS
 ATCONT   BSS    0
          SA1    BASATTN
          AX1    30                GET GENERATED CODE ADDRESS 
          SA1    X1                GET TARGET LBL TRANSFER ADDR 
          SB6    A1                SAVE FOR EXIT
          AX1    30                ISOSLATE TRANSFER ADDRESS
          MX7    42 
          BX7    -X7*X1 
          SA7    ONATNLB          SAVE TARGET LABEL ADDRESS 
          SX7    1
          SA7    UCNTRLA           SET USER CONTROL FLAG
          MX7    59 
          SA7    VALASL            RESET ATTN STMT LINE NO. 
          JP     B6+1              EXIT (SKIP OVER TARGET LBL TRANSFER) 
* 
 BATATTN  BSS    0
* 
*    CLEAR USER CONTROL OF TERMINAL INTERRUPTS
* 
          DATA   10HBASATNN 
 BASATNN  BSS    0
          JP     0
          SA1    DBUGON            CHECK FOR CID MODE 
          ZR     X1,CON01          BR, NOT IN CID MODE
          SX6    ATNPROC           CLEAR CID ATTN TRAP
          BX6    -X6
          SA6    ATBLOCK+2
          SA1    ATLIST            DBUG.FN APLIST 
          RJ     =YDBUG.FN
 CON01    BSS    0
          MX7    0
          SA7    UCNTRLA           CLEAR USER CONTROL FLAG
          SA7    INTRFLG           CLEAR INTERRUPT FLAG 
          MX7    1
          SA7    VALASL            RESET ATTN STMT LINE NO. 
          SA1    RPVBLK+3          FETCH RPV ERROR MASK 
          SA2    RPVRSET           GET RPV REQUEST SET-UP 
          MX3    1                 CLEAR RPV ERROR MASK 
          LX3    44                 FOR TERMINAL INTERRUPTS.
          BX6    -X3*X1 
          SA6    A1                RESTORE RPV ERROR MASK 
          SA6    =XRPVMASK         SAVE FOR LATER USE IN BASEGEN
          BX6    X2                SET RPV SET-UP REQUEST 
          SA6    RPVBLK 
          SYSTEM RPV,R,RPVBLK,1    ISSUE RPV CALL 
          EQ     BASATNN
* 
* 
 BATATNN  BSS    0
* 
* 
* 
*         ASL(X)
* 
          DATA   10HBASEASL 
 BASEASL  BSS    0
          JP     0
          SA5    VALASL            FETCH ON ATTN STMT LINE NO.
          PX5    B0,X5
          NX5    B6,X5
          EQ     BASEASL
* 
* 
 BATEASL  BSS    0
* 
* 
          END 
