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

NEW
  AUTO 3,1
*--------------------------------------
FCB.MAX			.EQ 8
FCB.ID				.EQ 0
FCB.DEVID			.EQ 1				d_dev -> d_dev+5
FCB.DIRHBLK			.EQ 2				2 bytes
FCB.DIREBLK			.EQ 4				2 bytes
FCB.DIRENUM			.EQ 6
FCB.STYPE			.EQ 7
FCB.F				.EQ 8
FCB.F.STMOD				.EQ %00001000
FCB.F.UMOD				.EQ %00010000
FCB.F.DBLKMOD			.EQ %01000000
FCB.F.IBLKMOD			.EQ %10000000
FCB.ACCESS			.EQ 9
FCB.NLBYTE			.EQ 10
FCB.BUFID			.EQ 11
FCB.1stBLK			.EQ 12				2 bytes
FCB.IBLK			.EQ 14				2 bytes
FCB.DBLK			.EQ 16				2 bytes
FCB.MARK			.EQ 18				3 bytes
FCB.EOF				.EQ 21				3 bytes
FCB.UBLK			.EQ 24				2 bytes

FCB.FLEVEL			.EQ 27
FCB.DIRTY			.EQ 28


FCB.NLMASK			.EQ 31
*
FCB				.EQ 32
*--------------------------------------
VCB.DEV				.EQ 16
VCB.OFCNT			.EQ 17
VCB.BMAP			.EQ 18				2 bytes
VCB.TBLK			.EQ 20				2 bytes
VCB.FBLK			.EQ 22				2 bytes
VCB.BMAPIDX			.EQ 24
*
VCB				.EQ 25
*--------------------------------------
XDOS.VCBPtr		.EQ XDOS.VCBs+0
XDOS.VCBDupFlag	.EQ XDOS.VCBs+1
XDOS.VCBDupEnt 	.EQ XDOS.VCBs+2
bmcnt			.EQ XDOS.VCBs+3
bmptr			.EQ XDOS.VCBs+4
basval			.EQ XDOS.VCBs+5
XDOS.VCB0		.EQ XDOS.VCBs+6			range $D906-$DA00
*--------------------------------------
* ZERO Page
*--------------------------------------
zpt				.EQ	$48					highly used zero page index pointer
datptr			.EQ	$4A					ptr to data area of buffer.
sos				.EQ	$4C					sos buffer pointer.
usrbuf			.EQ	$4E					data ptr in user buffer.
*--------------------------------------
XDOS.START		.PH XDOS

				.DO AUXLC=0

XDOS.MAIN		cld						no decimal.

				sty GP.MLIY				save x and y
				stx GP.MLIX

				ply						get processor status

				pla						find out the address of the caller
				sta ZP.A3L
				clc						preserve the address of the call spec.
				adc #$04
				sta GP.MLIRTN			last MLI call return address
				pla
				sta ZP.A3L+1
				adc #$00
				sta GP.MLIRTN+1

				phy						pull processor status
				
				.ELSE
				
XDOS.AUX		cld
				
				bit IO.RRAMWRAMBNK1
				sty GP.BNKBYT2

				stx GP.MLIEXIT.X+1

				tsx
				stx $100
				ldx	$101
				txs

				sec
				ror GP.MLIACTV

				pha

				lda GP.MLIEXIT.PCL+1
				sta ZP.A3L
				clc
				adc #$04
				sta GP.MLIEXIT.PCL+1
				lda GP.MLIEXIT.PCH+1
				sta ZP.A3L+1
				adc #$00
				sta GP.MLIEXIT.PCH+1
				
				.FIN
*--------------------------------------
				plp						to re-enable interrupts.
				cld						still no decimal
				stz	GP.ERROR			clear any previous errors.
				ldy #$01				find out if command is valid.
				lda	(ZP.A3L),y			get command #

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

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

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

				cmp (ZP.A3L)
				bne XDOS.BadCnt			error if wrong count.

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

				asl					 	carry set if BFMgr or DevMgr
				bpl .3
				bcs .4

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

.1				jmp GP.DISPATCH			P8 system death vector

.2				jsr GP.CLOCK		 	go read clock.
				bra XDOS.Exit			no errors possible

.3		 		lsr						shift back down for device manager.
				adc #$01				valid commands are 1 and 2.
				sta ZP.CMDNUM
				jsr XDOS.DevMgr			execute read or write request.
				bra XDOS.Exit

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

				jsr XDOS.BFMgr
*--------------------------------------
XDOS.Exit		stz GP.BUBIT			clear backup bit

				ldy GP.ERROR			P8 error code
				cpy #$01				if > 0 then set C
				tya						and set Z
				php						disable interrupts until exit complete.
				sei
				lsr GP.MLIACTV			indicate MLI done.

				ply						Get status register until return.

* Y = Status register
* A = MLI Error code
				
				.DO AUXLC=0

				ldx GP.MLIRTN+1			place last MLI call return address
				phx						on stack. return is done via 'rti'
				ldx GP.MLIRTN			so the status register is restored
				phx						at the same time, so

				phy						place status back on stack

				pha						Push return error, if any.

				ldx GP.MLIX				MLI X register savearea
				ldy GP.MLIY				MLI Y register savearea
				lda GP.BNKBYT1			restore language card status
				jmp GP.MLIEXIT			and return.
				
				.ELSE
				
				tsx
				stx $101
				ldx	$100
				txs
				jmp GP.MLIEXITX
				
				.FIN
*--------------------------------------
XDOS.NoDevice 	lda #MLI.E.NODEV		no device connected.
				jsr GP.SYSERR

XDOS.BadCall	lda #MLI.E.BADCALL
				.HS 2C					BIT ABS
XDOS.BadCnt		lda #MLI.E.BADCNT
				jsr XDOS.GoSysErr
				bra XDOS.Exit
*--------------------------------------
* ProDOS Device Manager
*--------------------------------------
XDOS.DevMgr		ldy #$05				the call spec for devices must

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

				ldx ZP.BUFPTR+1			buffer page
				stx usrbuf+1			to user buffer
				inx
				inx
				lda ZP.BUFPTR			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 XDOS.GoSysErr		conflicting with protected ram.

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

XDOS.GoSysErr	jsr GP.SYSERR
*--------------------------------------
XDOS.DevCall	php						do not allow interrupts.
				sei

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

				plp
				clc
				rts

.9				plp
				sec

XDOS.DevCall.RTS
				rts

XDOS.DevCall.Jmp
				jmp (GP.DEVPTRS,x)		goto driver (or error if no driver)
*--------------------------------------
* ProDOS interrupt manager
*--------------------------------------
XDOS.IntMgr		sta ZP.A4L				interrupt command
				lsr						allocate interrupt or deallocate?
				bcs .4					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	(ZP.A3L),y			must not be zero page.
				beq .3					error if it is.

				sta GP.IRQVs-2,x		save high address
				dey
				lda (ZP.A3L),y
				sta GP.IRQVs-3,x		and low address.
				txa						return interrupt # in range 1-4
				lsr
				dey
				sta (ZP.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
.3				lda #MLI.E.INVPARAM		invalid parameter.
				jsr GP.SYSERR

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

				cmp #$05				or > 4
				bcs .3

				asl
				tax

				stz GP.IRQVs-2,x
				stz GP.IRQVs-1,x
*				clc
				rts
*--------------------------------------
XDOS.SysErr		sta GP.ERROR			P8 error code
				plx
				plx						pop 1 level of return
				sec
				rts
*--------------------------------------
* $01 = more than 255 unclaimed irqs
* $0A = open file has no volume
* $0B = open file has no 1K buffer
* $0C = block allocation error.
*--------------------------------------
XDOS.SysDeath 	tax						death error code.
				sta IO.CLR80DISP		disable 80 col hardware.
				lda IO.SETTEXT			switch in text.
				lda XDOS.CortFlag		is this a Cortland?
				beq .1					if not, don't use super hires switch.

				stz IO.GS.NEWVIDEO		force off super hires.

.1	  			lda IO.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 GP.CLOCK			date/time

H3274  			jsr $FFFF				SELF MODIFIED : execute command
				bcc goodop

errorsys 		jsr GP.SYSERR

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 (ZP.A3L),y				low pointer address
				sta zpt

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

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

				stz prfxflg				assume prefix is in use.
				stz XDOS.PathBuf				mark XDOS.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 XDOS.PathBuf
				sta XDOS.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

				cmp #'z'+1
				bcs .1
				
				eor #$20				to uppercase
.1				.FIN

				sta XDOS.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
				.HS 2C

ptyperr			lda #MLI.E.UNSUPST		filetype error (not a directory)
pfxerr			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 XDOS.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 XDOS.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 GP.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 XDOS.PathBuf		is it a null pathname?
				bne pfxerr				error if not

				sty GP.NEWPFXPTR		fix appletalk PFI bug
				sty GP.PFXPTR
				clc						no error
				rts

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

				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 GP.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 GP.NEWPFXPTR
				sta GP.PFXPTR
				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 XDOS.PathBuf,y
				sta XDOS.PathBuf,x
				iny
				inx
				bne .1

				clc						good prefix
				rts
*--------------------------------------
XDOS.GetPrefix	clc						calc how big a buffer is needed.
				ldy #$01				get index to users pathname buffer
				lda (ZP.A3L),y
				sta usrbuf				user buffer ptr
				iny
				lda (ZP.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 pfxerr1

				ldy #$00				y = indirect index to user buffer.
				lda GP.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 XDOS.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 (ZP.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 XDOS.FCBs+FCB.ID,x
				bne errnoref
*--------------------------------------
XDOS.GetFCBBufX	lda XDOS.FCBs+FCB.BUFID,x	get page address of file buffer.

				tay						index into global buffer table.
				lda GB.BUFTABL-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 GB.BUFTABL-2,y			???? ALWAYS 0

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

				jsr XDOS.FCBDevIDSelect

				lda #XDOS.VCB0

fndfvol			tay						search for associated vcb
				lda XDOS.VCBs+VCB.DEV,y
				cmp XDOS.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 XDOS.VCBs,y				make sure this vcb is open.
				beq nxtfvol				branch if it is not active.

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

errnoref 		stz XDOS.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 (ZP.A3L),y				if 0 then cbytes=$100 else $010 for one
				and #$F0				device. mask out unused nibble.
				sta GP.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 GP.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 GP.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 XDOS.VCBPtr
				ldy XDOS.VCBs+VCB.OFCNT,x	don't take the vcb offline if
				bne online1.ERR			there are active files present.

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

				bra online1.ERR			branch if unable to read.

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

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

				lda XDOS.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 XDOS.VCBDupFlag		exits.
				bmi online1.ERR			branch if so.

.3  			ldx XDOS.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 XDOS.VCBDupEnt
				lda XDOS.VCBs+VCB.DEV,x
				sta (usrbuf),y
				stz XDOS.VCBDupFlag		clear duplicate flag.

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

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

.1  			lda XDOS.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 GP.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 (ZP.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 GP.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 ZP.BLKNUM			preserve disk address of current (last)
				pha						directory link, before allocating an
				lda ZP.BLKNUM+1			extended block.
				pha
				jsr alc1blk				allocate a block for extending directory
				plx
				stx ZP.BLKNUM+1			restore block addr of dir info in XDOS.GBuf
				plx
				stx ZP.BLKNUM
				bcs H351D				unable to allocate.

				sta XDOS.GBuf+2				save block address in y,a to
				sty XDOS.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 ZP.BLKNUM,x			prepare new directory block
				sta XDOS.GBuf,x				using current block as back link
				lda XDOS.GBuf+2,x
				sta ZP.BLKNUM,x			and save new block as next to be written
				dex
				bpl swpbloks

				inx						x = 0

clrdir 			stz XDOS.GBuf+2,x
				stz XDOS.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

				jsr XDOS.ZPT.InitGBuf

				ldx own_ent				and calc entry address.

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

				lda own_len				next entry address
				jsr XDOS.ZPT.NextA
				bra ocalc

H3584  			ldy #$13				index to block count
				clc

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 XDOS.GBuf

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

				ldy #$0B				move user specified date/time

cmvtime			lda (ZP.A3L),y				to directory.
				sta d_filid,y
				txa		 				if all 4 bytes of date/time = 0
				ora (ZP.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 GP.DATE,x			move current default date/time
				sta d_credt,x
				dex
				bpl mvdftime

cmvname			lda (ZP.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 XDOS.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 XDOS.PathBuf,x			move local name as filename
				sta d_stor,y

				dex
				dey
				bne crname

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

cmvauxid 		iny						move auxillary identification bytes
				lda (ZP.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 XDOS.GBuf+4,x
				dex
				bpl cmvheadr

				eor #$30
				sta XDOS.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 XDOS.GBuf+20,x

				lda xdosver,x
				sta XDOS.GBuf+32,x
				dex
				bpl cmvpass

				.ELSE
				lda #$75
				sta XDOS.GBuf+20

				ldx #XDOS.VolHdrDef.Cnt-1

.1				lda XDOS.VolHdrDef,x
				sta XDOS.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 XDOS.GBuf+39,x
				dex
				bpl cmvparnt

				lda h_entln				lastly, the length of parent's
				sta XDOS.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 ZP.BLKNUM
				sty ZP.BLKNUM+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
*--------------------------------------
MAN
SAVE usr/src/prodos.fx/prodos.s.xdos.a
LOAD usr/src/prodos.fx/prodos.s
ASM