BPXB1SM6 CSECT , Nonreentrant linkage
BPXB1SM6 AMODE 64
SYSSTATE AMODE64=YES
@BEGIN0 J @BEGIN1 Branch around program header
DC C'BPXB1SM6 - nonreentrant __getthent invoker'
DS 0H
@BEGIN1 STMG R14,12,12(R13) Save callers registers
BRAS R12,PDATA1 Establish addressability save area ea
DC A(@SAVE00)
PDATA1 L R12,0(,R12)
USING @SAVE00,R12
STG R13,@BACK Save ->Callers save area
LA R13,@SAVE00 Program addressability
DROP R12
USING @SAVE00,R13 Program addressability
J @BEGIN2
@SAVE00 DS 0D Standard save area - 144 Bytes
DS A Reserved
DS CL4'F4SA' Linkage Type
DS 15AD Regs 14,15,0-12
@BACK DS AD Backwards save area pointer
@FORWARD DS AD Forwards save area pointer
RETURN XR R15,R15 Zero return code
RETURNRC LG R13,@BACK Restore callers r13
LG R14,12(,R13) Restore callers r14
LMG R0,R12,20(R13) Restore callers r0-r12
BR R14 Branch back to caller
R0 EQU 0
R1 EQU 1 Parameter list pointer
R2 EQU 2
R3 EQU 3
R4 EQU 4
R5 EQU 5
R6 EQU 6
R7 EQU 7
R8 EQU 8
R9 EQU 9
R10 EQU 10
R11 EQU 11
R12 EQU 12
R13 EQU 13 Program and save area base
R14 EQU 14 Return address
R15 EQU 15 Branch location
@BEGIN2 EQU * * * * * * * End of the entry linkage code
EJECT ,
LA R5,BUFFERA R5-> Input buffer
STG R5,PGTHAB -> input buffer
USING PGTHA,R5 R5 base for PGTHA
XC PGTHA,PGTHA Null input area
MVI PGTHAFLAG1,PGTHAPROCESS+PGTHATHREAD
MVI PGTHAPID,PGTH#FIRST First thread
LA R15,BUFFERB Pgthb, Output buffer
STG R15,PGTHBB Output Buffer
SPACE , * * * * * *
LA R0,=CL8'BPX4GTH ' LOAD -> entry point name
XGR R1,R1 No JOBLIB or LINKLIB DCB
SVC 8 Issue LOAD SVC
NILL R0,X'FFFE' Turn off low order bit
STG R0,GETENTRY Store BPX4GTH entry point
GETTH LG R15,GETENTRY Address of BPX4GTH load module
CALL (15), Get process data +
(PGTHAL, Length of buffer +
PGTHAB, Buffer, mapped by BPXYPGTH +
PGTHBL, Length of output buffer +
PGTHBB, Buffer, mapped by BPXYPGTH +
RETVAL, Return value (next, eof or error) +
RETCODE, Return code +
RSNCODE), Reason code +
LINKINST=BALR
SPACE , * * * * * *
L R15,RETVAL Load return value
C R15,=F'-1' Test for -1 return
BE RETURNRC -1 is error
SPACE , * * * * * * Initialize WTO area & message
MVI XPID,C' ' Blank out variable portion of msg ge
MVC XPID+1(WTO#BLANK-1),XPID
SPACE , * * * * * * Process ID to printable hex
LA R6,BUFFERB R6-> Output buffer
STG R6,PGTHBB -> output buffer
USING PGTHB,R6 R6 base for PGTHB
L R8,PGTHBPID R8 = process ID
LA R9,XPID To be placed at message start
LA R15,8 8 nibbles to convert (4 bytes)
LA R10,9 For 0-9 / A-F compare
NIBBLE LR R11,R8 Target bits in 0-3 XYYYYYYZ
SRL R11,28 Bits 0-3 to 28-31 0000000X
SLL R8,4 Drop bits 0-3 off end YYYYYYZ0
CLR R11,R10 Are 4 bits 0-9 or A-F
BC B'0010',AF Branch if A-F
LA R11,57(,R11) Add for 0-9 (57+183=240 or F0)
AF LA R11,183(,R11) Add for 0-F (183+10=193 or C1)
STC R11,0(,R9) Store to results location
LA R9,1(,R9) Increment R9 to next location
BCT R15,NIBBLE Decrement half byte counter, loop
SPACE , * * * * * * Test status bits
* Go after the state of the process
LA R7,PGTHB Get the PGTHB address
SLR R9,R9 Clear r9
ICM R9,7,PGTHBOFFC Get offset for PGTHC
AR R7,R9 Calculate address
USING PGTHC,R7 Addressability for PGTHC
LA R8,PGTHB Get the PGTHB address
SLR R9,R9 Clear r9
ICM R9,7,PGTHBOFFJ Get offset for PGTHJ
AR R8,R9 Calculate address
USING PGTHJ,R8 Addressability for PGTHJ
MVI THREAD,C'1' Assume single
TM PGTHCFLAG1,PGTHCMULPROCESS if multiprocess
BZ NOTMULT
MVI THREAD,C'M'
NOTMULT MVC STATE,PGTHJSTATUS2 Z, W, X, S, C, F, K, R ...
TM PGTHCFLAG1,PGTHCSWAP if swapped out
BZ NOTSWAP
MVC SWAPA,=CL4'SWAP'
NOTSWAP TM PGTHCFLAG1,PGTHCSTOPPED if stopped
BZ NOTSTOP
MVC STOPA,=CL4'STOP'
NOTSTOP TM PGTHCFLAG1,PGTHCTRACE if ptrace
BZ NOTTRAC
MVC TRACA,=CL4'TRAC'
NOTTRAC EQU *
SPACE , * * * * * * Display message to operator
LA R2,WTOAREA R2->WTO message area
WTO TEXT=(R2) Write to Operator
SPACE , * * * * * * Loop back
MVC PGTHACONTINUE,PGTHBCONTINUE get next thread, process
J GETTH
WTOAREA DS 0F WTO message
DC AL2(WTO#LENGTH) Length of area
DC CL4'PID=' Process ID =
XPID DS CL8 Hex of process ID
DS CL1
THREAD DS CL1 1, M
DS CL1
STATE DS CL1 Z, W, X, C, F, K, R ...
DS CL1
SWAPA DS CL4 SWAP or blank
DS CL1
STOPA DS CL4 STOP or blank
DS CL1
TRACA DS CL4 TRAC or blank
WTO#BLANK EQU *-XPID Length to blank
DC C'.'
WTO#LENGTH EQU *-WTOAREA Length of WTO area
SPACE ,
GETENTRY DS AD Address of BPX4GTH
RETVAL DS F Return value - next
RETCODE DS F Return code
RSNCODE DS F Reason code
SPACE ,
BUFFERA DS CL50 Buffer for Process data
BUFFERB DS CL500 Buffer for Process data
PGTHAL DC A(PGTHA#LEN) Length of PGTH buffer
PGTHAB DS AD(PGTHA) ->Process data buffer
PGTHBL DC A(500) Length of PGTH buffer
PGTHBB DS AD(PGTHB) ->Process data buffer
BPXYPGTH DSECT=NO Place in current CSECT / DSECT
END