host.fst.aii

		include 'gsos.equ'
		include 'fst.equ'
		include	'fst.macros'
		include	'records.equ'


		longa	on
		longi	on
		string	asis

		entry	app_entry
		entry	sys_entry

		entry	rtl_no_error
		entry	sys_startup
		entry	sys_shutdown

		entry	check_path1, check_path2
		entry	build_vcr

		entry	fd_op_ro

		entry	create
		entry	destroy
		entry	change_path
		entry	set_file_info
		entry	get_file_info
		entry	judge_name
		entry	volume
		entry	open
		entry	close
		entry	read
		entry	write
		entry	flush
		entry	get_mark
		entry	set_mark
		entry	get_eof
		entry	set_eof
		entry	get_dir_entry
		entry	get_dev_num
		entry	format
		entry	erase_disk


		macro
&lab		call_host
&lab		dc.b $42, $ff
		endm

		macro
&lab		host_print
&lab		dc.b $42, $a0
		endm

		macro
&lab		host_hexdump
&lab		dc.b $42, $a1
		endm



header		proc
		str	'FST '
		dc.l	app_entry
		dc.l	sys_entry
		dc.w	fst_id

		dc.w	fst_attr	; attributes
		dc.w	$0100		; version
		dc.w	$0200 		; block size
		dc.l	$007FFFFF	; maximum volume size
		dc.l	1		; min volume size
		dc.l	$FFFFFFFF	; max file size
		dc.l	0 ; reserved
		str.b	'Host' ; name
		str.b	'Host FST              v01.00' ; comment
		dc.w	0 ; reserved
		; credits
		str.b	'Host FST written by Kelvin W Sherlock.'

		endp

data		record
		export dev_id
		; device id of the .host driver.
dev_id		dc.w 0

		export colon_host, colon_HOST, colon_Host
colon_host	str.w	':host'
colon_Host	str.w	':Host'
colon_HOST	str.w	':HOST'

		endr

sys_entry	proc

		phk
		plb
		long	m,x


		if 0 then
		; debug
		pha
		phx
		phy
		lda #$8001
		ldx #debugstr
		ldy #^debugstr
		host_print
		lda #$18
		ldx #$bd30
		ldy #$0000
		host_hexdump
		ply
		plx
		pla
		endif


		cpx #max_sys_call+1
		bge rtl_no_error

		jmp (@sys_table,x)

@sys_table
		dc.w rtl_no_error
		dc.w sys_startup
		dc.w sys_shutdown
		dc.w rtl_no_error	; remove vcr
		dc.w rtl_no_error	; deferred flush
max_sys_call	equ *-@sys_table-2

debugstr	str.b 'sys_entry'
		endp

rtl_no_error	proc
		lda #0
		clc
		rtl
		endp


rtl_invalid_fst_op	proc
		lda #invalid_fst_op
		sec
		rtl
		endp

rtl_bad_system_call	proc
		lda #bad_system_call
		sec
		rtl
		endp

rtl_invalid_pcount	proc
		lda #invalid_pcount
		sec
		rtl
		endp



find_host_device	proc
		with	dev_parms

		; find .host device.  if no .host, returns to gs/os.
		; entry via jsr
		; exit via rts (success) / sys_exit (fail).
		lda	dev_id
		beq	@search
		bmi	@fail
		rts
@fail		plx
		lda	#unknown_vol
		sec
		jml	sys_exit
@search
		lda	#-1
		sta	dev_id
		lda	#1
		sta	dev_dev_id
		stz	dev_num
@loop
		lda	#drvr_get_dib
		sta	dev_callnum
		jsl	dev_dispatcher
		bcs	@fail

		ldy	#$34 ; dib device id
		lda	[dev_dib_ptr],y
		cmp	#$10 ; file server
		bne	@next

		short	m
		ldy	#$0e ; name $04 H O S T
		lda	[dev_dib_ptr],y
		cmp	#$04
		bne	@next

		iny
		lda	[dev_dib_ptr],y
		cmp	#'H'
		bne	@next

		iny
		lda	[dev_dib_ptr],y
		cmp	#'O'
		bne	@next

		iny
		lda	[dev_dib_ptr],y
		cmp	#'S'
		bne	@next

		iny
		lda	[dev_dib_ptr],y
		cmp	#'T'
		bne	@next

		long	m
		lda	dev_dev_id
		sta	dev_id
		clc
		rts

@next
		long	m
		; try the next one.
		inc	dev_dev_id
		bra	@loop
		endp

sys_startup	proc


		stz dev_id

		; sanity check that the global buffer location
		; is where I expect it.
		jsl	get_sys_gbuf
		cpy	#$0000
		bne	no
		cpx	#$9a00
		bne	no

		; check if host wdm active.

		lda	#0
		sec
		ldx	#$8001
		call_host
		; wdm will clear carry if active.
		; if carry set, a <> 0, gs/os halts
		; "Sorry, system error $xxxx occurred while loading the FST file xxx"
		lda	#0
		rtl

no
		sec	; unload me!
		lda #0
		rtl
		endp

sys_shutdown	proc

		lda	#0
		clc
		ldx	#$8002
		call_host
		rtl
		endp



app_entry	proc


		with dp
		with fst_parms


		phk
		plb
		long	m,x


		if 0 then
		; debug
		pha
		phx
		phy
		lda #$8001
		ldx #debugstr
		ldy #^debugstr
		host_print
		lda #$18
		ldx #$bd30
		ldy #$0000
		host_hexdump

		lda path_flag
		and #$4000
		beq @xx

		lda #32
		ldx path1_ptr
		ldy path1_ptr+2
		host_hexdump

@xx
		ply
		plx
		pla
		;
		endif

		; x = call number * 2
		; y = call class * 2
		sty <call_class
		stx <tmp

		; debug saves all registers.
		IF DEBUG_S16 THEN
		jsr debug
		ENDIF

		
		; check the class 0 or 1 only.
		cpy	#2+1
		bge	@bad_system_call

		cpx	#max_app_call+1 ; 66+1
		bge	@bad_system_call

		; class 1 -- check the pcount maximum.
		cpy	#2
		bne	@ok

		lda	table,x
		and	#$00ff
		cmp	[param_blk_ptr]
		; gs/os already checks the minimum and verifies non-null names, etc.
		bcc	@invalid_pcount

@ok

		stz	my_fcr
		stz	my_fcr+2
		stz	my_vcr
		stz	my_vcr+2
		stz	cookie


		; check fcr bit.
		; n = fcr/vcr-based
		; v = path-based
		bit	table,x
		bmi	@vcr
		bvc	@call

@path
		; path checking...

		jsr	find_host_device
		jsr	check_path1
		bcc	@call
		jml	sys_exit

@vcr
		; deref vcr and fcr.
		ldx 	fcr_ptr
		ldy 	fcr_ptr+2
		jsl	deref
		stx	my_fcr
		sty	my_fcr+2
		ldy	#fcr.cookie
		lda	[my_fcr],y
		sta	cookie

		ldx 	vcr_ptr
		ldy 	vcr_ptr+2
		jsl	deref
		stx	my_vcr
		sty	my_vcr+2

@call
		; fake an rtl address for sys_exit
		; otherwise, would need to jml sys_exit from functions.
		pea	|(sys_exit-1)>>8
		phb
		lda	#<sys_exit-1
		sta	1,s

		; call it...
		ldx	<tmp
		jmp	(app_table,x)




@bad_system_call
		lda	#bad_system_call
		sec
		jml	sys_exit

@invalid_pcount
		lda	#invalid_pcount
		sec
		jml	sys_exit

@vol_not_found
		lda	#vol_not_found
		sec
		jml	sys_exit





app_table
		dc.w rtl_bad_system_call	; 
		dc.w create			; ($01) Create
		dc.w destroy			; ($02) Destroy
		dc.w rtl_bad_system_call	; ($03) OS Shutdown
		dc.w change_path		; ($04) Change Path
		dc.w set_file_info		; ($05) Set File Info
		dc.w get_file_info		; ($06) Get File Info
		dc.w judge_name			; ($07) Judge Name
		dc.w volume			; ($08) Volume
		dc.w rtl_bad_system_call	; ($09) Set Prefix
		dc.w rtl_bad_system_call	; ($0A) Get Prefix
		dc.w rtl_invalid_fst_op		; ($0B) Clear Backup Bit
		dc.w rtl_bad_system_call	; ($0C) Set Sys Prefs
		dc.w rtl_no_error		; ($0D) Null
		dc.w rtl_bad_system_call	; ($0E) Expand Path
		dc.w rtl_bad_system_call	; ($0F) Get Sys Prefs
		dc.w open			; ($10) Open
		dc.w rtl_bad_system_call	; ($11) NewLine
		dc.w read			; ($12) Read
		dc.w write			; ($13) Write
		dc.w close			; ($14) Close
		dc.w flush			; ($15) Flush
		dc.w set_mark			; ($16) Set Mark
		dc.w get_mark			; ($17) Get Mark
		dc.w set_eof			; ($18) Set EOF
		dc.w get_eof			; ($19) Get EOF
		dc.w rtl_bad_system_call	; ($1A) Set Level
		dc.w rtl_bad_system_call	; ($1B) Get Level
		dc.w get_dir_entry		; ($1C) Get Dir Entry
		dc.w rtl_bad_system_call	; ($1D) Begin Session
		dc.w rtl_bad_system_call	; ($1E) End Session
		dc.w rtl_bad_system_call	; ($1F) Session Status
		dc.w get_dev_num		; ($20) Get Dev Num
		dc.w rtl_bad_system_call	; ($21) Get Last Dev
		dc.w rtl_bad_system_call	; ($22) Read Block
		dc.w rtl_bad_system_call	; ($23) Write Block
		dc.w format			; ($24) Format
		dc.w erase_disk			; ($25) Erase Disk
		dc.w rtl_bad_system_call	; ($26) Reset Cache
		dc.w rtl_bad_system_call	; ($27) Get Name
		dc.w rtl_bad_system_call	; ($28) Get Boot Vol
		dc.w rtl_bad_system_call	; ($29) Quit
		dc.w rtl_bad_system_call	; ($2A) Get Version
		dc.w rtl_bad_system_call	; ($2B) Get FST Info
		dc.w rtl_bad_system_call	; ($2C) D_INFO
		dc.w rtl_bad_system_call	; ($2D) D_STATUS
		dc.w rtl_bad_system_call	; ($2E) D_CONTROL
		dc.w rtl_bad_system_call	; ($2F) D_READ
		dc.w rtl_bad_system_call	; ($30) D_WRITE
		dc.w rtl_bad_system_call	; ($31) Alloc Interrupt
		dc.w rtl_bad_system_call	; ($32) Dealloc Interrupt
		dc.w rtl_invalid_fst_op		; ($33) FST Specific
max_app_call	equ *-app_table-2



; insight - vcr and fcr always go together.
vcr_used	equ	$8000
fcr_used	equ	$0000
path_used	equ	$4000

table		; stores max pcount + 1
		dc.w	0
		dc.w	8+path_used			; ($01) Create
		dc.w	2+path_used			; ($02) Destroy
		dc.w	0				; ($03) OS Shutdown
		dc.w	4+path_used			; ($04) Change Path
		dc.w	13+path_used			; ($05) Set File Info
		dc.w	13+path_used			; ($06) Get File Info
		dc.w	7				; ($07) Judge Name
		dc.w	7				; ($08) Volume
		dc.w	0				; ($09) Set Prefix
		dc.w	0				; ($0A) Get Prefix
		dc.w	2+path_used			; ($0B) Clear Backup Bit
		dc.w	0				; ($0C) Set Sys Prefs
		dc.w	0				; ($0D) Null
		dc.w	0				; ($0E) Expand Path
		dc.w	0				; ($0F) Get Sys Prefs
		dc.w	16+path_used			; ($10) Open
		dc.w	0				; ($11) NewLine
		dc.w	6+vcr_used+fcr_used		; ($12) Read
		dc.w	6+vcr_used+fcr_used		; ($13) Write
		dc.w	2+vcr_used+fcr_used		; ($14) Close
		dc.w	3+vcr_used+fcr_used		; ($15) Flush
		dc.w	4+vcr_used+fcr_used		; ($16) Set Mark
		dc.w	3+vcr_used+fcr_used		; ($17) Get Mark
		dc.w	4+vcr_used+fcr_used		; ($18) Set EOF
		dc.w	3+vcr_used+fcr_used		; ($19) Get EOF
		dc.w	0				; ($1A) Set Level
		dc.w	0				; ($1B) Get Level
		dc.w	18+vcr_used+fcr_used		; ($1C) Get Dir Entry
		dc.w	0				; ($1D)
		dc.w	0				; ($1E)
		dc.w	0				; ($1F)
		dc.w	3+path_used			; ($20) Get Dev Num
		dc.w	0				; ($21) Get Last Dev
		dc.w	0				; ($22) Read Block
		dc.w	0				; ($23) Write Block
		dc.w	7+path_used			; ($24) Format
		dc.w	7+path_used			; ($25) Erase Disk
		dc.w	0				; ($26)
		dc.w	0				; ($27) Get Name
		dc.w	0				; ($28) Get Boot Vol
		dc.w	0				; ($29) Quit
		dc.w	0				; ($2A) Get Version
		dc.w	0				; ($2B) Get FST Info
		dc.w	0				; ($2C) D_INFO
		dc.w	0				; ($2D) D_STATUS
		dc.w	0				; ($2E) D_CONTROL
		dc.w	0				; ($2F) D_READ
		dc.w	0				; ($30) D_WRITE
		dc.w	0				; ($31) Alloc Interrupt
		dc.w	0				; ($32) Dealloc Interrupt
		dc.w	0				; ($33) FST Specific

debugstr	str.b 'app_entry'

		endp




close		proc
		with	dp, fst_parms

		lda	#invalid_fst_op
		ldx	call_number
		ldy	cookie
		sec
		call_host
		bcc	@ok
		rtl
@ok
		; destroy the fcr
		lda [my_fcr]
		jsl release_fcr

		; decrement vcr
		ldx vcr_ptr
		ldy vcr_ptr+2
		jsl deref
		stx my_vcr
		sty my_vcr+2


		ldy #vcr.open_count
		lda [my_vcr],y
		beq fatal
		dec a
		sta [my_vcr],y

		lda #0
		clc
		rtl

fatal
		lda #vcr_unusable
		jml sys_death

		endp

read		proc
		with	dp, fst_parms

		; slightly special since newline mode may be in effect.

		ldy	#fcr.mask
		lda	[my_fcr],y
		sta	>$009a00 ; hardcoded...
		beq	fd_op_ro

		; zero-out the table.
		ldx	#256-2
		lda	#0
@zloop
		sta >$009a00+2,x
		dex
		dex
		bpl @zloop

		; newline list is a virtual pointer.
		ldy #fcr.newline
		lda [my_fcr],y
		tax
		iny
		iny
		lda [my_fcr],y
		tay
		jsl deref
		stx ptr
		sty ptr+2

		ldy #fcr.newline_length
		lda [my_fcr],y
		tay
		dey

		ldx	#0
		lda	#0
		short	m
nloop
		lda	[ptr],y
		tax
		lda	#$ff
		sta	>$009a00+2,x
		dey
		bpl	nloop
		long	m

		bra	fd_op_ro

		endp

		macro
&lab		global
		export	&lab
&lab
		endm
fd_op_ro	proc


get_eof		global
get_mark	global
flush		global
get_dir_entry	global


		with dp, fst_parms

		; read, write, truncate, etc.
		; everything (except close) that uses an fcr.
		lda	#invalid_fst_op
		ldx	call_number
		ldy	cookie
		sec
		call_host
		rtl
		endp


fd_op_rw	proc

write		global
set_eof		global
set_mark	global

		with dp, fst_parms

		; read, write, truncate, etc.
		; everything (except close) that uses an fcr.
		lda	#invalid_fst_op
		ldx	call_number
		ldy	cookie
		sec
		call_host
		post_event
		rtl
		endp


path_op_ro	proc


get_file_info	global

		with	dp, fst_parms

		lda	#invalid_fst_op
		ldx	call_number
		sec
		call_host
		rtl

		endp

path_op_rw	proc

set_file_info	global
create		global
destroy		global
erase_disk	global
format		global

		with	dp, fst_parms

		lda	#invalid_fst_op
		ldx	call_number
		sec
		call_host
		post_event
		rtl

		endp


judge_name	proc

		with	dp, fst_parms

		; handle syntax message here. Need to return text pointer.
		lda	[param_blk_ptr]
		cmp	#3
		bcc	@no_syntax
		ldy	#JudgeNameRecGS.syntax
		lda	#syntax
		sta	[param_blk_ptr],y
		iny
		iny
		lda	#^syntax
		sta	[param_blk_ptr],y

@no_syntax

		lda	#invalid_fst_op
		ldx	call_number
		sec
		call_host
		rtl

syntax		str.b	'Names may contain any character except colon (:) or slash (/).'

		endp

change_path	proc

		with dp, fst_parms

		; todo -- verify both paths are on the device...

		jsr check_path1
		bcs exit
		jsr check_path2
		bcs exit


		lda	#invalid_fst_op
		ldx	call_number
		sec
		call_host
		post_event
exit
		rtl

		endp


volume		proc
		; check if a volume is ours, create vcr if necessary.

		with dp, fst_parms

		;
		; volume requires a device id. it doesn't fit
		; into the standard table so we check for the 
		; .host device here.
		;

		jsr	find_host_device
		lda	dev1_num
		beq	no

		cmp	dev_id
		bne	no
		; yes!

		lda	#unknown_vol
		ldx	call_number
		sec
		call_host
		bcc	@ok
		rtl
@ok
		; name is hardcoded to Host.
		jsr	build_vcr
		rtl


no
		lda #unknown_vol
		sec
		rtl

		endp

build_vcr	proc

		; for now, volume hard coded as 'Host'.


		with dp

		ldx #host_name
		ldy #^host_name
		lda #0
		jsl find_vcr
		bcs create_vcr
		stx my_vcr_ptr
		sty my_vcr_ptr+2
		jsl deref

		stx my_vcr
		sty my_vcr+2
		ldy #vcr.fst_id
		lda [my_vcr],y
		cmp #fst_id
		bne dump_vcr

		ldy #vcr.status
		lda [my_vcr],y
		and #vcr_swapped
		beq @exit

		and #vcr_swapped_in
		sta [my_vcr],y

		;lda device
		lda dev_id
		ldy #vcr.device
		sta [my_vcr],y

@exit
		lda #0
		clc
		rts

dump_vcr
		; vcr exists for the filename but it's not mine.
		; if inactive, kick it out.  otherwise, return dup error.

		;
		; todo -- prodos fst has kludge for change path which
		; allows duplicates if using a device name or something...
		;

		ldy #vcr.open_count
		lda [my_vcr],y
		beq @dump

		lda #dup_volume
		sec
		rts

@dump
		ldy #vcr.id
		lda [my_vcr],y
		jsl release_vcr
		; drop through.

create_vcr
		lda #vcr.__sizeof
		ldx #host_name
		ldy #^host_name
		jsl alloc_vcr
		stx my_vcr_ptr
		sty my_vcr_ptr+2

		lda #out_of_mem
		bcs exit

		jsl deref
		stx my_vcr
		sty my_vcr+2

		lda #0
		ldy #vcr.status
		sta [my_vcr],y
		ldy #vcr.open_count
		sta [my_vcr],y

		lda #fst_id
		ldy #vcr.fst_id
		sta [my_vcr],y

		lda dev_id
		ldy #vcr.device
		sta [my_vcr],y

		lda #0
		clc
exit
		rts

host_name
		str.w 'Host'

		endp

get_dev_num	proc
		with	dp, fst_parms

		; have already verified path is valid.
		lda	dev_id
		ldx	call_class
		ldy	table,x
		sta	[param_blk_ptr],y
		lda	#0
		clc
		rtl

table
		dc.w DevNumRec.devNum, DevNumRecGS.devNum

		endp

		;
		; verify this path is for us
		; (via dev number or :Host:)
		;
check_path1	proc

		with	dp, fst_parms

		lda	dev1_num
		beq	path
		cmp	dev_id
		beq	ok

vnf
		long	m
		lda	#unknown_vol
		sec
		rts

bps
		long	m
		lda	#bad_path_syntax
		sec
		rts

ok
		long	m
		lda	#0
		clc
		rts
path

		lda	path_flag
		and	#$4000
		beq	bps

		ldy	#2
		ldx	#0
		lda	#0
		short	m

loop
		lda	[path1_ptr],y
		cmp	colon_host,y
		beq	@next
		cmp	colon_HOST,y
		beq	@next
		bra	vnf
@next
		iny
		cpy	#5+2
		bne	loop

		; check for trailing null / :
		lda	[path1_ptr],y
		beq	@ok
		cmp	#':'
		beq	@ok

		bra	vnf
@ok
		bra	ok

		longa	on
		longi	on

		endp


check_path2	proc

		with	dp, fst_parms

		lda	dev2_num
		beq	path
		cmp	dev_id
		beq	ok

vnf
		long	m
		lda	#unknown_vol
		sec
		rts

bps
		long	m
		lda	#bad_path_syntax
		sec
		rts

ok
		long	m
		lda	#0
		clc
		rts
path

		lda	path_flag
		and	#$0040
		beq	bps

		ldy	#2
		ldx	#0
		lda	#0
		short	m

loop
		lda	[path2_ptr],y
		cmp	colon_host,y
		beq	@next
		cmp	colon_HOST,y
		bne	vnf
@next
		iny
		cpy	#5+2
		bne	loop

		; check for trailing null / :
		lda	[path2_ptr],y
		beq	@ok
		cmp	#':'
		beq	@ok

		bra	vnf
@ok
		bra	ok

		longa	on
		longi	on

		endp

open		proc


		with	dp, fst_parms

		jsr	build_vcr
		bcs	exit

		lda	#invalid_fst_op
		ldx	call_number
		sec
		call_host
		bcs	exit
		stx	cookie
		sty	tmp	; actual read/write access

		; build the fcr.
		lda	#fcr.__sizeof
		ldx	#colon_Host
		ldy	#^colon_Host
		jsl	alloc_fcr
		bcs	close

		jsl	deref
		stx	my_fcr
		sty	my_fcr+2

		; need to re-deref the vcr?
		; vcr_ptr is actually a pathname.
		ldx 	my_vcr_ptr
		ldy 	my_vcr_ptr+2
		jsl	deref
		stx	my_vcr
		sty	my_vcr+2


		ldy	#vcr.open_count
		lda	[my_vcr],y
		inc	a
		sta	[my_vcr],y

		lda	tmp
		ldy	#fcr.access
		sta	[my_fcr],y

		lda	#fst_id
		ldy	#fcr.fst_id
		sta	[my_fcr],y

		lda	cookie
		ldy	#fcr.cookie
		sta	[my_fcr],y


		ldy	#vcr.id
		lda	[my_vcr],y
		ldy	#fcr.vcr_id
		sta	[my_fcr],y

		; store the refnum for output.
		; conveniently, call_class is the offset.
		lda	[my_fcr]
		ldy	call_class
		sta	[param_blk_ptr],y

exit_ok
		lda	#0
		clc
exit
		rtl

close
		;; oops!  close it!
		lda	#0
		ldx	#$2014
		ldy	cookie
		call_host
		sec
		lda	#out_of_mem
		rtl

		endp


		end