!
!******************************************
!*                                        *
!*  MODIFIED MDIAG TO CO-OPERATE WITH     *
!*  THE IMP INTERPRETER (FLAG = 5)        *
!*                                        *
!******************************************
!
%DYNAMICROUTINESPEC DEFINE(%STRING(63) S)
%SYSTEMINTEGERFNSPEC I8DIAG(%INTEGER EP, EXTRA)
%OWNINTEGER MON HEX ADDR, BRIEF ADDR
%OWNINTEGER DTLAST = 0
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)

%ROUTINE SIGNAL(%INTEGER J,K,L,%INTEGERNAME FLAG)
%RECORDFORMAT AGFM(%INTEGER EP,%STRING(17) S,%INTEGER P1,P2,%C
%INTEGERNAME FLAG)
%SYSTEMROUTINESPEC AGENCY(%INTEGER P1,%RECORDNAME P)
%RECORD P(AGFM)
P_EP=J
P_P1=K
P_P2=L
P_FLAG==FLAG
AGENCY(2,P)
%END
%SYSTEMROUTINE PDIAG(%INTEGER PCOUNT, FAULT, INF)
!***********************************************************************
!*       FAILED ROUTINE FROM BYTE 4 OF THE GLA AND CALLS APPROPRIATE   *
!*       GIVEN.                                                        *
!*       PCOUNT = ADDR(PCOUNTER+REGISTERS AT FAILURE)                  *
!*       FAULT  = FAILURE  (0=%MONITOR  REQUESTED)                     *
!*       INF    =ANY FURTHER INFORMATION                               *
!***********************************************************************
%SHORTROUTINE
!
! COMMUNICATION VARIABLES FOR IMPI
!
%EXTRINSICBYTEINTEGER INIMPI;           ! SHOW IF IN INTERPRETER
%EXTRINSICINTEGER REG9;                 ! REG 9 FROM IMPI
%EXTRINSICINTEGER INTGLA;               ! GLA OF IMPI
!
%SYSTEMROUTINESPEC IIDUMP(%INTEGER I, J)
%SYSTEMROUTINESPEC FINDEP(%STRING (8) EP, %INTEGERNAME I)
%ROUTINESPEC ASSDUMP(%INTEGER I, J)
%ROUTINESPEC ENTER(%INTEGER NUM, PARS, %INTEGERNAME F)
%OWNSTRING (8) %ARRAY EPS(0 : 5) =     'S#ERMESS','S#INDIAG',
               'S#FDIA','F#LABS',
         ''(2)
%OWNINTEGERARRAY CGE(0 : 14)
%EXTERNALBYTEINTEGER MDACTIVE = 0
%INTEGER LANGFLAG, I, J, GLA, OLDREG, ANEWREG, NEWREG, SGLA
%SWITCH LANGUAGE(0 : 5)
%STRING (1) FAILNO
%INTEGERARRAY REGS(-1 : 24);            ! PCOUNTER,GRS & FRS IN HERE
         %OWNSTRING(9)%ARRAY LT(0:5)' !???! ',' IMP ',' FORTRAN ',
                                    ' IMPS ',' ASMBLR ',' IMPI '
   *OI_4(13),5
   MON HEX ADDR = ADDR(COMREG(25))
   BRIEF ADDR = MON HEX ADDR+1
   DTLAST = 0

   %CYCLE I = 0, 1, 14;  CGE(I) = 0
   %REPEAT;
                                        ! ONLY NEEDED ON EMAS
   ANEWREG = ADDR(NEWREG)
! LAY DOWN A CONTINGENCY AGAINST ERRORS IN MDIAGS
   I = 0
   %IF INIMPI = 0 %START
      *LA_15,<MDERROR>
      *L_1,REGS;  *STM_4,15,16(1);      ! STUFF OFF REGISTERS
      SIGNAL(0, ADDR(REGS(4)), 0, I)
   %FINISH
   MDACTIVE = MDACTIVE+1
   FAILNO = '1'
   %IF MDACTIVE > 5 %THEN -> EOUT
   FAILNO = '2'
   %IF I > 0 %THEN -> EOUT;             ! CONTINGENCY DID NOT GO DOWN
! COPY FAILURE REGS INTO ARRAY FOR CONVENIENCE
   *L_1,PCOUNT;  *L_2,REGS+4;  *MVC_0(100,2),0(1)
   GLA = REGS(13)
   FAILNO = '3'
   -> EOUT %UNLESS 0 < GLA < X'FFFFFF' %AND GLA&7 = 0
!
! NOW SET UP OUTPUT FILE IF NESC.
!
   SGLA = INTEGER(GLA+20)
   LANGFLAG = BYTE INTEGER(GLA+4)>>4
   LANGFLAG = 0 %IF LANGFLAG > 5
   PRINT STRING('
MONITOR ENTERED FROM'.LT(LANGFLAG).'

') %C
      %IF INIMPI = 0
! ONLY IF NOT IN IMPI
   %UNLESS (FAULT = 35 %AND INF = 0) %THEN %START
!
!        ON THE 370 THERE NEEDS TO BE A MECHANISM TO GIVE
!        THE FOLLOWING CODE IS EXECUTED EXCEPT AFTER SUCH A MESSAGE.
!
!
      %IF LANGFLAG = 2 %THEN ENTER(3, ADDR(FAULT), I)
                                        ! LABEL TRACE
      ENTER(0, ADDR(FAULT), I) %IF INIMPI = 0 %OR FAULT # 0
                                        ! ERROR MESSAGE
      %IF I < 0 %THEN %START
         %PRINTTEXT '
FAULT NO=';  WRITE(FAULT, 2)
      %FINISH
   %FINISH
!
!
   I = GLA
   OLDREG = ADDR(REGS(0));  -> LANGUAGE(LANGFLAG)
LANGUAGE(0):

   -> EXIT %IF INIMPI # 0
LANGUAGE(4):                            ! UNKNOWN & ASSEMBLER
   ASSDUMP(PCOUNT, 1)
   -> EXIT;                             ! NO WAY OF TRACING BACK
LANGUAGE(1):


LANGUAGE(3):                            ! IMP & IMPS
   ENTER(1, ADDR(OLDREG), I);           ! IDIAGS
   -> EXIT %IF I < 0 %OR NEWREG = 0
NEXTRT:                                 ! CONTINUE TO UNWIND STACK
   OLDREG = NEWREG
   -> EXIT %IF (REG9 = 0 %OR INIMPI = 0) %C
      %AND INTEGER(OLDREG+44) <= COMREG(36)
   ! FAR ENOUGH
   I = INTEGER(OLDREG+52)
   -> IMPI %IF I = INTGLA
   LANGFLAG = BYTEINTEGER(I+4)>>4
   LANGFLAG = 0 %IF LANGFLAG > 5
   -> LANGUAGE(LANGFLAG)
IMPI:


LANGUAGE(5):                            ! IMPI
   %IF BYTEINTEGER(I+4) = X'55' %START; ! FROM I8IOCP SO SKIP IT
      NEW REG = INTEGER(OLD REG+32);    ! OLD REG 8
   %FINISH %ELSE %START
      NEWLINE
      NEW REG = I8DIAG(-1, OLDREG);     ! CALL IMPI MONITOR
      -> EXIT %IF NEW REG = REG 9;      ! END FROM '%MONITOR'
   %FINISH
   -> NEXT RT
LANGUAGE(2):                            ! FORTRAN
   ENTER(2, ADDR(OLDREG), I)
   -> EXIT %IF I < 0;  -> NEXT RT
MDERROR:                                ! ENTER FROM CONTINGENCY
   *ST_2,I;  *LA_1,4(1);  *ST_1,J
   %PRINTTEXT '
 INTERRUPT DURING DIAGNOSTICS  WT = '
   WRITE(I, 3)
   ASSDUMP(J, 1)
   -> QUIT
EOUT:                                   ! ERRROR EXIT
   PRINTSTRING('
PDIAG FAILS '.FAILNO)
   NEWLINE;  -> QUIT
EXIT:

   NEWLINE %IF NEW REG = 0
   SIGNAL(1, 0, 0, I) %IF INIMPI = 0;   ! POP UP CONTINGENCY
   MDACTIVE = 0;  INTEGER(GLA+20) = SGLA
   %IF FAULT = 0 %THEN -> END
   %IF COMREG(27)&X'400000' # 0 %THEN -> END;! FTRAN ERROR RECOV
QUIT:

   **1,COMREG(36)
   *LM_4,15, 16(1)
   *BCR_15,15

   %ROUTINE ENTER(%INTEGER NUM, PARS, %INTEGERNAME FLAG)
!***********************************************************************
!*THIS ROUTINE ATTEMPTS TO ENTER THE ROUTINE WHOSE NAME IS EPS(NUM)    *
!* USING FINDEP. IF THE ROUTINE IS NOT IN STORE IT TRIES TO LOAD IT AS *
!* AN OVERLAY ON 4-70J AND 360OS. ON EMAS THE ROUTINES SHOULD ALWAYS BE*
!* IN VIRTUAL STORE. THE ARRAY CGE IS USED TO REMEMBER ROUTINES ENTERED*
!* AS THE FIND/LOAD/ENTER SEQUENCE IS EXPENSIVE                        *
!***********************************************************************
   %INTEGER I, J, K;                    ! ALL OF THESE ARE NEEDED
      %IF CGE(3*NUM+2) \= 0 %THEN -> ALREADY ENTERED
      FIND EP(EPS(NUM), I)
      %IF I <= 0 %THEN %START;          ! ERROR, ROUTINE SHOULD BE
                                        !LOADED
         PRINTSTRING('
UNABLE TO ENTER '.EPS(NUM))
         FLAG = -1
         -> END
      %FINISH
!        INSERT ENTRY INFORMATION INTO ARRAY CGE - USE M/C CODE
      **3,ADDR(CGE(3*NUM))
      *L_2,I;  *LM_0,2,4(2);  *STM_0,2,0(3)
   ALREADY ENTERED:                     ! ENTRY INFO IN ARRAY CGE
      **3,ADDR(CGE(3*NUM))
      *L_1,PARS;  *MVC_64(16,11),0(1);  ! MOVE IN UPTO 4 PARAMETERS
      *STM_0,15,0(11);                  ! 4 EXTRA REGS STORED IN CASE
                                        ! OF IIDUMPS WHILE DEBUGGING
      *LM_12,14,0(3);  *BALR_15,14
      FLAG = 0;                         ! FLAG TO 'SUCCESS'
   END:

   %END;                                ! OF ENTER

   %ROUTINE ASSDUMP(%INTEGER PCOUNT, FLAG)
   %INTEGER I
      COMREG(28) = 16;                  ! EMAS ONLY PERMIT HEX IIDUMP
      %PRINTTEXT '
P COUNTER AND REGISTERS
'
      IIDUMP(PCOUNT, PCOUNT+96)
      %PRINTTEXT '
CODE
'
      I = INTEGER(PCOUNT)&X'FFFFFF'
      IIDUMP(I-64, I+64)
      %RETURN %IF FLAG = 0
      %PRINTTEXT '
 GLA
'
      I = INTEGER(PCOUNT+56)
      IIDUMP(I, I+128)
   %END
END:

%END;                                   ! OF MDIAGS
!
! INDIAGS FOR IMPI
!

%SYSTEMROUTINE INDIAGS(%INTEGER OLDREG, %INTEGERNAME NEWREGS)
%SHORTROUTINE
%ROUTINESPEC FIND BLOCK
%ROUTINESPEC PRINT LOCALS
%ROUTINESPEC PRINT VAR
%BYTEINTEGERNAME MONHEX
%EXTERNALROUTINESPEC HEX(%INTEGER N)
%STRING (40) NAME
%INTEGER UGLAREG, FLINE, FBLINE, ADATA, BASEREG
%BYTEINTEGER BTYPE, NAM, TYPE, PREC
%INTEGER TSTART, PREV BLOCK
!
   MON HEX ADDR = ADDR(COMREG(25))
   BRIEF ADDR = MON HEX ADDR + 1
   MON HEX == BYTEINTEGER(MON HEX ADDR)
   UGLA REG = INTEGER(OLDREG+4*13);     ! GLA REGISTER
   FLINE = SHORTINTEGER(UGLAREG+22);    ! LINE NUMBER
   FBLINE = SHORTINTEGER(UGLAREG+20);   ! START OF RT/BLOCK

   %CYCLE
      FIND BLOCK
      %IF ADATA <= 0 %START;            ! NOT FOUND
         %PRINTTEXT 'NO FURTHER DIAGNOSTICS AVAILABLE
'
         NEWREGS = 0
         %RETURN
      %FINISH
      %PRINTTEXT 'ENTERED FROM '
      %IF FLINE >= FBLINE %START
         %PRINTTEXT 'LINE'
         WRITE(FLINE, 1)
         %PRINTTEXT ' OF '
      %FINISH
      %IF BTYPE = 0 %THEN %PRINTTEXT 'BLOCK' %C
         %ELSE PRINTSTRING('RT/FN/MAP '.NAME)
      %PRINTTEXT ' STARTING AT LINE'
      WRITE(FBLINE, 1)
      PRINT LOCALS
      %IF BTYPE # 0 %THEN %START
! RESTORE LINE NUMBER
         NEWREGS = INTEGER(OLDREG+4*BASEREG)
         INTEGER(UGLAREG+20) = INTEGER(NEWREGS)
         NEWLINE
         %RETURN
      %FINISH
      %IF PREV BLOCK = 0 %START
         NEWREGS = 0
         NEWLINE
         %RETURN
      %FINISH
      FLINE = FBLINE
      FBLINE = PREV BLOCK
      %PRINTTEXT '

'
   %REPEAT

!

   %ROUTINE PRINT LOCALS
! ADATA POINTS TO FIRST ENTRY IN DIAG TABLES
      NEWLINE
PRINTSTRING('NO LOCAL VARIABLES
') %IF INTEGER(ADATA) < 0

      %CYCLE

         %WHILE INTEGER(ADATA) >= 0 %CYCLE
            PRINT VAR
            ADATA = (ADATA+7+BYTEINTEGER(ADATA+3))&X'FFFFFC'
         %REPEAT

         %RETURN %UNLESS INTEGER(ADATA) = -2 %AND DTLAST # TSTART
         DTLAST = TSTART
         %PRINTTEXT '
ENVIRONMENTAL VARIABLES
'
         ADATA = ADATA+4
      %REPEAT

   %END
!

   %ROUTINE FIND BLOCK
! SEARCH THE DIAG TABLES FOR BLOCK STARTING AT 'FBLINE'
   %CONSTINTEGER BMARK = X'C2C2C2C2'
   %CONSTINTEGER SMARK = X'E2E2E2E2'
   %INTEGER K, L
      TSTART = INTEGER(UGLAREG+28)+INTEGER(UGLAREG+12)
                                        ! HEAD OF TABLES
      L = TSTART

      %CYCLE
         %IF INTEGER(L) = BMARK %START
            %EXIT %IF SHORTINTEGER(L+4) = FBLINE
            L = L+8
         %FINISH
         %IF INTEGER(L) = SMARK %START
            ADATA = 0
            %RETURN
         %FINISH
         L = L+4
      %REPEAT

! BLOCK FOUND OK
      BASE REG = BYTEINTEGER(L+6)
      K = BYTEINTEGER(L+7)
      NAME <- STRING(L+7)
      %IF K = 0 %START;                 ! BEGIN
         BTYPE = 0
         PREV BLOCK = INTEGER(L+8)
         ADATA = L+12
      %FINISH %ELSE %START;             ! ROUTINE
         BTYPE = 1
         ADATA = (K+L+11)&X'FFFFFC'
      %FINISH
   %END
!

   %ROUTINE PRINT VAR
!
! OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK
! THE ENTRY IS :-
! FLAG<<24 ! VBREG<<20 ! DISP<<8 ! L
!
   %INTEGER K, L, DISP, VBREG, VADDR, BYTES
   %CONSTINTEGER UNASSI = X'80808080'
   %CONSTINTEGER BTRTAB = X'03000107'
   %SWITCH S(0 : 7)
!
      L = INTEGER(ADATA)
      DISP = L>>8&4095
      VBREG = L>>20&15
      K = L>>24
      TYPE = K&7
      PREC = K>>3&3
      NAM = K>>6&1
      BYTES = PREC
      *TR_BYTES+3(1),BTRTAB;            ! ROUNDING FACTOR FOR EACH PREC
!
      PRINTSTRING(STRING(ADATA+3).' =')
      VADDR = INTEGER(OLDREG+4*VBREG)+DISP
      %IF NAM # 0 %START
         -> INVALID %UNLESS VADDR&3 = 0
         VADDR = INTEGER(VADDR)
         -> NOT ASS %IF VADDR = UNASSI
      %FINISH
      -> STR %IF TYPE = 5
      -> INVALID %UNLESS VADDR&BYTES = 0
      -> S(PREC+4*((TYPE-1)&1))
!
   S(0):                                ! INTEGER
      -> NOT ASS %IF INTEGER(VADDR) = UNASSI
      %IF MONHEX # 0 %AND 0 # SHORTINTEGER(VADDR) # -1 %START
         %PRINTTEXT ' X'''
         HEX(INTEGER(VADDR))
         %PRINTTEXT ''''
      %FINISH %ELSE WRITE(INTEGER(VADDR), 1)
      -> NEXT
   S(1):                                !BYTEINTEGER
      WRITE(BYTEINTEGER(VADDR), 1);  -> NEXT
   S(2):                                ! SHORTINTEGER
      WRITE(SHORTINTEGER(VADDR), 1);  -> NEXT
   S(4):                                ! REAL
      -> NOT ASS %IF INTEGER(VADDR) = UNASSI
      PRINTFL(REAL(VADDR), 7);  -> NEXT
   S(7):                                ! LONGREAL
      -> NOTASS %IF INTEGER(VADDR) = UNASSI = INTEGER(VADDR+4)
      PRINTFL(LONGREAL(VADDR), 14);  -> NEXT
   S(3):


   S(5):


   S(6):


   INVALID:

      %PRINTTEXT ' INVALID ADDRESS';  -> NEXT
   NOT ASS:

      %IF BYTEINTEGER(BRIEF ADDR) # 0 %THEN %PRINTTEXT ' ?' %C
         %ELSE %PRINTTEXT ' NOT ASSIGNED'
      -> NEXT
   STR:

      -> NOT ASS %C
         %IF BYTEINTEGER(VADDR) = X'80' = BYTEINTEGER(VADDR+1)
      %PRINTTEXT ' '''
      PRINTSTRING(STRING(VADDR))
      %PRINTTEXT ''''
   NEXT:

      NEWLINE
   %END
%END

%EXTERNALROUTINE MONHEX(%STRING (1) S)
   BYTEINTEGER(ADDR(COMREG(25))) = LENGTH(S)
%END
%ENDOFFILE