!
!*******************************************************************
!*                                                                 *
!*       SYSTEM ROUTINES FOR IMP INTERPRETER VERSION 8             *
!*                                                                 *
!*******************************************************************
!
!
%TRUSTEDPROGRAM
%RECORDFORMAT AGFM(%INTEGER EP, %STRING (17) NAME,  %C
          %INTEGER P1, P2, %INTEGERNAME FLAG)
%EXTERNALINTEGER INTSIZE = 16;          ! DEFAULT OF 16 PAGES
%EXTERNALBYTEINTEGER INIMPI = 0
%EXTERNALINTEGER INTGLA = 0
%OWNSTRING (6) INT OWNER = 'CONLIB'
%EXTERNALSTRING (8) OBJECT = 'IMPIOBJ'
%EXTRINSICBYTEINTEGER INSTREAM, COMPMODE, IOFLAG, MDACTIVE
%SYSTEMINTEGERFNSPEC COMREG(%INTEGER N);! TO GIVE ADDRESSES
%EXTERNALINTEGER REG9 = -1
%OWNINTEGER DIAGPT, OUTSTREAM, SYSOUT, INTPERM
%OWNINTEGER INPUT = 0, ILEN = 0, DICT HEAD, NLADDR, MLEVEL
%OWNBYTEINTEGER IMPIUSE = 0, FAST BACK = 0, PRINTED = 0
%OWNINTEGER PCOUNTER = 0
%OWNBYTEINTEGERARRAY INBUF(0 : 160)
!
!
%EXTERNALROUTINESPEC EXTINIT
%EXTERNALROUTINESPEC HEX(%INTEGER N)
%DYNAMICROUTINESPEC RUN(%STRING (63) S)
%SYSTEMROUTINESPEC PDIAG(%INTEGER REGS, FAULT, EXTRA)
%SYSTEMROUTINESPEC AGENCY(%INTEGER P1, %RECORDNAME P)
%EXTERNALSTRING (15) PSTRING = 'DATA:'; ! DEFAULT PROMPT
!
%SYSTEMROUTINESPEC RIM(%INTEGER CONSOLE, %STRING (15) PROMPT)


%ROUTINE FDP(%INTEGER EP, %STRING (17) NAME,  %C
          %INTEGER P1, P2, %INTEGERNAME FLAG)
%RECORD P(AGFM)
          **1,@P
          *LA_2,EP
          *MVC_0(36,1),0(2);            ! SHIFT IN PARAMETERS
          AGENCY(1,P)
%END

%ROUTINE SIGNAL(%INTEGER J, K, L, %INTEGERNAME FLAG)
%RECORD P(AGFM)
          P_EP = J
          P_P1 = K
          P_P2 = L
          P_FLAG == FLAG
          AGENCY(2,P)
%END

%SYSTEMROUTINE I8INIT( %C
          %INTEGER DICT, NLFLAGAD, DIAG, SO, IO, IGLA, IPERM,  %C
          I8MODE)
%INTEGER MON HEX ADDR
          %IF IMPIUSE = 0 %AND I8MODE = 0 %START
             %PRINTTEXT 'IMPI FAILS
'
             %STOP
          %FINISH
          EXTINIT;                      ! SET LANG FLAG TO 55 IN INTEXTS
          *MVI_4(13),X'55';             ! SPECIAL FOR MDIAG TO SKIP THIS 
!
!
!
          MON HEX ADDR = COMREG(25)
          BYTEINTEGER(MON HEX ADDR) = BYTEINTEGER(MON HEX ADDR)!128
                                        !ROUTINE
          DICT HEAD = DICT;  NLADDR = NLFLAGAD
          SYSOUT = SO;  OUTSTREAM = IO
          MLEVEL = IO+4
          INTPERM = IPERM;  INTGLA = IGLA
          DIAGPT = DIAG
          INIMPI = 1
                                        ! OTHER INITIALISATIONS IN HERE
%END
!
!

%SYSTEMROUTINE I8IOCP(%INTEGER EP, IP1, %LONGREAL RP1, RP2)
%SHORTROUTINE
%CONSTLONGREAL MAX INTEGER = 2.14748364699999@9
%INTEGER S, L
%BYTEINTEGER FLAG, SIGN
%LONGREAL DIV, VAL
%STRING (255) IOSTR
%STRINGNAME SN
%SWITCH EPT(1 : 42)
          -> EPT(EP)

%INTEGERFN SYMBOL
%BYTEINTEGER S
             %IF ILEN <= 0 %THEN %START

                %UNTIL S = NL %THEN %CYCLE
                   READSYMBOL(S)
                   ILEN = ILEN+1;  INBUF(ILEN) = S
                %REPEAT

                INPUT = 0
             %FINISH
             INPUT = INPUT+1;  ILEN = ILEN-1
             %RESULT = INBUF(INPUT)
%END

%ROUTINE BACK
             INPUT = INPUT-1
             ILEN = ILEN+1
%END

%ROUTINE MONITOR(%INTEGER EP, EXTRA)
             *LM_0,1,EP;                ! PICK UP PARAMETERS
             *LM_4,14,16(8);            ! CONTEXT OF CALL OF IOCP
             *BC_15,24(12,0);           ! CALL DIAGS FROM  PERM
%END

%LONGREALFN NUMBER
%LONGREAL N
             FLAG = 0
             N = 0

             %CYCLE
                %RESULT = N %UNLESS '0' <= S <= '9'
                FLAG = 1
                N = N*10+(S-'0')
                S = SYMBOL
             %REPEAT

%END
EPT(41):                                !  RESUME
          -> END
EPT(1):                                 ! READ
EPT(37):                                !  R#READ
          SIGN = 0
          S = SYMBOL %UNTIL S # ' ' %AND S # NL
          SIGN = S %AND S = SYMBOL %IF S = '-' %OR S = '+'
          %IF S # '.' %START
             VAL = NUMBER
             %IF FLAG = 0 %START
RFAIL:          BACK;                   ! BACK OVER LAST SYMBOL
                MONITOR(14,S);          ! SYMBOL IN DATA
             %FINISH
          %FINISH
          %IF S = '.' %START
             DIV = 0.1
             S = SYMBOL
             -> RFAIL %UNLESS '0' <= S <= '9'

             %CYCLE
                VAL = VAL+(S-'0')*DIV
                S = SYMBOL
                %EXIT %UNLESS '0' <= S <= '9'
                DIV = DIV/10.0
             %REPEAT

          %FINISH
          VAL = -VAL %IF SIGN = '-'
          %IF S = '@' %START
             S = SYMBOL %UNTIL S # ' '
             SIGN = 0
             SIGN = S %AND S = SYMBOL %IF S = '-' %OR S = '+'
             RP1 = NUMBER
             -> RFAIL %IF FLAG = 0
             MONITOR(1,0) %IF RP1 > MAX INTEGER
             IP1 = INT(RP1)
             IP1 = -IP1 %IF SIGN = '-'
             %IF IP1 = -99 %THEN VAL = 0.0 %ELSE VAL = VAL*10**IP1
          %FINISH
          BACK;                         ! RESTORE FINAL SYMBOL
          %IF EP = 37 %START;           ! R#READ
             *LD_2,VAL;  -> END
          %FINISH
          MONITOR(16,0) %UNLESS FRACPT(VAL) = 0.0 %C
             %AND !VAL! <= MAX INTEGER
          IP1 = INT(VAL)
          -> LOADI
EPT(40):                                ! CLOSESTREAM
          -> END %UNLESS 0 < IP1 <= 99
          %IF INSTREAM = IP1 %THEN %START
             INSTREAM = 0;  SELECTINPUT(0)
          %FINISH %ELSE %START
             %IF INTEGER(OUTSTREAM) = IP1 %THEN %START
                INTEGER(OUTSTREAM) = 0
                SELECTOUTPUT(0)
             %FINISH
          %FINISH
          CLOSESTREAM(IP1)
          -> END
EPT(38):                                ! SELECT INPUT
          INSTREAM = IP1;  SELECTINPUT(IP1)
EPT(42):                                ! DRAIN
          ILEN = 0
          -> END
EPT(39):                                ! SELECT OUTPUT
          INTEGER(OUTSTREAM) = IP1;  SELECTOUTPUT(IP1);  -> END
EPT(2):                                 ! READSYMBOL
EPT(3):                                 ! READCH
EPT(8):                                 ! SKIPSYMBOL
EPT(5):                                 ! READ ITEM
          S = SYMBOL
          %IF EP = 5 %THEN STRING(IP1) = TOSTRING(S) %ELSE IP1 = S
          -> LOADI
EPT(4):                                 ! READSTRING
          SN == STRING(IP1)
          L = IP1>>24+1;  L = 256 %IF L = 1
          S = SYMBOL %UNTIL ' ' # S # NL
          BACK %AND MONITOR(14,S) %UNLESS S = ''''
          SN = ''
STR1:
          S = SYMBOL
          %IF S = '''' %THEN %START
             %IF INBUF(INPUT+1) # '''' %THEN %RETURN
             INPUT = INPUT+1
          %FINISH
          L = L-1;  MONITOR(30,0) %IF L = 0
          SN = SN.TOSTRING(S)
          -> STR1
EPT(6):                                 ! NEXTSYMBOL
EPT(7):                                 ! NEXTITEM
          IP1 = SYMBOL
          BACK;  -> LOADI
EPT(11):                                ! PRINTSTRING
          PRINTSTRING(STRING(IP1))
          -> END
EPT(12):                                ! PRINTSYMBOL
          PRINTSYMBOL(IP1)
          -> END
EPT(13):                                ! PRINTCH
          PRINTCH(IP1);  -> END
EPT(18):                                ! SPACES/NEWLINES
          EP = INTEGER(ADDR(RP1));  -> END %UNLESS EP > 0

          %CYCLE EP = 1,1,EP;  PRINTSYMBOL(IP1)
          %REPEAT

          -> END
EPT(20):                                !  FROM  STRING
          IOSTR = FROM STRING(STRING(IP1),INTEGER(ADDR(RP1)), %C
             INTEGER(ADDR(RP1)+4))
          **1,@IOSTR
          -> END
EPT(21):                                !  CHARNO
          IP1 = CHARNO(STRING(IP1),INTEGER(ADDR(RP1)))
          -> LOADI
EPT(22):                                ! INT
          IP1 = INT(RP1);  -> LOADI
EPT(23):                                ! INTPT
          IP1 = INTPT(RP1);  -> LOADI
EPT(24):                                ! FRACPT
          RP1 = FRACPT(RP1);  -> LOADR
EPT(25):                                ! SIN
          RP1 = SIN(RP1);  -> LOADR
EPT(26):                                ! COS
          RP1 = COS(RP1);  -> LOADR
EPT(27):                                ! TAN
          RP1 = TAN(RP1);  -> LOADR
EPT(28):                                ! ARCSIN
          RP1 = ARCSIN(RP1);  -> LOADR
EPT(29):                                ! ARCCOS
          RP1 = ARCCOS(RP1);  -> LOADR
EPT(30):                                ! ARCTAN
          RP1 = ARCTAN(RP1,RP2);  -> LOADR
EPT(32):                                ! SQRT
          RP1 = SQRT(RP1);  -> LOADR
EPT(33):                                ! MOD
          *LD_2,RP1;  *LPDR_2,2;  -> END
EPT(34):                                ! LOG
          RP1 = LOG(RP1);  -> LOADR
EPT(35):                                ! EXP
          RP1 = EXP(RP1);  -> LOADR
EPT(31):                                !  RADIUS
          RP1 = RADIUS(RP1,RP2);  -> LOADR
EPT(36):                                !  PROMPT
          PSTRING <- STRING(IP1);  RIM(0,PSTRING);  -> END
EPT(19):                                !  WRITE
          WRITE(IP1,INTEGER(ADDR(RP1)));  -> END
EPT(9):                                 ! PRINT
          PRINT(RP2,IP1,INTEGER(ADDR(RP1)));  -> END
EPT(10):                                !  PRINTFL
          PRINTFL(RP2,IP1)
LOADR:
          *LD_2,RP1
LOADI:
          *L_1,IP1
END:
%END

%ROUTINE PRINT MESSAGE(%INTEGER EP, FNUM)
%SHORTROUTINE
%CONSTBYTEINTEGERARRAY FSYM(0 : 681) =   %C
  0,  '',  '',  '', ' ', 'M', 'O', 'N', 'I', 'T', 'O', 'R', ' ',  '',
  '',  '',  16, 'I', 'N', 'T', 'E', 'G', 'E', 'R', ' ', 'O', 'V', 'E',
 'R', 'F', 'L', 'O', 'W',  13, 'R', 'E', 'A', 'L', ' ', 'O', 'V', 'E',
 'R', 'F', 'L', 'O', 'W',  13, 'I', 'N', 'V', 'A', 'L', 'I', 'D', ' ',
 'C', 'Y', 'C', 'L', 'E',  13, 'E', 'X', 'C', 'E', 'S', 'S', ' ', 'B',
 'L', 'O', 'C', 'K', 'S',  13, 'S', 'Q', 'R', 'T', ' ', 'N', 'E', 'G',
 'A', 'T', 'I', 'V', 'E',  12, 'L', 'O', 'G', ' ', 'N', 'E', 'G', 'A',
 'T', 'I', 'V', 'E',  23, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'V', 'A',
 'R', 'I', 'A', 'B', 'L', 'E', ' ', 'N', 'O', 'T', ' ', 'S', 'E', 'T',
  21, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'N', 'O', 'T', ' ', 'D',
 'E', 'S', 'C', 'R', 'I', 'B', 'E', 'D',  16, 'I', 'N', 'P', 'U', 'T',
 ' ', 'F', 'I', 'L', 'E', ' ', 'E', 'N', 'D', 'E', 'D',  20, 'N', 'O',
 'N', '-', 'I', 'N', 'T', 'E', 'G', 'E', 'R', ' ', 'Q', 'U', 'O', 'T',
 'I', 'E', 'N', 'T',  20, 'R', 'E', 'S', 'U', 'L', 'T', ' ', 'N', 'O',
 'T', ' ', 'S', 'P', 'E', 'C', 'I', 'F', 'I', 'E', 'D',  13, 'T', 'I',
 'M', 'E', ' ', 'E', 'X', 'C', 'E', 'E', 'D', 'E', 'D',  20, 'O', 'P',
 'E', 'R', 'A', 'T', 'O', 'R', ' ', 'T', 'E', 'R', 'M', 'I', 'N', 'A',
 'T', 'I', 'O', 'N',  14, 'S', 'Y', 'M', 'B', 'O', 'L', ' ', 'I', 'N',
 ' ', 'D', 'A', 'T', 'A',  14, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ',
 'F', 'A', 'U', 'L', 'T', 'Y',  31, 'R', 'E', 'A', 'L', ' ', 'I', 'N',
 'S', 'T', 'E', 'A', 'D', ' ', 'O', 'F', ' ', 'I', 'N', 'T', 'E', 'G',
 'E', 'R', ' ', 'I', 'N', ' ', 'D', 'A', 'T', 'A',  12, 'D', 'I', 'V',
 'I', 'D', 'E', ' ', 'E', 'R', 'R', 'O', 'R',  23, 'S', 'U', 'B', 'S',
 'T', 'I', 'T', 'U', 'T', 'E', ' ', 'C', 'H', 'A', 'R', ' ', 'I', 'N',
 ' ', 'D', 'A', 'T', 'A',  19, 'G', 'R', 'A', 'P', 'H', ' ', 'P', 'L',
 'O', 'T', 'T', 'E', 'R', ' ', 'F', 'A', 'U', 'L', 'T',  18, 'S', 'T',
 'R', 'E', 'A', 'M', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'F', 'I', 'N',
 'E', 'D', 128,  16, 'I', 'L', 'L', 'E', 'G', 'A', 'L', ' ', 'E', 'X',
 'P', 'O', 'N', 'E', 'N', 'T',  18, 'T', 'R', 'I', 'G', ' ', 'F', 'N',
 ' ', 'I', 'N', 'A', 'C', 'C', 'U', 'R', 'A', 'T', 'E',  13, 'T', 'A',
 'N', ' ', 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E',  13, 'E', 'X',
 'P', ' ', 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E',  16, 'L', 'I',
 'B', 'R', 'A', 'R', 'Y', ' ', 'F', 'N', ' ', 'F', 'A', 'U', 'L', 'T',
  16, 'R', 'E', 'S', 'O', 'L', 'U', 'T', 'I', 'O', 'N', ' ', 'F', 'A',
 'I', 'L', 'S',  19, 'I', 'N', 'T', '/', 'I', 'N', 'T', 'P', 'T', ' ',
 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E',  16, 'A', 'R', 'R', 'A',
 'Y', ' ', 'I', 'N', 'S', 'I', 'D', 'E', '-', 'O', 'U', 'T',  15, 'O',
 'U', 'T', 'P', 'U', 'T', ' ', 'E', 'X', 'C', 'E', 'E', 'D', 'E', 'D',
  17, 'C', 'A', 'P', 'I', 'C', 'I', 'T', 'Y', ' ', 'E', 'X', 'C', 'E',
 'E', 'D', 'E', 'D',  19, 'U', 'N', 'A', 'S', 'S', 'I', 'G', 'N', 'E',
 'D', ' ', 'V', 'A', 'R', 'I', 'A', 'B', 'L', 'E',  21, 'A', 'R', 'R',
 'A', 'Y', ' ', 'B', 'O', 'U', 'N', 'D', 'S', ' ', 'E', 'X', 'C', 'E',
 'E', 'D', 'E', 'D',  19, 'C', 'O', 'R', 'R', 'U', 'P', 'T', ' ', 'D',
 'O', 'P', 'E', '-', 'V', 'E', 'C', 'T', 'O', 'R',  13, 'A', 'D', 'D',
 'R', 'E', 'S', 'S', ' ', 'E', 'R', 'R', 'O', 'R',  21, 'U', 'N', 'E',
 'X', 'P', 'L', 'A', 'I', 'N', 'E', 'D', ' ', 'I', 'N', 'T', 'E', 'R',
 'R', 'U', 'P', 'T',  14, 'I', 'L', 'L', 'E', 'G', 'A', 'L', ' ', 'O',
 'P', 'C', 'O', 'D', 'E',  18, 'S', 'T', 'R', 'E', 'A', 'M', ' ', 'N',
 'O', 'T', ' ', 'D', 'E', 'F', 'I', 'N', 'E', 'D'
%CONSTSHORTINTEGERARRAY FAULT(0 : 37) =   %C
    0,   16,   33,   47,   61,   75,   89,  102,  126,  148,
  165,  186,  207,  221,  242,  257,  272,  304,  317,  341,
  361,  381,  398,  417,  431,  445,  462,  479,  499,  516,
  532,  550,  570,  592,  612,  626,  648,  663
          %PRINTTEXT '

' %IF PCOUNTER = 0 %AND INIMPI # 0
          %UNLESS 0 <= EP <= 37 %THEN %START
             %PRINTTEXT 'UNKNOWN FAULT';  WRITE(EP,2)
          %FINISH %ELSE %START
             PRINTSTRING(STRING(ADDR(FSYM(FAULT(EP)))))
             %IF EP = 14 %C
                %THEN PRINTSTRING(' '''.TOSTRING(FNUM).'''') %C
                %ELSE %START
                %IF EP = 7 %OR EP = 32 %OR EP = 21 %OR EP = 33 %C
                   %THEN WRITE(FNUM,2)
             %FINISH
          %FINISH
          %PRINTTEXT '
'
          %PRINTTEXT '
' %IF INIMPI # 0
%END

%SYSTEMROUTINE I8DIAG(%INTEGER EP, FNUM)
%SHORTROUTINE
%INTEGER R10, BASE, DIAGS, NEWD, R9, VBASE, GLA, LEVEL, BRIEF AD
%SHORTINTEGER BLOCK, LINE
%SHORTINTEGER ADR, NAME, BLINE
%OWNINTEGER FIRST DIAG = -1
%BYTEINTEGER FROM MDIAG
          BRIEF AD = COMREG(25)+1
          PRINTED = 0 %IF EP >= 0
          LEVEL = INTEGER(MLEVEL)
          FROM MDIAG = 0
          %IF EP = -1 %START
             FROM MDIAG = 1
             BASE = FNUM
             -> X2
          %FINISH %ELSE FIRST DIAG = -1
          %IF EP # 0 %START
             SELECTOUTPUT(INTEGER(SYSOUT))
             PRINT MESSAGE(EP,FNUM)
             FAST BACK = 1
          %FINISH
          %IF PCOUNTER # 0 %START
             BASE = PCOUNTER+4
             PCOUNTER = 0
             -> X2
          %FINISH
          -> M1

%ROUTINE P N LIST(%INTEGER NLP, BASE)
%INTEGER IN
%BYTEINTEGER DELETE;                    ! FLAG FROM  **DELETE
%BYTEINTEGER TYPE;  %SHORTINTEGER AD, NAME
%INTEGER ADR, MASK, T, N, BREG
%SWITCH PVAR(0 : 6)
%CONSTSHORTINTEGERARRAY VTYPE(0 : 15) =         %C
6,0(3),1,2,3,0,4,0,5,0(5)
%CONSTSHORTINTEGERARRAY VMASK(0 : 6) =        0,3,0,1,3,7,0
             LEVEL = LEVEL-1
             -> QRET %IF LEVEL < 0
             %IF SHORTINTEGER(NLP) = 0 %THEN %START
                %PRINTTEXT 'NO LOCAL VARIABLES
'
                %RETURN
             %FINISH
             %PRINTTEXT 'LOCAL VARIABLES
'

             %UNTIL SHORTINTEGER(NLP) = 0 %THEN %CYCLE
                AD <- SHORTINTEGER(NLP)&X'FFFC'
                NAME <- SHORTINTEGER(NLP+2)
                TYPE <- BYTEINTEGER(NLP+5)
                DELETE = BYTEINTEGER(NLP+4)
                N = INTEGER(NAME+DICTHEAD)
                %IF N = 0 %THEN %START
PVAR(0):           %PRINTTEXT '*** DIAGS CORRUPT ***
'
QRET:              %PRINTTEXT '
'
                   PRINTED = 0
                   **1,REG9
                   *LM_4,15,16(8)
                   *BCR_15,15
                %FINISH
                %IF DELETE = 0 %START
                   PRINTSTRING(STRING(N).' =')
                   ADR = AD&X'FFF';  BREG = AD>>12&15
                   %IF BREG = 13 %THEN BREG = GLA %ELSE BREG = BASE
                   ADR = ADR+BREG
                   T = VTYPE(TYPE&15);  -> IVA %IF T = 0
                   MASK = VMASK(T)
                   %IF TYPE&128 # 0 %THEN %START
                      -> IVA %IF ADR&3 # 0 %C
                         %OR ADR&X'FF0000' < X'100000'
                      ADR = INTEGER(ADR)
                      -> UAV %IF ADR = X'80808080'
                   %FINISH
                   -> IVA %IF ADR&MASK # 0 %OR ADR = 0
                   -> PVAR(T)
!
PVAR(1):                                !  INTEGER
                   IN = INTEGER(ADR);  -> UAV %IF IN = X'80808080'
                   %IF 0 # SHORTINTEGER(ADR) # -1 %START
                      %PRINTTEXT ' X''';  HEX(IN);  %PRINTTEXT ''''
                      -> WRIT
                   %FINISH
                   WRITE(IN,1);  -> WRIT
PVAR(2):                                !  BYTEINTEGER
                   WRITE(BYTEINTEGER(ADR),1);  -> WRIT
PVAR(3):                                !  SHORTINTEGER
                   WRITE(SHORTINTEGER(ADR),1);  -> WRIT
PVAR(4):                                !  REAL
                   -> UAV %IF INTEGER(ADR) = X'80808080'
                   PRINTFL(REAL(ADR),7);  -> WRIT
PVAR(5):                                !  LONGREAL
                   -> UAV %IF INTEGER(ADR) = X'80808080'
                   PRINTFL(LONGREAL(ADR),14);  -> WRIT
PVAR(6):                                !  STRING
                   -> UAV %IF BYTEINTEGER(ADR) = X'80' =  %C
                      BYTEINTEGER(ADR+1)
                   PRINTSTRING(' '''.STRING(ADR).'''');  -> WRIT
IVA:                                    ! INVALID ADDRESS
                   %PRINTTEXT ' INVALID ADDRESS'
                   -> WRIT
UAV:               %IF BYTEINTEGER(BRIEF AD) = 0 %C
                      %THEN %PRINTTEXT ' NOT ASSIGNED' %C
                      %ELSE %PRINTTEXT ' ?'
WRIT:              NEWLINE
                %FINISH
                NLP = NLP+6
             %REPEAT

             NEWLINE
%END
M1:
          BASE = ADDR(EP)-64
X2:       R9 = INTEGER(BASE+9<<2)
          GLA = INTEGER(BASE+13<<2);  NEWD = GLA+20
          R10 = INTEGER(BASE+10<<2)
          %IF GLA = INT GLA %START
             FIRST DIAG = INTEGER(NEWD) %IF FIRST DIAG < 0
             %PRINTTEXT '
MONITOR ' %IF PRINTED = 0
          %FINISH
          PRINTED = 1
1:        !   INTEGER(ADDR(BLOCK)) = INTEGER(NEWD)
          *L_1,NEWD;  *MVC_BLOCK(4),0(1)
          GLA = INTEGER(BASE+13<<2)
          %IF GLA # INTGLA %START
             INTEGER(INT GLA+20) = INTEGER(BASE) %IF FIRST DIAG >= 0
             PDIAG(BASE-4,0,0) %AND %RETURN %IF FROM MDIAG = 0
             FROM MDIAG = 0
             *L_1,BASE
             *LM_4,15,16(8)
             *BCR_15,15;                ! RETURN TO MDIAG
          %FINISH
          %PRINTTEXT 'ENTERED FROM '
          -> 3 %IF LINE = 0
          -> DF %IF LINE < 0 %OR R9 # REG9
          %PRINTTEXT 'LINE';  WRITE(LINE,1)
          %PRINTTEXT ' OF ';  -> 3 %IF BLOCK = 0
          -> DF %IF BLOCK < 0
          DIAGS = R10+BLOCK
          *L_1,DIAGS
          *MVC_ADR(6),0(1)
          %IF ADR&X'FFF0' = 0 %THEN %START
             PRINTSTRING('RT/FN/MAP '.STRING(INTEGER(NAME+DICTHEAD)))
             BASE = INTEGER(BASE+ADR<<2);  NEWD = BASE
             R10 = INTEGER(BASE+10<<2)
             VBASE = BASE
          %FINISH %ELSE %START
             %PRINTTEXT 'BLOCK'
             VBASE = INTEGER(BASE+ADR>>10&60)
             R10 = VBASE+ADR&X'FFF'
             NEWD = R10+8
             R10 = INTEGER(R10)
          %FINISH
          %PRINTTEXT ' STARTING AT LINE' %AND WRITE(BLINE,1) %C
             %IF BLINE # 1
          NEWLINE
          P N LIST(DIAGS+6,VBASE)
          NEWLINE
          -> 1
DF:       %PRINTTEXT '
*** DIAGS FAILURE ***

'
3:        %PRINTTEXT 'BASIC LEVEL
'
          P N LIST(INTEGER(DIAGPT),REG9)
          NEWLINE
          PRINTED = 0
!
          MDACTIVE = 0;                 ! CLEAR MY MDIAG
!
! VERY DUBIOUS
!
          %IF FAST BACK # 0 %START
             FAST BACK = 0
             **1,REG9
             *LM_4,15,16(1)
             *BCR_15,15
          %FINISH
          INTEGER(INT GLA+20) = FIRST DIAG;  ! RESTORE GLA FOR '%MONITOR'
          **1,REG9
%END

%SYSTEMROUTINE ERMESS(%INTEGER FAULT, EXTRA)
!
! TAKE IT STRAIGHT TO I8DIAG
!
%ROUTINESPEC CALL(%ROUTINENAME DIAG)
%INTEGER N
          %IF INIMPI = 0 %START
             PRINT MESSAGE(FAULT,EXTRA) %IF FAULT # 0
             %RETURN
          %FINISH
          SIGNAL(1,0,0,N);              !  REMOVE SIGNAL
          CALL(I8DIAG)

%ROUTINE CALL(%ROUTINENAME DIAG)
             *L_2,64(7);                ! DESCRIPTOR OF 'DIAG'
             *LM_0,1,64(8)
             *L_8,32(8);                ! REG 8 OF MDIAG
             *L_3,64(8);                ! PCOUNTER FROM MDIAG
             *ST_3,PCOUNTER;            ! R13 SHOULD BE SAFE ?
             *LM_4,15,16(8);            ! ENTRY INFO TO MDIAG
             *STM_4,1,16(11)
             *LM_12,14,0(2)
             *BCR_15,14
%END
%END

%SYSTEMROUTINE IIGEN(%STRING (8) FILE, %INTEGERNAME CON, FLAG)
%SHORTROUTINE
%INTEGER X1, X2, X3, X4, P
          *L_1,52(8)
          *MVC_4(1,13),4(1);            ! COPY FLAG
          P = CON
          FDP(5,FILE,ADDR(X1),0,FLAG);  ! GET FILE INFO
          %IF FLAG # 0 %THEN %START
             %RETURN %UNLESS FLAG = 3;  ! DOES NOT EXIST
             X2 = CON
             FDP(162,FILE,X2,0,FLAG);   ! CREATE FILE
             %RETURN %IF FLAG # 0
             X1 = 0
          %FINISH
          %IF X2 # P %THEN %START
             FDP(2,FILE,0,0,FLAG);      ! DISCONNECT FILE (MAY FAIL)
             FDP(6,FILE,P-X2,ADDR(X1),FLAG); ! EXTEND FILE
             X1 = 0;                    ! IT'S NO LONGER CONNECTED
             %RETURN %IF FLAG # 0
          %FINISH
          %IF X1 = 0 %THEN %START;      ! NOT CONNECTED
             CON = (CON+15)>>4;         ! NUMBER OF SEGMENTS
             FDP(1,FILE,3,ADDR(CON),FLAG);   ! CONNECT FILE
             %RETURN %IF FLAG # 0
          %FINISH %ELSE %START
             %IF X3 # 3 %THEN %START
                FDP(171,FILE,3,0,FLAG); ! CHANGE ACCESS MODE
             %FINISH
             CON = X1<<16
          %FINISH
%END

%EXTERNALROUTINE IMPI(%STRING (1) PARM)
%INTEGER MON HEX ADDR
%SHORTROUTINE
%INTEGER FLAG
%OWNSTRING (1) DOT = '.'
          %IF IMPIUSE # 0 %START
             %PRINTTEXT 'IMPI FAILS
'
             %RETURN
          %FINISH
          IMPIUSE = 1
          %IF PARM # '' %AND '1' <= PARM <= '9' %C
             %THEN INTSIZE = (CHARNO(PARM,1)-'0'+1)<<4
          PRINTCH(7);  NEWLINE
          DOT = '' %IF INT OWNER = ''
          RUN(INT OWNER.DOT.OBJECT)
          %PRINTTEXT '#CLOSE
'
          MON HEX ADDR = COMREG(25)
          BYTEINTEGER(MON HEX ADDR) = BYTEINTEGER(MON HEX ADDR)&127
          FDP(3,'II#CODE',0,0,FLAG)
%END

%EXTERNALROUTINE IMPIP(%STRING (17) S)
%DYNAMICROUTINESPEC DEFINE(%STRING (63) S)
%STRING (15) T
          T = '' %UNLESS S -> S.(',').T
          DEFINE('ST78,'.S)
          SELECTINPUT(78)
          IOFLAG = 3
          COMP MODE = 64
          IMPI(T)
%END

%EXTERNALROUTINE IMPIT(%STRING (1) S)
          INT OWNER = ''
          OBJECT = 'IMPIOBJT'
          IMPI(S)
%END

%EXTERNALROUTINE ITEST(%STRING (15) S)
          OBJECT = S
          INT OWNER = ''
          IMPI('')
%END

%EXTERNALROUTINE BRIEF(%STRING (1) S)
          BYTEINTEGER(COMREG(25)+1) = LENGTH(S)
%END
%ENDOFFILE