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

NEW
  AUTO 3,1
*--------------------------------------
XDOS			cld						no decimal.
				sty mliy				save x and y
				stx mlix			 
				
				ply						get processor status
				
				pla						find out the address of the caller
				sta A3L
				clc						preserve the address of the call spec.
				adc #$04
				sta mliretn				last MLI call return address
				pla
				sta A3L+1
				adc #$00
				sta mliretn+1

				phy						pull processor status
				plp						to re-enable interrupts.

				cld						still no decimal
				stz	p8error				clear any previous errors.
				ldy #$01				find out if command is valid.
				lda	(A3L),y				get command #

				lsr						and hash it to a range of 0-$1F
				lsr
				lsr
				lsr
				clc
				adc (A3L),y
				and #$1F
				tax
				lda (A3L),y				check result to see if valid command #
				cmp XDOS.CmdNums,x
				bne scnerr

				iny						index to call spec parm list.
				lda (A3L),y				make A3L point to parameter count byte
				pha						in parameter block.
				iny
				lda (A3L),y
				sta A3L+1
				pla
				sta A3L

				lda	XDOS.ParamCnt,x		make sure parameter list has the correct # of parameters.
				beq goclock				clock has 0 parameters.

				cmp (A3L)
				bne scperr				error if wrong count.

				lda XDOS.CmdNums,x		get call # again
				cmp #MLIQUIT			is it quit?
				beq special				if so, then call quit dispatcher

				asl					 	carry set if bfm or dev mgr
				bpl godevmgr
				bcs gobfmgr

				lsr						shift back down for interrupt manager
				and #$03				valid calls are 0 and 1
				jsr XDOS.intmgr
				bra exitmli

special			jmp jspare				P8 system death vector

goclock			jsr clockv			 	go read clock.
				bra exitmli				no errors possible

godevmgr 		lsr						shift back down for device manager.
				adc #$01				valid commands are 1 and 2.
				sta A4L					save command #.
				jsr XDOS.devmgr			execute read or write request.
				bra exitmli

gobfmgr			lsr						shift back down for block file manager.
				and #$1F				valid commands are 0-$13
				tax
				
				jsr XDOS.bfmgr

exitmli			stz bubit				clear backup bit
				ldy p8error				P8 error code
				cpy #$01				if > 0 then set carry
				tya						and set z flag.
				php						disable interrupts until exit complete.
				sei
				lsr mliact				indicate MLI done.
				plx						save status register until return.
				lda mliretn+1			place last MLI call return address
				pha						on stack. return is done via 'rti'
				lda mliretn				so the status register is restored
				pha						at the same time, so
				phx						place status back on stack
				tya						return error, if any.
				ldx mlix				MLI X register savearea
				ldy mliy				MLI Y register savearea
				pha
				lda bnkbyt1				restore language card status
				jmp GP.MLIEXIT			and return.

nodevice 		lda #MLI.E.NODEV		no device connected.
				jsr GP.P8errv
				
scnerr			lda #MLI.E.BADCALL
				.HS 2C					BIT ABS
scperr			lda #MLI.E.BADCNT
				jsr gosyserr
				bra exitmli
*--------------------------------------
* ProDOS Device Manager
*--------------------------------------
XDOS.devmgr		ldy #$05				the call spec for devices must

.1	  			lda (A3L),y				be passed to drivers in page zero:
				sta A4L,y
				dey
				bne .1

				ldx buf+1				buffer page
				stx usrbuf+1			to user buffer
				inx
				inx
				lda buf					is buffer page aligned (nn00) ?
				beq .2					branch if it is

				inx						else account for 3-page straddle

.2  			jsr vldbuf1				make sure user buffer is not
				bcs gosyserr			conflicting with protected ram.

				jsr XDOS.DevCall		call internal entry for device dispatch
				bcc XDOS.DevCall.RTS

gosyserr 		jsr GP.P8errv
*--------------------------------------
XDOS.DevCall	php						do not allow interrupts.
				sei						

				lda unitnum				get device # and
				and #$F0				strip misc lower nibble
				sta unitnum				then save it.
				lsr						use as index to device table
				lsr
				lsr
				tax
				jsr XDOS.DevCall.Jmp
				bit CLRC8ROM			RELEASE $C800-$CFFF ROM space
				bcs .9
				
				plp
				clc
				rts
				
.9				plp				
				sec

XDOS.DevCall.RTS
				rts
				
XDOS.DevCall.Jmp
				jmp (DEVPTRS,x)			goto driver (or error if no driver)
*--------------------------------------
* ProDOS interrupt manager
*--------------------------------------
XDOS.intmgr		sta A4L					interrupt command
				lsr						allocate interrupt or deallocate?
				bcs dealcint			branch if deallocate.

				ldx #$03				test for a free interrupt space in tbl.

.1				lda	GP.IRQVs-2,x		test high address for 0.
				bne	.2					branch if spot occupied.

				ldy	#$03				get address of routine.
				lda	(A3L),y				must not be zero page.
				beq badint				error if it is.

				sta GP.IRQVs-2,x		save high address
				dey
				lda (A3L),y
				sta GP.IRQVs-3,x		and low address.
				txa						return interrupt # in range 1-4
				lsr
				dey
				sta (A3L),y				pass back to user.
				clc						no errors.
				rts

.2  			inx
				inx						next lower priority spot
				cpx #$0B				are all 4 already allocated?
				bne	.1					branch if not.

				lda	#MLI.E.IRQFULL		interrupt table full
				.HS 2C					BIT ABS
badint			lda #MLI.E.INVPARAM		invalid parameter.
				jsr GP.P8errv

dealcint		ldy #$01			   	zero out interrupt vector
				lda	(A3L),y				but make sure it is a valid #.
				beq badint				error if < 1

				cmp #$05				or > 4
				bcs badint

				asl
				tax
				
				stz GP.IRQVs-2,x
				stz GP.IRQVs-1,x
				clc
				rts
*--------------------------------------
XDOS.syserr		sta p8error				P8 error code
				plx
				plx						pop 1 level of return
				sec
				rts
*--------------------------------------
XDOS.SysDeath 	tax						death error code.
				sta CLR80DISP			disable 80 col hardware.
				lda SETTEXT				switch in text.
				lda cortflag			is this a Cortland?
				beq .1					if not, don't use super hires switch.

				stz newvideo			force off super hires.

.1	  			lda CLRPAGE2			switch in text page 1.

				ldy #deathmsg.LEN-1

.2  			lda deathmsg,y
				sta $400,y				'RESTART SYSTEM-$'
				dey
				bpl .2

				txa						x = death error code
				and #$0F				convert to ascii
				ora #$30
				cmp #$3A
				bcc .3					branch if not > 9.

				adc #$06				inc to alpha a-f

.3  			ldy #deathmsg.LEN
				ora #$80
				sta $400,y
				
				lda #" "
				
.4				iny
				sta $400,y
				cpy #39
				bne .4

				bra *
*--------------------------------------
* ProDOS Block File Manager
*--------------------------------------
XDOS.bfmgr		lda XDOS.CmdFlags,x		translate into command address.
				asl						bit 7 indicates pathname to process
				sta cmdtemp
				and #$3F				bit 6  is refnum, 5 is time to process
				tax
				lda cmdtable,x			move address to indirect jump
				sta H3274+1
				lda cmdtable+1,x		high byte
				sta H3274+2

				lda #$20				init backup bit flag
				sta bkbitflg			to say 'file modified'
				bcc nopath

				jsr XDOS.GetPath		process pathname before calling command
				bcs errorsys			branch if bad name.

nopath			asl cmdtemp				test for refnum processing
				bcc nopreref

				jsr XDOS.GetFCB			set pointers to fcb and vcb of file
				bcs errorsys

nopreref 		asl cmdtemp				check for necessity of time stamp
				bcc H3274	

				jsr clockv				date/time

H3274  			jsr $FFFF				SELF MODIFIED : execute command
				bcc goodop

errorsys 		jsr GP.P8errv
goodop			rts
*--------------------------------------
* entry used by rename for 2nd pathname.
*--------------------------------------
XDOS.GetRenPath	ldy #$03			 	get address to new pathname
				.HS 2C
*--------------------------------------
XDOS.GetPath	ldy #$01				index to pathname pointer
				lda (A3L),y				low pointer address
				sta zpt

				iny
				lda (A3L),y				hi pointer address
				sta zpt+1

				ldx #$00				x = index to pathbuf
				ldy #$00				y = index to input pathname.

				stz prfxflg				assume prefix is in use.
				stz pathbuf				mark pathbuf = nothing processed.

				lda (zpt),y				validate pathname length > 0 and < 65
				beq errsyn

				cmp #$41
				bcs errsyn

				sta pathcnt				this is used to compare for
				inc pathcnt				end of pathname processing.

				iny						now check for full pathname...
				lda (zpt),y				(full name if starts with '/')
				and #$7F
				cmp #'/'
				bne H32AD				branch if prefix appended.

				dec prfxflg				set prefix flag = prefix not used.
				iny						index to 1st character of pathname.

H32AD  			lda #$FF				set current position of pathbuf
				sta pathbuf,x			to indicate end of pathname.

				sta namcnt				$FF = no chars processed in local name.
				stx namptr				pointer to local name length byte.

H32B8  			cpy pathcnt				done with pathname processing?
				bcs endpath

				lda (zpt),y				get character
				and #$7F
				inx						prepare for next char
				iny
				cmp #'/'				is it delimiter '/' ?
				beq endname				yes

				.DO LOWERCASE=0
				cmp #'a'				lowercase?
				bcc .1					no

				and #$5F				shift to uppercase
.1				.FIN

				sta pathbuf,x			store char
				inc namcnt				is it the 1st char of a local name?
				bne .2					no
	
				inc namcnt				increment to 1
				jsr XDOS.IsValidFirstChar
				bcc H32B8

				bra errsyn
				
.2				jsr XDOS.IsValidChar
				bcc H32B8

errsyn			lda #MLI.E.INVPATH
				sec
				rts

endpath			lda #$00			 	end pathname with a 0
				bit namcnt				also make sure count is positive
				bpl H32FD

				sta namcnt
				dex

H32FD  			inx
				sta pathbuf,x
				beq errsyn				error if '/' only.

				stx pathcnt				save length of pathname
				tax

endname  		lda namcnt				validate local name < 16
				cmp #16
				bcs errsyn

				phx						save pointer
				ldx namptr				get index to beginning of local name
				sta pathbuf,x			save local name's length
				plx						restore pointer
				bne H32AD				branch if more names to process

				clc						probably no error, but
				lda prfxflg				make sure all pathnames are prefixed
				bne H3323				or begin with a '/'.

				lda newpfxptr			must be non-zero
				beq errsyn
H3323  			rts
*--------------------------------------
XDOS.SetPrefix	jsr XDOS.GetPath		call is made to detect if a null path.
				bcc H3333				path ok.

				ldy pathbuf				is it a null pathname?
				bne pfxerr				error if not

				sty newpfxptr			fix appletalk PFI bug
				sty preflag	  			prefix flag
				clc						no error
				rts

H3333  			jsr XDOS.FindFileOrVol	go find specified prefix directory.
				bcs pfxerr				branch if error is not root directory.

H333C  			lda d_stor				make sure last local name is dir type
				and #$D0				(either root or sub).
				eor #$D0				directory?
				bne ptyperr				wrong type

				ldy prfxflg				new or appended prefix?
				bne H334D

				lda newpfxptr			append new prefix to old

H334D  			tay
				sec						find new beginning of prefix
				sbc pathcnt
				cmp #$C0				too long?
				bcc errsyn				then error

				tax
				sta newpfxptr
				sta preflag
				lda d_dev				save device #
				sta p_dev
				lda d_frst				and address of 1st block
				sta p_blok
				lda d_frst+1
				sta p_blok+1

.1				lda pathbuf,y
				sta pathbuf,x
				iny
				inx
				bne .1

				clc						good prefix
				rts

ptyperr			lda #MLI.E.UNSUPST		filetype error (not a directory)
pfxerr			sec
				rts
*--------------------------------------
XDOS.GetPrefix	clc						calc how big a buffer is needed.
				ldy #$01				get index to users pathname buffer
				lda (A3L),y
				sta usrbuf				user buffer ptr
				iny
				lda (A3L),y
				sta usrbuf+1

				stz cbytes+1			set buffer length at 64 char max
				lda #$40
				sta cbytes

				jsr valdbuf				go validate prefix buffer address
				bcs pfxerr

				ldy #$00				y = indirect index to user buffer.
				lda newpfxptr			get address of beginning of prefix
				tax
				beq nulprfx				if null prefix.

				eor #$FF				get total length of prefix
				adc #$02				add 2 for leading and trailing slashes.

nulprfx  		sta (usrbuf),y			store length in user's buffer.
				beq gotprfx				branch if null prefix.

sendprfx 		iny						inc to next user buffer location.
				lda pathbuf,x			get next char of prefix.

sndlimit 		sta (usrbuf),y		  	give char to user.
				and #$F0				check for length descriptor.
				bne H33B3				branch if regular character

				lda #'/'				otherwise, substitute a slash.
				bne sndlimit			branch always

H33B3  			inx
				bne sendprfx			branch if more to send.
				iny
				lda #'/'				end with '/'
				sta (usrbuf),y
gotprfx  		clc						no error
				rts
*--------------------------------------
XDOS.GetFCB		ldy #$01				index to ref#
				lda (A3L),y				is it a valid file# ?
				beq badref				must not be 0.

				cmp #FCB.MAX+1
				bcs badref

				pha
				dec 
				lsr
				ror
				ror
				ror						multiply by 32.
				sta fcbptr				used as an index to fcb
				tax
				pla						restore ref# in acc
				cmp FCBs+FCB.ID,x
				bne errnoref
*--------------------------------------
XDOS.GetFCBBufX	lda FCBs+FCB.BUFID,x	get page address of file buffer.
				
				tay						index into global buffer table.
				lda buftbl-1,y
				sta bufaddrh

				beq fcbdead				fcb corrupted

				sta datptr+1			save ptr to data area of buffer
				inc
				inc						index block always 2 pages after data
				sta zpt+1

				lda buftbl-2,y			???? ALWAYS 0

				sta bufaddrl
				sta datptr				index and data buffers always on
				sta zpt					page boundaries.

				jsr XDOS.FCBDevIDSelect

				lda #VCB0

fndfvol			tay						search for associated vcb
				lda VCBs+VCB.DEV,y
				cmp FCBs+FCB.DEVID,x	is this vcb the same device?
				beq tstvopen			if it is, make sure volume is active.

nxtfvol			tya					 	adjust index to next vcb.
				clc
				adc #VCB
				bcc fndfvol				loop until volume found.

				lda #$0A				open file has no volume so
				.HS 2C					BIT ABS

fcbdead			lda #$0B				fcb error so

				jsr GP.SysDeath			kill the system.

tstvopen 		lda VCBs,y				make sure this vcb is open.
				beq nxtfvol				branch if it is not active.

				sty vcbptr				save ptr to good vcb.
				clc						no error
				rts						Y = VCBPtr, X = FCBPtr

errnoref 		stz FCBs,x

badref 			lda #MLI.E.BADREF		requested refnum is
				sec						illegal (out of range)
				rts
*--------------------------------------
XDOS.Online		jsr mvdbufr				figure out how big buffer has to be.

				stz cbytes				set this for valdbuf routine.
				stz cbytes+1
				ldy #$01
				lda (A3L),y				if 0 then cbytes=$100 else $010 for one
				and #$F0				device. mask out unused nibble.
				sta devnum				last device used.
				beq .1					branch if all devices.

				lda #$10				cbytes = $010
				sta cbytes
				bne .2					always taken

.1  			inc cbytes+1			cbytes = $100

.2  			jsr valdbuf				go validate buffer range against
				bcs .9					allocated memory.

				lda #$00				zero out user buffer space
				ldy cbytes

.3	  			dey
				sta (usrbuf),y
				bne .3

				sta namptr				used as pointer to user buffer.
				lda devnum				get device # again.
				bne online1				branch if only 1 device to process.

				jsr mvdevnums			get list of currently recognized dev's.

.4  			phx						save index to last item on list
				lda loklst,x
				sta devnum				save desired device to look at.
				jsr online1				log this volume and return it's name.
				lda namptr				inc pointer for next device
				clc
				adc #$10
				sta namptr
				plx						get index to device list.
				dex						next device.
				bpl .4					branch if there is another device.

				lda #$00				no errors for multiple on-line
				clc
.9		 		rts
*--------------------------------------
online1			jsr XDOS.FindVCBForDevNum	see if it has already been logged in.
				bcs online1.ERR			branch if vcb is full.

				lda #$02
				ldx #$00				read in root (volume) directory
				jsr XDOS.ReadGBufAX		read ROOT VOL into general purpose buffer.
				bcc .1					branch if read was ok.

				ldx vcbptr
				ldy VCBs+VCB.OFCNT,x	don't take the vcb offline if
				bne online1.ERR			there are active files present.

				stz VCBs,x				now take the volume offline
				stz VCBs+VCB.DEV,x

				bra online1.ERR			branch if unable to read.

.1		 		.DO LOWERCASE=1
				jsr XDOS.CheckAndUnpackGBuf
				bcs online1.ERR
				.FIN

				ldx vcbptr
				lda VCBs,x				has it been logged in before?
				beq .2					if not.

				lda VCBs+VCB.OFCNT,x	it has, are there active files?
				bne .3					branch if volume is currently busy.

.2  			jsr XDOS.VCBMountAtX
				bcs online1.ERR			branch if there is a problem.

				lda #MLI.E.DUPVOL		anticipate a duplicate active volume
				bit duplflag			exits.
				bmi online1.ERR			branch if so.

.3  			ldx vcbptr
				jsr XDOS.VCBCmpGBUF		does vol read compare with logged vol?
				lda #MLI.E.DSKSWIT		anticipate wrong volume mounted.
				bcc online1.OK			branch if ok.
*--------------------------------------
online1.ERR		pha						save error code.
				jsr svdevn				report what device has problem.
				pla						error code.
				iny						tell what error was encountered.
				sta (usrbuf),y
				cmp #MLI.E.DUPVOL		duplicate volume error?
				bne .1					no.

				iny						report which other device has same name
				ldx vcbentry
				lda VCBs+VCB.DEV,x
				sta (usrbuf),y
				stz duplflag			clear duplicate flag.

				lda #MLI.E.DUPVOL		duplicate volume error code.

.1  			sec						flag error
				rts
*--------------------------------------
online1.OK		lda VCBs,x				get volume name count
				sta namcnt
				ldy namptr				index to user's buffer.

.1  			lda VCBs,x				move name to user's buffer
				sta (usrbuf),y
				inx
				iny
				dec namcnt
				bpl .1

svdevn			ldy namptr				index to 1st byte of this entry.
				lda devnum				upper nibble = device# and
				ora (usrbuf),y			lower nibble = name length.
				sta (usrbuf),y
		
				clc						no errors
				rts						end of block file manager
*--------------------------------------
XDOS.Create		jsr XDOS.CheckPath		check for duplicate, get free entry
				bcc	duperr				error code may be 'file not found'

tstfnf			cmp #MLI.E.FNOTFND		'file not found' is ok
				bne crerr1				otherwise exit with error.

				ldy #$07				test for tree or directory file,
				lda (A3L),y				no other kinds are legal.
				cmp #$04				is it seed, sapling or tree?
				bcc tstdspc				branch if it is

				cmp #$0D
				bne ctyperr				report type error if not directory.

tstdspc			lda devnum				make sure destination device
				jsr twrprot1			is not write protected.
				bcs H351D

				lda nofree				is there space in directory to
				beq xtndir				add this file? branch if not
				jmp creat1				otherwise, go create file.

xtndir			lda own_blk				before extending directory,
				ora own_blk+1			make sure it's a subdirectory.
				bne H352A

				lda #MLI.E.DIRFULL		otherwise, directory full error
				.HS 2C					BIT ABS
ctyperr			lda #MLI.E.UNSUPST		filetype error
				.HS 2C					BIT ABS
duperr			lda #MLI.E.DUPFILE		name already exists
crerr1			sec
H351D  			rts
	
H352A  			lda bloknml				preserve disk address of current (last)
				pha						directory link, before allocating an
				lda bloknml+1			extended block.
				pha
				jsr alc1blk				allocate a block for extending directory
				plx
				stx bloknml+1			restore block addr of dir info in gbuf
				plx
				stx bloknml
				bcs H351D				unable to allocate.

				sta gbuf+2				save block address in y,a to
				sty gbuf+3				current directory.
				.DO LOWERCASE=1
				jsr XDOS.WriteGBufDir
				.ELSE
				jsr XDOS.WriteGBuf		update directory block with new link.
				.FIN
				bcs H351D				if error

				ldx #$01

swpbloks 		lda bloknml,x			prepare new directory block
				sta gbuf,x				using current block as back link
				lda gbuf+2,x
				sta bloknml,x			and save new block as next to be written
				dex
				bpl swpbloks

				inx						x = 0

clrdir 			stz gbuf+2,x
				stz gbuf+$100,x
				inx
				bne clrdir

				.DO LOWERCASE=1
				jsr XDOS.WriteGBufDir
				.ELSE
				jsr XDOS.WriteGBuf		write prepared directory extension.
				.FIN
				bcs H351D				if error

				lda own_blk
				ldx own_blk+1

				.DO LOWERCASE=1
				jsr XDOS.ReadGBufAXDir
				.ELSE
				jsr XDOS.ReadGBufAX		read in parent directory block
				.FIN

				ldx own_ent				and calc entry address.
				lda /gbuf
				sta zpt+1
				lda #$04

ocalc  			clc
				dex						has entry address been calculated?
				beq H3584				if yes.

				adc own_len				next entry address
				bcc ocalc

				inc zpt+1				entry must be in 2nd 256 bytes of block
				bcs ocalc				always taken.

H3584  			sta zpt
				ldy #$13				index to block count
H3588  			lda (zpt),y
				adc dinctbl-$13,y		add 1 to block count and
				sta (zpt),y
				iny
				tya						$200 to the directory's eof.
				eor #$18				done with usage/eof update?
				bne H3588				branch if not.

				.DO LOWERCASE=1
				jsr XDOS.WriteGBufDir
				.ELSE
				jsr XDOS.WriteGBuf		go update parent.
				.FIN
				bcs crerr2

				jmp XDOS.Create
crerr2 			rts						return and report errors
*--------------------------------------
creat1			ldx #$00				zero out gbuf

H35A0  			stz gbuf,x
				stz gbuf+$100,x			and data block of file.
				inx
				bne H35A0

				ldy #$0B				move user specified date/time

cmvtime			lda (A3L),y				to directory.
				sta d_filid,y
				txa		 				if all 4 bytes of date/time = 0
				ora (A3L),y				then use built-in date/time.
				tax
				dey
				cpy #$07
				bne cmvtime

				txa						does user want default time?
				bne cmvname				if not.

				ldx #$03

mvdftime 		lda p8date,x			move current default date/time
				sta d_credt,x
				dex
				bpl mvdftime

cmvname			lda (A3L),y				y = index to file kind.
				cmp #$04
				lda #$10				assume tree type
				bcc csvfkind

				lda #$D0			 	it's directory.

csvfkind 		ldx namptr			 	index to local name of pathname.
				ora pathbuf,x			combine file kind with name length.
				sta d_stor			 	sos calls this 'storage type'.
				and #$0F			 	strip back to name length
				tay		 				and use as counter for move.
				clc
				adc namptr			 	calc end of name
				tax

crname			lda pathbuf,x			move local name as filename
				sta d_stor,y

				dex
				dey
				bne crname

				ldy #$03				index to 'access' parameter
				lda (A3L),y
				sta d_attr
				iny						also move 'file identification'
				lda (A3L),y
				sta d_filid

cmvauxid 		iny						move auxillary identification bytes
				lda (A3L),y
				sta d_auxid-5,y
				cpy #$06
				bne cmvauxid

				.DO LOWERCASE=0
				lda xdosver				save current xdos version #
				sta d_sosver

				lda compat			 	and backward compatibility #
				sta d_comp
				.FIN
				
				lda #$01			 	usage is always 1 block
				sta d_usage
				lda d_head				place back pointer to header block
				sta d_dhdr

				lda d_head+1
				sta d_dhdr+1

				lda d_stor				storage type.
				and #$E0			 	is it a directory?
				beq cralcblk			branch if seed file.

* Create Dir First Block

				ldx #$1E			 	move header to data block

cmvheadr 		lda d_stor,x
				sta gbuf+4,x
				dex
				bpl cmvheadr

				eor #$30
				sta gbuf+4				make it a directory header mark.

				.DO LOWERCASE=0
				
				ldx #$07			 	overwrite password area and other

cmvpass			lda pass,x				header info.
				sta gbuf+20,x

				lda xdosver,x
				sta gbuf+32,x
				dex
				bpl cmvpass
				
				.ELSE
				lda #$75
				sta gbuf+20
				
				ldx #XDOS.VolHdrDef.Cnt-1
				
.1				lda XDOS.VolHdrDef,x
				sta gbuf+34,x
				dex
				bpl .1
				
				.FIN

				ldx #$02				and include info about parent directory
				stx d_eof+1				set file size = 512

cmvparnt 		lda d_entblk,x
				sta gbuf+39,x
				dex
				bpl cmvparnt

				lda h_entln				lastly, the length of parent's
				sta gbuf+42				directory entries.

				.DO LOWERCASE=1
				jsr XDOS.PackGBuf
				.FIN

cralcblk 		jsr alc1blk				get address of file's data block
				bcs crerr3

				sta d_frst
				sty d_frst+1
				sta bloknml
				sty bloknml+1
				jsr XDOS.WriteGBuf		go write data block of file
				bcs crerr3

				inc h_fcnt			 	add 1 to total # of files in this dir
				bne credone

				inc h_fcnt+1

credone			jsr drevise				go revise directories with new file
				bcs crerr3

				jmp upbmap			 	lastly, update volume bitmap
*--------------------------------------
entcalc			lda /gbuf				set high address of dir entry
				sta zpt+1			  	index pointer.
				lda #$04			 	calc address of entry based
				ldx d_entnum			on the entry #.

H3689  			clc

H368A  			dex		 				addr = gbuf + ((d_entnum-1) * h_entln)
				beq H3696			  	branch with carry clear = no errors.

				adc h_entln
				bcc H368A

				inc zpt+1			  	inc hi address.
				bcs H3689				always.

H3696  			sta zpt			  		newly calculated low address.
crerr3 			rts		 				carry set if error.
*--------------------------------------
drevise			lda p8date
				beq drevise1		  	if no clock, then don't mod date/time.

				ldx #$03

modtime			lda p8date,x			move last modification date/time
				sta d_moddt,x			to entry being updated.
				dex
				bpl modtime

drevise1 		lda bkbitflg			(bit 5 = backup needed)
				tsb d_attr				mark entry as backupable
				
				lda d_dev			  	get device # of directory
				sta devnum			 	to be revised

				lda d_entblk			and address of directory block.
				ldx d_entblk+1

				.DO LOWERCASE=1
				jsr XDOS.ReadGBufAXDir
				.ELSE
				jsr XDOS.ReadGBufAX		read block into general purpose buffer
				.FIN
				bcs crerr3

				jsr entcalc				fix up ptr to entry location within gbuf.

				ldy h_entln				now move 'd.' info to directory.
				dey
				
.1  			lda d_stor,y
				sta (zpt),y
				dey
				bpl .1

				lda d_head				is the entry block same as
				cmp bloknml				the entry's header block?
				bne H36E0			  	if no, go save entry block

				lda d_head+1			then maybe, so test high addresses.
				cmp bloknml+1
				beq uphead			 	branch if they are the same block.

H36E0  			.DO LOWERCASE=1
				jsr XDOS.WriteGBufDir
				.ELSE
				jsr XDOS.WriteGBuf		go write updated directory block.
				.FIN
				bcs crerr3

				lda d_head			 	get address of header block and
				ldx d_head+1

				.DO LOWERCASE=1
				jsr XDOS.ReadGBufAXDir
				.ELSE
				jsr XDOS.ReadGBufAX		go read in header block to modify.
				.FIN
				bcs crerr3

uphead			ldy #$01				update current # of files in this dir.

H36F2  			lda h_fcnt,y
				sta gbuf+37,y			(current entry count)
				dey
				bpl H36F2

				lda h_attr			 	also update header's attributes.
				sta gbuf+34

				.DO LOWERCASE=1
				jsr XDOS.WriteGBufDir
				.ELSE
				jsr XDOS.WriteGBuf		go write updated header
				.FIN
				bcs H375A
*--------------------------------------
ripple			lda gbuf+4				test for 'root' directory because
				and #$F0			 	if it is, then directory revision
				eor #$F0			 	is complete (leaves carry clear).
				beq H3770			  	branch if done.

				lda gbuf+41				get entry #
				sta d_entnum
				lda gbuf+42				and the length of entries in that dir
				sta h_entln

				lda gbuf+39				get addr of parent entry's dir block
				ldx gbuf+40
	
				.DO LOWERCASE=1
				jsr XDOS.ReadGBufAX		no need to pak/unpak....will disturb zpt
				.ELSE
				jsr XDOS.ReadGBufAX		read it
				.FIN
				bcs H375A

				jsr entcalc				get indirect ptr to parent entry in gbuf

				lda p8date				don't touch mod
				beq H373B			  	if no clock...

				ldx #$03			 	update the modification date & time
				ldy #$24			 	for this entry too

H3732  			lda p8date,x
				sta (zpt),y
				dey
				dex
				bpl H3732

H373B  			.DO LOWERCASE=1
				jsr XDOS.WriteGBuf		
				.ELSE
				jsr XDOS.WriteGBuf		write updated entry back to disk.
				.FIN
				bcs H375A			  	if error.

				ldy #$26			 	compare current block # to this
				lda (zpt),y				entry's header block.
				tax
				dey
				lda (zpt),y				block as header.
				cmp bloknml				are low addresses the same?
				bne H3751			 	branch if entry doesn't reside in same

				cpx bloknml+1			are high address the same?
				beq ripple			 	they are the same, continue to root dir.

H3751  			.DO LOWERCASE=1
				jsr XDOS.ReadGBufAX		
				.ELSE
				jsr XDOS.ReadGBufAX
				.FIN
				bcc ripple				continue if read was good

H375A  			rts

H3770  			clc		 				no error
				rts
*--------------------------------------
MAN
SAVE usr/src/prodos.fx/prodos.s.xdos.a
LOAD usr/src/prodos.fx/prodos.s
ASM