!J ALTERED FOR JOBBER 9/1/80
!J SET COMREG TO SSCOMREG
!INCORPORATES CODE FOR NEW FORTRAN DIAGNOSTICS
!INCLUDES ICL MATHS ROUTINE ERROR ROUTINE
!INCLUDES CORRECTION FOR FAULT AT THE END OF ONCOND. R.M.1/12/77
!REFS TO WRITE JS VAR COMMENTED OUT
!IMP AND ALGOL SECTION REPLACED 13.4.78
CONSTSTRING (10) ARRAY LT(0 : 8) = C
" !???! "," IMP "," FORTRAN ",
" IMPS "," ASMBLR "," ALGOL(E) ",
" OPTCODE "," PASCAL "," SIMULA "
!J; %EXTRINSICINTEGER ICL9CEFAC
!J; %EXTRINSICINTEGER OPEHMODE;! 1 IF OPEH IS INITIALISED
OWNINTEGER ACTIVE = 0; ! CHECKS FOR LOOPS
!*
!*
!**DELSTART
CONSTBYTEINTEGERARRAY HEX(0 : 15) = C
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
CONSTINTEGER SEGSHIFT = 18
!J; %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
!J%EXTRINSICINTEGERARRAY SSCOMREG(0:60)
EXTRINSICINTEGER SSARRAYDIAG; !DETERMINES NO OF ELEMENTS TO BE PRINTED
SYSTEMROUTINESPEC FIO1(INTEGER ADPARM)
!J %SYSTEMROUTINESPEC FINDENTRY(%STRING (32) ENTRY, %C
!J %INTEGER TYPE, DAD, %STRINGNAME FILE, %C
!J %INTEGERNAME DR0, DR1, FLAG)
!J %SYSTEMROUTINESPEC DUMP(%INTEGER S, F)
!J %SYSTEMROUTINESPEC FPRINTFL(%LONGREAL XX, %INTEGER N, I)
SYSTEMROUTINESPEC NCODE(INTEGER S, F, A)
SYSTEMROUTINESPEC SIGNAL(INTEGER I, J, K, INTEGERNAME F)
SYSTEMROUTINESPEC PRINTMESS(INTEGER N)
!J; %SYSTEMROUTINESPEC IOCP(%INTEGER EP,N)
!J; %SYSTEMROUTINESPEC OPEH USER ERROR(%INTEGER ERRNO,ADD INF,L,STK)
!J; %SYSTEMROUTINESPEC STOP BASE
!J; %SYSTEMROUTINESPEC STOP
SYSTEMROUTINESPEC SSERR(INTEGER N)
!**DELEND
!*
ROUTINESPEC INDIAG(INTEGER OLDLNB, LANG, PCOUNT, MODE, DIAG, C
ASIZE, INTEGERNAME FIRST, 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
ROUTINE PRHEX(INTEGER VALUE, PLACES)
INTEGER I
CYCLE I = PLACES<<2-4,-4,0
PRINT SYMBOL(HEX(VALUE>>I&15))
REPEAT
END
ROUTINE DUMP(INTEGER START,FINISH)
INTEGER I,J
I=START&(-4)
WHILE I<FINISH CYCLE
PRINTSYMBOL('(')
PRHEX(I,8)
PRINTSTRING(') ')
CYCLE J=I,4,I+28
IF J>=FINISH THEN ->L
SPACES(2)
PRHEX(INTEGER(J),8)
REPEAT
L: NEWLINE
I=I+32
REPEAT
END
ROUTINE ASSDUMP(INTEGER PCOUNT, OLDLNB)
!J; %INTEGER J
INTEGER I
!J PRINTSTRING("
!J PC =")
!J PRHEX(PCOUNT,8)
!J PRINTSTRING("
!J LNB =")
!J PRHEX(OLDLNB,8)
!J PRINTSTRING("
!J CODE
!J ")
!J NCODE(PCOUNT-64,PCOUNT+64,PCOUNT-64)
!J PRINTSTRING("
!J GLA
!J ")
!J I = INTEGER(OLDLNB+16)
!J DUMP(I,I+128)
!J; *STSF_I
!J; J=OLDLNB+256
!J; %IF J>I %THEN J=I
PRINTSTRING("
STACK FRAME
")
!J; DUMP(OLDLNB,J)
!J DUMP(OLDLNB,OLDLNB+256)
END
ROUTINE ONCOND(INTEGER FAULT, EVENT, SUBEVENT, LNB)
!***********************************************************************
!* UNWIND THE IMP STACK LOOKING FOR ON CONDITIONS *
!***********************************************************************
LONGREAL INFO
INTEGER GLAAD, LANG, TSTART, BIT, ONWORD, PREVLNB, I, STSTART, C
STSEG
BIT = 1<<(EVENT+17)
*LSS_(LNB +0); *ST_PREVLNB
STSTART = COMREG(36)
STSEG = STSTART>>18
WHILE LNB>>18 = STSEG AND LNB >= STSTART CYCLE
GLAAD = INTEGER(LNB+16); ! PLT ADDR
LANG = INTEGER(GLAAD+16)>>24; ! LANGUAGE
EXIT UNLESS LANG = 1 OR LANG = 3; ! NO MIXED LANG ONCONDS
TSTART = INTEGER(LNB+12)&X'FFFFFF'
WHILE TSTART # 0 CYCLE
TSTART = TSTART+INTEGER(GLAAD+12)
I = INTEGER(TSTART+12)>>24; ! LENGTH OF NAME
I = I>>2<<2+16
ONWORD = INTEGER(TSTART+I)
IF ONWORD&BIT # 0 THEN -> HIT
IF INTEGER(TSTART+12) # 0 THEN EXIT ; !ROUTINE
TSTART = INTEGER(TSTART+4)&X'FFFF'; !ENCLOSING BLOCK
REPEAT
PREVLNB = LNB
LNB = INTEGER(LNB)
REPEAT
RETURN
HIT: ! ON CONDITION FOUND
I = INTEGER(TSTART)&X'FFFF'; ! LINE NOS WORD
IF I # 0 THEN I = INTEGER(LNB+I)
INTEGER(ADDR(INFO)) = EVENT<<8!SUBEVENT
INTEGER(ADDR(INFO)+4) = I
SIGNAL(1,0,0,I)
! TAMPER WITH EXIT DESCRIPTOR OF NEXT LEVEL
INTEGER(PREVLNB) = (LNB&X'FFFFFFFE')!(INTEGER(PREVLNB)&1)
INTEGER(PREVLNB+4) = INTEGER(PREVLNB+4)&(-4)!X'12'
! ACS=2
INTEGER(PREVLNB+8) = INTEGER(GLAAD+ONWORD&X'3FFFF')
ACTIVE = 0
*LSD_INFO; ! INFO FOR THE ON SEQUENCE
*LLN_PREVLNB; ! LNB TO RT AFTER EXIT RT
*EXIT_-64; ! PRESERVING ACC SIZE
END
!*
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 *
!***********************************************************************
INTEGER LANGFLAG, I, J, GLA, OLDLNB, NEWLNB, EVENT, SUBEVENT
INTEGER PARM0 OF FIO1, PARM1 OF FIO1, PARM2 OF FIO1, C
PARM3 OF FIO1
INTEGER PARM4 OF FIO1, PARM5 OF FIO1, PARM6 OF FIO1, C
PARM7 OF FIO1
LONGINTEGER JJ
SWITCH LANGUAGE(0 : 8)
CONSTINTEGER MAXLANGUAGE=8
STRING (20) FAILNO
CONSTBYTEINTEGERARRAY TR(0 : 13) = 1,2,3,4,5,6,7,3,
10,10,7,7,8,10
! LAY DOWN A CONTINGENCY AGAINST ERRORS IN MDIAGS
I = 0
*STLN_OLDLNB
*JLK_3
*J_<MDERROR>; !CONTINGENCY JUMPS HERE
*LSS_TOS ; *ST_J
SIGNAL(-1,J,OLDLNB,I)
ACTIVE = ACTIVE+1
FAILNO = ' LOOPING'
IF ACTIVE > 5 THEN -> EOUT
FAILNO = ' CONT STACK FULL'
IF I > 0 THEN -> EOUT; ! CONTINGENCY DID NOT GO DOWN
IF FAULT = 35 THEN FAULT = 10
IF FAULT = 10 THEN START ; ! DEAL WITH INTERRUPT WT
IF INF = 32 THEN FAULT = 9
IF INF <= 13 THEN FAULT = TR(INF)
IF INF=136 THEN FAULT=13; !OUTPUT EXCEEDED
IF INF = 140 THEN FAULT = 25
IF INF = 144 THEN FAULT = 28
! MORE HELPFUL MESSAGE IF
!POSSIBLE
FINISH
!*
IF FAULT = 9 OR FAULT = 7 THEN START ; ! IF @ ERROR OR CAP. EXC.
IF BYTEINTEGER(PCOUNT) = X'1F' C
OR BYTEINTEGER(PCOUNT-4) = X'1F' THEN START
! ON CALL
FAULT = 37; ! UNSATISFIED REFERENCE
LNB = INTEGER(LNB); ! RETREAT ONE STACK FRAME
FINISH
FINISH
!*
NEXTLEVEL: GLA = INTEGER(LNB+16)
IF GLA&3#0 START
PRINTSTRING("CORRUPT STACK FRAME - DUMP FROM LNB:")
NEWLINE
DUMP(LNB,32)
ACTIVE=0
->QUIT
FINISH
!J; *LDTB_X'18000020'
!J; *LDA_GLA
!J; *VAL_(%LNB+1)
!J; *JCC_3,<NODIAGS>
!J %IF GLA&X'80000000'#0 %THEN LNB=INTEGER(LNB)%AND->NEXTLEVEL
! !IGNORE BLOCKS WITH GLA IN PUBLIC SEGMENT - MUST HAVE BEEN IN LOCAL CONTROLLER
LANGFLAG = INTEGER(GLA+16)>>24
LANGFLAG = 0 IF LANGFLAG > MAXLANGUAGE
SUBEVENT = 0; EVENT = FAULT>>8
!*
IF FAULT >= 256 THEN SUBEVENT = FAULT&255 AND FAULT = 0
TRANS(FAULT,EVENT,SUBEVENT)
ONCOND(FAULT,EVENT,SUBEVENT,LNB)
!J %UNLESS FAULT=0=EVENT %THEN COMREG(10)=1; !FOR USE BY JCL
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 START
!J %IF FAULT # 0 %THEN SELECT OUTPUT(99); !DONT SELECT IF JUST CALL OF %MONITOR
!J; %IF FAULT#0 %START
!J; IOCP(11,0) ;! WAS IOCP(11,-1)
!J; %IF OPEHMODE=1 %THEN %START
!J; OPEH USER ERROR(FAULT,0,LANGFLAG,2)
!J; STOPBASE
!J; %FINISH
!J; SELECTOUTPUT(107)
ERMESS(FAULT,INF)
!J; %FINISH
FINISH
NEWLINE
FINISH ELSE EVENT = 0
OLDLNB = LNB
IF LANGFLAG = 2 THEN ICL9CELABELS
-> LANGUAGE(LANGFLAG)
LANGUAGE(0):
LANGUAGE(4): ! UNKNOWN & ASSEMBLER
LANGUAGE(6): ! OPTCODE
LANGUAGE(7): ! PASCAL
NODIAGS:
PRINTSTRING("
NO DIAGNOSTICS FOR CALLING PROCEDURE
")
ASSDUMP(PCOUNT,OLDLNB)
LANGUAGE(8): !SIMULA - JUST GO BACK ONE STACK FRAME
NEWLNB = INTEGER(OLDLNB)&(-4); !AND OFF BOTTOM 2 BITS
-> NEXTRT
LANGUAGE(1):
LANGUAGE(3): ! IMP & IMPS
LANGUAGE(5): ! ALGOL 60
INDIAG(OLDLNB,LANGFLAG,PCOUNT,0,2,SSARRAYDIAG,FIRST,NEWLNB)
! IMP DIAGS
IF NEWLNB = 0 THEN -> EXIT
NEXTRT: ! CONTINUE TO UNWIND STACK
PCOUNT=INTEGER(OLDLNB+8)
NEXTRTF:
->EXIT IF OLDLNB=COMREG(36)OR OLDLNB>>SEGSHIFT#NEWLNB>>SEGSHIFT
! FAR ENOUGH
OLDLNB=NEWLNB
*LDTB_X'18000010'
*LDA_OLDLNB
*VAL_(LNB +1)
*JCC_3,<EXIT>
I=INTEGER(OLDLNB+16)
*LDTB_X'18000020'
*LDA_I
*VAL_(LNB +1)
*JCC_3,<NODIAGS>
LANGFLAG=INTEGER(I+16)>>24
LANGFLAG=0 IF LANGFLAG>MAXLANGUAGE
->LANGUAGE(LANGFLAG)
LANGUAGE(2): ! FORTRAN
PARM0 OF FIO1 = X'00090000'; !FIO1 ENTRY= GIVE DIAGNOSTICS
PARM1 OF FIO1 = OLDLNB; !PARM1= %INTEGER OLD LNB
PARM2 OF FIO1 = PCOUNT; !PARM2= %INTEGER PCOUNT
PARM3 OF FIO1 = 0; !PARM3= %INTEGER MODE
PARM4 OF FIO1 = 4; !PARM4= %INTEGER DIAG
PARM5 OF FIO1 = SSARRAYDIAG; !PARM5= %INTEGER ASIZE
PARM6 OF FIO1 = ADDR(FIRST); !PARM6= %INTEGERNAME FIRST
PARM7 OF FIO1 = ADDR(NEWLNB); !PARM7= %INTEGERNAME NEW LNB
FIO1(ADDR(PARM0 OF FIO1))
IF NEWLNB = 0 THEN -> EXIT
PCOUNT = INTEGER(INTEGER(OLDLNB)+8)-4
-> NEXT RTF
MDERROR: ! ENTER FROM CONTINGENCY
**=JJ; ! DESCPTR TO IMAGE STORE
J <- JJ; !GET ADDRESS FROM DESCRIPTOR
!TEMP J=(JJ<<32)>>32
PRINTSTRING("
INTERRUPT DURING DIAGNOSTICS WT= ")
WRITE(INTEGER(J),3)
ASSDUMP(INTEGER(J+16),OLDLNB)
-> QUIT
EOUT: ! ERRROR EXIT
PRINTSTRING("
MDIAG FAILS ".FAILNO."
")
ACTIVE = 0
-> QUIT
EXIT:
SIGNAL(1,0,0,I); ! POP UP CONTINGENCY
ACTIVE = 0
IF FAULT = 0 = EVENT THEN -> END
! %IF COMREG(27)&X'400000'#0 %THEN ->END
! FTRAN ERROR RECOV
QUIT:
STOP
END:
END ; ! OF MDIAGS
! 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.
SYSTEMROUTINE INDIAG(INTEGER OLDLNB, LANG, PCOUNT, MODE, C
DIAG, ASIZE, INTEGERNAME FIRST, NEWLNB)
!***********************************************************************
!* THE DIAGNOSTIC ROUTINE FOR IMP %AND ALGOL(LANG=5) *
!* THE ALGOL SYMBOL TABLES ARE SET UP AS FOR IMP *
!* MODE = 0 FOR JOBBER&EMAS2900, =1 FOR OPEH IN VMEB&VMEK *
!* DIAG = DIAGNOSTIC LEVEL *
!* 1 = ROUTE SUMMARY ONLY (ASIZE)=ADDR MODULE NAME FROM OPEH *
!* 2 = DIAGNOSTICS AS TRADITIONALLY PERFORMED *
!* ASIZE IS NO OF ELEMENTS OF EACH ARRAY TO BE PRINTED(DIAG>1) *
!***********************************************************************
ROUTINESPEC PRINT LOCALS(INTEGER ADATA, STRING (15) LOC)
ROUTINESPEC PRINT SCALAR(RECORDNAME VAR)
ROUTINESPEC PRINT ARR(RECORDNAME VAR, INTEGER ASIZE)
ROUTINESPEC PRINT VAR(INTEGER TYPE, PREC, NAM, LANG, FORM, C
VADDR)
INTEGERFNSPEC CHECKRECURSION(STRING (50) NAME)
INTEGER GLAAD, FLINE, NAM, TYPE, PREC, TSTART, PREV BLK, C
WORD0, WORD1, WORD2, WORD3, I
RECORDFORMAT F(INTEGER VAL, STRING (11) VNAME)
OWNINTEGERARRAY GLOBAD(0 : 20)
INTEGER INHIBIT
OWNINTEGER GLOBPTR
STRING (10) STMNT
STRING (20) PROC
STRING (50) NAME
CONSTINTEGER ALGOL = 5; ! LANGUAGE CODE
IF FIRST = 1 THEN GLOBPTR = 0
IF LANG # ALGOL THEN STMNT = " LINE" C
AND PROC = " ROUTINE/FN/MAP " C
ELSE STMNT = " STATEMENT" AND PROC = " PROCEDURE "
GLAAD = INTEGER(OLDLNB+16); ! ADDR OF GLA/PLT
TSTART = INTEGER(OLDLNB+12)&X'FFFFFF'
IF TSTART = 0 THEN START
IF PCOUNT>ADDR(GLOBPTR) START ; !IGNORE IF IN BASEFILE
PRINTSTRING("
".PROC."COMPILED WITHOUT DIAGNOSTICS
")
ASSDUMP(PCOUNT,OLDLNB)
FINISHELSE NEWLNB=0 AND RETURN
NEWLNB = INTEGER(OLDLNB)
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)
IF COMREG(25)=0 START
IF PCOUNT<ADDR(GLOBPTR)THEN NEWLNB=INTEGER(OLDLNB)ANDRETURN
!DONT DIAGNOSE BASEFILE ROUTINES. GLOBPTR IS IN BASE GLA
IF WORD1&X'C0000000' = X'40000000' C
THEN NEWLNB = INTEGER(OLDLNB) AND RETURN
! SYSTEM ROUTINE
FINISH
NAME = STRING(TSTART+12)
I = WORD0&X'FFFF'; ! LINE NO DISP
IF I = 0 THEN FLINE = -1 C
ELSE FLINE = INTEGER(OLDLNB+I)
INHIBIT=CHECK RECURSION(NAME)
IF INHIBIT=0 START
NEWLINE
IF MODE = 1 THEN PRINTSTRING(LT(LANG)) ELSE START
IF FIRST = 1 THEN FIRST = 0 C
AND PRINTSTRING("DIAGNOSTICS ")
PRINTSTRING("ENTERED FROM")
FINISH
IF WORD0>>16 = 0 THEN START
IF MODE = 0 THEN PRINTSTRING(LT(LANG))
PRINTSTRING("ENVIRONMENTAL BLOCK
")
FINISH ELSE START
IF FLINE >= 0 AND FLINE # WORD0>>16 THEN START
PRINTSTRING(STMNT)
WRITE(FLINE,4)
PRINTSTRING(" OF")
FINISH
FINISH
IF WORD3 = 0 THEN PRINTSTRING(" BLOCK") C
ELSE PRINT STRING(PROC.NAME)
PRINTSTRING(" STARTING AT".STMNT)
WRITE(WORD0>>16,2)
IF MODE = 1 AND DIAG = 1 THEN START
PRINTSTRING("(MODULE ".STRING(ASIZE).")")
FINISH
NEWLINE
IF LANG # ALGOL THEN I = 20 ELSE I = 16
IF MODE = 0 OR DIAG > 1 THEN START
PRINT LOCALS(TSTART+I+(WORD3>>26)<<2,"LOCAL")
IF WORD1&X'C0000000' # 0 THEN START
! EXTERNAL(ETC) ROUTINE
I = WORD1&X'3FFFF'+INTEGER(GLAAD+12)+I
PRINT LOCALS(I,"GLOBAL")
FINISH
FINISH
FINISH
IF WORD3 # 0 START
NEWLNB = INTEGER(OLDLNB)
UNLESS DIAG = 1 OR INHIBIT=1 THEN NEWLINE
RETURN
FINISH
PREV BLK = WORD1&X'FFFF'
TSTART = PREV BLK
REPEAT
NEWLNB = 0
NEWLINE; RETURN
ROUTINE QSORT(RECORDARRAYNAME A, INTEGER I, J)
RECORDSPEC A(F)
RECORD D(F)
INTEGER L, U
IF I >= J THEN RETURN
L = I; U = J; D = A(J); -> FIND
UP:
L = L+1
IF L = U THEN -> FOUND
FIND:
UNLESS A(L)_VNAME > D_VNAME THEN -> UP
A(U) = A(L)
DOWN:
U = U-1
IF L = U THEN -> FOUND
UNLESS A(U)_VNAME < D_VNAME THEN -> DOWN
A(L) = A(U); -> UP
FOUND:
A(U) = D
QSORT(A,I,L-1)
QSORT(A,U+1,J)
END
!*
INTEGERFN CHECKRECURSION(STRING (50) NAME)
!********************************************************
!* AVOID PRINTING TRACE OF RECURSING RTS *
!********************************************************
OWNINTEGER COUNT=0
OWNSTRING (50) LASTNAME=""
!*
! PRINTSTRING(" $$$$ ".NAME." ".LASTNAME)
! WRITE(COUNT,0)
! NEWLINE
IF LASTNAME=NAME START
COUNT=COUNT+1
IF COUNT=6 THEN PRINTSTRING("
**** ".NAME." CONTINUED TO RECURSE ****
")
RESULT =1 IF COUNT>5
FINISHELSESTART
IF COUNT>6 THEN START
PRINTSTRING("**** (FOR A FURTHER ")
WRITE(COUNT-6,1)
PRINTSTRING(" LEVEL")
IF COUNT>7 THEN PRINTSYMBOL('S')
PRINTSTRING(") ****
")
FINISH
COUNT=0
LASTNAME=NAME
FINISH
RESULT =0
END
ROUTINE PRINT LOCALS(INTEGER ADATA, STRING (15) LOC)
!***********************************************************************
!* ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES*
!***********************************************************************
INTEGER I, NRECS, SADATA
IF LOC = "GLOBAL" THEN START
I = 0
WHILE I < GLOBPTR CYCLE
IF GLOBAD(I) = ADATA THEN RETURN
I = I+1
REPEAT
IF GLOBPTR <= 20 THEN START
GLOBAD(GLOBPTR) = ADATA
GLOBPTR = GLOBPTR+1
FINISH
FINISH
NEWLINE
IF INTEGER(ADATA) < 0 THEN PRINTSTRING("NO ")
PRINTSTRING(LOC." VARIABLES
")
NRECS = 0; SADATA = ADATA
WHILE INTEGER(ADATA) > 0 CYCLE
NRECS = NRECS+1
ADATA = ADATA+8+BYTE INTEGER(ADATA+4)&(-4)
REPEAT
RETURN IF NRECS = 0
BEGIN
RECORDARRAY VARS(1 : NRECS)(F)
INTEGER I
ADATA = SADATA
CYCLE I = 1,1,NRECS
VARS(I) <- RECORD(ADATA)
ADATA = ADATA+8+BYTEINTEGER(ADATA+4)&(-4)
REPEAT
QSORT(VARS,1,NRECS)
CYCLE I = 1,1,NRECS
IF VARS(I)_VAL>>28&3 = 0 C
THEN PRINT SCALAR(VARS(I))
REPEAT
IF ASIZE > 0 THEN START
CYCLE I = 1,1,NRECS
IF VARS(I)_VAL>>28&3 # 0 C
THEN PRINT ARR(VARS(I),ASIZE)
REPEAT
FINISH
END
END
ROUTINE PRINT SCALAR(RECORDNAME VAR)
!***********************************************************************
!* 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 *
!***********************************************************************
RECORDSPEC VAR(F)
INTEGER I, K, VADDR
STRING (11) LNAME
I = VAR_VAL
K = I>>20
TYPE = K&7
PREC = K>>4&7
NAM = K>>10&1
LNAME <- VAR_VNAME." "
PRINT STRING(LNAME."=")
IF I&X'40000' = 0 THEN VADDR = OLDLNB ELSE VADDR = GLAAD
VADDR = VADDR+I&X'3FFFF'
PRINT VAR(TYPE,PREC,NAM,LANG,0,VADDR)
NEWLINE
END
ROUTINE PRINT VAR(INTEGER TYPE, PREC, NAM, LANG, FORM, C
VADDR)
!***********************************************************************
!* OUTPUT A VARIABLE. FIXED FORMAT(FORM#0) TAKE 14 PLACES FOR *
!* VARIABLES UP TO 32 BITS AND 21 PLACES THEREAFTER *
!***********************************************************************
INTEGER K, I, J,DTOPHALF
CONSTINTEGER UNASSI = X'81818181'
SWITCH INTV, REALV(3 : 7)
! USE VALIDATE ADDRESS HERE TO CHECK ACR LEVELS ETC
*LDTB_X'18000010'
*LDA_VADDR
*VAL_(LNB +1)
*JCC_3,<INVALID>
DTOPHALF=255
IF NAM # 0 OR (TYPE = 5 AND FORM = 0) THEN START
IF INTEGER(VADDR)>>24 = X'E5' THEN -> ESC
DTOPHALF=INTEGER(VADDR)
VADDR = INTEGER(VADDR+4)
-> NOT ASS IF VADDR = UNASSI
*LDTB_X'18000010'
*LDA_VADDR
*VAL_(LNB +1)
*JCC_3,<INVALID>
FINISH
-> ILL ENT IF PREC < 3; ! BITS NOT IMPLEMENTED
IF TYPE = 1 THEN -> INTV(PREC)
IF TYPE = 2 THEN -> REALV(PREC)
IF TYPE = 3 AND PREC = 5 THEN -> BOOL
IF TYPE = 5 THEN -> STR
INTV(4): ! 16 BIT INTEGER
K = BYTEINTEGER(VADDR)<<8!BYTEINTEGER(VADDR+1)
-> NOT ASS IF K = UNASSI>>16
WRITE(K,12*FORM+1)
RETURN
INTV(7): ! 128 BIT INTEGER
REALV(3): ! 8 BIT REAL
REALV(4): ! 16 BIT REAL
ILL ENT: ! SHOULD NOT OCCURR
PRINTSTRING("UNKNOWN TYPE OF VARIABLE")
RETURN
INTV(5): ! 32 BIT INTEGER
-> NOT ASS IF INTEGER(VADDR) = UN ASSI
WRITE(INTEGER(VADDR),1+12*FORM)
UNLESS LANG=ALGOL OR FORM=1 OR -255<=INTEGER(VADDR)<=255 START
PRINTSTRING(" (X'")
PRHEX(INTEGER(VADDR),8); PRINTSTRING("')")
FINISH
RETURN
INTV(3): ! 8 BIT INTEGER
WRITE(BYTEINTEGER(VADDR),1+12*FORM); RETURN
REALV(5): ! 32 BIT REAL
-> NOT ASS IF INTEGER(VADDR) = UN ASSI
PRINT FL(REAL(VADDR),7)
RETURN
INTV(6): ! 64 BIT INTEGER
-> NOT ASS IF UN ASSI = INTEGER(VADDR) = INTEGER(VADDR+4)
PRINTSTRING("X'")
PRHEX(INTEGER(VADDR),8); SPACES(2)
PRHEX(INTEGER(VADDR+4),8)
PRINTSYMBOL('''')
RETURN
REALV(6): ! 64 BIT REAL
-> NOT ASS IF UNASSI = INTEGER(VADDR) = INTEGER(VADDR+4)
PRINT FL(LONG REAL(VADDR),14)
RETURN
REALV(7): ! 128 BIT REAL
-> NOT ASS IF UNASSI = INTEGER(VADDR) = INTEGER(VADDR+4)
PRINT FL(LONGREAL(VADDR),14)
IF FORM = 0 THEN START
PRINTSTRING(" (R'"); PRHEX(INTEGER(VADDR),8)
PRHEX(INTEGER(VADDR+4),8)
SPACE; PRHEX(INTEGER(VADDR+8),8)
PRHEX(INTEGER(VADDR+12),8)
PRINTSTRING("')")
FINISH
RETURN
BOOL: ! BOOLEAN
-> NOT ASS IF INTEGER(VADDR) = UNASSI
IF INTEGER(VADDR) = 0 THEN PRINTSTRING(" 'FALSE' ") C
ELSE PRINTSTRING(" 'TRUE' ")
RETURN
STR:
I = BYTEINTEGER(VADDR)
-> NOT ASS IF BYTE INTEGER(VADDR+1) = UNASSI&255 = I
->WRONGL IF I>DTOPHALF&X'1FF'; !CUR LENGTH>MAX LENGTH
K = 1
WHILE K <= I CYCLE
J = BYTE INTEGER(VADDR+K)
-> NPRINT UNLESS 32 <= J <= 126 OR J = 10
K = K+1
REPEAT
PRINTSTRING("""")
PRINTSTRING(STRING(VADDR)); PRINTSTRING("""")
RETURN
ESC: ! ESCAPE DESCRIPTOR
PRINTSTRING("ESCAPE ROUTINE")
-> AIGN
INVALID:
PRINTSTRING("INVALID ADDRSS")
-> AIGN
NPRINT:
PRINT STRING(" CONTAINS UNPRINTABLE CHARS")
RETURN
WRONGL:
PRINTSTRING("WRONG LENGTH ")
->AIGN
NOT ASS:
PRINTSTRING(" NOT ASSIGNED")
AIGN:
IF PREC >= 6 AND FORM = 1 THEN SPACES(7)
END ; ! PRINT VAR
INTEGERFN CHECK DUPS(INTEGER REFADDR, VADDR, ELSIZE)
!***********************************************************************
!* CHECK IF VAR THE SAME AS PRINTED LAST TIME *
!***********************************************************************
ELSIZE = ELSIZE!X'18000000'
*LDTB_ELSIZE; *LDA_REFADDR
*CYD_0; *LDA_VADDR
*CPS_L =DR
*JCC_8,<A DUP>
RESULT = 0
ADUP:
RESULT = 1
END
ROUTINE DCODEDV(LONGINTEGER DV,INTEGERARRAYNAME LB,UB)
!***********************************************************************
!* WORK DOWN A DOPE VECTOR DESCRIBED BY WORD DESCRIPTOR DV AND *
!* RETURN SIZE,DIMENIONALITY AND SUBSCRIPT RANGES IN DATA *
!***********************************************************************
INTEGER I, ND, AD, U
ND = (DV>>32)&255; ND = ND//3
LB(0) = ND; UB(0) = ND
AD = INTEGER(ADDR(DV)+4)+12*(ND-1)
CYCLE I = 1,1,ND
U = INTEGER(AD+8)//INTEGER(AD+4)-1
LB(I) = INTEGER(AD)
UB(I)=LB(I)+U
AD = AD-12
REPEAT
UB(ND+1) = 0
LB(ND+1) = 0
END
ROUTINE PRINT ARR(RECORDNAME VAR, INTEGER ASIZE)
!***********************************************************************
!* PRINT THE FIRST ASIZE ELEMENTS OF THE ARRAY DEFINED BY VAR *
!* ARRAYNAMES PRINTED ALSO AT PRESENT. UP TO COMPILERS TO AVOID THIS*
!***********************************************************************
RECORDSPEC VAR(F)
INTEGER I, J, K, TYPE, PREC, ELSIZE, ND, VADDR, HDADDR, C
BASEADDR, ELSPERLINE, M1, REFADDR, ELSONLINE, DUPSEEN
LONGINTEGER ARRD,DOPED
INTEGERARRAY LBS, UBS, SUBS(0 : 13)
I = VAR_VAL
K = I>>20
PREC = K>>4&7
TYPE = K&7
PRINTSTRING("
ARRAY ".VAR_VNAME)
IF I&X'40000' # 0 THEN VADDR = GLAAD ELSE VADDR = OLDLNB
HDADDR = VADDR+I&X'3FFFF'
! VALIDATE HEADER ADDRESS AND THE 2 DESCRIPTORS
*LDTB_X'18000010'
*LDA_HDADDR
*VAL_(LNB +1)
*JCC_3,<HINV>
ARRD = LONG INTEGER(HDADDR)
DOPED = LONG INTEGER(HDADDR+8)
*LD_ARRD
*VAL_(LNB +1)
*JCC_3,<HINV>
*LD_DOPED
*VAL_(LNB +1)
*JCC_3,<HINV>
BASEADDR = INTEGER(ADDR(ARRD)+4)
DCODEDV(DOPED,LBS,UBS)
ND = LBS(0)
IF TYPE # 5 THEN ELSIZE = 1<<(PREC-3) ELSE START
I = INTEGER(ADDR(DOPED)+4)
ELSIZE = INTEGER(I+12*(ND-1)+4)
FINISH
! PRINT OUT AND CHECK ARRAYS BOUND PAIR LIST
PRINT SYMBOL('('); J = 0
CYCLE I = 1,1,ND
SUBS(I) = LBS(I); ! SET UP SUBS TO FIRST EL
WRITE(LBS(I),1)
PRINT SYMBOL(':')
WRITE(UBS(I),1)
PRINT SYMBOL(',') UNLESS I = ND
J = 1 IF LBS(I) > UBS(I)
REPEAT
PRINT SYMBOL(')')
NEWLINE
IF J # 0 THEN PRINTSTRING("BOUND PAIRS INVALID") AND RETURN
! WORK OUT HOW MANY ELEMENTS TO PRINT ON A LINE
IF TYPE = 5 THEN ELSPERLINE = 1 ELSE START
IF ELSIZE <= 4 THEN ELSPERLINE = 6 ELSE ELSPERLINE = 4
FINISH
CYCLE ; ! THROUGH ALL THE COLUMNS
! PRINT COLUMN HEADER EXCEPT FOR ONE DIMENSION ARRAYS
IF ND > 1 THEN START
PRINT STRING("
COLUMN (*,")
CYCLE I = 2,1,ND
WRITE(SUBS(I),1)
PRINT SYMBOL(',') UNLESS I = ND
REPEAT
PRINT SYMBOL(')')
FINISH
! COMPUTE THE ADDRESS OF FIRST ELEMENT OF THE COLUMN
K = 0; M1 = 1; I = 1
WHILE I <= ND CYCLE
K = K+M1*(SUBS(I)-LBS(I))
M1 = M1*(UBS(I)-LBS(I)+1)
I = I+1
REPEAT
VADDR = BASEADDR+K*ELSIZE
REFADDR = 0; ! ADDR OF LAST ACTUALLY PRINTED
DUPSEEN = 0; ELSONLINE = 99; ! FORCE FIRST EL ONTO NEW LINE
! CYCLE DOWN THE COLUMN AND PRINT THE ELEMENTS. SEQUENCES OF REPEATED
! ELEMENTS ARE REPLACED BY "(RPT)". AT THE START OF EACH LINE THE
! CURRENT VALUE OF THE FIRST SUBSCRIPTED IS PRINTED FOLLOWED BY A APAREN
CYCLE I = LBS(1),1,UBS(1)
IF REFADDR # 0 THEN START ; ! CHK LAST PRINTED IN THIS COL
K = CHECK DUPS(REFADDR,VADDR,ELSIZE)
IF K # 0 THEN START
PRINT STRING("(RPT)") IF DUPSEEN = 0
DUPSEEN = DUPSEEN+1
-> SKIP
FINISH
FINISH
! START A NEW LINE AND PRINT SUBSCRIPT VALUE IF NEEDED
IF DUPSEEN # 0 OR ELS ON LINE >= ELS PER LINE START
NEWLINE; WRITE(I,3); PRINT STRING(")")
DUPSEEN = 0; ELS ON LINE = 0
FINISH
PRINT VAR(TYPE,PREC,0,LANG,1,VADDR)
ELSONLINE = ELSONLINE+1
REFADDR = VADDR
SKIP:
VADDR = VADDR+ELSIZE
ASIZE = ASIZE-1
EXIT IF ASIZE < 0
REPEAT ; ! UNTIL COLUMN FINISHED
NEWLINE
EXIT IF ASIZE <= 0 OR ND = 1
! UPDATE SECOND SUBSCRIPT TO NEXT COLUMN. CHECK FOR AND DEAL WITH
! OVERFLOW INTO NEXT OR FURTHER CLOUMNS
I = 2; SUBS(1) = LBS(1)
CYCLE
SUBS(I) = SUBS(I)+1
EXIT UNLESS SUBS(I) > UBS(I)
SUBS(I) = LBS(I); ! RESET TO LOWER BOUND
I = I+1
REPEAT
EXIT IF I > ND; ! ALL DONE
REPEAT ; ! FOR FURTHER CLOMUNS
RETURN
HINV:
PRINTSTRING(" HAS INVALID HEADER
")
END ; ! OF RT PRINT ARR
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,
9,9,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=64 THEN N=211; !CPU TIME EXCEEDED
IF INF=65 THEN N=213; !TERMINATION REQUESTED
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)
!*
IF N = 26 THEN PRINT SYMBOL(NEXT SYMBOL)
!* N=6(ARRAY BOUND FAULT) EXCLUDED FROM FOLLOWING - 19/3/76
IF N = 17 OR N = 10 THEN WRITE(INF,1)
NEWLINE
END ; ! ERMESS
!*
SYSTEMROUTINE MLIBERR(INTEGER N)
INTEGER I
*STLN_I
NDIAG(0,INTEGER(I),N,0)
END ; ! MLIBERR
!*
!%SYSTEMINTEGERFNSPEC WRITE JS VAR(%STRING (32) NAME, %C
INTEGER OPTION, ADDR)
!*
OWNINTEGERARRAY FLABKEY(0 : 32)
OWNINTEGERARRAY FLABINF(0 : 32)
OWNINTEGERARRAY FLABAD(0 : 32)
!*
OWNINTEGER FLABINDEX
OWNINTEGER FLABMAX
OWNINTEGER FTRACELEVEL = 2
!*
ROUTINESPEC PTRACE(INTEGER INDEX)
!*
SYSTEMROUTINE FAUX1(INTEGER EP, P1, P2)
OWNINTEGER ENTRYLNB
INTEGER I, J, F, CALL LNB, GLA AD, INDEX AD
SWITCH E(0 : 8)
UNLESS 0 <= EP <= 8 THEN RETURN
-> E(EP)
!*
!****** PRIME CONTINGENCY
E(0):
!J SIGNAL(0,P1,P2,F)
!J ENTRYLNB = P2
FLABMAX = 0
FLABINDEX = 0
FTRACELEVEL = 0
RETURN
!*
!****** HARDWARE DETECTED FAULT
E(1):
I=INTEGER(P2+16); !NORMAL PC
J=INTEGER(P2+72); !FAILING PC - IF SET
IF I>>18 = J>>18 THEN I=J; !USE FAILING PC IF SET
NDIAG(I,INTEGER(P2+8),10,INTEGER(P2))
-> EXIT
!*
!****** SOFTWARE DETECTED FAULT
E(2):
*STLN_I
IF P1 = 1 THEN P1 = 11; ! UNASSIGNED
IF P1 = 2 THEN P1 = 6; ! ARRAY BOUND
IF P1=3 THEN P1=36; !WRONG NO OF PARAMS
NDIAG(0,INTEGER(I),P1,P2)
-> EXIT
!*
!****** PAUSE
E(3):
!J; SELECTOUTPUT(107)
PRINTSTRING("
PAUSE ")
-> TEXT
!*
!****** STOP
E(4):
!J; SELECTOUTPUT(107)
PRINTSTRING("
STOP ")
TEXT:
IF P1 # 0 THEN START
IF INTEGER(P1) = 2 THEN START
PRINTSTRING(STRING(P1+4))
FINISH ELSE START
I = INTEGER(P1+4)
!J COMREG(24)=I; !RETURN CODE
WRITE(INTEGER(P1+4),1)
FINISH
FINISH
NEWLINE
RETURN IF EP = 3
EXIT:
SSERR(0)
!%IF FACILITY#0 %THEN TIDY EXIT
! I=ENTRYLNB
! %IF INTEGER(I)>I %THEN I=INTEGER(I)
!**I
!*PUT_X"4998"
! ST (TOS)
!*PUT_X'7D98'
! LLN (TOS)
!*PUT_X'3800'
! EXIT 0
!*
!****** TRACE1
!* P1>0 LABEL
!* P1=-1 RETURN
E(5):
IF P1 < 0 THEN START ; ! RETURN
I = 2
P1 = 0
FINISH ELSE START ; ! LABEL
J = FLABKEY(FLABINDEX)
IF J <= 0 AND FLABINF(FLABINDEX) = P1 THEN START
! REPEATED LABEL
IF J < 0 THEN I = J-1 ELSE I = -2
FLABKEY(FLABINDEX) = I
-> COMMON
FINISH
I = 0
FINISH
NOTE:
IF FLABINDEX = 32 THEN START
FLABMAX = 32
FLABINDEX = 0
FINISH
FLABINDEX = FLABINDEX+1
*STLN_CALL LNB
CALL LNB = INTEGER(CALL LNB)
GLA AD = INTEGER(CALL LNB+16)
INDEX AD = INTEGER(GLA AD+12)+INTEGER(CALL LNB+12)& C
X'FFFFFF'+12
FLABKEY(FLABINDEX) = I
FLABINF(FLABINDEX) = P1
FLABAD(FLABINDEX) = INDEX AD
COMMON:
RETURN IF FTRACELEVEL = 0 OR (I <= 0 AND FTRACELEVEL = 1)
PRINTSTRING("FTRACE: ")
PTRACE(FLABINDEX)
RETURN
!*
!****** TRACE2
!* ENTRY TO FN/SUBR
E(6):
I = 1
P1 = 0
-> NOTE
!*
E(7): ! FORTRAN I/O ERROR
E(8): ! FORTRAN FORMAT ERROR
*STLN_I
J=INTEGER(INTEGER(I)+8)-4; !PC OF CALL
IF P1 = -1 THEN I = INTEGER(INTEGER(I));! LNB OF USER PROGRAM
NDIAG(J,I,-1,0)
RETURN
END ; ! FAUX
!*
EXTERNALINTEGERFN ICL9CEINDEX(INTEGER L0,A0,L1,A1)
INTEGER I,J,K
L0=L0&255
L1=L1&255
IF L0>L1 THEN RESULT =0
IF L0=0 OR L1=0 THEN RESULT =0
J=BYTEINTEGER(A0)
CYCLE I=0,1,L1-1
IF J=BYTEINTEGER(A1+I) THENSTART
IF L1-I<L0 THEN RESULT =0
CYCLE K=0,1,L0-1
IF BYTEINTEGER(A0+K)#BYTEINTEGER(A1+I+K) THEN ->LOOP
REPEAT
RESULT =I+1
FINISH
LOOP: REPEAT
RESULT =0
END ;! ICL9CEINDEX
!*
ROUTINE PTRACE(INTEGER INDEX)
STRING (63) S
INTEGER I, P1, AD
I = FLABKEY(INDEX)
P1 = FLABINF(INDEX)
AD = FLABAD(INDEX)
S = STRING(AD)
IF I > 0 THEN START
IF I = 1 THEN START
IF S = 'S#GO' THEN START
PRINTSTRING("ENTER MAIN PROGRAM
")
RETURN
FINISH
PRINTSTRING("ENTER FN./SUBR. ")
FINISH ELSE START
PRINTSTRING("EXIT FN./SUBR. ")
FINISH
FINISH ELSE START
PRINTSTRING("LABEL ")
WRITE(P1,9)
FINISH
IF S = 'S#GO' THEN S = 'MAIN PROGRAM'
PRINTSTRING(" ".S)
IF I < 0 THEN START
PRINTSTRING(" (")
WRITE(-I,1)
PRINTSYMBOL(')')
FINISH
NEWLINE
RETURN
END ; ! PTRACE
!*
EXTERNALROUTINE ICL9CEFTRACE(INTEGERNAME N)
IF 0 <= N <= 2 THEN FTRACELEVEL = N ELSE FTRACELEVEL = 0
END ; ! ICL9CEFTRACE
!*
EXTERNALROUTINE ICL9CELABELS
INTEGER I
IF FLABINDEX = 0 THEN RETURN
IF FLABMAX = 0 THEN I = 1 ELSE I = FLABINDEX+1
PRINTSTRING("
***** LABEL TRACE *****
")
NEXT:
IF I > 32 THEN I = 1
PTRACE(I)
IF I = FLABINDEX THEN NEWLINE AND RETURN
I = I+1
-> NEXT
END ; ! ICL9CELABELS
!*
EXTERNALROUTINE ICL9CEDIAG; ! FORTRAN LIBRARY ROUTINE
INTEGER I
*STLN_I
!J; SELECTOUTPUT(107)
!J SELECTOUTPUT(99)
PRINTSTRING("
DIAGNOSTIC TRACE REQUESTED
")
NDIAG(0,I,0,0)
RETURN
END ; ! DIAG
!*
EXTERNALROUTINE ICL9CEXIT
SELECT OUTPUT(107)
PRINTSTRING('
STOP ''EXIT''
')
SSERR(0)
END ;! ICL9CEXIT
SYSTEMROUTINE ICL MATHS ERROR ROUTINE( C
INTEGER ADDRESS OF PARMS)
! MODIFIED 1/02/78 11.30
! THIS ROUTINE ACCEPTS CONTROL FROM AN ICL MATHS ROUTINE
! AFTER IT HAS FOUND A FAULT WITH ONE OF ITS
! PARAMETERS. THE ICL ERROR CONDITION NUMBER
! IS CONVERTED INTO A FORTRANG FAULT NUMBER,
! AND A MONITOR FROM THE APPROPRIATE POINT
! IS GIVEN. EXECUTION IS THEN TERMINATED
! UNDER CONTROL.
! THE PARAMETER ('ADDRESS OF PARMS') POINTS TO A FIVE BYTE AREA.
! EACH BYTE IS IDENTIFIED BY THE NAMES:- P1
! PROCNO
! ERRNO
! P2
! P3 RESPECTIVELY
! OF THE FIVE PARAMETERS PASSED, ONLY 'PROCNO' AND 'ERRNO' ARE
! RELEVANT: 'PROCNO' IDENTIFIES THE ICL MATHS ROUTINE WHICH
! ISSUED THE FAULT
! 'ERRNO' IDENTIFIES THE ACTUAL FAULT
! IN THIS ROUTINE, 'PROCNO' CAN TAKE THE FOLLOWING VALUES:-
! PROCNO ICL MATHS ROUTINE
! 1 - 3 SIN (SINGLE, DOUBLE, QUADRUPLE PRECISION)
! 4 - 6 COS
! 13 - 15 TAN
! 16 - 18 COT
! 22 - 24 ASIN
! 25 - 27 ACOS
! 37 - 39 ATAN2
! 49 - 51 CSIN
! 52 - 54 CCOS
! 73 - 75 SINH
! 76 - 78 COSH
! 97 - 99 EXP
! 103 - 105 LOG
! 106 - 108 LOG10
! 112 - 114 CEXP
! 115 - 117 CLOG
! 118 - 120 SQRT
! 124 - 126 'REAL' ** 'REAL'
! 133 - 135 'COMPLEX' ** 'REAL'
! 145 - 147 GAMMA
! 148 - 150 LGAMMA
! THE FOLLOWING TABLE REPRESENTS THE TRANSLATIONS EFFECTED
! FROM ICL ERROR CONDITION NUMBERS TO FORTRANG FAULTS
CONSTBYTEINTEGERARRAY ERROR CODE TABLE( 1:2 , 0:49)= C
54 , 71 , 55 , 71 , 70 , 70 , 70 , 70 , 56 , 57 ,
66 , 67 , 70 , 70 , 58 , 71 , 59 , 71 , 70 , 70 ,
70 , 70 , 70 , 70 , 60 , 71 , 70 , 70 , 70 , 70 ,
70 , 70 , 54 , 54 , 55 , 55 , 70 , 70 , 70 , 70 ,
70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 61 , 71 ,
62 , 71 , 70 , 70 , 70 , 70 , 70 , 70 , 70 , 70 ,
70 , 70 , 70 , 70 , 53 , 53 , 70 , 70 , 51 , 52 ,
51 , 52 , 70 , 70 , 53 , 53 , 52 , 71 , 50 , 71 ,
70 , 70 , 68 , 68 , 70 , 70 , 70 , 70 , 69 , 69 ,
70 , 70 , 70 , 70 , 70 , 70 , 65 , 65 , 63 , 64
! THE LIST OF FORTRANG MATHEMATICAL LIBRARY ERROR MESSAGES
! IS AS FOLLOWS:-
! FAULT MESSAGE
! 50 SQRT ARG NEGATIVE
! 51 LOG ARG NEGATIVE
! 52 LOG ARG ZERO
! 53 EXP ARG OUT OF RANGE
! 54 SIN ARG OUT OF RANGE
! 55 COS ARG OUT OF RANGE
! 56 TAN ARG OUT OF RANGE
! 57 TAN ARG INAPPROPRIATE
! 58 ASIN ARG OUT OF RANGE
! 59 ACOS ARG OUT OF RANGE
! 60 ATAN2 ARGS ZERO
! 61 SINH ARG OUT OF RANGE
! 62 COSH ARG OUT OF RANGE
! 63 LGAMMA ARG NOT POSITIVE
! 64 LGAMMA ARG TOO LARGE
! 65 GAMMA ARG OUT OF RANGE
! 66 COT ARG OUT OF RANGE
! 67 COT ARG INAPPROPRIATE
! 68 REAL EXPONENTIATION FAULT
! 69 COMPLEX EXPONENTIATION FAULT
! 70 FUNCTION NOT SUPPORTED
! 71 UNKNOWN FUNCTION FAULT
INTEGER PREVIOUS LNB; !POINTER TO THE STACK OF
! THE PREVIOUS ROUTINE
INTEGER FAULT; !FORTRANG EQUIVALENT FAULT TO
!ISSUED ICL MATHS FUNCTION
!ERROR NUMBER
INTEGER STACK SEGMENT NUMBER; !SEGMENT NUMBER OF THE STACK
INTEGER I; !WORK VARIABLE
INTEGER PROCNO
INTEGER ERRNO
INTEGER PC
PROCNO = BYTEINTEGER(ADDRESS OF PARMS+1)
ERRNO = BYTEINTEGER(ADDRESS OF PARMS+2)
! CONVERT ICL ERROR NUMBER TO FORTRANG FAULT
IF PROCNO <= 0 OR PROCNO > 150 THEN FAULT = 70 ELSE START
I = (PROCNO-1)//3
IF ERRNO <= 0 OR ERRNO >= 3 THEN START
IF 112 <= PROCNO <= 114 THEN FAULT = 53 ELSE START
IF 124 <= PROCNO <= 126 THEN FAULT = 68 ELSE START
IF 133 <= PROCNO <= 135 THEN FAULT = 69 C
ELSE START
FAULT = ERROR CODE TABLE(1,I)
IF FAULT ¬= 70 THEN FAULT = 71
FINISH
FINISH
FINISH
FINISH ELSE FAULT = ERROR CODE TABLE(ERRNO,I)
FINISH
! GET THE STACK SEGMENT NUMBER
*STLN_ PREVIOUS LNB ; !GET CURRENT STACK FRAME PTR
STACK SEGMENT NUMBER = (PREVIOUS LNB>>18)&X'00003FFF'
! SELECT OUTPUT (107)
SELECTOUTPUT(99)
! FIND THE STACK FRAME OF THE FORTRANG ROUTINE
! THAT CALLED THE ICL MATHS FUNCTION
! ------- AND WRITE OUT THE APPROPRIATE ERROR MESSAGE
GET NEXT FRAME:
PC = INTEGER(PREVIOUS LNB+8)-4
PREVIOUS LNB = INTEGER(PREVIOUS LNB)
IF STACK SEGMENT NUMBER ¬= ((PREVIOUS LNB>>18)& C
X'00003FFF') THEN PRINT STRING('
DIAGNOSTICS FAIL STACK CORRUPT
') C
AND STOP
IF INTEGER(PREVIOUS LNB+24) ¬= M'FDIA' C
THEN -> GET NEXT FRAME
NDIAG(PC,PREVIOUS LNB,FAULT,0); !WRITE OUT THE ERROR MESSAGE
! AND GIVE A MONITOR TRACE
END ; !OF ICL MATHS ERROR ROUTINE
SYSTEMROUTINE PPROFILE(INTEGER A, B)
INTEGER LINES, V, I, J, MAX, MAXMAX
LINES = A&X'FFFF'-1
MAX = 0
CYCLE I = 1,1,LINES
IF INTEGER(B+4*I) > MAX THEN MAX = INTEGER(B+4*I)
REPEAT
MAXMAX = MAX
MAX = 1+MAX//40; ! TWO&AHALF PER CENT
CYCLE I = 1,1,LINES
V = INTEGER(B+4*I)
IF V >= MAX THEN START
WRITE(I,4)
J = I
WHILE INTEGER(B+4*J+4) = V THEN J = J+1
IF J # I THEN PRINTSTRING("->") AND WRITE(J,4) C
ELSE SPACES(7)
I = J
WRITE(V,6)
IF V = MAXMAX THEN PRINTSTRING(" ***")
NEWLINE
FINISH
REPEAT
CYCLE I = 1,1,LINES
INTEGER(B+4*I) = 0
REPEAT
END
ENDOFFILE