Skip to content

Commit 1a3e71b

Browse files
borkdudeborkdude
committed
wip
1 parent f9686a9 commit 1a3e71b

File tree

4 files changed

+99
-102
lines changed

4 files changed

+99
-102
lines changed

‎src/sci/impl/analyzer.cljc‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@
99
#?(:cljs [sci.impl.types :as t :refer [->constant]])
1010
#?(:cljs [sci.impl.unrestrict :as unrestrict])
1111
[clojure.string :as str]
12+
[sci.ctx-store :as store]
1213
[sci.impl.evaluator :as eval]
1314
[sci.impl.faster :as faster]
1415
[sci.impl.fns :as fns]
@@ -62,6 +63,7 @@
6263

6364
(defn macroexpand-1 [ctx expr]
6465
(let [ctx (assoc ctx :sci.impl/macroexpanding true)
66+
_ (set! store/*ctx* ctx)
6567
original-expr expr]
6668
(if (seq? expr)
6769
(let [op (first expr)]

‎src/sci/impl/deftype.cljc‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -89,7 +89,6 @@
8989
(-sci-print-method v w)))
9090

9191
(defn deftype [[_fname & _ :as form] _ record-name fields & raw-protocol-impls]
92-
(prn :record-name record-name)
9392
(let [ctx (store/get-ctx)]
9493
(if (:sci.impl/macroexpanding ctx)
9594
(cons 'clojure.core/deftype (rest form))

‎src/sci/impl/namespaces.cljc‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1350,8 +1350,7 @@
13501350
'defn (macrofy 'defn fns/defn*)
13511351
'defn- (macrofy 'defn- defn-*)
13521352
'defonce (macrofy 'defonce defonce*)
1353-
'defrecord (macrofy 'defrecord sci.impl.records/defrecord
1354-
clojure-core-ns true)
1353+
'defrecord (macrofy 'defrecord sci.impl.records/defrecord clojure-core-ns)
13551354
'deftype (macrofy 'deftype sci.impl.deftype/deftype
13561355
clojure-core-ns)
13571356
'delay (macrofy 'delay delay*)

‎src/sci/impl/records.cljc‎

Lines changed: 96 additions & 99 deletions
Original file line numberDiff line numberDiff line change
@@ -247,105 +247,102 @@
247247
:cljs (defn ->record-impl [rec-name type var m]
248248
(SciRecord. rec-name type var m nil)))
249249

250-
(defn defrecord [[_fname & _ :as form] _ ctx record-name & fields+raw-protocol-impls]
251-
(if (:sci.impl/macroexpanding ctx)
252-
(cons 'clojure.core/defrecord (rest form))
253-
(let [[ctx record-name fields raw-protocol-impls]
254-
(if (symbol? ctx)
255-
[(store/get-ctx) ctx record-name fields+raw-protocol-impls]
256-
[ctx record-name (first fields+raw-protocol-impls) (next fields+raw-protocol-impls)])
257-
factory-fn-str (str "->" record-name)
258-
factory-fn-sym (symbol factory-fn-str)
259-
constructor-fn-sym (symbol (str "__" factory-fn-str "__ctor__"))
260-
map-factory-sym (symbol (str "map" factory-fn-str))
261-
keys (mapv keyword fields)
262-
rec-type (symbol (str (munge (utils/current-ns-name)) "." record-name))
263-
protocol-impls (utils/split-when symbol? raw-protocol-impls)
264-
field-set (set fields)
265-
protocol-impls
266-
(mapcat
267-
(fn [[protocol-name & impls] #?(:clj expr :cljs expr)]
268-
(let [impls (group-by first impls)
269-
protocol (@utils/eval-resolve-state ctx (:bindings ctx) protocol-name)
270-
;; _ (prn :protocol protocol)
271-
#?@(:cljs [protocol (or protocol
272-
(when (= 'Object protocol-name)
273-
::object))])
274-
_ (when-not protocol
275-
(utils/throw-error-with-location
276-
(str "Protocol not found: " protocol-name)
277-
expr))
278-
#?@(:clj [_ (assert-no-jvm-interface protocol protocol-name expr)])
279-
protocol (if (utils/var? protocol) @protocol protocol)
280-
protocol-var (:var protocol)
281-
_ (when protocol-var
282-
;; TODO: not all externally defined protocols might have the :var already
283-
(vars/alter-var-root protocol-var update :satisfies
284-
(fnil conj #{}) (protocols/type->str rec-type)))
285-
protocol-ns (:ns protocol)
286-
pns (cond protocol-ns (str (types/getName protocol-ns))
287-
(= #?(:clj Object :cljs ::object) protocol) "sci.impl.records")
288-
fq-meth-name #(if (simple-symbol? %)
289-
(symbol pns (str %))
290-
%)]
291-
(map (fn [[method-name bodies]]
292-
(let [bodies (map rest bodies)
293-
bodies (mapv (fn [impl]
294-
(let [args (first impl)
295-
body (rest impl)
296-
destr (utils/maybe-destructured args body)
297-
args (:params destr)
298-
body (:body destr)
299-
orig-this-sym (first args)
300-
rest-args (rest args)
301-
shadows-this? (some #(= orig-this-sym %) rest-args)
302-
this-sym (if shadows-this?
303-
(gensym "this_")
304-
orig-this-sym)
305-
args (if shadows-this?
306-
(vec (cons this-sym rest-args))
307-
args)
308-
bindings (mapcat (fn [field]
309-
[field (list (keyword field) this-sym)])
310-
(reduce disj field-set args))
311-
bindings (if shadows-this?
312-
(concat bindings [orig-this-sym this-sym])
313-
bindings)
314-
bindings (vec bindings)]
315-
`(~args
316-
(let ~bindings
317-
~@body)))) bodies)]
318-
`(defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies)))
319-
impls)))
320-
protocol-impls
321-
raw-protocol-impls)
322-
arg-syms (mapv #(symbol (name %)) keys)
323-
nil-map (zipmap (map keyword field-set) (repeat nil))]
324-
`(do
325-
(declare ~record-name ~factory-fn-sym ~constructor-fn-sym ~map-factory-sym)
326-
(def ~(with-meta record-name
327-
{:sci/record true})
328-
(sci.impl.records/-create-record-type
329-
~{:sci.impl/type-name (list 'quote rec-type)
330-
:sci.impl/record true
331-
:sci.impl/constructor (list 'var constructor-fn-sym)
332-
:sci.impl/var (list 'var record-name)
333-
:sci.impl.record/map-constructor (list 'var map-factory-sym)}))
334-
(defn ~constructor-fn-sym
335-
([~@arg-syms]
336-
(~constructor-fn-sym ~@arg-syms nil nil))
337-
([~@arg-syms meta# ext#]
338-
(sci.impl.records/->record-impl '~rec-type ~rec-type (var ~record-name)
339-
(cond-> (zipmap ~keys ~arg-syms)
340-
ext# (merge ext#)
341-
meta# (with-meta meta#)))))
342-
(defn ~factory-fn-sym
343-
([~@arg-syms]
344-
(~constructor-fn-sym ~@arg-syms nil nil)))
345-
(defn ~map-factory-sym [m#]
346-
(sci.impl.records/->record-impl '~rec-type ~rec-type (var ~record-name) (merge '~nil-map m#)))
347-
~@protocol-impls
348-
~record-name))))
250+
(defn defrecord [[_fname & _ :as form] _ record-name fields & raw-protocol-impls]
251+
(let [ctx (store/get-ctx)]
252+
(if (:sci.impl/macroexpanding ctx)
253+
(cons 'clojure.core/defrecord (rest form))
254+
(let [factory-fn-str (str "->" record-name)
255+
factory-fn-sym (symbol factory-fn-str)
256+
constructor-fn-sym (symbol (str "__" factory-fn-str "__ctor__"))
257+
map-factory-sym (symbol (str "map" factory-fn-str))
258+
keys (mapv keyword fields)
259+
rec-type (symbol (str (munge (utils/current-ns-name)) "." record-name))
260+
protocol-impls (utils/split-when symbol? raw-protocol-impls)
261+
field-set (set fields)
262+
protocol-impls
263+
(mapcat
264+
(fn [[protocol-name & impls] #?(:clj expr :cljs expr)]
265+
(let [impls (group-by first impls)
266+
protocol (@utils/eval-resolve-state ctx (:bindings ctx) protocol-name)
267+
;; _ (prn :protocol protocol)
268+
#?@(:cljs [protocol (or protocol
269+
(when (= 'Object protocol-name)
270+
::object))])
271+
_ (when-not protocol
272+
(utils/throw-error-with-location
273+
(str "Protocol not found: " protocol-name)
274+
expr))
275+
#?@(:clj [_ (assert-no-jvm-interface protocol protocol-name expr)])
276+
protocol (if (utils/var? protocol) @protocol protocol)
277+
protocol-var (:var protocol)
278+
_ (when protocol-var
279+
;; TODO: not all externally defined protocols might have the :var already
280+
(vars/alter-var-root protocol-var update :satisfies
281+
(fnil conj #{}) (protocols/type->str rec-type)))
282+
protocol-ns (:ns protocol)
283+
pns (cond protocol-ns (str (types/getName protocol-ns))
284+
(= #?(:clj Object :cljs ::object) protocol) "sci.impl.records")
285+
fq-meth-name #(if (simple-symbol? %)
286+
(symbol pns (str %))
287+
%)]
288+
(map (fn [[method-name bodies]]
289+
(let [bodies (map rest bodies)
290+
bodies (mapv (fn [impl]
291+
(let [args (first impl)
292+
body (rest impl)
293+
destr (utils/maybe-destructured args body)
294+
args (:params destr)
295+
body (:body destr)
296+
orig-this-sym (first args)
297+
rest-args (rest args)
298+
shadows-this? (some #(= orig-this-sym %) rest-args)
299+
this-sym (if shadows-this?
300+
(gensym "this_")
301+
orig-this-sym)
302+
args (if shadows-this?
303+
(vec (cons this-sym rest-args))
304+
args)
305+
bindings (mapcat (fn [field]
306+
[field (list (keyword field) this-sym)])
307+
(reduce disj field-set args))
308+
bindings (if shadows-this?
309+
(concat bindings [orig-this-sym this-sym])
310+
bindings)
311+
bindings (vec bindings)]
312+
`(~args
313+
(let ~bindings
314+
~@body)))) bodies)]
315+
`(defmethod ~(fq-meth-name method-name) ~rec-type ~@bodies)))
316+
impls)))
317+
protocol-impls
318+
raw-protocol-impls)
319+
arg-syms (mapv #(symbol (name %)) keys)
320+
nil-map (zipmap (map keyword field-set) (repeat nil))]
321+
`(do
322+
(declare ~record-name ~factory-fn-sym ~constructor-fn-sym ~map-factory-sym)
323+
(def ~(with-meta record-name
324+
{:sci/record true})
325+
(sci.impl.records/-create-record-type
326+
~{:sci.impl/type-name (list 'quote rec-type)
327+
:sci.impl/record true
328+
:sci.impl/constructor (list 'var constructor-fn-sym)
329+
:sci.impl/var (list 'var record-name)
330+
:sci.impl.record/map-constructor (list 'var map-factory-sym)}))
331+
(defn ~constructor-fn-sym
332+
([~@arg-syms]
333+
(~constructor-fn-sym ~@arg-syms nil nil))
334+
([~@arg-syms meta# ext#]
335+
(sci.impl.records/->record-impl '~rec-type ~rec-type (var ~record-name)
336+
(cond-> (zipmap ~keys ~arg-syms)
337+
ext# (merge ext#)
338+
meta# (with-meta meta#)))))
339+
(defn ~factory-fn-sym
340+
([~@arg-syms]
341+
(~constructor-fn-sym ~@arg-syms nil nil)))
342+
(defn ~map-factory-sym [m#]
343+
(sci.impl.records/->record-impl '~rec-type ~rec-type (var ~record-name) (merge '~nil-map m#)))
344+
~@protocol-impls
345+
~record-name)))))
349346

350347
(defn resolve-record-or-protocol-class
351348
"A record class is represented by a symbol with metadata (currently). This is only an implementation detail.

0 commit comments

Comments
 (0)