From 3680ee6d589018f1694c7a68317663cc06cdf199 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Tue, 9 Jun 2026 16:47:45 -0400 Subject: [PATCH] =?UTF-8?q?core:=20Stage=202=20Task=202=20tier=205a=20?= =?UTF-8?q?=E2=80=94=20compile=20defmulti=20+=20defmethod?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit defmulti/defmethod become macros (30-macros) over ctx-capturing clojure.core fns (defmulti-setup/defmethod-setup, interned by install-stateful-fns!): - defmulti: (defmulti name dispatch & opts) -> (defmulti-setup 'name dispatch ~@opts). name quoted; dispatch + opts (:default/:hierarchy) evaluated. defmulti-setup builds the dispatch closure over the method table and interns the var (same hierarchy/default/cache behavior). - defmethod: (defmethod mm dval & fn-tail) -> (defmethod-setup 'mm dval (fn ~@fn-tail)). The method impl is now a COMPILED (fn …) (was an interpreted fn* eval). Auto-creates the multimethod if missing. - removed their special-symbol? entries + eval-list arms, and dropped them from host_iface special-names + loader stateful-head?. Both compile + interpret as plain invokes; dispatch incl. :default and derive/hierarchy works in both modes. Tests: evaluator-test (defmulti case) + namespace-test now use init (these forms are overlay macros now, so a bare make-ctx lacks them). Gate green: conformance 269x3, fallback-zero 38/4, bootstrap-fixpoint stage1==2==3, self-host, staged-bootstrap, sci-bootstrap, clojure-test-suite >=4034/67, features 78/78, all unit + spec (multimethods 16/16). --- jolt-core/clojure/core/30-macros.clj | 10 ++ src/jolt/evaluator.janet | 155 ++++++++++++-------------- src/jolt/host_iface.janet | 3 +- src/jolt/loader.janet | 2 +- test/integration/namespace-test.janet | 11 +- test/unit/evaluator-test.janet | 4 +- 6 files changed, 93 insertions(+), 92 deletions(-) diff --git a/jolt-core/clojure/core/30-macros.clj b/jolt-core/clojure/core/30-macros.clj index 8378619..cc1957f 100644 --- a/jolt-core/clojure/core/30-macros.clj +++ b/jolt-core/clojure/core/30-macros.clj @@ -12,6 +12,16 @@ (defmacro comment [& body] nil) +;; defmulti/defmethod are sugar over defmulti-setup/defmethod-setup (ctx-capturing +;; clojure.core fns) so they compile as plain invokes. name/mm are passed quoted; +;; the dispatch fn, options, and dispatch value evaluate normally, and the method +;; body becomes a compiled (fn …). +(defmacro defmulti [name dispatch & opts] + `(defmulti-setup (quote ~name) ~dispatch ~@opts)) + +(defmacro defmethod [mm dispatch-val & fn-tail] + `(defmethod-setup (quote ~mm) ~dispatch-val (fn ~@fn-tail))) + ;; Single arglist (Jolt defmacro is single-arity); the optional else defaults nil ;; via rest-destructuring. (defmacro if-not [test then & [else]] diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index a9b0d8c..8feb6ee 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -21,7 +21,7 @@ (= name "recur") (= name "throw") (= name "try") (= name "set!") (= name "var") (= name "locking") (= name "eval") - (= name "instance?") (= name "defmulti") (= name "defmethod") + (= name "instance?") (= name "deftype") (= name "new") (= name ".") (= name "var-get") (= name "var-set") (= name "var?") (= name "alter-var-root") (= name "find-var") (= name "intern") @@ -816,6 +816,72 @@ (ns-unmap ns (if (and (struct? sym) (= :symbol (sym :jolt/type))) (sym :name) (string sym)))))) nil) +(defn defmulti-setup + "(defmulti name dispatch & opts) — intern a multimethod var. A fn; name arrives + quoted, dispatch + opts (:default key, :hierarchy h) arrive evaluated. The + defmulti macro is the thin wrapper. Builds the dispatch closure over the method + table (shared with the var's :jolt/methods so defmethod adds to it)." + [ctx name-sym dispatch-raw & opts] + (def dispatch-fn (if (keyword? dispatch-raw) (fn [x] (get x dispatch-raw)) dispatch-raw)) + (def 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))) (+= i 2))) + dv)) + (def hierarchy + (do (var h nil) (var i 0) + (while (< i (length opts)) + (if (= :hierarchy (in opts i)) (do (set h (in opts (+ i 1))) (set i (length opts))) (+= i 2))) + h)) + (def ns (ctx-find-ns ctx (ctx-current-ns ctx))) + (def methods @{}) + (def dispatch-cache @{}) + (def mm-fn + (fn [& args] + (let [dv (apply dispatch-fn args) + method (get methods dv)] + (if method + (apply method args) + (let [cached (get dispatch-cache dv)] + (if cached + (apply cached args) + (let [h (or hierarchy the-global-hierarchy) + found (do (var f nil) (var i 0) + (let [ks (keys methods)] + (while (and (nil? f) (< i (length ks))) + (if (isa? h dv (in ks i)) (set f (get methods (in ks i)))) + (++ i))) + f)] + (if found + (do (put dispatch-cache dv found) (apply found args)) + (let [dm (get methods default-key)] + (if dm (apply dm args) + (error (string "No method in multimethod " (name-sym :name) + " for dispatch value: " dv)))))))))))) + (def v (ns-intern ns (name-sym :name) mm-fn)) + (put v :jolt/methods methods) + (put v :jolt/dispatch-cache dispatch-cache) + (put v :jolt/default default-key) + (when hierarchy (put v :jolt/hierarchy hierarchy)) + (var-get v)) + +(defn defmethod-setup + "(defmethod mm dispatch-val impl) — add a method to a multimethod. A fn; mm + arrives quoted, dispatch-val evaluated, impl is the COMPILED method fn (the + defmethod macro builds (fn …)). Auto-creates the multimethod if it's missing." + [ctx mm-sym dispatch-val impl] + (def mm-var + (or (resolve-var ctx @{} mm-sym) + (let [ns (ctx-find-ns ctx (ctx-current-ns ctx))] + (def v (ns-intern ns (mm-sym :name) (fn [& args] nil))) + (put v :jolt/methods @{}) + v))) + (def methods (or (get mm-var :jolt/methods) (let [m @{}] (put mm-var :jolt/methods m) m))) + (put methods dispatch-val impl) + (let [dc (get mm-var :jolt/dispatch-cache)] + (when dc (each k (keys dc) (put dc k nil)))) + mm-var) + (defn install-stateful-fns! "Intern ctx-capturing closures for the stateful primitives into clojure.core, so both the interpreter and the compiler reach them as ordinary fns. Called by @@ -836,6 +902,8 @@ (ns-intern core "use" (fn [& specs] (use-impl ctx ;specs))) (ns-intern core "import" (fn [& specs] (import-impl ctx ;specs))) (ns-intern core "refer-clojure" (fn [& args] (refer-clojure-impl ctx ;args))) + (ns-intern core "defmulti-setup" (fn [name-sym dispatch & opts] (defmulti-setup ctx name-sym dispatch ;opts))) + (ns-intern core "defmethod-setup" (fn [mm-sym dval impl] (defmethod-setup ctx mm-sym dval impl))) core) # Dispatch a special form by its string name. @@ -1297,88 +1365,9 @@ "clojure.lang.IPersistentSet" (set? val) "Object" true false))) - "defmulti" (let [name-sym (in form 1) - dispatch-fn (do - (def raw (eval-form ctx bindings (in form 2))) - (if (keyword? raw) - (fn [x] (get x raw)) - raw)) - # Parse options: :default dispatch-key (defaults to :default) - # and :hierarchy h - opts (tuple/slice form 3) - 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))) - (+= i 2))) dv) - hierarchy (do - (var h nil) (var i 0) - (while (< i (length opts)) - (if (= :hierarchy (in opts i)) - (do (set h (eval-form ctx bindings (in opts (+ i 1)))) (set i (length opts))) - (+= i 2))) h) - ns (ctx-find-ns ctx (ctx-current-ns ctx)) - methods @{} - # Cache for hierarchy-resolved dispatch values: the isa? walk - # over every method key is the expensive path (derive-based - # dispatch). Direct (get methods dv) hits stay uncached (already - # fast). Cleared in place when methods/prefs change (defmethod, - # prefer-method, remove-method, …) so a redef can't be hidden. - dispatch-cache @{} - mm-fn (fn [& args] - (let [dv (apply dispatch-fn args) - method (get methods dv)] - (if method - (apply method args) - (let [cached (get dispatch-cache dv)] - (if cached - (apply cached args) - # hierarchy-based match (explicit :hierarchy or - # the global hierarchy from derive) - (let [h (or hierarchy the-global-hierarchy) - found (do (var f nil) (var i 0) - (let [ks (keys methods)] - (while (and (nil? f) (< i (length ks))) - (if (isa? h dv (in ks i)) (set f (get methods (in ks i)))) - (++ i))) f)] - (if found - (do (put dispatch-cache dv 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))))))))))) ] - (def v (ns-intern ns (name-sym :name) mm-fn)) - (put v :jolt/methods methods) - (put v :jolt/dispatch-cache dispatch-cache) - (put v :jolt/default default-key) - (when hierarchy (put v :jolt/hierarchy hierarchy)) - (var-get v)) - "defmethod" (let [mm-sym (in form 1) - dispatch-val (eval-form ctx bindings (in form 2)) - # (defmethod mm dispatch [args] body...) — single-arity, or - # (defmethod mm dispatch ([args] body)...) — multi-arity. - # Build a fn* form and evaluate it (reuses arity dispatch - # and destructuring). - impl (eval-form ctx bindings - @[{:jolt/type :symbol :ns nil :name "fn*"} ;(tuple/slice form 3)]) - mm-var (resolve-var ctx bindings mm-sym) - # Auto-create multimethod if it doesn't exist - mm-var (if mm-var mm-var - (let [ns (ctx-find-ns ctx (ctx-current-ns ctx)) - dummy-fn (fn [& args] nil)] - (def v (ns-intern ns (mm-sym :name) dummy-fn)) - (put v :jolt/methods @{}) - v)) - # The resolved var may be a plain fn (e.g. a copy-core-var'd - # print-method) with no method table yet — initialize one. - methods (or (get mm-var :jolt/methods) - (let [m @{}] (put mm-var :jolt/methods m) m))] - (put methods dispatch-val impl) - (let [dc (get mm-var :jolt/dispatch-cache)] - (when dc (each k (keys dc) (put dc k nil)))) - mm-var) + # defmulti / defmethod are now macros (30-macros) over defmulti-setup / + # defmethod-setup (ctx-capturing clojure.core fns) — they compile as plain + # invokes; no special-form arms. defmethod's impl is a compiled (fn …). "prefer-method" (let [mm-arg (in form 1) mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type))) (resolve-var ctx bindings mm-arg) diff --git a/src/jolt/host_iface.janet b/src/jolt/host_iface.janet index 13a0780..992e87e 100644 --- a/src/jolt/host_iface.janet +++ b/src/jolt/host_iface.janet @@ -72,7 +72,8 @@ (let [t @{}] (each n ["quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def" "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" - "locking" "eval" "instance?" "defmulti" "defmethod" "deftype" "new" + # defmulti/defmethod now compile (macros over *-setup fns). + "locking" "eval" "instance?" "deftype" "new" "." "var-get" "var-set" "var?" "alter-var-root" "find-var" "intern" "alter-meta!" "reset-meta!" "satisfies?" # protocol-dispatch/register-method/make-reified are now clojure.core diff --git a/src/jolt/loader.janet b/src/jolt/loader.janet index c1223ec..671207d 100644 --- a/src/jolt/loader.janet +++ b/src/jolt/loader.janet @@ -14,7 +14,7 @@ # compile path; syntax-quote already compiles via the analyzer's `handled` set. (defn- stateful-head? [head-name] (or (= head-name "defmacro") - (= head-name "deftype") (= head-name "defmulti") (= head-name "defmethod") + (= head-name "deftype") (= head-name "set!") (= head-name ".") (= head-name "new") (= head-name "eval"))) diff --git a/test/integration/namespace-test.janet b/test/integration/namespace-test.janet index 6362cee..755128b 100644 --- a/test/integration/namespace-test.janet +++ b/test/integration/namespace-test.janet @@ -1,13 +1,12 @@ (use ../../src/jolt/reader) (use ../../src/jolt/types) (use ../../src/jolt/evaluator) +(import ../../src/jolt/api :as api) -# in-ns/require are now ordinary clojure.core fns (Stage 2 jolt-eaa), interned by -# install-stateful-fns! — api/init does this; a bare make-ctx must do it too. -(defn- fresh-ctx [] - (let [ctx (make-ctx)] - (install-stateful-fns! ctx) - ctx)) +# ns/in-ns/require/use are overlay macros + clojure.core fns now (Stage 2 jolt-eaa), +# so these interpreter tests need the full env (init loads the overlay + installs +# the stateful fns), not a bare make-ctx. +(defn- fresh-ctx [] (api/init)) # Helper: parse and eval in a fresh ctx (defn eval-str [s] diff --git a/test/unit/evaluator-test.janet b/test/unit/evaluator-test.janet index 3b216a3..22c099a 100644 --- a/test/unit/evaluator-test.janet +++ b/test/unit/evaluator-test.janet @@ -111,7 +111,9 @@ (print " passed") (print "15: defmulti/defmethod...") -(let [ctx (make-ctx)] +# defmulti/defmethod are overlay macros now (Stage 2 jolt-eaa), so this needs the +# full env (init loads the overlay + installs the *-setup fns), not a bare make-ctx. +(let [ctx (init)] (eval-form ctx @{} (parse-string "(defmulti my-dispatch (fn* [x] (x :type)))")) (eval-form ctx @{} (parse-string "(defmethod my-dispatch :foo [_] :got-foo)")) (eval-form ctx @{} (parse-string "(defmethod my-dispatch :bar [_] :got-bar)"))