;*************************** AMUS Program Label ******************************
; Filename: PROGS.SBR                                       Date: 04/20/90
; Category: UTIL         Hash Code: 522-273-702-257      Version: 1.1(102)
; Initials: ULTR/US      Name: DAVID PALLMANN
; Company: ULTRASOFT CORPORATION                   Telephone #: 5163484848
; Related Files: 
; Min. Op. Sys.: AMOSL 1.3B/AMOS32 1.0         Expertise Level: BEG
; Special: 
; Description: Return program names (and, optionally, job names, and now user
; names) to BASIC. 
;*****************************************************************************
;****************************************************************************
;*									    *
;*				  PROGS.SBR				    *
;*   AlphaBASIC XCALL to return program names of all jobs on the system	    *
;*									    *
;****************************************************************************
;Copyright (C) 1990 UltraSoft Corporation.  All Rights Reserved.
; Username code added Copyleft 1993 Bob Rubendunst, Soft Machines.
;
;	MAP1 JOB'COUNT, F, 6
;	MAP1 PROG'NAME(x), S, 6
;	MAP1 JOB'NAME(x), S, 6			<- optional
;	MAP1 USER'NAME(x), S, 20		<- also optional
;		...
;	XCALL PROGS, JOB'COUNT, PROG'NAME(1) {,JOB'NAME(1)} {,USER'NAME(1)}
;
;	sets JOB'COUNT to the number of jobs on the system
;	returns PROG'NAME(1) through PROG'NAME(JOB'COUNT) with program names
;
;	if specified, JOB'NAME(1) through JOB'NAME(JOB'COUNT) receives the
;	name of each job.  This third parameter is optional.
;
;	if specified, USER'NAME(1) through USER'NAME(JOB'COUNT) receives the
;	name of each job.  This third parameter is optional.
;
;Written by: David Pallmann
;
;Edit History:
;1.0(100)  29-Aug-90  created. /DFP
;1.1(101)  12-Dec-90  add optional third argument to return job names. /DFP
;[102] 20 April 1993 15:05	Edited by Bob Rubendunst, Soft Machines.
;	Added user name array code.
;	

	VMAJOR	=1
	VMINOR	=1
	VSUB	=0
	VEDIT	=102.
	VWHO	=0

	OBJNAM	.SBR

	SEARCH	SYS
	SEARCH	SYSSYM

;XCALL argument list - indexed by A3

	.OFINI
	.OFDEF	X.ARGS,	2		; number of arguments
	.OFDEF	X.TYP1,	2		; arg 1 - type code
	.OFDEF	X.ADR1,	4		;       - address
	.OFDEF	X.SIZ1,	4		;       - size
	.OFDEF	X.TYP2,	2		; arg 2 - type code
	.OFDEF	X.ADR2,	4		;       - address
	.OFDEF	X.SIZ2,	4		;       - size
	.OFDEF	X.TYP3,	2		; arg 3 - type code		[101]
	.OFDEF	X.ADR3,	4		;       - address		[101]
	.OFDEF	X.SIZ3,	4		;       - size			[101]
	.OFDEF	X.TYP4,	2		; arg 4 - type code		[102]
	.OFDEF	X.ADR4,	4		;       - address		[102]
	.OFDEF	X.SIZ4,	4		;       - size			[102]

;XCALL variable types

	.OFINI
	.OFDEF	X.UNF,	2		; binary
	.OFDEF	X.STR,	2		; string
	.OFDEF	X.FLT,	2		; float
	.OFDEF	X.BIN,	2		; unformatted

	X.ARY	=16.

;***********
;*  START  *
;***********

START:	PHDR	-1,0,PH$REE!PH$REU	; program header

;check validity of arguments

CHECK:	CMPW	X.ARGS(A3),#2		; 2 or more arguments supplied?	[101]
	JLO	CNTERR			;   no - error			[101]
	CMPW	X.TYP1(A3),#X.FLT	; arg 1 floating point?
	JNE	TYPERR			;   no - error

	MOVW	X.TYP2(A3),D7		; get 2nd argument type
	ANDW	#^C<X.ARY>,D7		; clear array bit
	CMPW	D7,#X.STR		; arg 2 string?
	JNE	TYPERR			;   no - error

	CMPW	X.ARGS(A3),#3		; are there 3 arguments?
	BLO	10$			;   no
	MOVW	X.TYP3(A3),D7		; get 3rd argument type
	ANDW	#^C<X.ARY>,D7		; clear array bit
	CMPW	D7,#X.STR		; arg 3 string?
	JNE	TYPERR			;   no - error
	MOV	X.ADR3(A3),A4		; set index A4
	CMPW	X.ARGS(A3),#4		; are there 4 arguments?
	BLO	10$			;   no
	MOVW	X.TYP4(A3),D7		; get 4th argument type
	ANDW	#^C<X.ARY>,D7		; clear array bit
	CMPW	D7,#X.STR		; arg 4 string?
	JNE	TYPERR			;   no - error
	MOV	X.ADR4(A3),D2		; set index D2

;index job table, initialize job count, and set index to array

10$:	MOV	JOBTBL,A0		; index jobn table
	CLR	D5			; clear job count
	MOV	X.ADR2(A3),A2		; index return array

;main loop of program

LOOP:	MOV	(A0)+,D7		; get next JCB address
	BEQ	LOOP			; deallocated job
	CMP	D7,#-1			; end of job table?
	JEQ	RETURN			;   yes
	MOV	D7,A6			; 
	INC	D5			; update job count

;check for job at AMOS command level

	MOV	A6,D4			; save JCB address for later
	MOVW	JOBSTS(A6),D6		; get job status
	ANDW	#J.MON,D6		; at AMOS command level?
	BNE	CLRPRG			;   yes - return empty string

;convert program name to ASCII

	LEA	A1,JOBPRG(A6)		; index program name
	UNPACK				; return
	UNPACK				;   program name
	CALL	TRIM			; remove trailing spaces	[101]
	BR	CHKJOB			; 				[101]

;job is at AMOS - clear program name					[101]

CLRPRG:	MOV	#6-1,D6			; 				[101]
10$:	CLRB	(A2)+			; 				[101]
	DBF	D6,10$			; 				[101]

;if a third argument was specified, also return job name

CHKJOB:	CMPW	X.ARGS(A3),#3		; 3rd argument specified?	[101]
	JLO	LOOP			;   no				[101]

;convert job name to ASCII

	SAVE	A2			; save registers		[101]
	MOV	A4,A2			; set-up A2 for UNPACKing	[101]
	MOV	D4,A6			; restore JCB address		[101]
	LEA	A1,JOBNAM(A6)		; index program name		[101]
	UNPACK				; return			[101]
	UNPACK				;   program name		[101]
	CALL	TRIM			; remove trailing spaces	[101]
	MOV	A2,A4			; put back in A4 so we remember	[101]
	REST	A2			; restore registers		[101]

CHKUSN:	CMPW	X.ARGS(A3),#4		; 4th argument specified?	[102]
	JLO	LOOP			;   no				[102]

	SAVE	A2
	MOV	D2,A2			; use A2 as index
; copy user name to array [102]
	MOV	#19.,D0			; get max size of username field
	MOV	X.SIZ4(A3),D1		; get size of array element
	MOV	D4,A6			; index jcb
	LEA	A6,JOBUSN(A6)		; index job user name (null terminated)
20$:	MOVB	(A6)+,D7		; get a byte
	BEQ	40$			;   end of username.
	MOVB	D7,(A2)+		; copy to array
	DEC	D1			; count down element bytes remaining
	BEQ	40$			;   end of element
	SOB	D0,20$			; until whole name scanned or null
40$:	TST	D1			; room for null?
	BEQ	60$			;   no, done
	CLRB	(A2)+			;   yes, append null to terminate string
	DEC	D1			; count while we null & space out
	BR	40$			; and loop till we hit next element
60$:	MOV	A2,D2			; save array ptr for next elemnet
	REST	A2			; end [102]
	JMP	LOOP			; 				[101]

;pass back job count and return to BASIC program

RETURN:	MOV	X.ADR1(A3),A0		; return
	FLTOF	D5,@A0			;   job count
	RTN				; return

;error handling

CNTERR:	TYPESP	?Argument count		; 
	BR	ERROR			; 

TYPERR:	TYPESP	?Argument type		; 

ERROR:	TYPECR	error in PROGS.SBR	; 
	RTN				; 

;**********
;*  TRIM  *
;**********
;remove trailing spaces from 6-character string just output to buffer @A2

TRIM:	MOV	#6,D6			; 
	MOV	A2,A6			; 
5$:	CMPB	-1(A6),#40		; 
	BNE	7$			; 
	CLRB	-(A6)			; 
	SOB	D6,5$			; 
7$:	BR	30$			; 
10$:	MOV	#6,D6			; 
20$:	CLRB	(A2)+			; 
	SOB	D6,20$			; 
30$:	RTN				; 

	END

.