! 21Nov93 Extended to cope with PENTIUM and old code gen ! by use of byte 1 of word4 in the gla(options word) !Modified 21/September/88 15:00 DELLDIAG8 !***************************************************** !* !* DRS/NX NDIAG - IMP monitors and trapped errors !* come here. This routine cycles !* down the stack, calling a lang. !* dept. routine to analyse each frame !* !***************************************************** %include "ftnht.inc" %constinteger no = 0 %constinteger yes= 1 %constinteger verbose=1 %constinteger COMPILE TIME= no !if COMPILE TIME= yes then this source will be used by either the ! the Fortran or Imp compiler !if COMPILE TIME= no then this source will be used by either the ! the Fortran or Imp runtime library (see the ! constant LIBRARY below). %if COMPILE TIME= no %thenstart %constinteger LIBRARY= Imp !if LIBRARY= Fortran then IMP diagnostics are not available !if LIBRARY= Imp then IMP and Fortran diagnostics are available %finish !---History: ! ! %c DELLDIAG8 updated ON SIGNAL so that it recognises the subcodes for a %c a SIGFPE signal which are made available on the Sequent: it %c is assumed that no subcode is made available on the U6000. !%c DELLDIAG7 derived from DELLDIAG6C, and includes changes from DELLDIAG6R %c which are included here under conditional compilation. Also %c includes FTN_HT. There exist various versions of DELLDIAG6R %c and DELLDIAG7 is an attempt to consolidate. From here on it %c is proposed that: !%c DELLDIAGxC - ndiag for the Fortrran/Imp compiler %c DELLDIAGxF - ndiag for the Fortran library %c DELLDIAGxI - ndiag for the Imp library (although it %c could be used in the Fortran library %c for development). %if COMPILE TIME= yes %thenstart %routine coredump ! ! %if Usechipfns= 0 {DRS286} %thenstart %externalshortintegerfnspec getpid %externalroutinespec kill (%shortinteger pid, signal) %externalroutinespec signal (%shortinteger trap, %integer trap rtn) %externalroutinespec write (%shortinteger chan, %integer text adr, bytes) %finishelsestart !if 386 (U6000, DRS300, Sequent, Dell) %externalintegerfnspec getpid %externalroutinespec kill (%integer pid, signal) %externalroutinespec signal (%integer trap, trap rtn) %externalroutinespec write (%integer chan, text adr, bytes) %finish %ownstring(9) abort text= " Fortran " signal ( 6 {SIGIOT}, 0 {SIG_DFL}) !disable any IOT traps write ( 2 {STDERR}, addr (abort text)+1, length (abort text)) !introduce impending coredump kill (getpid, 6 {SIGIOT}) !send an IOT signal to force a dump %end; !of coredump ! Coredump could call abort(3) but this would drag ! in all the C library I/O tidy-up routines which ! we do not require since our I/O is not compatible. ! So instead we mimic above what abort would do %finish; !if COMPILE TIME= yes %if COMPILE TIME= yes %OR LIBRARY= Imp %THENSTART %externalroutinespec phex(%integer n) %routinespec Indiag(%integer LNB,GP,ADIAGS,ADIDIA, %integer mode,diag,asize,first, %integername flag) !----------------------------------------------! ! ! ! ! ! DUMP ! ! ! ! ! !----------------------------------------------! %EXTERNALROUTINE DUMP %alias "s_dump" (%STRING(31) TEXT, %INTEGER START {from}, FINISH {to}) %INTEGER CNT,INC %INTEGER I, J %UNLESS TEXT="" %THENSTART NEWLINE SPACES (14) PRINT STRING (TEXT); NEWLINE %FINISH I= START %IF I< 0 %THENSTART I= (I+3) & (-4) %IF FINISH>0 %THEN FINISH= I+FINISH %FINISHELSESTART I= I & (-4) %IF FINISH 0 %CYCLE PRINTSYMBOL ('(') PHEX (I) PRINTSTRING (") ") %CYCLE J= 0,1,3 SPACES (2) PHEX (INTEGER(I)) CNT= CNT - 1 %IF CNT= 0 %THENEXIT I= I+INC %REPEAT NEWLINE %REPEAT %END; !of DUMP %finish %externalroutinespec Fdiag(%integer LNB,gla,PC,ADIAGS,first,%integername next) %externalstring(15) %fnspec itos(%integer n) %externalintegerfnspec Sbrk(%integer n) %owninteger ignore %owninteger signaled %owninteger Topad,Bottomad %owninteger startofstack !************************************************************* %externalroutine NDIAG %alias "s_ndiag"(%integer PC,LNB,p3,p4) %integer first,line,i,gla,adiags,flag,nextlnb,prevlnb,ad,bot %integer i2,lnb2,event,subevent %owninteger onceonly=0, diagnosing=0 %conststring(23)%array errtext(0:29)= %c {0 0/21} " No result", {1 1/1 } " Integer Overflow", {2 1/2 } "Real Overflow", {3 1/3 } "Zero divide ", {4 1/4 } "Trig Fn out of range", {5 1/5 } "Tan too large", {6 1/6 } "Exp too large", {7 2/1 } "Excess stack", {8 4/1 } "Symbol in Data", {9 4/2 } "Symbol in String", {10 5/1 } "Illegal cycle", {11 5/2 } "Sqrt negative", {12 5/3 } "Log negative", {13 5/4 } "Unused fault!", {14 5/5 } "Illegal exponetiation", {15 5/6 } "Array insideout", {16 6/1 } "Capacity exceeded", {17 6/2 } "Array bound fault", {18 7/1 } "Resolutione Fault", {19 8/1 } "Unassigned variable", {20 8/2 } "Switch Label not set", {21 9/1 } "Input ended", {22 A/all} "Library function fault", {23 F/1 } "Quit Signal", {24 F/2 } "Illegal Instruction", {25 F/3 } "Abort(etc) signal", {26 F/4 } "Address error", {27 F/5 } "FP Unit Error", {28 F/6 } "Unordered condition", {29 F/7 } "Unknown Signal occurred"; %constintegerarray Eindex(0:15)=-21,0,6,-1,7,9,15,17, 18,20,21,-1,-1,-1,-1,22; %if verbose=yes %then %start printstring(" Ndiag Entered ") printstring(" LNB = ") phex(LNB) printstring(" p3 = ") phex(p3) newline %finish event=p3>>8&15; subevent=p3&255 %if p3 #0 %start { soft error } ! ignore=1 %if p4#x'80000001' newline i=eindex(event) %if i#-1 %then printstring("** ".errtext(i+subevent)." **") newline %finish Topad = Sbrk(0) { Max DATA address - presumed positive } onceonly=0 diagnosing = 0 i=addr(pc)-8 prevlnb=i %if p4#x'80000001' %start { entry NOT from signal stack continuous } %cycle { Back down the stack looking for USER error frame } %if verbose=yes %then %start printstring("@@i,lnb,prevlnb=");phex(i);space;phex(lnb);space;phex(prevlnb) newline %finish %exit %if i=lnb prevlnb=i i=integer(i) %repeat %finish startofstack= x'00ffffff' ! (lnb & x'ff000000') flag=1 first=2 %cycle { through the user frames } %if verbose#0 %start dump("Raw Frame",prevlnb,lnb+8) %finish nextlnb = integer(lnb) %if ignore#0 %then %start %if verbose#0 %then printstring("Frame Ignored") %and newline ignore=ignore-1 ->nxtfr { ignore service rt } %finish %exit %if nextlnb=0 { check bottom stack } bot=prevlnb %if prevlnb=0 %then bottomad = lnb-1000 %else bottomad = prevlnb %if lnb-40 > bot %then bot=lnb-40 { limit search area} %if integer(lnb-8) = m'FDIA' %then ->fortfnd %cycle i=lnb,-4,bot { IDIA means IMP } { display means posn unknown } ->impfnd %if integer(i)=m'IDIA'{m'IDIA'} %repeat %if verbose=yes %or diagnosing#0 %then %start printstring(" No diags for stack frame ") phex(lnb); newline %finish i=lnb-bottomad; %if i>256 %then i=256 dump("Unknown frame in HEX",lnb-i,i) ->nxtfr fortfnd: { In case we break in FDIAG avoid looping diagnostics by ensuring we } { only call FDIAG once for each stack frame } diagnosing = 1 %if onceonly= lnb %thenstart %if COMPILE TIME= no %thenstart print string (" Diagnostics aborted") newlines (2) %stop %finishelse coredump %finishelse onceonly= lnb GLA = integer(lnb-4) Adiags = shortinteger(lnb-12) %if Adiags<=0 %start %if Adiags=0 %then printstring(" Fortran subprogram compiled without diagnostics ") %finishelsestart i=integer(gla+20) %if i<0 %or (i&3)#0 %then printstring(" Corrupt Data for Fortran subprogram ") %and ->nxtfr Adiags=i+Adiags flag=-1 FDIAG(lnb,GLA,0,adiags,first,flag) %finish ->nxtfr impfnd: %if integer(i-4)=x'49414944' %then i=i-4 { beware coincidence NS only } diagnosing = 1 GLA = integer(i+4) Adiags = integer(GLA+20) flag=-1 %if verbose=yes %start printstring("Gla and diags area = "); phex(Gla); space phex(adiags); newline %finish %if COMPILE TIME= yes %or LIBRARY= Imp %thenstart INDIAG(lnb,gla,adiags,i,0,2,0,first,flag) %finish nxtfr: %exit %if flag=0 { stop at main program } %if first = 2 %then first = 1 %else first = 0 prevlnb=lnb lnb=nextlnb %repeat !---Terminate Diagnostics: ! %if COMPILE TIME= yes %thenstart coredump {%unless p3= 0} %finishelsestart print string (" End of diagnostics") newlines (2) %stop %finish %end; !of NDIAG !****************************************************************** { Called when wanting a monitor which hides 'levels' from the user } %externalroutine CALLNDIAG(%integer levels) ignore = levels +1 %monitor ! NDIAG(0,0,0,0) %end %if COMPILE TIME= yes %or LIBRARY= Imp %thenstart !* ! LAYOUT OF DIAGNOSTIC TABLES { THIS INFO EX_EMAS AND VERY OLD } !****** ** ********* ****** ! 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. !! !! NOTE: ALL DISPLACEMENTS ARE BYTE WITHIN THE DIAGNOSTIC TABLES. !! %{EXTERNAL}ROUTINE INDIAG(%INTEGER LP,GP,ADIAGS,ADIDIA,MODE, %C DIAG, ASIZE, FIRST, %INTEGERNAME FLAG) !*********************************************************************** !* THE DIAGNOSTIC ROUTINE 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) * !*********************************************************************** %RECORDFORMAT VARF(%shortinteger FLAGS,DISP, %STRING (11) VNAME) %ROUTINESPEC PLOCALS(%INTEGER ADATA, %STRING (15) LOC) %ROUTINESPEC PSCALAR(%RECORD(VARF)%NAME VAR) ! %ROUTINESPEC PARR(%RECORD(VARF)%NAME VAR, %INTEGER ASIZE) %ROUTINESPEC PVAR(%INTEGER TYPE, PREC, NAM, FORM, %C %INTEGER VADDR) %INTEGERFNSPEC CKREC(%STRING(255) NAME); ! CHECK RECURSION %RECORDFORMAT RTHEADF(%shortinteger RTLINE,LINENO POS,RTFLAGS, ENV,DISPLAY,RTTYPE, (%shortinteger IDHEAD %OR %STRING(11) RTNAME)) !* FOLLOWED BY 32 BITS ONCOND WORD !* !* %RECORD(RTHEADF)%NAME RTHEAD %RECORD(VARF)%NAME VAR %INTEGER TYPE %INTEGER GLAAD, LINE, NAM, PREC, TSTART, I %OWNINTEGERARRAY GLOBAD(0:20) %INTEGER INHIBIT %integer refpt %INTEGER RLEN %integer diagdisp,lflag,linedisp %OWNINTEGER GLOBPTR %STRING (10) STMNT %STRING (20) PROC %STRING (255) NAME %OWNINTEGER COUNT; ! Used in checking for recursion. %IF FIRST=1 %THEN GLOBPTR=0 %and COUNT = 0 STMNT=" line" PROC=" routine/fn/map " lflag=integer(gp+16)>>16&255 %if lflag=1 %start { Pentium generator } %if Verbose#0 %Then printstring("Pentium CG") %and newline diagdisp=integer(adidia-8) linedisp=-12 %else DIAGDISP = shortINTEGER(ADIDIA-2) linedisp=-4 %finish %cycle TStart = adiags+diagdisp %unless 0<=Tstart0 %then %start %if Verbose#0 %Then printstring("Stack frame is corrupt") %return %finish RTHEAD==RECORD(Tstart) %IF RTHEAD_LINENO POS=0 %THEN LINE=-1 %ELSE LINE=shortinteger(adidia+linedisp) %IF RTHEAD_IDHEAD#0 %START NAME = RTHEAD_RTNAME %if length(name)>32 %then printstring("Procedure name in Diagnostics Tables is corrupt ") %and %return INHIBIT = CKREC (NAME); ! CHECK RECURSION %FINISHELSE inhibit=0 %if inhibit=0 %start NEWLINE %IF MODE=1 %THEN PRINTSTRING(" IMP ") %ELSE %START %IF FIRST=1 %then PRINTSTRING("Diagnostics ") %and first=0 PRINTSTRING("Entered from") %FINISH %IF RTHEAD_RTLINE=0 %START %IF MODE=0 %THEN PRINTSTRING(" IMP ") PRINTSTRING("ENVIRONMENTAL BLOCK ") flag=0 %return ! %exit %FINISH %ELSE %START %IF LINE>=0 %AND LINE#RTHEAD_RTLINE %START PRINTSTRING(STMNT) WRITE(LINE,4) PRINTSTRING(" of") %FINISH %IF RTHEAD_IDHEAD=0 %THEN PRINTSTRING(" Block") %AND RLEN=20 %elseC PRINTSTRING(PROC.NAME) %AND RLEN=(20+LENGTH(RTHEAD_RTNAME))>>2<<2 PRINTSTRING(" starting at".STMNT) WRITE(RTHEAD_RTLINE,2) NEWLINE %IF MODE=0 %OR DIAG>1 %START PLOCALS(TSTART+RLEN,"Local") %IF RTHEAD_RTFLAGS&X'C000'#0 %START; ! EXTERNAL(ETC) ROUTINE I = ADIAGS + (RTHEAD_ENV+20) PLOCALS(I,"Global") %FINISH %FINISH %FINISH %FINISH { inhibit } %IF RTHEAD_IDHEAD#0 %START FLAG = 1 ;! ROUTINE %UNLESS DIAG = 1 %OR INHIBIT=1 %THEN NEWLINE %RETURN %FINISH DIAGDISP=RTHEAD_ENV %REPEAT %UNTIL DIAGDISP=0 FLAG = 0 ;! MAIN PROGRAM NEWLINE %RETURN !%ROUTINE QSORT(%RECORD(VARF)%ARRAYNAME A, %INTEGER I, J) !%RECORD (VARF)D !%INTEGER L, U ! %IF I>=J %THEN %RETURN ! L = I - 1; U = J; D = A(J) ! %CYCLE ! %CYCLE ! L = L+1 ! {%EXIT outer loop} %IF L=U %THEN -> FOUND ! %REPEAT %UNTIL A(L)_VNAME>D_VNAME ! A(U) = A(L) ! %CYCLE ! U = U-1 ! {%EXIT outer loop} %IF L=U %THEN -> FOUND ! %REPEAT %UNTIL D_VNAME>A(U)_VNAME ! A(L) = A(U) ! %REPEAT !FOUND: ! A(U) = D ! QSORT(A,I,L-1) ! QSORT(A,U+1,J) !%END !* %INTEGERFN CKREC(%STRING(255) NAME); ! CHECK RECURSION !******************************************************** !* AVOID PRINTING TRACE OF RECURSING RTS * !******************************************************** %OWNSTRING(51) LASTNAME="" %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 PLOCALS(%INTEGER ADATA, %STRING (15) LOC) !*********************************************************************** !* ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES* !*********************************************************************** %RECORD(VARF) %NAME VAR %INTEGER I, NRECS %INTEGER SADATA %IF loc="Global" %THEN %START I=0 %WHILE I0 %CYCLE VAR == RECORD(ADATA) %if verbose#0 %start printstring("Local found "); phex(integer(addr(var))); space; phex(integer(addr(var)+4)); newline %Finish NRECS=NRECS+1 ADATA=ADATA+((8+LENGTH(VAR_VNAME))>>2<<2) %REPEAT %RETURN %IF NRECS=0 %begin %RECORD(VARF)%ARRAY VARS(1:NRECS) %INTEGER I ADATA=SADATA %FOR I=NRECS,-1,1 %CYCLE VAR == RECORD(ADATA) VARS(I)<-RECORD(ADATA) ADATA = ADATA + ((8+LENGTH(VAR_VNAME))>>2<<2) %REPEAT ! QSORT(VARS,1,NRECS) refpt = lp+rthead_display { IMP vars disp not rel to lnb } %FOR I=1,1,NRECS %CYCLE %IF VARS(I)_FLAGS>>12&3=0 %THEN PSCALAR(VARS(I)) %REPEAT ! %IF ASIZE>0 %THEN %START ! %FOR I=1,1,NRECS %CYCLE ! %IF VARS(I)_FLAGS>>12&3#0 %THEN PARR(VARS(I), %C ! ASIZE) ! %REPEAT ! %FINISH %END %END %ROUTINE PSCALAR(%RECORD(VARF)%NAME 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 * !*********************************************************************** %INTEGER VADDR %INTEGER I,K %STRING (11) LNAME I=VAR_FLAGS ! printstring(" var_flags = "); !phex(var_flags); !newline K=I>>4 TYPE=K&7 PREC=K>>4&7 NAM=K>>10&1 LNAME<-VAR_VNAME." " PRINT STRING(LNAME."=") %IF I&4=0 %start { For non Owns } %if var_disp>rthead_display %then %start VADDR=refpt -var_disp %else VADDR=refpt -var_disp %if Lflag#0 %then vaddr=vaddr+8 %finish { diag tables point at rhs of var - } { we need the LHS so adjust by var size } %if nam#0 %thenc vaddr = vaddr - 4 %c %elsestart %if 1<=type<=2 %then vaddr = vaddr - ((1<NOT ASS %IF VADDR=UNASSI %FINISH ->ILL ENT %IF PREC<3; ! BITS NOT IMPLEMENTED %IF TYPE=1 %THEN ->INTV(PREC) %IF TYPE=2 %THEN ->REALV(PREC) %IF TYPE=5 %THEN ->STR %if type=3 %then ->REC INTV(4): ! 16 BIT INTEGER K=shortinteger(vadDR) WRITE(K,12*FORM+1) %RETURN INTV(6): ! 64 BIT INTEGER REALV(7): ! 128 BIT REAL 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 i = integer(vaddr) ->NOT ASS %IF i=UN ASSI WRITE(i,1+12*FORM) %UNLESS FORM=1 %OR -255<=i<=255 %START PRINTSTRING(" (X'") PHEX(i); 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 %if integer(vaddr)&x'7f800000' # x'7f800000' %thenc PRINT FL(REAL(vADDR),7) %else printstring(" Invalid real ") printstring(" x'") phex(integer(vaddr)) printstring("'") %RETURN REALV(6): ! 64 BIT REAL ->NOT ASS %IF UNASSI=INTEGER(vADDR)=INTEGER(vADDR) %if integer(vaddr)&x'7ff00000' # x'7ff00000' %thenc PRINT FL(LONG REAL(vADDR),14) %else printstring(" Invalid real ") printstring(" x'") phex(integer(vaddr)) phex(integer(vaddr+4)) printstring("'") %RETURN REC: printstring(" Record(x'") %cycle i=0,4,20 { print hex contents of first six integers in a record } phex(integer(vaddr+i)) space %unless i = 20 %repeat printstring("')") %return STR: SV == STRING(vADDR) I = LENGTH(SV) ! ->NOT ASS %IF BYTE INTEGER(SVADDR+1)=UNASSI&255=I SA == ARRAY(VADDR,SAFM) K=1 %WHILE K<=I %CYCLE ->NPRINT %UNLESS 32<=SA(K)<=126 %OR SA(K)=10 K=K+1 %REPEAT space; printsymbol('"') PRINTSTRING(SV); PRINT SYMBOL ('"') %RETURN NPRINT: PRINT STRING(" CONTAINS UNPRINTABLE CHARS") %RETURN NOT ASS: PRINTSTRING(" NOT ASSIGNED") AIGN: %IF PREC>=6 %AND FORM=1 %THEN SPACES(7) %END; ! PVAR %END; ! OF RT IDIAGS %finish; !if COMPILE TIME= yes or LIBRARY= Imp %routine call monitor(%string(47) text) newlines(2) print string ("** ") print string (text) print string (" **") newlines (2) ignore=1 { hide top level as of no interest to user } { ie. this, ON rt and trap rt } %monitor %end; !of call monitor %if COMPILE TIME= no %thenstart %externalintegerfn Validate(%integer ad,len,access) { for Fdiag } %externalintegerfnspec impsaferead(%integer ad) %result=impsaferead(ad)!impsaferead(ad+len) %end; !of Validate %finish; !if COMPILE TIME= no %if COMPILE TIME= yes %or library=IMP{pro tem } %thenstart %externalroutine FDIAG(%integer lnb,gla,pc,adiags,first,%integername next) %end; !of FDIAG %finish; !if COMPILE TIME= yes %externalroutine on Signal %alias "f_onsignal"(%integer signal, subcode,contextAd) ! ! ! !A routine to catch one of the traps set by IMPENTRY !The traps expected are: ! %constinteger SIGQUIT= 3, SIGILL = 4, SIGIOT = 6, SIGEMT = 7, SIGFPE = 8, SIGBUS = 10, SIGSEGV= 11 !conststring(19) %array FPE texts (19:24)= "Unordered Condition" , "Divide by Zero" , "Underflow" , "Operand Error" , "Overflow" , "Signalling NAN" %string(47) text %switch handle signal (SIGQUIT:SIGSEGV) %integer Br1,Br2,event,i %if verbose=yes %start printstring(" On Signal "); phex(signal) printstring(" Subcode "); phex(subcode) printstring(" Contextad "); phex(contextad) newline newline %for i=0,4,96 %cycle phex(integer(contextad+i)); space; %repeat newline %finish %if Target=RTMX %start BR2=integer(contextad+12) BR1=integer(contextad+20) {pc} %if verbose=yes %start %finish %else %if env=IntelSolaris %start BR1=integer((contextad)+92); BR2=integer((contextad)+60); %else BR1=integer(addr(contextad)+52) BR2=integer(addr(contextad)+20) %finish %if verbose=yes %start newline %for i=0,4,96 %cycle phex(integer(addr(contextad)+i)); space; %repeat %finish %finish signaled=1 %if signal>= SIGQUIT %and %c signal<= SIGSEGV %then -> handle signal (signal) handle signal (*) : text= "Signal " . itos (signal); event=x'f01'; -> monitor handle signal (SIGQUIT): text= "QUIT signal"; event=x'f01' ; -> monitor handle signal (SIGILL) : text= "Illegal Instruction"; event=x'f02' ; -> monitor handle signal (SIGIOT) : text= "IOT signal (could be an ABORT call)"; event=x'f03'; -> monitor handle signal (SIGEMT) : text= "EMT signal"; event=x'f01' ; -> monitor handle signal (SIGBUS) : handle signal (SIGSEGV): text= "Address Error"; event=x'f04' ; -> monitor handle signal (SIGFPE ): ! ! Decode SIGFPE Signal ! %if ENV= SEQUENT %thenstart ! %if subcode & x'01'# 0 %then text= "Invalid operation" %elsec %if subcode & x'02'# 0 %then text= "Denormal" %elsec %if subcode & x'04'# 0 %then text= "Divide by zero" %elsec %if subcode & x'08'# 0 %then text= "Overflow" %elsec %if subcode & x'10'# 0 %then text= "Underflow" %elsec %if subcode & x'20'# 0 %then text= "Precision" %elsec %if subcode & x'40'# 0 %then text= "Stack overflow/underflow" %c %else text= "" text= "Floating Exception: " . text %finishelsestart ! %if subcode= 2 %then text= "Divide By Zero" %elsec ! %if subcode= 7 %then text= "Bound Check Failure" %elsec ! %if subcode< 19 %orc ! subcode> 24 %then text= "FPE signal" %c ! %else text= FPE texts (subcode) text= "FPE signal"; event=x'102' %finish monitor: %if verbose=yes %start printstring("*** ".text." ***") newlines(2) %finish ndiag(Br1,BR2,event,x'80000001') %end; !of on Signal %endoffile