!*_ DATED 11 NOV 76 1
! ALTERATIONS BY K.YARWOOD ...
! PRINT FL AND NEXT SYMBOL LINES COMMENTED OUT
! PRINTTEXT'S TURNED TO PRINTSTRING'S
! ADDITION FOR LONGINTEGER IN RT PRINT VAR
! HEX EQUIVALENTS FOR INTS,LONGINTS ETC PRINTED
! INF PRINTED IN HEX IN RT ERRMESS
EXTERNALSTRINGFNSPEC STRHEX(INTEGER I)
EXTERNALSTRING (8)FNSPEC STRINT(INTEGER I)
CONSTINTEGER STACKBASE=X'80100000'; ! START OF RESIDENT STACK
! %SYSTEMROUTINESPEC SIGNAL(%INTEGER I, J, K, %INTEGERNAME F)
ROUTINESPEC PRINTMESS(INTEGER N)
! %SYSTEMROUTINESPEC TIDY EXIT
!*
ROUTINESPEC INDIAG(INTEGER OLDLNB, L, PC, INTEGERNAME NEWLNB)
! %ROUTINESPEC FDIAG(%INTEGER OLDLNB,PC,%INTEGERNAME NEWLNB)
ROUTINESPEC ERMESS(INTEGER N, INF)
! %ROUTINESPEC ICL9CELABELS
ROUTINE TRANS(INTEGERNAME FAULT, EVENT, SUBEVENT)
!***********************************************************************
!*_______TRANSLATE FAULT TO EVENT & VICE VERSA *
!***********************************************************************
CONSTBYTEINTEGERARRAY ETOF(0:54)=0,14,22,24,26,28,35,38,40,42,44,47,
0(3),3,1,5,54,56,53,19,0,23,0,28,0,26,
0,18,50,51,16,15,20,0,7,6,0,32,0,11,0,
25,0,54,0,72,73,71,74,75,70,0,30
CONSTBYTEINTEGERARRAY FTOE(1:75)=X'12',0,X'11',0,X'13',X'62',X'61',0,
0(2),X'81',0(3),X'55',X'54',
0,X'51',X'17',X'56',0(4),
X'91',X'41',0,X'31',0,X'B1',0,X'71',
0(17),X'52',X'53',X'53',X'16',
X'14'(4),0(8),X'14'(2),0(2),
X'A6',X'A3',X'A1',X'A2',X'A4',X'A5'
INTEGER K
IF FAULT=0 THEN START ; ! EVENT-SUBEVENT GIVEN
K=ETOF(EVENT)
IF K#0 THEN FAULT=ETOF(K+SUBEVENT)
FINISH ELSE START
IF 1<=FAULT<=75 START
K=FTOE(FAULT)
EVENT=K>>4; SUBEVENT=K&15
FINISH
FINISH
END ; ! TRANS
ROUTINE DUMP(INTEGER START, FINISH)
INTEGER I, J
I=START&(-4)
WHILE I<=FINISH CYCLE
PRINTSTRING(STRHEX(I))
CYCLE J=0,4,12
SPACES(2)
PRINTSTRING(STRHEX(INTEGER(I+J)))
REPEAT
NEWLINE
I=I+16
REPEAT
END ; ! DUMP
ROUTINE ASSDUMP(INTEGER PCOUNT, OLDLNB)
INTEGER I
PRINTSTRING("
PC =")
PRINTSTRING(STRHEX(PCOUNT))
PRINTSTRING("
LNB =")
PRINTSTRING(STRHEX(OLDLNB))
PRINTSTRING("
GLA
")
I=INTEGER(OLDLNB+16)
DUMP(I,I+128)
PRINTSTRING("
STACK FRAME
")
DUMP(OLDLNB,OLDLNB+256)
END ; ! ASSDUMP
!*
OWNINTEGER FIRST
!*
SYSTEMROUTINE NDIAG(INTEGER PCOUNT, LNB, FAULT, INF)
!***********************************************************************
!*_______'MASTER DIAGNOSTIC ROUTINE'. DISCOVERS THE LANGUAGE OF THE *
!*_______FAILED ROUTINE FROM WORD 4 OF THE GLA AND CALLS APPROPRIATE *
!*_______DIAGNOSTIC ROUTINE. THIS IS REPEATED TILL ALL DIAGNOSTICS *
!*_______GIVEN. *
!*_______PCOUNT = PCOUNTER AT FAILURE *
!*_______LNB = LOCAL NAME BASE AT FAILURE *
!*_______FAULT = FAILURE (0=%MONITOR REQUESTED) *
!*_______INF =ANY FURTHER INFORMATION *
!***********************************************************************
OWNINTEGER ACTIVE=0; ! CHECK FOR LOOPS
CONSTINTEGER RECURSE LIMIT=16; ! LIMIT OF STACK FRAME UNWOUND
INTEGER LANGFLAG, I, J, GLA, OLDLNB, NEWLNB, EVENT, SUBEVENT, RECURSE
SWITCH LANGUAGE(0:6)
STRING (20) FAILNO
CONSTSTRING (9)ARRAY LT(0:6)=" !???! "," IMP "," FORTRAN ",
" IMPS "," ASMBLR "," ALGOL60 ",
" OPTCODE ";
! LAY DOWN A CONTINGENCY AGAINST ERRORS IN MDIAGS
I=0; RECURSE=0
LNB=LNB&(-4)
*STLN_OLDLNB
ACTIVE=ACTIVE+1
FAILNO=" LOOPING"
IF ACTIVE>5 THEN ->EOUT
FAILNO=" CONT STACK FULL"
IF I>0 THEN ->EOUT; ! CONTINGENCY DID NOT GO DOWN
!
! FIRST CHECK THE STACK FOR VALID DESCRIPTOR TO GLA. IF INVALID ASSUME
! A FAILURE DURING A CALL AND GO BACK ONE STACK FRAME
!
INVGLA:
IF INTEGER(LNB+12)>>25<<1#X'B0' THEN C
LNB=INTEGER(LNB)&(-4) AND ->INVGLA
GLA=INTEGER(LNB+16)
*LDTB_X'18000020'
*LDA_GLA
*VAL_(LNB +1)
*JCC_12,<GLAOK>; ! READ ACCESS AVAILABLE
LNB=INTEGER(LNB)&(-4); ->INVGLA
GLAOK:
LANGFLAG=INTEGER(GLA+16)>>24
LANGFLAG=0 IF LANGFLAG>6
SUBEVENT=0; EVENT=FAULT>>8
IF FAULT>=256 THEN SUBEVENT=FAULT&255 AND FAULT=0
TRANS(FAULT,EVENT,SUBEVENT)
! ONCOND(EVENT,SUBEVENT,LNB)
FIRST=1
IF FAULT>=0 THEN START
PRINT STRING("
MONITOR ENTERED FROM".LT(LANGFLAG)."
!")
IF FAULT=0 AND EVENT#0 START
PRINTSTRING("
MONITOR ENTERED
")
PRINTSTRING("EVENT"); WRITE(EVENT,1)
PRINTSYMBOL('/'); WRITE(SUBEVENT,1)
FINISH ELSE ERMESS(FAULT,INF)
NEWLINE
FINISH ELSE EVENT=0
OLDLNB=LNB
->LANGUAGE(LANGFLAG)
LANGUAGE(0):
LANGUAGE(6): ! NO TRACE CODE
LANGUAGE(4): ! UNKNOWN & ASSEMBLER
ASSDUMP(PCOUNT,OLDLNB)
NEWLNB=INTEGER(OLDLNB)&(-4)
->NEXTRT
LANGUAGE(1):
LANGUAGE(3): ! IMP & IMPS
LANGUAGE(5): ! ALGOL 60
INDIAG(OLDLNB,LANGFLAG>>2,PCOUNT,NEWLNB); ! IMP DIAGS
IF NEWLNB=0 THEN ->EXIT
NEXTRT: ! CONTINUE TO UNWIND STACK
PCOUNT=INTEGER(OLDLNB+8)
OLDLNB=NEWLNB
RECURSE=RECURSE+1
->EXIT IF OLDLNB<STACKBASE OR RECURSE>RECURSE LIMIT
! FAR ENOUGH
I=INTEGER(OLDLNB+16)
LANGFLAG=INTEGER(I+16)>>24
LANGFLAG=0 IF LANGFLAG>6
->LANGUAGE(LANGFLAG)
LANGUAGE(2): ! FORTRAN
! FDIAG(OLDLNB,PCOUNT,NEWLNB)
IF NEWLNB=0 THEN ->EXIT
->NEXT RT
EOUT: ! ERRROR EXIT
PRINTSTRING("
MDIAG FAILS ".FAILNO."
")
ACTIVE=0
->QUIT
EXIT:
! POP UP CONTINGENCY
ACTIVE=0
IF FAULT=0=EVENT THEN ->END
QUIT:
STOP
*IDLE_X'DDDD'
END: END ; ! OF NDIAG
! LAYOUT OF DIAGNOSIC TABLES
!***********************
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
! FORM OF THE TABLES:-
! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1 = (12 LANG DEPENDENT BITS)<<20 ! ENVIRONMENT
! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT 2**19 =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
ROUTINE INDIAG(INTEGER OLDLNB, LANG, PCOUNT, INTEGERNAME NEWLNB)
!***********************************************************************
!*_______THE DIAGNOSTIC ROUTINE FOR IMP(LANG=0) %AND ALGOL *
!*_______THE ALGOL SYMBOL TABLES ARE SET UP AS FOR IMP *
!***********************************************************************
ROUTINESPEC PRINT LOCALS(INTEGER ADATA)
ROUTINESPEC PRINTVAR(INTEGER ADATA)
INTEGER GLAAD, FLINE, ADATA, NAM, TYPE, PREC
INTEGER TSTART, PREV BLK, WORD0, WORD1, WORD2, WORD3, I
STRING (50) NAME
GLAAD=INTEGER(OLDLNB+16); ! ADDR OF GLA/PLT
TSTART=INTEGER(OLDLNB+12)&X'FFFFFF'
IF TSTART=0 THEN START
PRINTSTRING("
RT/FN/MAP COMPILED WITHOUT DIAGNOSTICS
")
ASSDUMP(PCOUNT,OLDLNB)
NEWLNB=INTEGER(OLDLNB)&(-4)
RETURN
FINISH
UNTIL PREVBLK=0 CYCLE
TSTART=TSTART+INTEGER(GLAAD+12)
WORD0=INTEGER(TSTART)
WORD1=INTEGER(TSTART+4)
WORD2=INTEGER(TSTART+8)
WORD3=INTEGER(TSTART+12)
NAME=STRING(TSTART+12)
I=WORD0&X'FFFF'; ! LINE NO DISP
IF I=0 THEN FLINE=-1 ELSE FLINE=INTEGER(OLDLNB+I)
NEWLINE
IF FIRST=1 THEN START
PRINTSTRING("MONITOR ")
FIRST=0
FINISH
PRINTSTRING("ENTERED FROM")
IF FLINE>=0 THEN START
PRINTSTRING(" LINE")
WRITE(FLINE,4)
PRINTSTRING(" OF")
FINISH
IF WORD3=0 THEN PRINTSTRING(" BLOCK") C
ELSE PRINT STRING(" RT/FN/MAP ".NAME)
PRINTSTRING(" STARTING AT LINE")
WRITE(WORD0>>16,2)
IF LANG=0 THEN I=20 ELSE I=16
PRINT LOCALS(TSTART+I+(WORD3>>26)<<2)
IF WORD3#0 START
NEWLNB=INTEGER(OLDLNB)&(-4)
NEWLINE
RETURN
FINISH
PREV BLK=WORD1&X'FFFF'
TSTART=PREV BLK
REPEAT
NEWLNB=0
NEWLINE; RETURN
ROUTINE PRINT LOCALS(INTEGER ADATA)
!***********************************************************************
!*______ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES*
!***********************************************************************
NEWLINE
IF INTEGER(ADATA)<0 THEN PRINTSTRING("NO ")
PRINTSTRING("LOCAL VARIABLES
")
WHILE INTEGER(ADATA)>0 CYCLE
PRINT VAR(ADATA)
ADATA=ADATA+8+BYTE INTEGER(ADATA+4)&(-4)
REPEAT
END ; ! PRINT LOCALS
ROUTINE PRINT VAR(INTEGER ADATA)
!***********************************************************************
!*_______OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK. *
!*_______A VARIABLE ENTRY IN THE TABLES IS:- *
!*_______FLAG<<20!VBREG<<18!DISP *
!*_______WHERE:- *
!*_________VBREG IS VARIABLE'S BASE REGISTER, DISP IS IT'S OFFSET *
!*_________AND FLAGS=NAM<<6!PREC<<3!TYPE *
!***********************************************************************
INTEGER I, J, K, DISP, VBREG, VADDR, V, ARR
CONSTINTEGER UNASSI=X'81818181'
STRING (11)LNAME
STRING (63)MESS
SWITCH INTV,REALV(3:7)
I=INTEGER(ADATA)
DISP=I&X'3FFFF'
VBREG=I&X'40000'
K=I>>20
TYPE=K&7
PREC=K>>4&7
ARR=K>>8&3
NAM=K>>10&1
LNAME<-STRING(ADATA+4)." "
PRINT STRING(LNAME."=")
IF VBREG=0 THEN VADDR=OLDLNB ELSE VADDR=GLAAD
VADDR=VADDR+DISP
! USE VALIDATE ADDRESS HERE TO CHECK ACR LEVELS ETC
*LDTB_X'18000010'
*LDA_VADDR
*VAL_(LNB +1)
*JCC_3,<INVALID>
J=VADDR>>18
->INVALID UNLESS VADDR<X'3000' OR ((J=5 OR J=7 OR J=10)C
AND INTEGER(8*J+4)&X'80000001'=X'80000001')
! ALLOWS PUBLIC AND LOCKED LOCALS ONLY
IF (ARR=0 AND NAM#0) OR TYPE=5 THEN START
IF INTEGER(VADDR)>>24=X'E5' THEN ->ESC
VADDR=INTEGER(VADDR+4)
->NOT ASS IF VADDR=UNASSI
*LDTB_X'18000010'
*LDA_VADDR
*VAL_(LNB +1)
*JCC_3,<INVALID>
J=VADDR>>18
->INVALID UNLESS VADDR<X'3000' OR ((J=5 OR J=7 OR J=10)C
AND INTEGER(8*J+4)&X'80000001'=X'80000001')
! ALLOWS PUBLIC AND LOCKED LOCALS ONLY
FINISH
->ILL ENT IF PREC<3; ! BITS NOT IMPLEMENTED
IF PREC>=5 OR ARR#0 THEN V=INTEGER(VADDR)
->ARRAY IF ARR#0
IF TYPE=1 THEN ->INTV(PREC)
IF TYPE=2 THEN ->REALV(PREC)
IF TYPE=5 THEN ->STR
INTV(4): ! 16 BIT INTEGER
V=HALFINTEGER(VADDR)
MESS="X'".STRHEX(V)."' ".STRINT(V)
->OMESS
INTV(7): ! 128 BIT INTEGER
REALV(3): ! 8 BIT REAL
REALV(4): ! 16 BIT REAL
ILL ENT: ! SHOULD NOT OCCURR
MESS="UNKNOWN TYPE OF VARIABLE"
->OMESS
INTV(5): ! 32 BIT INTEGER
->NOT ASS IF V=UN ASSI
MESS="X'".STRHEX(V)."' ".STRINT(V)
->OMESS
INTV(3): ! 8 BIT INTEGER
WRITE(BYTEINTEGER(VADDR),1); ->NEWL
REALV(5): ! 32 BIT REAL
->NOT ASS IF V=UN ASSI
MESS="X'".STRHEX(V)."'"
->OMESS
INTV(6): ! 64 BIT INTEGER
REALV(6): ! 64 BIT REAL
REALV(7): ! 128 BIT REAL
ARRAY: ! ARRAY PRINT 128 BIT HEADER
->NOT ASS IF UN ASSI=V
MESS="X'".STRHEX(V).STRHEX(INTEGER(VADDR+4))
IF PREC=7 OR ARR#0 THEN START
MESS=MESS." ".STRHEX(INTEGER(VADDR+8)).STRHEX(INTEGER(VADDR+12))
FINISH
MESS=MESS."'"; ->OMESS
STR: ->NOT ASS IF BYTE INTEGER(VADDR+1)=UNASSI&255=BYTEINTEGER( C
VADDR)
->TOOLONG IF BYTEINTEGER(VADDR)>50
MESS="""".STRING(VADDR).""""
->OMESS
ESC: ! ESCAPE DESCRIPTOR
INVALID:
MESS=" INVALID ADDRESS ".STRHEX(VADDR); ->OMESS
TOO LONG:
MESS=" TOO LONG "; ->OMESS; ! ASSUME SHORT STRINGS
NOT ASS:
MESS=" NOT ASSIGNED"
OMESS:PRINTSTRING(MESS)
NEWL: NEWLINE
END ; ! PRINT VAR
END ; ! OF RT IDIAGS
!*
ROUTINE ERMESS(INTEGER N, INF)
!***********************************************************************
!*_______OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT *
!***********************************************************************
CONSTBYTEINTEGERARRAY TR(0:13)=1,2,3,4,5,6,7,3,
10,10,7,7,8,10
RETURN IF N<=0
IF N=35 THEN N=10
IF N=10 THEN START ; ! DEAL WITH INTERRUPT WT
IF INF=32 THEN N=9
IF INF<=13 THEN N=TR(INF)
IF INF=140 THEN N=25
IF INF=144 THEN N=28
! MORE HELPFUL MESSAGE IF
!POSSIBLE
FINISH
!*
PRINTMESS(N)
!*
! (WE WOULD GET AN IOCP REF ON THIS NEXT LINE)
! %IF N=26 %THEN PRINT SYMBOL(NEXT SYMBOL)
!*__________N=6(ARRAY BOUND FAULT) EXCLUDED FROM FOLLOWING - 19/3/76
IF N=16 OR N=17 OR N=10 THEN WRITE(INF,1)
NEWLINE
END ; ! ERMESS
ROUTINE PRINTMESS(INTEGER N)
PRINTSTRING("PROGRAM ERROR")
WRITE(N,3)
NEWLINE
END
ENDOFFILE