360 lines
12 KiB
Fennel
360 lines
12 KiB
Fennel
(local Object (require :core.object))
|
|
(local Prodos (Object:extend))
|
|
(local {: bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
|
|
: int8-to-bytes : int16-to-bytes : int24-to-bytes
|
|
: splice : lo : hi} (require :lib.util))
|
|
(local lume (require :lib.lume))
|
|
|
|
(local prodos-mli :0xbf00)
|
|
(fn Prodos.str [str] [:block [:db (length str)] [:bytes str]])
|
|
(fn Prodos.install-words [vm]
|
|
(fn vm.pstr [self str] (self:anon (Prodos.str str)))
|
|
(fn prodos-call [cmd param-addr crash-on-fail]
|
|
[:block
|
|
[:jsr prodos-mli]
|
|
[:db cmd]
|
|
[:ref param-addr]
|
|
(when crash-on-fail
|
|
[:block
|
|
[:beq :success]
|
|
[:brk 0]
|
|
:success])])
|
|
(vm.code:append :currently-open-file [:db 0])
|
|
(vm:def :open ; filename buffer --
|
|
[:block
|
|
[:lda vm.ST1 :x] [:sta :open-param-filename]
|
|
[:lda vm.ST1H :x] [:sta :open-param-filename-hi]
|
|
[:lda vm.TOP :x] [:sta :open-param-buffer]
|
|
[:lda vm.TOPH :x] [:sta :open-param-buffer-hi]
|
|
(prodos-call 0xc8 :open-params true)
|
|
[:lda :open-param-refnum]
|
|
[:sta :currently-open-file]
|
|
(vm:drop) (vm:drop)])
|
|
(vm.code:append
|
|
:open-params [:db 3]
|
|
:open-param-filename [:db 0]
|
|
:open-param-filename-hi [:db 0]
|
|
:open-param-buffer [:db 0]
|
|
:open-param-buffer-hi [:db 0]
|
|
:open-param-refnum [:db 0])
|
|
|
|
(vm:def
|
|
[:block
|
|
:flush [:export :flush] ; --
|
|
[:lda 0xcd]
|
|
[:bne :prodos-flush-close]
|
|
:close [:export :close] ; --
|
|
[:lda 0xcc]
|
|
:prodos-flush-close
|
|
[:sta :fc-cmd]
|
|
[:lda :currently-open-file]
|
|
[:sta :fc-param-refnum]
|
|
[:jsr prodos-mli]
|
|
:fc-cmd [:db 0] [:ref :fc-params]
|
|
[:beq :success]
|
|
[:brk 0]
|
|
:success])
|
|
(vm.code:append
|
|
:fc-params [:db 1]
|
|
:fc-param-refnum [:db 0])
|
|
|
|
(vm:def
|
|
[:block
|
|
:write [:export :write] ; count buffer -- count
|
|
[:lda 0xcb]
|
|
[:bne :prodos-read-write]
|
|
:read [:export :read] ; count buffer -- count
|
|
[:lda 0xca]
|
|
:prodos-read-write
|
|
[:sta :rw-cmd]
|
|
[:lda :currently-open-file]
|
|
[:sta :rw-param-refnum]
|
|
[:lda vm.TOP :x] [:sta :rw-param-buffer]
|
|
[:lda vm.TOPH :x] [:sta :rw-param-buffer-hi]
|
|
[:lda vm.ST1 :x] [:sta :rw-param-count]
|
|
[:lda vm.ST1H :x] [:sta :rw-param-count-hi]
|
|
[:jsr prodos-mli]
|
|
:rw-cmd [:db 0] [:ref :rw-params]
|
|
[:beq :success]
|
|
[:cmp 0x4c]
|
|
[:beq :success]
|
|
[:brk 0]
|
|
:success
|
|
[:lda :rw-param-count-out] [:sta vm.ST1 :x]
|
|
[:lda :rw-param-count-out-hi] [:sta vm.ST1H :x]
|
|
(vm:drop)])
|
|
(vm.code:append
|
|
:rw-params [:db 4]
|
|
:rw-param-refnum [:db 0]
|
|
:rw-param-buffer [:db 0]
|
|
:rw-param-buffer-hi [:db 0]
|
|
:rw-param-count [:db 0]
|
|
:rw-param-count-hi [:db 0]
|
|
:rw-param-count-out [:db 0]
|
|
:rw-param-count-out-hi [:db 0])
|
|
|
|
; this does not handle files bigger than 64kb; I don't want or need to implement 24-bit numbers
|
|
(vm:def :seek ; position --
|
|
[:lda :currently-open-file]
|
|
[:sta :seek-param-refnum]
|
|
[:lda vm.TOP :x] [:sta :seek-param-position]
|
|
[:lda vm.TOPH :x] [:sta :seek-param-position-hi]
|
|
(prodos-call 0xce :seek-params true)
|
|
(vm:drop))
|
|
(vm.code:append
|
|
:seek-params [:db 2]
|
|
:seek-param-refnum [:db 0]
|
|
:seek-param-position [:db 0]
|
|
:seek-param-position-hi [:dw 0]))
|
|
|
|
(fn Prodos.new [self filename]
|
|
(local f (io.open filename :r))
|
|
(set self.bytes (f:read "*a"))
|
|
(f:close)
|
|
(assert (= (length self.bytes) 143360))
|
|
(self:parse-structure))
|
|
|
|
(fn Prodos.write [self filename]
|
|
(local f (io.open filename :w))
|
|
(f:write self.bytes)
|
|
(f:close))
|
|
|
|
(fn Prodos.sector-offset [self itrack isector]
|
|
(+ (* itrack 0x1000) (* isector 0x100)))
|
|
(fn Prodos.sector [self itrack isector]
|
|
(local offset (self:sector-offset itrack isector))
|
|
(self.bytes:sub (+ offset 1) (+ offset 0x100)))
|
|
|
|
(fn Prodos.set-sector [self itrack isector bytes]
|
|
(assert (<= (length bytes) 256))
|
|
(set self.bytes (splice self.bytes (+ (* itrack 0x1000) (* isector 0x100)) bytes)))
|
|
|
|
(local prodos-to-dos [0 14 13 12 11 10 9 8 7 6 5 4 3 2 1 15])
|
|
(fn Prodos.block-sectors [self index]
|
|
(local track (math.floor (/ index 8)))
|
|
(local iprodos (* (% index 8) 2))
|
|
(local isector1 (. prodos-to-dos (+ 1 iprodos)))
|
|
(local isector2 (. prodos-to-dos (+ 2 iprodos)))
|
|
(values track isector1 isector2))
|
|
|
|
(fn Prodos.block [self index]
|
|
(local (track isector1 isector2) (self:block-sectors index))
|
|
(.. (self:sector track isector1) (self:sector track isector2)))
|
|
|
|
(fn Prodos.set-block [self index bytes]
|
|
(local (track isector1 isector2) (self:block-sectors index))
|
|
(self:set-sector track isector1 (bytes:sub 1 256))
|
|
(self:set-sector track isector2 (bytes:sub 257 512))
|
|
(local bitmap (self:parse-bitmap))
|
|
(when (. bitmap index)
|
|
(tset bitmap index nil)
|
|
(self:set-bitmap bitmap)))
|
|
|
|
(fn Prodos.parse-entry [self bytes]
|
|
(local type_namelen (bytes-to-uint8 bytes 0))
|
|
(local entry-type (bit.rshift (bit.band type_namelen 0xf0) 4))
|
|
(local namelen (bit.band type_namelen 0x0f))
|
|
(local name (bytes:sub 2 (+ 1 namelen)))
|
|
(if (= entry-type 0x0f)
|
|
{: entry-type : name
|
|
:version (bytes-to-uint8 bytes 0x1c)
|
|
:min-version (bytes-to-uint8 bytes 0x1d)
|
|
:access (bytes-to-uint8 bytes 0x1e)
|
|
:entry-length (bytes-to-uint8 bytes 0x1f)
|
|
:entries-per-block (bytes-to-uint8 bytes 0x20)
|
|
:file-count (bytes-to-uint16 bytes 0x21)
|
|
:bitmap-pointer (bytes-to-uint16 bytes 0x23)
|
|
:total-blocks (bytes-to-uint16 bytes 0x25)}
|
|
{: entry-type : name
|
|
:file-type (bytes-to-uint8 bytes 0x10)
|
|
:key-pointer (bytes-to-uint16 bytes 0x11)
|
|
:blocks-used (bytes-to-uint16 bytes 0x13)
|
|
:eof (bytes-to-uint24 bytes 0x15)
|
|
:version (bytes-to-uint8 bytes 0x1c)
|
|
:min-version (bytes-to-uint8 bytes 0x1d)
|
|
:access (bytes-to-uint8 bytes 0x1e)
|
|
:aux-type (bytes-to-uint16 bytes 0x1f)
|
|
:header-pointer (bytes-to-uint16 bytes 0x25)}))
|
|
|
|
(fn Prodos.parse-directory [self iblock]
|
|
(local bytes (self:block iblock))
|
|
(local prev-block (bytes-to-uint16 bytes 0x00))
|
|
(local next-block (bytes-to-uint16 bytes 0x02))
|
|
(local entries [])
|
|
(for [offset 0x04 0x1ff 0x27]
|
|
(when (>= (length bytes) (+ offset 0x27))
|
|
(local entry (self:parse-entry (bytes:sub (+ offset 1) (+ offset 0x27))))
|
|
(set entry.entry-offset offset)
|
|
(table.insert entries entry)))
|
|
{: prev-block : next-block : entries})
|
|
|
|
(set Prodos.storage-type {
|
|
:deleted 0
|
|
:seedling 1
|
|
:sapling 2
|
|
:tree 3
|
|
:dir 13
|
|
:subdir-header 14
|
|
:volume-header 15
|
|
})
|
|
|
|
(set Prodos.file-type {
|
|
:none 0x00
|
|
:BAD 0x01
|
|
:TXT 0x04
|
|
:BIN 0x06
|
|
:DIR 0x0F
|
|
:ADB 0x19
|
|
:AWP 0x1a
|
|
:ASP 0x1b
|
|
:PAS 0xef
|
|
:CMD 0xf0
|
|
:BAS 0xfc
|
|
:VAR 0xfd
|
|
:REL 0xfe
|
|
:SYS 0xff
|
|
})
|
|
|
|
(fn Prodos.parse-structure [self]
|
|
(set self.files {})
|
|
(set self.next-free nil)
|
|
(set self.root nil)
|
|
(var iblock 2)
|
|
(while (~= iblock 0)
|
|
(local dir (self:parse-directory iblock))
|
|
(each [ientry entry (ipairs dir.entries)]
|
|
(match entry.entry-type
|
|
self.storage-type.volume-header (set self.root entry)
|
|
self.storage-type.deleted (set self.next-free {: entry : iblock : ientry})
|
|
_ (tset self.files entry.name {: entry : iblock : ientry})))
|
|
(set iblock dir.next-block))
|
|
self)
|
|
|
|
(fn Prodos.parse-index [self iblock]
|
|
(local block (self:block iblock))
|
|
(local index [])
|
|
(for [i 1 256]
|
|
(local lo (block:sub i i))
|
|
(local hi (block:sub (+ i 256) (+ i 256)))
|
|
(table.insert index (bytes-to-uint16 (.. lo hi))))
|
|
index)
|
|
|
|
(fn Prodos.set-index [self iblock index]
|
|
(var block "")
|
|
(for [i 1 256] (set block (.. block (string.char (lo (or (. index i) 0))))))
|
|
(for [i 1 256] (set block (.. block (string.char (hi (or (. index i) 0))))))
|
|
(self:set-block iblock block))
|
|
|
|
(fn bit-in-bytes [bytes ibit]
|
|
(local ibyte (math.floor (/ ibit 8)))
|
|
(local byte (string.byte (bytes:sub (+ ibyte 1) (+ ibyte 1))))
|
|
(local mask (bit.rshift 0x80 (% ibit 8)))
|
|
(values byte mask ibyte))
|
|
|
|
(fn Prodos.parse-bitmap [self]
|
|
(local block (self:block self.root.bitmap-pointer))
|
|
(local bitmap {})
|
|
(for [iblock 0 279]
|
|
(local (byte mask) (bit-in-bytes block iblock))
|
|
(when (~= (bit.band byte mask) 0)
|
|
(tset bitmap iblock true)))
|
|
bitmap)
|
|
|
|
(fn Prodos.set-bitmap [self bitmap]
|
|
(var block (string.rep "\0" 512))
|
|
(each [ibit f (pairs bitmap)]
|
|
(when (= f true)
|
|
(local (byte mask ibyte) (bit-in-bytes block ibit))
|
|
(set block (splice block ibyte (string.char (bit.bor byte mask))))))
|
|
(self:set-block self.root.bitmap-pointer block))
|
|
|
|
(fn Prodos.find-next-free-block [self]
|
|
(let [iblock (next (self:parse-bitmap))] iblock))
|
|
|
|
(fn Prodos.add-file-data [self bytes]
|
|
(assert (< (length bytes) 0xffff) (.. "Tried to add files containing " (length bytes) " bytes"))
|
|
(if (> (length bytes) 512)
|
|
(let [index []]
|
|
(for [offset 1 (length bytes) 512]
|
|
(local iblock (self:add-file-data (bytes:sub offset (+ offset 511))))
|
|
(table.insert index iblock))
|
|
(local iblock-index (self:find-next-free-block))
|
|
(self:set-index iblock-index index)
|
|
(values iblock-index self.storage-type.sapling (+ (length index) 1)))
|
|
|
|
(let [iblock-index (self:find-next-free-block)]
|
|
(self:set-block iblock-index bytes)
|
|
(values iblock-index self.storage-type.seedling 1))))
|
|
|
|
(fn Prodos.generate-file-entry [self iblock-parent filename type aux bytes]
|
|
(local (iblock storage-type block-count) (self:add-file-data bytes))
|
|
(..
|
|
(int8-to-bytes (bit.bor (bit.lshift storage-type 4) (length filename)))
|
|
filename
|
|
(string.rep "\0" (- 15 (length filename)))
|
|
(int8-to-bytes type)
|
|
(int16-to-bytes iblock)
|
|
(int16-to-bytes block-count)
|
|
(int24-to-bytes (length bytes))
|
|
"\0\0\0\0" ; created date
|
|
(int8-to-bytes 36) ; version
|
|
(int8-to-bytes 0) ; min-version
|
|
(int8-to-bytes 0x01) ; access (read-only, locked)
|
|
(int16-to-bytes aux) ; aux-type - generally load address
|
|
"\0\0\0\0" ; last modified date
|
|
(int16-to-bytes iblock-parent)))
|
|
|
|
(fn Prodos.blocks-from-entry [self entry]
|
|
(match entry.entry-type
|
|
self.storage-type.seedling [entry.key-pointer]
|
|
self.storage-type.sapling
|
|
(let [block-count (- entry.blocks-used 1)
|
|
index (self:parse-index entry.key-pointer)]
|
|
(lume.slice index 1 block-count))
|
|
_ []))
|
|
|
|
(fn Prodos.validate-entry [self entry]
|
|
(local bitmap (self:parse-bitmap))
|
|
(local blocks (self:blocks-from-entry entry))
|
|
(each [_ iblock (ipairs blocks)]
|
|
(when (. bitmap iblock)
|
|
(print (.. iblock " is used by " entry.name " but marked free"))
|
|
(self:set-block iblock (self:block iblock)))))
|
|
|
|
(fn Prodos.validate-entries [self]
|
|
(each [_ file (pairs self.files)] (self:validate-entry file.entry)))
|
|
|
|
(fn Prodos.generate-volume-header [self ?overrides]
|
|
(local overrides (or ?overrides {}))
|
|
(local name (or overrides.name self.root.name))
|
|
(..
|
|
(int8-to-bytes (bit.bor (bit.lshift self.storage-type.volume-header 4) (length name)))
|
|
name
|
|
(string.rep "\0" (- 15 (length name)))
|
|
"\0\0\0\0\0\0\0\0" ; reserved
|
|
"\0\0\0\0" ; created date
|
|
(int8-to-bytes 36) ; version
|
|
(int8-to-bytes 0) ; min-version
|
|
(int8-to-bytes 0x01) ; access (read-only, locked)
|
|
(int8-to-bytes 0x27)
|
|
(int8-to-bytes 0x0d)
|
|
(int16-to-bytes (or overrides.file-count self.root.file-count))
|
|
(int16-to-bytes (or overrides.bitmap-pointer self.root.bitmap-pointer))
|
|
(int16-to-bytes 280)))
|
|
|
|
(fn Prodos.update-volume-header [self ?overrides]
|
|
(local block (-> (self:block 2) (splice 4 (self:generate-volume-header ?overrides))))
|
|
(self:set-block 2 block)
|
|
(self:parse-structure))
|
|
|
|
(fn Prodos.add-file [self filename type aux bytes]
|
|
(assert self.next-free)
|
|
(local iblock self.next-free.iblock)
|
|
(var block (self:block iblock))
|
|
(local file-entry (self:generate-file-entry iblock filename type aux bytes))
|
|
(set block (splice block self.next-free.entry.entry-offset file-entry))
|
|
(self:set-block iblock block)
|
|
(self:update-volume-header {:file-count (+ self.root.file-count 1)}))
|
|
|
|
Prodos
|