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 >8 phb lda #$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