SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

First cut at disk image generation; generated disk will not currently boot

Browse source
This commit is contained in:
Jeremy Penner 2021-01-02 14:47:57 -05:00
parent 264ce5d269
commit c508456325
9 changed files with 416 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

BIN
ProDOS_2_4_2.dsk Normal file
View file

Binary file not shown.

4
asm/asm.fnl
View file

@ -7,10 +7,10 @@
(let [ops
{:php 0x08 :plp 0x28 :pha 0x48 :pla 0x68 :dey 0x88 :tay 0xa8 :iny 0xc8 :inx 0xe8
:clc 0x18 :sec 0x38 :cli 0x58 :sei 0x78 :tya 0x98 :clv 0xb8 :cld 0xd8 :sed 0xf8
:txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :brk 0x00 :rti 0x40
:rts 0x60}]
:txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}]
(each [opcode byte (pairs ops)]
(tset opcodes opcode (fn [mode] (if mode nil byte)))))
(set opcodes.brk (fn [mode] (if (or (= mode :imm) (= mode nil)) 0x00 nil)))
; branch ops
(let [ops {:bpl 0x10 :bmi 0x30 :bvc 0x50 :bvs 0x70 :bcc 0x90 :bcs 0xb0 :bne 0xd0 :beq 0xf0}]

336
asm/prodos.fnl Normal file
View file

@ -0,0 +1,336 @@
(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 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)))))
(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 [ibit 0 280]
(local (byte mask) (bit-in-bytes block ibit))
(when (~= (bit.band byte mask) 0)
(tset bitmap ibit 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]
(next (self:parse-bitmap)))
(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.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

5
editor/tileedit.fnl
View file

@ -33,10 +33,7 @@
(bit.bor (if is-set orval 0))))
(fn set-tile-bit [tile ibyte ibit is-set]
(..
(tile:sub 1 ibyte)
(string.char (set-bit tile ibyte ibit is-set))
(tile:sub (+ ibyte 2))))
(util.splice tile ibyte (string.char (set-bit tile ibyte ibit is-set))))
(fn draw-bit-color [bit x y]
(local (bgcolor color) (tiledraw.pal-from-bit bit))

7
game/bosskey.fnl
View file

@ -47,17 +47,12 @@
(cells 16 ["TOTAL" style.inverse] "TOO MANY" ["* MAGIC *" style.flashing] "ALL@ONCE")
(cells 17) (cells 18) (cells 19) (cells 20)])
(fn splice [bytes offset str]
(.. (bytes:sub 1 offset)
str
(bytes:sub (+ (length str) offset 1))))
(fn bytes-from-lines [lines]
(var bytes (string.rep (astr " ") 0x400))
(each [y line (ipairs lines)]
(local offset (+ (* (math.floor (/ (- y 1) 8)) 0x28)
(* (% (- y 1) 8) 0x80)))
(set bytes (splice bytes offset line)))
(set bytes (util.splice bytes offset line)))
bytes)
(textorg:append [:bytes (bytes-from-lines (generate-boss-screen-lines))])

19
game/disk.fnl Normal file
View file

@ -0,0 +1,19 @@
(local asm (require :asm.asm))
(local Prodos (require :asm.prodos))
(local {: basic} (require :asm.tape))
(local prg (basic (asm.new)))
(local org (prg:org 0x801))
(org:append [:basic
[10 :print "\"HELLO FROM A GENERATED DISK IMAGE!\""]
[20 :goto :10]])
(prg:assemble)
(local disk (Prodos "ProDOS_2_4_2.dsk"))
(disk:add-file "STARTUP" Prodos.file-type.BAS 0x801 org.block.bytes)
(disk:update-volume-header {:name "NEUT.TOWER"})
(pp disk)
(disk:write "Test.dsk")

20
lib/util.fnl
View file

@ -13,6 +13,21 @@
(string.char (lo i)))
(fn int16-to-bytes [i]
(string.char (lo i) (hi i)))
(fn int24-to-bytes [i]
(string.char (lo i) (hi i) (bit.band (bit.rshift i 16) 0xff)))
(fn bytes-to-uint8 [b ?offset]
(string.byte b (+ 1 (or ?offset 0)) (+ 1 (or ?offset 0))))
(fn bytes-to-uint16 [b ?offset]
(local (lo hi) (string.byte b (+ 1 (or ?offset 0)) (+ 2 (or ?offset 0))))
(bit.bor lo (bit.lshift hi 8)))
(fn bytes-to-uint24 [b ?offset]
(local (lo mid hi) (string.byte b (+ 1 (or ?offset 0)) (+ 3 (or ?offset 0))))
(bit.bor lo (bit.lshift mid 8) (bit.lshift hi 16)))
(fn splice [bytes offset str]
(.. (bytes:sub 1 offset)
str
(bytes:sub (+ (length str) offset 1))))
(fn reload [modname]
(tset package.loaded modname nil)
@ -61,5 +76,8 @@
(fn in-coro [f ...] (-> (coroutine.create f) (coroutine.resume ...)))
{: lo : hi : int8-to-bytes : int16-to-bytes : reload : hotswap : swappable :require swappable-require : readjson : writejson : waitfor : in-coro}
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
: splice : lo : hi
: reload : hotswap : swappable :require swappable-require
: readjson : writejson : waitfor : in-coro}

2
link/serial.fnl
View file

@ -41,7 +41,7 @@
(set bytes-to-write (bytes-to-write:sub 11))
(set addrout (+ addrout 10))))
:monitor (fn [self] (self:cmd "CALL-151"))
:stub (fn [self org post-debug-stub]) ; todo
; :stub (fn [self org post-debug-stub]) ; todo
})
(command.add #(not (machine:connected?)) {

37
todo.txt
View file

@ -1,3 +1,40 @@
FLOPPY DISK IDEAS:
* I am not going to write my own DOS
* I will use ProDOS - BOOTI-compatible, modern
* ProDOS 2.4.2 - https://prodos8.com/
* Generate file(s) to be injected into a blank bootable ProDOS disk image
thinking:
neut.tower contains all code / data
loader.system contains a small program that maps offsets of 512-byte blocks to memory addresses
- is loaded to 0x2000 & will be wiped by gfx? No, PRODOS is loaded at $2000 and moved
- no, XXX.SYSTEM is loaded to 0x2000 as well
- Alternately, we could write one program that batch-loads the whole game into $2000 and moves it to where it belongs?
- How big is the game with all levels? Could we load the whole thing into consecutive memory starting at $4000?
- (I don't think this would work on 32kb tape-loaded machines...)
- With ProDOS I can assume 64kb
prodos claims:
$bf00-$ffff - ProDOS
$9600-$bf00 - BASIC.SYSTEM - don't care?
$0100-$0800 - "other use or reserved"
$3A-$3F - used by disk routines, unsafe
$40-$4F - used by ProDOS but preserved, safe to use
system bitmap: marks pages of memory as "not valid to allocate a file buffer"
- loader will have to protect memory that it will be moving game code to?
https://prodos8.com/docs/techref/calls-to-the-mli/
the existence of SET_BUF should mean we can load directly to the memory
we care about? orr I guess 512 bytes is housekeeping stuff (index block)
16kb version - $0000-$4000 - no we need at least 32kb
there's basically only 5kb of code space for an hgr game?
$0000-$03ff 0kb-1kb - zp, stack, input buffer, DOS
$0400-$07ff 1kb-2kb - text page 1
$0800-$0bff 2kb-3kb - text page 2
$0c00-$1fff 3kb-8kb - free space
$2000-$4000 8kb-16kb - hgr gfx page 1
Game:
* level loading
* Title screen