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.

jolt-core/clojure/core/30-macros.clj

@@ -159,6 +159,37 @@
               (conj (pop acc) (conj (peek acc) x))))
           [] 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
 ;; 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
@@ -213,7 +244,6 @@
 
 (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)
@@ -229,8 +259,9 @@
                              `(~(first spec) ~argv (let [~@binds] ~@(drop 2 spec)))))
                          specs)))]
     `(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)
-       (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)))))
 

src/jolt/evaluator.janet

@@ -22,7 +22,7 @@
       (= name "set!") (= name "var") (= name "locking")
       (= name "eval")
       (= name "instance?")
-      (= name "deftype") (= name "new") (= name ".")
+      (= name "new") (= name ".")
       (= name "var-get") (= name "var-set") (= name "var?")
       (= name "alter-var-root") (= name "find-var") (= name "intern")
       (= name "alter-meta!") (= name "reset-meta!")
@@ -882,6 +882,21 @@
     (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!
   "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
@@ -904,6 +919,7 @@
   (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)
 
 # Dispatch a special form by its string name.
@@ -1419,64 +1435,8 @@
                             (let [dc (get mm-var :jolt/dispatch-cache)]
                               (when dc (each k (keys dc) (put dc k nil)))))
                           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)
                 args (map |(eval-form ctx bindings $) (tuple/slice form 2))
                 ctor (eval-form ctx bindings type-sym)]

src/jolt/host_iface.janet

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

src/jolt/loader.janet

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

test/integration/fallback-zero-test.janet

@@ -49,14 +49,16 @@
    "(require (quote [clojure.string :as s]))" "(in-ns (quote foo.bar))"
    "(ns foo.bar (:require [clojure.string :as s]))"
    "(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.
-# 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
-  ["(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))"])
 
 (var fails @[])

test/unit/evaluator-test.janet

@@ -122,7 +122,8 @@
 (print "  passed")
 
 (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 "(def p (Point. 10 20))"))
       p-val (eval-form ctx @{} (parse-string "p"))