*DECK,ERROR 
          IDENT     BASEGEN 
          TITLE  BASEGEN  (ERROR CONTROL) 
*CALL COPYRITE
          IPARAMS 
          COMMENT BASIC 3 - ERROR CONTROL.
          ENTRY     BASEGEN 
          ENTRY  BASEND.           CID MODE WRAPUP PROCEDURE
          ENTRY  ATNPROC,BASERR.   DBUG.FN RECOVERY PROCS 
          ENTRY  DBUGON            CID MODE FLAG
          ENTRY  ERBLOCK,ERLIST    DBUG.FN PARAM BLOCK
          ENTRY  ATBLOCK,ATLIST    DBUG.FN PARAM BLCK FOR T.I.
          ENTRY  RNBLOCK,RNLIST    CID MODE APLIST
          ENTRY  ER170
          ENTRY  DATAXXX,GOSUBXX
          ENTRY  BASEXIT
          ENTRY  STRFMT 
          EXT    RNDMWR 
          ENTRY  ER120,ER121,ER123
          ENTRY  ER125,ER137,ER141
          ENTRY  ER119,ER122,ER124
          ENTRY  ER126
          ENTRY  ER168,ER174,ER129
          ENTRY  PDWORD,DEFPD 
          ENTRY     BASRCHK 
          ENTRY  MEMUP
          EXT    BASOTAB
          EXT    BASOMOV
          EXT    BASOCON
          EXT    BASOCLS
          ENTRY  ININPRG
          ENTRY  ERRSTRT
          ENTRY  CODEND,CODSTRT 
          ENTRY  UCNTRLE
          ENTRY  ONERLBL
          ENTRY  VALESL,VALESM,VALEST,VALNXL
          ENTRY  DB.SW
          ENTRY  SAVEBR 
          ENTRY  PDSAVE 
          ENTRY  STRFMT 
          ENTRY  RPVMASK
          ENTRY  RPVBLK            RPV PARAMETER BLOCK
          ENTRY  INTRFLG           INTERRUPT FLAG 
          ENTRY  PRTFLG            CONNECTED PRINT FLAG 
          ENTRY  UCNTRLA           USER CONTROL OF T.I. FLAG
          ENTRY  ONATNLB          INTERRUPT TARGET LABEL
          ENTRY  VALASL            INTERRUPTED LINE NUMBER
          ENTRY  ATTN              INTERRUPT PROCESSOR
          ENTRY  RECOVER           RPV PROCESSOR
          ENTRY  DXMESS            DISPLAY EXECUTION TIME 
* 
          IFC    EQ,,"OS.NAME",KRONOS,
          SST 
          SYSCOM
          ELSE
 ACTR     EQU    64B
 LWPR     EQU    65B
          ENDIF 
*CALL,LCORE 
*CALL,LIPARAM 
* 
 SETA0    EQU    510B 
*         REFERENCES TO I/O-ROUTINES
* 
          EXT       BASOCHK 
          ENTRY  STRINP 
* 
          ENTRY  SETDGTS
          ENTRY  COMRUNS
 DEFPD    DATA   1LS
          ENTRY  ASCII             ASCII MODE SWITCH
          ENTRY  ASCMOD.           DEBUG ASCII MODE FLAG
          ENTRY  OLDFILE           OLD FILENAME FOR CHAIN 
          ENTRY  BASWRAP           WRAP UP - CLOSE ALL FILES
          ENTRY  BASATIM,BATATIM
          ENTRY  STIME
          ENTRY  ELAPTIM
* 
* 
* 
 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
* 
*         RPV PARAMETER BLOCK EQUATES 
* 
 FWA      EQU    0
 FWA01    EQU    FWA+1             TRANSFER ADDRESS 
 FWA02    EQU    FWA01+1           CHECKSUM 
 FWA03    EQU    FWA02+1           MASK/ERROR CLASS/ERROR CODE
 FWA04    EQU    FWA03+1           PENDING INTERRUPTS 
 FWA05    EQU    FWA04+1           PENDING RA+1 REQUEST 
 FWA06    EQU    FWA05+1           INTERRUPTED TERMINAL INPUT REQUEST 
 FWA07    EQU    FWA06+1           ERROR FLAG 
 FWA10    EQU    FWA07+1           RESERVED 
 FWA11    EQU    FWA10+1           FIRST WORD OF EXCHANGE PACKAGE 
* 
* 
*CALL,ERMNUM
* 
*         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* INDEFINITE OPERAND *
 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 *
 ERM119   DATA   C* COMPILATION ERROR * 
 ERM120   DATA   C* END OF DATA * 
 ERM121   DATA   C* SUBSCRIPT ERROR * 
 ERM122   DATA   C* ON EXPRESSION OUT OF RANGE *
 ERM123   DATA   C* GOSUB NEST TOO DEEP * 
 ERM124   DATA   C* RETURN BEFORE GOSUB * 
 ERM125   DATA   C* DIVISION BY ZERO *
 ERM126   DATA   C* BAD DATA IN READ *
 ERM129   DATA   C* UNSATISFIED EXTERNAL REFERENCE *
 ERM137   DATA   C* ILLEGAL INPUT ON FILE * 
 ERM141   DATA   C* FILE CLOSED/UNDEFINED * 
 ERM168   DATA   C* STRING OVERFLOW * 
 ERM170   DATA   C* ILLEGAL LABEL * 
 ERM174   DATA   C* RANDOM ACTION BEYOND EOF *
 ERM190   DATA   C* TERMINAL INTERRUPT *
 SETDGTS  DATA   40000000000000000006B
 DBUGON   DATA   0                 BASIC DEBUG ON FLAG
* 
* 
          IFC    EQ,,"OS.NAME",KRONOS,
          RJ     =XCPM=            FORCE CPM= INTO (0,0) OVL ALSO 
          ENDIF 
* 
          EJECT 
*         ENTRIES INTO ERROR-ROUTINE
* 
          DATA      10HBASEGEN
 BASEGEN  BSS       0                   GENERAL ERROR ENTRY 
          JP     GENPLUS
 GENPLUS  BSS    0
          SA1    BASEGEN     GET RETURN 
          SA2    INITGEN     LOAD THE PRESET BASEGEN LOCN 
          IX6    X2-X1       COMPARE TO CURRENT CONTENTS (LINK) 
          ZR     X6,ERRSTRT  IT WAS  NOT A -RJ- 
          BX6    X1 
          SA6    ERRORAD     SET RETURN ADDRESS 
          BX6    X2 
          SA6    A1          RESET BASEGEN ENTRY LOCATION 
          EQ     ERRST1      B2/B4 NEED NOT BE RESTORED 
* 
          DATA   5LER119
 ER119    BSS    0
          RTERROR ERMN119,ERM119,ERRSTRT   * COMPILATION ERROR *
* 
          DATA   5LER120
 ER120    BSS    0
          RTERROR ERMN120,ERM120,ERRSTRT   * END OF DATA *
* 
          DATA   5LER121
 ER121    BSS    0
          RTERROR ERMN121,ERM121,ERRSTRT   * SUBSCRIPT ERROR *
* 
          DATA   5LER122
 ER122    BSS    0
          RTERROR ERMN122,ERM122,ERRSTRT   *ON EXPRESSION OUT OF RANGE *
* 
          DATA   5LER123
 ER123    BSS    0
          RTERROR ERMN123,ERM123,ERRSTRT   *GOSUB NEST TO DEEP *
* 
          DATA   5LER124
 ER124    BSS    0
          RTERROR ERMN124,ERM124,ERRSTRT   *RETURN BEFORE GOSUB * 
* 
          DATA   5LER125
 ER125    BSS    0
          RTERROR ERMN125,ERM125,ERRSTRT   *DIVISION BY ZERO *
* 
          DATA   5LER129
 ER129    BSS    0
          RTERROR ERMN129,ERM129,ERRSTRT   *UNSATISFIED EXT REF * 
* 
          DATA   5LER137
 ER137    BSS    0
          RTERROR ERMN137,ERM137,ERRSTRT   *ILLEGAL INPUT ON FILE * 
* 
          DATA   5LER141
 ER141    BSS    0
          RTERROR ERMN141,ERM141,ERRSTRT   *FILE CLOSED/UNDEFINED * 
* 
          DATA   5LER168
 ER168    BSS    0
          RTERROR ERMN168,ERM168,ERRSTRT   *STRING OVERFLOW * 
* 
          DATA   5LER170
 ER170    BSS    0
          RTERROR ERMN170,ERM170,ERRSTRT   *ILLEGAL LABEL * 
* 
          DATA   5LER174
 ER174    BSS    0
          RTERROR ERMN174,ERM174,ERRSTRT   *RANDOM ACTION BEYOND EOF *
* 
          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
 ER126    BSS    0
          RTERROR ERMN126,ERM126,ERRSTRT   *BAD DATA IN READ *
* 
* 
*         MEMUP  INCREASES/DECREASES MEMORY 
*                USED BY BASCOMP AND BASSMMM
*         ENTRY  (X0) > 0, NUMBER OF WORDS TO INCREASE FL.
*                     = 0, REQUEST TO UPDATE *FIELDLG* TO CURRENT FL. 
*                     < 0, NUMBER OF WORDS TO DECREASE FL.
* 
*         EXIT   X0 = 0 IF REQUEST GRANTED
*                X0 = -1 IF FL COULDN'T BE EXTENDED BY ANY AMOUNT 
*                X0 = + VALUE IF FL COULDN'T BE EXTENDED BY REQUIRED AMO
*                         BUT COULD BE EXTENDED BY SOME SMALLER VALUE 
*                         FL = MAXFL IN THIS CASE 
*                FIELDLG = NEW FIELD LENGTH 
* 
* 
 MEMUP    DATA   0
          SA1    FIELDLG     X1 = CURRENT FL
          IX6    X0+X1       X6 = DESIRED NEW FL
          SX1    77B         ROUND OFF THE FL 
          IX6    X1+X6
          MX3    -6 
          BX6    X3*X6
          SX3    377777B     X3 - SYSTEM MAX FLD LEN
          IX3    X3-X6       X3 - SYSTEM MAX - DESIRED FL 
          NG     X3,MEMUP0   BR, DESIRED FL IMPOSSIBLE
          RJ     MEMUP2      TRY TO INCREASE FL 
          BX2    X0          GET REQUESTED INCREMENT FROM X0
          MX0    0           X0 = 0 TO SHOW REQUEST GRANTED 
          ZR     X2,MEMUP1   EXIT IF ONLY REQUESTED *FIELDLG* UPDATE. 
          NZ     X3,MEMUP1   EXIT IF FL CHANGED 
          NG     X2,MEMUP1   EXIT IF NO CHANGE,BUT NEG(MEM DOWN) REQUEST
                             (HAPPENS IF REDUCE,- IS IN EFFECT.)
 MEMUP0   BSS    0
          MX6    29          X6 = -1 IN TOP HALF
          LX6    30 
          RJ     MEMUP2      DETERMINE MAXIMUM FL 
          BX6    X1          X6 = MAX FL
          RJ     MEMUP2      ACQUIRE MAXIMUM FL 
          BX0    X3          X0 = MAX - OLD 
          NZ     X3,MEMUP1   FL INCREASED BY X0 AMMOUNT 
          MX0    59          X0 = -1 IF OLD FL WAS ALREADY MAX
 MEMUP1   BX6    X1 
          SA6    FIELDLG     SAVE NEW FL
          EQ     MEMUP
* 
 MEMUP2   DATA   0           ISSUE MEM REQUEST
          LX6    30 
          SA6    STAT 
          MEMORY CM,STAT,R,,NOABORT 
          SA1    STAT 
          AX1    30          X1 = NEW FL
          SA2    FIELDLG     X2 = OLD FL
          IX3    X1-X2       X3 = NEW - OLD 
          EQ     MEMUP2 
* 
 STAT     BSSZ   1           STATUS WORD FOR MEMORY MACRO 
          TITLE  MAIN ERROR CONTROL 
* 
*         MAIN CONTROL OF ERROR-ROUTINE 
* 
 ERRSTRT  BSS       0 
          SA1    SAVEBR 
          SA2    SAVEBR+1 
          SB2    X1                RESTORE B2/B4 IN CASE CLOBBERED
          SB4    X2 
 ERRST1   BSS    0
          SB6    B6-40B            CHECK FOR T.I. 
          ZR     B6,TICON          BR, PROCESS T.I. 
          SA1    SOFTERR           IF SECOND SOFTWARE DETECTED ERROR
          SX1    X1-2 
          PL   X1,SYSCNTRL         IGNORE ON ERROR AND TERMINATE
 UCERR    SA1    UCNTRLE
          ZR     X1,SYSCNTRL       SKIP IF BASIC SUBSYSTEM CONTROLS 
*                                  ERROR HANDLING 
* 
 ERRST2   SA1    RPVSETU           CLEAR COMPLETE BIT 
          BX6    X1                      AND
          SA6    RPVBLK            FUNCTION = SET UP
          SA1    RPVMASK           RESTORE ERROR MASK 
          BX6    X1 
          SA2    INTRFLG           FETCH T.I. FLAG
          ZR     X2,ERRST2A        BR IF NO T.I.
          MX6    1
          LX6    44                IF T.I. OCCURRED, CLEAR THE RPV
          BX6    -X6*X1             ERROR MASK FOR TERMINAL INTERRUPTS. 
 ERRST2A  BSS    0                 SET RPV ERROR MASK 
          SA6    RPVBLK+FWA03 
          SA6    RPVMASK           SAVE RPV ERROR MASK
          MX6    0
          SA6    RPVBLK+FWA04      CLEAR PENDING INTERRUPTS 
          SA6    RPVBLK+FWA05      CLEAR PENDING RA+1 REQUEST 
          SA6    RPVBLK+FWA06      CLEAR INTERRUPTED TERMINAL 
*                                  INPUT REQUEST
          SYSTEM RPV,R,RPVBLK,1    REINSTATE ERROR RECOVERY 
          MX6    0
          SA6    PRTFLG            CLEAR PRINT FLAG 
          SA1    INTRFLG           FETCH T.I. FLAG
          NG     X1,ATTN        BR, PROCESS T.I.
* 
 ERRST3   BSS    0
          SX6    B0 
          SA6    UCNTRLE           REVERT TO BASIC SUBSYSTEM ERR CONTROL
          SA6    ININPRG
          SA7    VALESM            DUMP ERROR MESSAGE NUMBER
          SX6    A0 
          SA6    VALESL            SAVE LINE NO IN ERROR
          MX6    0                 CLEAR RUNTIME ERROR NUMBER 
          SA6    RNBLOCK+1
          SA1    ENDITJP
          BX7    X1 
          SA7    ERRORAD           RESET PROGRAM EXIT TRANSFER
          SA1    ONERLBL           PICK UP TARGET LABEL 
          SB6    X1 
          SX7    B0 
          SA7    STRINP            RESET REAL/STRING FLAG 
          MX7    59 
          SA1    SAVEBR 
          SA2    SAVEBR+1 
          SB2    X1          RESTORE B2/B4 IN CASE CLOBBERED
          SB4    X2 
          JP     B6                EXIT TO PROCESS ERROR
 ATNPROC  BSS    0                 CID DBUG.FN T.I. PROCEDURE 
          SA1    SAVEBR 
          SA2    SAVEBR+1 
          SB2    X1                RESTORE B2/B4 IN CASE CLOBBERED
          SB4    X2 
          MX6    0
          SA6    ININPRG           CLEAR INPUT-IN-PROGRESS FLAG IN CASE SET 
          SX6    ATNPROC           CLEAR CID ATTN TRAP
          BX6    -X6
          SA6    ATBLOCK+2
          SA1    ATLIST 
          RJ     =YDBUG.FN         DO IT
          MX6    1                 SET T.I. FLAG
          SA6    INTRFLG
          JP     ATTN              BR, PROCESS T.I. 
* 
 ATBLOCK  DATA   2                 DBUG.FN FUNCTION CODE
          DATA   200B              RPV ERROR MASK = T.I.
          DATA   0                 RECOVERY ADDRESS 
          DATA   0                 RETURNED RPV ERROR CODE
* 
 BASERR.  BSS    0                 DBUG.FN ERROR RECOVERY PROCEDURE 
          SX6    BASERR.           CLEAR DBUG ERROR TRAP. 
          BX6    -X6
          SA6    ERBLOCK+2
          SA1    ERLIST            DO IT
          RJ     =YDBUG.FN
          SA1    RNBLOCK+1         CHECK FOR RUNTIME ERROR
          ZR     X1,ERPROC1        BR, NOT RUNTIME ERROR
          BX7    X1                GET RUNTIME ERROR NUMBER 
          JP     ERRST3            PROCESS RUNTIME ERROR
 ERPROC1  BSS    0
          SA1    ERBLOCK+3         GET RPV ERROR CODE 
          MX7    48 
          BX1    -X7*X1            EXTRACT ERROR CODE 
          JP     RER1              BR, PROCESS ERROR
* 
 ERBLOCK  DATA   2                 DBUG.FN FUNCTION CODE
          DATA   4037B             RPV ERROR MASK 
          DATA   0                 ^RECOVERY ADDRESS
          DATA   0                 RETURNED RPV ERROR CODE
* 
 RNLIST   VFD    42/0,18/RNBLOCK
          VFD    42/0,18/RNBLOCK+1
          VFD    42/0,18/RNBLOCK+2
* 
 RNBLOCK  DATA   1                 DBUG.FN RUN TIME ERROR FUNCTION CODE 
          DATA   0                 RUN TIME ERROR NUMBER
          DATA   0                  RUN TIME ERROR MESSAGE
* 
 ATLIST   VFD    42/0,18/ATBLOCK
          VFD    42/0,18/ATBLOCK+1
          VFD    42/0,18/ATBLOCK+2
          VFD    42/0,18/ATBLOCK+3
* 
 ERLIST   VFD    42/0,18/ERBLOCK
          VFD    42/0,18/ERBLOCK+1
          VFD    42/0,18/ERBLOCK+2
          VFD    42/0,18/ERBLOCK+3
* 
* 
*     PROCESS TERMINAL INTERRUPT
*     TERMINAL INTERRUPTS (T.I.) MAY BE HONORED IMMEDIATELY 
*     FOR CONNECTED FILE I/O(INTERACTIVE PRINT/INPUT) OR THEY 
*     MAY BE DEFERRED AND HONORED BETWEEN THE EXECUTION OF
*     BASIC PROGRAM STATEMENTS
* 
 TICON    BSS    0
          SA1    UCNTRLA           CHECK FOR USER CONTROL 
          NZ     X1,TICON0         BR, USER CONTROL 
          JP     UCERR             BR, CHK FOR ON ERROR CONTROL 
 TICON0   MX7    59 
          SA7    INTRFLG           SET T.I. FLAG
* 
*     CHECK FOR IMMEDIATE T.I. PROCESSING 
* 
          SA1    PRTFLG            CHK FOR CONNECTED PRINT
          PL     X1,TICONA         BR, NOT CONNECTED PRINT
*  CONNECTED PRINT INTERRUPT PROCESSOR
          SA1    B5+FETFRST        GET CIO BUFFER FIRST POINTER 
          SX6    X1 
          SA6    B5+FETIN          RESET CIO BUFFER IN POINTER
          SA6    B5+FETOUT         RESET CIO BUFFER OUT POINTER 
          JP     ERRST2            BR, IMMEDIATE PROCESSING OF CONNECTED
 TICONA   SA1    RPVBLK+FWA06      FETCH INTERRUPTED TERMINAL 
*                                  INPUT REQUEST
          ZR     X1,TICON1         BR, DEFERRED PROCESSING
          SB5    X1                B5 = FET ADDRESS 
          BX6    X6-X6
          SA6    ININPRG
          SA1    B5+FETSTAT        X1 = FILE STATUS 
          UX1    B6,X1             B6 = FILE MODE 
          LX1    59-18             INTERACTIVE FILE BIT 18
          PL     X1,TICON1         BR, NOT CONNECTED FILE I/O 
          SB7    READFUN           B7 = CODED READ FUNCTION 
          EQ     B6,B7,ERRST2      BR CODED READ
* 
*     DEFERRED T.I. PROCESSING
* 
 TICON1   BSS    0
          MX7    0
          SA7    RPVBLK+FWA05      CLEAR PENDING RA+1 REQUEST 
          SA1    RPVRSME
          BX7    X1 
          SA7    RPVBLK            FUNCTION = RPV RESUME
          SA1    RPVMASK           CLEAR ERROR CLASS/CODE 
          MX7    1
          LX7    44                CLEAR RPV ERROR MASK OF T.I. 
          BX7    -X7*X1             AND 
          SA7    RPVBLK+FWA03      RESET ERROR MASK 
          SA7    RPVMASK           SAVE RPV ERROR MASK
          MX7    0
          SA7    RPVBLK+FWA07      CLEAR ERROR FLAG 
* 
*  NOTE:  
*       BASIC ISSUES ITS OWN RA+1 REQUEST TO RESUME RPV TO
*       AVOID CLOBBERING SYS= ENTRY FOR THOSE TIMES WHEN A
*       TERMINAL INTERRUPT HAS BEEN RECIEVED WHILE SYS= WAS 
*       ACTIVE, SPECIFICALLY, A CIO WRITE REQUEST 
* 
          SX6    3RRPV             SET PPU NAME = RPV 
          PX6 
          LX6    42D               AUTO RECALL BIT 40 SET 
          SX2    1                 EXTENTED MODE RPV FLAG SET 
          LX2    18D
          IX6    X6+X2
          SX1    RPVBLK            RPV PARAMETER BLOCK ADDRESS
          BX6    X6+X1
          SA6    1                 ISSUE RA+1 REQUEST 
          SA1    1
          NZ     X1,*              LOOP UNTIL REQUEST PROCESSED 
* 
 SYSCNTRL BSS    0
          SX6       B7
          SX7       B5
          SA7       ESAVEB5             SAVE B5 FOR I/O-ROUTINES
          SA6       ERRTYPE 
          NG        B7,ERRST90
          ZR        B7,ERRST90
          SA2    COMRUNS
          SA1    EOPTION     COMPILE TIME 
          NZ     X2,SYSCNT1 
          SA1    KOPTION
* 
          IFC    EQ,,"OS.NAME",SCOPE ,
* 
          ENTRY  IMESFLG     INTERACTIVE INPUT ERR FLAG 
* 
          SA2    IMESFLG           IF INTERACTIVE INPUT ERROR 
          ZR     X2,ERR100            MESSAGES, SEND MESSAGES TO
          SX1    B5                   INTERACTIVE FILE RATHER 
          SX7    B0                   THAN K FILE 
          SA7    IMESFLG           CLEAR INTERACTIVE INPUT ERROR FLAG 
ERR100    BSS    0
          ENDIF 
 SYSCNT1  BSS    0
          SB5       X1                  GET CHANNEL 
         SA1       B5+FETSTAT           SET WRITE CODED 
         SB6       WRITFUN
         PX6       B6,X1
         SA6       A1 
          SA2       B5+FETCHAR          CHAR-POINTER
          ZR        X2,ERRST01
          SX4       -1
          RJ        BASOTAB             SET NEW LINE
 ERRST01  BSS       0 
          RJ        BASOCHK             MAKE ROOM FOR ERROR-MESSAGE 
          IFC    EQ,,"OS.NAME",KRONOS,
          SA1    B5+FETSTAT        CHECK FOR INTERACTIVE ON NOS 
          LX1    59-18
          NG     X1,ERRST02        IF SO, NO CC NEEDED
          ENDIF 
          SA2    KOPTION           IF ERROR IS TO OUTPUT
          SX2    X2                MOVE IN THE CC CHARACTER 
          SX1    B5 
          IX1    X1-X2
          NZ     X1,ERRST02 
          SA5    PRTBLNK
          BX6    X5 
          SA5    =XCC 
          SA6    A5 
          RJ     =XBASOMOV
          SX7    B0 
          SA7    B5+FETCHAR 
          SX7    1
          SA7    =XLBLKFLG
 ERRST02  SA1    ERRTYPE
          SA5       X1
          RJ        BASOMOV             MOVE MESSAGE
          SB6    A0 
          NG     B6,ERRST20  NO LINE NUMBER 
          SA5       ERRLINE 
          RJ        BASOMOV             MOVE   IN 
          SX3       A0
          PX4       X3,B0 
          NX5       X4,B6 
          SA4    SETDGTS
          BX7    X4                SAVE CURRENT VALUE 
          SA7    SAVDGTS
          SA4    SETDGTC           FORCE SETDGTS OFF
          BX7    X4                ( SO LINE NO CONVERSION IS 
          SA7    SETDGTS              CORRECTLY DONE )
          SA1    BASOCON     SAVE THE ENTRY POINT 
          BX7    X1          OF BASOCON IN CASE 
          SA7    SAVOCON     BASOCON CALLED BASEGEN 
          RJ        BASOCON             CONVERT LINE-NUMBER 
          SA1    SAVOCON     RESTORE THE ENTRY POINT
          BX7    X1 
          SA7    BASOCON
          SA5    X5          A5 = FWA OF STRING 
          SA1    SAVDGTS           RESTORE CURRENT
          BX7    X1 
          SA7    SETDGTS           SET DIGITS VALUE 
          RJ        BASOMOV             MOVE IT OUT 
 ERRST20  BSS    0
          SX4       -1                  NO WAIT 
          RJ        BASOTAB             END LINE
 ERRST90  BSS       0 
          SA1       ERRORAD             PREPARE EXITLINE
          SA2       ENDITJP 
          AX1    30 
          BX7       X2
          SB6    X1 
          SA7       A1                  RESET TO END-EXECUTION
          SA1       ESAVEB5 
          SB5       X1                  RESET B5
          JP     B6 
 PRTBLNK  DATA   1L 
 SAVOCON  DATA   0
          DATA   10HATTN
*         PROCESS TERMINAL INTERRUPT
* 
* 
 ATTN     BSS    0
          SA1    ONATNLB          GET CUR ACTIVE TARGET LBL ADDR
          SB6    X1                SAVE FOR LATER 
          MX7    0
          SA7    UCNTRLA           CLEAR USER CONTROL FLAG
          SA7    INTRFLG           CLEAR INTERRUPT FLAG 
          SX7    A0                GET NEXT STMT LINE NO. 
          SA7    VALASL            SET ATTN STMT LINE NO. 
          JP     B6                GOTO TARGET LABEL ADDRESS
* 
* 
 ATNN     BSS    0
* 
          EJECT 
* 
* 
 BASWRAP  DATA   0                 CLOSE ALL FILES
          SA1       B4                  START CHAIN 
          SB5    X1+B4         WAS USED 
          SA3     B5+FETSTAT
          LX3     59-18       CHECK IF INTERACTIVE FILE 
          MI      X3,ERRND02  IF SO, DONT PRINT OUT DEFAULT PD
          SX7     B4          SAVE VALUE OF B4
          SA7     SAVEB4
          IFC    EQ,,"OS.NAME",SCOPE ,
          SA2    ASCII
          ZR     X2,ERRND00 
          SX2    1
          BX6    X6+X2
          LX6    54 
 ERRND00  BSS    0
          ENDIF 
          SA1     B5+FETCHAR  CHECK IF BUFFER STILL CONTAINS UNWRITTEN
*                             INFORMATION 
          ZR      X1,PRNTPD   IF NOT, PRINT OUT DEFAULT PD. 
          SX4     -1          IF SO, SET FLAG TO CLOSE CURRENT LINE AND 
          RJ      BASOTAB     SET UP FOR NEW LINE. WRITE THE LINE.
 PRNTPD   SA5     DEFPD       PUT DEFAULT PD IN X5
          BX6     X5          SAVE DEFAULT PD 
          SA6     PDHOLD      MOVE DEFAULT PD TO HOLDING AREA FOR BAOMOV
          SA5     PDHOLD      POINT A5 TO STRING TO BE MOVED TO BUFFER. 
          RJ      BASOMOV     MOVE THE CONTENTS POINTED TO BY A5 TO THE 
*                             OUTPUT BUFFER. THE END OF THE STRING IS 
*                             DENOTED BY A ZERO WORD. 
          SA1     SAVEB4      PUT VALUE OF B4 BACK INTO A1
          SA1     X1          X1 NOW EQUAL TO CONTENTS OF ADDRESS IN B4 
 ERRND02  SB5       X1+B4 
         SA1     FETSETV+B5 
          LX1    1           CHECK IF SET OCCURRED
          NG     X1,RNDMCLO  SKIP IF FILE IS RANDOM 
          LX1    1
          NG     X1,APNDCLO  SKIP IF BUFFER MUST BE APPENDED
          SA1       B5+FETSTAT          GET STATUS-WORD 
          UX2       B6,X1 
          SB7       WRITFUN 
          LT        B6,B7,ERRND03       NOT WRITE-CHANNEL 
          NE        B6,B7,ERRND04       NOT CODED-WRITE 
          SA1    B5+FETCHAR        CHECK CURRENT LINE POSITION
          ZR     X1,ERRND04        SKIP IF ALREADY COMPLETE 
          SX4       -1
          RJ        BASOTAB             END LINE
 ERRND04  BSS       0 
          RJ        BASOCLS             CLOSE CHANNEL 
 ERRND03  BSS       0 
          SA1       B5+FETCHAN          NEXT OF CHAIN 
          SX1       X1
          PL        X1,ERRND02          NOT END OF CHAIN
          EQ   BASWRAP             RETURN 
* 
* 
 SAVEB4   BSS     1           STORAGE AREA FOR B4 
 PDHOLD   BSSZ    2           PRINT STRING USED BY BASOMOV
DXMESS    DATA   0                 DISPLAY EXECUTION TIME 
          SA1    STIME             START TIME 
          RJ     ELAPTIM           GET EXEC TIME IN DISPLAY CODE IN X6
          SA6    ETIMESS           STORE IN MESSAGE 
          IFNE   MESSAG,0 
          MESSAGE ETIMESS,0,R 
          ELSE
          MESSAGE ETIMESS,6,R 
          ENDIF 
          EQ     DXMESS 
* 
*   CONTROL REACHES HERE IF NO CONTINUATION 
* 
 ERRORND  BSS    0
          SA1    DBUGON            CHECK FOR CID MODE 
          ZR     X1,EXIT01         BR, NOT IN CID MODE
* 
          ENDRUN                   ISSUE ENDRUN TO CID
* 
*   BASEND. CALLED BY CID AFTER ENDRUN TO CLOSE ALL FILES 
* 
 BASEND.  DATA   0                 ENTRY/EXIT 
          SA1    SAVEBR            BASEND. RESTORES REGS B2/B4
          SA2    SAVEBR+1 
          SB2    X1                RESTORE B2 
          SB4    X2                RESTORE B4= START OF CONSTANTS 
          RJ     BASWRAP           CLOSE ALL OPENED FILES 
          RJ     DXMESS 
          EQ     BASEND.           EXIT BACK TO CID 
 EXIT01   BSS    0
* 
          RJ   BASWRAP             CLOSE ALL FILES
* 
          RJ     DXMESS            DISPLAY EXEC TIME
         SA1       ERRTYPE
          ZR     X1,ERRND01 
          NG     X1,BASEXIT        COMPILE ABORT
          MESSAGE BEEERR1,0,R 
 BASEXIT  BSS    0
          IFC    EQ,,"OS.NAME",KRONOS,
          ABORT 
          ELSE
          ABORT  ,ND
          ENDIF 
 ERRND01  BSS    0
          ENDRUN
* 
* 
 SAVDGTS  BSSZ   1                 SET DGTS VALUE DUMPED HERE 
 SETDGTC  DATA   40000000000000000006B       CONST SETTING
* 
ERRLINE  DATA      4L AT
 ENDITJP  EQ        ERRORND             CONSTANT FOR RE-SETTING 
 ERRORAD  EQ        ERRORND             PRESET EXIT-ADDRESS 
 ERRTYPE  BSSZ      1 
 ESAVEB5  BSSZ      1 
BEEERR1   DATA   21LBASIC EXECUTION ERROR 
 ETIMESS  DATA   C*   XXX.XXX CP SECONDS EXECUTION TIME*
* 
 INITGEN  JP     GENPLUS           REPLACEMENT (WHEN -RJ- DESTROYS
*                                  THE BASEGEN ENTRY LOCATION 
 MAXLN    DATA   99999.            MAXIMUM VALID LINE NO
 CODSTRT  BSSZ   1                 START ADDRESS FOR GEN CODE 
 CODEND   BSSZ   1                 END ADDRESS FOR GEN CODE 
 UCNTRLE  BSSZ   1                 1/0 AS USER DOES/DOESNT CONTROL ERRS 
 ONERLBL  BSSZ   1                 TARGET LABEL FOR ERROR PROCESSING
 VALESL   BSSZ   1                 LINE NO OF ERROR  (-1 INITIALLY) 
 VALESM   BSSZ   1                 ERROR MESSAGE NO (-1 INITIALLY)
 VALEST   BSSZ   1                 (NOT USED )
 VALNXL   BSSZ   1                 LINE NO SUCCEEDING ERR LINE (-1 INIT)
 PRTFLG        BSSZ   1             INTERRUPT PROCESSOR PRINT FLAG
 UCNTRLA       BSSZ   1                 USER CONTROL OF T.I. FLAG 
          DATA   10HINTRFLG 
 INTRFLG       BSSZ   1                 T.I. HAS OCCURED FLAG 
 ONATNLB      BSSZ   1                 TARGET LBL FOR T.I. PROCESSING 
 VALASL        BSSZ   1                 ATTN STMT LINE NO (ASL FUNCTION)
 RPVSETU  BSS    0
          VFD 36/0,12/31B,11/1,1/0  RPV SETUP 
 RPVRSME  BSS    0
          VFD 36/0,12/31B,11/2,1/0  RPV RESUME
 RPVMASK  BSS    0
          VFD    24/37B,24/0,12/0  RPV ERROR MASK 
 STRINP   DATA   0
 COMRUNS  BSSZ   1                 NONZERO AT COMPILE TIME
 ASCMOD.  BSS    0
 ASCII    BSSZ   1           NONZERO IF IN ASCII MODE 
 OLDFILE  DATA   0                 CONTAINS SOURCE FILENAME IF COMPILE
*                                   AND EXEC IN CM MODE 
 DB.SW    BSS    1           DEBUG SWITCH, B59 ON=TRACE 
 SAVEBR   BSS    2                 SAVE B2/B4 HERE
 PDSAVE   DATA   0                 SAVE PDOPTION FROM GEN CODE
          DATA   10HDATAXXX        NAME FOR RELOC GEN 
 DATAXXX  BSS    2           DATA BLOCK POINTERS FORMERLY B1. 
          DATA   10HGOSUBXX        NAME FOR RELOC GEN 
 GOSUBXX  BSS    1                 GOSUB STACK POINTER (FORMERLY B3)
 PDWORD   DATA   0
 STRFMT   BSS    1                 NONE ZERO FOR STR$ CALL
 IMESFLG  DATA   0
 ININPRG  DATA   0           INPUT IN PROGRESS FLAG 
* 
*         END ERROR-ROUTINE 
* 
* 
* 
 APNDCLO  BSS    0
  
          SA1    FETSTAT+B5 
          SB7    WRITFUN
          UX1    X1,B6
          NE     B6,B7,NOTBCDW     SKIP IF NOT
  
          MX4    59 
  
          RJ     BASOTAB     COMPLETE THE (BCD) LINE
  
 NOTBCDW  BSS    0
          SA1    FETOUT+B5
          LX1    18 
          SA2    FETIN+B5 
          IX1    X1+X2       ADJOIN IN AND OUT
  
          SA2    FETROI+B5
          MX0    60-36
          BX6    X0*X2       DROP OLD -IN- AND -OUT-
          IX6    X6+X1       INSERT -IN- AND -OUT- FROM READ
          SA6    A2          TO FET 
  
          SB7    1
  
          RJ     RNDMWR      APPEND THE BUFFER (WITH AN EOR)
  
          EQ     ERRND04     REJOIN -END- PROCESSING
  
  
  
  
 RNDMCLO  BSS    0
          SA1    FETROI+B5         CHECK IF BUFFER HAS BEEN ALTERED 
          PL     X1,ERRND03        IF NOT REJOIN END SEQUENCE 
          SB7    B0 
          SA1    B5 
          LX1    59-4              TEST IF EOR/EOF MET ON THE LAST READ 
          PL     X1,FINWR          SKIP IF NOT
          SB7    1                 SPECIFY WRITER (WRITE WITH EOR)
  
 FINWR    BSS    0
          RJ     RNDMWR            REWRITE THE BUFFER 
          EQ     ERRND03           REJOIN END SEQUENCE
          TITLE  ELAPTIM - COMPUTE ELAPSED CP TIME
          EXT    OBUFLCL
          EXT    NUMFLG 
* 
* 
* 
 ELAPTIM  DATA   0
*  INPUT IS START CP TIME F.P. IN X1
*  FIND ELAPSED CP TIME, CONVERT TO DISPLAY CODE IN X6
          BX6    X1                SAVE START TIME
          SA6    STIME
          RJ   BASATIM             GET CURRENT CP TIME IN X5
          SA1    STIME
          BX6    X5-X1                                                   BAS0014
          NZ   X6,ELAP7            JUMP IF ELAPSED NOT ZERO              BAS0014
          SA1    MINTIME           MINIMUM IS .001 SEC                   BAS0014
          FX5    X1+X1             .002 TO GET .001 AFTER SUBTRACTION    BAS0014
 ELAP7    BSS    0                                                       BAS0014
          FX5    X5-X1             ELAPSED
* 
*         TEST IF MAGNITUDE OF ELAPSED TIME IS
*         EQUAL OR GREATER THAN 1000000. IF SO
*         INSERT MSG - GTR 999999 AS TIME AND 
*         GO TO EXIT OF PREPARATION OF TIME 
*         MESSAGE.
          SA3 K999999        X3 - FP CONSTANT = 999999
          IX1 X5-X3          X1 DIFF ELAP TIME - 999999 
          NG X1,UNDERLIM     BRANCH IF TIME UNDER 999999 SECS 
          JP GTRMSG         BRANCH TO PREPARE GTR 999999 MESSAGE
 K999999  DATA 999999.
* 
*         FORCE SETDIGITS TO = 6 SO THAT ELAPSED TIME 
*         RETURNED BY BASOCON WILL NOT EXCEED 6 DIGITS. 
*         THIS LIMIT TO 6 DIGITS OF PRECISION 
*         IMPLIES THAT A TIME SUCH AS 12345.600 
*         CP SECONDS IS ACCURATE TO TENTH OF SEC. 
 UNDERLIM SA1 SETDGTS        X1 - GET CURRENT SETDIGITS 
          BX7 X1             X7 - MOVE CURRENT SETDIGITS TO OUT REG X7
          SA7 SAVDGTS        STORE CURRENT SETDIGITS  IN TEMP 
          SA1 SETDGTC        X1 - GET SETDIGITS = 6 
          BX7 X1             X7 - MOVE SETDIGITS = 6 TO X7
          SA7 SETDGTS        X7 - STORE SETDIGITS = 6 IN CURRENT
          RJ   BASOCON             CONVERT TO DISPLAY IN X5 
          SA5    X5          A5 = FWA OF STRING 
          MX7    0           X7 SET TO FALSE
          SA7    NUMFLG      NUMFLG SET TO FALSE - SEE COMMENT BELOW
*         NUMFLG IS EXTERNALIZED SO THAT ELAPTIM CAN TURN IT OFF
*         FOR THE CASE WHEN A CALL IS MADE BY ELAPTIM (IN BASEGEN)
*         TO BASOCON (IN BASOGEN) TO DEVELOP NUMERIC STRING 
*         OF ELAPSED TIME. BASOCON SETS NUMFLG ON ASSUMPTION THAT 
*         EVERY CALL TO BASOCON WILL BE FOLLOWED BY A CALL TO 
*         BASOMOV TO MOVE THE CONVERTED STRING TO AN OUTPUT BUFFER. 
*         (BASOMOV TURNS OFF NUMFLG.) 
*         IN THE CASE OF ELAPTIM, HOWEVER, THE CONVERTED STRING IS
*         SUBSEQUENTLY OUTPUTTED BY BASCOMP TO THE DAYFILE USING
*         A MESSG MACRO, THEREBY BYPASSING A SUBSEQUENT CALL TO BASOMOV.
*         IF ELAPTIM DOES NOT TURN THE NUMFLG OFF AFTER A CALL TO 
*         BASOCON, THEN AN ERROR CAN ARISE IF THE NEXT CALL TO BASOMOV
*         IS MADE WITHOUT A PRECEDING CALL TO BASOCON BECAUSE BASOMOV 
*         WILL SEE THE NUMFLG STILL ON ALTHOUGH IN FACT BASOMOV MAY HAVE
*         BEEN CALLED TO OUTPUT AN ASCII NON NUMERIC STRING, FOR EXAMPLE
*         RESTORE SETDIGITS TO VALUE THAT EXISTED BEFORE CALL 
*         TO BASOCON
          SA1 SAVDGTS        X1 - GET SETDIGITS FROM TEMP 
          BX7 X1             X7 - MOVE SAVED SETDIGITS TO OUT REG X7
          SA7 SETDGTS        STORE SAVED SETDIGITS IN CURRENT 
* 
***       FINDFMT 
*         (SEE DOCUMENTATION IN BASOCON FOR DESCRIPTION OF POSSIBLE 
*         FORMATS OF NUMBER RETURNED BY BASOCON)
*         THIS ROUTINE DETERMINES IF THE CONVERTED NUMBER RETURNED BY 
*         BASOCON IS IN EXPONENTIAL OR NON-EXPONENTIAL FORMAT BY
*         SCANNING FOR A DELIMITER BLANK OR E CHARACTER IN THE
*         FIRST WORD OF THE RETURNED NUMBER.  A DELIMITER BLANK 
*         OR E FOLLOWS NUMBER IN THE FIRST WORD WHEN SETDIGITS
*         = 6 AS IS THE CASE HERE.
* 
*         ON ENTRY           X5 - IMAGE OF FIRST WORD OF NUMBER 
* 
*         ON EXIT            B3 - POSN NUMBER E OR BLANK WAS FOUND IN 
*                            X5 - IMAGE OF FIRST WORD OF NUMBER UNCHANGE
* 
*----- ---POSITIONS OF WORD NUMBERED 0-9 LEFT TO RIGHT----- 
* 
*         INITIALIZE REGS 
          SB3 2              B3 = ORIGINAL POSN NUMBER OF CURRENT TEST
          SB4 8              B4 = NUMBER OF LAST POSITION TO BE TESTED
          MX0 54             X0 - LEFT 9 CHARACTER MASK 
          SX1 1R             X1 - DISPLAY BLANK CHARACTER 
          BX6 X5             X6 = MOVE NUMBER TO WORKING REG X6 
          SX3 1RE            X3 - DISPLAY E CHARACTER 
* 
*         POSITION 2 IS THE FIRST POSITION TO BE INSPECTED. WE SHIFT
*         IT TO LOW ORDER OF REG FOR TESTING. 
          LX6 18             X6 - NUMBER,SHIFTED
* 
*         EXTRACT CHARACTER AND TEST IF BLANK OR E
 EXTRLUP  BX4 -X0*X6         X4 = EXTRACTED CHARACTER 
          IX7 X4-X1          X7 - DIFF EXTRACTED CHAR - BLANK 
          ZR X7,HITBLNK      BRANCH IF EXTRACTED CHAR WAS BLANK 
          IX7 X4-X3          X6 - DIFF EXTRACTED CHAR - DISPLAY E 
          ZR X7,HITE         BRANCH IF EXTRACTED CHAR WAS DISPLAY E 
          EQ B3,B4,NOHIT     BRANCH NO BLANK OR E 3-8 INCL (ERROR)
          SB3 B3+1           B3 = INCREMENTED POSITION NUMBER 
          LX6 6              X6 - NUMBER,NEXT TEST POSITION IN LOW ORDER
          JP EXTRLUP         LOOP BACK TO TEST NEXT CHAR
***       THIS IS END OF FINDFMT
* 
***       HITBLNK 
*         WE ARE HERE BECAUSE NUMBER IS NON-EXPONENTIAL FORMAT
***       POSNDEC 
*         THIS ROUTINE SHIFTS THE NUMBER IN X5 SO THAT DECIMAL POINT
*         IS LOCATED IN POSITION 6
*         IT ASSUMES POSSIBLE LOCATIONS OF DECIMAL POINT IN THE ORIGINAL
*         NUMBER IN X5 ARE 1-7 INCL (ASSUME SETDGTS WAS = 6). 
*         IT IS POSSIBLE THAT THE NUMBER RETURNED 
*         BY BASOCON WILL NOT CONTAIN A DECIMAL POINT.
*         THIS HAPPENS IF THE ORIGINAL NUMBER INPUTTED
*         TO BASOCON IS ACTUALLY INTEGER VALUE. 
*         IF WE DISCOVER THERE IS NOT A DECIMAL POINT,
*         THE TRAILING DELIMITER SPACE IS OVERLAYED 
*         WITH DECIMAL PT FOLLOWED BY SPACE, TO MAKE
*         IT CONFORM TO THE NON-EXPONENTIAL DECIMAL 
*         POINT TYPE OF FORMAT. 
* 
*         ON ENTRY           X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK IN LOW ORDER
*                            X5 - IMAGE OF FIRST WORD OF NUMBER UNCHANGE
*                            X6 - NUMBER,TRLG BLANK IN LOW ORDER
*                            B3 - POSN NUMBER THAT CONTAINED TRLG BLANK 
* 
*         ON EXIT            X5 - ORIGINAL NUMBER LEFT CIRC SHIFTED 
*                            SO DEC PT IN POSN 6
*                            X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK IN LOW ORDER
* 
*         THE FIRST POSITION TO BE TESTED FOR DECIMAL POINT IS THE
*         POSITION IMMEDIATELY TO LEFT OF THE TRAILING BLANK. 
* 
*         MOVE SHIFTED NUMBER IN X6 TO X5 AND 
*         SHIFT FIRST POSITION TO BE TESTED TO LOW ORDER OF X5. 
 HITBLNK  BX5 X6             X5 - NUMBER, TRLG BLNK IN LOW ORDER
*         CONTROL CAN BE PASSED TO FOLLOWING LABEL
*         FROM HITE ROUTINE, IN WHICH CASE X6 
*         CONTENTS HAVE NOT BEEN SET UP AND SHOULD
*         NOT BE REQUIRED.
 FRMHITE  LX5 54             X5 - NUMBER, FIRST TEST POSN IN LOW ORDER
* 
*         INITIALIZE TESTING LOOP 
          SB7 B3-2           B7 - NUMBER OF POSNS TO TEST - 1 
          SX2 1R.            X2 - DISPLAY DECIMAL POINT CHAR
* 
*         NOW LOOP THRU TO FIND DECIMAL POINT IN NUMBER 
 FINDLUP  BX3 -X0*X5          X3 - EXTRACTED CHARACTER FROM LOW ORDER 
          IX3 X3-X2          X3 - DIFF EXTRACTED - DECIMAL POINT
          ZR X3,SHFTTO6      BRANCH IF DECIMAL FOUND
          EQ B0,B7,NODECPT   BRANCH ALL LEGIT POSNS TESTED
          LX5 54             X5 - NUMBER, NEXT TEST POSITION IN LOW ORDE
          SB7 B7-1           B7 - DECREMENTED LOOP COUNTER
          JP FINDLUP         LOOP BACK TO TEST NEXT CHARACTER 
* 
*         NODECPT 
*         HERE BECAUSE NO DEC PT IN NUMBER
*         THE OBJECTIVE HERE IS TO SET X5 TO CONTENTS 
*         OF X6 (NUMBER,TRAILING BLANK IN LOW ORDER)
*         THEN REPLACE THE TRAILG BLANK WITH
*         A DECIMAL POINT AND INSERT A TRAILING BLANK 
*         FOLLOWING THE DECIMAL POINT. WE THEN SHIFT
*         THE DECIMAL POINT JUST INSERTED BACK INTO LOW 
*         ORDER AND JUMP TO NORMAL DECIMAL FOUND
*         PROCESSING. 
* 
*         ON ENTRY           X5 - NUMBER, POSITION 2 IN LOW ORDER 
*                            X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK IN LOW ORDER
*                            X2 - DISPLAY DEC PT CHAR IN LOW ORDER
*                            X6 - NUMBER, TRAILG BLANK IN LOW ORDER 
* 
*         ON EXIT            X5 - NUMBER, DECPT IN POSN 6 
*                            X0,1 - UNCHANGED 
* 
 NODECPT  BX5 X6             X5 - NUMBER, TRAILG BLANK IN LOW ORDER 
          BX5 X0*X5          X5 - NUMBER, TRLG BLANK SET TO BINRY ZEROS 
          IX5 X5+X2          X5 - NUMBER, INSERTED DECPT IN LOW ORDER 
          LX5 6              X5 - NUMBER, POSN AFTER DECPT IN LOW ORDER 
          BX5 X0*X5          X5 - NUMBER, POSN AFTER SET TO BINRY ZEROES
          IX5 X5+X1          X5 - NUMBER,INSERTED BLNK IN LOW ORDER 
          LX5 54             X5 - NUMBER DECPT IN LOW ORDER 
*         FALL THRU TO POSITION DEC IN POSN 6 
* 
* 
 SHFTTO6  LX5 18             X5 - NUMBER, DECIMAL POINT IN POSN 6 
***       THIS IS END OF POSNDEC
* 
***       RTZRFILL
*         THIS ROUTINE TESTS POSITIONS 7,8,9 IN SUCCESSION LOOKING
*         FOR A BLANK CHARACTER.  IF ONE FOUND,THE FOUND POSITION 
*         AND FOLLOWING POSITIONS THRU POSITION 9 ARE REPLACED WITH 
*         DISPLAY ZERO CHARS. 
* 
*         ON ENTRY           X5 - NUMBER,DECIMAL POINT IN POSN 6
*                            X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK IN LOW ORDER
* 
*         ON EXIT            X5 - NUMBER, DECIMAL POINT IN POSN 6, POSNS
*                            RIGHT OF DECIMAL ARE ZERO FILLED IF NEC. 
* 
*         INITIALIZE
          SB2 2              B2 - DESCENDING LOOP COUNTER 2,1,0 
          SX6 1R0            X6 - DISPLAY ZERO CHARACTER
          LX5 48             X5 - NUMBER, POSN 7 SHIFTED TO LOW ORDER 
* 
*         EXTRACT CHAR, TEST,LOOP UNTIL BLANK FOUND OR NONE.
 RZFLUP   BX3 -X0*X5         X3 - EXTRACTED CHAR IN LOW ORDER 
          IX3 X3-X1          X3 - DIFF EXTRACTED - DISPLAY BLANK
          ZR X3,RTZFND       BRANCH IF BLANK CHAR FOUND 
          EQ B0,B2,LSPFILL   BRANCH IF POSN 7-9 INCL BEEN TESTED
          SB2 B2-1           B2 - DECREMENTED LOOP COUNTER
          LX5 6              X5 - NUMBER, NEXT TEST POSITION IN LOW ORDE
          JP RZFLUP          LOOP BACK TO TEST NEXT CHAR
* 
*         RTZFND
*         HERE IF BLANK FOUND IN POS 7-9
*         INSERT DISPLAY ZERO IN POSITION IN WHICH BLANK FOUND
*         AND LOOP TO INSERT DISPLAY ZERO IN ALL SUCCEEDING POSNS 
* 
* 
*         ON ENTRY           X5 - NUMBER, DECIMAL POINT IN POSN 6 
*                            X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK CHARACTER 
*                            X6 - DISPLAY ZERO IN LOW ORDER 
*                            B2 - POSN NO. RT OF DEC HOLDING BLNK 
* 
*         ON EXIT            X5 - NUMBER, DEC PT IN POSN 6 RT ZERO FILLE
*                            X0,X1 UNCHANGED
* 
 RTZFND   BX4 X0*X5          X4 EXTRACTED POSNS 0-8 OF NUMBER 
          IX5 X4+X6          X5 - NUMBER,DISPLAY ZERO INSERTED IN LOW OR
          EQ B0,B2,LSPFILL   BRANCH IF POSITIONS 7 THRU 9 TESTED
          SB2 B2-1           B2 - DECREMENTED LOOP COUNTER
          LX5 6              X5 - NUMBER, NEXT TEST POSITION IN LOW ORDE
          JP RTZFND          LOOP BACK TO TEST NEXT CHAR
* 
***       THIS IS END OF RTZFILL
* 
***       LSPFILL 
*         THIS ROUTINE TESTS POSITIONS 5 THRU 0 IN SUCCESSION LOOKING 
*         FOR A BLANK CHARACTER. IF BLANK FOUND 
*         ALL POSITIONS PRECEEDING ARE SET TO BLANK.  IT IS CORRECTLY 
*         POSSIBLE THAT A BLANK WILL NOT BE FOUND (FOR EXAMPLE, THE 
*         NUMBER 123456.000 MAY BE PRESENT). THE MINIMUM NUMBER THAT
*         MAY BE PRESENT IS GGGGGB.001 WHERE G = GARBAGE AND B = BLANK. 
* 
*         ON ENTRY           X5 - NUMBER, DECIMAL POINT IN POSN 6 
*                            X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK IN LOW ORDER
* 
*         ON EXIT            X5 - NUMBER, BLANK FILLED TO LEFT OF DECPT 
*                            IF NECESSARY.  DEC PT IN POSN 6. 
*                            X0,X1 - UNCHANGED
* 
*         INITIALIZE
 LSPFILL  SB2 5              B2 - DESCENDING LOOP COUNTER 5,4,..0 
          LX5 36             X5 - NUMBER, POSITION 5 SHIFTED TO LOW ORDE
* 
*         EXTRACT POSITIONS 5-0 IN SUCCESSION, TEST FOR BLANK 
 LSFLUP   BX2 -X0*X5         X2 - EXTRACTED CHARACTER FROM LOW ORDER
          IX2 X2-X1          X2 - DIFF EXTRACTED CHARACTER - BLANK
          ZR X2,LSPFND       BRANCH IF A  BLANK FOUND 
          EQ B0,B2,LSPDONE   BRANCH IF NO MORE POSNS TO TEST
          SB2 B2-1           B2 - DECREMENTED LOOP COUNTER
          LX5 54             X5 - NUMBER, NEXT TEST POSN IN LOW ORDER 
          JP LSFLUP          LOOP BACK TO TEST NEXT CHAR
* 
 LSPDONE  LX5 54             X5 - NUMBER,DECPT IN POSN 6
          JP ELAP6
* 
***       LSPFND
*         WE ARE HERE BECAUSE BLANK WAS FOUND TO LEFT OF DECPT
* 
*         INSERT BLANKS IN FOUND POSITION AND ALL PRECEDING 
 LSPFND   BX3 X0*X5          X3 - EXTRACTED POSNS 0-8 OF NUMBER 
          IX5 X3+X1          X5 - NUMBER, BLANK INSERTED IN LOW ORDER 
          EQ B0,B2,LSPDONE   BRANCH IF ALL PRECEDING POSNS BLANKED
          SB2 B2-1           B2 - DECREMENTED LOOP COUNTER
          LX5 54             X5 - NUMBER, NEXT TEST POSITION IN LOW ORDE
          JP LSPFND          LOOP BACK TO TEST NEXT POSITION
*         THIS IS THE END OF LSPFILL
*         THIS IS END OF HITBLNK
* 
* 
***       HITE
*         WE ARE HERE BECAUSE NUMBER RETURNED BY BASOCON
*         WAS IN EXPONENTIAL FORMAT.
*         THE OVERALL OBJECTIVE OF ALL PROCESSING WITHIN ROUTINE HITE 
*         IS TO ELIMINATE THE EXPONENTIAL NOTATION FROM THE NUMBER
*         RETURNED BY BASOCON.
*         NUMBERS WITH A POSITIVE EXPONENT SHOULD 
*         NOT OCCUR HERE.  NUMBERS WITH A POSITIVE
*         EXPONENT OF 6 OR GREATER ARE DETECTED 
*         BY THE TEST FOR NUMBERS HAVING A MAGNITUDE
*         THE NEED FOR POSITIVE EXPONENTS IN THE
*         RANGE OF 0-5 INCLUSIVE BY SHIFTING THE
*         SHIFT THE DECIMAL POINT LEFT,INSERT ZEROES AND
*         TRUNCATE AS APPROPRIATE.
*         DECIMAL POINT RIGHT AND RETURNING 
*         THE NUMBER IN NON-EXPONENTIAL FORMAT. 
*         FOR NUMBERS HAVING A NEGATIVE EXPONENT, WE
*         NUMBERS HAVING A NEGATIVE EXPONENT SUCH AS 1.90000E-3 OR
*         1.00001E-3 ARE TRUNCATED WITHOUT ROUNDING AND 
*         A MAGNITUDE OF .001 IS THE RESULT.
*         THIS LOGIC ASSUMES THAT A NUMBER WILL NOT HAVE A NEGATIVE 
*         EXPONENT DIGIT GREATER THAN 3 BECAUSE THAT IMPLIES THAT 
*         THE MAGNITUDE OF THE NUMBER IS LESS THAN .001 WHICH IS
*         IMPOSSIBLE DUE TO EARLIER CODE IN ELAPTIM.
* 
*         UPON EXIT FROM HITE PROCESSING, THE RESULTING NON-EXPONENTIAL 
*         NUMBER WILL BE PROCESSED AS IF IT WERE A NON-EXPONENTIAL
*         NUMBER RETURNED BY BASOCON. 
* 
* 
*         ON ENTRY           X5 - IMAGE OF FIRST WORD OF EXPONENTIAL NUM
*                            FORMAT IS BN.NNNNNES WHERE B=BLANK,N=DIGIT,
*         OF 999999 OR MORE BEFORE THE CALL 
*         TO BASOCON.  BASOCON ELIMINATES 
*                            E=E,S=-
*                            X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK IN LOW ORDER
* 
*         ON EXIT            X5 - UNCHANGED 
*                            X0,X1 - UNCHANGED
* 
*         NOTE -  SIGN OF EXPONENT ASSUMED MINUS
*         THE SECOND WORD OF A NUMBER IN EXPONENTIAL FORMAT IS
*         LOCATED IN OBUFLCL+1.  AS DISCUSSED ABOVE, WE 
*         EXPECT NEGATIVE EXPONENT TO HAVE ONE DIGIT AND THE
*         DIGIT TO BE 1,2 OR 3.  THE FORMAT OF THE 2ND WORD 
*         IN THIS CASE IS NBZZZZZZZZ WHERE N IS THE EXPONENT
*         DIGIT,B=BLANK,Z=BINARY ZEROES.
* 
*         FETCH 2ND WORD OF NUMBER, 
*         SHIFT EXPONENT DIGIT TO LOW ORDER ,EXTRACT , TEST 
*         IF 1,2,3 AND BRANCH.
 HITE     SA3 OBUFLCL+1      X3 - 2ND WORD OF NUMBER
          LX3 6              X3 - 2ND WORD, EXPONENT DIGIT IN LOW ORDER 
          BX7 -X0*X3         X7 - EXTRACTED EXPONENT DIGIT
          SX6 1R3            X6 - DISPLAY DIGIT 3 
          IX6 X7-X6          X6 - DIFF EXTRACTED DIGIT - DISPLAY DIGIT 3
          ZR X6,FNDDSP3      BRANCH IF EXPONENT DIGIT 3 FOUND 
          SX6 1R2            X6 - DISPLAY DIGIT 2 
          IX6 X7-X6          X6 - DIFF EXPONENT DIGIT - DISPLAY DIGIT 2 
          ZR X6,FNDDSP2      BRANCH IF EXPONENT DIGIT 2 FOUND 
* 
*         FALL THRU ASSUMES EXPONENT DIGIT IS 1 
* 
*         SET UP APPROPRIATE CONSTANT IN X2 FOR 
*         USE BY LEFT SHIFT DECIMAL LOGIC LATER 
* 
*FNDDSP1  THIS IS PHONY LABEL FOR DOCUMENTATION 
          SA2 KSHFDEC1       X2 - CONSTANT ZZZZBZZB.Z FOR E-1 
          JP LFSHFDEC       BRANCH TO EFFECTIVELY SHIFT DEC LEFT 1
 FNDDSP2  SA2 KSHFDEC2      X2 - CONSTANT ZZZZBZB.0Z FOR E-2
          JP LFSHFDEC        BRANCH TO EFFECTIVELY SHIFT DEC LEFT 2 
 FNDDSP3  SA2 KSHFDEC3       X2 - CONSTANT ZZZZBB.00Z FOR E-3 
*         FALL THRU TO EFFECTIVELY SHIFT DEC LEFT 3 
* 
***       LFSHFDEC
*         UPON ENTRY X5 CONTAINS THE FIRST WORD OF NUMBER 
*         POSITIONED AS BN.NNNNNES.  THE OBJECTIVE HERE IS TO 
*         INSERT THE INTEGER DIGIT OF THE NUMBER INTO THE 
*         CONSTANT PREVIOUSLY SET UP IN X2. THE 
*         RESULTING 6 CHARACTER CONSTANT IS INSERTED INTO THE 
*         FRONT OF THE NUMBER IN X5, OVERLAYING THE DECIMAL 
*         POINT AND POSITIONS LEFTWARD CIRCULAR.
*                            X0 - LEFT 9 CHARACTER MASK 
*                            X1 - DISPLAY BLANK IN LOW ORDER
* 
*         UPON EXIT - X5 CONTAINS NUMBER,DECIMAL POINT
*         SHIFTED LEFT AND IN ONE OF THE FOLLOWING FORMATS
*         DEPENDING ON WHAT THE ORIGINAL EXPONENT VALUE WAS.
*         ZZB.NNNNNB (WAS E-1)
*         ZB.0NNNNNB (WAS E-2)
*         B.00NNNNNB (WAS E-3)
*         WHERE B=BLANK,Z=BINARY ZEROES,N=DIGIT OF ORIGINAL NUMBER
*         AND 0 IS FORCED IN DISPLAY ZERO CHARACTER 
*         X0,X1 - UNCHANGED 
*         B3 - NUMBER OF POSN THAT CONTAINS TRLG BLANK
* 
*         EXTRACT INTEGER DIGIT AND INSERT INTO CONSTANT
 LFSHFDEC LX5 12             X5 - NUMBER,INTEGER DIGIT IN LOW ORDER = .N
          BX3 -X0*X5         X3 - EXTRACTED INTEGER DIGIT 
          IX2 X2+X3          X2 - CONSTANT, INTEGER INSERTED INTO LOW OR
* 
*         SHIFT NUMBER IN X5, CLEAR OUT UNWANTED BITS, INSERT CONSTANT
          LX5 6             X5 - NUMBER,SHIFTED = NNNNNESBN.
          MX0 24             X0 - LEFT 4 CHARACTER MASK 
          BX5 X0*X5          X5 - NUMBER, FRACTIONAL DIGITS ONLY NNNNZZZ
          IX5 X5+X2          X5 - NUMBER, FRACTIONAL + INSERTED CONSTANT
          LX5 30             X5 - NUMBER, CORRECTLY POSITIONED, DEC PT N
*         THIS NUMBER IS NOW IN NON-EXPONENTIAL FORMAT AND CAN BE 
*         PROCESSED AS IF IT WERE A NON-EXPONENTIAL NUMBER RETURNED 
*         BY BASOCON
* 
*         RESTORE REGS
          MX0 54    X0 - LEFT 9 CHARACTER MASK
          SB3 9      B3 - POSN NUMBER THAT CONTAINS TRLG BLANK
          JP FRMHITE         BRANCH TO NON-EXPONENTIAL PROCESSIN
* 
*         GTRMSG
*         MOVE MESSAGE = GTR 999999 INTO X5 IN LIEU 
*         OF NUMBER AND JUMP TO EXIT PROCESSING.
 GTRMSG  SA5 =10RGTR 999999 X5 - MSG = GTR 999999 
          JP TOOBIG 
* 
 KSHFDEC1 DATA 00000000550000555700B
 KSHFDEC2 DATA 00000000550055573300B
 KSHFDEC3 DATA 00000000555557333300B
* 
***       THIS IS END OF HITE 
* 
 NOHIT    SA5 =10RBAD LOGIC 
*         X5 - CONTAINS MSG - BAD LOGIC 
*         FALL THRU 
 TOOBIG   BSS 0 
*         X5 - CONTAINS MSG -  GTR 999999 
*         FALL THRU 
 ELAP6    BX6    X5                RESULT IN X6 
          EQ   ELAPTIM             EXIT 
* 
* 
* 
TIME      DATA      0 
CLKMSK    DATA      00333300333300333300B 
SEC2HRS   DATA      3600. 
MIN2HRS   DATA       60.
BATACLK   BSS       0 
* 
*         TIM(X)
* 
          DATA      10HBASATIM
BASATIM   DATA      0 
          TIME   TIME 
          SA2       TIME
          SX0       7777B 
          BX0       X0*X2              GET MILLISECONDS 
          PX0       B0,X0 
          NX0       B0,X0 
          SA1       TENM3 
          RX0       X1*X0 
          AX2       12
          MX1       24
          LX1       24
          BX2       X1*X2              GET SECONDS
          PX2       B0,X2 
          NX2       B0,X2 
          RX5       X2+X0              TOTAL ELAPSED SECONDS
          NX5       B0,X5 
          MOVEREG   5,UV
          JP        BASATIM 
TENM3     DATA       1.0E-03
BATATIM   BSS       0 
* 
*         END   TIM(X)
* 
 STIME    BSS    1                 SAVE START CP TIME HERE
 MINTIME  DATA   0.001                                                   BAS0014
          TITLE  RECOVER
* 
*         PROCEDURE RECOVER 
* 
 SOFTERR  DATA   0                 COUNT OF SOFTWARE DETECTED ERRORS
* 
*         RPV PARAMETER BLOCK 
* 
 RPVBLK   BSS    0
          VFD    36/0,12/31B,11/1,1/0  LENGTH/FUNCTION/COMPLETE BIT 
          VFD    30/0,30/RECOVER   TRANSFER ADDRESS 
          VFD    60/0              CHECKSUM 
          VFD    24/37B,24/0,12/0   MASK/ERROR CLASS/ERROR CODE 
          VFD    60/0              PENDING INTERRUPTS 
          VFD    60/0              PENDING RA+1 REQUESTS
          VFD    60/0              INTERRUPTED TERMINAL INPUT REQUEST 
          VFD    48/0,12/0         ERROR FLAG 
          VFD    60/0              RESERVED 
          BSSZ   20B               INTERRUPTED EXCHANGE PACKAGE 
 RECOVER  SA1    RPVBLK+FWA03      GET ERROR CODE WORD
          MX7    48 
          BX1    -X7*X1            EXTRACT ERROR CODE 
 RER1     BSS    0
          SB6    X1                TRUNCATE TO BITS 0-17
          SB7    2B                SYSTEM CODE FOR HARD WARE ERROR
          NE     B7,B6,SERR        SKIP IF SOFTWARE DETECTED
* 
*                PROCESS HARD WARE DETECTED ERRORS
          MX2    3
          SA1    B0                GET RA 
          LX2    3*17 
          BX3    X1*X2             EXTRACT MODE NUMBER
          AX3    3*16               MOVE TO LOW BITS
          SA4    X3+RERH           GET ADDRESS OF MESSAGE 
          EQ     RER2              SEND MESSAGE 
* 
*                PROCESS SOFT WARE DETECTED ERRORS
 SERR     SA4    B6+SCPRERS        FETCH ERROR ENTRY
          SB7    40B               SYSTEM ERROR CODE FOR TERMINAL INTERR
          EQ     B6,B7,RER2        BR, ALLOW ANY NUMBER OF T.I. 
          SA1    SOFTERR           INCREMENT SOFTWARE ERROR COUNT 
          SX7    X1+1 
          SA7    A1 
* 
 RER2     SB7    X4          MESSAGE ADDRESS
          MX7    42 
          AX4    18 
          BX7    -X7*X4            PICK UP ERROR NUMBER 
          SA1    DBUGON            GET CID MODE FLAG
          NZ     X1,ERRST3         BR, CID ENABLED
          PL     X4,ERRSTRT  IF NO RECOVERY DESIRED 
  
*         IF RECOVERY FROM OVERFLOW CONDITIONS IS NECESSARY, ADD
*         RECOVERY PROCESSING AT THIS POINT AND DEFINE THE TAG *RESTART*
  
          EQ     ERRSTRT
  
** THE FOLLOWING TABLE IS USED TO PROCESS SOFTWARE DETECTED ERRORS
 SCPRERS  BSS    0
          DATA   0                           0  UNUSED (NORMAL TERMINATI
          VFD    1/1,41/ERMN100,18/ERM100    1  TIME LIMIT
          DATA   0                           2  UNUSED (MODE ERROR) 
          VFD    1/1,41/ERMN102,18/ERM102    3  PPU ABORT 
          DATA   0                           4  UNUSED (CPU ABORT)
          VFD    1/1,41/ERMN104,18/ERM104    5  PP CALL ERROR 
          VFD    1/1,41/ERMN105,18/ERM105    6  OPERATOR DROP 
          VFD    1/1,41/ERMN105,18/ERM105    7  OPERATOR KILL 
          VFD    1/1,41/ERMN115,18/ERM115   10  OPERATOR RERUN
          DATA   0                          11  UNUSED (CPU ABORT)
          VFD    1/1,41/ERMN101,18/ERM101   12  ECS PARITY ERROR
          VFD    1/1,41/ERMN101,18/ERM101   13  CY170 PARITY ERROR
          DATA   0                          14  UNUSED (NOT RETURNED) 
          VFD    1/1,41/ERMN116,18/ERM116   15  AUTO RECALL STATUS MISSI
          VFD    1/1,41/ERMN117,18/ERM117   16  HUNG IN AUTO RECALL 
          VFD    1/1,41/ERMN118,18/ERM118   17  MASS STORAGE LIMIT
          VFD    1/1,41/ERMN103,18/ERM103   20  XXX NOT IN PPLIB
          VFD    1/1,41/ERMN106,18/ERM106   21  IO TIME LIMIT 
          BSSZ   16B               UNUSED SYSTEM ERROR CODES
          VFD    1/1,41/ERMN190,18/ERM190 
* 
*         HARDWARE DETECTED ERRORS
*         BIT 59 IS SET TO ALLOW RECOVERY 
* 
 RERH     BSS    0
          VFD    1/1,41/ERMN107,18/ERM107   UNKNOWN ABORT       (E=0) 
          VFD    1/1,41/ERMN108,18/ERM108   ADDRESS OUT OF RANGE(E=1) 
          VFD    1/1,41/ERMN109,18/ERM109   INFINITE OPERAND    (E=2) 
          VFD    1/1,41/ERMN110,18/ERM110   MODE 1 AND 2        (E=3) 
          VFD    1/1,41/ERMN111,18/ERM111   INDEFINITE OPERAND  (E=4) 
          VFD    1/1,41/ERMN112,18/ERM112   MODE 1 AND 4        (E=5) 
          VFD    1/1,41/ERMN113,18/ERM113   MODE 2 AND 4        (E=6) 
          VFD    1/1,41/ERMN114,18/ERM114   MODE 1,2 AND 4      (E=7) 
* 
*         END RECOVER 
* 
          END 
