OBJNAM PHDR.SBR ; Created 26-Oct-85, Last modified 28-Oct-85
; Subroutine to return BASIC program's name and version
; by Irv Bromberg, Medic/OS Consultants, Toronto, CANADA
RADIX 10
VEDIT=5
VMINOR=3
VMAJOR=1

IF EQ,1

Calling syntax: XCALL PHDR {,PRGNAM{,Version}}

where PRGNAM is a string variable and Version is an optional string
variable long enough to hold the unpacked version number (excess will be
truncated).  If no parameters are passed the program header will be
output to the user's screen in the format: PRGNAM 1.0A(10) When the
program name has a .RUN extension the extension will not be returned but
when it is other than .RUN it will be returned. The returned program
name is the file name of the compiled program, which may not be the same
as the program name that was declared in the PROGRAM statement (the
COMPIL program ignores the program name following the PROGRAM keyword,
so PHDR.SBR is unable to find out what that name was and therefore has
to use the program's file name instead).

Note that if PHDR is called from Interactive BASIC it cannot determine
the appropriate program header so a dummy header, "PRGNAM A.BC(D)" will
be returned.

ENDC

SEARCH SYS
SEARCH SYSSYM

Impure=A0
PRGBAS=A0
Rad50=A1
AscBuf=A2
ArgBas=A3
String=A4

Pcount=D0
Char=D1
Number=D1
Size=D2

IMPSIZ=30
SPACE=32

	PHDR	-1,0,PH$REE!PH$REU

	MOVW	@ArgBas,Pcount		; get parameter count
	SUB	#IMPSIZ,SP		; get some workspace from user stack
	MOV	SP,AscBuf
	TST	@Impure			; in compiled BASIC?
	BEQ	5$
	LEA	AscBuf,Dummy		; yes, just show dummy PHDR
	JMP	Any
5$:	LEA	Rad50,448(Impure) 	; point to the program name
	UNPACK				; convert packed program name to ASCII
	UNPACK
10$:	CMPB	-(AscBuf),#SPACE	; strip trailing blanks
	BEQ	10$
	INC	AscBuf			; undo last pre-decrement
	CMPW	(Rad50),#[RUN]		; do we have .RUN extension?
	BEQ	15$
	MOVB	#'.,(AscBuf)+		; no, add "." before ext unpacked
	UNPACK				; unpack the extension
13$:	CMPB	-(AscBuf),#SPACE	; strip trailing blanks again
	BEQ	13$			; (needed if ext <3 characters)
	INC	AscBuf
15$:	MOVB	#SPACE,(AscBuf)+	; insert single space separator
	MOV	462(Impure),PRGBAS	; point to .RUN file program base
	CLR	Number			; pre-clear for byte move
	MOVB	3(PRGBAS),Number	; get VMAJOR
	DCVT	0,OT$MEM		; output it to workspace
	MOVB	#'.,(AscBuf)+		; always need "." separator
	MOVB	2(PRGBAS),Number	; get VMINOR
	DCVT	0,OT$MEM
	MOVB	5(PRGBAS),Number	; get VSUB*16+VWHO
	LSRB	Number,#4		; shift down VSUB nibble
	BEQ	20$			; no VSUB
	ADDB	#64,Char		; convert VSUB value to capital letter
	MOVB	Char,(AscBuf)+
20$:	MOVB	4(PRGBAS),Number	; get VEDIT
	BEQ	30$			; no VEDIT
	MOVB	#'(,(AscBuf)+
	DCVT	0,OT$MEM		; output VEDIT value
	MOVB	#'),(AscBuf)+
30$:	CLRB	(AscBuf)		; terminate with NULL
	MOV	SP,AscBuf		; reset pointer
	
Any:	TSTW	Pcount			; any parameters passed?
	BNE	40$
35$:	TTYL	@AscBuf			; no, send PRGNAM and version to
	BR	Done			; user's screen
40$:	MOV	4(ArgBas),String	; get program name string address
	MOV	8(ArgBas),Size		; get program name string size
	BCALL	PreClr			; pre-clear the string
	BR	MovNam			; enter at end of DBF loop
NamLoop:MOVB	(AscBuf)+,Char		; terminate on SPACE separater
	CMPB	Char,#SPACE
	BEQ	Version
	MOVB	Char,(String)+
MovNam:	DBF	Size,NamLoop		; truncate excess

Version:CMPW	Pcount,#2		; 2nd parameter passed for version?
	BLO	Done
	MOV	14(ArgBas),String 	; get version string address
	MOV	18(ArgBas),Size
	BCALL	PreClr			; pre-clear the string
	BR	MovVer
VerLoop:MOVB	(AscBuf)+,Char		; terminate on NULL terminator
	BEQ	Done
	MOVB	Char,(String)+
MovVer:	DBF	Size,VerLoop		; truncate excess

Done:	ADD	#IMPSIZ,SP		; return the workspace
	RTN

PreClr:	; pre-clear passed string
	SAVE	A4,D2
	BR	20$
10$:	CLRB	(String)+
20$:	DBF	Size,10$
	REST	A4,D2
	RTN

Dummy:	ASCIZ	"PRGNAM A.BC(D)" ; dummy program header for Interactive BASIC
	EVEN

	END

.