! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
%OWN %STRING (90) copyright= " Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved."
!
!*****************************************************************
!*                                                                     *
!*  Joint Imp and Fortran Diagnostics module for Gould PN6000.         *
!*                                                                     *
!***********************************************************************
!
! Version 11
! Uses assembler not frigs to find value of BR2 on entry
! Version 10
! This version created by PDS by merging AK's npndiag9 and AAs utxcndiag16
! THe code for Fortran and conditional compilation for UTX and MPX
! has been left alone but never tested. THe IMP diags work with PDS revisions
! to IMP of Dec88. Earlier versions of IMP store the GLa address in the exception
! handler word and these will not work with this NDIAG
!
!---Conditional Compilation Constants:
                                         !
                                         !
%CONST %INTEGER UTX= 0
%CONST %INTEGER MPX= 1
%CONST %INTEGER NP1= 2

%CONST %INTEGER target=NP1

%CONST %INTEGER info=0   { verbose tracing }
%CONST %INTEGER Ccomp= 1
%CONST %INTEGER compiler= 1

!---Global Specs:
                                         !
                                         !
%EXTERNAL %STRING (15) %FN %SPEC itos(%INTEGER n)
! %EXTERNALROUTINESPEC fdiag (%INTEGER lnb,gla,pc,adiags,first, %INTEGERNAME flag)

      %IF target=MPX %THEN %START
                                         !
      %EXTERNAL %INTEGER %FN %SPEC validate(%INTEGER address,bytes)
         %IF compiler=Ccomp %START
         %EXTERNAL %ROUTINE %SPEC fexit %ALIAS "exit"(%INTEGER return code)
         %FINISH %ELSE %START
         %EXTERNAL %ROUTINE %SPEC fexit %ALIAS "f_exit"(%INTEGER return code)
         %FINISH
      %FINISH

      %IF target=UTX %OR target=NP1 %THEN %START
                                         !
      %EXTERNAL %INTEGER %FN %SPEC getpid
      %EXTERNAL %ROUTINE %SPEC kill(%INTEGER pid,signal)
      %EXTERNAL %ROUTINE %SPEC signal(%INTEGER trap,trap rtn)
      %EXTERNAL %ROUTINE %SPEC UNIX write %ALIAS "write"(%INTEGER chan,text adr,bytes)
      %EXTERNAL %INTEGER %FN %SPEC sbrk(%INTEGER n)
      %FINISH



!---Global Constants:
                                         !
                                         !
      %IF target=NP1 %THEN %START
      %OWN %INTEGER marker
      %CONST %INTEGER gla displacement= 20 {bytes from lnb}
      %CONST %INTEGER adr mask=X'FFFFFFFF'
      %FINISH %ELSE %START
                                         !if UTX or MPX
      %CONST %INTEGER gla displacement=  8 {bytes from lnb}
      %CONST %INTEGER adrmask=X'00FFFFFF'
      %FINISH




!---Global Variables:
                                         !
                                         !
%OWN %INTEGER ignore

      %IF target=MPX %THEN %START
                                         !
      %OWN %INTEGER abort code= 1
      %FINISH

      %IF target=UTX %OR target=NP1 %THEN %START
                                         !
      %OWN %INTEGER topad,bottomad,bottomlnb
      %FINISH

%OWN %INTEGER failed
%OWN %INTEGER signaled=0
%OWN %INTEGER firsttime=1



%INTEGER %FN mylnb
%INTEGER i
      *Eoldlnb; **i; *estore
      %RESULT=i
%END
      %IF target=UTX %OR target=NP1 %THEN %START

      %ROUTINE COREDUMP
!***********************************************************************
!*    Force a coredump after failure in case ADB etc is to be used
!***********************************************************************
      %OWN %STRING (8) abort text="IMP "
         signal(6 {SIGIOT},0 {SIG_dfl})
         UNIX write(2 {STDERR},addr(abort text)+1,length(abort text))
         kill(getpid,6 {SIGIOT})

      %END;                              !of COREDUMP
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!

      %FINISH %ELSE %START
                                         !if MPX



      %ROUTINE COREDUMP
                                         !
                                         !
      %INTEGER return code
         return code=abort code
         abort code=1

         fexit(return code)

      %END;                              !of COREDUMP
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
                                         !
                                         !
      %FINISH;                           !if MPX


      %IF target=NP1 %THEN %START

      %INTEGER %FN NDIAG STACK SIZE(%INTEGER dummy)
!*    a local routine to determine the size of NDIAG's                 *
!*     stack frame. It is dependent upon the storage                   *
!*     allocation of the IMP compiler.                                 *
!*    Dont change the first 4 declarations till assembler available    *
!***********************************************************************
      %INTEGER ndiag link {return address to NDIAG}
      %INTEGER ndiag code base {  code address of NDIAG}
      %INTEGER ndiag stack size {  size of NDIAG`s stack}
      %INTEGER lnb {lnb of this procedure  }
         lnb=mylnb
         ndiag link=integer(lnb+8)
         ndiag code base=integer(ndiag link)
         ndiag stack size=integer(ndiag code base)

         %RESULT=ndiag stack size
                                         !
      %END;                              !of NDIAG STACK SIZE
                                         !
                                         !
      %FINISH;                           !if NP1



%ROUTINE PHEX(%INTEGER val)

      %CONST %STRING (1) %ARRAY hex(0:15) =
 "0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F"

%INTEGER I
      %CYCLE I=28,-4,0
         printstring(Hex((Val>>I)&15))
      %REPEAT
%END;                                    !of Phex
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!





%ROUTINE DUMP(%STRING (31) text, %INTEGER start {from},finish {to})
%INTEGER CNT,INC
%INTEGER I,J

      %UNLESS TEXT="" %THEN %START
         NEWLINE
         SPACES(14)
         PRINT STRING(TEXT); NEWLINE
      %FINISH

      I=START
      %IF I<0 %THEN %START
         I=(I+3)&(-4)
         %IF FINISH>0 %THEN FINISH=I-FINISH
         %IF FINISH>I %THEN %RETURN
      %FINISH %ELSE %START

         I=I&(-4)
         %IF FINISH<0 %THEN %RETURN
         %IF FINISH<I %THEN FINISH=FINISH+I
      %FINISH

      CNT=(FINISH-I)//4
      %IF CNT<0 %THEN CNT=-CNT %AND INC=-4 %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 %THEN %EXIT
            I=I+INC
         %REPEAT

         NEWLINE
      %REPEAT

%END;                                    !of DUMP
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!




%INTEGER %FN ADR CONTENTS OF(%INTEGER address,bndry)
!***********************************************************************
!*    A procedure to validate the contents of the word                 *
!*      pointed at by ADDRESS as an address.                           *
!***********************************************************************
%INTEGER contents
      contents=integer(address)&adr mask
      %RESULT=0 %IF contents&(bndry-1)#0
      %RESULT=contents %IF (Target=UTX %OR Target=NP1) %AND ((contents>bottomad %AND %C
         contents<topad) %OR (contents>=bottom lnb %AND contents<=x'7fffffff'))

      %RESULT=contents %IF target=MPX %AND validate(contents,4)=0

      %RESULT=0 {invalid}
                                         !
%END;                                    !of ADR CONTENTS OF
!
%ROUTINE %SPEC Indiag(%INTEGER LNB,GP,ADIAGS,ADIDIA,mode,diag,asize,first,
   %INTEGER %NAME flag)

%EXTERNAL %ROUTINE NDIAG %ALIAS "s_ndiag"(%INTEGER pc,lnb,p3,p4)
                                         !
                                         !
                                         !
%EXTERNAL %ROUTINE %SPEC fdiag(%INTEGER lnb,gla,pc,adiags,first, %INTEGER %NAME flag)
%EXTERNAL %INTEGER %FN %SPEC sbrk(%INTEGER n)

%OWN %INTEGER once only, active
%OWN %INTEGER diagnosing

%INTEGER first { Must actually be first local }
%INTEGER second
%INTEGER gla
%INTEGER adiags
%INTEGER flag
%INTEGER i
%INTEGER adidia
%INTEGER oldlnb
%INTEGER adr of code;                    !address of address of start of code for current proc
%INTEGER base of code;                   !address of stack of code for current proc
%INTEGER stack size,nextstack size;      !size of stack for current proc
%INTEGER currlnb

! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!

      select output(2) { STDERR }
      %IF info#0 %START
         printstring("Ndiags enterered")
         phex(pc); space; phex(lnb); write(p3,8); write(p4,8); newline
      %FINISH
      %IF p3#0 %START { soft error }
         newline
         %IF p3>>8=1 %THEN printstring("** Any overflow ** ") %ELSE %IF p3=2049 %THEN %C
            printstring("** Unassigned Variable ** ") %ELSE %IF p3=2050 %THEN %C
            printstring("** Switch Bounds Exceeded  ** ") %ELSE %IF p3=513 %THEN %C
            printstring("** Top of Stack **") %ELSE %IF p3=1537 %THEN %C
            printstring("** Capacity Exceeded **") %ELSE %IF p3=21 %THEN %C
            printstring("** No %result **") %ELSE %IF p3=1281 %THEN %C
            printstring("** Invalid %FOR loop **") %ELSE %IF p3=1793 %THEN %C
            printstring("** Resolution error **") %ELSE %IF p3=1538 %THEN %C
            printstring("** Array bounds check **") %ELSE %IF p3=1285 %THEN %C
            printstring("** Expontiation out of bounds **") %ELSE %START
            printstring("** Imp Event")
            write(p3>>8,1)
            printstring("/")
            write(p3&255,1)
            printstring(" **")
         %FINISH
         newline
      %FINISH


      %IF target=UTX %OR Target=NP1 %START

         bottomad=0
         bottomlnb=lnb
         topad=sbrk(0) {maximum DATA address}
      %FINISH %ELSE %START { MPX }

         %IF validate(lnb,4)#0 %THEN ->stop

      %FINISH
      flag=1
      first=1
      second=m'SSSS';                    ! while adb needed to debug
      curr lnb=mylnb
      active=active+1
      %IF active>2 %START
         printstring("NDIAGS Looping
")
         %STOP
      %FINISH
      %IF target=NP1 %THEN %START
                                         !   Initialise for Scan Down the Stack
         %IF p4=X'80000000' %START;      ! Signal entry pc=br1
            base of code=pc
            stack size=integer(base of code)
         %ELSE
            stack size=ndiag stack size(1234)
!            curr lnb=addr(first)-x'70'
            %CYCLE i=0,1,1
               adr of code=integer(curr lnb+8); ! skip over stack frames
               base of code=integer(adr of code); !     belonging
               next stack size=integer(base of code); !     to NDIAG
               curr lnb=curr lnb+stack size; !     and %MONITOR
               stack size=next stack size
               %IF curr lnb=lnb %THEN %EXIT
               %IF info#0 %THEN %START
                  printstring("Frame discarded"); phex(curr lnb); newline
               %FINISH
            %REPEAT
            ->stop %IF lnb#curr lnb;     ! jump if something went wrong unwinding the
         %FINISH
      %FINISH;                           !  stack to the frame passed in by %MONITOR
      %CYCLE;                            ! up the stack

         adr of code=adr contents of(lnb+8,4)
         %IF info#0 %START
            printstring(" lnb = "); phex(lnb); newline
            printstring(" adr of code = "); phex(adr of code); newline
         %FINISH

         %IF adr of code=0 %THEN ->abandon

         base of code=adr contents of(adr of code,4)
         %IF info#0 %START
            printstring(" base of code = "); phex(base of code); newline
         %FINISH
         %IF base of code=0 %THEN ->abandon

         next stack size=integer(base of code)
         %IF info#0 %START
            printstring(" stack size = "); phex(stack size); newline
            printstring("next stack size="); phex(next stack size); newline
         %FINISH
         %IF (next stack size&3)>0 %THEN ->abandon
         %IF next stack size=0 %THEN ->abandon

         %IF next stack size<0 %THEN %START
            i=next stack size>>24
            %IF i\=x'80' %THEN ->abandon
            %EXIT
         %FINISH

         ->Next Frame %IF ignore>0

         %IF integer(base of code-8)=m'F77 ' %AND %C
            integer(base of code-4)#m'diag' %THEN %START
                                         !
                                         !   Analyse a Fortran Stack Frame
                                         !
                                         !In case we break in FDIAG avoid looping diagnostics by
                                         !ensuring we only call FDIAG once for each stack frame
            %IF onceonly=lnb %THEN coredump %ELSE onceonly=lnb

            adiags=integer(base of code-4)
            %IF adiags<=0 %THEN %START
               %IF adiags=0 %START
                  print string("
Fortran subprogram compiled without diagnostics

") %IF diagnosing#0
                  ->next frame
               %FINISH %ELSE print string("
Corrupt stack for Fortran subprogram") %AND ->dump stack
            %FINISH

            gla=adr contents of(lnb+gla displacement,4)
            %IF gla=0 %THEN %START
               print string("
Corrupt GLA Address")
               ->dump stack
            %FINISH

            i=adr contents of(gla+20,4)
            %IF i=0 %THEN %START { corrupted address of the diagnostic tables}
                                         !
               print string("
Corrupt Data for Fortran subprogram")
               ->dump stack
            %FINISH

            adiags=i+adiags
            diagnosing=1
                                         !FDIAG(lnb,GLA,base of code,adiags,first,flag)
            first=0
            ->nextframe
         %FINISH
         %IF integer(base of code-8)=m'IMP ' %START
            %IF info#0 %THEN printstring("imp marker present")
            gla=adr contents of(lnb+gla displacement,4)
            %IF gla=0 %THEN gla=adr contents of(lnb+4,4); ! try old format
            %IF gla=0 %THEN printstring("
Corrupt Gla address ") %AND ->dump stack
            i=adr contents of(gla+20,4)
            %IF i=0 %THEN printstring("
Corrupt Data for Imp Procedure ") %AND {->dump stack}->nextframe
            adiags=i
            %CYCLE i=lnb+12,4,lnb+512
               %IF integer(i)=m'IDIA' %START
                  %CONTINUE %IF (integer(i+4)>>16)&3#0
                  adidia=i
                  failed=0
                  oldlnb=lnb
                  Indiag(lnb,gla,adiags,adidia,0,2,0,first,flag)
                  first=0
                  %IF failed=1 %AND signaled>1 %THEN ->abandon
                  %EXIT
               %FINISH
            %REPEAT
            ->nextframe
         %FINISH
                                         !
                                         !   Stack Frame Not Recognised
                                         !
         %IF signaled>1 %THEN ->abandon

         newlines(2)
         dump("Unrecognosed Frame",lnb,stack size)

next frame:
         ignore=ignore-1
         %EXIT %IF flag=0 {stop at main program}

         lnb=lnb+stack size
         stack size=next stack size
      %REPEAT

STOP: newline
      active=active-1
      %IF P3=0 %THEN %RETURN
      coredump {unless P3=0}

ABANDON:
      print string("
Corrupt Stack Frame at "); phex(lnb); newline
      ->STOP

DUMP STACK:
      %IF signaled>1 %THEN ->abandon
      newlines(2)
      stack size=256 %IF stack size>256
      dump("Dump Of Stack",lnb,stack size)
      ->STOP


%END;                                    !of NDIAG
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!




      %IF target=UTX %OR target=NP1 %THEN %START

      %EXTERNAL %ROUTINE CALL NDIAG(%INTEGER levels {to hide})
                                         !
                                         !
         ignore=levels+1 {for CALL NDIAG}+1 {for %monitor  }

         %MONITOR

      %END;                              !of CALL NDIAG
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!





      %EXTERNAL %INTEGER %FN VALIDATE(%INTEGER address,length)
!
!
!
!
!     An externalroutine, primariliy for FDIAG, to
!
!        determine whether a given address is valid.
!
!
!        At Exit:   Result = 0 => address is valid
!                   Result\= 0 => address is not valid
!
!
!
         address=(address&adr mask)+length
         %IF address>bottomad %AND address<topad %THEN %RESULT=0 {okay}

         %RESULT=1 {invalid address}
                                         !
      %END;                              !of validate
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!

      %FINISH %ELSE %START
                                         !if MPX




      %EXTERNAL %ROUTINE CALL NDIAG(%INTEGER levels {to hide},return code)
                                         !
                                         !
         abort code=return code
         ignore=levels+1 {for CALL NDIAG}+1 {for %monitor  }

         %MONITOR

      %END;                              !of CALL NDIAG
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
                                         !
                                         !
      %FINISH;                           !if MPX



!*
! 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.
!!

%ROUTINE INDIAG(%INTEGER LP,GP,ADIAGS,ADIDIA,MODE,DIAG,ASIZE,FIRST, %INTEGER %NAME 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)   *
!***********************************************************************
%RECORD %FORMAT VARF(%SHORT %INTEGER FLAGS,DISP, %STRING (11) VNAME)
%ROUTINE %SPEC PLOCALS(%INTEGER ADATA, %STRING (15) LOC)
%ROUTINE %SPEC PSCALAR(%RECORD (VARF) %NAME VAR)
! %ROUTINESPEC PARR(%RECORD(VARF)%NAME VAR, %INTEGER ASIZE)
%ROUTINE %SPEC PVAR(%INTEGER TYPE,PREC,NAM,FORM, %INTEGER VADDR)
%INTEGER %FN %SPEC CKREC(%STRING (32) NAME); ! CHECK RECURSION
%RECORD %FORMAT RTHEADF(%SHORT %INTEGER RTLINE,LINENO POS,RTFLAGS,ENV,DISPLAY,RTTYPE,
   (%SHORT %INTEGER 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,PARM ADDR,I
      %OWN %INTEGER %ARRAY GLOBAD(0:20)
%INTEGER INHIBIT
%INTEGER refpt
%INTEGER RLEN
%INTEGER diagdisp
%OWN %INTEGER GLOBPTR
%STRING (10) STMNT
%STRING (20) PROC
%STRING (32) NAME
%OWN %INTEGER COUNT;                     ! Used in checking for recursion.


      %IF FIRST=1 %THEN GLOBPTR=0 %AND COUNT=0
      STMNT=" line"
      PROC=" routine/fn/map "
      DIAGDISP=shortINTEGER(ADIDIA+4)
      %CYCLE

         TStart=adiags+diagdisp
         Parm addr=adr contents of(Lp+12,4)
         %IF info#0 %THEN printstring("Parms at") %AND %C
            phex(parm addr) %AND newline
         %UNLESS Target=MPX %START
            %UNLESS 0<=Tstart<Topad %AND TStart&3=0 %THEN %C
               printstring("Stack frame is corrupt") %AND failed=1 %AND %RETURN
         %FINISH
         RTHEAD==RECORD(Tstart)
         %IF RTHEAD_LINENO POS=0 %THEN LINE=-1 %ELSE LINE=shortinteger(adidia+6)
         %IF RTHEAD_IDHEAD#0 %START
            %IF length(rthead_rtname)>32 %THEN %C
               printstring("Procedure name in Diagnostics Tables is corrupt
") %AND failed=1 %AND %RETURN
            NAME=RTHEAD_RTNAME
            INHIBIT=CKREC(NAME);         ! CHECK RECURSION
         %FINISH %ELSE 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 %ELSE %C
                  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) %ARRAY %NAME 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
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
!*
%INTEGER %FN CKREC(%STRING (32) NAME);   ! CHECK RECURSION
!********************************************************
!*    AVOID PRINTING TRACE OF RECURSING RTS             *
!********************************************************
%OWN %STRING (32) LASTNAME=""
      %IF LASTNAME=NAME %START
         COUNT=COUNT+1
         %IF COUNT=6 %THEN PRINTSTRING("


**** ".NAME." CONTINUED TO RECURSE ****

")
         %RESULT=1 %IF COUNT>5
      %FINISH %ELSE %START
         %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
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
%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)
         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=adidia-(rthead_linenopos-4)
      %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
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
%END
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
%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 }
         VADDR=refpt+var_disp
         %IF Vaddr<adidia %AND parm addr#0 %THEN vaddr=parm addr+8+var_disp
                                         ! Extract parameter from param area
      %FINISH %ELSE VADDR=GP+var_disp
      PVAR(TYPE,PREC,NAM,0,VADDR)
      newline
%END
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!


%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 (254) %NAME SV
%INTEGER A
%STRING (254) SX
%INTEGER K,I,J,DTOPHALF
%CONST %INTEGER UNASSI=X'80808080'
      %CONST %BYTE %INTEGER %ARRAY bytes(0:7)=0(3),1,2,4,8,8;
%SWITCH INTV,REALV(3:7)
%BYTE %INTEGER %ARRAY %FORMAT SAFM(0:254)
%BYTE %INTEGER %ARRAY %NAME SA
      %IF NAM#0 %THEN %START
         vaddr=adr contents of(vaddr,bytes(prec))
         %IF vaddr=0 %THEN printstring(" Invalid Address") %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
      i=integer(vaddr)
      ->NOT ASS %IF i=UNASSI
      printstring(" X'"); Phex(i)
      space; phex(integer(vaddr+4))
      printstring("'")
      %RETURN
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")
      failed=1
      %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' %THEN PRINT FL(REAL(vADDR),7) %ELSE %C
         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' %THEN %C
         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:
      %IF vADDR<0 %AND vADDR&1>0 %THEN %C
         vADDR=vADDR-1 {'to make even length local strings work on PERQ3'}
      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
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
%END;                                    ! OF RT IDIAGS
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!



%ROUTINE call monitor(%STRING %NAME text)
      newlines(2)
      print string("** ")
      print string(text)
      print string(" **
")
      ignore=3 {1 for call monitor 1 for calling routine and 1 for %monitor}
      %MONITOR
      Coredump
                                         !
%END;                                    !of call monitor
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!





%EXTERNAL %ROUTINE on Signal(%INTEGER signal,subcode,contextAd)
                                         !
                                         !
                                         !
                                         !A routine to catch one of the traps set by IMPENTRY


!The traps expected are:
                                         !
%CONST %INTEGER SIGQUIT=  3,
                SIGILL =  4,
                SIGIOT =  6,
                SIGEMT =  7,
                SIGFPE =  8,
                SIGBUS = 10,
                SIGSEGV= 11

      %CONST %STRING (19) %ARRAY FPE texts(19:24)= "Unordered Condition" ,
                                           "Divide by Zero"      ,
                                           "Underflow"           ,
                                           "Operand Error"       ,
                                           "Overflow"            ,
                                           "Signalling NAN"
%STRING (19) text
%SWITCH handle signal(SIGQUIT:SIGSEGV)
%INTEGER Br1,Br2,Event

      BR2=integer(contextad+8)
      BR1=integer(contextad+12)

      signaled=1; Event=X'F00'!subcode
      %IF signal>=SIGQUIT %AND signal<=SIGSEGV %THEN ->handle signal(signal)

handle signal(*): text="Signal ".itos(signal); ->monitor

handle signal(SIGBUS):
handle signal(SIGQUIT): text="QUIT signal"; ->monitor
handle signal(SIGILL): text="Illegal Instruction"; ->monitor
handle signal(SIGIOT): text="IOT signal (could be an ABORT call)"; ->monitor
handle signal(SIGEMT): text="EMT signal"; ->monitor
handle signal(SIGSEGV): text="Address Error"; ->monitor
handle signal(SIGFPE):
                                         !
                                         !   Decode SIGFPE Signal
                                         !
      %IF subcode=2 %THEN Event=X'102' %AND text="Divide By Zero" %ELSE %IF %C
         subcode=7 %THEN text="Bound Check Failure" %ELSE %IF %C
         subcode<19 %OR subcode>24 %THEN text="FPE signal" %ELSE text=FPE texts(subcode)

monitor: ndiag(Br1,BR2,Event,X'80000000')
                                         !call monitor (text)

%END;                                    !of on Signal
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!


!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd.  All Rights Reserved.
!
%END %OF %FILE