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

core: Stage 2 Task 2 tier 5a — compile defmulti + defmethod

Browse source 
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).
This commit is contained in:
Yogthos 2026-06-09 16:47:45 -04:00
parent 63d92cd122
commit 3680ee6d58
6 changed files with 93 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

10
jolt-core/clojure/core/30-macros.clj
View file

@ -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]]

155
src/jolt/evaluator.janet
View file

@ -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)

3
src/jolt/host_iface.janet
View file

@ -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

2
src/jolt/loader.janet
View file

@ -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")))

11
test/integration/namespace-test.janet
View file

@ -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]

4
test/unit/evaluator-test.janet
View file

@ -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)"))