Skip to content

Commit 5652c6a

Browse files
borkdudeborkdude
committed
broken
1 parent 0b08357 commit 5652c6a

File tree

4 files changed

+121
-127
lines changed

4 files changed

+121
-127
lines changed

‎src/sci/impl/analyzer.cljc‎

Lines changed: 2 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1632,21 +1632,12 @@
16321632
:else
16331633
(try
16341634
(if (macro? f)
1635-
(let [needs-ctx? (and (utils/var? f)
1636-
(vars/needs-ctx? f))
1637-
;; Fix for #603
1635+
(let [;; Fix for #603
16381636
#?@(:cljs [f (if (utils/var? f)
1639-
16401637
@f
16411638
f)
16421639
f (or (.-afn ^js f) f)])
1643-
v (if needs-ctx?
1644-
(apply f expr
1645-
(:bindings ctx)
1646-
ctx
1647-
(rest expr))
1648-
(apply f expr
1649-
(:bindings ctx) (rest expr)))
1640+
v (apply f expr (:bindings ctx) (rest expr))
16501641
v (if (seq? v)
16511642
(with-meta v (merge m (meta v)))
16521643
v)

‎src/sci/impl/deftype.cljc‎

Lines changed: 100 additions & 102 deletions
Original file line numberDiff line numberDiff line change
@@ -88,105 +88,103 @@
8888
(defmethod print-method SciType [v w]
8989
(-sci-print-method v w)))
9090

91-
(defn deftype [[_fname & _ :as form] _ ctx record-name & fields+raw-protocol-impls]
92-
(if (:sci.impl/macroexpanding ctx)
93-
(cons 'clojure.core/deftype (rest form))
94-
(let [[ctx record-name fields raw-protocol-impls]
95-
(if (symbol? ctx)
96-
[nil ctx record-name fields+raw-protocol-impls]
97-
[ctx record-name (first fields+raw-protocol-impls) (rest fields+raw-protocol-impls)])
98-
factory-fn-str (str "->" record-name)
99-
factory-fn-sym (symbol factory-fn-str)
100-
rec-type (symbol (str (munge (utils/current-ns-name)) "." record-name))
101-
protocol-impls (utils/split-when symbol? raw-protocol-impls)
102-
field-set (set fields)
103-
protocol-impls
104-
(mapcat
105-
(fn [[protocol-name & impls] #?(:clj expr :cljs expr)]
106-
(let [impls (group-by first impls)
107-
protocol (@utils/eval-resolve-state ctx (:bindings ctx) protocol-name)
108-
;; _ (prn :protocol protocol)
109-
#?@(:cljs [protocol (or protocol
110-
(when (= 'Object protocol-name)
111-
::object)
112-
(when (= 'IPrintWithWriter protocol-name)
113-
::IPrintWithWriter))])
114-
_ (when-not protocol
115-
(utils/throw-error-with-location
116-
(str "Protocol not found: " protocol-name)
117-
expr))
118-
#?@(:clj [_ (assert-no-jvm-interface protocol protocol-name expr)])
119-
protocol (if (utils/var? protocol) @protocol protocol)
120-
protocol-var (:var protocol)
121-
_ (when protocol-var
122-
;; TODO: not all externally defined protocols might have the :var already
123-
(vars/alter-var-root protocol-var update :satisfies
124-
(fnil conj #{}) (symbol (str rec-type))))
125-
protocol-ns (:ns protocol)
126-
pns (cond protocol-ns (str (types/getName protocol-ns))
127-
(= #?(:clj Object :cljs ::object) protocol) "sci.impl.deftype")
128-
fq-meth-name #(if (simple-symbol? %)
129-
(symbol pns (str %))
130-
%)]
131-
(map (fn [[method-name bodies]]
132-
(if #?(:cljs (and (keyword-identical? ::IPrintWithWriter protocol)
133-
(= '-pr-writer method-name))
134-
:clj false)
135-
#?(:cljs
136-
`(alter-meta! (var ~record-name)
137-
assoc :sci.impl/print-method (fn ~(rest (first bodies))))
138-
:clj nil)
139-
(let [bodies (map rest bodies)
140-
bodies (mapv (fn [impl]
141-
(let [args (first impl)
142-
body (rest impl)
143-
destr (utils/maybe-destructured args body)
144-
args (:params destr)
145-
body (:body destr)
146-
orig-this-sym (first args)
147-
rest-args (rest args)
148-
;; shadows-this? (some #(= orig-this-sym %) rest-args)
149-
this-sym (if true #_shadows-this?
150-
'__sci_this
151-
orig-this-sym)
152-
args (vec (cons this-sym rest-args))
153-
ext-map-binding (gensym)
154-
bindings [ext-map-binding (list 'sci.impl.deftype/-inner-impl this-sym)]
155-
bindings (concat bindings
156-
(mapcat (fn [field]
157-
;; TODO: the premature get is only necessary for immutable bindings
158-
;; We could however delay the getting of these values for both immutable and mutable fields.
159-
;; Currently a mutable binding is retrieved from the ext-map directly, since it can be mutated in the body we're analyzing here
160-
;; See resolve.cljc. We could apply the same trick to records.
161-
[field (list 'get ext-map-binding (list 'quote field))])
162-
(reduce disj field-set args)))
163-
bindings (concat bindings [orig-this-sym this-sym])
164-
bindings (vec bindings)]
165-
;; (prn :bindings bindings)
166-
`(~args
167-
(let ~bindings
168-
~@body)))) bodies)]
169-
(@utils/analyze (assoc ctx
170-
:deftype-fields field-set
171-
:local->mutator (zipmap field-set
172-
(map (fn [field]
173-
(fn [this v]
174-
(types/-mutate this field v)))
175-
field-set)))
176-
`(defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies)))))
177-
impls)))
178-
protocol-impls
179-
raw-protocol-impls)]
180-
`(do
181-
(declare ~record-name ~factory-fn-sym)
182-
(def ~(with-meta record-name
183-
{:sci/type true})
184-
(sci.impl.deftype/-create-type
185-
~{:sci.impl/type-name (list 'quote rec-type)
186-
:sci.impl/type rec-type
187-
:sci.impl/constructor (list 'var factory-fn-sym)
188-
:sci.impl/var (list 'var record-name)}))
189-
(defn ~factory-fn-sym [& args#]
190-
(sci.impl.deftype/->type-impl '~rec-type ~rec-type (var ~record-name) (zipmap ~(list 'quote fields) args#)))
191-
~@protocol-impls
192-
~record-name))))
91+
(defn deftype [[_fname & _ :as form] _ record-name fields & raw-protocol-impls]
92+
(prn :record-name record-name)
93+
(let [ctx (store/get-ctx)]
94+
(if (:sci.impl/macroexpanding ctx)
95+
(cons 'clojure.core/deftype (rest form))
96+
(let [factory-fn-str (str "->" record-name)
97+
factory-fn-sym (symbol factory-fn-str)
98+
rec-type (symbol (str (munge (utils/current-ns-name)) "." record-name))
99+
protocol-impls (utils/split-when symbol? raw-protocol-impls)
100+
field-set (set fields)
101+
protocol-impls
102+
(mapcat
103+
(fn [[protocol-name & impls] #?(:clj expr :cljs expr)]
104+
(let [impls (group-by first impls)
105+
protocol (@utils/eval-resolve-state ctx (:bindings ctx) protocol-name)
106+
;; _ (prn :protocol protocol)
107+
#?@(:cljs [protocol (or protocol
108+
(when (= 'Object protocol-name)
109+
::object)
110+
(when (= 'IPrintWithWriter protocol-name)
111+
::IPrintWithWriter))])
112+
_ (when-not protocol
113+
(utils/throw-error-with-location
114+
(str "Protocol not found: " protocol-name)
115+
expr))
116+
#?@(:clj [_ (assert-no-jvm-interface protocol protocol-name expr)])
117+
protocol (if (utils/var? protocol) @protocol protocol)
118+
protocol-var (:var protocol)
119+
_ (when protocol-var
120+
;; TODO: not all externally defined protocols might have the :var already
121+
(vars/alter-var-root protocol-var update :satisfies
122+
(fnil conj #{}) (symbol (str rec-type))))
123+
protocol-ns (:ns protocol)
124+
pns (cond protocol-ns (str (types/getName protocol-ns))
125+
(= #?(:clj Object :cljs ::object) protocol) "sci.impl.deftype")
126+
fq-meth-name #(if (simple-symbol? %)
127+
(symbol pns (str %))
128+
%)]
129+
(map (fn [[method-name bodies]]
130+
(if #?(:cljs (and (keyword-identical? ::IPrintWithWriter protocol)
131+
(= '-pr-writer method-name))
132+
:clj false)
133+
#?(:cljs
134+
`(alter-meta! (var ~record-name)
135+
assoc :sci.impl/print-method (fn ~(rest (first bodies))))
136+
:clj nil)
137+
(let [bodies (map rest bodies)
138+
bodies (mapv (fn [impl]
139+
(let [args (first impl)
140+
body (rest impl)
141+
destr (utils/maybe-destructured args body)
142+
args (:params destr)
143+
body (:body destr)
144+
orig-this-sym (first args)
145+
rest-args (rest args)
146+
;; shadows-this? (some #(= orig-this-sym %) rest-args)
147+
this-sym (if true #_shadows-this?
148+
'__sci_this
149+
orig-this-sym)
150+
args (vec (cons this-sym rest-args))
151+
ext-map-binding (gensym)
152+
bindings [ext-map-binding (list 'sci.impl.deftype/-inner-impl this-sym)]
153+
bindings (concat bindings
154+
(mapcat (fn [field]
155+
;; TODO: the premature get is only necessary for immutable bindings
156+
;; We could however delay the getting of these values for both immutable and mutable fields.
157+
;; Currently a mutable binding is retrieved from the ext-map directly, since it can be mutated in the body we're analyzing here
158+
;; See resolve.cljc. We could apply the same trick to records.
159+
[field (list 'get ext-map-binding (list 'quote field))])
160+
(reduce disj field-set args)))
161+
bindings (concat bindings [orig-this-sym this-sym])
162+
bindings (vec bindings)]
163+
;; (prn :bindings bindings)
164+
`(~args
165+
(let ~bindings
166+
~@body)))) bodies)]
167+
(@utils/analyze (assoc ctx
168+
:deftype-fields field-set
169+
:local->mutator (zipmap field-set
170+
(map (fn [field]
171+
(fn [this v]
172+
(types/-mutate this field v)))
173+
field-set)))
174+
`(defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies)))))
175+
impls)))
176+
protocol-impls
177+
raw-protocol-impls)]
178+
`(do
179+
(declare ~record-name ~factory-fn-sym)
180+
(def ~(with-meta record-name
181+
{:sci/type true})
182+
(sci.impl.deftype/-create-type
183+
~{:sci.impl/type-name (list 'quote rec-type)
184+
:sci.impl/type rec-type
185+
:sci.impl/constructor (list 'var factory-fn-sym)
186+
:sci.impl/var (list 'var record-name)}))
187+
(defn ~factory-fn-sym [& args#]
188+
(sci.impl.deftype/->type-impl '~rec-type ~rec-type (var ~record-name) (zipmap ~(list 'quote fields) args#)))
189+
~@protocol-impls
190+
~record-name)))))

‎src/sci/impl/interpreter.cljc‎

Lines changed: 18 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -13,8 +13,23 @@
1313

1414
#?(:clj (set! *warn-on-reflection* true))
1515

16+
(defn- eval-form** [ctx form]
17+
(let [upper-sym (gensym)
18+
cb (volatile! {upper-sym {0 {:syms {}}}})
19+
ctx (assoc ctx
20+
:parents [upper-sym 0]
21+
:closure-bindings cb)]
22+
(store/with-ctx ctx
23+
(let [analyzed (ana/analyze ctx form)
24+
binding-array-size (count (get-in @cb [upper-sym 0 :syms]))
25+
bindings (object-array binding-array-size)]
26+
(try (types/eval analyzed ctx bindings)
27+
(catch #?(:clj Throwable :cljs js/Error) e
28+
(utils/rethrow-with-location-of-node ctx bindings e analyzed)))))))
29+
1630
(defn eval-form* [ctx form]
17-
(let [eval-file (:clojure.core/eval-file (meta form))]
31+
(store/with-ctx ctx
32+
(let [eval-file (:clojure.core/eval-file (meta form))]
1833
(when eval-file
1934
(vars/push-thread-bindings {utils/current-file eval-file}))
2035
(try
@@ -43,20 +58,10 @@
4358
(try (types/eval analyzed ctx bindings)
4459
(catch #?(:clj Throwable :cljs js/Error) e
4560
(utils/rethrow-with-location-of-node ctx bindings e analyzed))))))
46-
(let [upper-sym (gensym)
47-
cb (volatile! {upper-sym {0 {:syms {}}}})
48-
ctx (assoc ctx
49-
:parents [upper-sym 0]
50-
:closure-bindings cb)
51-
analyzed (ana/analyze ctx form)
52-
binding-array-size (count (get-in @cb [upper-sym 0 :syms]))
53-
bindings (object-array binding-array-size)]
54-
(try (types/eval analyzed ctx bindings)
55-
(catch #?(:clj Throwable :cljs js/Error) e
56-
(utils/rethrow-with-location-of-node ctx bindings e analyzed)))))
61+
(eval-form** ctx form))
5762
(finally
5863
(when eval-file
59-
(vars/pop-thread-bindings))))))
64+
(vars/pop-thread-bindings)))))))
6065

6166
(defn eval-form [ctx form]
6267
(store/with-ctx ctx

‎src/sci/impl/namespaces.cljc‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1356,7 +1356,7 @@
13561356
'defrecord (macrofy 'defrecord sci.impl.records/defrecord
13571357
clojure-core-ns true)
13581358
'deftype (macrofy 'deftype sci.impl.deftype/deftype
1359-
clojure-core-ns true)
1359+
clojure-core-ns)
13601360
'delay (macrofy 'delay delay*)
13611361
'delay? (copy-core-var delay?)
13621362
#?@(:clj ['deliver (copy-core-var deliver)])

0 commit comments

Comments
 (0)