SPL,L,M,O,T,C 
       NAME DGLST(8) "REV G  770323"
!           REV-G 03/23/77
!      DIAGNOSTIC PRINT ROUTINE 
!      PRINTS A DIAGNOSTIC MESSAGE ON THE TELETYPE AND OTHER
!      INFORMATION, ACCORDING TO THE ERROR CODE.
! 
!      ERROR CODES 1-49 DO NOT CAUSE AN ABORT, UNLESS THE "ABORT
!      IF ERRORS" FLAG IS SET.  IF THE COMMAND FILE IS NOT THE
!      TTY, THEN THE POSITION OF THE PREVIOUS FILE, NAME, ETC., 
!      IS SAVED(STACKED) AND THE COMMAND FILE IS SETUP TO 
!      COME FROM THE TTY. COMMAND CONTROL CAN BE RETURNED BY A
!      "TR" COMMAND WITH NO FILE ATTACHED.
! 
!      ONLY ERROR CODES 1-21 AND 50 ARE IMPLEMENTED.
! 
       LET BUF BE INTEGER(40) 
       INITIALIZE BUF TO " V        " 
       LET ABRT BE INTEGER(6) 
       INITIALIZE ABRT TO "SXL ABORTED "
       LET JTY,JLU,JSEC,OFF,RS,REC,NAM3,NAM2,NAM1\
         BE INTEGER 
       LET IAILU BE INTEGER,EXTERNAL
       LET UMAIN BE LABEL,EXTERNAL
       LET STAK,SVLU BE PSEUDO,EXTERNAL 
       LET XCOM,DNFLG,CCPTR,PTPTR,SOURC BE INTEGER,EXTERNAL 
       LET TRSTK,SODC4,INLU,ASTAK,ERR,CMDLN BE INTEGER,EXTERNAL 
       LET LAST ,WKTOP BE INTEGER,EXTERNAL
       LET ERR,FILEX,ABRTF,LOCC,BPLOC,FWAM,LWAM,XMAXA,DCBBO,DCBB4,\ 
       LWABP,LCOMM,ABRTF,BPLOC BE INTEGER,EXTERNAL
       LET LISTO,LSTLU BE INTEGER,EXTERNAL
       LET NXSY,CCON BE FUNCTION,EXTERNAL 
       LET MSTBL,.XEC,.GOTO,BLNK,UNSTR ,\ 
       STPRG,TRBAK,\
       OCTAQ,DECV,MOVE., EXEC BE SUBROUTINE,EXTERNAL
       LET PSER BE SUBROUTINE 
       LET OBT BE INTEGER(41),EXTERNAL
       LET LOCF,CLOSE,ILOSE,FKDCB BE SUBROUTINE,EXTERNAL
! 
DGLST: SUBROUTINE(ERRNO,DATA) GLOBAL
       LET ERRNO BE INTEGER            !ERROR NUMBER CODE 
       LET DATA BE INTEGER             !DATA FOR ERROR PRINTOUT 
! 
       LET SER1,SER2,SER3,SER4,SER5,SER6,SER7 ,SER8,SER9,SER10,\
       SER11,SER12,SER13,SER14,SER15,SER16,SER17,SER18,SER19,\
       SER20,SER21,\
       SER50 BE LABEL 
       DNFLG_0; CALL STPRG(SOURC); CALL STPRG(CCPTR); CALL STPRG(PTPTR) 
       CALL .XEC(2,OBT(2),CMDLN)
!      JUMP TO PROPER ERROR CODE PROCESSOR
       CALL .GOTO(ERRNO,SER1,SER2,SER3,SER4,SER5,\
       SER6,SER7,SER8,SER9,SER10,\
       SER11,SER12,SER13,SER14,SER15,\
       SER16,SER17,SER18,SER19,\
       SER20,SER21,\
       SER50) 
!      ERROR # 1--NO NAM RECORD IN RELOCATABLE INPUT
       LET M1 BE INTEGER(6) 
       INITIALIZE M1 TO "NO NAM RCRD."
SER1:  CALL .XEC(2,M1,6)
       GOTO SER4. 
!      ERR #2-- ILLEGAL RECORD TYPE 
       LET M2 BE INTEGER(7) 
       INITIALIZE M2 TO "ILL.RCRD TYPE."
SER2:  CALL .XEC(2,M2,7)
       GOTO SER4. 
!      ERROR # 3--ILLEGAL EXT ORDINAL IN DBL RECORD 
       LET M3 BE INTEGER(4) 
       INITIALIZE M3 TO "ILL.EXT."
SER3:  CALL .XEC(2,M3,4)
       GOTO SER4. 
!      ERROR #4--CAN'T ALLOCATE ANY LINK. 
       LET M4 BE INTEGER(6) 
       INITIALIZE M4 TO "NO LINK ROOM"
SER4:  CALL .XEC(2,M4,6)
SER4.: CALL PSER(DATA)
!      ERROR 5--SCANNER FAILURE. ILLEGAL CHARACTER
       LET M5 BE INTEGER(5) 
       INITIALIZE M5 TO "ILL.CHAR  "
SER5:  M5(5)_DATA OR 20000K 
       CALL .XEC(2,M5,5)
       GOTO SRTRN 
!      ERR #6/-- PARSING ERROR
       LET M6 BE INTEGER(9) 
       INITIALIZE M6 TO "UNRECOGNIZED STMT."
SER6:  CALL .XEC(2,M6,9)
       GOTO SRTRN 
!      ERR #7 ILLEGAL LINKS START AT ADDRESS
       LET M7 BE INTEGER(21)
       INITIALIZE M7 TO "ILL.LINKS STRT ADDR.=       BPLOCC=       "
SER7:  T1_[T_@M7+11]+7
       CALL OCTAQ($T,DATA); CALL OCTAQ($T1,BPLOC) 
       CALL .XEC(2,M7,21) 
       GOTO SRTRN 
!      ERROR # 8--MEMORY OVERFLOW 
       LET LOCC,LWAM BE INTEGER,EXTERNAL
       LET M8 BE INTEGER(16)
       INITIALIZE M8 TO "MEM OVF LOCC=       LWAM=      " 
SER8:  T1_[T_@M8+7]+5 
       CALL OCTAQ($T,LOCC); CALL OCTAQ($T1,LWAM)
       CALL .XEC(2,M8,16) 
       GOTO SER4. 
!      ERROR #9-- BP OVERFLOW 
       LET M9 BE INTEGER(18)
       INITIALIZE M9 TO "BP MEM OVF BPLOCC=      LWABP=      "
SER9:  T1_[T_@M9+9]+6 
       CALL OCTAQ($T,BPLOC); CALL OCTAQ($T1,LWABP)
       CALL .XEC(2,M9,18) 
       GOTO SER4. 
!      ERROR # 10--FILE MANAGER CREATE ERROR
       LET M10 BE INTEGER(12) 
       INITIALIZE M10 TO "CREAT         ERR       " 
SER10: T1_[T_[T3_@M10]+3]+6 
SR10:  CALL MOVE.($DATA,$T,3); CALL DECV($T1,ERR,I) 
       CALL .XEC(2,$T3,(I+19)>-1) 
       GOTO SRTRN 
!      ERROR # 11 -- FILE MANAGER OPEN ERROR
       LET M11 BE INTEGER(12) 
       INITIALIZE M11 TO "OPEN          ERR       " 
SER11: T1_[T_[T3_@M11]+3]+6; GOTO SR10
!      ERROR 12 -- SET $(<EXPR>) WHERE EXPR EVALUATES < 2 
       LET M12 BE INTEGER(12) 
       INITIALIZE M12 TO "EVAL.ERR,EXPR=      (8) " 
SER12: T_@M12+7 
       CALL OCTAQ($T,DATA)
       CALL .XEC(2,M12,12)
       GOTO SRTRN 
!      ERROR 13 -- BP LNTH IN NAM RECORD <0 
       LET M13 BE INTEGER(6)
       INITIALIZE M13 TO "ILL.BP LNTH " 
SER13: CALL .XEC(2,M13,6) 
       GOTO SER4. 
!      ERROR # 14 -- COMMON BLOCK ERROR 
       LET M14 BE INTEGER(20) 
       INITIALIZE M14 TO "COMMON LNTH ERR,LNTH=       ,NOW=       " 
SER14:  T1_[T_@M14+11]+6
       CALL OCTAQ($T,XCOM); CALL OCTAQ($T1,LCOMM) 
       CALL .XEC(2,M14,20); DATA_0
       GOTO SER4. 
!      ERROR # 15 -- NAM OUT OF SEQUENCE
       LET M15 BE INTEGER(8)
       INITIALIZE M15 TO "NAM OUT OF SEQ."
SER15: CALL .XEC(2,M15,7 )
       GOTO SER4. 
!      ERROR 16 -- FILE READ OR WRITE ERROR 
           LET M16 BE INTEGER(22) 
       INITIALIZE M16 TO "FILE READ OR WRITE ERR=       FILE =       "
SER16: T1_[T_@M16+12]+6 
       CALL DECV($T,ERR,I); CALL MOVE.($DATA,$T1,3) 
       CALL .XEC(2,M16,22)
       GOTO SRTRN 
!      ERROR # 17 -- NO COMMAND ID CHARACTER AND NON-KEYBOARD CMND INPUT
       LET M17 BE INTEGER(5)
       INITIALIZE M17 TO "NO CMND ID" 
SER17: CALL .XEC(2,M17,5) 
       GOTO SRTRN 
!      ERROR # 18 -- ABORT BECAUSE OF UNDEFINEDS(ABORT IF UNDEFS SET) 
       LET M18 BE INTEGER(6)
       INITIALIZE M18 TO "UNDEFS ABORT" 
SER18: CALL .XEC(2,M18,6) 
       GOTO SRTT
!      ERROR 19 -- NO MAIN PROGRAM
       LET M19 BE INTEGER(6)
       INITIALIZE M19 TO "NO MAIN PRGM" 
SER19: CALL .XEC(2,M19,6) 
       GOTO SRTRN 
!      ERROR 20 --DUPLICATE ABSOLUTE FILE 
       LET M20 BE INTEGER(7)
       INITIALIZE  M20 TO "DUPL.ABS.FILE" 
SER20: CALL .XEC(2,M20,7); GOTO  SRTRN
! 
!ERROR 21 ABORT SXL 
       SER21: GOTO SRTT 
       LET M50 BE INTEGER(9)
       INITIALIZE M50 TO "WORKSPACE OVERFLOW" 
!      ERROR 50 -- WORKSPACE OVERFLOW 
SER50: CALL .XEC(2,M50,9) 
       GOTO SRTT
! 
SRTRN: IFNOT(ABRTF AND 2) THEN GOTO TRTTY 
SRTT:  CALL .XEC(2,ABRT,6)
       CALL EXEC(5,-1)                 !RELEASE DISC TRACKS 
       $(@DCBB4+15)_0        !SET CURRENT EXTENT# TO 0 FOR PURGING
       IF DCBB4 THEN CALL CLOSE(DCBB4,ERR,48)!PURGE ABS. FILE 
       IF(LISTO AND 27K)THEN CALL EXEC(3,1100K+LSTLU,-1)
       ALWAYS DO\ CLOSE ALL TRANSFER FILES
       [CALL ILOSE($SODC4,ERR);\
        IF TRSTK THEN CALL TRBAK, ELSE CALL EXEC(6)]
TRTTY: CALL LOCF($SODC4,ERR,REC,RS,OFF,JSEC,JLU,JTY)
       IF IAILU = 0 THEN \    DON'T STACK IF FILE = TTY 
       [CALL ILOSE($SODC4,ERR); T_@JTY; REPEAT 6 TIMES DO\
       [STAK(TRSTK)_$T; T_T+1]; T_SODC4; REPEAT 3 TIMES DO\ 
       [T_T-1; STAK(TRSTK)_$T]; \ 
       INLU_401K; CALL FKDCB($SODC4,INLU,0,0,100000K)]
       GOTO UMAIN 
       END
PSER:  SUBROUTINE(PROG) 
       LET PSERM BE INTEGER(14) 
       INITIALIZE PSERM TO "FILE NAME=       NAME=      " 
       T1_[T_@PSERM+5]+6
       CALL MSTBL(FILEX,$T,I); IF PROG THEN\
       [T2_CCON(PROG); CALL UNSTR(PROG,$T1,T2); I_17] 
       CALL .XEC(2,PSERM,((I+11)>-1)) 
       GOTO SRTRN 
       END
       END
END$
                                                                                                                                                        