!
!**************************************************
!*                                                *
!*    VARIOUS EXTERNAL ROUTINES FOR IMPI          *
!*                                                *
!***************************************************
!
%TRUSTEDPROGRAM
%EXTERNALINTEGER MON REP = 0;           ! REPETITION COUNTER FOR RESUMES
%EXTERNALBYTEINTEGER MONLOCK
%EXTRINSICINTEGER MONFRAME, MONINFO, BRKR9AD
%OWNSHORTINTEGER TRAP BLOCK, TRAP LINE
!

%EXTERNALROUTINE EXTINIT
          *MVI_4(13),X'55';             ! FLAG FOR MDIAG
%END

%EXTERNALROUTINE HEX(%INTEGER N)
%SHORTROUTINE
%CONSTBYTEINTEGERARRAY XSYM(0 : 15) =     %C
                                  '0', '1', '2', '3',
                                  '4', '5', '6', '7',
                                  '8', '9', 'A', 'B',
                                  'C', 'D', 'E', 'F'
%INTEGER J, S

          %CYCLE J = 1,1,8
             S = N>>28
             N = N<<4
             PRINTSYMBOL(XSYM(S))
          %REPEAT

%END
%CONSTBYTEINTEGERARRAY TRT(0 : 255) =         %C
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', ' ', '!',  34, '#', '$', '%', '&','''', '(', ')',
 '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7',
 '8', '9', ':', ';', '<', '=', '>', '?', '@', 'A', 'B', 'C', 'D', 'E',
 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S',
 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '\', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_',
 '_', '_', '_', '_'

%ROUTINE PHSYMBOLS(%INTEGER AD)
%STRING (18) TEXT
          **1,@TEXT;  *L_2,AD
          *MVC_2(16,1),0(2)
          *L_2,TRT
          *TR_2(16,1),0(2)
          *MVI_0(1),18
          *MVI_1(1),'*'
          *MVI_18(1),'*'
          *->P5
%END

%SYSTEMROUTINE IIDUMP(%INTEGER FROM, TO)
%SHORTROUTINE
%INTEGER N, M, D, LINES
%BYTEINTEGER STOP
%ROUTINESPEC HEAD
          LINES = 30
          STOP = 0;                     ! TO STOP FROM HEAD
          M = (FROM&15)>>2
          FROM = FROM&(\15);  TO = (TO+15)&(\15)
          *LA_1,1(13);  *ST_1,D
          HEAD
          FROM = FROM+M<<2
          N = M
          SPACES(M*10)

          %WHILE FROM < TO %THEN %CYCLE
             %IF N = 4 %START
                HEAD
                %RETURN %IF STOP # 0
             %FINISH
             N = N+1
             %PRINTTEXT '  ';  HEX(INTEGER(FROM))
             FROM = FROM+4
          %REPEAT

          NEWLINE
          %RETURN

%ROUTINE HEAD
%INTEGER NN
             LINES = LINES-1
             LINES = 30 %AND NEWLINES(2) %IF LINES <= 0
             %PRINTTEXT '
'
             *SLR_0,0;                  ! DUPLICATE LINE COUNTER
             *L_1,D;  *L_2,FROM
1:           *CLC_0(16,1),0(2);  *BC_7,<2>
             *LA_2,16(2)
             *C_2,TO;  *BC_2,<S>;       ! END REACHED
             *BCT_0,<1>
S:           *MVI_STOP,255;             ! SET STOP FLAG
2:           *ST_0,NN
             *LTR_0,0
             *BC_8,<3>
             *ST_2,FROM
             %PRINTTEXT 'NEXT'
             %IF NN = -1 %THEN %PRINTTEXT ' LINE' %ELSE %START
                WRITE(-NN,1)
                %PRINTTEXT ' LINES'
             %FINISH
             %PRINTTEXT ' THE SAME
'
3:           %RETURN %IF STOP # 0
             PHSYMBOLS(FROM)
             D = FROM
             %PRINTTEXT ' (';  HEX(FROM);  %PRINTTEXT ')   '
             N = 0
%END
%END

%ROUTINE PSYMBOLS(%INTEGER AD)
%STRING (34) TEXT
          **1,@TEXT;  *L_2,AD
          *MVC_2(32,1),0(2)
          *L_2,TRT
          *TR_2(32,1),0(2)
          *MVI_0(1),34
          *MVI_1(1),'*'
          *MVI_34(1),'*'
          *->P5
%END

%SYSTEMROUTINE LPDUMP(%INTEGER FROM, TO)
%SHORTROUTINE
%INTEGER N, M, D, LINES
%BYTEINTEGER STOP
%ROUTINESPEC HEAD
          LINES = 60
          STOP = 0;                     ! STOP FLAG FROM HEAD
          M = (FROM&15)>>2
          FROM = FROM&(\15);  TO = (TO+15)&(\15)
          *LA_1,1(13);  *ST_1,D
          HEAD
          FROM = FROM+M<<2
          N = M
          SPACES(M*10)

          %WHILE FROM < TO %CYCLE
             %PRINTTEXT '  ' %IF N = 4
             HEAD %IF N = 8
             N = N+1
             %PRINTTEXT '  ';  HEX(INTEGER(FROM))
             FROM = FROM+4
          %REPEAT

          NEWLINE
          %RETURN

%ROUTINE HEAD
%INTEGER NN
             LINES = LINES-1
             LINES = 60 %AND NEWPAGE %IF LINES <= 0
             %PRINTTEXT '
'
             *SLR_0,0;                  ! DUPLICATE LINE COUNTER
             *L_1,D;  *L_2,FROM
1:           *CLC_0(32,1),0(2);  *BC_7,<2>
             *LA_2,32(2)
             *C_2,TO;  *BC_2,<S>;       ! END REACHED
             *BCT_0,<1>
S:           *MVI_STOP,255
2:           *ST_0,NN
             *LTR_0,0
             *BC_8,<3>
             *ST_2,FROM
             %PRINTTEXT 'NEXT'
             %IF NN = -1 %THEN %PRINTTEXT ' LINE' %ELSE %START
                WRITE(-NN,1)
                %PRINTTEXT ' LINES'
             %FINISH
             %PRINTTEXT ' THE SAME
'
3:           %RETURN %IF STOP # 0
             PSYMBOLS(FROM)
             D = FROM
             %PRINTTEXT ' (';  HEX(FROM);  %PRINTTEXT ')   '
             N = 0
%END
%END

%SYSTEMROUTINE ITRAP(%INTEGER B, L)
%SHORTROUTINE
          %IF 0 # TRAPLINE # L %START
             %PRINTTEXT 'LINE'
             WRITE(TRAPLINE,1)
             %PRINTTEXT ' RELEASED
'
          %FINISH
          TRAP BLOCK = B
          TRAP LINE = L
%END
!

%SYSTEMROUTINE UNTRAP
          TRAP BLOCK = 0
          TRAP LINE = 0
%END
!

%SYSTEMROUTINE IMPMON
%INTEGER GLA
%INTEGER R8, FLAG
          *L_1,52(8);                   ! CALLING GLA
          *CLC_22(2,1),TRAP LINE;       ! COMPARE LINE NUMBER
          *BC_7,<BACK>;                 ! DIFFERENT
          *LH_2,TRAP BLOCK;             ! BLOCK NUMBER WANTED
          *LTR_2,2
          *BC_8,<ANY>;                  ! ZERO MEANS ANY BLOCK
          *CH_2,20(1);                  ! LOOK AT GLA WORD
          *BC_7,<BACK>;                 ! DIFFERENT
ANY:
          %RETURN %IF MON LOCK # 0;     ! CALLED RECURSIVELY
          MONREP = MONREP-1 %AND %RETURN %IF MONREP > 0
          *ST_1,GLA
          MONINFO = GLA
          MONLOCK = 1
          *ST_8,R8
          MONFRAME = R8
          FLAG = BRKR9AD
          *L_1,FLAG
          *LA_11,4000(11);              ! PROTECT STACK
          *ST_11,8(1)
          *LM_9,14,0(1)
          *BCR_15,14;                   ! CALL THE INTERPRETER AS A 
                                        !CO-ROUTINE
BACK:
%END

%SYSTEMROUTINE DECODE(%INTEGER S, TO, BASE)
%SHORTROUTINE
%CONSTINTEGERARRAY OPCODES(0 : 255) =    %C
     0(4),
M'SPM ',M'BALR',M'BCTR',M'BCR ',M'SSK ',M'ISK ',M'SVC ',     0(5),
M'LPR ',
M'LNR ',M'LTR ',M'LCR ',M'NR  ',M'CLR ',M'OR  ',M'XR  ',M'LR  ',
M'CR  ',
M'AR  ',M'SR  ',M'MR  ',M'DR  ',M'ALR ',M'SLR ',M'LPDR',M'LNDR',
M'LTDR',
M'LCDR',M'HDR ',M'LRDR',M'MXR ',M'MXDR',M'LDR ',M'CDR ',M'ADR ',M'SDR ',
M'MDR ',
M'DDR ',M'AWR ',M'SWR ',M'LPER',M'LNER',M'LTER',M'LCER',M'HER ',M'LRER',
M'AXR ',
M'SXR ',M'LER ',M'CER ',M'AER ',M'SER ',M'MER ',M'DER ',M'AUR ',M'SUR ',
M'STH ',
M'LA  ',M'STC ',M'IC  ',M'EX  ',M'BAL ',M'BCT ',M'BC  ',M'LH  ',M'CH  ',
M'AH  ',
M'SH  ',M'MH  ',     0,
M'CVD ',
M'CVB ',M'ST  ',     0(3),M'N   ',M'CL  ',M'O   ',
M'X   ',
M'L   ',M'C   ',M'A   ',M'S   ',M'M   ',M'D   ',M'AL  ',M'SL  ',M'STD ',
     0(6),
M'MXD ',
M'LD  ',M'CD  ',M'AD  ',M'SD  ',M'MD  ',M'DD  ',M'AW  ',M'SW  ',
M'STE ',
     0(7),
M'LE  ',
M'CE  ',M'AE  ',M'SE  ',M'ME  ',M'DE  ',M'AU  ',M'SU  ',
M'SSM',
     0,M'LPSW',M'DIAG',M'WRD ',M'RDD ',M'BXH ',M'BXLE',M'SRL ',M'SLL ',
M'SRA ',
M'SLA ',M'SRDL',M'SLDL',M'SRDA',M'SLDA',M'STM ',M'TM  ',M'MVI ',
M'TS  ',
M'NI  ',M'CLI ',M'OI  ',M'XI  ',M'LM  ',     0(3),
M'SIO ',
M'TIO ',M'HIO ',
M'TCH ',
     0(49),
M'MVN ',
M'MVC ',M'MVZ ',M'NC  ',M'CLC ',M'OC  ',M'XC  ',     0(4),
M'TR  ',
M'TRT ',M'ED  ',M'EDMK',     0(17),M'MVO ',M'PACK',M'UNPK',     0(4),
M'ZAP ',
M'CP  ',M'AP  ',M'SP  ',M'MP  ',M'DP  ',     0,     0
%INTEGER J, K, L, M
%INTEGER T
%ROUTINESPEC HEX(%INTEGER N)
%ROUTINESPEC PUT(%INTEGER S, C)
          S = S&(\1)
1:        NEWLINE
          NEWLINE %AND %RETURN %IF S >= TO
          HEX(S-BASE)
          SPACES(4)
          J = SHORTINTEGER(S);  S = S+2
          M = J>>8&255
          T = OPCODES(M)
          HEX(J)
          -> 1 %IF T = 0
          %IF M>>6 = 0 %THEN %START;    ! RR
             PUT(12,T)
             WRITE(J>>4&15,4)
             %PRINTTEXT ','
             WRITE(J&15,2)
             -> 1
          %FINISH
          K = SHORTINTEGER(S);  S = S+2
          HEX(K)
          %IF M>>6 = 1 %THEN %START;    !  RX
             PUT(8,T)
             WRITE(J>>4&15,4);  %PRINTTEXT ','
             WRITE(K&X'FFF',4);  %PRINTTEXT '('
             WRITE(J&15,2);  %PRINTTEXT ','
3:           WRITE(K>>12&15,2);  %PRINTTEXT ')'
             -> 1
          %FINISH
          %IF M&X'F8' = X'88' %THEN %START
             PUT(8,T)
             WRITE(J>>4&15,4);  %PRINTTEXT ','
2:           WRITE(K&X'FFF',4);  %PRINTTEXT '('
             -> 3
          %FINISH
          %IF M > 192 %THEN %START
             L = SHORTINTEGER(S);  S = S+2
             HEX(L)
             PUT(4,T)
             WRITE(K&X'FFF',5);  %PRINTTEXT '('
             %IF M>>4&15 # 15 %THEN WRITE(J&255+1,2) %C
                %ELSE WRITE(J>>4&15,2)
             %PRINTTEXT ','
             WRITE(K>>12&15,2);  %PRINTTEXT ')';  %PRINTTEXT ','
             WRITE(L&X'FFF',4);  %PRINTTEXT '('
             %IF M>>4&15 = 15 %THEN %START
                WRITE(J&15,2);  %PRINTTEXT ','
             %FINISH
             WRITE(L>>12&15,2);  %PRINTTEXT ')'
             -> 1
          %FINISH
          %IF M = 134 %OR M = 135 %OR M = 144 %OR M = 152 %THEN %START
             PUT(8,T)
             WRITE(J>>4&15,4);  %PRINTTEXT ','
             WRITE(J&15,2);  %PRINTTEXT ','
             -> 2
          %FINISH
          PUT(8,T)
          WRITE(K&X'FFF',5);  %PRINTTEXT '('
          WRITE(K>>12&15,2);  %PRINTTEXT ')'
          %PRINTTEXT ','
          WRITE(J&255,2)
          -> 1

%ROUTINE HEX(%INTEGER N)
%CONSTINTEGER S1 = M'0123', S2 = M'4567', S3 = M'89AB', S4 = M'CDEF'
%INTEGER W1, W2, W3
%OWNINTEGER MASK = X'0F0F0F0F', M2 = X'0F0F0F0F'
             *UNPK_W1+1(9),N(5)
             *NC_W1+1(8),MASK
             *TR_W1+1(8),S1
             *LA_1,W1+4
             *MVI_0(1),4
             *->P5
%END

%ROUTINE PUT(%INTEGER SP, SYMS)
             SPACES(SP)
             SP = 4
             PRINTSTRING(STRING(ADDR(SP)+3))
%END
%END
!

%SYSTEMINTEGERFN RTINFO(%INTEGER X, %ROUTINENAME R)
          *L_1,X+4;                     ! @ OF ENTRY VECTOR FOR R
          *L_2,X
          *BCTR_2,0
          *SLL_2,2
!*4
          *L_1,0(1,2)
          %RETURN
%END
%ENDOFFILE