honeylisp/asm/prodos.fnl

(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.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))
  (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