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:
Yogthos 2026-06-09 14:38:39 -04:00
parent 70176005db
commit cd5a971434
4 changed files with 27 additions and 29 deletions

View file

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

View file

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

View file

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

View file

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