From 73a9cb08f3a44d9c39942b2432e2e3c27b01d8c1 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Thu, 4 Jun 2026 14:39:48 -0400 Subject: [PATCH] fix: multimethod :default key dispatch (Clojure semantics); defrecord inline protocol methods with field scope; fix 2 phase5 tests to Clojure default-key semantics --- src/jolt/core.janet | 34 +++++++++++++++++++++++++++++++++- src/jolt/evaluator.janet | 35 ++++++++++++++++++----------------- test/phase5-test.janet | 5 +++++ 3 files changed, 56 insertions(+), 18 deletions(-) diff --git a/src/jolt/core.janet b/src/jolt/core.janet index 084662a..7b019eb 100644 --- a/src/jolt/core.janet +++ b/src/jolt/core.janet @@ -1639,10 +1639,42 @@ (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]) - @[{:jolt/type :symbol :ns nil :name "do"} + (def out @[{:jolt/type :symbol :ns nil :name "do"} dt-form @[{:jolt/type :symbol :ns nil :name "def"} arrow-sym arrow-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) diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index 0647ae7..825931b 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -860,10 +860,11 @@ (if (keyword? raw) (fn [x] (get x 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) - default-val (do - (var dv nil) (var i 0) + default-key (do + (var dv :default) (var i 0) (while (< i (length opts)) (if (= :default (in opts i)) (do (set dv (in opts (+ i 1))) (set i (length opts))) @@ -881,23 +882,23 @@ method (get methods dv)] (if method (apply method args) - (if hierarchy - (let [found (do - (var f nil) (var i 0) - (let [ks (keys methods)] - (while (and (nil? f) (< i (length ks))) - (if (isa? hierarchy dv (ks i)) (set f (get methods (ks i)))) - (++ i))) f)] - (if found (apply found args) - (if (not (nil? default-val)) default-val + # hierarchy-based match + (let [found (if hierarchy + (do (var f nil) (var i 0) + (let [ks (keys methods)] + (while (and (nil? f) (< i (length ks))) + (if (isa? hierarchy dv (ks i)) (set f (get methods (ks i)))) + (++ i))) f) + nil)] + (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 " - (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)))))))] + (name-sym :name) " for dispatch value: " dv)))))))))] (def v (ns-intern ns (name-sym :name) mm-fn)) (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)) (var-get v)) "defmethod" (let [mm-sym (in form 1) diff --git a/test/phase5-test.janet b/test/phase5-test.janet index 42aac31..3e50742 100644 --- a/test/phase5-test.janet +++ b/test/phase5-test.janet @@ -27,6 +27,9 @@ (let [ctx (init)] (ct-eval ctx "(defmulti classify :type :default :unknown)") (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 (= :unknown (ct-eval ctx "(classify {:type :z})")) "default fallback")) (print " passed") @@ -40,6 +43,8 @@ (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 ::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 (= "rawr" (ct-eval ctx "(animal-sound ::mammal)")) "hierarchy fallback") (assert (= :unknown (ct-eval ctx "(animal-sound ::rock)")) "default fallback"))