! PASCAL DIAGNOSTICS RELEASE 4
! Mike Brown
! RELEASE 2 - February 1981
! RELEASE 3 - DOES NOT EXIST AS ROSEMARYS AND MY NUMBERING GOT OUT OF PHASE
! RELEASE 4 - NOVEMBER 1981
!
%SYSTEMROUTINESPEC ITOE (%INTEGER ADDR, LEN)
%SYSTEMROUTINESPEC DUMP (%INTEGER S, F)
%SYSTEMROUTINESPEC FINFO (%STRING (31) FILE, %INTEGER MODE, %C
%RECORDNAME R, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC NCODE (%INTEGER S, F, A)
%SYSTEMSTRINGFNSPEC ITOS (%INTEGER INT)
%SYSTEMSTRINGFNSPEC CONFILE (%INTEGER AD)
%SYSTEMSTRINGFNSPEC FAILUREMESSAGE (%INTEGER ERROR)
!
%EXTERNALINTEGERFNSPEC ICL9LPPMPROCL (%INTEGER ERRNO, PROCNO, GROUP, %LONGINTEGER EMESS, %C
%INTEGER LANG0, LANG1, DISPLACEMENT, %LONGINTEGER DIAGREC, %INTEGER MODCHAINENTRY0, %C
MODCHAINENTRY1, AREAENTRY0, AREAENTRY1,STACKFRAME0, STACKFRAME1)
%EXTERNALINTEGERFNSPEC ICL9LPPMPROCR (%INTEGER DIAGNOSTICS, ARRAYSIZE, DISPLACEMENT, %C
STACKFRAME0, STACKFRAME1, %LONGINTEGER DIAGREC, %INTEGER MODCHAINENTRY0, %C
MODCHAINENTRY1, AREAENTRY0, AREAENTRY1, AREASOFENTRY0, AREASOFENTRY1)
%EXTERNALINTEGERFNSPEC ICL9HERRMESSP (%INTEGER ERRNO0, ERRNO1, %LONGINTEGERNAME EMESS)
!
%RECORDFORMAT RF (%INTEGER CONAD, FILETYPE, DATASTART, DATAEND, %C
SIZE, RUP, EEP, MODE, USERS, ARCH, %STRING (6) TRAN, %C
%STRING (8) DATE, TIME, %INTEGER COUNT, SPARE1, SPARE2)
!
%EXTERNALINTEGER LOOPCOUNT
%EXTERNALBYTEINTEGER FLAGABORT
!
%CONSTBYTEINTEGERARRAY HEX (0:15) = %C
'0', '1', '2', '3', '4', '5', '6', '7', %C
'8', '9', 'A', 'B', 'C', 'D', 'E', 'F'
!
%ROUTINE PHEX (%INTEGER VALUE, PLACES)
%INTEGER Z
%CYCLE Z = PLACES << 2 - 4, -4, 0
PRINTSYMBOL(HEX(VALUE >> Z & 15))
%REPEAT
%END
!
%ROUTINE ABORT (%INTEGER CODE, PC, LNB)
%INTEGER W
PRINTSTRING("ABORT")
WRITE(CODE,1)
NEWLINE
PRINTSTRING("PC =")
PHEX(PC,8)
PRINTSTRING(" ; LNB =")
PHEX(LNB,8)
NEWLINE
PRINTSTRING("CODE")
NEWLINE
NCODE(PC - 64,PC + 64,PC - 64)
NEWLINE
PRINTSTRING("GLA")
NEWLINE
W = INTEGER(LNB + 16)
DUMP(W,W + 128)
NEWLINE
PRINTSTRING("STACKFRAME")
NEWLINE
DUMP(LNB,LNB + 256)
FLAGABORT = 1
%MONITOR
%STOP
%END
!
! PASCAL DIAGNOSTIC ROUTINE CALLED FROM SUBSYSTEM NDIAG MASTER DIAGNOSTIC ROUTINE
! CALLED ON TWO OCCASIONS (1) TO PRINT OUT NATURE OF ERROR (AS DOES ERRMESS FOR IMP)
! (2) TO ENTER PASCAL DIAGNOSTIC TRACEBACK PROCEDURES
! PARAMETERS
! OLDLNB - FOR (1) WHEN SET TO 1 INDICATES A CONTINGENCY ERROR
! FOR (2) CONTAINS LNB OF STACK FRAME TO BE EXAMINED
! PC - FOR (1) CONTAINS INTERRUPT WEIGHT
! FOR (2) CONTAINS PC OF FAILED ROUTINE
! ASIZE - FOR (1) CONTAINS ERROR NUMBER (CONTINGENCY OR PROGRAM)
! FOR (2) CONTAINS NUMBER OF ARRAY ELEMENTS TO BE PRINTED
! FIRST - -1 = ERROR MESSAGE CALL ON PDIAG
! - 1 = FIRST DIAGNOSTIC CALL ON PDIAG
! - 0 = SUBSEQUENT DIAGNOSTIC CALLS ON PDIAG
! NEWLNB - LNB OF PREVIOUS STACKFRAME (NEXT TO BE ANALYSED)
!
%SYSTEMROUTINE PDIAG (%INTEGER OLDLNB, PC, ASIZE, %INTEGERNAME FIRST, NEWLNB)
%RECORDFORMAT MAPMODULEENTRYFM (%BYTEINTEGER TYPE, LANGUAGE, %HALFINTEGER ENTRYSIZE, %C
%INTEGER CHAIN, VERSION, %BYTEINTEGERARRAY DATE (1:10), TIME (1:8), %C
%BYTEINTEGER NAMEUSE, %STRING (32) NAME)
%RECORD R(RF)
%OWNRECORD MODCHAIN(MAPMODULEENTRYFM)
%OWNLONGINTEGER EMESSADDR, EMESS, DR0
%OWNINTEGER ERRNO, MOD1, DISPLACEMENT, DR1 , NEARBASE, RFIRST
%LONGINTEGER DIAGREC, LANGUAGE
%CONSTINTEGER BYTEVECT = X'18000000'
%CONSTINTEGER WORDVECT = X'28000001'
%INTEGER FLAG, ERRNO0, ERRNO1, LANG1, LANG0, SF0, SF1, MOD0, AREA0, AREA1, %C
AREAMOD0, AREAMOD1, EMESS0, EMESS1, DATETIME, W, FILETYPE, START, %C
ADIR
%STRING (31) FILENAME, SUBFILE, NEARNAME
%STRING (10) DATE
%STRING (8) TIME
%STRING (2) T1, T2, T3, D1, D2, D3
%OWNSTRING (255) MESSAGE
%IF FLAGABORT = 1 %THEN %START ;! TO PREVENT DIAGNOSTICS LOOPING
PRINTSTRING("DIAGNOSTICS LOOPING")
NEWLINE
%STOP
%FINISH
%IF FIRST = -1 %THEN %START ;! ERROR MESSAGE CALL ON PDIAG
%IF LOOPCOUNT = 1 %THEN %START
PRINTSTRING("DIAGNOSTICS LOOPING")
NEWLINE
%STOP
%FINISH
LOOPCOUNT = 1
FIRST = 1
%IF OLDLNB > 0 %THEN %START ;! CONTINGENCY SIGNALLED
NEWLINE
MESSAGE = FAILUREMESSAGE(ASIZE) ;! CONTINGENCY ERROR MESSAGE
%IF ASIZE = 10 %THEN MESSAGE = MESSAGE." ".ITOS(PC)
MESSAGE = FROMSTRING(MESSAGE,1,LENGTH(MESSAGE) - 1)
%IF OLDLNB = 1 %THEN MESSAGE = "CONTINGENCY ERROR (".MESSAGE.") "
%IF OLDLNB = 2 %THEN MESSAGE = "MATHS ERROR (".MESSAGE.") "
ITOE(ADDR(MESSAGE) + 1,LENGTH(MESSAGE) + 1)
DR0 = BYTEVECT ! LENGTH(MESSAGE) + 1
DR1 = ADDR(MESSAGE) + 1
EMESS = DR1 ! (DR0 << 32)
ERRNO = ASIZE
%RETURN
%FINISH
! MESSAGE FOR NON-CONTINGENCY ERROR
ERRNO = ASIZE
ERRNO0 = WORDVECT
ERRNO1 = ADDR(ASIZE)
EMESS0 = X'B0000001'
EMESS1 = ADDR(EMESSADDR)
EMESS = EMESS1 ! (EMESS0 << 32)
;! CALL ERROR MESSAGE PROCEDURE
FLAG = ICL9HERRMESSP(ERRNO0,ERRNO1,EMESS)
%IF FLAG # 0 %THEN ABORT(160,PC,OLDLNB)
%RETURN
%FINISH
%IF FIRST = 1 %THEN %START ;! FIRST DIAGNOSTIC CALL ON PDIAG
FIRST = 0
FILENAME = CONFILE(PC) ;! FILE SIGNALLING FAILURE
FINFO(FILENAME,0,R,FLAG)
FILETYPE = INTEGER(R_CONAD + X'C')
%IF FILETYPE = 1 %THEN %START ;! EMAS 2900 OBJECT FILE
DISPLACEMENT = PC - R_CONAD - X'20'
DATETIME = INTEGER (R_CONAD + X'14')
NEARBASE = R_CONAD
%FINISH
%IF FILETYPE = 6 %THEN %START ;! PARTITIONED FILE
NEARNAME = ""
NEARBASE = 0
ADIR = INTEGER(R_CONAD + X'18') + R_CONAD
%CYCLE W = 1, 1, INTEGER(R_CONAD + X'1C') ;! FIND FAILING SUBFILE
START = INTEGER(ADIR) + R_CONAD
SUBFILE = STRING(ADIR + 4)
%IF START < PC %AND START > NEARBASE %THEN %START
NEARBASE = START
NEARNAME = SUBFILE
%FINISH
ADIR = ADIR + 32
%REPEAT
DISPLACEMENT = PC - NEARBASE - X'20'
DATETIME = INTEGER(NEARBASE + X'14')
FILENAME = FILENAME."_".NEARNAME
%FINISH
T1 = ITOS((DATETIME & X'1F000') >> 12) ;! UNPACK DATE AND TIME
T2 = ITOS((DATETIME & X'FC0') >> 6)
T3 = ITOS(DATETIME & X'3F')
D1 = ITOS((DATETIME & X'3E0000') >> 17)
D2 = ITOS((DATETIME & X'3C00000') >> 22)
D3 = ITOS(70 + (DATETIME & X'7C000000') >> 26)
%IF LENGTH(T1) = 1 %THEN T1 = "0".T1 ;! INSERT LEADING ZEROES
%IF LENGTH(T2) = 1 %THEN T2 = "0".T2
%IF LENGTH(T3) = 1 %THEN T3 = "0".T3
%IF LENGTH(D1) = 1 %THEN D1 = "0".D1
%IF LENGTH(D2) = 1 %THEN D2 = "0".D2
DATE = D1."/".D2."/19".D3
TIME = T1.".".T2.".".T3
ITOE(ADDR(FILENAME) + 1, LENGTH(FILENAME)) ;! FILENAME TO EBCDIC
ITOE(ADDR(TIME) + 1,8)
ITOE(ADDR(DATE) + 1,10)
%CYCLE W = 1, 1, 10
MODCHAIN_DATE(W) = CHARNO(DATE,W)
%IF W <= 8 %THEN MODCHAIN_TIME(W) = CHARNO(TIME,W)
%REPEAT
MODCHAIN_TYPE = 16 ;! FILL IN MODULE CHAIN ENTRIES
MODCHAIN_LANGUAGE = X'D7'
MODCHAIN_ENTRYSIZE = 64
MODCHAIN_CHAIN = X'FFFFFFFF'
MODCHAIN_VERSION = X'C5D4C1E2'
MODCHAIN_NAMEUSE = 0
MODCHAIN_NAME = FILENAME
LANGUAGE = X'F7D7C1E2C3C1D340'
LANG0 = BYTEVECT ! 8
LANG1 = ADDR(LANGUAGE)
DIAGREC = 0
MOD0 = BYTEVECT ! 1
MOD1 = ADDR(MODCHAIN)
AREA0 = 0
AREA1 = 0
SF0 = WORDVECT ! (ADDR(OLDLNB) - OLDLNB)
SF1 = OLDLNB
;! CALL ERROR LINE PROCEDURE
FLAG = ICL9LPPMPROCL(ERRNO,0,0,EMESS,LANG0,LANG1,DISPLACEMENT,DIAGREC,MOD0, %C
MOD1,AREA0,AREA1,SF0,SF1)
%IF FLAG > 0 %THEN ABORT(161,PC,OLDLNB)
NEWLNB = OLDLNB
RFIRST = 1
%RETURN
%FINISH
%IF FIRST = 0 %THEN %START ;! SUBSEQUENT DIAGNOSTIC CALL ON PDIAG
%IF RFIRST = 1 %THEN RFIRST = 0 %ELSE DISPLACEMENT = PC - NEARBASE - X'20'
SF0 = WORDVECT ! (ADDR(OLDLNB) - OLDLNB)
SF1 = OLDLNB
DIAGREC = 0
MOD0 = BYTEVECT
MOD1 = ADDR(MODCHAIN)
AREA0 = 0
AREA1 = 0
AREAMOD0 = 0
AREAMOD1 = 0
;! CALL POST MORTEM REPORT PROCEDURE
FLAG = ICL9LPPMPROCR(4,ASIZE,DISPLACEMENT,SF0,SF1,DIAGREC,MOD0, %C
MOD1,AREA0,AREA1,AREAMOD0,AREAMOD1)
%IF FLAG > 0 %THEN ABORT(162,PC,OLDLNB)
NEWLNB = INTEGER(OLDLNB)
%FINISH
%END ;! OF PDIAG
!
%ENDOFFILE