(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.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))) (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.lshift 1 (% 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)) (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))) (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