Upgrade to Fennel 1.3.0, z80 assembly support

asm/6502.fnl

@@ -81,6 +81,9 @@
     [_] [nil nil]
     _ (error (.. "Unrecognized syntax" (fv op)))))
 
+(fn parse-op [op]
+  (let [[mode arg] (parse-mode-arg op)] {: mode : arg}))
+
 (local op-pdat {})
 
 (fn is-zp? [env name]
@@ -122,4 +125,4 @@
     ""))
 
 
-{: opcodes : op-pdat : parse-mode-arg}
+{: opcodes : op-pdat : parse-op}

asm/65816.fnl

@@ -96,6 +96,9 @@
     [_] [nil nil]
     _ (error (.. "Unrecognized syntax" (fv op)))))
 
+(fn parse-op [op]
+  (let [[mode arg] (parse-mode-arg op)] {: mode : arg}))
+
 ; abl = $000000
 ; alx = $000000,X
 (local op-pdat {})
@@ -143,4 +146,4 @@
         (error (.. op.opcode " doesn't support mode " op.mode))))
     ""))
 
-{: opcodes : parse-mode-arg : op-pdat : addr-parser}
+{: opcodes : parse-op : op-pdat : addr-parser}

asm/asm.fnl

@@ -29,7 +29,7 @@
        (self.parent:lookup-addr name)))})
 
 (fn program [prg-base ?processor]
-  (local {: opcodes : op-pdat : parse-mode-arg : addr-parser} (require (.. :asm. (or ?processor :6502))))
+  (local {: opcodes : op-pdat : parse-op : 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 ...}
@@ -68,8 +68,7 @@
     block)
 
   (fn dat-parser.op [op]
-    (let [[mode arg] (parse-mode-arg op)]
+    (lume.extend {:type :op :opcode (. op 1)} (parse-op op)))
-      {:type :op :opcode (. op 1) : mode : arg}))
 
   (fn dat-parser.block [block]
     (let [dats (lume.clone block)]

asm/z80.fnl

@@ -0,0 +1,240 @@
+(local {: int8-to-bytes : int16-to-bytes} (require :lib.util))
+(local lume (require :lib.lume))
+(local fennel (require :lib.fennel))
+
+(local opcodes {})
+; http://www.z80.info/decoding.htm
+(fn argmatch [matcher arg]
+  (case (type matcher)
+    :function (matcher arg)
+    :table    (when (= (type arg) :table)
+                (accumulate [result {} i child (ipairs matcher) &until (= result nil)]
+                  (case (argmatch child (. arg i))
+                    argresult (lume.extend result argresult))))
+    _         (when (= matcher arg) {})))
+
+(fn comp-matchers [m1 m2] (fn [arg] (or (argmatch m1 arg) (argmatch m2 arg))))
+(fn rekey [matcher k knew]
+  (fn [arg] (match (matcher arg) {k val} {knew val})))
+
+(fn try-parse-op [op matchers prefixgen]
+  (when (= (length matchers) (- (length op) 1))
+    (let [params
+          (accumulate [result {} i matcher (ipairs matchers) &until (= result nil)]
+            (let [arg (. op (+ i 1))
+                  argresult (argmatch matcher arg)]
+              (when (not= argresult nil)
+                (lume.extend result argresult))))]
+      (when (not= params nil)
+        (case (prefixgen params)
+          prefix (lume.extend {: prefix} params))))))
+
+(fn chain-op [opcode f]
+  (let [prev (or (. opcodes opcode) #nil)]
+    (tset opcodes opcode
+      (fn [op] (case (prev op)
+                 result result
+                 nil    (f op))))))
+
+(fn opform [opcode matchers prefixgen]
+  (chain-op opcode #(try-parse-op $1 matchers prefixgen)))
+
+(fn is-addr? [param] (= (type param) :string))
+(fn addr [param] (when (is-addr? param) {:addr param}))
+(fn rel-addr [param] (when (is-addr? param) {:rel8 param}))
+(fn num [param] (when (= (type param) :number) {:num param}))
+(fn imm16 [param] (when (= (type param) :number) {:imm16 param}))
+(fn imm8 [param] (when (= (type param) :number) {:imm8 param}))
+
+(fn table-matcher [tbl key]
+  (let [lookup (collect [i val (ipairs tbl)] val (- i 1))]
+    (fn [param] (case (. lookup param) octet {key octet}))))
+
+(local cc (table-matcher [:nz :z :nc :c :po :pe :p :m] :cc))
+(local reg (comp-matchers (table-matcher [:b :c :d :e :h :l :*hl :a] :reg)
+                        #(when (argmatch [:hl] $1) {:reg 6})))
+(local rp (table-matcher [:bc :de :hl :sp] :rp))
+(local rp2 (table-matcher [:bc :de :hl :af] :rp))
+(fn im [arg] (match arg
+                0 {:im 0}
+                1 {:im 2}
+                2 {:im 3}
+                _ nil))
+
+(fn ix [arg]
+  (case arg
+    :ix {:ixprefix "\xdd"}
+    :iy {:ixprefix "\xfd"}))
+
+(fn def-alu [f]
+  (each [i opcode (ipairs [:add :adc :sub :sbc :and :xor :or :cp])]
+    (f opcode (- i 1))))
+(fn def-rot [f]
+  (each [i opcode (ipairs [:rlc :rrc :rl :rr :sla :sra :sll :srl])]
+    (f opcode (- i 1))))
+
+(fn xyz [x y z] (int8-to-bytes (bit.bor (bit.lshift x 6) (bit.lshift y 3) z)))
+(fn xpqz [x p q z] (int8-to-bytes (bit.bor (bit.lshift x 6) (bit.lshift p 4) (bit.lshift q 3) z)))
+
+(opform :nop [] #(xyz 0 0 0))
+(opform :ex [:af :af_] #(xyz 0 1 0))
+(opform :djnz [rel-addr] #(xyz 0 2 0))
+(opform :jr [rel-addr] #(xyz 0 3 0))
+(opform :jr [cc rel-addr] #(when (< $1.cc 4) (xyz 0 (+ $1.cc 4) 0)))
+(opform :ld [rp imm16] #(xpqz 0 $1.rp 0 1))
+(opform :add [:hl rp] #(xpqz 0 $1.rp 1 1))
+(opform :ld [[:bc] :a] #(xpqz 0 0 0 2))
+(opform :ld [[:de] :a] #(xpqz 0 1 0 2))
+(opform :ld [[addr] :hl] #(xpqz 0 2 0 2))
+(opform :ld [[addr] :a] #(xpqz 0 3 0 2))
+(opform :ld [:a [:bc]] #(xpqz 0 0 1 2))
+(opform :ld [:a [:de]] #(xpqz 0 1 1 2))
+(opform :ld [:hl [addr]] #(xpqz 0 2 1 2))
+(opform :ld [:a [addr]] #(xpqz 0 3 1 2))
+(opform :inc [rp] #(xpqz 0 $1.rp 0 3))
+(opform :dec [rp] #(xpqz 0 $1.rp 1 3))
+(opform :inc [reg] #(xyz 0 $1.reg 4))
+(opform :dec [reg] #(xyz 0 $1.reg 5))
+(opform :ld [reg imm8] #(xyz 0 $1.reg 6))
+(opform :rlca [] #(xyz 0 0 7))
+(opform :rrca [] #(xyz 1 0 7))
+(opform :rla [] #(xyz 2 0 7))
+(opform :rra [] #(xyz 3 0 7))
+(opform :daa [] #(xyz 4 0 7))
+(opform :cpl [] #(xyz 5 0 7))
+(opform :scf [] #(xyz 6 0 7))
+(opform :ccf [] #(xyz 7 0 7))
+(opform :ld [reg (rekey reg :reg :reg2)] #(when (or (not= $1.reg 6) (not= $1.reg 6))
+                                            (xyz 1 $1.reg $1.reg2)))
+(opform :halt [] #(xyz 1 6 6))
+(def-alu (fn [opcode alu] (opform opcode [reg] #(xyz 2 alu $1.reg))))
+(opform :ret [cc] #(xyz 3 $1.cc 0))
+(opform :pop [rp2] #(xpqz 3 $1.rp 0 1))
+(opform :ret [] #(xpqz 3 0 1 1))
+(opform :jp [:hl] #(xpqz 3 1 1 1))
+(opform :exx [] #(xpqz 3 2 1 1))
+(opform :ld [:sp :hl] #(xpqz 3 3 1 1))
+(opform :jp [cc addr] #(xyz 3 $1.cc 2))
+(opform :jp [addr] #(xyz 3 0 3))
+(opform :out [[imm8] :a] #(xyz 3 2 3))
+(opform :in [:a [imm8]] #(xyz 3 3 3))
+(opform :ex [[:sp] :hl] #(xyz 3 4 3))
+(opform :ex [:de :hl] #(xyz 3 5 3))
+(opform :di [] #(xyz 3 6 3))
+(opform :ei [] #(xyz 3 7 3))
+(opform :call [cc addr] #(xyz 3 $1.cc 4))
+(opform :push [rp2] #(xpqz 3 $1.rp 0 5))
+(opform :call [addr] #(xpqz 3 0 1 5))
+(def-alu (fn [opcode alu] (opform opcode [imm8] #(xyz 3 alu 6))))
+(opform :rst [num] #(xyz 3 (/ $1.num 8) 7))
+
+; DD / FD prefix
+(each [opcode prev (pairs opcodes)]
+  (tset opcodes opcode
+    (fn [op]
+      (case op
+        [:ex :de :ix] (error "EX DI, IX does not exist")
+        [:ex :de :iy] (error "EX DI, IY does not exist"))
+      (var prefix nil)
+      (var rel8 nil)
+      (fn rewrite [new-prefix new-val ?rel8]
+        (if (= prefix nil) (set prefix new-prefix)
+            (not= prefix new-prefix) (error "Can't mix IX and IY in one op"))
+        (if (and ?rel8 rel8) (error "Only one displacement is allowed")
+            ?rel8 (set rel8 ?rel8))
+        new-val)
+      (let [op-new (icollect [_ arg (ipairs op)]
+                      (case arg
+                        :ix (rewrite "\xdd" :hl)
+                        :iy (rewrite "\xfd" :hl)
+                        :ixl (rewrite "\xdd" :l)
+                        :iyl (rewrite "\xfd" :l)
+                        :ixh (rewrite "\xdd" :h)
+                        :iyh (rewrite "\xfd" :h)
+                        [:ix rel8] (rewrite "\xdd" [:hl] rel8)
+                        [:iy rel8] (rewrite "\xfd" [:hl] rel8)
+                        _ arg))
+            result (prev op-new)]
+        (if (= prefix nil) result
+            (= result nil) nil
+          (lume.extend result {: rel8 :prefix (.. prefix result.prefix)}))))))
+
+; CB prefix
+(def-rot (fn [opcode rot] (opform opcode [reg] #(.. "\xcb" (xyz 0 rot $1.reg)))))
+(opform :bit [num reg] #(.. "\xcb" (xyz 1 $1.num $1.reg)))
+(opform :res [num reg] #(.. "\xcb" (xyz 2 $1.num $1.reg)))
+(opform :set [num reg] #(.. "\xcb" (xyz 3 $1.num $1.reg)))
+; ED prefix
+(opform :in [reg [:c]] #(when (not= $1.reg 6) (.. "\xed" (xyz 1 $1.reg 0))))
+(opform :in [[:c]] #(.. "\xed" (xyz 1 6 0)))
+(opform :out [reg [:c]] #(when (not= $1.reg 6) (.. "\xed" (xyz 1 $1.reg 1))))
+(opform :out [[:c]] #(.. "\xed" (xyz 1 6 1)))
+(opform :sbc [:hl rp] #(.. "\xed" (xpqz 1 $1.rp 0 2)))
+(opform :adc [:hl rp] #(.. "\xed" (xpqz 1 $1.rp 1 2)))
+(opform :ld [[addr] rp] #(.. "\xed" (xpqz 1 $1.rp 0 3)))
+(opform :ld [rp [addr]] #(.. "\xed" (xpqz 1 $1.rp 1 3)))
+(opform :neg [] #(.. "\xed" (xyz 1 0 4)))
+(opform :retn [] #(.. "\xed" (xyz 1 0 5)))
+(opform :reti [] #(.. "\xed" (xyz 1 1 5)))
+(opform :im [im] #(.. "\xed" (xyz 1 $1.im 6)))
+(opform :ld [:i :a] #(.. "\xed" (xyz 1 0 7)))
+(opform :ld [:r :a] #(.. "\xed" (xyz 1 1 7)))
+(opform :ld [:a :i] #(.. "\xed" (xyz 1 2 7)))
+(opform :ld [:a :r] #(.. "\xed" (xyz 1 3 7)))
+(opform :rrd [] #(.. "\xed" (xyz 1 4 7)))
+(opform :rld [] #(.. "\xed" (xyz 1 5 7)))
+(opform :ldi [] #(.. "\xed" (xyz 2 4 0)))
+(opform :cpi [] #(.. "\xed" (xyz 2 4 1)))
+(opform :ini [] #(.. "\xed" (xyz 2 4 2)))
+(opform :outi [] #(.. "\xed" (xyz 2 4 3)))
+(opform :ldd [] #(.. "\xed" (xyz 2 5 0)))
+(opform :cpd [] #(.. "\xed" (xyz 2 5 1)))
+(opform :ind [] #(.. "\xed" (xyz 2 5 2)))
+(opform :outd [] #(.. "\xed" (xyz 2 5 3)))
+(opform :ldir [] #(.. "\xed" (xyz 2 6 0)))
+(opform :cpir [] #(.. "\xed" (xyz 2 6 1)))
+(opform :inir [] #(.. "\xed" (xyz 2 6 2)))
+(opform :otir [] #(.. "\xed" (xyz 2 6 3)))
+(opform :lddr [] #(.. "\xed" (xyz 2 7 0)))
+(opform :cpdr [] #(.. "\xed" (xyz 2 7 1)))
+(opform :indr [] #(.. "\xed" (xyz 2 7 2)))
+(opform :otdr [] #(.. "\xed" (xyz 2 7 3)))
+
+; DDCB / FDCB prefix
+(def-rot (fn [opcode rot]
+  (opform :ld [reg opcode [ix rel-addr]]
+          #(when (not= $1.reg 6) (.. $1.ixprefix "\xcb" (xyz 0 rot $1.reg))))
+  (opform opcode [[ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 0 rot 6)))))
+(opform :bit [num [ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 1 $1.num 0)))
+(opform :ld [reg :res num [ix rel-addr]]
+        #(when (not= $1.reg 6) (.. $1.ixprefix "\xcb" (xyz 2 $1.num $1.reg))))
+(opform :res [num [ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 2 $1.num 6)))
+(opform :ld [reg :set num [ix rel-addr]]
+        #(when (not= $1.reg 6) (.. $1.ixprefix "\xcb" (xyz 3 $1.num $1.reg))))
+(opform :set [num [ix rel-addr]] #(.. $1.ixprefix "\xcb" (xyz 3 $1.num 6)))
+
+(fn parse-op [[opcode &as op]]
+  (let [result ((. opcodes opcode) op)]
+    (if (= result nil) (error (.. "no such opcode " (fennel.view op)))
+        result)))
+
+(local op-pdat {})
+(fn op-pdat.size [op env]
+  (+ (length op.prefix)
+     (case op
+       {: addr}  2
+       {: rel8}  1
+       {: imm16} 2
+       {: imm8}  1
+       _         0)))
+
+(fn op-pdat.bytes [op env]
+  (.. op.prefix
+      (case op
+        {: addr}  (int16-to-bytes (env:lookup-addr addr))
+        {: rel8}  (int8-to-bytes (- (env:lookup-addr rel8) op.addr))
+        {: imm16} (int16-to-bytes imm16)
+        {: imm8}  (int8-to-bytes imm8)
+        _         "")))
+
+{: opcodes : parse-op : op-pdat : try-parse-op}

lib/stdio.fnl

@@ -1,5 +1,6 @@
 (require "love.event")
-(local view (require "lib.fennelview"))
+(local fennel (require "lib.fennel"))
+(local view fennel.view)
 
 ;; This module exists in order to expose stdio over a channel so that it
 ;; can be used in a non-blocking way from another thread.

vendor/lite/data/core/strict.lua

@@ -17,7 +17,7 @@ end
 
 
 function strict.__index(t, k)
-  if not strict.defined[k] then
+  if not strict.defined[k] and k ~= nil then
     error("cannot get undefined variable: " .. k, 2)
   end
 end