; PROGRAM:	SAVE
; AUTHOR:	Jay Sage
; DATE:		May 19, 1987
; VERSION:	0.4
; DERIVATION:	ZCPR33 resident SAVE command

; SYNTAX:
;	SAVE NUMBER UFN [SECTOR-FLAG]
; where number is a decimal number unless followed by an 'H' (exact character
; defined by the NUMBASE equate below), in which case it is a hesadecimal
; number.  UFN is an unambiguous file specification.  The third field is
; optional.  It allows the number of units to be stored to be interpreted not
; as pages (the default, 256-byte units) but as sectors or records (128-byte
; units).  The SECTCH equate below defines the character used for this switch.
; If SECTCH is defined to be the space character, then any character (and only
; the first character matters) will select sector mode.  Otherwise the
; character must match SECTCH.


; REVISION HISTORY
;
; Version 0.4	Jay Sage	May 19, 1987
; Updated to use Z33LIB routines.  Added version message with load address
; information.

; Version 0.3	Jay Sage	May 15, 1987
; Updated for latest release of Z33, which has a different entry point for
; the reparse routine.
;
; Version 0.2	Jay Sage	May 4, 1987
;
; This is a hastily constructed transient version of the SAVE command from the
; ZCPR33 command processor.  It uses a type-3 environment so that it can be
; loaded at a high address in memory, where one hopes that it will not
; interfere with the memory image to be stored.  The command will work in the
; desired way only when the memory area saved does not include the memory
; occupied by SAVE.COM, or where it does not matter that that part of memory
; has been corrupted.  I recommend linking the program to an address about
; 0.5K below the lowest system address ever used in your system (this is the
; CCP base address if you never use resident system extensions, such as print
; spoolers or XSUB, that install themselves below the CCP).  A value of A000H
; is typical.
;
; This first release is intended primarily as an example of some of the ways
; features of ZCPR33 can be used.  Of particular interest is the use of the
; parser from the command processor.  Many refinements should be added to this
; program before it is considered to be more than an instructional example.
; I would recommend the following at least:
;
;    1.	Replace many of the in-line routines with calls to library
;	functions.  This will make the code more readable and easier to
;	maintain.
;    2.	Add various self-checking features.  For example, a warning should
;	at least be given if the memory area saved includes any part of the
;	SAVE code itself.
;    3. Increase the flexibility of the command.  For example, the command
;	could be made to allow saving blocks of memory from arbitrary starting
;	to arbitrary ending addresses (as in the DSD debugger).
;    4.	The interface to the ZCPR33 error handling facilities should be
;	developed further.
;    5.	Add to the built-in help display showing the syntax allowed.  This
;	screen should adapt automatically to the actual name of the program
;	and to the definitions of SECTCH and NUMBASE.
;
;		Jay Sage, April 28, 1987


;=============================================================================
;
;			D E F I N I T I O N S
;
;=============================================================================

version	equ	04

sectch	equ	' '		; Character used to switch to sector mode (if
				; ..set to ' ', any character will switch)
numbase	equ	'H'		; Character to switch to hexadecimal numbers

ecambig	equ	08		; Error code to return for an ambiguous file
				; ..name specification
ecbadnum equ	09		; Error code to return for a bad number

ecfull	equ	11		; Directory or disk full error

tfcb	equ	005ch
tfcb2	equ	006ch
tail	equ	0080h
tpa	equ	0100h
bdos	equ	0005h
bell	equ	07h
tab	equ	09h
lf	equ	0ah
cr	equ	0dh

	extrn		reparse		; Z33LIB
	extrn		z3init,getwhl	; Z3LIB
	extrn		phl4hc		; SYSLIB

;=============================================================================
;
;			M A I N    C O D E
;
;=============================================================================

entry:
	jp	save
	db	'Z3ENV'
	db	3		; Type-3 environment
z3env:
	dw	0		; ENV address
	dw	entry		; Load address

save:

; Display version message

	call	print
	db	cr,lf
	db	'  SAVE Version '
	db	version/10+'0'
	db	'.'
	db	version mod 10 + '0'
	db	' (loaded at '
	db	0

	ld	hl,entry
	call	phl4hc		; SYSLIB routine to display four hex digits

	call	print
	db	'H)'
	db	cr,lf,0

; Check for help request

	ld	a,(tfcb+1)	; Get first character of first token
	cp	' '
	jr	z,help
	cp	'/'
	jr	z,help
	cp	'?'
	jp	nz,main

; This help screen should be significantly improved.  This is just a quick and
; dirty cut at something.

help:
	call	print
	db	lf
	db	'  Syntax: SAVE number ufn ['

	 if	sectch eq ' '
	db	'S|R'
	 else
	db	sectch
	 endif	;sectch eq ' '

	db	']',cr,lf,lf,tab
	db	'number format: ## for decimal, ##'
	db	numbase
	db	' for hex'
	db	cr,lf,tab
	db	'sector switch: '

	 if	sectch eq ' '
	db	'any character'
	 else
	db	'''',sectch,''''
	 endif	;sectch eq ' '

	db	' in third token switches'
	db	cr,lf,tab,tab
	db	'from page to sector/record mode'
	db	cr,lf,0

	ret

main:
	ld	hl,(z3env)
	call	z3init

	call	getwhl		; Make sure user has wheel status
	jr	nz,main1	; Branch if OK

	call	print
	db	bell,'  Not Wheel',0
	ret

main1:
	ld	(stack),sp	; Save system stack pointer
	ld	sp,stack	; ..and set up a local stack

	call	setcsf		; Set the transient bit in the cmd status flag
	ld	hl,tail+1	; Point to first character in command tail
	call	number		; Extract number from command line
	jp	c,badnumber	; Invoke error handler if bad number
	push	bc		; Save the number
	call	reparse		; Reparse tail after number of sectors/pages
	pop	hl		; Get sector/page count back into HL
	ld	a,(tfcb2+1)	; Check sector flag in second FCB
	cp	sectch

	 if	sectch ne ' '	; If using a specific character, then jump
	jr	z,save0		; ..if it is that character
	 else			; If allowing any character (SECTCH=' ')
	jr	nz,save0	; ..jump if it is anything other than space
	 endif	;sectch ne ' '

	add	hl,hl		; Double page count to get sector count
save0:
	ld	a,1		; Maximum allowed value in H
	cp	h		; Make sure sector count < 512 (64K)
	jp	c,badnumber	; If >511, invoke error handler

	push	hl		; Save sector count
	ld	hl,tfcb
	call	ambchk		; Check for ambiguous file spec (vectors to
				; ..error handler if so)

	call	extest		; Test for existence of file and abort if so
	ld	c,16h		; BDOS make file function
	call	bdostest
	jr	z,save3		; Branch if error in creating file

	pop	bc		; Get sector count into BC
	ld	hl,tpa-128	; Set pointer to one record before TPA

save1:
	ld	a,b		; Check for BC = 0
	or	c
	dec	bc		; Count down on sectors
				; ..B=0ffh if all records written successfully
	jr	z,save2		; If so, save is done so branch

	push	bc		; Save sector count
	ld	de,128		; Advance address by 128 bytes
	add	hl,de
	push	hl		; Save address on stack
	ex	de,hl		; Put address into DE for BDOS call
	call	dmaset		; Set DMA address for write
	ld	de,tfcb		; Write sector
	ld	c,15h		; BDOS write sector function
	call	bdossave
	pop	hl		; Get address back into HL
	pop	bc		; Get sector count back into BC
	jr	Z,save1		; If write successful, go back for more

ld	b,0		; B=0 if write failed

save2:
	call	close		; Close file even if last write failed
	and	b		; Combine close return code with
				; ..write success flag
	jr	nz,save4	; If all writes successful and close OK, branch

save3:				; Disk must be full
	ld	a,ecfull
	jr	error

save4:
	call	rescsf		; Reset the command status flag
	call	print
	db	'  ',0
	ld	hl,tfcb+1
	call	prfn
	call	print
	db	' saved'
	db	0
	jr	done

;-----------------------------------------------------------------------------

; SETCSF -- set the transient program bit in the command status flag.  This
; routine also saves a pointer to the CSF so that it can be reset later as
; needed.

setcsf:
	ld	hl,(z3env)	; Get ENV address
	ld	de,22h		; Offset to MSG buffer
	add	hl,de
	ld	a,(hl)
	inc	hl
	ld	h,(hl)
	ld	l,a		; HL points to MSG buffer
	inc	hl
	inc	hl
	inc	hl		; HL has address of command status flag
	ld	(csfptr),hl	; Save the pointer
	set	3,(hl)		; Set the transient operation bit
	ret

csfptr:	dw	0		; Place to keep pointer

;-----------------------------------------------------------------------------

; RESCSF -- reset the transient program bit in the command status flag.

rescsf:
	ld	hl,(csfptr)
	res	3,(hl)
	ret

;-----------------------------------------------------------------------------

ambchk:
	push	hl		; Save pointer to FCB
	inc	hl		; Point to first character in file name
	ld	a,(hl)		; See if first character is a space
	cp	' '
	ld	a,'?'		; Set up for scan for question mark
	jr	nz,ambchk1	; Skip if first character not a space
	ld	(hl),a		; Substitute '?' for space
ambchk1:
	ld	bc,11		; Scan 11 characters
	cpir
	pop	de		; Restore pointer to FCB in DE
	ret	nz		; Return if no '?' found
	pop	hl		; Pop subroutine return address
	pop	hl		; Pop sector count
	ld	a,ecambig	; Error code for ambiguous file name
	jr	error

badnumber:
	ld	a,ecbadnum	; Error code for bad number value
	jr	error
loaderr:
	ld	a,ecfull
error:
	ld	hl,(csfptr)	; Point to command status flag
	set	1,(hl)		; Set the error bit
	set	2,(hl)		; Set the ECP bit
	dec	hl		; Back up to error code byte
	dec	hl
	dec	hl
	ld	(hl),a		; Save the error code
				; Fall through to RET
done:
	ld	sp,(stack)	; Restore system stack pointer
	ret

;-----------------------------------------------------------------------------

; Get uppercase character from console (with ^S processing).  Registers B,
; D, H, and L are preserved.  The character is returned in A.

conin:
	ld	c,1		; BDOS conin function
	call	bdossave
				; Fall through to UCASE

;-----------------------------------------------------------------------------

; Convert character in A to upper case.  All registers except A are preserved.

ucase:
	and	7fh		; Mask out msb
	cp	61h		; Less than lower-case 'a'?
	ret	c		; If so, return
	cp	7bh		; Greater than lower-case 'z'?
	ret	nc		; If so, return
	and	5fh		; Otherwise capitalize
	ret

;-----------------------------------------------------------------------------

; Output character in A to the console.  All registers are preserved.

conout:
	push	de
	push	bc
	ld	c,2		; BDOS conout function
	ld	e,a
	call	bdossave
	pop	bc
	pop	de
	ret

;----------------------------------------

; Print the character string immediately following the call to this routine.
; The string terminates with a character whose high bit is set or with a null.
; All registers are preserved except A.

print:
	ex	(sp),hl		; Get pointer to string
	call	printhl		; Print string
	ex	(sp),hl		; Restore HL and set return address
	ret

;----------------------------------------

; Print the character string pointed to by HL.  Terminate on character with
; the high bit set or on a null character.  On return HL points to the byte
; after the last character displayed.  All other registers except A are
; preserved.

printhl:
	ld	a,(hl)		; Get a character
	inc	hl		; Point to next byte
	or	a		; End of string null?
	ret	z
	push	af		; Save flags
	and	7fh		; Mask out msb
	call	conout		; Print character
	pop	af		; Get flags
	ret	m		; String terminated by msb set
	jr	printhl

;-----------------------------------------------------------------------------

; Test File in FCB for existence, ask user to delete if so, and abort if he
;  choses not to

extest:
	ld	de,tfcb		; Point to FCB
	push	de		; ..and save it for later
	call	fcblog		; Log into specified directory
	call	srchfst1	; Look for specified file
	pop	de		; Restore pointer
	ret	z		; OK if not found, so return
	call	print
	defb	bell
	defb	'  Erase',' '+80h
	ld	hl,tfcb+1	; Point to file name field
	call	prfn		; Print it
	call	print		; Add question mark
	defb	'?' or 80h
	call	conin		; Get user response
	cp	'Y'		; Test for permission to erase file
	jr	nz,done		; If not, flush the entire command line
	jr	delete		; Delete the file

;-----------------------------------------------------------------------------

; Print file name pointed to by HL


prfn:
	ld	b,8		; Display 8 characters in name
	call	prfn1
	call	print		; Put in dot
	defb	'.' or 80h
	ld	b,3		; Display 3 characters in type
prfn1:
	ld	a,(hl)		; Get character
	inc	hl		; Point to next
	call	conout		; Print character
	djnz	prfn1		; Loop through them all
	ret

;----------------------------------------

; Search for first matching file.  At entry point SRCHFST1 the first default FCB
; is used.  At entry point SRCHFST the FCB pointed to by DE is used.

srchfst1:
	ld	de,tfcb		; Use first default FCB
srchfst:
	ld	c,11h
	jr	bdostest

;--------------------

; Call BDOS for read and write operations.  The flags are set appropriately.
; The BC, DE, and HL registers are preserved.

bdossave:
	push	hl
	push	de
	push	bc
	call	bdos
	pop	bc
	pop	de
	pop	hl
	or	a		; Set flags
	ret

;-----------------------------------------------------------------------------

; Set DMA address.  At the entry point DMASET it is set to the value passed
; in the DE registers.

dmaset:
	ld	c,1ah
	jr	bdossave

;-----------------------------------------------------------------------------

; Log in the drive value passed in the A register (A=0).

setdrive:
	ld	e,a
	ld	c,0eh
	jr	bdossave

;-----------------------------------------------------------------------------

; Open a file.  At entry point OPEN the file whose FCB is pointed to by DE
; is used.

open:
	ld	c,0fh		; BDOS open function
				; Fall through to BDOSTEST

;--------------------

; Invoke BDOS for disk functions.  This routine increments the return code in
; register A so that the zero flag is set if there was an error.  Registers
; BC, DE, and HL are preserved.

bdostest:
	call	bdossave
	inc	a		; Set zero flag for error return
	ret

;-----------------------------------------------------------------------------

; Close file whose FCB is pointed to by DE.

close:
	ld	c,10h
	jr	bdostest

;-----------------------------------------------------------------------------

; Delete file whose FCB is pointed to by DE.

delete:
	ld	c,13h
	jr	bdossave

;-----------------------------------------------------------------------------

; Get and set user number.  Registers B, D, H, and L are preserved.  Register
; E is also preserved at entry point SETUSER1.

getuser:
	ld	a,0ffh		; Get current user number
setuser:
	ld	e,a		; User number in E
setuser1:
	ld	c,20h		; Get/Set BDOS function
	jr	bdossave

;-----------------------------------------------------------------------------

; The routine NUMBER evaluates a string in the first FCB as either a decimal
; or, if terminated with the NUMBASE hexadecimal marker, a HEX number.  If the
; conversion is successful, the value is returned as a 16-bit quantity in BC.
; If the number is less than 256, then the zero flag is set.  If an invalid
; character is encountered in the string, the routine returns with the carry
; flag set and HL pointing to the offending character.

number:
	ld	hl,tfcb+1	; Set pointer to beginning of number string
	ld	bc,8		; Number of characters to scan
	add	hl,bc		; Point to end of character string
	dec	hl
	ld	a,numbase	; Scan for HEX identifier
	cpdr			; Do the search
	jr	nz,decimal	; Branch if HEX identifier not found

	inc	hl		; Point to HEX marker
	ld	(hl),' '	; Replace HEX marker with valid terminator
				; ..and fall through to HEXNUM

;----------------------------------------

; At this entry point the character string in the first default FCB is
; converted as a hexadecimal number (there must NOT be a HEX marker).

hexnum:
	ld	hl,tfcb+1	; Point to string in first FCB

; At this entry point the character string pointed to by HL is converted
; as a hexadecimal number (there must be NO HEX marker at the end).

hexnum1:
	ld	de,16		; HEX radix base
	jr	radbin		; Invoke the generalized conversion routine

;----------------------------------------

; This entry point performs decimal conversion of the string in the first
; default FCB.

decimal:
	ld	hl,tfcb+1	; Set pointer to number string

; This entry point performs decimal conversion of the string pointed to
; by HL.

decimal1:
	ld	de,10		; Decimal radix base
				; Fall through to generalized
				; ..radix conversion routine

; This routine converts the string pointed to by the entry on the top of
; the stack using the radix passed in DE.  If the conversion is successful,
; the value is returned in BC.  HL points to the character that terminated
; the number, and A contains that character.  If an invalid character is
; encountered, the routine returns with the carry flag set and nonzero, and
; HL points to the offending character.

radbin:
	ld	bc,0		; Initialize result
radbin1:
	or	a		; Make sure carry is reset
	call	sdelm		; Test for delimiter (returns Z if delimiter)
	ret	z		; Return if delimiter encountered

	sub	'0'		; See if less than '0'
	ret	c		; Return with carry set if so
	cp	10		; See if in range '0'..'9'
	jr	c,radbin2	; Branch if it is valid
	cp	'A'-'0'		; Bad character if < 'A'
	ret	c		; ..so we return with carry set
	sub	7		; Convert to range 10..15
radbin2:
	cp	e		; Compare to radix in E
	ccf			; Carry should be set; this will clear it
	ret	c		; If carry now set, we have an error

	inc	hl		; Point to next character
	push	bc		; Push the result we are forming onto the stack
	ex	(sp),hl		; Now HL=result, (sp)=source pointer
	call	mpy16		; HLBC = previous$result * radix
	ld	h,0		; Discard high 16 bits and
	ld	l,a		; ..move current digit into HL
	add	hl,bc		; Form new result
	ld	c,l		; Move it into BC
	ld	b,h
	pop	hl		; Get string pointer back
	jr	radbin1		; Loop until delimiter

;-----------------------------------------------------------------------------

; This routine multiplies the 16-bit values in DE and HL and returns the
; 32-bit result in HLBC (HL has high 16 bits; BC has low 16 bits).  Register
; pair AF is preserved.

mpy16:
	ex	af,af'		; Save AF
	ld	a,h		; Transfer factor in HL to A and C
	ld	c,l
	ld	hl,0		; Initialize product
	ld	b,16		; Set bit counter
	rra			; Shift AC right so first multiplier bit
	rr	c		; ..is in carry flag
mp161:
	jr	nc,mp162 	; If carry not set, skip the addition
	add	hl,de		; Add multiplicand
mp162:
	rr	h		; Rotate HL right, low bit into carry
	rr	l
	rra			; Continue rotating through AC, with
	rr	c		; ..next multiplier bit moving into carry
	djnz	mp161		; Loop through 16 bits

	ld	b,a		; Move A to B so result is in HLBC
	ex	af,af'		; Restore original AF registers
	ret

;-----------------------------------------------------------------------------

; This routine checks for a delimiter character pointed to by HL.  It returns
; with the character in A and the zero flag set if it is a delimiter.  All
; registers are preserved except A.

sdelm:
	ld	a,(hl)		; Get the character
	exx			; Use alternate register set (shorter code)
	ld	hl,deldat	; Point to delimiter list
	ld	bc,delend-deldat; Length of delimiter list
	cpir			; Scan for match
	exx			; Restore registers
	ret			; Returns Z if delimiter

deldat:				; List of delimiter characters
	db	' '
	db	'='
	db	'_'
	db	'.'
	db	':'
	db	';'
	db	'<'
	db	'>'
	db	','
	db	0
delend:

;-----------------------------------------------------------------------------

; Log into DU contained in FCB pointed to by DE.  Registers DE are preserved;
; all others are changed.

fcblog:
	push	de		; Save pointer to FCB
	ex	de,hl
	ld	a,(hl)		; Get drive
	ld	bc,13		; Offset to S1 field
	add	hl,bc
	ld	c,(hl)		; Get user into C
	ld	b,a		; Get drive into B
	ld	(tempusr),bc	; Set up temporary DU values
	call	logtemp		; ..and log into it
	pop	de		; Restore pointer to FCB
	ret

tempusr:
	ds	2

;-----------------------------------------------------------------------------

; Log into the temporary directory.  Registers B, H, and L are preserved.

logtemp:
	ld	de,(tempusr)	; Set D = tempdr, E = tempusr
	call	setuser1	; Register D is preserved during this call
	ld	a,d		; Log in drive
	or	a		; Is TEMPDR the current drive (0)?
	jr	nz,logtemp1	; If not, branch
	ld	a,(4)		; Else substitute the current drive
	and	0fh
	inc	a		; Add 1 for following decrement
logtemp1:
	dec	a		; Adjust for drive range 0..15
	jp	setdrive	; Log in new drive and return

	dseg

	defs	40		; Room for 20-element stack
stack:	defs	2		; Place to keep system stack address

	end