Skip to content

Deftype set fix #1063

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
borkdude merged 2 commits into from
Jul 13, 2026
Merged

Deftype set fix #1063

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
870768b
Accept unsynchronized-mutable for set! on CLJS deftype fields
borkdude Jul 13, 2026
6e309ed
Install JS accessors for CLJS deftype and record fields
borkdude Jul 13, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
39 changes: 31 additions & 8 deletions src/sci/impl/deftype.cljc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -194,6 +194,27 @@
([] (new-js-prototype SciType))
([base-class] (js/Object.create (.-prototype base-class)))))

#?(:cljs
(defn -install-field-accessors!
"Installs a JS accessor on the type's prototype for each field, so
host-style interop on instances resolves fields like compiled CLJS:
(.-field x) reads the field and, on deftypes, (set! (.-field x) v)
mutates it. A field shadows inherited members like toString when it
shares the name. One-time cost per type definition; instance
construction and host-object interop are unaffected."
[proto fields record?]
(doseq [field fields]
(js/Object.defineProperty
proto (utils/munge-str (str field))
(if record?
(let [k (keyword field)]
#js {:get (fn [] (this-as self (get self k)))
;; allow redefinition when the type is redefined
:configurable true})
#js {:get (fn [] (this-as self (get (types/getVal self) field)))
:set (fn [v] (this-as self (types/-mutate self field v)))
:configurable true})))))

#?(:cljs
(defn ensure-js-prototype [t]
(let [data (types/getVal t)]
Expand Down Expand Up @@ -264,25 +285,27 @@

(defn ^:private emit-deftype
"Generate the common deftype boilerplate: declare, def type, defn factory, protocol-impls."
[rec-type record-name factory-fn-sym factory-fn-body & [protocol-impls]]
[rec-type record-name factory-fn-sym fields factory-fn-body & [protocol-impls]]
`(do
(declare ~factory-fn-sym)
(sci.impl.deftype/-create-type
~{:sci.impl/type-name (list 'quote rec-type)
:sci.impl/constructor (list 'var factory-fn-sym)})
:sci.impl/constructor (list 'var factory-fn-sym)
:sci.impl/fields (list 'quote fields)})
~factory-fn-body
~@protocol-impls
~record-name))

(defn ^:private emit-record-type
"Generate record type creation and protocol implementations (no factory fns)."
[rec-type record-name constructor-fn-sym map-factory-sym protocol-impls]
[rec-type record-name constructor-fn-sym map-factory-sym fields protocol-impls]
`(do
(sci.impl.records/-create-record-type
~{:sci.impl/type-name (list 'quote rec-type)
:sci.impl/record true
:sci.impl/constructor (list 'var constructor-fn-sym)
:sci.impl.record/map-constructor (list 'var map-factory-sym)})
:sci.impl.record/map-constructor (list 'var map-factory-sym)
:sci.impl/fields (list 'quote fields)})
~@protocol-impls
~record-name))

Expand Down Expand Up @@ -341,7 +364,7 @@
`(~'clojure.core/defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies))))
impls)))
protocol-impls)]
(emit-deftype rec-type record-name factory-fn-sym
(emit-deftype rec-type record-name factory-fn-sym fields
`(defn ~(with-meta factory-fn-sym
{:doc (str "Positional factory function for class " rec-type ".")})
~fields
Expand Down Expand Up @@ -426,7 +449,7 @@
impls)))))
protocol-impls)]
(emit-record-type rec-type record-name constructor-fn-sym map-factory-sym
protocol-impls)))
(vec field-set) protocol-impls)))

(defn analyze-deftype*
"Analyzer handler for deftype* special form.
Expand Down Expand Up @@ -523,7 +546,7 @@
protocols-form (if (seq protocols)
`#{~@(map (fn [p] (list 'deref (:var p))) protocols)}
`#{})]
(emit-deftype rec-type record-name factory-fn-sym
(emit-deftype rec-type record-name factory-fn-sym fields
`(defn ~(with-meta factory-fn-sym
{:doc (str "Positional factory function for class " rec-type ".")
:arglists (list fields)})
Expand Down Expand Up @@ -608,7 +631,7 @@
`(~'clojure.core/defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies))))
impls)))))
protocol-impls)]
(emit-deftype rec-type record-name factory-fn-sym
(emit-deftype rec-type record-name factory-fn-sym fields
`(defn ~(with-meta factory-fn-sym
{:doc (str "Positional factory function for class " rec-type ".")})
~fields
Expand Down
7 changes: 7 additions & 0 deletions src/sci/impl/namespaces.cljc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -900,6 +900,13 @@
sci.impl.records/SciRecord
sci.impl.deftype/SciType))))
:default data)
;; fields become JS accessors on the prototype so host-style
;; interop ((.-field x), set!) matches compiled CLJS semantics
_ #?(:cljs (when-let [fields (:sci.impl/fields data)]
(sci.impl.deftype/-install-field-accessors!
(:sci.impl/js-prototype data) fields
(boolean (:sci.impl/record data))))
:default nil)
t (if existing
(do (types/setVal existing data)
existing)
Expand Down
11 changes: 5 additions & 6 deletions src/sci/impl/resolve.cljc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -226,12 +226,11 @@
(some-> k meta :tag))])
mutable? (when track-mutable?
(when-let [m (some-> k meta)]
#?(:cljd (or (:mutable m)
(:volatile-mutable m))
:clj (or (:volatile-mutable m)
(:unsynchronized-mutable m))
:cljs (or (:mutable m)
(:volatile-mutable m)))))
(or (:volatile-mutable m)
#?(:cljd (:mutable m)
:clj (:unsynchronized-mutable m)
:cljs (or (:mutable m)
(:unsynchronized-mutable m))))))
v (if call? ;; resolve-symbol is already handled in the call case
(mark-resolve-sym k idx)
(let [v (cond-> (if mutable?
Expand Down
34 changes: 34 additions & 0 deletions test/sci/defrecords_and_deftype_test.cljc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
[clojure.test :refer [are deftest is testing]]
[sci.core :as sci]
#?(:clj [sci.impl.deftype :as deftype])
#?(:cljs [sci.impl.unrestrict :as unrestrict])
[sci.test-utils :as tu]))

(deftest protocol-test
Expand Down Expand Up @@ -676,3 +677,36 @@
(applyTo [_ xs] 3))
(apply (->Dude) [])"
{:classes {'clojure.lang.IFn clojure.lang.IFn}})))))))

#?(:cljs
(deftest mutable-field-hints-test
(doseq [hint ["^:mutable" "^:unsynchronized-mutable" "^:volatile-mutable"]]
(testing hint
(is (= 2 (tu/eval* (str "(defprotocol IBump (bump [_]) (value [_]))"
" (deftype Box [" hint " n]"
" IBump (bump [this] (set! n (inc n)) this) (value [_] n))"
" (value (bump (bump (->Box 0))))")
{})))))))

#?(:cljs
(deftest unrestricted-field-interop-test
(binding [unrestrict/*unrestricted* true]
(testing "deftype field read"
(is (= [:a :b] (tu/eval* "(deftype Foo [a b]) (let [x (->Foo :a :b)] [(.-a x) (.-b x)])" {}))))
(testing "defrecord field read"
(is (= [1 2] (tu/eval* "(defrecord R [a b]) (let [x (->R 1 2)] [(.-a x) (.-b x)])" {}))))
(testing "external set! on deftype fields"
(is (= [42 43] (tu/eval* "(deftype Foo [a ^:mutable b]) (def x (->Foo 1 2)) (set! (.-a x) 42) (set! (.-b x) 43) [(.-a x) (.-b x)]" {}))))
(testing "external set! visible in method bodies"
(is (= 42 (tu/eval* "(defprotocol IGet (value [_])) (deftype Foo [a] IGet (value [_] a)) (def x (->Foo 1)) (set! (.-a x) 42) (value x)" {}))))
(testing "field shadows an inherited JS member"
(is (= "f" (tu/eval* "(deftype Bar [toString]) (.-toString (->Bar \"f\"))" {}))))
(testing "munged field name"
(is (= :yes (tu/eval* "(deftype Dash [my-field]) (.-my-field (->Dash :yes))" {}))))
(testing "nil field value"
(is (nil? (tu/eval* "(deftype N [v]) (.-v (->N nil))" {}))))
(testing "custom toString"
(is (= "Q<1>" (tu/eval* "(deftype Q [x] Object (toString [_] (str \"Q<\" x \">\"))) (.toString (->Q 1))" {}))))
(testing "host member access"
(is (= 3 (tu/eval* "(.-length \"abc\")" {})))
(is (= "AB" (tu/eval* "(.toUpperCase \"ab\")" {})))))))
Loading