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

NEW
  AUTO 3,1
*--------------------------------------
XDOS.START
XDOS.MLI		cld						no decimal.
				pla						get processor status
				sta spare1				save it temporarily
				sty mliy				save x and y
				stx mlix			 
				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
				lda spare1
				pha						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 #

*			cmp #$D5
*			bne .77
*			>DEBUG
*.77			
				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
*				ldy #$00
				lda	XDOS.ParamCnt,x		make sure parameter list has the correct # of parameters.
				beq goclock				clock has 0 parameters.

				cmp (A3L)				,y
				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		php						do not allow interrupts.
				sei						the call spec for devices must

				ldy #$05

.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 dvmgrerr			conflicting with protected ram.
				jsr dmgr				call internal entry for device dispatch
				bcs dvmgrerr			branch if error
				plp
				clc						no error
				rts

dvmgrerr 		plp						restore interrupt status
gosyserr 		jsr GP.P8errv
*--------------------------------------
dmgr			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
gocmd			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	inttbl-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 inttbl-2,x			save high address
				dey
				lda (A3L),y
				sta inttbl-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
				lda #$00				now clear it
				sta inttbl-2,x
				sta inttbl-1,x
				clc
				rts
*--------------------------------------
XDOS.syserr		sta p8error				P8 error code
				plx
				plx						pop 1 level of return
				sec
				rts
*--------------------------------------
sysdeath1 		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
				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 findfcb				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 findfile			go find specified prefix directory.
				bcc H333C				if no error.

				cmp #MLI.E.INVPATH		bad pathname.
				bne 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
*--------------------------------------
findfcb			ldy #$01				index to ref#
				lda (A3L),y				is it a valid file# ?
				beq badref				must not be 0.

				cmp #$09				must be 1 to 8 only.
				bcs badref

				pha
				dec 
				lsr
				ror
				ror
				ror						multiply by 32.
				sta fcbptr				used as an index to fcb
				tay
				pla						restore ref# in acc
				cmp fcbbuf,y
				bne errnoref

fndfcbuf 		lda fcbbuf+11,y			get page address of file buffer.
				jsr getbufadr			get file's address into bufaddrl,h
				ldx bufaddrh			(y=fcbptr preserved)
				beq fcbdead				fcb corrupted
				stx datptr+1			save ptr to data area of buffer
				inx
				inx						index block always 2 pages after data
				stx zpt+1
				lda fcbbuf+1,y			also set up device #
				sta devnum
				lda bufaddrl
				sta datptr				index and data buffers always on
				sta zpt					page boundaries.

fndfvol			tax						search for associated vcb
				lda vcbbuf+16,x
				cmp fcbbuf+1,y			is this vcb the same device?
				beq tstvopen			if it is, make sure volume is active.

nxtfvol			txa					 	adjust index to next vcb.
				clc
				adc #$20
				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 sysdeath			kill the system.

tstvopen 		lda vcbbuf,x			make sure this vcb is open.
				beq nxtfvol				branch if it is not active.
				stx vcbptr				save ptr to good vcb.
				clc						no error
				rts

errnoref 		lda #$00				put a zero into this fcb to
				sta fcbbuf,y			show free fcb.

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 H343C				branch if all devices.

				lda #$10				cbytes = $010
				sta cbytes
				bne H343F				always taken

H343C  			inc cbytes+1			cbytes = $100

H343F  			jsr valdbuf				go validate buffer range against
				bcs onlinerr			allocated memory.

				lda #$00				zero out user buffer space
				ldy cbytes

H3449  			dey
				sta (usrbuf),y
				bne H3449

				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.

H3459  			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 H3459				branch if there is another device.

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

				ldx #$00				read in root (volume) directory
				lda #$02
				jsr rdblk				read it into general purpose buffer.
				ldx vcbptr				index to the vcb entry.
				bcc volfound			branch if read was ok.

				tay						error value.
				lda vcbbuf+17,x			don't take the vcb offline if
				bne rtrnerr				there are active files present.

				sta vcbbuf,x			now take the volume offline
				sta vcbbuf+16,x

rtrnerr			tya						error value.
				bcs olinerr1			branch if unable to read.

volfound 		lda vcbbuf,x			has it been logged in before?
				beq H349E				if not.

				lda vcbbuf+17,x			it has, are there active files?
				bmi H34AA				branch if volume is currently busy.

H349E  			jsr logvcb1				go log it in.
				bcs olinerr1			branch if there is a problem.

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

H34AA  			ldx vcbptr
				jsr cmpvcb				does vol read compare with logged vol?
				lda #MLI.E.DSKSWIT		anticipate wrong volume mounted.
				bcc H34D0				branch if ok.

olinerr1 		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 H34CE				no.

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

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

H34CE  			sec						flag error
				rts

H34D0  			lda vcbbuf,x			get volume name count
				sta namcnt
				ldy namptr				index to user's buffer.

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

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 lookfile			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.
				jsr wrtgbuf				update directory block with new link.
				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
				txa						x and a = 0

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

				jsr wrtgbuf				write prepared directory extension.
				bcs H351D				if error

				lda own_blk
				ldx own_blk+1
				jsr rdblk				read in parent directory block
				ldx own_ent				and calc entry address.
				lda /gbuf
				sta zpt+1
				lda #$04
ocalc  			clc
				dex						has entry address been calulated?
				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.

				jsr wrtgbuf				go update parent.
				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

				.DO LOWERCASE=1
				stz d_sosver
				stz d_comp
				.FIN
				
crname			lda pathbuf,x			move local name as filename
				sta d_stor,y

				.DO LOWERCASE=1
				cmp #'a'
				bcc .3
				cmp #'z'+1
				bcs .3

				eor #$20
				sta d_stor,y
				
				cpy #8
				bcs .1

				lda whichbit,y
				tsb d_sosver
				bra .2

.1				lda whichbit-8,y
				tsb d_comp
				
.2				lda #$80
				tsb d_sosver
.3				.FIN
				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.

				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
				
				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

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.

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 wrtgbuf				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 d_attr				mark entry as backupable
				ora bkbitflg			(bit 5 = backup needed)
				sta d_attr
				lda d_dev			  	get device # of directory
				sta devnum			 	to be revised
				lda d_entblk			and address of direcotry block.
				ldx d_entblk+1
				jsr rdblk			  	read block into general purpose buffer
				bcs crerr3

				jsr entcalc				fix up ptr to entry location within gbuf.

				ldy h_entln				now move 'd.' info to directory.

				dey

H36CA  			lda d_stor,y
				sta (zpt),y
				dey
				bpl H36CA

				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  			jsr wrtgbuf				go write updated directory block.
				bcs crerr3

				lda d_head			 	get address of header block and
				ldx d_head+1
				jsr rdblk			  	go read in header block to modify.
				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
				jsr wrtgbuf				go write updated header
				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 ertries in that dir
				sta h_entln
				lda gbuf+39				get addr of parent entry's dir block
				ldx gbuf+40
				jsr rdblk			  	read it
				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  			jsr wrtgbuf				write updated entry back to disk.
				bcs H375A			  	if error.

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

				lda (zpt),y				block as header.
				cmp bloknml+1			are high address the same?
				beq ripple			 	they are the same, continue to root dir.

H3751  			lda (zpt),y				not same so read in this dir's header.
				sta bloknml+1
				jsr rdgbuf
				bcc ripple				continue if read was good

H375A  			rts

tsterr 			lda #MLI.E.NOTPRODOS	not tree or dir, unrecognized type
				sec
				rts

tstsos			lda gbuf			 	pointer to previous dir block
				ora gbuf+1			 	must be null
				bne tsterr

				lda gbuf+4			 	test for header
				and #$E0
				cmp #$E0
				bne tsterr

H3770  			clc		 				no error
				rts
*--------------------------------------
MAN
SAVE USR/SRC/PRODOS.FX/PRODOS.S.XDOS.A
LOAD USR/SRC/PRODOS.FX/PRODOS.S
ASM