From e9df75a511c62a0bc5ac08bb470913c176bd9757 Mon Sep 17 00:00:00 2001 From: Herwig Hochleitner Date: Wed, 31 Oct 2012 05:19:32 +0100 Subject: [PATCH 2/2] CLJS-414: Implement extend-type in terms of specify cljs.core/Keyword is changed to implement the correctly named methods -invoke instead of invoke, since specify asserts the method name on the IFn fast-path too. --- src/clj/cljs/core.clj | 94 ++++++++--------------------------------------- src/cljs/cljs/core.cljs | 4 +- 2 files changed, 18 insertions(+), 80 deletions(-) diff --git a/src/clj/cljs/core.clj b/src/clj/cljs/core.clj index 86ec0dc..8f4c0f6 100644 --- a/src/clj/cljs/core.clj +++ b/src/clj/cljs/core.clj @@ -562,88 +562,26 @@ ~@(apply concat prelude) (specify* ~(with-meta osym (meta oexpr)) ~@(apply concat proto-map))))) -(defmacro extend-type [tsym & impls] - (let [resolve #(let [ret (:name (cljs.analyzer/resolve-var (dissoc &env :locals) %))] - (assert ret (core/str "Can't resolve: " %)) - ret) - impl-map (loop [ret {} s impls] +;; Extend js builtins +(defn emit-extend-base-type [env t impls] + (let [impl-map (loop [ret {} s impls] (if (seq s) (recur (assoc ret (first s) (take-while seq? (next s))) (drop-while seq? (next s))) ret)) - warn-if-not-protocol #(when-not (= 'Object %) - (if cljs.analyzer/*cljs-warn-on-undeclared* - (if-let [var (cljs.analyzer/resolve-existing-var (dissoc &env :locals) %)] - (do - (when-not (:protocol-symbol var) - (cljs.analyzer/warning &env - (core/str "WARNING: Symbol " % " is not a protocol"))) - (when (and cljs.analyzer/*cljs-warn-protocol-deprecated* - (-> var :deprecated) - (not (-> % meta :deprecation-nowarn))) - (cljs.analyzer/warning &env - (core/str "WARNING: Protocol " % " is deprecated")))) - (cljs.analyzer/warning &env - (core/str "WARNING: Can't resolve protocol symbol " %))))) - skip-flag (set (-> tsym meta :skip-protocol-flag))] - (if (base-type tsym) - (let [t (base-type tsym) - assign-impls (fn [[p sigs]] - (warn-if-not-protocol p) - (let [psym (resolve p) - pfn-prefix (subs (core/str psym) 0 (clojure.core/inc (.indexOf (core/str psym) "/")))] - (cons `(aset ~psym ~t true) - (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) - prototype-prefix (fn [sym] - `(.. ~tsym -prototype ~(to-property sym))) - assign-impls (fn [[p sigs]] - (warn-if-not-protocol p) - (let [psym (resolve p) - pprefix (protocol-prefix psym)] - (if (= p 'Object) - (let [adapt-params (fn [[sig & body]] - (let [[tname & args] sig] - (list (vec args) (list* 'this-as (vary-meta tname assoc :tag t) body))))] - (map (fn [[f & meths :as form]] - `(set! ~(prototype-prefix f) - ~(with-meta `(fn ~@(map adapt-params meths)) (meta form)))) - sigs)) - (concat (when-not (skip-flag psym) - [`(set! ~(prototype-prefix pprefix) true)]) - (mapcat (fn [[f & meths :as form]] - (if (= psym 'cljs.core/IFn) - (let [adapt-params (fn [[[targ & args :as sig] & body]] - (let [this-sym (with-meta (gensym "this-sym") {:tag t})] - `(~(vec (cons this-sym args)) - (this-as ~this-sym - (let [~targ ~this-sym] - ~@body))))) - meths (map adapt-params meths) - this-sym (with-meta (gensym "this-sym") {:tag t}) - argsym (gensym "args")] - [`(set! ~(prototype-prefix 'call) ~(with-meta `(fn ~@meths) (meta form))) - `(set! ~(prototype-prefix 'apply) - ~(with-meta - `(fn ~[this-sym argsym] - (.apply (.-call ~this-sym) ~this-sym - (.concat (array ~this-sym) (aclone ~argsym)))) - (meta form)))]) - (let [pf (core/str pprefix f) - adapt-params (fn [[[targ & args :as sig] & body]] - (cons (vec (cons (vary-meta targ assoc :tag t) args)) - body))] - (if (vector? (first meths)) - [`(set! ~(prototype-prefix (core/str pf "$arity$" (count (first meths)))) ~(with-meta `(fn ~@(adapt-params meths)) (meta form)))] - (map (fn [[sig & body :as meth]] - `(set! ~(prototype-prefix (core/str pf "$arity$" (count sig))) - ~(with-meta `(fn ~(adapt-params meth)) (meta form)))) - meths))))) - sigs)))))] - `(do ~@(mapcat assign-impls impl-map)))))) + assign-impls (fn [[p sigs]] + (let [psym (resolve-protocol-symbol env p) + pfn-prefix (subs (core/str psym) 0 (clojure.core/inc (.indexOf (core/str psym) "/")))] + (cons `(aset ~psym ~t true) + (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) ~t))) + +(defmacro extend-type [tsym & impls] + (if-let [t (base-type tsym)] + (emit-extend-base-type &env t impls) + `(specify (.-prototype ~tsym) ~@impls))) (defn- prepare-protocol-masks [env t impls] (let [resolve #(let [ret (:name (cljs.analyzer/resolve-var (dissoc env :locals) %))] diff --git a/src/cljs/cljs/core.cljs b/src/cljs/cljs/core.cljs index 3bb58ef..f728b39 100644 --- a/src/cljs/cljs/core.cljs +++ b/src/cljs/cljs/core.cljs @@ -1754,13 +1754,13 @@ reduces them without incurring seq initialization" (deftype Keyword [k] IFn - (invoke [_ coll] + (-invoke [_ coll] (when-not (nil? coll) (let [strobj (.-strobj coll)] (if (nil? strobj) (-lookup coll k nil) (aget strobj k))))) - (invoke [_ coll not-found] + (-invoke [_ coll not-found] (if (nil? coll) not-found (-lookup coll k not-found)))) -- 1.7.8.6