! PASCAL DIAGNOSTICS RELEASE 1
! Mike Brown - September 1980
!
%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)
!
%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, LOOPCOUNT, 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
      %IF ERRNO = 1100 %OR ERRNO = 1200 %THEN %START                            ;! SPECIAL CASE - RANGE ERRORS
         NEWLINES(4)
         PRINTSTRING("PASCAL ERROR:")
         WRITE(ERRNO,1)
         NEWLINE
         PRINTSTRING("DESCRIPTION: ")
         %IF ERRNO = 1100 %THEN PRINTSTRING("VALUE OUT OF RANGE OF ORDINAL TYPE")
         %IF ERRNO = 1200 %THEN PRINTSTRING("NO LABEL FOR VALUE OF ""CASE"" STATEMENT SELECTOR EXPRESSION")
         NEWLINE
         PRINTSTRING("LOCATION: BYTE DISPLACEMENT X")
         PHEX(DISPLACEMENT,8)
         NEWLINE
         SPACES(10)
         PRINTSTRING("IN CODE AREA")
         NEWLINE
         SPACES(10)
         PRINTSTRING("OF MODULE ".FILENAME." COMPILED ON ".DATE." AT ".TIME)
         NEWLINE
         SPACES(10)
         PRINTSTRING("NO DIAGNOSTICS FOR RANGE ERRORS")
         NEWLINE
         %STOP
      %FINISH
      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