honeylisp/asm/prodos.fnl

359 lines
12 KiB
Plaintext
Raw Normal View History

(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))
2021-01-02 21:32:43 +00:00
(local lume (require :lib.lume))
(local prodos-mli :0xbf00)
(fn Prodos.install-words [vm]
(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)))
2021-01-02 21:32:43 +00:00
(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))))
2021-01-03 15:34:46 +00:00
(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 {})
2021-01-02 21:32:43 +00:00
(for [iblock 0 279]
(local (byte mask) (bit-in-bytes block iblock))
(when (~= (bit.band byte mask) 0)
2021-01-02 21:32:43 +00:00
(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]
2021-01-02 21:32:43 +00:00
(let [iblock (next (self:parse-bitmap))] iblock))
(fn Prodos.add-file-data [self bytes]
(assert (< (length bytes) 0xffff))
(if (> (length bytes) 512)
(let [index []]
(for [offset 1 (length bytes) 512]
(local iblock (self:add-file-data (bytes:gsub 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)))
2021-01-02 21:32:43 +00:00
(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))
(print (length file-entry) file-entry)
(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