simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

fix: multimethod :default key dispatch (Clojure semantics); defrecord inline protocol methods with field scope; fix 2 phase5 tests to Clojure default-key semantics

Browse source
This commit is contained in:
Yogthos 2026-06-04 14:39:48 -04:00
parent fc6c630d5d
commit 73a9cb08f3
3 changed files with 56 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

34
src/jolt/core.janet
View file

@ -1639,10 +1639,42 @@
(def map-sym {:jolt/type :symbol :ns nil :name map-name}) (def map-sym {:jolt/type :symbol :ns nil :name map-name})
(def map-body @[{:jolt/type :symbol :ns nil :name "fn"} @[{:jolt/type :symbol :ns nil :name (string "m")}] map-call]) (def map-body @[{:jolt/type :symbol :ns nil :name "fn"} @[{:jolt/type :symbol :ns nil :name (string "m")}] map-call])
@[{:jolt/type :symbol :ns nil :name "do"} (def out @[{:jolt/type :symbol :ns nil :name "do"}
dt-form dt-form
@[{:jolt/type :symbol :ns nil :name "def"} arrow-sym arrow-body] @[{:jolt/type :symbol :ns nil :name "def"} arrow-sym arrow-body]
@[{:jolt/type :symbol :ns nil :name "def"} map-sym map-body]]) @[{:jolt/type :symbol :ns nil :name "def"} map-sym map-body]])
# Process inline protocol/interface implementations:
# (defrecord T [fs] Proto (m [this] body) ... Proto2 (m2 [this] body))
# Emit an extend-type per protocol. Each method body is wrapped in a let that
# binds the record's fields from the instance (first method param), matching
# Clojure's field-in-scope semantics for deftype/defrecord methods.
(var i 0)
(while (< i (length body))
(def elem (in body i))
(if (and (struct? elem) (= :symbol (elem :jolt/type)))
# protocol name; collect following method specs
(let [proto-sym elem
et @[{:jolt/type :symbol :ns nil :name "extend-type"} name-sym proto-sym]]
(++ i)
(while (and (< i (length body)) (not (and (struct? (in body i)) (= :symbol ((in body i) :jolt/type)))))
(let [spec (in body i)
mname (spec 0)
argv (spec 1)
mbody (tuple/slice spec 2)
instance (in argv 0)
# (let [f0 (core-get instance :f0) ...] body...)
field-binds @[]
_ (each f fields-vec
(array/push field-binds f)
(array/push field-binds @[{:jolt/type :symbol :ns nil :name "get"}
instance (keyword (f :name))]))
wrapped @[{:jolt/type :symbol :ns nil :name "let"}
(tuple/slice (tuple ;field-binds)) ;mbody]]
(array/push et @[mname argv wrapped]))
(++ i))
(array/push out et))
(++ i)))
out)
# resolve stub — returns nil (symbols not found in Jolt's clojure.core) # resolve stub — returns nil (symbols not found in Jolt's clojure.core)

35
src/jolt/evaluator.janet
View file

@ -860,10 +860,11 @@
(if (keyword? raw) (if (keyword? raw)
(fn [x] (get x raw)) (fn [x] (get x raw))
raw)) raw))
# Parse options: :default val and :hierarchy h # Parse options: :default dispatch-key (defaults to :default)
# and :hierarchy h
opts (tuple/slice form 3) opts (tuple/slice form 3)
default-val (do default-key (do
(var dv nil) (var i 0) (var dv :default) (var i 0)
(while (< i (length opts)) (while (< i (length opts))
(if (= :default (in opts i)) (if (= :default (in opts i))
(do (set dv (in opts (+ i 1))) (set i (length opts))) (do (set dv (in opts (+ i 1))) (set i (length opts)))
@ -881,23 +882,23 @@
method (get methods dv)] method (get methods dv)]
(if method (if method
(apply method args) (apply method args)
(if hierarchy # hierarchy-based match
(let [found (do (let [found (if hierarchy
(var f nil) (var i 0) (do (var f nil) (var i 0)
(let [ks (keys methods)] (let [ks (keys methods)]
(while (and (nil? f) (< i (length ks))) (while (and (nil? f) (< i (length ks)))
(if (isa? hierarchy dv (ks i)) (set f (get methods (ks i)))) (if (isa? hierarchy dv (ks i)) (set f (get methods (ks i))))
(++ i))) f)] (++ i))) f)
(if found (apply found args) nil)]
(if (not (nil? default-val)) default-val (if found (apply found args)
# fall back to the method registered under the default key
(let [dm (get methods default-key)]
(if dm (apply dm args)
(error (string "No method in multimethod " (error (string "No method in multimethod "
(name-sym :name) " for dispatch value: " dv))))) (name-sym :name) " for dispatch value: " dv)))))))))]
(if (not (nil? default-val)) default-val
(error (string "No method in multimethod "
(name-sym :name) " for dispatch value: " dv)))))))]
(def v (ns-intern ns (name-sym :name) mm-fn)) (def v (ns-intern ns (name-sym :name) mm-fn))
(put v :jolt/methods methods) (put v :jolt/methods methods)
(when default-val (put v :jolt/default default-val)) (put v :jolt/default default-key)
(when hierarchy (put v :jolt/hierarchy hierarchy)) (when hierarchy (put v :jolt/hierarchy hierarchy))
(var-get v)) (var-get v))
"defmethod" (let [mm-sym (in form 1) "defmethod" (let [mm-sym (in form 1)

5
test/phase5-test.janet
View file

@ -27,6 +27,9 @@
(let [ctx (init)] (let [ctx (init)]
(ct-eval ctx "(defmulti classify :type :default :unknown)") (ct-eval ctx "(defmulti classify :type :default :unknown)")
(ct-eval ctx "(defmethod classify :a [_] :alpha)") (ct-eval ctx "(defmethod classify :a [_] :alpha)")
# :default :unknown renames the catch-all dispatch key; a method must be
# registered under it (Clojure semantics).
(ct-eval ctx "(defmethod classify :unknown [_] :unknown)")
(assert (= :alpha (ct-eval ctx "(classify {:type :a})")) "known dispatch") (assert (= :alpha (ct-eval ctx "(classify {:type :a})")) "known dispatch")
(assert (= :unknown (ct-eval ctx "(classify {:type :z})")) "default fallback")) (assert (= :unknown (ct-eval ctx "(classify {:type :z})")) "default fallback"))
(print " passed") (print " passed")
@ -40,6 +43,8 @@
(ct-eval ctx "(defmulti animal-sound (fn [x] x) :default :unknown :hierarchy h)") (ct-eval ctx "(defmulti animal-sound (fn [x] x) :default :unknown :hierarchy h)")
(ct-eval ctx "(defmethod animal-sound ::animal [_] \"rawr\")") (ct-eval ctx "(defmethod animal-sound ::animal [_] \"rawr\")")
(ct-eval ctx "(defmethod animal-sound ::dog [_] \"woof\")") (ct-eval ctx "(defmethod animal-sound ::dog [_] \"woof\")")
# catch-all method registered under the renamed default key :unknown
(ct-eval ctx "(defmethod animal-sound :unknown [_] :unknown)")
(assert (= "woof" (ct-eval ctx "(animal-sound ::dog)")) "direct dispatch") (assert (= "woof" (ct-eval ctx "(animal-sound ::dog)")) "direct dispatch")
(assert (= "rawr" (ct-eval ctx "(animal-sound ::mammal)")) "hierarchy fallback") (assert (= "rawr" (ct-eval ctx "(animal-sound ::mammal)")) "hierarchy fallback")
(assert (= :unknown (ct-eval ctx "(animal-sound ::rock)")) "default fallback")) (assert (= :unknown (ct-eval ctx "(animal-sound ::rock)")) "default fallback"))