         TITLE    'ERROR-B00,08/22/73,DWG702985'
         SYSTEM   SIG7F
         CSECT    1
         PCC      0                 CONTROL CARDS NOT PRINTED.
ERROR@   RES      0                 ORIGIN OF ERROR MODULE.
*
*  REF'S  AND  DEF'S
*
         DEF      ERROR@            = START OF 'ERROR' MODULE.
         DEF      ENTEREM           PT OF ENTRY INTO THE ERROR MODULE.
 SPACE 3
*                             REFS TO PROCEDURE:
         REF      EBALS             TBL OF BAL,R15 EXITS INTO ENTEREM.
         REF      ALOCBLK           ALLOCATES A DATA BLOCK.
         REF      ALOCHNW           ALLOCS. DATA BLK W/HDR & EVENS SIZE.
         REF      DREF              DE-REFERENCES A DATA BLOCK.
         REF      MAYDREF           DE-REFS. DATA BLK, IF NON-ZERO PTR.
         REF      SICLR             CLEARS STATE-INDICATOR TO GO-STATE.
         REF      NIRETURN          RETURN AFTER NILADIC INTRINSIC OPER.
         REF      BCBRANCH          CLR BREAK & START ERR-CTRL'D BRANCH.
         REF      ECBRANCH          START ERR-CONTROLLED BRANCH.
         REF      BBADFL            EXIT TO USE BAD FUN.LINE (MAYBE).
         REF      BCONTOFF          EXIT AS IF A )CONTINUE CMD ISSUED.
         REF      CMDEXITM          EXIT ACCORDING TO MODE.
         REF      CMDEXITO          EXIT VIA MODE UNLESS OFF-LINE RUN.
         REF      INPDIR            EXIT FOR DIRECT INPUT.
         REF      INPEVAL           EXIT FOR EVALUATED INPUT.
         REF      INPLSCER          EXIT FOR INPUT AFTER LINESCAN ERR.
         REF      GENNAME           GENERATE A NAME IN IMAGE BUFFER.
         REF      GENNAME0            DITTO (ALT.ENTRY).
         REF      TEXTC2I           MOVE TEXTC MSG TO IMAGE.
         REF      FUNLDIS%          DISPLAY FUNCTION LINE.
         REF      EDECODOP          DECODE CODESTRING & DISPLAY ERROR.
         REF      DUMPLINP          DISPLAY LINE AS A PROMPT.
         REF      EDUMPLIN          DISPLAY LINE IN ERROR.
         REF      EDUMPLIG            DITTO (ALT.ENTRY).
         REF      EWRTEXTC          WRITE TEXTC ERROR MSG.
         REF      EWROUTWB          WRITE ERROR INFO AT WORD BOUNDARY.
         REF      CLOSR             CLOSE & RELEASE FILE.
         REF      OBSERVEZ          EXIT PT AFTER AN OBSERVATION.
         REF      SINGOUT           DISPLAY VALUE OF OBSERVATION.
*                             REFS TO CONTEXT:
         REF      ELINK             SOMETIME LINK TO ERROR ROUTINE.
         REF      ERRORID           INTERNAL I.D. FOR ERROR.
         REF      EREGS           @ R1-R6 SAVED AT ERR-CTRL TEST.
         REF      ERRLOC          @ ERROR LOC (CURRLINO & NAME PTR).
         REF      ERRNUM          @ ERROR NUMBER.
         REF      SICTRL            STATE-INDICATOR CTRL:
*                                     0  = ON -- SUSPEND, IF APPROPR.
*                                     NZ = OFF -- DON'T SUSPEND ON ERR.
         REF      STATEPTR          PTS AT TOP STATE-ENTRY.
         REF      GOSTATE           PTS AT GO-STATE ENTRY.
         REF      BRNVAL            ERR-CTRL BRANCH VALUE (OR NEGATIVE).
         REF      MODE              EXECUTION MODE:
*                                     -1 = FORCED CLOSE OF FUN DEFN.
*                                      0 = FUN DEFN.
*                                      1 = DIRECT INPUT.
*                                      2 = EVAL-INPUT OR EXECUTE-OPER.
         REF      OLDMODE           MODE WHEN FUN DEFN MODE BEGAN.
         REF      IOERCODE          I/O ERROR CODE,SUBCODE,DCB ADDR WD.
         REF      ON%OFF            ON OR OFF-LINE RUN FLAG.
         REF      BSPFLAG           BACKSPACE FLAG FOR TERMINAL TYPE.
         REF      ERRORCHR          ERROR MARKER CHAR FOR TERMINAL TYPE.
         REF      OUTRANST          OUTPUT TRANSLATION TBL FOR TERMINAL.
         REF      OBSAVE            REG.SAVE AREA DURING AN OBSERVATION.
         REF      SAVE14            LINKAGE HOLDER.
         REF      F:WS              DCB FOR WS FILE ACTIVITIES.
         REF      BREAKFLG          BREAK FLAG: <0 IF HANG-UP,
*                                               =0 IF NO BREAK DETECTED,
*                                               >0 IF BREAK DETECTED.
         REF      CURRCS            PTR TO CURRENT CODESTRING, IF ANY.
         REF      OFFSET            OFFSET.
         REF      WHATERR           DATA CONCERNING EXECUTION ERROR.
         REF      IMAGE             IMAGE BUFFER.
         REF      HICOL             INDICATES HIGH COLUMN IN IMAGE.
         REF      IMAGEPOS          POSITION INDICATOR FOR IMAGE BUFFER.
         REF      INBUF             INPUT OR OUTPUT BUFFER.
         REF      ERRCOL            COLUMN INDICATOR FOR ERROR.
         REF      WSIDNAME          WS I.D. NAME (TEXTC).
         REF      RESULT            PTR TO RESULT DATA BLK.
         REF      STRAYS            STRAY DATA BLK PTRS.
         REF      SYMT              PTS AT SYMBOL TABLE.
*                             REFS TO CONSTANTS:
         REF      BLANKS            BLANK DBLWD.
         REF      HEXTBL            TBL OF EBCDIC CHARS FOR HEX DIGITS.
*                             REFS TO EQU'S:
         REF      NSTRAYS           NO.OF NORMAL EXECUTION STRAYS.
         REF      DWSIZIM           DBLWD SIZE OF IMAGE.
*                                   INTERNAL ERROR I.D.'S FOR:
         REF      IDLSCAN             LINESCAN ERR
         REF      IDDEFN              DEFN ERR
         REF      IDNOTSAV            NOT SAVED, THIS WS IS ...
         REF      IDSIDAM             SI DAMAGE
         REF      IDNERASE            ... NOT ERASED
         REF      IDNOTCPY            ... NOT COPIED
         REF      IDNOTFND            ... NOT FOUND
         REF      IDXEQERR            ERR DURING AN 'EXECUTE' OPERATION.
*
*  STANDARD EQU'S
*                   REGISTERS
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
*
*  OTHER EQU'S
*
CATQ     EQU      7                 QUAD-STATE CATEGORY.
CATF     EQU      10                FUNCTION-STATE CATEGORY.
EFLAG    EQU      X'10000'          MARKS 'EXECUTE' TYPE OF Q-ENTRY.
TYPETEXT EQU      2                 DATA BLK TYPE = TEXT.
TYPEINTG EQU      3                 DATA BLK TYPE = INTEGER.
FNOFF    EQU      5                 FUN.DESCR. OFFSET TO FUN.NAME PTR.
XSIZOFF  EQU      2                 FUN.DESCR. OFFSET TO XSIZE WD.
PENDFLAG EQU      X'8000'           MARKS PENDENT STATES.
LOCKFLAG EQU      X'10000'          MARKS LOCKED FUNCTIONS.
IDLE     EQU      X'16'             IDLE CHARACTER.
*
*  CONSTANTS
*
PENDFUN  DATA     X'A008000'        PENDENT FUNCTION STATE BITS.
 PAGE
*
*  ERROR MESSAGES:
*
M%SYNTAX TEXTC    'SYNTAX ERR'
M%UNDEF  TEXTC    'UNDEFINED'
M%NORES  TEXTC    'NO RESULT'
M%IOERR  TEXTC    'I/O ERR '
M%DOMAIN TEXTC    'DOMAIN ERR'
M%RANK   TEXTC    'RANK ERR'
M%LENGTH TEXTC    'LENGTH ERR'
M%WSFULL TEXTC    'WS FULL'
M%SINGMX TEXTC    'SING. MATRIX'
M%FMTSYN TEXTC    'FORMAT SYNTAX ERR'
M%INDEX  TEXTC    'INDEX ERR'
M%BADCH  TEXTC    'BAD CHAR'
M%TRUNC  TEXTC    'TRUNCATED INPUT'
M%OPENQT TEXTC    'OPEN QUOTE'
M%SYMFUL TEXTC    'SYM TBL FULL'
M%LSCAN  TEXTC    'LINESCAN ERR'
M%DEFN   TEXTC    'DEFN ERR'
M%SIDAM  TEXTC    'SI DAMAGE'
M%BADCMD TEXTC    'BAD COMMAND'
M%NOTGRP TEXTC    'NOT GROUPED'
M%2BIGLD TEXTC    'TOO BIG TO LOAD'
M%FILREF TEXTC    'BAD FILE REF'
M%FILBSY TEXTC    'FILE IN USE'
M%WSNOTF TEXTC    'WS NOT FOUND'
M%NOTSAV TEXTC    'NOT SAVED, THIS WS IS '
M%NERASE TEXTC    ' NOT ERASED'
M%NOTCPY TEXTC    ' NOT COPIED'
M%NOTFND TEXTC    ' NOT FOUND'
M%TOOBIG TEXTC    'TOO BIG'
M%2NAMEY TEXTC    'TOO MANY SYMBOLS'
M%FILSPC TEXTC    'FILE SPACE TOO LOW'
M%TERMAL TEXTC    'WRONG TERMINAL'
M%FILNAM TEXTC    'FILE NAME ERR'
M%NOTAPL TEXTC    'NOT APL FILE'
M%FTFULL TEXTC    'FILE TBL FULL'
M%FILACC TEXTC    'FILE ACCESS ERR'
M%FILTIE TEXTC    'FILE TIE ERR'
M%NOPACK TEXTC    'PRIVATE PACK UNAVAIL, CALL OPR.'
M%FILIDX TEXTC    'FILE INDEX ERR'
M%FILDAM TEXTC    'FILE DAMAGE'
M%FIOERR TEXTC    'FILE I/O ERR '
 PAGE
IDMSGTBL EQU      %+1    ERROR I.D. VS MESSAGE LOCATION:
         DATA     0             -1  BREAK (NO MESSAGE)
         DATA     M%SYNTAX       0  LINESCAN ERR = SYNTAX ERR
         DATA     M%SYNTAX       1  SYNTAX ERR
         DATA     M%UNDEF        2  UNDEFINED
         DATA     M%NORES        3  NO RESULT
         DATA    -M%IOERR        4  I/O ERR ....
         DATA     M%DOMAIN       5  DOMAIN ERR
         DATA     M%RANK         6  RANK ERR
         DATA     M%LENGTH       7  LENGTH ERR
         DATA     M%WSFULL       8  WS FULL
         DATA     M%SINGMX       9  SING. MATRIX
         DATA     M%FMTSYN      10  FORMAT SYNTAX ERR
         DATA     M%INDEX       11  INDEX ERR
         DATA     0             12  XEQ ERR (NO MESSAGE)
         DATA     M%BADCH       13  BAD CHAR
         DATA     M%TRUNC       14  TRUNCATED INPUT
         DATA     M%OPENQT      15  OPEN QUOTE
         DATA     M%SYMFUL      16  SYM TBL FULL
         DATA     M%LSCAN       17  LINESCAN ERR
         DATA     M%DEFN        18  DEFN ERR
         DATA     M%SIDAM       19  SI DAMAGE
         DATA     M%BADCMD      20  BAD COMMAND
         DATA     M%NOTGRP      21  NOT GROUPED
         DATA     M%2BIGLD      22  TOO BIG TO LOAD
         DATA     M%FILREF      23  BAD FILE REF
         DATA     M%FILBSY      24  FILE IN USE
         DATA     M%WSNOTF      25  WS NOT FOUND
         DATA     M%NOTSAV      26  NOT SAVED, THIS WS IS ...
         DATA     M%NERASE      27  ... NOT ERASED
         DATA     M%NOTCPY      28  ... NOT COPIED
         DATA     M%NOTFND      29  ... NOT FOUND
         DATA     M%TOOBIG      30  TOO BIG
         DATA     M%2NAMEY      31  TOO MANY SYMBOLS
         DATA     M%FILSPC      32  FILE SPACE TOO LOW
         DATA     M%TERMAL      33  WRONG TERMINAL
         DATA     M%FILNAM      34  FILE NAME ERR
         DATA     M%NOTAPL      35  NOT APL FILE
         DATA     M%FTFULL      36  FILE TBL FULL
         DATA     M%FILACC      37  FILE ACCESS ERR
         DATA     M%FILTIE      38  FILE TIE ERR
         DATA     M%NOPACK      39  PRIVATE PACK UNAVAIL, CALL OPR.
         DATA     M%FILIDX      40  FILE INDEX ERR
         DATA     M%FILDAM      41  FILE DAMAGE
         DATA    -M%FIOERR      42  FILE I/O ERR ....
 PAGE
ERRO#TBL EQU      %+1    ERROR I.D. VS ERROR NUMBER TABLE:
         DATA     100           -1  BREAK
         DATA,1   2              0  LINESCAN ERR (SYNTAX ERR ASSUMED)
         DATA,1   2              1  SYNTAX ERR
         DATA,1   3              2  UNDEFINED
         DATA,1   8              3  NO RESULT
         DATA,1   30             4  I/O ERR
         DATA,1   4              5  DOMAIN ERR
         DATA,1   5              6  RANK ERR
         DATA,1   6              7  LENGTH ERR
         DATA,1   1              8  WS FULL
         DATA,1   15             9  SINGULAR MATRIX
         DATA,1   16            10  FORMAT SYNTAX ERR
         DATA,1   7             11  INDEX ERR
         DATA,1   0             12  XEQ ERR
         DATA,1   20            13  BAD CHAR
         DATA,1   22            14  TRUNCATED INPUT
         DATA,1   23            15  OPEN QUOTE
         DATA,1   9             16  SYM TBL FULL
         DATA,1   21            17  LINESCAN ERR
         DATA,1   35            18  DEFN ERR
         DATA,1   36            19  SI DAMAGE
         DATA,1   40            20  BAD COMMAND
         DATA,1   51            21  NOT GROUPED
         DATA,1   45            22  TOO BIG TO LOAD
         DATA,1   43            23  BAD FILE REF
         DATA,1   42            24  FILE IN USE
         DATA,1   44            25  WS NOT FOUND
         DATA,1   41            26  NOT SAVED, THIS WS IS ...
         DATA,1   50            27  ... NOT ERASED
         DATA,1   48            28  ... NOT COPIED
         DATA,1   49            29  ... NOT FOUND
         DATA,1   46            30  TOO BIG
         DATA,1   47            31  TOO MANY SYMBOLS
         DATA,1   70            32  FILE SPACE TOO LOW
         DATA,1   31            33  WRONG TERMINAL
         DATA,1   73            34  FILE NAME ERR
         DATA,1   74            35  NOT APL FILE
         DATA,1   75            36  FILE TBL FULL
         DATA,1   76            37  FILE ACCESS ERR
         DATA,1   77            38  FILE TIE ERR
         DATA,1   78            39  PRIVATE PACK UNAVAIL, CALL OPR.
         DATA,1   79            40  FILE INDEX ERR
         DATA,1   72            41  FILE DAMAGE
         DATA,1   71            42  FILE I/O ERR ....
 SPACE 2
         BOUND    4
 PAGE
************************************************************************
*                                                                      *
*  DSTRAYS -- DEREFERENCES THE NORMAL STRAY DATA BLK PTRS ASSOCIATED   *
*             WITH EXECUTION.                                          *
*       REGS:    R14 LINK, EXIT VIA *R14                               *
*                R4,R5,R7 ARE VOLATILE.                                *
*                                                                      *
DSTRAYS  LI,R5    NSTRAYS           = NO.OF NORMAL EXEC. STRAYS.
DSTRAY   LI,R4    0
         XW,R4    STRAYS-1,R5
         BAL,R7   MAYDREF           DEREFERENCE, IF NON-ZERO PTR.
         BDR,R5   DSTRAY
         B       *R14               EXIT.
 PAGE
************************************************************************
*                                                                      *
*  ECTEST -- ERROR CONTROL TESTER.                                     *
*                                                                      *
*  IDECTEST -- ALT.ENTRY PT.  ENTERED WITH THE ERROR I.D. IN R8.  THIS *
*              IS SAVED IN ERRORID & R8 IS GIVEN THE ERROR NUMBER.     *
*                                                                      *
*       REGS:    R8 (ENTRY) CONTAINS THE ERROR NUMBER (BYTE SIZE).     *
*                R7 LINK -- EXIT 0,R7 IF CONTROLLED, BRNVAL SET MAX.OF *
*                                   ERR-CTRL LINE NO. VALUE OR ZERO.   *
*                           EXIT 1,R7 IF UNCONTROLLED, BRNVAL SET NEG. *
*                ALL REGS. PRESERVED.                                  *
*                                                                      *
IDECTEST STW,R8   ERRORID           SAVE ERROR I.D.
         STW,R7   ERRLOC            SAVE R7.
         LW,R7    ERRORID
         LB,R8    ERRO#TBL,R7       GET ERROR NUMBER.
         LW,R7    ERRLOC            RESTORE R7.
ECTEST   LCI      8                 SAVE R1-R6, USE R7 TO 'CLEAR' ERRLOC
         STM,R1   EREGS               AND PUT R8 IN ERRNUM.
         LW,R1    STATEPTR          PT AT TOP STATE ENTRY.
         LI,R2    EFLAG             SET FOR 'EXECUTE' STATE TESTS.
         B        ECTESTS
ECTESTNS LI,R6    X'7FFF'           PT AT THE NEXT STATE ENTRY.
         AND,R6   0,R1
         AW,R1    R6
ECTESTS  CW,R2    0,R1              TEST FOR 'EXECUTE'...
         BANZ     ECTESTNS            YES, TRY AGAIN.
         LI,R3    X'F8000'
         AND,R3   0,R1
         CW,R3    PENDFUN           TEST FOR PENDENT FUNCTION...
         BE       ECTESTPF            YES.
         STW,R1   GOSTATE             NO, SAVE PTR TO SUSP. OR EVAL-INP.
         LI,R2    -1
         STW,R2   BRNVAL            SET BRNVAL NEG. = UNCONTROLLED ERROR
         LCI      6
         LM,R1    EREGS             RESTORE USED REGS.
         B        1,R7              EXIT (UNCONTROLLED).
ECTESTPF LW,R5    1,R1              GET LINE # & FDEFPTR WD.
         CW,R7    ERRLOC            HAS THE ERROR LOC BEEN UPDATED...
         BNE      ECTESTCT            YES.
         LI,R4    X'E0000'            NO, SET IT NOW --
         AND,R4   1,R1                  CURRLINO &
         AW,R4    FNOFF,R5                FUNCTION NAME PTR.
         STW,R4   ERRLOC
ECTESTCT LW,R4    XSIZOFF,R5        DOES PEND FUNC HAVE ERR-CTRL TBL...
         CI,R4    X'1FFFF'
         BL       ECTESTNS            NO, TRY AGAIN.
         AI,R4    2                   YES, PT AT # OF ROWS.
         LW,R6    0,R4              GET # OF ROWS.
ECTESTCR AI,R4    2                 PT AT NEXT ROW OF ERR-CTRL TBL.
         LW,R5    1,R4              GET ERR-CTRL NO...
         BEZ      ECTESTC             ZERO -- CONTROL THIS ERROR.
         CW,R5    ERRNUM              NZ, DOES IT MATCH THE ERROR NO...
         BE       ECTESTC               YES, CONTROL THIS ERROR.
         BDR,R6   ECTESTCR              NO, LOOP THRU ERR-CTRL TBL...
         B        ECTESTNS                NO SCORE, TRY AGAIN.
ECTESTC  LW,R2    0,R4              GET ERR-CTRL LINE NO. VALUE...
         BGEZ     ECTESTB
         LI,R2    0                   USE ZERO IF THAT VALUE IS NEG.
ECTESTB  STW,R2   BRNVAL            SET BRNVAL = BRANCH VALUE FOR ERROR.
         STW,R1   GOSTATE           SAVE PTR TO ERR-CTRL'D FUN STATE.
         LCI      6
         LM,R1    EREGS             RESTORE USED REGS.
         B        0,R7              EXIT (CONTROLLED).
 PAGE
*
*  COMMUNICATIONS REGION -- FROM ROOT INTO ERROR MODULE -- VIA R15.
*
*  IT IS INTENDED THAT ALL ENTRIES TO THIS MODULE BE CHANNELED THRU HERE
*
ENTEREM  STW,R7   ELINK             SAVE R7 FOR PROCESSES NEEDING THAT.
         AI,R15   BE-EBALS          CALC. COMMUNICATION BRANCH.
BE       B       *R15             @ ENTER APPROPRIATE PROCESS.
         B        ERRN            @
         B        ERRF            @
         B        ERRX            @
         B        CMDERRH         @
         B        IDECTEST        @
         B        CTRL            @
         B        DONTSAVH        @
         B        DERASE          @
         B        DNOTFND         @
         B        DNOTCPY         @
         B        DSIDAM          @
         B        DEFNERRH        @
         B        LSCANERH        @
         B        UNREF           @
         B        ERRSET          @
         B        OBSERVER        @
*        B        FUNDERRH        @
FUNDERRH RES      0               @
         BAL,R7   IDECTEST   @      RECORD ERROR & TEST ERR-CTRL...
         B       *ELINK      @        CONTROLLED -- RESUME FUNDEF AWHILE
         B        EIDTEXTC   @        UNCONTROLLED -- DISPLAY & RESUME.
LSCANERH LI,R5    F:WS              RELEASE WS IF OPEN DUE TO ERROR ON
         BAL,R6   CLOSR               AN AUTOCONTINUE CODESTRING ERR.
         LI,R8    IDLSCAN           = ERROR I.D. FOR 'LINESCAN ERR'.
         BAL,R7   IDECTEST   @      RECORD ERROR & TEST ERR-CTRL...
         B        BBADFL     @        CONTROLLED -- MUST BE BAD FUN.LINE
         LW,R7    ERRCOL     @        UNCONTROLLED.
         BAL,R11  GENCARMS          DISPLAY MSG WITH AN ERROR MARKER.
         LW,R7    MODE              CK MODE...
         BLEZ     BBADFL              FUN.DEFN -- MAY USE BAD FUN.LINE.
         LW,R10   ON%OFF            IF HANG-UP OCCURRED.
         BEZ      BCONTOFF            DO LIKE A  CONTINUE CMD.
         LW,R10   BSPFLAG           DOES TERMINAL ADMIT BACKSPACING...
         BEZ      CMDEXITM            NO, EXIT VIA MODE AS IF A CMD.
         LW,R3    ERRCOL              YES, DISPLAY ACCEPTABLE
         LI,R12   INPLSCER              PORTION OF LINE
         B        DUMPLINP                AS A PROMPT.
DEFNERRH LI,R8    IDDEFN            = ERROR I.D. FOR 'DEFN ERR'.
         BAL,R7   IDECTEST   @      RECORD ERROR & TEST ERR-CTRL...
         B        CMDEXITM   @        CONTROLLED -- EXIT VIA MODE.
         STW,R1   ERRCOL     @        UNCONTROLLED.
         LI,R11   EFLAG             WAS THIS AN 'EXECUTED' FUN DEFN...
         CW,R11   OLDMODE
         BAZ      DEFNERRM            NO.
         LI,R3    -BA(IMAGE)          YES, DISPLAY THE OFFENDING LINE.
         AW,R3    HICOL
         BAL,R12  EDUMPLIN
DEFNERRM LW,R7    ERRCOL
         LI,R11   CMDEXITO          GO TO CMDEXITO AFTER
*        B        GENCARMS        @   DISPLAYING ERR MSG & ERROR MARKER.
GENCARMS AI,R7    -BA(IMAGE)      @
         STW,R7   ERRCOL            SET ERROR POSITION IN THE LINE.
         LW,R6    ERRORID
         LW,R6    IDMSGTBL,R6       GET LOC OF (TEXTC) ERR MSG.
         LB,R8   *R6                GET BYTE COUNT OF ERR MSG.
         LW,R10   R8                SAVE BYTE COUNT FOR LOOP
         AI,R8    1                 ADD 1 TO ERR MSG SIZE FOR FITTING.
         SLS,R6   2
         AI,R6    1                 = BA(ERROR MSG STRING).
         LI,R5    DWSIZIM
         LW,R9    BLANKS
BLANKIT  STD,R9   INBUF-2,R5        BLANK THE OUTPUT BUFFER.
         BDR,R5   BLANKIT
         LI,R5    IDLE
         STB,R5   IMAGE,R7          PUT IDLE IN BAD SPOT IN IMAGE.
         LB,R5    ERRORCHR
         LB,R5    OUTRANST,R5       GET TERMINAL'S ERROR MARKER &
         STB,R5   INBUF,R7            PUT IT IN THE OUTPUT BUFFER.
         LW,R9    R7
         SW,R7    R8                CK IF MESSAGE FITS ON LEFT...
         BGEZ     SETMESS            YES
         AW,R7    R8                  NO, MOVE TO RIGHT OF MARKER.
         AI,R7    2
         AW,R9    R8                ADJUST SIZE.
SETMESS  LB,R5    0,R6
         LB,R5    OUTRANST,R5        TRANSLATE BYTE TO OUTPUT FORM
         STB,R5   INBUF,R7            AND PUT IN INBUF
         AI,R6    1
         AI,R7    1
         BDR,R10  SETMESS           LOOP
         LI,R8    INBUF
         AI,R9    1                 SIZE.
         LW,R7    R11               EXIT FROM GENCARMS AFTER
         B        EWROUTWB            DISPLAYING THE DIAGNOSTIC.
DONTSAVH LI,R8    IDNOTSAV          = ERROR I.D. FOR 'NOT SAVED, ETC.'.
         BAL,R7   IDECTEST   @      RECORD ERROR & TEST ERR-CTRL...
         B        CTRL       @        CONTROLLED.
         LW,R7    ERRORID    @        UNCONTROLLED.
         LW,R8    IDMSGTBL,R7       GET LOC OF (TEXTC) ERR MSG.
         LI,R3    0                 INIT. CHAR POSITION.
         BAL,R13  TEXTC2I           MOVE ERR MSG INTO IMAGE BUFFER.
         LI,R8    WSIDNAME          PT AT (TEXTC) WS I.D.
         BAL,R13  TEXTC2I           APPEND THAT TO ERR MSG IN IMAGE.
         LI,R12   CMDEXITO          GO TO CMDEXITO AFTER
         B        EDUMPLIG            DISPLAYING THE DIAGNOSTIC.
CMDERRH  BAL,R7   IDECTEST   @      RECORD ERROR & TEST ERR-CTRL...
         B        CTRL       @        CONTROLLED.
EIDTEXTC LW,R7    ERRORID    @        UNCONTROLLED, GET ERROR I.D. AGAIN
MSGTEXTC LW,R8    IDMSGTBL,R7       GET LOC OF (TEXTC) ERR MSG.
         LW,R7    ELINK             EXIT AFTER
*        B        WRTEXTCQ        @   DISPLAYING THE ERR MSG.
WRTEXTCQ AI,R8    0               @ IS R8 POSITIVE...
         BGZ      EWRTEXTC            YES, NORMAL MSG.
         LCW,R8   R8                  NO, I/O OR FILE I/O ERR MSG.
         LI,R3    0                 INIT. CHAR POSITION.
         BAL,R13  TEXTC2I           MOVE ERR MSG INTO IMAGE BUFFER.
         LW,R12   R7                PUT LINK IN R12 SO EDUMPLIG IS EXIT.
         LI,R14   WRTEXTCX          EXIT FROM 'HEXIO' TO 'WRTEXTCX'.
HEXIO    LW,R7    IOERCODE          GET I/O ERR CODE & SUBCODE.
         SLD,R6   8                 MOVE CODE OVER.
         SLS,R7   -1                RIGHT-JUSTIFY SUBCODE.
         SLD,R6   -8                MOVE CODE BACK.
         LI,R11   4                 PRODUCE 4 HEX DIGITS.
HEXCHAR  LI,R6    0
         SLD,R6   4
         LB,R6    HEXTBL,R6         GET EBCDIC VERSION OF A HEX DIGIT.
         B       *R14
WRTEXTCX STB,R6   IMAGE,R3          PUT HEX CHAR IN IMAGE.
         AI,R3    1                 PT AT NEXT POS.
         BDR,R11  HEXCHAR           LOOP TILL LAST HEX CHAR PUT.
         B        EDUMPLIG          DISPLAY DIAG., LINK IS R12.
DSIDAM   LI,R8    -IDSIDAM          RECORD NEG. ERROR I.D. (DISPLAY NOW,
         STW,R8   ERRORID             TEST ERR-CTRL LATER).
         LI,R7    IDSIDAM           = ERROR I.D. FOR 'SI DAMAGE'.
         B        MSGTEXTC          DISPLAY & RESUME PROCESSING.
DERASE   LI,R8    -IDNERASE         RECORD NEG. ERROR I.D. (DISPLAY NOW,
         STW,R8   ERRORID             CK ERR-CTRL LATER)--'NOT ERASED'.
         LI,R3    0                 INIT. CHAR POSITION.
         LW,R8    R6                GET NAME PTR, I.E. SYMT OFFSET.
         BAL,R13  GENNAME           GEN. NAME INTO IMAGE BUFFER.
NAMEGEND LCW,R7   ERRORID           GET ERROR I.D.
         LW,R8    IDMSGTBL,R7       GET LOC OF (TEXTC) ERR MSG.
         BAL,R13  TEXTC2I           APPEND ERR MSG TO NAME IN IMAGE.
         LW,R12   R14               EXIT AFTER
         B        EDUMPLIG            DISPLAYING DIAGNOSTIC.
DNOTCPY  LI,R8    -IDNOTCPY         RECORD NEG. ERROR I.D. (DISPLAY NOW,
         STW,R8   ERRORID             CK ERR-CTRL LATER)--'NOT COPIED'.
         LI,R3    0                 INIT. CHAR POSITION.
         LW,R8    R1                GET NAME PTR, I.E. SYMT OFFSET.
         LI,R13   NAMEGEND          GO TO NAMEGEND AFTER
         B        GENNAME0            GEN. NAME INTO IMAGE BUFFER.
DNOTFND  LI,R8    -IDNOTFND         RECORD NEG. ERROR I.D. (DISPLAY NOW,
         STW,R8   ERRORID             CK ERR-CTRL LATER)--'NOT FOUND'.
         LI,R8    ' '               NAME IS IN IMAGE BUFFER WITH A
         LI,R3    -1                  TRAILING BLANK.
DNOTFND1 AI,R3    1                 FIND THE CHAR POSITION
         CB,R8    IMAGE,R3            OF THAT BLANK.
         BNE      DNOTFND1
         B        NAMEGEND
 PAGE
************************************************************************
*                                                                      *
*  ERRSET IS ENTERED VIA SETERR IN THE INTRINS MODULE.  IT HANDLES THE *
*        END ACTIONS TO BE TAKEN ON AN EXECUTION ERROR.  THERE ARE     *
*        REALLY TWO TYPES OF EXECUTION ERRORS -- THE USUAL ONES (E.G.  *
*        DOMAIN, RANK, SYNTAX, ETC.) ASSOCIATED WITH EXECUTION AND     *
*        COMMAND OR FUNCTION DEFINITION ERRORS RESULTING VIA AN        *
*        EXECUTE-OPERATOR (THESE ARE CALLED XEQ ERRORS).  IN THE XEQ   *
*        ERROR CASE, ERROR-CONTROL HAS ALREADY BEEN TESTED.            *
*                                                                      *
ERRSET   STW,R2   ERRORID           SAVE EXECUTION-ERROR I.D. VALUE.
         LB,R8    ERRO#TBL,R2       GET ERROR NUMBER...
         BNEZ     TESTCTRL            USUAL TYPE.
         LW,R8    BRNVAL              XEQ ERR, IS IT A CONTROLLED ERR...
         BGEZ     CTRL                  YES.
         B        UNCTRL                NO.
TESTCTRL BAL,R7   ECTEST          @ TEST ERROR CONTROL...
         B        CTRL            @   CONTROLLED ERROR.
UNCTRL   LB,R4   *STATEPTR        @   UNCONTROLLED ERROR.
         STB,R4   WHATERR           SAVE F OR Q STATE CATEGORY...
         AI,R4    -CATQ
         BNEZ     ERRFSTAT            F -- FUNCTION OR FINAL STATE.
         LI,R4    EFLAG               Q -- EVAL-INPUT OR EXECUTE...
         CW,R4   *STATEPTR
         BAZ      ERRS                  EVAL-INPUT STATE.
         LW,R4    CURRCS                EXECUTE STATE.
         BNEZ     ERRXEQCS          CODESTRING IS AVAILABLE FOR ERR DIAG
         LW,R4    STATEPTR          CODESTRING NOT YET AVAILABLE.
         LI,R3    X'1FFFF'
         AND,R3   1,R4              PT AT CODESTRING CONTAINING THIS
         STW,R3   CURRCS              EXECUTE-OPERATOR.
         MTW,1    -1,R3             BUMP REF-COUNT OF CODESTRING DATABLK
         LW,R3    1,R4
         SLS,R3   -17               RESTORE BYTE OFFSET USED WHEN THIS
         STW,R3   OFFSET              EXECUTE WAS RECOGNIZED.
         LI,R3    X'7FFF'
         AND,R3   0,R4              UPDATE TO NEXT STATE ENTRY.
         AWM,R3   STATEPTR
         B        UNCTRL
ERRXEQCS BAL,R14  EXERRLNK          HANDLE ERR DIAGNOSTIC & DEREF CURRCS
         LW,R2    ERRORID           WAS IT A BREAK 'MESSAGE'...
         BLZ      UNCTRL              YES, RETAIN BREAK I.D.
         LI,R2    IDXEQERR
         STW,R2   ERRORID             NO, SWITCH TO XEQ ERROR I.D.
         B        UNCTRL
ERRFSTAT LI,R4    PENDFLAG          IS F-ENTRY PENDENT...
         CW,R4   *STATEPTR
         BANZ     ERRP                YES.
         STB,R4   WHATERR             NO, SET CAT=0 -- DIRECT LINE ERR.
         B        ERRS
ERRP     LW,R4    ERRORID           WAS THIS A BREAK...
         BLZ      ERRSUSP             YES, SUSPEND THE FUNCTION.
         LW,R4    SICTRL            TEST STATE INDICATOR CONTROL...
         BNEZ     ERRS                OFF -- DON'T SUSPEND THE FUNCTION.
ERRSUSP  LI,R4    -PENDFLAG-1         ON -- SUSPEND IT.
         AND,R4  *STATEPTR
         STW,R4  *STATEPTR
         LW,R4    STATEPTR          MAKE IT THE 'GO' STATE.
         STW,R4   GOSTATE
ERRS     BAL,R14  DSTRAYS           DEREF ANY EXECUTION STRAYS.
         LI,R14   EXERR             ISSUE LAST ERR DIAGNOSTIC AFTER
         B        SICLR               CLEARING THE STATE INDICATOR DOWN
*                                       TO THE 'GO' STATE.
 PAGE
************************************************************************
*                                                                      *
*  EXERR -- EXECUTION ERROR DIAGNOSTIC DRIVER.  USUALLY DISPLAYS AN    *
*        ERROR MSG & OFFENDING LINE WITH ERROR MARKER.  EXITS TO       *
*        INPDIR OR INPEVAL.                                            *
*                                                                      *
*  EXERRLNK -- ALT. ENTRY PT CALLED FOR 'EXECUTE' OPERATOR ERRORS      *
*        (LINK VIA R14).                                               *
*                                                                      *
*       ALL REGS SHOULD BE CONSIDERED VOLATILE.                        *
*                                                                      *
EXERRLNK STW,R14  SAVE14            SAVE LINK FOR RETURN VIA UNREF.
         LW,R7    BREAKFLG          CK FOR BREAK OR HANGUP...
         BNEZ     UNREF               YES, NO DISPLAY.
         B        EXERR1              NO.
EXERR    LI,R14   EXERREX           SET RETURN FROM UNREF.
         STW,R14  SAVE14
         LCW,R7   BREAKFLG          CK FOR BREAK...
         BGEZ     EXERR1              NOT ON OR ELSE HANGUP.
         AWM,R7   BREAKFLG            ON, RESET BREAK FLAG.
EXERR1   LW,R7    ERRORID           GET ERROR IDENTIFIER.
         LW,R8    IDMSGTBL,R7       GET ERR MSG LOC...
         BEZ      EXNOMSG             NONE (BREAK OR XEQ ERR).
         BAL,R7   WRTEXTCQ            DISPLAY ERR MSG.
EXNOMSG  LB,R7    WHATERR           GET STATE CATEGORY FOR ERROR PT...
         AI,R7    -CATF
         BEZ      FLINERR             FUNCTION LINE.
         LW,R7    BLANKS              DIRECT OR EVAL INPUT LINE OR XEQ.
         STD,R7   IMAGE             BLANK BYTES D-7 OF IMAGE.
         LI,R3    6                 SET FOR COLUMN 7.
SETIMPOS STW,R3   IMAGEPOS          = START PT FOR DECODE OPS.
         LW,R7    ERRORID           CK FOR BREAK I.D...
         BGEZ     EDECODOP            NO, DISPLAY ERR LINE & MARKER.
UNREF    LW,R7    SAVE14            SET RETURN.
         CI,R7    OBSLINE+1         WAS THIS AN OBSERVATION...
         BE       0,R7                YES -- RETURN.
         LI,R4    0                   NO, CLEAR & GET CODESTRING PTR.
         XW,R4    CURRCS
         AI,R4    -2                PT AT CODESTRING DATA BLK HEADER.
*                                   RETURN IS VIA R7.
         B        DREF              DE-REFERENCE THE CODESTRING DATA BLK
EXERREX  LI,R11   0
         STW,R11  ERRORID           CLEAR THE ERROR I.D.
         LW,R11   ON%OFF            ON OR OFF-LINE...
         BEZ      BCONTOFF            OFF LINE -- DO LIKE CONTINUE CMD.
         LB,R11  *STATEPTR            ON LINE.
         AI,R11   -CATQ             IS EVAL-INPUT THE TOP STATE NOW...
         BNEZ     INPDIR              NO -- DO DIRECT INPUT.
         B        INPEVAL             YES -- DO EVAL INPUT AGAIN.
FLINERR  LW,R6    ERRLOC            GET CURRLINO (& FUNCTION NAME PTR).
         LI,R8    X'FFFF'
         AND,R8   ERRLOC            GET FUNCTION NAME PTR.
         BAL,R14  FUNLDIS%          GEN. FUN NAME & LINE NO.
         LI,R12   UNREF             SET EXIT TO UNREF AFTER DISPLAY.
         LW,R8    ERRORID           CK FOR BREAK I.D...
         BLZ      EDUMPLIN            YES -- DISPLAY ONLY FUN NAME & LN.
         LI,R8    LOCKFLAG          IS FUNCTION LOCKED...
         AW,R6    SYMT
         LW,R6    0,R6
         CW,R8    0,R6
         BAZ      SETIMPOS            NO.
         B        EDUMPLIN            YES -- DISPLAY ONLY FUN NAME & LN.
 PAGE
*
*  OBSERVER -- DISPLAYS AN OBSERVATION: LINE & MARKER PLUS A VALUE.
*
OBSERVER LW,R15   ERRLOC            SAVE ERROR LOCATION.
         LCI      0                 SAVE ALL REGS.
         STM,R0   OBSAVE
         LI,R2    IDXEQERR          CLAIM THIS IS AN 'XEQ ERR' TO AVOID
         STW,R2   ERRORID             DISPLAYING AN ERROR MSG.
         LB,R4   *STATEPTR
         STB,R4   WHATERR           SAVE F OR Q STATE CATEGORY...
         AI,R4    -CATQ
         BEZ      OBSLINE             Q-STATE.
         LI,R4    PENDFLAG            F-STATE.
         CW,R4   *STATEPTR          PENDENT OR SUSPENDED...
         BANZ     OBSFLINE            PENDENT (SHOW FUN.NAME & LN).
         STB,R4   WHATERR             SUSPENDED (DIRECT INPUT LINE).
OBSLINE  BAL,R14  EXERRLNK        @ SHOW LINE & MARKER, DON'T DE-CURRCS.
         LW,R4    OBSAVE+6        @ PT AT DATA BLK TO BE OBSERVED.
         BAL,R14  SINGOUT          @  DISPLAY THAT VALUE.
         B        %+1              @    SCREW ERROR RETURN.
         LCI      0                @    NORMAL RETURN.
         LM,R0    OBSAVE            RESTORE ALL REGS.
         STW,R15  ERRLOC            RESTORE ERROR LOCATION.
         B        OBSERVEZ          EXIT FROM THIS OBSERVATION.
OBSFLINE LW,R4    STATEPTR          PT AT THE F-STATE.
         LI,R14   X'E0000'          EXTRACT CURR.LINE NO.
         AND,R14  1,R4
         LW,R4    1,R4              PT AT FUNC.DESCR.
         AW,R14   FNOFF,R4          INCLUDE FUN.NAME PTR.
         STW,R14  ERRLOC            TEMP. SET ERRLOC.
         B        OBSLINE
 PAGE
CTRL     LI,R4    0                 CLEAR & TEST CODESTRING PTR...
         STW,R4   ERRORID             (CLEAR THE ERROR I.D.)
         XW,R4    CURRCS
         BEZ      CTRLS               NOT CURRENTLY IN USE.
         AI,R4    -2                  USED, PT AT CODESTRING D.B. HDR.
         BAL,R7   DREF              DEREFERENCE THAT DATA BLOCK.
CTRLS    BAL,R14  DSTRAYS           DEREF ANY EXECUTION STRAYS.
         BAL,R14  SICLR             CLEAR STATE INDIC. DOWN TO 'GO'STATE
         LCW,R12  BREAKFLG          TEST BREAK FLAG...
         BGEZ     ECBRANCH            OFF OR HANGUP -- DO ERR-CTRL BRNCH
         B        BCBRANCH            ON -- RESET & DO ERR-CTRL BRANCH.
ERRN     LI,R11   6
         BAL,R7   ALOCBLK           ALLOCATE 6-WD DATA BLK.
         STW,R4   RESULT            SAVE PTR TO RESULT DATA BLK.
         LI,R11   (TYPEINTG**8)+1   TYPE = INTEGER & RANK = 1.
         STH,R11 *RESULT
         LI,R11   2                 LENGTH = 2.
         STW,R11  2,R4
         LW,R11   ERRNUM
         STW,R11  3,R4              SET ERROR NUMBER.
         LW,R11   ERRLOC
         SLS,R11  -17               SET ERROR LINE NUMBER (OR ZERO).
         STW,R11  4,R4
         B        NIRETURN          RETURN FROM NILADIC INTRINSIC.
ERRF     LI,R12   0                 PREPARE FOR EMPTY ERROR LOC.
         LW,R2    ERRLOC            IF FUNC.ERR, GET CURRLINO & NAME PTR
         CI,R2    X'E0000'          IS THERE A CURRENT LINE NO...
         BAZ      EFNALOC             NO -- USE EMPTY FUNCTION NAME.
         AI,R2    1                 = OFFSET TO FUN'S NAME INDIC. WD.
         LW,R3   *SYMT,R2           GET NAME INDICATOR WD.
         LB,R12   R3                GET # WDS FOR THAT NAME (UNLESS IT
         CI,R12   20                  IS A SHORT NAME).
         BLE      EFNALOC           LONG NAME.
         LI,R12   1                 SHORT NAME, 1 WD IN R3 ALREADY.
EFNALOC  LW,R11   R12               = NO.OF WDS FOR FUNCTION NAME.
         AI,R11   1                 ADD 1 FOR THE VECTOR LENGTH WD.
         BAL,R7   ALOCHNW           ALLOC DATA BLK, INCLUDING HEADER.
         STW,R4   RESULT            SAVE PTR TO RESULT DATA BLK.
         LI,R11   (TYPETEXT**8)+1   TYPE = TEXT & RANK = 1.
         STH,R11 *RESULT
         AI,R4    2                 PT AT LENGTH WD.
         LW,R11   R12               GET # WDS FOR NAME...
         BEZ      EFNLEN              NONE (EMPTY TEXT VECTOR).
         CI,R11   1
         BE       EFNMOV              ONE (NAME WD IS ALREADY IN R3).
         LW,R5   *SYMT,R2             LONG, PT AT 1ST WD OF LONG NAME.
EFNGET   LW,R3    0,R5              GET NAME WD.
         AI,R5    1                 PT AT NEXT WD OF LONG NAME DATA BLK.
EFNMOV   AI,R4    1                 PT AT NEXT WD OF RESULT.
         STW,R3   0,R4              STORE NAME WD.
         BDR,R12  EFNGET            LOOP TILL LAST NAME WD STORED.
         SW,R4    R11               PT AT LENGTH WD AGAIN.
         SLS,R11  2                 = NO.OF BYTES MOVED.
EFNBLCK  CB,R3    BLANKS            CK FOR TRAILING BLANK IN NAME...
         BNE      EFNLEN              NO, R11 = # CHARS IN NAME.
         SLS,R3   -8                  YES, DROP THAT BLANK.
         BDR,R11  EFNBLCK           DECR. BYTE COUNT & LOOP.
EFNLEN   STW,R11  0,R4              SET TEXT VECTOR'S LENGTH.
         B        NIRETURN          RETURN FROM NILADIC INTRINSIC.
ERRX     LI,R11   4
         BAL,R7   ALOCBLK           ALLOCATE 4-WD DATA BLK.
         STW,R4   RESULT            SAVE PTR TO RESULT DATA BLK.
         LI,R11   (TYPETEXT**8)+1   TYPE = TEXT & RANK = 1.
         STH,R11 *RESULT
         LI,R11   4                 LENGTH = 4.
         STW,R11  2,R4
         AI,R4    3                 PT AT VALUE WORD.
         SLS,R4   2                 PT AT 1ST VALUE BYTE POS.
         BAL,R14  HEXIO             START GETTING I/O ERR CODE & SUBCODE
         STB,R6   0,R4              SET VALUE BYTE (EBCDIC HEX DIGIT).
         AI,R4    1                 PT AT NEXT VALUE BYTE.
         BDR,R11  HEXCHAR           LOOP TILL LAST HEX CHAR SET.
         B        NIRETURN          RETURN FROM NILADIC INTRINSIC.
 PAGE
************************************************************************
 SPACE 2
Z        SET      %-ERROR@                       SIZE IN HEX.
 SPACE
Z        SET      Z+Z/10*6+Z/100*96+Z/1000*1536  SIZE IN DECIMAL.
 SPACE 3
         END

