A2osX/ProDOS.FX/ProDOS.S.XDOS.E.txt

NEW
  AUTO 3,1
*--------------------------------------
XDOS.Close		ldy #$01				close all ?
				lda (ZP.A3L),y
				bne XDOS.CloseOne	  	no, just one of them.

				sta cferr			 	clear global close error.
*				lda #$00				start at the beginning.

L4654  			sta fcbptr			 	save current low byte of pointer.
				tax		 				get the level at which the file
				lda XDOS.FCBs+FCB.FLEVEL,x	was opened.
				cmp GP.FLEVEL		 	if file's level is < global level
				bcc L4675			 	then don't close.

				lda XDOS.FCBs+FCB.ID,x		is this reference file open ?
				beq L4675			  	no, try next.

				jsr flush2				clean it out...
				bcs L46B6			  	return flush errors.

				jsr close2				update fcb & vcb

				ldy #$01
				lda (ZP.A3L),y
				beq L4675			  	no error if close all.

				bcs L46B6			  	close error.

L4675  			lda fcbptr			 	inc pointer to next fcb
				clc
				adc #FCB
				bcc L4654			  	branch if within same page.

				lda cferr			  	on final close report logged errors.
				beq L46B4			  	branch if errors.

				rts		 				(carry already set).
*--------------------------------------
XDOS.CloseOne	jsr flush1				flush file 1st (including updating bitmap)
*				bcs L46B6			  	branch if errors.

				bcc close2

				php
				pha
				jsr close2
				pla
				plp
				rts

close2			ldx fcbptr
				lda XDOS.FCBs+FCB.BUFID,x	release file buffer
				jsr relbuffr
				bcs L46B6

				jsr XDOS.FCBDevIDSelect

				stz XDOS.FCBs,x				free fcb too

				jsr XDOS.FindVCBForDevNum	get vcb pointer.

				dec XDOS.VCBs+VCB.OFCNT,x	indicate one less file open.

L46B4			clc
				rts

L46B6  			bcs L46E6			  	don't report close all error now.
*--------------------------------------
XDOS.Flush		ldy #$01				flush all ?
				lda (ZP.A3L),y
				bne flush1				no, just one of them.

				sta cferr			  	clear global flush error.
*				lda #$00				start at the beginning.

L46C3  			sta fcbptr				save current low byte of pointer.
				tax		 				index to ref #.
				lda XDOS.FCBs,x				is this reference file open ?
				beq L46D1			  	no, try next.

				jsr flush2			 	clean it out...
				bcs L46E6			  	return anty errors.

L46D1  			lda fcbptr			 	inc pointer to next fcb.
				clc
				adc #FCB
				bcc L46C3			  	branch if within same page

L46D9  			clc
				lda cferr			  	on last flush,
				beq L46E0			  	branch if no logged errors.

				sec		 				report error now
L46E0  			rts
*--------------------------------------
flush2			jsr XDOS.GetFCBBufX		must set up vcb & buffer locations 1st.
				bcc L46F1			  	branch if no error.

L46E6  			jmp glberr				error so check for close or flush all.

flush1			stz cferr				for normal refnum flush, clear global error.
				jsr XDOS.GetFCB			setup pointer to fcb user references.
				bcs L46E6			  	return any errors.

L46F1  			lda XDOS.FCBs+FCB.ACCESS,x	test to see if file is modified.
				and #$02			 	is it write enabled ?
				beq L46D9			  	branch if 'read only'

				lda XDOS.FCBs+FCB.DIRTY,x	has eof been modified ?
				bmi L4704			  	if yes.

				jsr XDOS.GetFCBStatus	has data been modified ?
				and #$70			 	(was written to while it's been open?)
				beq L46D9			  	if not.

L4704  			jsr XDOS.GetFCBStatus
				and #$40			 	does current data buffer need to be
				beq L4710			  	written ? branch if not.

				jsr wfcbdat				if so, go write it.
				bcs L46E6			  	if error.

L4710  			jsr XDOS.GetFCBStatus	check to see if the index block (tree
				and #$80			 	files only) needs to be written.
				beq L471C			  	branch if not.

				jsr wfcbidx
				bcs L46E6			  	return any errors.

L471C  			ldy #0

				jsr XDOS.FCBDevIDSelect	X = FCBPtr

L4723  			lda XDOS.FCBs+FCB.DEVID,x	note: this code depends on the defined
				sta d_dev,y				order of the file control block and the
				inx		 				temporary directory area in 'work space'
				iny
				cpy #6
				bne L4723

				lda d_head				read the directory header for this file
				ldx d_head+1
				.DO LOWERCASE=1
				jsr XDOS.ReadGBufAXDir
				.ELSE
				jsr XDOS.ReadGBufAX	  	read DIR into the general purpose buffer.
				.FIN
				bcs L46E6			  	if error.

				jsr movhed0				move header info.
				lda d_entblk			get address of directory block that
				ldx d_entblk+1			contains the file entry.
				cmp d_head			 	test to see if it's the same block the
				bne .1				  	header is in. branch if not.

				cpx d_head+1
				beq L4755			  	branch if header block = entry block

.1  			.DO LOWERCASE=1
				jsr XDOS.ReadGBufAXDir
				.ELSE
				jsr XDOS.ReadGBufAX	 	read DIR block with file entry in general buffer.
				.FIN

L4755  			jsr entcalc				set up pointer to entry.

				jsr moventry			move entry to temp entry buffer in

				ldx fcbptr			 	'work space'. update 'blocks used' count
				lda XDOS.FCBs+FCB.UBLK,x
				sta d_usage
				lda XDOS.FCBs+FCB.UBLK+1,x
				sta d_usage+1

				ldy #0				 	and move in end of file mark whether

L476C  			lda XDOS.FCBs+FCB.EOF,x	   	needed or not.
				sta d_eof,y
				iny
				cpy #$03			 	move all 3 bytes
				beq L4780

				lda XDOS.FCBs+FCB.1stBLK,x	also move in the address of the file's
				sta d_filid,y			first block since it might have changed
				inx		 				since the file first opened.
				bne L476C			  	branch always.

L4780  			ldx fcbptr
				lda XDOS.FCBs+FCB.STYPE,x	the last thing to update is storage
				asl			  			type (y=fcbptr+2). shift into high
				asl			  			nibble.
				asl
				asl
				sta scrtch
				lda d_stor				get old type byte (might be the same).
				and #$0F			 	strip off old type,
				ora scrtch			 	add in the new type
				sta d_stor			 	and put it away.
				jsr drevise				go update directory.
				bcs glberr			  	error.

				ldx fcbptr			 	mark
				stz XDOS.FCBs+FCB.DIRTY,x	fcb/directory as undirty.

				lda d_dev			  	see if bitmap should be written.
				cmp bmadev			 	is it in same as current file ?
				bne L47B2			  	yes, put it on the disk if necessary.

				jsr upbmap			 	go put it away.
				bcs glberr			  	flush error

L47B2  			clc
				rts
*--------------------------------------
* report error only if not a close all or flush all
*--------------------------------------
glberr			ldy #$01
				pha
				lda (ZP.A3L),y
				bne L47C1				not an 'all' so report now

				clc
				pla
				sta cferr			  	save for later

				rts

L47C1  			pla
				rts
*--------------------------------------
XDOS.FCBDevIDSelect
				ldx fcbptr
				lda XDOS.FCBs+FCB.DEVID,x
				sta GP.DEVNUM
				rts
*--------------------------------------
XDOS.SetFCBSType
				lsr
				lsr
				lsr
				lsr
				ldy fcbptr			 	and save it in fcb.
				sta XDOS.FCBs+FCB.STYPE,y
				rts
*--------------------------------------
XDOS.ClrFCBStatus
				ldy fcbptr			 	clear allocation states for data block
				lda XDOS.FCBs+FCB.F,y		and both levels of indexes/
				and #$F8
				sta XDOS.FCBs+FCB.F,y		indicates that either they exist now
				rts						or unnecessary for current position.
*--------------------------------------
XDOS.GetFCBStatus
				ldx fcbptr			 	index to fcb.
				lda XDOS.FCBs+FCB.F,x		return status byte.
				rts
*--------------------------------------
XDOS.SetFCBStatus
				ldx fcbptr
				ora XDOS.FCBs+FCB.F,x
				sta XDOS.FCBs+FCB.F,x
				rts
*--------------------------------------
L47CA  			lda #MLI.E.LOCKED	 	access error
				sec
L47CD  			rts
*--------------------------------------
XDOS.SetEOF		jsr gfcbstyp			can only move end of tree, sapling or seed.
				cmp #$04			 	tree type ?
				bcs L47CA			  	if not then access error

				asl
				asl
				asl
				asl
				sta stortyp				may be used later.
				lda XDOS.FCBs+FCB.ACCESS,y
				and #$02			 	is write enabled to set new eof ?
				beq L47CA			  	no, access error.

				jsr tstwprot			hardware write protected ?
				bcs L47CA			  	yes, access error.

				ldy fcbptr			 	save old eof so it can be seen
				iny		 				whether blocks need to be released
				iny		 				upon contraction.
				ldx #$02			 	all 3 bytes of the eof

L47EF  			lda XDOS.FCBs+FCB.EOF,y
				sta oldeof,x
				dey
				dex
				bpl L47EF

				ldy #$04
				ldx #$02

L47FD  			lda (ZP.A3L),y				position mark to new eof
				sta tposll,x
				dey
				dex
				bpl L47FD

				ldx #$02			 	point to 3rd byte.

L4808  			lda oldeof,x			see if eof moved backwards so blocks
				cmp tposll,x			can be released.
				bcc eofset				(branch if not)
				bne purge			  	branch if blocks to be released

				dex
				bpl L4808			  	all 3 bytes

eofset			ldy #$04
				ldx fcbptr				place new end of file into fcb
				inx
				inx

L481C  			lda (ZP.A3L),y
				sta XDOS.FCBs+FCB.EOF,x
				dex
				dey
				cpy #$02			 	all 3 bytes moved ?
				bcs L481C			  	no.

				jmp fcbused				mark fcb as dirty.

purge  			jsr flush1			 	make sure file is current
				bcs L47CD

				ldx datptr+1			pointer to index block
				inx
				inx
				stx zpt+1			  	(zero page conflict with dir buf ptr)
				ldx datptr
				stx zpt
				ldy fcbptr			 	check if eof < mark
				iny
				iny
				ldx #$02

L4840  			lda XDOS.FCBs+FCB.MARK,y
				cmp tposll,x			compare until not equal or carry clear.
				bcc L485F			  	branch if eof > mark.

				bne L484E			  	branch if eof < mark.

				dey
				dex
				bpl L4840			  	compare all 3 bytes

L484E  			ldy fcbptr
				ldx #$00

L4853  			lda tposll,x			fake position, correct position will
				sta XDOS.FCBs+FCB.MARK,y		be made below...
				iny
				inx
				cpx #$03			 	move all 3 bytes
				bne L4853

L485F  			jsr tkfrecnt			force free block count before releasing
				lda tposll			 	blocks. prepare for purge of excess...
				sta dseed			  	all blocks and bytes beyond new eof
				lda tposlh				 must be zero'd
				sta dsap
				and #$01
				sta dseed+1
				lda tposhi
				lsr
				sta dtree
				ror dsap			 	pass position in terms of block & bytes.
				lda dseed				now adjust for boundaries of $200
				ora dseed+1
				bne L48A2			  	branch if no adjustment necessary.

				lda dsap			 	get correct block positions for sap
				sec		 				and tree levels.
				sbc #$01
				sta dsap			 	deallocate for last (phantom) block

				lda #$02			 	and don't modify last data block.
				bcs L489F			  	branch if tree level unaffected.

				dec dtree
				bpl L489F			  	branch if new eof not zero

				lda #$00
				sta dtree			 	otherwise, make a null seed out of it.
				sta dsap

L489F  			sta dseed+1
L48A2  			ldy fcbptr			 	also must pass file's 1st block address.
				lda XDOS.FCBs+FCB.1stBLK,y
				sta firstbl
				lda XDOS.FCBs+FCB.1stBLK+1,y
				sta firstbh
				stz deblock				lastly, initialize # of blocks to
				stz deblock+1			be free'd.
				jsr detree				deallocate blocks from tree.
				php		 				save any error status until fcb
				pha		 				is cleaned up.

				sec
				ldy fcbptr
				ldx #$00

L48C2  			lda firstbl,x
				sta XDOS.FCBs+FCB.1stBLK,y	move in possible new first file block
				lda XDOS.FCBs+FCB.UBLK,y		address. adjust usage count also
				sbc deblock,x
				sta XDOS.FCBs+FCB.UBLK,y
				iny
				inx
				txa
				and #$01			 	test for both bytes adjusted
				bne L48C2			  	without disturbing carry.

				lda stortyp				get possibly modified storage type
				jsr XDOS.SetFCBSType

				jsr XDOS.ClrFCBStatus	make it look as though position has
				jsr dvcbrev				nothing allocated, update total blocks
				ldy fcbptr			 	in fcb and correct position.
				iny
				iny

				ldx #$02

L48F2  			lda XDOS.FCBs+FCB.MARK,y		tell 'rdposn' to go to correct
				sta tposll,x
				eor #$80			 	position from incorrect place.
				sta XDOS.FCBs+FCB.MARK,y
				dey
				dex
				bpl L48F2

				jsr rdposn			 	go to correct position.

				bcc L490D			  	if no error.
				tax		 				otherwise, report latest error.
				pla
				plp
				txa		 				restore latest error code to stack
				sec
				php
				pha		 				save new error.

* mark file as in need of a flush and update fcb with new end of file,
* then flush it.

L490D  			jsr eofset				go mark and update
				jsr flush1				then go do the flush.
				bcc L491C			  	branch if no error.

				tax		 				save latest error.
				pla		 				clean previous error off stack
				plp
				txa		 				and restore latest error to stack.
				sec		 				show error condition.
				php		 				restore error status to stack
				pha		 				and the error code.
L491C  			pla		 				report any errors that may have
				plp		 				appeared.
				rts
*--------------------------------------
XDOS.GetEOF		ldx fcbptr				index to end of file mark

				ldy #$02			 	and index to user's call parameters

L4924  			lda XDOS.FCBs+FCB.EOF,x
				sta (ZP.A3L),y
				inx
				iny
				cpy #$05
				bne L4924			  	loop until all 3 bytes moved

				clc		 				no errors
				rts
*--------------------------------------
XDOS.NewLine	ldy #$02				adjust newline status for open file.

				lda (ZP.A3L),y				on or off ?
				ldx fcbptr			 	it will be 0 if off.
				sta XDOS.FCBs+FCB.NLMASK,x	set new line mask

				iny
				lda (ZP.A3L),y				and move in 'new-line' byte
				sta XDOS.FCBs+FCB.NLBYTE,x

				clc		 				no error possible
				rts
*--------------------------------------
XDOS.GetFileInfo
				jsr XDOS.FindFile		look for file.
				bcc .1				  	no error.

				jsr XDOS.GetFileInfoVol
				bcs .9

.1	  			lda d_stor			 	transfer bytes from internal order to
				lsr			  			call spec via 'inftabl' translation
				lsr			  			table but first change storage type to
				lsr			  			external (low nibble) format.
				lsr
				sta d_stor

				ldy #$11			 	index to last of user's spec table.

.2  			lda inftabl-3,y
				and #$7F			 	strip bit used by setinfo
				tax
				lda d_stor,x			move directory info to call spec. table
				sta (ZP.A3L),y
				dey
				cpy #$03
				bcs .2			  	if all info bytes moved, retn carry clr

*				clc

.9  			rts
*--------------------------------------
XDOS.SetFileInfo
				jsr XDOS.FindFile		get the file to work on.
				bcs L49CF			  	if error.

				lda GP.BUBIT		  	see if backup bit can be cleared
				eor #$20
				and d_attr
				and #$20
				sta bkbitflg			or preserve current...

				ldy #$0D			 	init pointer to user supplied list.

L49B9  			ldx inftabl-3,y		   	get index to corresponding 'd.' table.
				bmi L49C3			  	branch if parameter can't be set.

				lda (ZP.A3L),y
				sta d_stor,x

L49C3  			dey		 				has user's request been satisfied ?
				cpy #$03
				bcs L49B9			  	no, move next byte.

				and #$18				make sure no illegal access bits were
				beq L49D0			  	set !! branch if legal access.

				lda #MLI.E.LOCKED	 	otherwise, access error.
				sec
L49CF  			rts

L49D0  			ldy #$0B
				lda (ZP.A3L),y				was clock null input ?
				bne XDOS.SetFileInfoEx.8

				jmp drevise				update with clock also...
*--------------------------------------
XDOS.SetFileInfoEx
				jsr XDOS.FindFile
				bcs XDOS.GetFileInfoEx.RTS

				ldx #S.FIEX.BLKPTR+2-1
				ldy #S.FIEX.BLKPTR+2-1+3

.2				lda (ZP.A3L),y
				sta d_stor,x
				dey
				dex
				bpl .2
XDOS.SetFileInfoEx.8
				jmp drevise1
*--------------------------------------
XDOS.GetFileInfoEx
				jsr XDOS.FindFile
				bcc .1

				jsr XDOS.GetFileInfoVol
				bcs .9

.1				ldx #S.FIEX.BLKPTR+2-1
				ldy #S.FIEX.BLKPTR+2-1+3

.2				lda d_stor,x
				sta (ZP.A3L),y
				dey
				dex
				bpl .2

				ldx #7
				ldy #S.FIEX.ACL+7+3

.3				lda h_acl,x
				sta (ZP.A3L),y
				dey
				dex
				bpl .3

*				clc
.9				
XDOS.GetFileInfoEx.RTS
				rts
*--------------------------------------
XDOS.GetFileInfoVol
				cmp #MLI.E.INVPATH	 	was it a root directory file ?
				sec		 				(in case of no match)
				bne .9				  	if not, then error.

				lda #$F0
				sta d_stor			 	for get info, report proper storage type

				stz reql			 	force a count of free blocks.
				stz reqh

				ldx XDOS.VCBPtr
				jsr tkfrecnt			get a fresh count of free blocks on

				ldx XDOS.VCBPtr			 	this volume.
				lda XDOS.VCBs+VCB.FBLK+1,x	return total blocks and total in use.
				sta reqh			 	1st transfer 'free' blocks to zpage
				lda XDOS.VCBs+VCB.FBLK,x		for later subtraction to determine
				sta reql			 	the 'used' count.

				lda XDOS.VCBs+VCB.TBLK+1,x	transfer to 'd.' table as aux id
				sta d_auxid+1			(total block count is considered aux id
				pha		  				for the volume)
				lda XDOS.VCBs+VCB.TBLK,x
				sta d_auxid
				sec		 				subtract and report the number of
				sbc reql			 	blocks 'in use'
				sta d_usage
				pla
				sbc reqh
				sta d_usage+1

				clc

.9				rts
*--------------------------------------
XDOS.ACL		jsr XDOS.FindDirOrVol
				bcs .9

				jsr XDOS.ReadGBuf_d_frst
				bcs .9

				ldx #7

				ldy #S.FIEX.ACL+3
				lda (ZP.A3L),y
				beq .2

				ldy #S.FIEX.ACL+7+3

.1				lda (ZP.A3L),y
				sta XDOS.GBuf+$14,x
				dey
				dex
				bpl .1

				.DO LOWERCASE=1
				jmp XDOS.WriteGBufDir
				.ELSE
				jmp XDOS.WriteGBuf
				.FIN

.2				ldy #S.FIEX.ACL+7+3

.3				lda XDOS.GBuf+$14,x
				sta (ZP.A3L),y
				dey
				dex
				bpl .3

*				clc
.9				rts
*--------------------------------------
XDOS.Rename		jsr XDOS.CheckPath		look for source (original) file.
				bcc XDOS.RenameFileDir 	if found.

				cmp #$40			 	trying to rename a volume ?
				bne L49FD			  	no, return error.

XDOS.RenameVol	jsr XDOS.GetRenPath		syntax new name.
				bcs L49FD			  	rename error.

				ldy XDOS.PathBuf				find out if only rootname for new name
				iny
				lda XDOS.PathBuf,y			must be $FF if volume name only.
				bne L4A72			  	if not single name

				ldx XDOS.VCBPtr			 	check for open files before changing.
				lda XDOS.VCBs+VCB.OFCNT,x
				beq L49FF			  	if volume not busy.

				lda #MLI.E.OPEN		 	file busy error.
L49FD  			sec
				rts

L49FF  			ldy #0				 	get newname's length
				lda XDOS.PathBuf,y
				ora #$F0			 	(root file storage type)
				jsr XDOS.UpdateHdr		update root directory.
				bcs .9			  		rename error.

				ldy #$00
				ldx XDOS.VCBPtr			 	update vcb also.

.1  			lda XDOS.PathBuf,y			move new name to vcb.
				beq .8

				sta XDOS.VCBs,x
				iny		 				next character
				inx
				bra .1
.8
*	  			clc		 				no errors
.9				rts
*--------------------------------------
XDOS.RenameFileDir
				jsr getnamptr			set y = 1st char of path, x = 0.

L4A21  			lda XDOS.PathBuf,y		   	move original name to XDOS.GBuf
				sta XDOS.GBuf,x			 	for later comparison to new name.
				bmi L4A2D			  	if last character has been moved

				iny		 				otherwise, get the next one.
				inx
				bra L4A21

L4A2D  			jsr XDOS.GetRenPath		get new name syntaxed.
				bcs L4A74			  	rename error.

				jsr getnamptr		   	set y = path, x = 0.

				lda XDOS.PathBuf,y			now compare new name with old name

L4A38  			cmp XDOS.GBuf,x			 	to make sure they are in the same dir.
				php		 				save result of comparison.
				and #$F0			 	was last char really a count ?
				bne L4A46			  	if not.

				sty rnptr			  	save pointer to next name, it might
				stx namptr				be the last.

L4A46  			plp		 				result of last comparison ?
				bne L4A52			  	branch if different character or count.

				inx		 				bump pointers.
				iny
				lda XDOS.PathBuf,y			was it the last character ?
				bne L4A38			  	if not.

				clc		 				no operation, names were the same.
				rts

L4A52  			ldy rnptr			  	index to last name in the chain.
				lda XDOS.PathBuf,y			get last name length.
				sec
				adc rnptr
				tay
				lda XDOS.PathBuf,y			this byte should be $00 !
				bne L4A72			  	if not, bad path error.

				ldx namptr			 	index to last of original name
				lda XDOS.GBuf,x
				sec
				adc namptr
				tax
				lda XDOS.GBuf,x			 	this byte should also be $00.
				beq L4A76			  	if so, continue processing.

L4A72  			lda #MLI.E.INVPATH	 	bad pathname error.
L4A74  			sec
				rts

L4A76  			jsr XDOS.CheckPath		test for duplicate file name.
				bcs L4A7F			  	branch if file not found, which is ok !!

				lda #MLI.E.DUPFILE	 	duplicate name error.
				sec
				rts

L4A7F  			cmp #MLI.E.FNOTFND	 	was it a valid file not found ?
				bne L4A74			  	no, rename error.

				jsr XDOS.GetPath		syntax pathname of file to be changed.
				jsr XDOS.FindFile		get all the info on this file.
				bcs L4A74			  	rename error.

				jsr tstopen				is file in use ?
				lda #MLI.E.OPEN		 	anticipate file busy error.
				bcs L4A74			  	error if in use.

				lda d_attr			 	test bit which allows rename.
				and #$40
				bne L4A9D			  	branch if ok to rename

				lda #MLI.E.LOCKED	 	otherwise, illegal access.
				.HS 2C					BIT ABS
L4A98			lda #MLI.E.INCFF
L4A9B  			sec
				rts

L4A9D  			lda d_stor				find out which storage type.
				and #$F0			 	strip off name length.
				cmp #$D0			 	is it a directory ?
				beq L4AAE			  	then ok.

				cmp #$40			 	is it a seed, sapling or tree ?
				bcs	L4A98			 	file incompatible error.

L4AAE  			jsr XDOS.GetRenPath		since both names go into the directory,
				bcs L4A74			  	syntax the new name to get the local

				ldy rnptr			  	name address. y = index to local name
				ldx XDOS.PathBuf,y			length. adj y to last char of new name.
				tya
				adc XDOS.PathBuf,y
				tay

L4ABE  			lda XDOS.PathBuf,y			move local name to dir entry workspace.
				sta d_stor,x
				dey
				dex
				bne L4ABE

				lda d_stor			 	preserve file storage type.
				and #$F0			 	strip off old name length.
				tax
				ora XDOS.PathBuf,y			add in new name's length.
				sta d_stor
				cpx #$D0			 	that file must be changed also.
				bne L4AF0			  	branch if not directory type.

				jsr XDOS.ReadGBuf_d_frst
				bcs L4A74			  	errors.

				ldy rnptr			  	change the header's name to match the
				lda XDOS.PathBuf,y			owner's new name. get local name length.
				ora #$E0				assume it's a header.
				jsr XDOS.UpdateHdr
				bcs L4A74

L4AF0  			jmp drevise1			end by updating all path directories.
*--------------------------------------
XDOS.Destroy	jsr XDOS.FindFile		look for file to be destroyed.
				bcs L4B66			  	if error.

				jsr tstopen				is it open ?
				lda totent
				bne L4B64			  	error if open.

				stz reql			 	force proper free count in volume.
				stz reqh			 	(no disk access occurs if already
				jsr tstfrblk			proper)
				bcc L4B39				no errors.

				cmp #MLI.E.VOLFULL	 	was error a full disk ?
				bne L4B66			  	no, report error.

L4B39  			lda d_attr			 	make sure ok to destroy file.
*				and #$80
*				bne L4B45
				bmi L4B45

				lda #MLI.E.LOCKED	 	access error
				jsr GP.SYSERR

L4B45  			lda GP.DEVNUM			 	last device used.
				jsr twrprot1			test for write protected hardware
				bcs L4B66			  	before going thru deallocation.

				lda d_frst			 	'detree' needs first block address
				sta firstbl
				lda d_frst+1
				sta firstbh
				lda d_stor			 	find out which storage type.
				and #$F0			 	strip off name length.
				cmp #$40			 	is it a seed, sapling or tree ?
				bcc L4B68			  	branch if it is.
				bra L4BCF			  	otherwise, test for directory destroy.

L4B64  			lda #MLI.E.OPEN			file busy error.
L4B66  			sec		 				can't be destroyed
				rts

L4B68  			sta stortyp				destroy a tree file. save storage type.

				ldx #$05

*				lda #$00			 	set 'detree' input variables, must be

L4B6F  			stz stortyp,x		   	in order: deblock, dtree, dsap, dseed.
				dex
				bne L4B6F			  	loop until all zero'd.

				lda #$02			 	this avoids an extra file i/o and pre-
				sta dseed+1				vents destruction of any deleted data.
				inc delflag				don't allow detree to zero index blocks.
				jsr detree				make trees and saplings into seeds.
				dec delflag				reset flag.
				bcs L4B93			  	(de-evolution)

L4B85  			ldx firstbh
				lda firstbl				now deallocate seed.
				jsr XDOS.DeallocAX
				bcs L4B93

				jsr upbmap

L4B93  			pha		 				save possible error code.
				lda #$00			 	update directory to free entry space.
				sta d_stor
				cmp h_fcnt			 	file entry wrap ?
				bne L4BA1			 	branch if no carry adjustment.

				dec h_fcnt+1			take carry from hi byte of file entries.

L4BA1  			dec h_fcnt				mark header with one less file.
				jsr dvcbrev				go update block count in vcb (ignore
				jsr drevise				error, if any) and update dir last.
				tax		 				save possible new error code,
				pla		 				restore possible old error code.
				bcc L4BAF			  	branch if last call succeeded.
				txa		 				last call failed, use it's error code.

L4BAF  			cmp #$01			 	adjust carry accordingly
				rts

dvcbrev			ldx XDOS.VCBPtr			 	update block free count in vcb. point to vcb of correct device.
				lda deblock				get # of blocks recently freed.
				adc XDOS.VCBs+VCB.FBLK,x
				sta XDOS.VCBs+VCB.FBLK,x		update current free block count.
				lda deblock+1
				adc XDOS.VCBs+VCB.FBLK+1,x
				sta XDOS.VCBs+VCB.FBLK+1,x

				stz XDOS.VCBs+VCB.BMAPIDX,x	force re-scan from 1st bitmap

*			lda #0						?????

				rts

L4BCD  			bcc L4B85			  	branch widened (always taken)

L4BCF  			cmp #$D0			 	is this a directory file ?
				bne L4C1B			  	no, file incompatible.

				jsr fndbmap				make sure a buffer available for bitmap
				bcs L4C1A			  	if error.

				jsr XDOS.ReadGBuf_d_frst	read 1st block of directory into XDOS.GBuf
				bcs L4C1A

				lda XDOS.GBuf+37				do any files exist in this directory ?
				ora XDOS.GBuf+38
				bne L4C1Abis			if so, access error.

L4BF6  			sta XDOS.GBuf+4			 	make it an invalid subdirectory
				.DO LOWERCASE=1
				jsr XDOS.WriteGBufDir
				.ELSE
				jsr XDOS.WriteGBuf
				.FIN
				bcs L4C1A

L4BFE  			lda XDOS.GBuf+2			 	get forward link.
				cmp #$01			 	test for null block into carry.
				ldx XDOS.GBuf+3				get the rest of the block address.
				bne L4C0A			  	branch if not null.
				bcc L4BCD			  	was the low part null as well ?

L4C0A  			jsr XDOS.DeallocAX		free this block.
				bcs L4C1A

				lda XDOS.GBuf+2
				ldx XDOS.GBuf+3
				jsr XDOS.ReadGBufAX		read next DIR block (no need to unpack)
				bcc L4BFE			  	loop until all freed

L4C1A  			rts

L4C1Abis		lda #MLI.E.LOCKED	 	access error.
				.HS 2C					BIT ABS
L4C1B  			lda #MLI.E.INCFF	 	file incompatible
				jsr GP.SYSERR

fcbused			pha		 				mark fcb as dirty so the directory will be flushed on 'flush'.
				phy		 				save regs.

				ldy fcbptr

				lda #$80			 	mark fcb as dirty.
				sta XDOS.FCBs+FCB.DIRTY,y	save it back

				ply		 				and restore regs.
				pla
				rts
*--------------------------------------
XDOS.UpdateHdr	ldx #$00

.1  			sta XDOS.GBuf+4,x
				inx
				iny
				lda XDOS.PathBuf,y
				bne .1

				.DO LOWERCASE=1
				jmp XDOS.WriteGBufDir
				.ELSE
				jmp XDOS.WriteGBuf		write changed header block.
				.FIN
*--------------------------------------
getnamptr 		ldy #$00				return pointer to 1st name of path.
				bit prfxflg				is this a prefixed name ?
				bmi .1				  	branch if not.

				ldy GP.NEWPFXPTR

.1  			ldx #$00

				rts
*--------------------------------------
MAN
SAVE usr/src/prodos.fx/prodos.s.xdos.e
LOAD usr/src/prodos.fx/prodos.s
ASM