Stage2 task2 tier5 (#16)

* 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).

* core: Stage 2 Task 2 tier 5b — compile deftype + defrecord

deftype becomes a macro (30-macros) over make-deftype-ctor (a ctx-capturing
clojure.core fn that bakes the ns-qualified type tag at def time) plus
extend-type for any inline protocol methods — so it compiles as a plain (do …).
Mirrors defrecord's existing field-let/protocol-grouping pattern.
- make-deftype-ctor-impl (evaluator) builds the ctor; interned as a closure.
- removed the deftype special-symbol? entry + eval-list arm; dropped deftype/
  defrecord from host_iface special-names + loader stateful-head?.
- defrecord no longer redefines ->name via (Name. …) interop (frozen) — deftype
  already provides ->name, so defrecord compiles too (map->name builds via it).
- field-kws spliced into a vector LITERAL ([~@…]) so the analyzer sees a vector
  form, not a runtime pvec; type name + fields are unwrapped of ^meta (the reader
  yields (with-meta sym m) forms, e.g. sci's (deftype ^{:doc …} Var …)).

With tier 5a, all of deftype/defrecord/defmulti/defmethod compile. The loader's
interpret-only set is now just the frozen host-coupled forms: defmacro/set!/./
new/eval.

Tests: evaluator-test deftype case uses init (deftype is an overlay macro now);
fallback-zero moves deftype off must-punt, adds deftype/defrecord/defmulti/
defmethod to must-compile (43/3).

Gate green (full jpm build + jpm test): conformance 269x3, fallback-zero 43/3,
bootstrap-fixpoint stage1==2==3, self-host, staged-bootstrap, sci-bootstrap
422/0, clojure-test-suite >=4034/67, all unit + spec.

---------

Co-authored-by: Yogthos <yogthos@gmail.com>
This commit is contained in:
Dmitri Sotnikov 2026-06-10 08:13:42 +08:00 committed by GitHub
parent 63d92cd122
commit 11fb5a7de6
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
7 changed files with 156 additions and 162 deletions

View file

@ -12,6 +12,16 @@
(defmacro comment [& body] nil) (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 ;; Single arglist (Jolt defmacro is single-arity); the optional else defaults nil
;; via rest-destructuring. ;; via rest-destructuring.
(defmacro if-not [test then & [else]] (defmacro if-not [test then & [else]]
@ -149,6 +159,37 @@
(conj (pop acc) (conj (peek acc) x)))) (conj (pop acc) (conj (peek acc) x))))
[] items)) [] items))
;; deftype is sugar over make-deftype-ctor (a ctx-capturing clojure.core fn that
;; bakes the ns-qualified type tag at def time) plus extend-type for any inline
;; protocol methods — so it compiles as a plain (do …). Each method body sees the
;; type's fields, bound from the instance (the method's first param), matching
;; Clojure's deftype scope. defrecord (below) expands to a bodyless (deftype …) and
;; handles its own methods, so this also serves the no-body case.
(defmacro deftype [tname fields & body]
;; strip ^meta off the type name and fields (the reader yields a (with-meta sym m)
;; form for e.g. (deftype ^{:doc …} Foo …)), so (name …) sees a bare symbol.
(let [unwrap (fn [x] (if (and (seq? x) (symbol? (first x)) (= "with-meta" (name (first x))))
(second x) x))
tname (unwrap tname)
fields (map unwrap fields)
arrow (symbol (str "->" (name tname)))
;; a seq of field keywords; spliced into a vector LITERAL below ([~@…]) so
;; the analyzer sees a vector form, not a runtime pvec value.
field-kws (map (fn [f] (keyword (name f))) fields)
impl (fn [proto specs]
`(extend-type ~tname ~proto
~@(map (fn [spec]
(let [argv (nth spec 1)
inst (first argv)
binds (vec (mapcat (fn [f] [f `(get ~inst ~(keyword (name f)))]) fields))]
`(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec)))))
specs)))]
`(do
(def ~tname (make-deftype-ctor (quote ~tname) [~@field-kws]))
(def ~arrow ~tname)
~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body))
~tname)))
;; The protocol value is built by make-protocol (a fn call) rather than an embedded ;; The protocol value is built by make-protocol (a fn call) rather than an embedded
;; tagged map literal: the interpreter would otherwise self-evaluate such a struct ;; tagged map literal: the interpreter would otherwise self-evaluate such a struct
;; instead of evaluating its fields. methods is a {kw {:name str}} map (only :name ;; instead of evaluating its fields. methods is a {kw {:name str}} map (only :name
@ -203,7 +244,6 @@
(defmacro defrecord [name-sym fields & body] (defmacro defrecord [name-sym fields & body]
(let [tn (name name-sym) (let [tn (name name-sym)
dot (symbol (str tn "."))
arrow (symbol (str "->" tn)) arrow (symbol (str "->" tn))
mapf (symbol (str "map->" tn)) mapf (symbol (str "map->" tn))
m (fresh-sym) m (fresh-sym)
@ -219,8 +259,9 @@
`(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec))))) `(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec)))))
specs)))] specs)))]
`(do `(do
;; deftype already defines ->name (= the ctor); no (name. …) interop needed,
;; so defrecord compiles too. map->name builds via that ctor.
(deftype ~name-sym ~fields) (deftype ~name-sym ~fields)
(def ~arrow (fn* ~fields (~dot ~@fields)))
(def ~mapf (fn* [~m] (~arrow ~@(map (fn [f] `(get ~m ~(keyword (name f)))) fields)))) (def ~mapf (fn* [~m] (~arrow ~@(map (fn [f] `(get ~m ~(keyword (name f)))) fields))))
~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body))))) ~@(map (fn [g] (impl (first g) (rest g))) (group-by-head body)))))

View file

@ -21,8 +21,8 @@
(= name "recur") (= name "throw") (= name "try") (= name "recur") (= name "throw") (= name "try")
(= name "set!") (= name "var") (= name "locking") (= name "set!") (= name "var") (= name "locking")
(= name "eval") (= name "eval")
(= name "instance?") (= name "defmulti") (= name "defmethod") (= name "instance?")
(= name "deftype") (= name "new") (= name ".") (= name "new") (= name ".")
(= name "var-get") (= name "var-set") (= name "var?") (= name "var-get") (= name "var-set") (= name "var?")
(= name "alter-var-root") (= name "find-var") (= name "intern") (= name "alter-var-root") (= name "find-var") (= name "intern")
(= name "alter-meta!") (= name "reset-meta!") (= name "alter-meta!") (= name "reset-meta!")
@ -816,6 +816,87 @@
(ns-unmap ns (if (and (struct? sym) (= :symbol (sym :jolt/type))) (sym :name) (string sym)))))) (ns-unmap ns (if (and (struct? sym) (= :symbol (sym :jolt/type))) (sym :name) (string sym))))))
nil) 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 make-deftype-ctor-impl
"Build a deftype constructor closure. The ns-qualified type tag is baked at
definition time (this runs during the deftype's (def …), in the type's ns), so
instances carry a stable tag matching what extend-type registers methods under.
field-kws is the [:f1 :f2 …] keyword vector; the ctor maps positional args to
those keys. A ctx-capturing closure (make-deftype-ctor) is the public handle."
[ctx type-name-sym field-kws]
(def type-tag (string (ctx-current-ns ctx) "." (type-name-sym :name)))
(def kws (d-realize field-kws))
(fn [& args]
(var inst @{:jolt/deftype type-tag})
(var i 0)
(each kw kws (put inst kw (in args i)) (++ i))
inst))
(defn install-stateful-fns! (defn install-stateful-fns!
"Intern ctx-capturing closures for the stateful primitives into clojure.core, so "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 both the interpreter and the compiler reach them as ordinary fns. Called by
@ -836,6 +917,9 @@
(ns-intern core "use" (fn [& specs] (use-impl ctx ;specs))) (ns-intern core "use" (fn [& specs] (use-impl ctx ;specs)))
(ns-intern core "import" (fn [& specs] (import-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 "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)))
(ns-intern core "make-deftype-ctor" (fn [name-sym field-kws] (make-deftype-ctor-impl ctx name-sym field-kws)))
core) core)
# Dispatch a special form by its string name. # Dispatch a special form by its string name.
@ -1297,88 +1381,9 @@
"clojure.lang.IPersistentSet" (set? val) "clojure.lang.IPersistentSet" (set? val)
"Object" true "Object" true
false))) 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) "prefer-method" (let [mm-arg (in form 1)
mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type))) mm-var (if (and (struct? mm-arg) (= :symbol (mm-arg :jolt/type)))
(resolve-var ctx bindings mm-arg) (resolve-var ctx bindings mm-arg)
@ -1430,64 +1435,8 @@
(let [dc (get mm-var :jolt/dispatch-cache)] (let [dc (get mm-var :jolt/dispatch-cache)]
(when dc (each k (keys dc) (put dc k nil))))) (when dc (each k (keys dc) (put dc k nil)))))
mm-var) mm-var)
"deftype" (let [raw-name (in form 1) # deftype is now a macro (30-macros) over make-deftype-ctor + extend-type —
type-name (unwrap-meta-name raw-name) # compiles as a plain (do …); no special-form arm.
fields-vec (in form 2)
field-names (map
(fn [f]
# Handle ^:meta and ^Type annotations — extract the actual name
(let [f (unwrap-meta-name f)]
(if (and (struct? f) (= :symbol (f :jolt/type)))
(keyword (f :name))
(error (string "Unsupported deftype field: " (string f))))))
fields-vec)
ns-name (ctx-current-ns ctx)
type-tag (string ns-name "." (type-name :name))]
(defn ctor [& args]
(var inst @{:jolt/deftype type-tag})
(var i 0)
(each fn field-names
(put inst fn (args i))
(++ i))
inst)
(let [ns (ctx-find-ns ctx ns-name)
ctor-name (type-name :name)
arrow-name (string "->" ctor-name)]
(ns-intern ns ctor-name ctor)
(ns-intern ns arrow-name ctor)
# Process inline protocol/interface methods (like defrecord):
# (deftype T [fs] Proto (m [this] body) Proto2 (m2 [this] body))
# Emit one extend-type per protocol, wrapping each method body in a
# let that binds the type's fields from the instance (first param),
# matching Clojure's field-in-scope semantics.
(let [body (tuple/slice form 3)
field-syms (map unwrap-meta-name fields-vec)]
(var bi 0)
(while (< bi (length body))
(def elem (in body bi))
(if (and (struct? elem) (= :symbol (elem :jolt/type)))
(let [proto-sym elem
et @[{:jolt/type :symbol :ns nil :name "extend-type"} type-name proto-sym]]
(++ bi)
(while (and (< bi (length body))
(not (and (struct? (in body bi)) (= :symbol ((in body bi) :jolt/type)))))
(let [spec (in body bi)
mname (in spec 0)
argv (in spec 1)
mbody (tuple/slice spec 2)
instance (in argv 0)
field-binds @[]
_ (each f field-syms
(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]))
(++ bi))
(eval-form ctx bindings et))
(++ bi))))
(var-get (ns-intern ns ctor-name))))
"new" (let [type-sym (in form 1) "new" (let [type-sym (in form 1)
args (map |(eval-form ctx bindings $) (tuple/slice form 2)) args (map |(eval-form ctx bindings $) (tuple/slice form 2))
ctor (eval-form ctx bindings type-sym)] ctor (eval-form ctx bindings type-sym)]

View file

@ -72,7 +72,8 @@
(let [t @{}] (let [t @{}]
(each n ["quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def" (each n ["quote" "syntax-quote" "unquote" "unquote-splicing" "do" "if" "def"
"defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!" "defmacro" "fn*" "let*" "loop*" "recur" "throw" "try" "set!"
"locking" "eval" "instance?" "defmulti" "defmethod" "deftype" "new" # defmulti/defmethod/deftype now compile (macros over *-setup fns).
"locking" "eval" "instance?" "new"
"." "var-get" "var-set" "var?" "alter-var-root" "find-var" "intern" "." "var-get" "var-set" "var?" "alter-var-root" "find-var" "intern"
"alter-meta!" "reset-meta!" "satisfies?" "alter-meta!" "reset-meta!" "satisfies?"
# protocol-dispatch/register-method/make-reified are now clojure.core # protocol-dispatch/register-method/make-reified are now clojure.core
@ -85,9 +86,9 @@
# ns/require/in-ns/use/import/refer-clojure are now clojure.core # ns/require/in-ns/use/import/refer-clojure are now clojure.core
# fns/macros (compile as plain invokes / expand to them). # fns/macros (compile as plain invokes / expand to them).
"read-string" "macroexpand-1" "defonce" "read-string" "macroexpand-1" "defonce"
"refer" "defrecord" "refer"
# defprotocol/extend-type/extend-protocol/reify now expand to plain # defprotocol/extend-type/extend-protocol/reify/defrecord now expand to
# def + protocol-dispatch/register-method/make-reified invokes. # plain def + protocol-dispatch/register-method/make-reified/deftype.
"gen-class" "gen-class"
# letfn stays: its let* expansion needs letrec semantics (mutual # letfn stays: its let* expansion needs letrec semantics (mutual
# recursion between the fns), which compiled sequential let* lacks. # recursion between the fns), which compiled sequential let* lacks.

View file

@ -14,7 +14,6 @@
# compile path; syntax-quote already compiles via the analyzer's `handled` set. # compile path; syntax-quote already compiles via the analyzer's `handled` set.
(defn- stateful-head? [head-name] (defn- stateful-head? [head-name]
(or (= head-name "defmacro") (or (= head-name "defmacro")
(= head-name "deftype") (= head-name "defmulti") (= head-name "defmethod")
(= head-name "set!") (= head-name "set!")
(= head-name ".") (= head-name "new") (= head-name ".") (= head-name "new")
(= head-name "eval"))) (= head-name "eval")))

View file

@ -49,14 +49,16 @@
"(require (quote [clojure.string :as s]))" "(in-ns (quote foo.bar))" "(require (quote [clojure.string :as s]))" "(in-ns (quote foo.bar))"
"(ns foo.bar (:require [clojure.string :as s]))" "(ns foo.bar (:require [clojure.string :as s]))"
"(defprotocol P (m [x]))" "(extend-type Long P (m [x] x))" "(defprotocol P (m [x]))" "(extend-type Long P (m [x] x))"
"(reify P (m [this] 1))" "(var map)"]) "(reify P (m [this] 1))" "(var map)"
# Stage 2 tier 5: type/dispatch definitional forms compile too
"(deftype Pt [x y])" "(deftype Sq [s] P (m [this] s))"
"(defrecord Rec [a b])" "(defmulti mf :k)" "(defmethod mf :a [x] x)"])
# --- Intentional fallback (sanity sample): these SHOULD punt to the interpreter. # --- Intentional fallback (sanity sample): these SHOULD punt to the interpreter.
# Shrinking as Stage 2 (jolt-eaa) moves stateful forms onto the compile path # The remaining frozen/uncompiled set keeps the harness honest in the punt
# (require/in-ns/protocols/binding now compile). The remaining frozen/uncompiled # direction: defmacro + set! (frozen host-coupled), and letfn (needs letrec IR).
# set keeps the harness honest in the punt direction.
(def must-punt (def must-punt
["(defmacro m [x] x)" "(deftype T [a])" ["(defmacro m [x] x)"
"(set! *warn-on-reflection* true)" "(letfn [(f [n] (g n)) (g [n] (f n))] (f 1))"]) "(set! *warn-on-reflection* true)" "(letfn [(f [n] (g n)) (g [n] (f n))] (f 1))"])
(var fails @[]) (var fails @[])

View file

@ -1,13 +1,12 @@
(use ../../src/jolt/reader) (use ../../src/jolt/reader)
(use ../../src/jolt/types) (use ../../src/jolt/types)
(use ../../src/jolt/evaluator) (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 # Helper: parse and eval in a fresh ctx
(defn eval-str [s] (defn eval-str [s]

View file

@ -111,7 +111,9 @@
(print " passed") (print " passed")
(print "15: defmulti/defmethod...") (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 "(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 :foo [_] :got-foo)"))
(eval-form ctx @{} (parse-string "(defmethod my-dispatch :bar [_] :got-bar)")) (eval-form ctx @{} (parse-string "(defmethod my-dispatch :bar [_] :got-bar)"))
@ -120,7 +122,8 @@
(print " passed") (print " passed")
(print "16: deftype...") (print "16: deftype...")
(let [ctx (make-ctx) # deftype is an overlay macro now (Stage 2 jolt-eaa) — needs the full env (init).
(let [ctx (init)
_ (eval-form ctx @{} (parse-string "(deftype Point [x y])")) _ (eval-form ctx @{} (parse-string "(deftype Point [x y])"))
_ (eval-form ctx @{} (parse-string "(def p (Point. 10 20))")) _ (eval-form ctx @{} (parse-string "(def p (Point. 10 20))"))
p-val (eval-form ctx @{} (parse-string "p")) p-val (eval-form ctx @{} (parse-string "p"))