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:
parent
63d92cd122
commit
11fb5a7de6
7 changed files with 156 additions and 162 deletions
|
|
@ -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)))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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)]
|
||||||
|
|
|
||||||
|
|
@ -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.
|
||||||
|
|
|
||||||
|
|
@ -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")))
|
||||||
|
|
|
||||||
|
|
@ -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 @[])
|
||||||
|
|
|
||||||
|
|
@ -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]
|
||||||
|
|
|
||||||
|
|
@ -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"))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue