! 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=0

%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<I %THEN FINISH= FINISH+ I
              %FINISH
 
             CNT= (FINISH-I)//4
         %IF CNT< 0 %THEN CNT= -CNT %AND INC= -4 %C
                    %ELSE INC=  4
 
      %WHILE CNT> 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<=Tstart<Topad %and diagdisp>0 %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 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
         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<<prec)//8) 
         %finish
      %finishelse  VADDR=GP +var_disp 
      PVAR(TYPE,PREC,NAM,0,VADDR)
     newline
%END


%ROUTINE PVAR(%INTEGER TYPE, PREC, NAM, FORM, %INTEGER VADDR { bytead})
!***********************************************************************
!*    OUTPUT A VARIABLE. FIXED FORMAT(FORM#0) TAKE 14 PLACES FOR       *
!*    VARIABLES UP TO 32 BITS AND 21 PLACES THEREAFTER                 *
!***********************************************************************
%STRING(255) %NAME SV
%INTEGER A 
%STRING(255) SX
%INTEGER K, I, J, DTOPHALF
%CONSTINTEGER UNASSI=X'80808080'
%SWITCH INTV, REALV(3:7)
     %BYTEINTEGERARRAYFORMAT SAFM(0:255)
     %BYTEINTEGERARRAYNAME SA
      %IF NAM#0 %THEN %START
         vaddr=integer(vaddr)
         { Valid address check. NS only}
         %unless bottomad<=vaddr<=x'FFFFFF' %or 0<=vaddr<Topad %thenc
            printstring(" Invalid Address ") %and phex(vaddr) %and %return
         ->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
