! EXTENDED FOR ALGOLE(60) WITH EBCDIC STRING !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 : 9) = %C " !???! "," IMP "," FORTRAN ", " IMPS "," ASMBLR "," ALGOL(E) ", " OPTCODE "," PASCAL "," SIMULA "," BCPL " %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 %EXTRINSICINTEGERARRAY SSCOMREG(0:60) %EXTRINSICINTEGER SSARRAYDIAG; !DETERMINES NO OF ELEMENTS TO BE PRINTED %SYSTEMROUTINESPEC FIO1(%INTEGER ADPARM) %SYSTEMROUTINESPEC ETOI(%INTEGER AD,L) %SYSTEMROUTINESPEC DUMP(%INTEGER S, F) %SYSTEMROUTINESPEC NCODE(%INTEGER S, F, A) %SYSTEMROUTINESPEC SIGNAL(%INTEGER I, J, K, %INTEGERNAME F) %SYSTEMROUTINESPEC PRINTMESS(%INTEGER N) %SYSTEMROUTINESPEC SSERR(%INTEGER N) !**DELEND !* %ROUTINESPEC INDIAG(%INTEGER OLDLNB, LANG, PCOUNT, MODE, DIAG, %C ASIZE, %INTEGERNAME FIRST, NEWLNB) %ROUTINESPEC ERMESS(%INTEGER N, INF) %INTEGERFNSPEC WTFAULT(%INTEGER INF) %ROUTINESPEC ICL9CELABELS ! FAULT EVENT MESSAGE ! 1 (1/2) REAL OVERFLOW ! 2 (0/0) REAL UNDERFLOW ! 3 (1/1) INTEGER OVERFLOW ! 4 (0/0) DECIMAL OVERFLOW ! 5 (1/3) ZERO DIVIDE ! 6 (6/2) ARRAY BOUNDS EXCEEDED ! 7 (6/1) CAPACITY EXCEEDED ! 8 (0/0) ILLEGAL OPERATION ! 9 (0/0) ADDRESS ERROR ! 10 (0/0) INTERRUPT OF CLASS ! 11 (8/1) UNASSIGNED VARIABLE ! 12 (F/1) TIME EXCEEDED ! 13 (F/2) OUTPUT EXCEEDED ! 14 (F/3) OPERATOR TERMINATION ! 15 (5/5) ILLEGAL EXPONENT ! 16 (5/4) SWITCH LABEL NOT SET ! 17 (0/0) CORRUPT DOPE VECTOR *** NO LONGER USED***** ! 18 (5/1) ILLEGAL CYCLE ! 19 (1/7) INT PT TOO LARGE ! 20 (5/6) ARRAY INSIDE OUT ! 21 (0/0) NO RESULT ! 22 (0/0) PARAM NOT DESTINATION ! 23 (2/1) PROGRAM TOO LARGE ! 24 (0/0) STREAM NOT DEFINED ! 25 (9/1) INPUT ENDED ! 26 (4/1) SYMBOL IN DATA ! 27 (0/0) IOCP ERROR *** NOT USED ON EMAS VMEB???***** ! 28 (3/1) SUB CHARACTER IN DATA ! 29 (0/0) STREAM IN USE ! 30 (B/1) GRAPH FAULT ! 31 (0/0) DIAGNOSTICS FAIL ! 32 (7/1) RESOLUTION FAULT ! 33 (0/0) INVALID MARGINS ! 34 (4/2) SYMBOL INSTEAD OF STRING ! 35 (0/0) STRING INSIDE OUT ! 36 (0/0) WRONG PARAMS PROVIDED ! 37 (0/0) UNSATISFIED REFERENCE ! 38 (0/0) Failure No. 38 ! 39 (0/0) Failure No. 39 ! 40 (0/0) Failure No. 40 ! 41 (0/0) Failure No. 41 ! 42 (0/0) Failure No. 42 ! 43 (0/0) Failure No. 43 ! 44 (0/0) Failure No. 44 ! 45 (0/0) Failure No. 45 ! 46 (0/0) Failure No. 46 ! 47 (0/0) Failure No. 47 ! 48 (0/0) Failure No. 48 ! 49 (0/0) Failure No. 49 ! 50 (5/2) SQRT ARG NEGATIVE ! 51 (5/3) LOG ARG NEGATIVE ! 52 (5/3) LOG ARG ZERO ! 53 (1/6) EXP ARG OUT OF RANGE ! 54 (1/4) SIN ARG OUT OF RANGE ! 55 (1/4) COS ARG OUT OF RANGE ! 56 (1/4) TAN ARG OUT OF RANGE ! 57 (1/4) TAN ARG INAPPROPRIATE ! 58 (0/0) ASIN ARG OUT OF RANGE ! 59 (0/0) ACOS ARG OUT OF RANGE ! 60 (0/0) ATAN2 ARGS ZERO ! 61 (0/0) SINH ARG OUT OF RANGE ! 62 (0/0) COSH ARG OUT OF RANGE ! 63 (0/0) LGAMMA ARG NOT POSITIVE ! 64 (0/0) LGAMMA ARG TOO LARGE ! 65 (0/0) GAMMA ARG OUT OF RANGE ! 66 (1/4) COT ARG OUT OF RANGE ! 67 (1/4) COT ARG INAPPROPRIATE ! 68 (0/0) REAL EXPONENTIATION FAULT ! 69 (0/0) COMPLEX EXPONENTIATION FAULT ! 70 (A/6) RADIUS ARGS TOO LARGE ! 71 (A/3) ARCTAN ARGS ZERO ! 72 (A/1) ARCSIN ARG OUT OF RANGE ! 73 (A/2) ARCCOS ARG OUT OF RANGE ! 74 (A/4) HYPSIN ARG OUT OF RANGE ! 75 (A/5) HYPCOS ARG OUT OF RANGE %ROUTINE TRANS(%INTEGERNAME FAULT, EVENT, SUBEVENT) !*********************************************************************** !* TRANSLATE FAULT TO EVENT & VICE VERSA * !*********************************************************************** %CONSTINTEGER MAXFAULTS=75 %CONSTBYTEINTEGERARRAY FTOE(1:MAXFAULTS)= %C X'12',0,X'11',0,X'13',X'62',X'61',0(3), X'81',X'F1',X'F2',X'F3',X'55',X'54', 0,X'51',X'17',X'56',0(2),X'21',0, X'91',X'41',0,X'31',0,X'B1',0,X'71', 0,X'42',0(15),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,J %IF FAULT=0 %THEN %START; ! EVENT-SUBEVENT GIVEN J=EVENT<<4+SUBEVENT %RETURN %IF J=0; ! %MONITOR %CYCLE K=1,1,MAXFAULTS %IF J=FTOE(K) %THEN FAULT=K %AND %RETURN %REPEAT %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 ASSDUMP(%INTEGER PCOUNT, OLDLNB) %INTEGER I PRINTSTRING(" PC =") PRHEX(PCOUNT,8) PRINTSTRING(" LNB =") PRHEX(OLDLNB,8) PRINTSTRING(" CODE ") NCODE(PCOUNT-64,PCOUNT+64,PCOUNT-64) PRINTSTRING(" GLA ") I=INTEGER(OLDLNB+16) DUMP(I,I+128) PRINTSTRING(" STACK FRAME ") DUMP(OLDLNB,OLDLNB+256) %END %ROUTINE ONCOND(%INTEGER EVENT, SUBEVENT, LNB) !*********************************************************************** !* UNWIND THE IMP STACK LOOKING FOR ON CONDITIONS * !*********************************************************************** %LONGREAL INFO %INTEGER GLAAD, LANG, TSTART, BIT, ONWORD, PREVLNB, I, STSTART, %C STSEG %UNLESS 1<=EVENT<=14 %THEN %RETURN BIT=1<<(EVENT+17) *LSS_(%LNB+0); *ST_PREVLNB STSTART=SSCOMREG(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) ! AMEND EXIT DESCRIPTOR OF NEXT LEVEL ! TO ENSURE ACS=2 AND PRCL UNSTACKS ! CORRECTLY IF RELEVANT 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 ! LAY DOWN A CONTINGENCY !AGAINST ERRORS IN MDIAGS I=0 *STLN_OLDLNB *JLK_3 *J_; !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 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 %IF GLA&X'80000000'#0 %THEN LNB=INTEGER(LNB) %C %AND ->NEXTLEVEL ! IGNORE BLOCKS WITH PULIC GLA ! MUST BE 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 %IF FAULT=10 %THEN FAULT=WTFAULT(INF) ! UNSCRAMBLE INTS TO ERRORS ! BEFORE ONCOND FOR O'FLOW ETC TRANS(FAULT,EVENT,SUBEVENT) ONCOND(EVENT,SUBEVENT,LNB) %UNLESS FAULT=0=EVENT %THEN SSCOMREG(10)=1; !FOR USE BY JCL FIRST=1 %IF FAULT>=0 %THEN %START %IF FAULT=0 %AND EVENT#0 %START PRINTSTRING(" MONITOR ENTERED ") PRINTSTRING("EVENT"); WRITE(EVENT,1) PRINTSYMBOL('/'); WRITE(SUBEVENT,1) %FINISH %ELSE %START %IF FAULT#0 %THEN SELECT OUTPUT(99); !DONT SELECT IF JUST CALL OF %MONITOR ERMESS(FAULT,INF) %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, %C NEWLNB) ! IMP DIAGS %IF NEWLNB=0 %THEN ->EXIT NEXTRT: ! CONTINUE TO UNWIND STACK PCOUNT=INTEGER(OLDLNB+8) NEXTRTF: ->EXIT %IF OLDLNB=SSCOMREG(36) %C %OR OLDLNB>>SEGSHIFT#NEWLNB>>SEGSHIFT ! FAR ENOUGH OLDLNB=NEWLNB *LDTB_X'18000010' *LDA_OLDLNB *VAL_(%LNB+1) *JCC_3, I=INTEGER(OLDLNB+16) *LDTB_X'18000020' *LDA_I *VAL_(%LNB+1) *JCC_3, 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 *ST_JJ; ! DESCPTR TO IMAGE STORE J<-JJ; ! GET ADDRESS FROM DESCRIPTOR 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 ! (TOP 2 BITS FOR ROUTINE TYPE.B'01'==SYSTEM ROUTINE) ! (NEXT BIT SET FOR EBCDIC CHARS&STRINGS(ALGOLE ONLY)) ! 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) %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) %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) %FINISH %ELSE 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 SSCOMREG(25)=0 %START %IF PCOUNT>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 %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 %IF WORD3#0 %START NEWLNB=INTEGER(OLDLNB) %UNLESS DIAG=1 %THEN NEWLINE %RETURN %FINISH %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)_VNAMEDOWN A(L)=A(U); ->UP FOUND: A(U)=D QSORT(A,I,L-1) QSORT(A,U+1,J) %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 I0 %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 %THEN PRINT SCALAR(VARS(I)) %REPEAT %IF ASIZE>0 %THEN %START %CYCLE I=1,1,NRECS %IF VARS(I)_VAL>>28&3#0 %THEN PRINT ARR(VARS(I), %C 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, 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 %STRING(255) EBCDIC %CONSTINTEGER UNASSI=X'81818181' %SWITCH INTV, REALV(3:7) ! USE VALIDATE HERE TO CHECK ACCESS *LDTB_X'18000010' *LDA_VADDR *VAL_(%LNB+1) *JCC_3, 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, %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: %IF WORD1&X'20000000'=0 %START; ! STRINGS IN ISO CODE I=BYTEINTEGER(VADDR) ->NOT ASS %IF BYTE INTEGER(VADDR+1)=UNASSI&255=I ->WRONGL %IF I>DTOPHALF&X'1FF';!CUR LENGTH>MAX LENGTH %FINISH %ELSE %START; ! STRINGS IN EBCDIC I=DTOPHALF&255 CHARNO(EBCDIC,0)=I; ! SET LENGTH K=0 %WHILE KNPRINT %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, %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 AND THE 2 DESCRIPTORS *LDTB_X'18000010' *LDA_HDADDR *VAL_(%LNB+1) *JCC_3, ARRD=LONG INTEGER(HDADDR) DOPED=LONG INTEGER(HDADDR+8) *LD_ARRD *VAL_(%LNB+1) *JCC_3, *LD_DOPED *VAL_(%LNB+1) *JCC_3, 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 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 1-D 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 !* %INTEGERFN WTFAULT(%INTEGER INF) !*********************************************************************** !* TURNS INTERRUPT WT INTO PROPER FAULT FOR COMMON CASES * !*********************************************************************** %CONSTBYTEINTEGERARRAY TR(0 : 13) = 1,2,3,4,5,6,7,3, 9,9,7,7,8,10 %INTEGER N N=10; ! DEFAULT FOR UNUSUAL CASE %IF INF=32 %THEN N=9; ! VSI MSG=ADDRESS ERROR %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=136 %THEN N=13; ! OUTPUT EXCEEDED %IF INF=140 %THEN N=25; ! INPUT ENDED %RESULT=N %END %ROUTINE ERMESS(%INTEGER N, INF) !*********************************************************************** !* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT * !*********************************************************************** %RETURN %IF N<=0 PRINTMESS(N) %IF N=26 %OR N=34 %THEN PRINT SYMBOL(NEXT SYMBOL) %IF N=10 %THEN WRITE(INF,1); ! GIVE WT FOR FUNNY INTS 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 FAUX(%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): SIGNAL(0,P1,P2,F) 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): PRINTSTRING(" PAUSE ") ->TEXT !* !****** STOP E(4): 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) SSCOMREG(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) %THEN %START %IF L1-ILOOP %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 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 %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) !*********************************************************************** !* SUPPORTS THE PROFILE FEATURE IN IMP BY GIVING THE LINE MAP * !* AND RESTTING ALL COUNTS * !*********************************************************************** %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("->") %C %AND WRITE(J,4) %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