Skip to content

Commit

Permalink
CLJS-293: field metadata attached to fn
Browse files Browse the repository at this point in the history
  • Loading branch information
@netguy204
netguy204 authored and David Nolen committed Jun 2, 2012
1 parent cefd8ce commit f58bee6
Show file tree
Hide file tree
Showing 3 changed files with 43 additions and 35 deletions.
25 changes: 13 additions & 12 deletions src/clj/cljs/compiler.clj
View file
Expand Up @@ -980,25 +980,16 @@
(when export-as {:export export-as})
(when init-expr {:children [init-expr]})))))

(defn- analyze-fn-method [env locals meth]
(defn- analyze-fn-method [env locals meth gthis]
(letfn [(uniqify [[p & r]]
(when p
(cons (if (some #{p} r) (gensym (str p)) p)
(uniqify r))))]
(let [params (first meth)
fields (-> params meta ::fields)
variadic (boolean (some '#{&} params))
params (uniqify (remove '#{&} params))
fixed-arity (count (if variadic (butlast params) params))
body (next meth)
gthis (and fields (gensym "this__"))
locals (reduce (fn [m fld]
(assoc m fld
{:name (symbol (str gthis "." (munge fld)))
:field true
:mutable (-> fld meta :mutable)
:tag (-> fld meta :tag)}))
locals fields)
locals (reduce (fn [m name] (assoc m name {:name (munge name)})) locals params)
recur-frame {:names (vec (map munge params)) :flag (atom nil)}
block (binding [*recur-frames* (cons recur-frame *recur-frames*)]
Expand All @@ -1017,8 +1008,18 @@
mname (when name (munge name))
locals (:locals env)
locals (if name (assoc locals name {:name mname}) locals)
fields (-> form meta ::fields)
gthis (and fields (gensym "this__"))
locals (reduce (fn [m fld]
(assoc m fld
{:name (symbol (str gthis "." (munge fld)))
:field true
:mutable (-> fld meta :mutable)
:tag (-> fld meta :tag)}))
locals fields)

menv (if (> (count meths) 1) (assoc env :context :expr) env)
methods (map #(analyze-fn-method menv locals %) meths)
methods (map #(analyze-fn-method menv locals % gthis) meths)
max-fixed-arity (apply max (map :max-fixed-arity methods))
variadic (boolean (some :variadic methods))
locals (if name (assoc locals name {:name mname :fn-var true
Expand All @@ -1028,7 +1029,7 @@
methods (if name
;; a second pass with knowledge of our function-ness/arity
;; lets us optimize self calls
(map #(analyze-fn-method menv locals %) meths)
(map #(analyze-fn-method menv locals % gthis) meths)
methods)]
;;todo - validate unique arities, at most one variadic, variadic takes max required args
{:env env :op :fn :form form :name mname :methods methods :variadic variadic
Expand Down
45 changes: 22 additions & 23 deletions src/clj/cljs/core.clj
View file
Expand Up @@ -352,8 +352,8 @@
(let [psym (resolve p)
pfn-prefix (subs (core/str psym) 0 (clojure.core/inc (.lastIndexOf (core/str psym) ".")))]
(cons `(aset ~psym ~t true)
(map (fn [[f & meths]]
`(aset ~(symbol (core/str pfn-prefix f)) ~t (fn ~@meths)))
(map (fn [[f & meths :as form]]
`(aset ~(symbol (core/str pfn-prefix f)) ~t ~(with-meta `(fn ~@meths) (meta form))))
sigs))))]
`(do ~@(mapcat assign-impls impl-map)))
(let [t (resolve tsym)
Expand All @@ -365,35 +365,37 @@
(if (= p 'Object)
(let [adapt-params (fn [[sig & body]]
(let [[tname & args] sig]
(list (with-meta (vec args) (meta sig))
(list* 'this-as tname body))))]
(map (fn [[f & meths]]
`(set! ~(symbol (core/str prototype-prefix f)) (fn ~@(map adapt-params meths))))
(list (vec args) (list* 'this-as tname body))))]
(map (fn [[f & meths :as form]]
`(set! ~(symbol (core/str prototype-prefix f))
~(with-meta `(fn ~@(map adapt-params meths)) (meta form))))
sigs))
(concat (when-not (skip-flag psym)
[`(set! ~(symbol (core/str prototype-prefix pprefix)) true)])
(mapcat (fn [[f & meths]]
(mapcat (fn [[f & meths :as form]]
(if (= psym 'cljs.core.IFn)
(let [adapt-params (fn [[[targ & args :as sig] & body]]
(let [tsym (gensym "tsym")]
`(~(with-meta (vec (cons tsym args)) (meta sig))
`(~(vec (cons tsym args))
(this-as ~tsym
(let [~targ ~tsym]
~@body)))))
meths (map adapt-params meths)
tsym (gensym "tsym")
argsym (gensym "args")]
[`(set! ~(symbol (core/str prototype-prefix 'call)) (fn ~@meths))
[`(set! ~(symbol (core/str prototype-prefix 'call)) ~(with-meta `(fn ~@meths) (meta form)))
`(set! ~(symbol (core/str prototype-prefix 'apply))
(fn ~(with-meta [tsym argsym] (meta (first meths)))
(.apply (.-call ~tsym) ~tsym
(.concat (array ~tsym) (aclone ~argsym)))))])
~(with-meta
`(fn ~[tsym argsym]
(.apply (.-call ~tsym) ~tsym
(.concat (array ~tsym) (aclone ~argsym))))
(meta form)))])
(let [pf (core/str prototype-prefix pprefix f)]
(if (vector? (first meths))
[`(set! ~(symbol (core/str pf "$arity$" (count (first meths)))) (fn ~@meths))]
[`(set! ~(symbol (core/str pf "$arity$" (count (first meths)))) ~(with-meta `(fn ~@meths) (meta form)))]
(map (fn [[sig & body :as meth]]
`(set! ~(symbol (core/str pf "$arity$" (count sig)))
(fn ~meth)))
~(with-meta `(fn ~meth) (meta form))))
meths)))))
sigs)))))]
`(do ~@(mapcat assign-impls impl-map))))))
Expand Down Expand Up @@ -425,18 +427,16 @@
(range fast-path-protocol-partitions-count))]))))

(defmacro deftype [t fields & impls]
(let [adorn-params (fn [sig]
(cons (vary-meta (second sig) assoc :cljs.compiler/fields fields)
(nnext sig)))
;;reshape for extend-type
(let [;;reshape for extend-type
dt->et (fn [specs]
(loop [ret [] s specs]
(if (seq s)
(recur (-> ret
(conj (first s))
(into
(reduce (fn [v [f sigs]]
(conj v (cons f (map adorn-params sigs))))
(conj v (vary-meta (cons f (map #(cons (second %) (nnext %)) sigs))
assoc :cljs.compiler/fields fields)))
[]
(group-by first (take-while seq? (next s))))))
(drop-while seq? (next s)))
Expand All @@ -463,9 +463,7 @@
fields (vec (map #(with-meta % nil) fields))
base-fields fields
fields (conj fields '__meta '__extmap (with-meta '__hash {:mutable true}))
adorn-params (fn [sig]
(cons (vary-meta (second sig) assoc :cljs.compiler/fields fields)
(nnext sig)))

;;reshape for extend-type
dt->et (fn [specs]
(loop [ret [] s specs]
Expand All @@ -474,7 +472,8 @@
(conj (first s))
(into
(reduce (fn [v [f sigs]]
(conj v (cons f (map adorn-params sigs))))
(conj v (vary-meta (cons f (map #(cons (second %) (nnext %)) sigs))
assoc :cljs.compiler/fields fields)))
[]
(group-by first (take-while seq? (next s))))))
(drop-while seq? (next s)))
Expand Down
8 changes: 8 additions & 0 deletions test/cljs/cljs/core_test.cljs
View file
Expand Up @@ -1393,6 +1393,14 @@
(assert (= (-find-first fv [1]) 1))
(assert (identical? (fv 1) fv)))

(deftype DestructuringWithLocals [a]
IFindsFirst
(-find-first [_ [x y]]
[x y a]))

(let [t (DestructuringWithLocals. 1)]
(assert (= [2 3 1] (-find-first t [2 3]))))

(let [x 1]
(assert (= (case x 1 :one) :one)))
(let [x 1]
Expand Down

0 comments on commit f58bee6

Please sign in to comment.