simon/jolt
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

core: move the protocol/type macros to the overlay

Browse source 
defprotocol/defrecord/extend-type/extend-protocol/reify + the extend/proxy/
definterface stubs move to 30-macros (user-facing, not used by the compiler). They
emit Jolt's protocol/type special forms (protocol-dispatch/register-method/
make-reified/deftype).

The one subtlety: a protocol value is a :jolt/type-tagged struct, and the
interpreter can't tell an embedded opaque value from a tagged map literal being
constructed. So defprotocol builds it via a make-protocol fn call (exposed from
core) instead of an embedded literal — a fn result evaluates normally and even
compiles. reify emits a {kw (fn* ...)} map literal that make-reified evaluates
(build-eval-map yields a struct it can iterate, unlike a hash-map phm). defrecord
vecs its spliced field-let bindings (a lazy mapcat seq won't splice) and uses an
explicit fresh-sym for the map-> param (auto-gensym doesn't cross nested
syntax-quotes).

protocols-spec 21/21, conformance 228x3, fixpoint, clojure-test-suite 3930, full
suite green.
This commit is contained in:
Yogthos 2026-06-07 18:06:55 -04:00
parent 08c796c145
commit 1a1a1134d6
2 changed files with 93 additions and 186 deletions
Download patch file Download diff file Expand all files Collapse all files

83
jolt-core/clojure/core/30-macros.clj
View file

@ -134,3 +134,86 @@
(~(nth clause 2) p#)
~(emit more)))))]
`(let [~gp ~pred ~ge ~expr] ~(emit clauses))))
;; --- protocols, records, types ---------------------------------------------
;; These emit Jolt's protocol/type special forms (protocol-dispatch,
;; register-method, make-reified, deftype). The :jolt/protocol value built by
;; defprotocol is an opaque tagged struct — it self-evaluates (see eval-form).
;; Group a flat seq that starts with a head symbol followed by its list specs
;; into [[head spec spec ...] ...] runs. Used by extend-protocol and defrecord.
(defn- group-by-head [items]
(reduce (fn [acc x]
(if (symbol? x)
(conj acc [x])
(conj (pop acc) (conj (peek acc) x))))
[] items))
;; 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
;; instead of evaluating its fields. methods is a {kw {:name str}} map (only :name
;; is consulted). Each method is a thin dispatch fn over protocol-dispatch.
(defmacro defprotocol [pname & sigs]
(let [methods (reduce (fn [m sig]
(assoc m (keyword (name (first sig))) {:name (name (first sig))}))
{} sigs)]
`(do
(def ~pname (make-protocol ~(name pname) ~methods))
~@(map (fn [sig]
`(def ~(first sig)
(fn* [this# & rest#] (protocol-dispatch ~pname ~(first sig) this# rest#))))
sigs))))
(defmacro extend-type [tsym psym & impls]
`(do ~@(map (fn [spec]
`(register-method ~tsym ~psym ~(first spec)
(fn* ~(nth spec 1) ~@(drop 2 spec))))
impls)))
(defmacro extend-protocol [psym & type-impls]
`(do ~@(map (fn [g] `(extend-type ~(first g) ~psym ~@(rest g)))
(group-by-head type-impls))))
;; extend (the fn form) is not supported — stub to nil, as before.
(defmacro extend [& args] nil)
;; JVM proxies are unsupported.
(defmacro proxy [& args] nil)
;; definterface is JVM-only; bind the name to an empty marker.
(defmacro definterface [name-sym & body] `(def ~name-sym {}))
;; Build a method map {kw (fn* ...)} as an embedded map literal — make-reified
;; evaluates it (the fn* forms become fns) via build-eval-map, which yields a
;; struct it can iterate; a (hash-map ...) call would instead yield a phm it can't.
(defmacro reify [& forms]
(loop [items (seq forms) proto nil methods {}]
(if (empty? items)
`(make-reified ~proto ~methods)
(let [x (first items)]
(if (symbol? x)
(recur (rest items) (if proto proto x) methods)
(recur (rest items) proto
(assoc methods (keyword (name (first x)))
`(fn* ~(nth x 1) ~@(drop 2 x)))))))))
(defmacro defrecord [name-sym fields & body]
(let [tn (name name-sym)
dot (symbol (str tn "."))
arrow (symbol (str "->" tn))
mapf (symbol (str "map->" tn))
m (fresh-sym)
;; each method body sees the record fields, bound from the instance (the
;; method's first param), matching Clojure's defrecord method scope. vec the
;; spliced binding seq so ~@ splices its elements, not the lazy-seq itself.
impl (fn [proto specs]
`(extend-type ~name-sym ~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
(deftype ~name-sym ~fields)
(def ~arrow (fn* ~fields (~dot ~@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)))))

196
src/jolt/core.janet
View file

@ -2190,81 +2190,11 @@
# Proxy stub — returns nil form (macro, args not evaluated)
(defn core-proxy [& args] nil)
# Thread stubs
(def core-Thread (fn [& args] (struct ;[:jolt/type :jolt/thread])))
(def core-ThreadLocal (fn [& args] (struct ;[:jolt/type :jolt/thread-local])))
(def core-IllegalStateException (fn [& args] (struct ;[:jolt/type :jolt/exception])))
# definterface stub — JVM-only, emits def form
(defn core-definterface [name-sym & body]
@[{:jolt/type :symbol :ns nil :name "def"}
name-sym
@{}])
# defrecord — creates a proper type via deftype + factory functions
(defn core-defrecord [name-sym fields-vec & body]
(def type-name (name-sym :name))
(def type-name-dot (string type-name "."))
(def arrow-name (string "->" type-name))
(def map-name (string "map->" type-name))
# (deftype TypeName [fields...])
(def dt-form @[{:jolt/type :symbol :ns nil :name "deftype"} name-sym fields-vec])
# Arrow factory: (def ->TypeName (fn [field1 field2 ...] (TypeName. field1 field2 ...)))
(def arrow-call @[{:jolt/type :symbol :ns nil :name type-name-dot}])
(each f fields-vec (array/push arrow-call f))
(def arrow-sym {:jolt/type :symbol :ns nil :name arrow-name})
(def arrow-body @[{:jolt/type :symbol :ns nil :name "fn"} fields-vec arrow-call])
# map-> factory: (def map->TypeName (fn [m] (->TypeName (get m :field1) (get m :field2) ...)))
(def map-call @[{:jolt/type :symbol :ns nil :name arrow-name}])
(each f fields-vec
(array/push map-call @[{:jolt/type :symbol :ns nil :name "get"} {:jolt/type :symbol :ns nil :name (string "m")} (keyword (f :name))]))
(def map-sym {:jolt/type :symbol :ns nil :name map-name})
# params must be a tuple (a vector), not an array — fn* treats an array
# first-arg as multi-arity clauses
(def map-body @[{:jolt/type :symbol :ns nil :name "fn"} [{:jolt/type :symbol :ns nil :name "m"}] map-call])
(def out @[{:jolt/type :symbol :ns nil :name "do"}
dt-form
@[{:jolt/type :symbol :ns nil :name "def"} arrow-sym arrow-body]
@[{:jolt/type :symbol :ns nil :name "def"} map-sym map-body]])
# Process inline protocol/interface implementations:
# (defrecord T [fs] Proto (m [this] body) ... Proto2 (m2 [this] body))
# Emit an extend-type per protocol. Each method body is wrapped in a let that
# binds the record's fields from the instance (first method param), matching
# Clojure's field-in-scope semantics for deftype/defrecord methods.
(var i 0)
(while (< i (length body))
(def elem (in body i))
(if (and (struct? elem) (= :symbol (elem :jolt/type)))
# protocol name; collect following method specs
(let [proto-sym elem
et @[{:jolt/type :symbol :ns nil :name "extend-type"} name-sym proto-sym]]
(++ i)
(while (and (< i (length body)) (not (and (struct? (in body i)) (= :symbol ((in body i) :jolt/type)))))
(let [spec (in body i)
mname (spec 0)
argv (spec 1)
mbody (tuple/slice spec 2)
instance (in argv 0)
# (let [f0 (core-get instance :f0) ...] body...)
field-binds @[]
_ (each f fields-vec
(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]))
(++ i))
(array/push out et))
(++ i)))
out)
# letfn — mutually-recursive local fns. Expands to let* of fn* bindings; jolt
@ -2399,113 +2329,14 @@
(while (< i n) (d-process (in bindings i) (in bindings (+ i 1)) out) (+= i 2))
(tuple/slice out))
# Protocol implementation — methods dispatch via type registry
(defn core-defprotocol [protocol-name & sigs]
(def result @[])
(array/push result {:jolt/type :symbol :ns nil :name "do"})
(def methods @{})
(each sig sigs
(def method-name (first sig))
(def arglists (tuple/slice sig 1))
(put methods (keyword (if (struct? method-name) (method-name :name) method-name)) {:name method-name :arglists arglists}))
(def proto-def @[])
(array/push proto-def {:jolt/type :symbol :ns nil :name "def"})
(array/push proto-def protocol-name)
(array/push proto-def @{:jolt/type :jolt/protocol
:name {:jolt/type :symbol :ns nil :name (protocol-name :name)}
:methods methods})
(array/push result proto-def)
(each sig sigs
(def method-name (first sig))
(def method-def @[])
(array/push method-def {:jolt/type :symbol :ns nil :name "def"})
(array/push method-def method-name)
(def fn-form @[])
(array/push fn-form {:jolt/type :symbol :ns nil :name "fn*"})
(array/push fn-form [{:jolt/type :symbol :ns nil :name "this"} {:jolt/type :symbol :ns nil :name "&"} {:jolt/type :symbol :ns nil :name "rest-args"}])
(array/push fn-form @[
{:jolt/type :symbol :ns nil :name "protocol-dispatch"}
protocol-name
method-name
{:jolt/type :symbol :ns nil :name "this"}
{:jolt/type :symbol :ns nil :name "rest-args"}])
(array/push method-def fn-form)
(array/push result method-def))
result)
(defn core-extend-type [type-sym proto-sym & impls]
(def result @[{:jolt/type :symbol :ns nil :name "do"}])
(each method-spec impls
(def method-name (method-spec 0))
(def arg-vec (method-spec 1))
(def body (tuple/slice method-spec 2))
(def fn-form @[{:jolt/type :symbol :ns nil :name "fn*"} arg-vec ;body])
(array/push result @[
{:jolt/type :symbol :ns nil :name "register-method"}
type-sym
proto-sym
method-name
fn-form]))
result)
(defn core-extend-protocol [proto-sym & type-impls]
(def result @[{:jolt/type :symbol :ns nil :name "do"}])
(var i 0)
(while (< i (length type-impls))
(let [type-sym (type-impls i)
methods (type-impls (+ i 1))]
# methods is a single method spec array or an array of method specs
# If the first element is a symbol (method name), treat as single spec
(if (and (struct? (methods 0)) (= :symbol ((methods 0) :jolt/type)))
(let [method-spec methods]
(def method-name (method-spec 0))
(def arg-vec (method-spec 1))
(def body (tuple/slice method-spec 2))
(def fn-form @[{:jolt/type :symbol :ns nil :name "fn*"} arg-vec ;body])
(array/push result @[
{:jolt/type :symbol :ns nil :name "register-method"}
type-sym
proto-sym
method-name
fn-form]))
(each method-spec methods
(def method-name (method-spec 0))
(def arg-vec (method-spec 1))
(def body (tuple/slice method-spec 2))
(def fn-form @[{:jolt/type :symbol :ns nil :name "fn*"} arg-vec ;body])
(array/push result @[
{:jolt/type :symbol :ns nil :name "register-method"}
type-sym
proto-sym
method-name
fn-form]))))
(+= i 2))
result)
(def core-extend (fn [& args] nil))
(defn core-reify [& forms]
# forms interleaves protocol-name symbols with method specs (name [args] body);
# collect every method spec (a list), tracking the first protocol for the tag.
(def result @[{:jolt/type :symbol :ns nil :name "do"}])
(def methods @{})
(var proto-sym nil)
(var i 0)
(while (< i (length forms))
(def elem (in forms i))
(if (and (struct? elem) (= :symbol (elem :jolt/type)))
(do (when (nil? proto-sym) (set proto-sym elem)) (++ i))
(let [method-name (in elem 0)
arg-vec (in elem 1)
body (tuple/slice elem 2)]
(put methods (keyword (if (struct? method-name) (method-name :name) method-name))
@{:fn* true :args arg-vec :body body})
(++ i))))
(array/push result @[
{:jolt/type :symbol :ns nil :name "make-reified"}
proto-sym
methods])
result)
# Build a protocol value (a self-evaluating tagged table). Exposed so the overlay
# `defprotocol` can construct one via a fn call rather than embedding a tagged
# struct literal (which the interpreter would try to re-evaluate). `methods` is a
# {kw {:name str}} map; only :name is consulted (by satisfies?).
(defn core-make-protocol [name-str methods]
@{:jolt/type :jolt/protocol
:name {:jolt/type :symbol :ns nil :name name-str}
:methods methods})
(def core-satisfies? (fn [proto-sym obj] false))
@ -3370,11 +3201,7 @@
"prefer-method" core-prefer-method
"Object" core-Object
"destructure" core-destructure
"defprotocol" core-defprotocol
"extend-type" core-extend-type
"extend-protocol" core-extend-protocol
"extend" core-extend
"reify" core-reify
"make-protocol" core-make-protocol
"satisfies?" core-satisfies?
"extends?" core-extends?
"implements?" core-implements?
@ -3382,12 +3209,9 @@
"volatile!" core-volatile!
"vswap!" core-vswap!
"vreset!" core-vreset!
"proxy" core-proxy
"Thread" core-Thread
"ThreadLocal" core-ThreadLocal
"IllegalStateException" core-IllegalStateException
"definterface" core-definterface
"defrecord" core-defrecord
"resolve" core-resolve
"ns-name" core-ns-name
"update-in" core-update-in
@ -3431,7 +3255,7 @@
(defn core-macro-names
"Set of core binding names that are macros."
[]
@{"when-let" true "defrecord" true "defprotocol" true "extend-type" true "extend-protocol" true "extend" true "reify" true "proxy" true "definterface" true "lazy-seq" true "lazy-cat" true})
@{"when-let" true "lazy-seq" true "lazy-cat" true})
(def init-core!
(fn [& args]