!*_ 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