core: Stage 2 Task 2 tier 2b — compile reify (make-reified as a fn)
Completes the protocol machinery: make-reified joins protocol-dispatch/
register-method as a ctx-capturing clojure.core fn (install-stateful-fns!).
- make-reified-impl takes the EVALUATED {keyword fn} method map (a phm when
compiled, struct/table when interpreted) and builds the reified object.
- reify macro passes the protocol NAME as a string; method map is an ordinary
map literal evaluating to {keyword fn}.
- Removed make-reified's special-symbol? entry + handler arm, and dropped
make-reified + reify from host_iface special-names + compiler
uncompilable-heads.
reify now compiles and dispatches in both modes (single- and multi-method).
With tier 2a, the full protocol surface (defprotocol/extend-type/
extend-protocol/reify) compiles; defrecord still waits on deftype (tier 5).
Gate green: conformance 267x3, fallback-zero 31/5, bootstrap-fixpoint
stage1==2==3, self-host, staged-bootstrap, clojure-test-suite >=4034/67,
features 78/78, all unit + spec (protocols 7/7x3).
This commit is contained in:
parent
70176005db
commit
cd5a971434
4 changed files with 27 additions and 29 deletions
|
|
@ -187,13 +187,13 @@
|
||||||
;; definterface is JVM-only; bind the name to an empty marker.
|
;; definterface is JVM-only; bind the name to an empty marker.
|
||||||
(defmacro definterface [name-sym & body] `(def ~name-sym {}))
|
(defmacro definterface [name-sym & body] `(def ~name-sym {}))
|
||||||
|
|
||||||
;; Build a method map {kw (fn* ...)} as an embedded map literal — make-reified
|
;; make-reified is a fn (clojure.core); the method map {kw (fn* ...)} is an
|
||||||
;; evaluates it (the fn* forms become fns) via build-eval-map, which yields a
|
;; ordinary map literal that evaluates to {keyword fn}, and the protocol NAME is
|
||||||
;; struct it can iterate; a (hash-map ...) call would instead yield a phm it can't.
|
;; passed as a string (not the symbol) so the call compiles as a plain invoke.
|
||||||
(defmacro reify [& forms]
|
(defmacro reify [& forms]
|
||||||
(loop [items (seq forms) proto nil methods {}]
|
(loop [items (seq forms) proto nil methods {}]
|
||||||
(if (empty? items)
|
(if (empty? items)
|
||||||
`(make-reified ~proto ~methods)
|
`(make-reified ~(name proto) ~methods)
|
||||||
(let [x (first items)]
|
(let [x (first items)]
|
||||||
(if (symbol? x)
|
(if (symbol? x)
|
||||||
(recur (rest items) (if proto proto x) methods)
|
(recur (rest items) (if proto proto x) methods)
|
||||||
|
|
|
||||||
|
|
@ -158,7 +158,7 @@
|
||||||
"macroexpand-1" "defonce" "defmacro" "deftype" "defmulti"
|
"macroexpand-1" "defonce" "defmacro" "deftype" "defmulti"
|
||||||
"defmethod" "prefer-method" "remove-method" "remove-all-methods"
|
"defmethod" "prefer-method" "remove-method" "remove-all-methods"
|
||||||
"get-method" "methods"
|
"get-method" "methods"
|
||||||
"make-reified" "satisfies?" "instance?" "set!" "var" "var-get"
|
"satisfies?" "instance?" "set!" "var" "var-get"
|
||||||
"var-set" "var?" "in-ns" "ns" "require" "create-ns" "remove-ns"
|
"var-set" "var?" "in-ns" "ns" "require" "create-ns" "remove-ns"
|
||||||
"find-ns" "all-ns" "the-ns" "find-var" "intern" "resolve"
|
"find-ns" "all-ns" "the-ns" "find-var" "intern" "resolve"
|
||||||
"ns-resolve" "ns-aliases" "ns-imports" "ns-interns"
|
"ns-resolve" "ns-aliases" "ns-imports" "ns-interns"
|
||||||
|
|
|
||||||
|
|
@ -27,7 +27,6 @@
|
||||||
(= 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!")
|
||||||
(= name "satisfies?")
|
(= name "satisfies?")
|
||||||
(= name "make-reified")
|
|
||||||
(= name "prefer-method") (= name "remove-method") (= name "remove-all-methods")
|
(= name "prefer-method") (= name "remove-method") (= name "remove-all-methods")
|
||||||
(= name "get-method") (= name "methods")))
|
(= name "get-method") (= name "methods")))
|
||||||
|
|
||||||
|
|
@ -742,6 +741,16 @@
|
||||||
(def type-tag (if host host (string (ctx-current-ns ctx) "." type-name)))
|
(def type-tag (if host host (string (ctx-current-ns ctx) "." type-name)))
|
||||||
(register-protocol-method ctx type-tag proto-name method-name f))
|
(register-protocol-method ctx type-tag proto-name method-name f))
|
||||||
|
|
||||||
|
(defn make-reified-impl [ctx proto-name methods-map]
|
||||||
|
# methods-map is the EVALUATED {keyword fn} map (a phm when compiled, a struct/
|
||||||
|
# table when interpreted) — the fn* literals are already fns, just store them.
|
||||||
|
(def obj @{:jolt/deftype (string "reified-" proto-name) :jolt/protocol-methods @{}})
|
||||||
|
(def pairs (if (phm? methods-map)
|
||||||
|
(phm-entries methods-map)
|
||||||
|
(map (fn [k] [k (get methods-map k)]) (keys methods-map))))
|
||||||
|
(each p pairs (put (obj :jolt/protocol-methods) (in p 0) (in p 1)))
|
||||||
|
obj)
|
||||||
|
|
||||||
(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
|
||||||
|
|
@ -755,6 +764,8 @@
|
||||||
(ns-intern core "register-method"
|
(ns-intern core "register-method"
|
||||||
(fn [type-name proto-name method-name f]
|
(fn [type-name proto-name method-name f]
|
||||||
(register-method-impl ctx type-name proto-name method-name f)))
|
(register-method-impl ctx type-name proto-name method-name f)))
|
||||||
|
(ns-intern core "make-reified"
|
||||||
|
(fn [proto-name methods-map] (make-reified-impl ctx proto-name methods-map)))
|
||||||
core)
|
core)
|
||||||
|
|
||||||
# Dispatch a special form by its string name.
|
# Dispatch a special form by its string name.
|
||||||
|
|
@ -1240,23 +1251,10 @@
|
||||||
(ns-intern ns (if (struct? sym-name) (sym-name :name) sym-name) val))
|
(ns-intern ns (if (struct? sym-name) (sym-name :name) sym-name) val))
|
||||||
# set?/disj are plain clojure.core fns now (core-set?/core-disj) — no longer
|
# set?/disj are plain clojure.core fns now (core-set?/core-disj) — no longer
|
||||||
# special-cased here, the analyzer, or compiler.janet (jolt-g3h).
|
# special-cased here, the analyzer, or compiler.janet (jolt-g3h).
|
||||||
# protocol-dispatch / register-method are now ordinary clojure.core fns
|
# protocol-dispatch / register-method / make-reified are now ordinary
|
||||||
# (install-stateful-fns!) — the defprotocol/extend-type macros call them with
|
# clojure.core fns (install-stateful-fns!) — the defprotocol/extend-type/reify
|
||||||
# name STRINGS, so they compile + interpret as plain invokes (no special arm).
|
# macros call them with name STRINGS, so they compile + interpret as plain
|
||||||
"make-reified" (let [proto-sym (in form 1)
|
# invokes (no special-form arms).
|
||||||
methods-map (eval-form ctx bindings (in form 2))
|
|
||||||
proto-name (proto-sym :name)
|
|
||||||
reified-tag (string "reified-" proto-name)]
|
|
||||||
(def obj @{:jolt/deftype reified-tag :jolt/protocol-methods @{}})
|
|
||||||
(loop [[k v] :pairs methods-map]
|
|
||||||
(let [fn-value (if (and (table? v) (get v :fn*))
|
|
||||||
(let [args-vec (get v :args)
|
|
||||||
body-forms (get v :body)]
|
|
||||||
(eval-form ctx @{}
|
|
||||||
@[{:jolt/type :symbol :ns nil :name "fn*"} args-vec ;body-forms]))
|
|
||||||
v)]
|
|
||||||
(put (obj :jolt/protocol-methods) k fn-value)))
|
|
||||||
obj)
|
|
||||||
"satisfies?" (let [proto-sym (eval-form ctx bindings (in form 1))
|
"satisfies?" (let [proto-sym (eval-form ctx bindings (in form 1))
|
||||||
obj (eval-form ctx bindings (in form 2))
|
obj (eval-form ctx bindings (in form 2))
|
||||||
type-tag (if (and (table? obj) (get obj :jolt/deftype))
|
type-tag (if (and (table? obj) (get obj :jolt/deftype))
|
||||||
|
|
|
||||||
|
|
@ -75,18 +75,18 @@
|
||||||
"locking" "eval" "instance?" "defmulti" "defmethod" "deftype" "new"
|
"locking" "eval" "instance?" "defmulti" "defmethod" "deftype" "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 are now clojure.core fns (compile
|
# protocol-dispatch/register-method/make-reified are now clojure.core
|
||||||
# as plain invokes); only make-reified is still a special.
|
# fns (compile as plain invokes).
|
||||||
"make-reified" "prefer-method"
|
"prefer-method"
|
||||||
"remove-method" "remove-all-methods" "get-method" "methods"
|
"remove-method" "remove-all-methods" "get-method" "methods"
|
||||||
# ns-management forms dispatched by the interpreter (not core vars)
|
# ns-management forms dispatched by the interpreter (not core vars)
|
||||||
"create-ns" "remove-ns" "find-ns" "all-ns" "the-ns" "resolve"
|
"create-ns" "remove-ns" "find-ns" "all-ns" "the-ns" "resolve"
|
||||||
"ns-resolve" "ns-aliases" "ns-imports" "ns-interns"
|
"ns-resolve" "ns-aliases" "ns-imports" "ns-interns"
|
||||||
"read-string" "macroexpand-1" "defonce" "ns" "in-ns" "require"
|
"read-string" "macroexpand-1" "defonce" "ns" "in-ns" "require"
|
||||||
"import" "use" "refer" "defrecord"
|
"import" "use" "refer" "defrecord"
|
||||||
# defprotocol/extend-type/extend-protocol now expand to plain
|
# defprotocol/extend-type/extend-protocol/reify now expand to plain
|
||||||
# def + protocol-dispatch/register-method invokes — let them compile.
|
# def + protocol-dispatch/register-method/make-reified invokes.
|
||||||
"reify" "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.
|
||||||
"monitor-enter" "monitor-exit" "binding" "letfn"]
|
"monitor-enter" "monitor-exit" "binding" "letfn"]
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue