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

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

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

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)
+    # defmulti / defmethod are now macros (30-macros) over defmulti-setup /
-                      dispatch-fn (do
+    # defmethod-setup (ctx-capturing clojure.core fns) — they compile as plain
-                                    (def raw (eval-form ctx bindings (in form 2)))
+    # invokes; no special-form arms. defmethod's impl is a compiled (fn …).
-                                    (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)
     "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)

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

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

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
+# ns/in-ns/require/use are overlay macros + clojure.core fns now (Stage 2 jolt-eaa),
-# install-stateful-fns! — api/init does this; a bare make-ctx must do it too.
+# so these interpreter tests need the full env (init loads the overlay + installs
-(defn- fresh-ctx []
+# the stateful fns), not a bare make-ctx.
-  (let [ctx (make-ctx)]
+(defn- fresh-ctx [] (api/init))
-    (install-stateful-fns! ctx)
-    ctx))
 
 # Helper: parse and eval in a fresh ctx
 (defn eval-str [s]

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