!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