Factor out 6502 into its own module, generalize asm, complete 65816??

asm/6502.fnl

@@ -0,0 +1,125 @@
+(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
+
+(local opcodes {})
+
+; op mode arg
+; single-byte ops
+(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 :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}]
+  (each [opcode byte (pairs ops)]
+    (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
+(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
+
+; aaabbbcc ops
+(fn aaabbbcc [aaa cc modemap]
+  (local base (bit.bor cc (bit.lshift aaa 5)))
+  (fn [mode]
+    (local bbb (. modemap mode))
+    (if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
+
+(fn indexed-modes [...]
+  (let [modemap {}]
+    (each [index mode (pairs [...])]
+      (tset modemap mode (- index 1)))
+    modemap))
+
+(fn without-modes [modemap ...]
+  (let [newmodemap (lume.clone modemap)]
+    (each [_ mode (pairs [...])]
+      (tset newmodemap mode nil))
+    newmodemap))
+
+(fn only-modes [modemap ...]
+  (let [newmodemap {}]
+    (each [_ mode (pairs [...])]
+      (tset newmodemap mode (. modemap mode)))
+    newmodemap))
+
+; cc=1 ops
+(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
+      ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
+  (each [opcode aaa (pairs ops)]
+    (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
+  (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
+; cc=2 ops
+(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
+  (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
+    (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
+  (each [opcode aaa (pairs {:dec 6 :inc 7})]
+    (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
+(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
+(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
+
+; cc=0 ops
+(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
+  (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
+  (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
+  (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
+  (each [opcode aaa (pairs {:cpy 6 :cpx 7})]
+    (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
+(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
+
+(fn parse-mode-arg [op]
+  (match op
+    [_ :a] [:a nil]
+    ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
+    ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
+    [_ addr :x] [:addr-x addr]
+    [_ [addr] :y] [:zp*-y addr]
+    [_ addr :y] [:addr-y addr]
+    [_ [addr :x]] [:zp-x* addr]
+    ([_ addr] ? (= (type addr) "string")) [:addr addr]
+    [_ [addr]] [:abs* addr]
+    [_] [nil nil]
+    _ (error (.. "Unrecognized syntax" (fv op)))))
+
+(local op-pdat {})
+
+(fn is-zp? [env name]
+  (match (env:lookup-org name)
+    org (< org 0x100)))
+
+(fn op-pdat.patch [op env]
+  (when (and op.mode (= (op.mode:sub 1 4) :addr))
+    (let [zp-mode (.. :zp (op.mode:sub 5))
+          abs-mode (.. :abs (op.mode:sub 5))
+          is-zp (and ((. opcodes op.opcode) zp-mode) (is-zp? env op.arg))]
+      (set op.mode (if is-zp zp-mode abs-mode)))))
+
+(fn op-pdat.size [{: mode}]
+  (if
+    (or (= mode nil) (= mode :a)) 1
+    (= (mode:sub 1 3) :abs) 3
+    2))
+
+(fn op-pdat.bytes [op env]
+  (local bytegen (. opcodes op.opcode))
+;   (pp op)
+  (if bytegen
+    (let [opbyte (bytegen op.mode)
+          argbytes
+          (if
+            (and (= op.mode :imm) (= (type op.arg) "function"))
+            (int8-to-bytes (op.arg env))
+
+            (= op.mode :imm) (int8-to-bytes op.arg)
+            (= op.mode :rel)
+              (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
+            (= (op-pdat.size op) 2) (int8-to-bytes (env:lookup-addr op.arg))
+            (= (op-pdat.size op) 3) (int16-to-bytes (env:lookup-addr op.arg))
+            "")]
+      (if opbyte
+        (.. (int8-to-bytes opbyte) argbytes)
+        (error (.. op.opcode " doesn't support mode " op.mode))))
+    ""))
+
+
+{: opcodes : op-pdat : parse-mode-arg}

asm/65816.fnl

@@ -1,3 +1,5 @@
+(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
+
 (local opcodes {})
 
 ; http://www.oxyron.de/html/opcodes816.html
@@ -43,23 +45,16 @@
   (each [mnemonic modemap (pairs mnemonic-to-modemap)]
     (tset opcodes mnemonic (fn [mode] (. modemap (or mode :nil))))))
 
-(fn size [mode]
-  (match mode
-    (where (or :imm :sr :dp :dpx :dpy :idp :idx :idy :idl :idly :isy :rel)) 2
-    (where (or :abs :abx :aby :ind :iax :rell :bm)) 3
-    (where (or :abl :alx :ial)) 4
-    nil 1
-    _ (error (.. "unknown mode " mode))))
-
 (fn dp-addr [addr]
   (when (and (= (type addr) :string) (= (addr:sub 1 1) :d))
     (tonumber (addr:sub 2))))
+(fn addr-parser [addr] (or (dp-addr addr) (tonumber addr)))
 
 (fn parse-mode-arg [op]
   (match op
     (where [mvx srcbank dstbank]
-           (= (type srcbank) :number) (= (type dstbank :number)) (= (mvx:sub 1 2) :mv))
-       [:bm srcbank dstbank]
+           (= (type srcbank) :number) (= (type dstbank) :number) (= (mvx:sub 1 2) :mv))
+       [:bm [srcbank dstbank]]
     (where [_ imm] (or (= (type imm) :number) (= (type imm) :function))) [:imm imm]
     [_ offset :s] [:sr offset]
     [_ [[addr]] :y] [:idly addr]
@@ -86,7 +81,53 @@
     ; we'll assume local bank for now and fix up bankswitching in :patch
     [_ addr :x] [:abx addr]
     [_ addr] [:abs addr]
-    ))
+    [_] [nil nil]
+    _ (error (.. "Unrecognized syntax" (fv op)))))
 
 ; abl = $000000
 ; alx = $000000,X
+(local op-pdat {})
+(fn addr-page [addr] (math.floor (/ addr 0x10000)))
+(fn op-pdat.patch [op env]
+  (local long-mode (match op.opcode :abs :abl :abx :alx))
+  (when (and long-mode (not= (addr-page (env:lookup-org op.arg))
+                             (addr-page env.root-block.org)))
+    (set op.mode long-mode)))
+
+(fn op-pdat.size [op env]
+; TODO: handle 8-bit modes
+  (match op.mode
+    (where (or :sr :dp :dpx :dpy :idp :idx :idy :idl :idly :isy :rel)) 2
+    :imm 3 ;; todo: support 8-bit immediate mode
+    (where (or :abs :abx :aby :ind :iax :rell :bm)) 3
+    (where (or :abl :alx :ial)) 4
+    nil 1
+    _ (error (.. "unknown mode " op.mode))))
+(fn int24-to-bytes [i] (.. (int8-to-bytes (addr-page i)) (int16-to-bytes (bit.band i 0xffff))))
+
+(fn op-pdat.bytes [op env]
+  (local bytegen (. opcodes op.opcode))
+;   (pp op)
+  (if bytegen
+    (let [opbyte (bytegen op.mode)
+          argbytes
+          (if
+            (or (= op.mode :sr) (= op.mode :isy)) (int8-to-bytes op.arg)
+            (= op.mode :bm) (.. (int8-to-bytes (. op.arg 1)) (int8-to-bytes (. op.arg 2)))
+            (and (= op.mode :imm) (= (type op.arg) "function"))
+              (int16-to-bytes (op.arg env))
+            (= op.mode :imm) (int16-to-bytes op.arg)
+            (= op.mode :rel)
+              (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
+            (= op.mode :rell)
+              (int16-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 3)))
+            (= (op-pdat.size op) 2) (int8-to-bytes (env:lookup-addr op.arg))
+            (= (op-pdat.size op) 3) (int16-to-bytes (env:lookup-addr op.arg))
+            (= (op-pdat.size op) 4) (int24-to-bytes (env:lookup-addr op.arg))
+            "")]
+      (if opbyte
+        (.. (int8-to-bytes opbyte) argbytes)
+        (error (.. op.opcode " doesn't support mode " op.mode))))
+    ""))
+
+{: opcodes : parse-mode-arg : op-pdat : addr-parser}

asm/asm.fnl

@@ -1,98 +1,16 @@
 (local lume (require "lib.lume"))
 (local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
-(local opcodes {})
-
-; op mode arg
-; single-byte ops
-(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 :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}]
-  (each [opcode byte (pairs ops)]
-    (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
-(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
-
-; aaabbbcc ops
-(fn aaabbbcc [aaa cc modemap]
-  (local base (bit.bor cc (bit.lshift aaa 5)))
-  (fn [mode]
-    (local bbb (. modemap mode))
-    (if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
-
-(fn indexed-modes [...]
-  (let [modemap {}]
-    (each [index mode (pairs [...])]
-      (tset modemap mode (- index 1)))
-    modemap))
-
-(fn without-modes [modemap ...]
-  (let [newmodemap (lume.clone modemap)]
-    (each [_ mode (pairs [...])]
-      (tset newmodemap mode nil))
-    newmodemap))
-
-(fn only-modes [modemap ...]
-  (let [newmodemap {}]
-    (each [_ mode (pairs [...])]
-      (tset newmodemap mode (. modemap mode)))
-    newmodemap))
-
-; cc=1 ops
-(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
-      ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
-  (each [opcode aaa (pairs ops)]
-    (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
-  (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
-; cc=2 ops
-(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
-  (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
-    (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
-  (each [opcode aaa (pairs {:dec 6 :inc 7})]
-    (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
-(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
-(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
-
-; cc=0 ops
-(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
-  (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
-  (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
-  (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
-  (each [opcode aaa (pairs {:cpy 6 :cpx 7})]
-    (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
-(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
-
-(fn size [mode]
-  (if
-    (or (= mode nil) (= mode :a)) 1
-    (= (mode:sub 1 3) :abs) 3
-    2))
-(fn opsize [op] (if (= op.opcode :block) 0 (size op.mode)))
-
-(fn parse-mode-arg [op]
-  (match op
-    [_ :a] [:a nil]
-    ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
-    ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
-    [_ addr :x] [:addr-x addr]
-    [_ [addr] :y] [:zp*-y addr]
-    [_ addr :y] [:addr-y addr]
-    [_ [addr :x]] [:zp-x* addr]
-    ([_ addr] ? (= (type addr) "string")) [:addr addr]
-    [_ [addr]] [:abs* addr]
-    [_] [nil nil]
-    _ (error (.. "Unrecognized syntax" (fv op)))))
 
 (fn make-env [block parent]
   {:parent parent
+   :prg (or parent.prg parent)
+   :root-block (or parent.root-block block)
    :block block
-   ; todo: support local self-reference if org is set to zp
-   :is-zp? (fn [self name] (if (. self.block.symbols name) false (self.parent:is-zp? name)))
+   :lookup-org
+   (fn [self name]
+     (if (or (. self.block.symbols name) (. self.block.globals name))
+       self.root-block.org
+       (self.parent:lookup-org name)))
    :lookup-addr
    (fn [self name]
      (local ipdat (. self.block.symbols name))
@@ -110,7 +28,8 @@
 
        (self.parent:lookup-addr name)))})
 
-(fn program [prg-base]
+(fn program [prg-base ?processor]
+  (local {: opcodes : op-pdat : parse-mode-arg : addr-parser} (require (.. :asm. (or ?processor :6502))))
   ; dat - anything that takes up space in the assembled output (op, dw, db, etc)
   ;   takes the form [:op args]
   ; pdat - a parsed dat; takes the form {:type type :addr addr ...}
@@ -178,7 +97,7 @@
       preserve-block))
 
   (local pdat-processor {
-    :op {}
+    :op op-pdat
     :var {}
     :ref {}
     :raw {}
@@ -191,43 +110,17 @@
       (if ok (values ...)
           (do (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>") " - " ...)))))
     (local processor (. pdat-processor pdat.type process))
-    (if processor (complain (pcall #(processor pdat $...) ...)) default))
-
-  (fn pdat-processor.op.patch [op env]
-    (when (and op.mode (= (op.mode:sub 1 4) :addr))
-      (let [zp-mode (.. :zp (op.mode:sub 5))
-            abs-mode (.. :abs (op.mode:sub 5))
-            is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))]
-        (set op.mode (if is-zp zp-mode abs-mode)))))
+    (let [(a1 a2 a3 a4 a5) ...]
+      (if processor (complain (xpcall #(processor pdat a1 a2 a3 a4 a5) fennel.traceback)) default)))
+;     (if processor (complain (pcall #(processor pdat $...) ...)) default))
 
   (fn pdat-processor.raw.size [raw] (length raw.bytes))
-  (fn pdat-processor.op.size [op] (size op.mode))
   (fn pdat-processor.var.size [d] d.size)
   (fn pdat-processor.ref.size [r] 2)
   (fn pdat-processor.pad.size [pad]
     (let [misalignment (% pad.addr pad.align)]
       (if (= misalignment 0) 0
         (- pad.align misalignment))))
-  (fn pdat-processor.op.bytes [op env]
-    (local bytegen (. opcodes op.opcode))
-  ;   (pp op)
-    (if bytegen
-      (let [opbyte (bytegen op.mode)
-            argbytes
-            (if
-              (and (= op.mode :imm) (= (type op.arg) "function"))
-              (int8-to-bytes (op.arg env))
-
-              (= op.mode :imm) (int8-to-bytes op.arg)
-              (= op.mode :rel)
-                (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
-              (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg))
-              (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg))
-              "")]
-        (if opbyte
-          (.. (int8-to-bytes opbyte) argbytes)
-          (error (.. op.opcode " doesn't support mode " op.mode))))
-      ""))
   (fn pdat-processor.var.bytes [d env]
     (local init (match (type d.init)
                   :number d.init
@@ -297,7 +190,8 @@
      (var block (. self.org-to-block org))
      (when (not block)
        (set block (new-block))
-       (tset self.org-to-block org block))
+       (tset self.org-to-block org block)
+       (set block.org org))
      {: block
       : org
       :prg self
@@ -305,14 +199,8 @@
       :append (fn [self ...] (self.prg:dbg self.org ...) (parse-dats self.block [...]) self)})
    :parse-addr
    (fn [self name]
-     (local addr (tonumber name))
+     (local addr ((or addr-parser tonumber) name))
      (if addr addr (error (.. "Symbol '" name "' not found"))))
-   :is-zp?
-   (fn [self name]
-     (local org (. self.symbol-to-org name))
-     (if org (< org 0x100)
-         self.prg-base (self.prg-base:is-zp? name)
-       (< (self:parse-addr name) 0x100)))
    :env-lookup
    (fn [self name lookup ...]
      (local org (. self.symbol-to-org name))
@@ -324,6 +212,9 @@
    (fn [self name]
 ;       (print "looking up" name "in" self)
       (or (self:env-lookup name :lookup-addr) (self:parse-addr name)))
+   :lookup-org
+   (fn [self name]
+     (or (self:env-lookup name :lookup-org) (self:parse-addr name)))
    :pass
    (fn [self passname]
      (print passname)

main.lua

@@ -1,6 +1,7 @@
 -- bootstrap the compiler
 fennel = require("lib.fennel")
 table.insert(package.loaders, fennel.make_searcher())
+debug.traceback = fennel.traceback
 fv = fennel.view
 pp = function(x) print(fv(x)) end
 lume = require("lib.lume")