.Title	LOC_INFO
.Ident	/X01.17/
.Enable	suppression
.Nlist	cnd,me
.Library /Sys$library:lib.mlb/
;
; LOC_INFO - Procedure to histogram process by procedures
;
; Author:
;
;	T. Miles, TRIUMF
;	 4004 Wesbrook Mall
;	  Vancouver, B.C.
;	   CANADA, V6T 2A3
;
;	(604) 228-4711
;
; External procedures
;
;	LIB$DISABLE_CTRL- Procedure disables control characters
;
;	LIB$ENABLE_CTRL	- Procedure enables  control characters
;
;	LIB$ERASE_LINE	- Procedure erases remainder of line
;
;	LIB$ERASE_PAGE	- Procedure erases remainder of page
;
;	LIB$GET_EF	- Procedure gets  local event flag
;
;	LIB$FREE_EF	- Procedure frees local event flag
;
;	LIB$GET_FOREIGN	- Procedure gets 'foreign' command line
;
;	LIB$PUT_SCREEN	- Procedure prints line on screen
;
;	LIB$SET_CURSOR	- Procedure places cursor as desired on screen
;
;	LIB$TPARSE	- Procedure parses command line into pieces
;
;	LOC_I$GET_PRC	- Procedure to return process name, state
;
;	OTS$CVT_L_TI	- Procedure converts decimal_to_ascii text
;
;	STR$TRIM	- Procedure removes trailing blanks
;
; Restrictions:
;
; (1)	Requires CMEXEC privilege
;
; Modifications:
;
;	Who		When		What
;	---		----		----
;	T. Miles	17-Aug-83	Original
;
;	T. Miles	18-Aug-83	Added RATE to reduce overhead
;
;	T. Miles	18-Aug-83	Guarantee CPU time has elapsed
;					before allowing 'event'.
;
;	T. Miles	18-Aug-83	Added /INTERVAL qualifier
;
;	T. Miles	19-Aug-83	Hike base priority
;
;	T. Miles	22-Aug-83	Use SETPRV to get temp privilege
;
;	T. Miles	23-Aug-83	Maintain info on HSTMAX procedures
;					Display HSTMAX if output to disk
;
;	T. Miles	23-Aug-83	Display accumulated CPU time
;
;	T. Miles	29-Aug-83	Changed names to agree with the
;					new TRIUMF naming convention
;
; Do definitions
;
$DCDEF
$DVIDEF
$PRVDEF
$PSLDEF
$SFDEF
$STATEDEF
$TPADEF
;
ACTIVE	=7.				; Line where histograms start
BUFLEN	=80.				; Length of line buffer
F_ACC	=1.				; Bit to FLAG if accumulating
F_INT	=F_ACC*2			; Bit to FLAG if interval
F_PID	=F_INT*2			; Bit to FLAG if PID specified
F_PRN	=F_PID*2			; Bit to FLAG if Name specified
HOME	=22.				; Home line for cursor
IMGLEN	=^X0040				; Maximum image name length
MAXDSP	=^X0008				; Maximum routines to display on CRT
MAXHST	=^X0080				; Maximum routines to histogram
NAMLEN	=^X0020				; Maximum routine name
PRI	=8.				; Priority to run info at
RATE	=050.				; Event Rate (Milliseconds)
START	=^X001C				; Column to start bar graphs
TKMIN	=5.				; Minimum number of ticks for display
VFYINT	=2				; Verify interval
;
.PSECT	$CODE,PIC,CON,REL,LCL,SHR,EXE,RD,NOWRT,LONG
;
.ENTRY	LOC_INFO,^M<R2,R3,R4,R5>
	JSB	ASK			; Find out what is wanted
	JSB	PRINT			;  ...and print header
	JSB	SETUP			;  ...then setup hist.
;
	$HIBER_S			; Wait for 'event'
;
99$:	RET				; Return to caller
;
; ASK - This routine interrogates user for details of INFO request
;
ASK:	MOVZBL	#BUFLEN,BUFDST		; Initialize string
	MOVAL	BUFFER,BUFDST+4		;  ...descriptor
;
	PUSHAL	PASS			; Push pass count
	PUSHAL	BUFDST			; Get user's PID
	PUSHAL	PRMDST			;  ...prompt
	PUSHAL	BUFDST			; From him
	CALLS	#4,G^LIB$GET_FOREIGN	;  ...do it
	BLBC	R0,10$			;  ...failed
;
	PUSHAL	PARM2			; Push parameter #2
	PUSHAL	PARM1			;  ... parameter #1
	PUSHAL	BLOCK			;  ... then block
	CALLS	#3,G^LIB$TPARSE		;  ... parse it
	BLBC	R0,10$			;  ... failed
;
	BITL	#F_PID!F_PRN,FLAGS	; Any process specified
	BEQL	ASK			;  ...no, retry
;
	$CMEXEC_S ROUTIN=GETPRV		; Grant temporary privileges
10$:	BLBC	R0,99$			;  ...couldn't
;
	JSB	CLRHST			; Translate process name to PID
	BLBC	R0,99$			;  ...oops
;
	$CMEXEC_S ROUTIN=GIVPRV		; Surrender temp. privileges
	BLBC	R0,99$			;  ...couldn't
;
	MOVC5	IMNDST,IMGNEW,#^X20,-	; Save original file name
		#IMGLEN,IMGFIL		;  ...for /ACCUMULATE
;
	TSTL	INT			; Is the interval valid?
	BLEQU	20$			;  ...no
	EMUL	#-10.*1000.*1000.,-	; Calculate display interval
		INT,#0,DSPTIM		;  ...delta time units
;
	RSB				; Return to caller
;
20$:	MOVZWL	#SS$_IVTIME,R0		; Invalid time specified
;	BRB	99$			;  ...and continue
;
99$:	RET				; Exit with Status
;
; PRINT - Routine to print initial mask on user screen
;
PRINT:	MOVZBL	#BUFLEN,BUFDST		; Initialize temp
	MOVAL	BUFFER,BUFDST+4		;  ...descriptor
;
	$FAOL_S CTRSTR=HDR1,PRMLST=PID,-; Format process i.d.
	OUTLEN=BUFDST,OUTBUF=BUFDST	;  ...into header
	BLBC	R0,15$			;  ...error somewhere
;
	MOVZBL	#1,LINE			; Now erase
	MOVZBL	#1,COL			;  ...the page
	PUSHAL	COL			;  ...like this
	PUSHAL	LINE			;  ...from example
	CALLS	#2,G^LIB$ERASE_PAGE	;  ...in manual
	BLBC	R0,15$			;
;
10$:	MOVZBL	#10.,COL		; Now print title
	PUSHAL	COL			;  ...of display
	PUSHAL	LINE			;  ...like this
	PUSHAL	BUFDST			;  ...header
	CALLS	#3,G^LIB$PUT_SCREEN	;  ...like so
	BLBC	R0,15$			;
;
	MOVZBL	#ACTIVE-3,LINE		; Print header #2
	MOVZBL	#1,COL			;  ...like this
	PUSHAL	COL			;
	PUSHAL	LINE			;
	PUSHAL	HDR2			;
	CALLS	#3,G^LIB$PUT_SCREEN	;
15$:	BLBC	R0,99$			;
;
	MOVZBL	#ACTIVE-2,LINE		; Print header #3
	PUSHAL	COL			;
	PUSHAL	LINE			;
	PUSHAL	HDR3			;
	CALLS	#3,G^LIB$PUT_SCREEN	;
	BLBC	R0,99$			;
;
	BITL	#F_ACC,FLAGS		; Accumulating?
	BEQL	20$			;  ...no, so skip
;
	MOVZBL	#3,LINE			; Show /ACCUMULATE status
	MOVZBL	#4.,COL			;  ...for John Lloyd
	PUSHAL	COL			;
	PUSHAL	LINE			;
	PUSHAL	JLMSG			;
	CALLS	#3,G^LIB$PUT_SCREEN	;
	BLBC	R0,99$			;
;
20$:	MOVZBL	#HOME,LINE		; Print end of line
	MOVZBL	#1,COL			;  ...for home
	PUSHAL	COL			;
	PUSHAL	LINE			;
	CALLS	#2,G^LIB$SET_CURSOR	;
	BLBC	R0,99$			;
;
	RSB				;  ...back to user
;
99$:	RET				; Exit with status
;
; SETUP - Routine to set up 'Events' to histogram
;
SETUP:	$ASSIGN_S CHAN=CHAN,-		; Assign a channel
	DEVNAM=TTY,ACMODE=#PSL$C_USER	;  ...for the user
	BLBC	R0,10$			;  ...couldn't
;
	PUSHAL	EFN			; Then go allocate event
	CALLS	#1,G^LIB$GET_EF		;  ...flag for us
	BLBC	R0,10$			;  ...couldn't
;
	$GETDVI_S CHAN=CHAN,EFN=EFN,-	; Find out what the device
		ITMLST=GLST		;  ...type is
	BLBC	R0,10$			;  ...couldn't
;
	$WAITFR_S EFN=EFN		; Wait for the answer
	BLBC	R0,10$			;  ...couldn't
;
	PUSHAL	EFN			; Release the event flag
	CALLS	#1,G^LIB$FREE_EF	;  ...since available
10$:	BLBC	R0,20$			;  ...couldn't
;
	MOVAL	MSKNEW,R0		; R0 --> Mask
	$QIO_S	CHAN=CHAN,-		; Go prepare to blow him away
	P1=C_AST,P2=R0,P3=#PSL$C_USER,-	; ...politely, with display
	FUNC=#IO$_SETMODE!IO$M_OUTBAND	; ...on unsolicited stuff
;
	$CMEXEC_S ROUTIN=GETPRV		; Grant temporary privileges
	BLBC	R0,20$			;  ...couldn't
;
	$DCLEXH_S DESBLK=DESBLK		; Declare exit handler
20$:	BLBC	R0,99$			;  ...error somewhere
;
	PUSHAL	MSKOLD			; Push old control mask
	PUSHAL	MSKNEW+4		;  ...and new mask
	CALLS	#2,G^LIB$DISABLE_CTRL	;  ...disable control
;
	$SETPRI_S PRI=#PRI,PRVPRI=PRB	; Go boost priority
	BLBC	R0,99$			;  ...couldn't
;
	$DCLAST_S MODE=#PSL$C_USER,-	; Force an 'Event' to activate
		ASTADR=EVENT		;  ...histogramming
	BLBC	R0,99$			;  ...error somewhere
;
	$DCLAST_S MODE=#PSL$C_USER,-	; Force 'Verify' event to start
		ASTADR=VFY		;  ...image verify
	BLBC	R0,99$			;  ...error somewhere
;
	$DCLAST_S MODE=#PSL$C_USER,-	; Force 'Display' event to start
		ASTADR=DPY		;  ...displaying
	BLBC	R0,99$			;  ...error somewhere
;
	RSB				;  ...return to caller
;
99$:	RET				; Exit with status
;
; C_AST - This procedure prints display, then terminates INFO gracefully...
;
C_AST:	.WORD	^M<R2,R3,R4,R5,R6,R7,R8>
	JSB	DISP			;  ...do display
	BRW	GRACE+2			;  ...then go away
;
; GRACE - This procedure makes INFO go away gracefully...
;
GRACE:	.WORD	^M<>			; Use no registers
	$SETAST_S ENBFLG=#0		;  ...disable AST
	$WAKE_S				;  ...and wake up
	RET				;  ...back to caller
;
; EVENT - This procedure increments the bin for the active user subroutine
;
EVENT:	.WORD	^M<R2,R3,R4,R5,R6,R7,R8>
;
	PUSHAL	CPUTIM			; Cpu time
	PUSHAL	STATE			; Process state
	PUSHAL	IMODST			; Image name
	PUSHAL	NAMDST			; Procedure name
	PUSHAL	PID			; Process I.D.
	CALLS	#5,G^LOC_I$GET_PRC	; Do look-up
;
	BLBS	R0,10$			; Continue on success
	CMPL	#SS$_BADIMGHDR,R0	; Missing symbol table?
	BEQL	10$			;  ...yes, continue
	CMPL	#SS$_SUSPENDED,R0	; Process swapped out?
	BEQL	15$			;  ...yes, bad event
	CMPL	#SS$_NONEXPR,R0		; Process gone away?
	BEQL	C_AST+2			;  ...yes, handle gracefully
	$EXIT_S CODE=R0			; Else ungraceful error
;
10$:	CMPW	#SCH$C_COM,STATE	; Compute bound?
	BEQL	20$			;  ...yes
	CMPW	#SCH$C_COMO,STATE	; Compute, outstapped?
	BEQL	20$			;  ...yes
	CMPW	#SCH$C_CUR,STATE	; Current?
	BEQL	20$			;  ...yes
	CMPW	#SCH$C_PFW,STATE	; Awaiting page?
	BEQL	20$			;  ...yes
15$:	BRW	90$			; Bad event.
;
20$:	CMPL	CPUTIM,CPULST		; Has any CPU time elapsed?
	BEQL	15$			;  ...no, bad event
	MOVL	CPUTIM,CPULST		; Else save new CPU time
;
	CLRL	R6			; R6 = bin index
;
30$:	MOVQ	NAMDST,R0		; R0 = Name Descriptor
	MOVL	G^NAMTBL[R6],R2		; R2 --> Name String
	TSTL	G^USETBL[R6]		;  ...bin in use?
	BNEQ	40$			;  ...yes
	MOVC3	#NAMLEN,(R1),(R2)	; Else name the bin
	BRB	50$			;  ...and continue
;
40$:	CMPC3	#NAMLEN,(R1),(R2)	; Found correct bin?
	BNEQ	60$			;  ...no
50$:	INCL	G^USETBL[R6]		; Else increment bin
	BRB	70$			;  ...and get out
;
60$:	AOBLEQ	#MAXHST-1,R6,30$	; Try the next bin
;
70$:	INCL	TICK			; Bump tick count
;
90$:	$SETIMR_S DAYTIM=TIME,-		; Queue another 'Event'
		ASTADR=EVENT		;  ...in real time
	RET				;  ...and go away
;
; SORT - Routine to sort name and use table by ticks
;
SORT:	CLRL	R6			; R6 = Index
;
10$:	TSTL	G^USETBL[R6]		; Done entire sort?
	BEQL	15$			;   ...yes
	CMPL G^USETBL+4[R6],G^USETBL[R6]; Entry in order?
	BGTR	20$			;  ...no
	AOBLEQ	#MAXHST-2,R6,10$	; Else done?
15$:	RSB				;  ...yes
;
20$:	MOVL	G^NAMTBL[R6],R7		; R7 --> This entry
	MOVL	G^NAMTBL+4[R6],R8	; R8 --> Next Entry
;
	MOVL	G^USETBL[R6],USE	; Save this entry
	MOVC3	#NAMLEN,(R7),@NAMDST+4	;
;
	MOVL G^USETBL+4[R6],G^USETBL[R6]; Do swap
	MOVC3	#NAMLEN,(R8),(R7)	;
;
	MOVL	USE,G^USETBL+4[R6]	; Restore entry
	MOVC3	#NAMLEN,@NAMDST+4,(R8)	;
;
	BRB	SORT			;  ...and retry
;
; DISP - Routine to display histogram on screen
;
DISP:	CMPL	#TKMIN,TICK		; Minimum number of ticks
	BLEQU	05$			;  ...yes, display
	BRW	40$			; Else give up
;
05$:	JSB	SORT			; Sort the display
;
	MOVZBL	#2,LINE			; Erase old image name
	MOVZBL	#28.,COL
	PUSHAL	COL
	PUSHAL	LINE
	CALLS	#2,G^LIB$ERASE_LINE
;
	BITL	#F_ACC,FLAGS		; Accumulating statistics
	BEQL	07$			;  ...no
	MOVC3	#IMGLEN,IMGFIL,IMGOLD	; Else force image name
;
07$:	MOVZWL	#IMGLEN,IMNDST		; Reset desc. length
	PUSHAL	IMNDST			;  ...copy from old
	PUSHAL	IMODST			;  ...to new image name
	PUSHAL	IMNDST			;  ...and remove blanks
	CALLS	#3,G^STR$TRIM		;  ...thusly
;
	PUSHAL	COL			;  ...print new name
	PUSHAL	LINE
	PUSHAL	IMNDST
	CALLS	#3,G^LIB$PUT_SCREEN
;
	SUBL3	CPUSTA,CPUTIM,TIMBUF	; Find elapsed CPU time
	EMUL	#100000.,TIMBUF,#0,-	;  ...in system units
		TIMBUF			;  ...for system call
	$ASCTIM_S TIMADR=TIMBUF,-	;  ...then convert
	TIMBUF=TIMDST,CVTFLG=#1		;  ...into ascii
;
	MOVZBL	#3,LINE			; Print elapsed CPU time
	MOVZBL	#START+7.,COL
	PUSHAL	COL
	PUSHAL	LINE
	PUSHAL	TIMDST
	CALLS	#3,G^LIB$PUT_SCREEN
;
	$ASCTIM_S TIMBUF=TIMDST,CVTFLG=#1
;
	MOVZBL	#START+32.,COL		; Print real day-time
	PUSHAL	COL
	PUSHAL	LINE
	PUSHAL	TIMDST
	CALLS	#3,G^LIB$PUT_SCREEN
;
	CLRL	R6			; Reset index
	MOVZBL	#ACTIVE,LINE
	MOVZBL	#1,COL
;
10$:	MOVZBL	#BUFLEN,BUFDST		; Reset buffer descriptor
	MOVAL	BUFFER,BUFDST+4		;  ...as it was
	MOVQ	BUFDST,R7		; R7,R8 are buffer descriptor
;
	MOVL	G^NAMTBL[R6],R2		; R2 --> Name String
	MOVC5	#NAMLEN,(R2),#^X20,R7,(R8)
;
	MOVAL	START(R8),R5		; R5 --> Buffer
	MOVB	#^A/:/,-1(R5)		; Insert 'Fence'
	MULL3	#100.,G^USETBL[R6],USE	; Use = Ticks * 100
	DIVL	TICK,USE		;     = %
	BEQL	25$			;  ...none
;
	PUSHAL	USEDST			; Ascii descriptor
	PUSHAL	USE			;  ...value
	CALLS	#2,G^OTS$CVT_L_TI	;  ...convert to string
	INCL	USE			; Remove aliasing
;
15$:	SUBL	#2,USE			; Decrease use
	BLSS	20$			;  ...done
	MOVB	#^A/=/,(R5)+		;  ...lengthen arrow
	BRB	15$			;  ...and continue
;
20$:	MOVB	#^A/>/,-1(R5)		;  ...insert arrowhead
;
25$:	SUBL3	R8,R5,BUFDST		; Calculate line length
	PUSHAL	COL			; Erase previous line
	PUSHAL	LINE			;  ...with library
	CALLS	#2,G^LIB$ERASE_LINE	;  ...procedure
;
	PUSHAL	COL			;  ...then print
	PUSHAL	LINE			;  ...the entire
	PUSHAL	BUFDST			;  ...new line
	CALLS	#3,G^LIB$PUT_SCREEN	;  ...here
;
	ADDL	#2,LINE			; Select next line
	INCL	R6			;  ...next bin
	CMPL	#MAXHST-1,R6		; Maximum histogram reached
	BLSS	30$			;  ...yes, done
	TSTL	G^USETBL[R6]		; Is next bin in use
	BEQL	30$			;  ...no, done
	CMPL	#MAXDSP-1,R6		; Maximum display reached
	BLSS	28$			;  ...yes
	BRW	10$			; Else process next bin
;
28$:	CMPL	#DC$_DISK,DEVCLS	; Is display going to disk
	BNEQ	30$			;  ...no, done
	BRW	10$			; Else process next bin
;
30$:	DECL	LINE			; Decrement line count
	MOVZBL	#1,COL			;  ...and reset column
	PUSHAL	COL			;  ...and erase
	PUSHAL	LINE			;  ...rest of
	CALLS	#2,G^LIB$ERASE_PAGE	;  ...the page
;
	MOVZBL	#HOME,LINE		; Print end of line
	MOVZBL	#1,COL			;  ...for home
	PUSHAL	COL			;
	PUSHAL	LINE			;
	CALLS	#2,G^LIB$SET_CURSOR	;
;
	CMPL	#DC$_DISK,DEVCLS	; Is display going to disk?
	BEQL	50$			;  ...yes, done
	BITL	#F_ACC,FLAGS		; Else accumulating?
	BNEQ	40$			;  ...yes, accumulate
	JSB	CLRHST			; Else clear histogram
;
40$:	RSB				;  ...and return
;
50$:	BRW	GRACE+2			;  ...take graceful exit
;
; LOOKUP - Routine to return PID and IMAGE file name
;
LOOKUP:	PUSHAL	EFN			; Allocate Event Flag
	CALLS	#1,G^LIB$GET_EF		;  ...with call
	BLBC	R0,99$			;  ...failed
;
	$GETJPI_S EFN=EFN,PIDADR=PID,-	; Get the current image
	PRCNAM=PRCDST,ITMLST=ITMLST	;  ...name from sys
	BLBC	R0,99$			;  ...failed
;
	$WAITFR_S EFN=EFN		; Wait for answer
	BLBC	R0,99$			;  ...failed
;
	PUSHAL	EFN			; Release Event Flag
	CALLS	#1,G^LIB$FREE_EF	;  ...with call
	BLBC	R0,99$			;  ...failed
;
	CLRQ	PRCDST			;  ...reset name
;
99$:	RSB				; Return to caller
;
; VFY - Procedure queued at VFYINT seconds to verify image has not changed
;
VFY:	.WORD	^M<R2,R3,R4,R5,R6,R7,R8>
;
	JSB	LOOKUP			;  ...get new image name
	BLBC	R0,40$			;  ...couldn't
;
	TSTW	IMNDST			; Is there an image file?
	BEQL	20$			;  ...no, treat specially
;
	CMPB	#^X20,IMGNEW		; Is there an image file?
	BGEQU	20$			;  ...no, treat specially
;
	CMPC3	IMNDST,IMGOLD,IMGNEW	; Has the image changed?
	BEQL	40$			;  ...no, just go away
;
	BITL	#F_ACC,FLAGS		; Yes, was /ACC specified?
	BEQL	10$			;  ...no, flush histogram
;
	BRW	C_AST+2			; Else treat like ^C
;
10$:	CALLS	#0,G^LOC_I$GET_PRC	; Flush old symbol table
	JSB	CLRHST			;  ...and histogram
;
	BRB	40$			;  ...and go away
;
20$:	BITL	#F_ACC,FLAGS		;  ...is /ACCUMULATE set?
	BEQL	30$			;  ...no
	BRW	C_AST+2			;  ...else die
;
30$:	CMPB	#^X20,IMGOLD		; Was there an old image file?
	BLSSU	10$			;  ...yes, flush symbol table
;
40$:	$SETIMR_S DAYTIM=VFYTIM,-	;  ...and queue another
		ASTADR=VFY		;  ...verify request
	RET				;  ...then leave
;
; DPY - Procedure queued at INT real-time seconds to do display
;
DPY:	.WORD	^M<R2,R3,R4,R5,R6,R7,R8>
	JSB	DISP			;  ...do display
	$SETIMR_S DAYTIM=DSPTIM,-	;  ...and queue another
		ASTADR=DPY		;  ...display
	RET				;  ...then leave
;
; GETPRV - Procedure gives image temporary privileges
;
GETPRV:	.WORD	^M<>			; Entered in Exec. Mode
	$SETPRV_S ENBFLG=#1,PRMFLG=#0,-	;  ...give temporary
	PRVADR=PRIV,PRVPRV=PRVPRV	;  ...privilege only
	RET				;  ...exit with status
;
; GIVPRV - Procedure surrenders image temporary privileges
;
GIVPRV:	.WORD	^M<>			; Entered in Exec. Mode
	$SETPRV_S ENBFLG=#0,PRMFLG=#0,-	;  ...surrender temp.
		PRVADR=PRIV		;  ...privileges
	$SETPRV_S ENBFLG=#1,PRMFLG=#0,-	;  ...enable old temp.
		PRVADR=PRVPRV		;  ...privileges.
	RET				;  ...exit with status
;
; EXHNDL - Procedure restores saved process priority, control mask
;
EXHNDL:	.WORD	^M<>			;
	$SETPRI_S PRI=PRB		; Restore saved priority
	PUSHAL	MSKOLD			;  ...then restore
	CALLS	#1,G^LIB$ENABLE_CTRL	;  ...control chars.
	RET				;  ...back to caller
;
; CLRHST - Routine to zero histogram and reset event count
;
CLRHST:	MOVC5	#0,G^USETBL,#0,-	; Zero the event count
		#MAXHST*4,G^USETBL	;  ...for everything
	CLRL	TICK			;  ...no 'events'
	JSB	LOOKUP			;  ...get 'CPU'
	MOVL	CPUTIM,CPUSTA		;  ...and reset
	RSB				;  ...then return
;
.PSECT	$HIST,PIC,CON,REL,LCL,NOSHR,NOEXE,RD,WRT,LONG
;
USETBL:	.BLKL	MAXHST			; CPU usage table
;
.PSECT	$LOCAL,PIC,CON,REL,LCL,NOSHR,NOEXE,RD,WRT,LONG
;
BUFFER:	.BLKB	BUFLEN			; Line Buffer
CHAN:	.LONG	0			; Channel number for tty
COL:	.LONG	0			; Column of cursor
CPULST:	.LONG	0			; Saved CPU time
CPUSTA:	.LONG	0			; Start CPU time
CPUTIM:	.LONG	0			; Event CPU time
DEVCLS:	.LONG	0			; Device class
DSPTIM:	.LONG	-1,-1			; Display interval
EFN:	.LONG	0			; Local Event Flag
FLAGS:	.LONG	0			; Status Flags go here
IMGFIL:	.BLKB	IMGLEN			; Original image name
IMGNEW:	.BLKB	IMGLEN			; New image name
IMGOLD:	.BLKB	IMGLEN			; Old image name
IMNDST:	.ADDRESS 0,IMGNEW		; New image descriptor
INT:	.LONG	3			; Polling interval (seconds)
LINE:	.LONG	0			; Line   of cursor
MSKOLD:	.LONG	0			; Old control mask
NAME:	.BLKB	NAMLEN			; Name of Routine
PASS:	.LONG	0			; Counter for force_prompt
PID:	.LONG	0			; Process Identification
PRB:	.LONG	4			; Saved base priority
PRCDST:	.LONG	0,0			; Process name descriptor
PRVPRV:	.LONG	0,0			; Previous privileges
STATE:	.LONG	0			; Process state
TICK:	.LONG	0			; Ticks since hist
TIMBUF:	.BLKB	11.			; Buffer for time
USE:	.LONG	0			; Usage in %
;
DESBLK:	.ADDRESS	0		; Forward Link
	.ADDRESS	EXHNDL		; Exit handler
	.LONG		1		; One argument
	.ADDRESS	.+4		;  ...reason
	.LONG		0		;  ...is here
;
BLOCK:	.LONG	TPA$K_COUNT0
	.LONG	TPA$M_ABBREV!-
		TPA$M_BLANKS
	.BLKB	TPA$K_LENGTH0-<.-BLOCK>
;
BUFDST	=BLOCK+TPA$L_STRINGCNT		; String descriptor
;
$INIT_STATE	PARM1,PARM2
;
; Look for something
;
$STATE	BEGIN				; Start parsing line
$TRAN	'/',OPTION			; Option found
$TRAN	TPA$_BLANK,BEGIN		; Ignore blanks
$TRAN	TPA$_EOS,TPA$_EXIT		; End of string
$TRAN	!GET_IT,BEGIN,,,PRCDST		; Extract process name
;
; Get character string
;
$STATE	GET_IT				; Start fetching string
$TRAN	!CHECK,GET_IT,,F_PRN,FLAGS	; Check character
$TRAN	TPA$_LAMBDA,TPA$_EXIT		;  ...and return
;
; Check character (fetch if legal)
;
$STATE	CHECK				; Check single character
$TRAN	TPA$_BLANK,TPA$_FAIL		; Blank illegal
$TRAN	TPA$_EOS,TPA$_FAIL		;  ...also end of string
$TRAN	'/',TPA$_FAIL			;  ...and backslash
$TRAN	TPA$_ANY,TPA$_EXIT		; Else get character
;
; What option is it?
;
$STATE	OPTION
$TRAN	'ACCUMULATE',BEGIN,,F_ACC,FLAGS
$TRAN	'IDENTIFICATION',GETPID,,F_PID,FLAGS
$TRAN	'INTERVAL',GETINT,,F_INT,FLAGS
$TRAN	TPA$_LAMBDA,TPA$_FAIL
;
; Extract Process I.D.
;
$STATE	GETPID
$TRAN	'='				; Valid delimiter
$TRAN	':'				; Valid delimiter
$TRAN	TPA$_LAMBDA,TPA$_FAIL		;  ...else die
;
$STATE
$TRAN	TPA$_HEX,BEGIN,,,PID		; Get hex value
$TRAN	TPA$_LAMBDA,TPA$_FAIL		;  ...else die
;
; Extract display interval
;
$STATE	GETINT
$TRAN	'='				; Valid delimiter
$TRAN	':'				; Valid delimiter
$TRAN	TPA$_LAMBDA,TPA$_FAIL		;  ...else die
;
$STATE
$TRAN	TPA$_DECIMAL,BEGIN,,,INT	; Get display interval
$TRAN	TPA$_LAMBDA,TPA$_FAIL		;  ...else die
;
$END_STATE
;
.PSECT	$PDATA,PIC,CON,REL,LCL,SHR,NOEXE,RD,NOWRT,LONG
;
IMODST:	.LONG	IMGLEN
	.ADDRESS IMGOLD
NAMDST:	.LONG	NAMLEN
	.ADDRESS NAME
TIMDST:	.LONG	11.
	.ADDRESS	TIMBUF
USEDST:	.LONG	3
	.ADDRESS BUFFER+START-5.
;
MSKNEW:	.LONG	0,-1			; New control mask
PRIV:	.LONG	<1@PRV$V_ALTPRI>!<1@PRV$V_BYPASS>!<1@PRV$V_WORLD>,0
TIME:	.LONG	-10*RATE*1000,-1	; Tick rate (delta)
VFYTIM:	.LONG	-10*1000*1000*VFYINT,-1	; Verify rate (delta)
;
GLST:	.WORD	4,DVI$_DEVCLASS		; Used by SYS$GETDVI procedure call
	.ADDRESS DEVCLS,0,0		;  ...terminate list
;
ITMLST:	.WORD	4,JPI$_PID		; Used by SYS$GETJPI procedure call
	.ADDRESS PID,0			;  ...return PID
;
	.WORD	4,JPI$_CPUTIM		;  ...return CPU time
	.ADDRESS CPUTIM,0		;  ...for CLRHST
;
	.WORD	IMGLEN,JPI$_IMAGNAME	;  ...return image name
	.ADDRESS IMGNEW,IMNDST		;  ...text and descriptor
;
	.LONG	0			; Terminate list
;
NAMTBL	=.				; Name table
;
	.REPT	MAXHST
	.ENABLE	LSB
	.ADDRESS 10$
	.SAVE_PSECT
	.PSECT	$HIST,PIC,CON,REL,LCL,NOSHR,NOEXE,RD,WRT,LONG
10$:	.BLKB	NAMLEN
	.RESTORE_PSECT
	.DISABLE LSB
	.ENDR
;
HDR1:	.ASCID	$VAX/VMS process !XL top CPU users by procedure name...   T.M.$
HDR2:	.LONG	20$-10$
	.ADDRESS 10$
10$:	.BYTE	^X20[START-1]
	.ASCII	/0%                      50%                      100%/
20$:
;
HDR3:	.LONG	20$-10$
	.ADDRESS 10$
10$:	.BYTE	^X20[START-1]
	.ASCII	/:           ..           :           ..           :/
20$:
JLMSG:	.ASCID	/-- Accumulating --/
PRMDST:	.ASCID	/$_Process: /
TTY:	.ASCID	/SYS$COMMAND:/
;
.End	LOC_INFO