diff options
23 files changed, 3635 insertions, 1011 deletions
diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj index eb40cc14..6e5da291 100644 --- a/src/clj/clojure/core.clj +++ b/src/clj/clojure/core.clj @@ -243,7 +243,8 @@ (assoc m :inline (cons ifn (cons name (next inline)))) m))] (list 'def (with-meta name (conj (if (meta name) (meta name) {}) m)) - (cons `fn fdecl))))) + (cons `fn (cons name fdecl)))))) + ;(cons `fn fdecl))))) (. (var defn) (setMacro)) @@ -449,8 +450,6 @@ [obj f & args] (with-meta obj (apply f (meta obj) args))) - - (defmacro lazy-seq "Takes a body of expressions that returns an ISeq or nil, and yields a Seqable object that will invoke the body only the first time seq @@ -511,8 +510,6 @@ (cat (concat x y) zs)))) ;;;;;;;;;;;;;;;;at this point all the support for syntax-quote exists;;;;;;;;;;;;;;;;;;;;;; - - (defmacro delay "Takes a body of expressions and yields a Delay object that will invoke the body only the first time it is forced (with force), and @@ -1951,6 +1948,10 @@ (next vs)) map))) +(defmacro declare + "defs the supplied var names with no bindings, useful for making forward declarations." + [& names] `(do ~@(map #(list 'def (vary-meta % assoc :declared true)) names))) + (defn line-seq "Returns the lines of text from rdr as a lazy sequence of strings. rdr must implement java.io.BufferedReader." @@ -2199,7 +2200,11 @@ (defn type "Returns the :type metadata of x, or its Class if none" [x] - (or (:type (meta x)) (class x))) + (or (:type (meta x)) + (if (instance? clojure.lang.IDynamicType x) + (let [x #^ clojure.lang.IDynamicType x] + (.getDynamicType x)) + (class x)))) (defn num "Coerce to Number" @@ -2327,6 +2332,7 @@ of *out*. Prints the object(s), separated by spaces if there is more than one. By default, pr and prn print in a way that objects can be read by the reader" + {:dynamic true} ([] nil) ([x] (pr-on x *out*)) @@ -2924,7 +2930,7 @@ (let [name (if (symbol? (first sigs)) (first sigs) nil) sigs (if name (next sigs) sigs) sigs (if (vector? (first sigs)) (list sigs) sigs) - psig (fn [sig] + psig (fn* [sig] (let [[params & body] sig conds (when (and (next body) (map? (first body))) (first body)) @@ -2936,11 +2942,11 @@ `((let [~'% ~(if (< 1 (count body)) `(do ~@body) (first body))] - ~@(map (fn [c] `(assert ~c)) post) + ~@(map (fn* [c] `(assert ~c)) post) ~'%)) body) body (if pre - (concat (map (fn [c] `(assert ~c)) pre) + (concat (map (fn* [c] `(assert ~c)) pre) body) body)] (if (every? symbol? params) @@ -3680,10 +3686,11 @@ (defn bases "Returns the immediate superclass and direct interfaces of c, if any" [#^Class c] - (let [i (.getInterfaces c) - s (.getSuperclass c)] - (not-empty - (if s (cons s i) i)))) + (when c + (let [i (.getInterfaces c) + s (.getSuperclass c)] + (not-empty + (if s (cons s i) i))))) (defn supers "Returns the immediate and indirect superclasses and interfaces of c, if any" @@ -3865,7 +3872,7 @@ [fmt & args] (print (apply format fmt args))) -(def gen-class) +(declare gen-class) (defmacro with-loading-context [& body] `((fn loading# [] @@ -3997,7 +4004,7 @@ (let [d (root-resource lib)] (subs d 0 (.lastIndexOf d "/")))) -(def load) +(declare load) (defn- load-one "Loads a lib given its name. If need-ns, ensures that the associated @@ -4272,10 +4279,6 @@ #^{:doc "bound in a repl thread to the most recent exception caught by the repl"} *e) -(defmacro declare - "defs the supplied var names with no bindings, useful for making forward declarations." - [& names] `(do ~@(map #(list 'def %) names))) - (defn trampoline "trampoline can be used to convert algorithms requiring mutual recursion without stack consumption. Calls f with supplied args, if @@ -4456,11 +4459,91 @@ "Returns true if future f is done" [#^java.util.concurrent.Future f] (.isDone f)) + +(defmacro letfn + "Takes a vector of function specs and a body, and generates a set of + bindings of functions to their names. All of the names are available + in all of the definitions of the functions, as well as the body. + + fnspec ==> (fname [params*] exprs) or (fname ([params*] exprs)+)" + [fnspecs & body] + `(letfn* ~(vec (interleave (map first fnspecs) + (map #(cons `fn %) fnspecs))) + ~@body)) + + +;;;;;;; case ;;;;;;;;;;;;; +(defn- shift-mask [shift mask x] + (-> x (bit-shift-right shift) (bit-and mask))) + +(defn- min-hash + "takes a collection of keys and returns [shift mask]" + [keys] + (let [hashes (map hash keys) + cnt (count keys)] + (when-not (apply distinct? hashes) + (throw (IllegalArgumentException. "Hashes must be distinct"))) + (or (first + (filter (fn [[s m]] + (apply distinct? (map #(shift-mask s m %) hashes))) + (for [mask (map #(dec (bit-shift-left 1 %)) (range 1 14)) + shift (range 0 31)] + [shift mask]))) + (throw (IllegalArgumentException. "No distinct mapping found"))))) + +(defmacro case + "Takes an expression, and a set of clauses. + + Each clause can take the form of either: + + test-constant result-expr + + (test-constant1 ... test-constantN) result-expr + + The test-constants are not evaluated. They must be compile-time + literals, and need not be quoted. If the expression is equal to a + test-constant, the corresponding result-expr is returned. A single + default expression can follow the clauses, and its value will be + returned if no clause matches. If no default expression is provided + and no clause matches, an IllegalArgumentException is thrown. + + Unlike cond and condp, case does a constant-time dispatch, the + clauses are not considered sequentially. All manner of constant + expressions are acceptable in case, including numbers, strings, + symbols, keywords, and (Clojure) composites thereof. Note that since + lists are used to group multiple constants that map to the same + expression, a vector can be used to match a list if needed. The + test-constants need not be all of the same type." + + [e & clauses] + (let [ge (with-meta (gensym) {:tag Object}) + default (if (odd? (count clauses)) + (last clauses) + `(throw (IllegalArgumentException. (str "No matching clause: " ~ge)))) + cases (partition 2 clauses) + case-map (reduce (fn [m [test expr]] + (if (seq? test) + (into m (zipmap test (repeat expr))) + (assoc m test expr))) + {} cases) + [shift mask] (if (seq case-map) (min-hash (keys case-map)) [0 0]) + + hmap (reduce (fn [m [test expr :as te]] + (assoc m (shift-mask shift mask (hash test)) te)) + (sorted-map) case-map)] + `(let [~ge ~e] + ~(condp = (count clauses) + 0 default + 1 default + `(case* ~ge ~shift ~mask ~(key (first hmap)) ~(key (last hmap)) ~default ~hmap + ~(every? keyword? (keys case-map))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; helper files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (alter-meta! (find-ns 'clojure.core) assoc :doc "Fundamental library of the Clojure language") (load "core_proxy") (load "core_print") (load "genclass") +(load "core_deftype") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; futures (needs proxy);;;;;;;;;;;;;;;;;; (defn future-call @@ -4470,10 +4553,12 @@ not yet finished, calls to deref/@ will block." [#^Callable f] (let [fut (.submit clojure.lang.Agent/soloExecutor f)] - (proxy [clojure.lang.IDeref java.util.concurrent.Future] [] + (reify + clojure.lang.IDeref (deref [] (.get fut)) - (get ([] (.get fut)) - ([timeout unit] (.get fut timeout unit))) + java.util.concurrent.Future + (get [] (.get fut)) + (get [timeout unit] (.get fut timeout unit)) (isCancelled [] (.isCancelled fut)) (isDone [] (.isDone fut)) (cancel [interrupt?] (.cancel fut interrupt?))))) @@ -4528,16 +4613,6 @@ [& exprs] `(pcalls ~@(map #(list `fn [] %) exprs))) -(defmacro letfn - "Takes a vector of function specs and a body, and generates a set of - bindings of functions to their names. All of the names are available - in all of the definitions of the functions, as well as the body. - - fnspec ==> (fname [params*] exprs) or (fname ([params*] exprs)+)" - [fnspecs & body] - `(letfn* ~(vec (interleave (map first fnspecs) - (map #(cons `fn %) fnspecs))) - ~@body)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; clojure version number ;;;;;;;;;;;;;;;;;;;;;; @@ -4583,8 +4658,10 @@ [] (let [d (java.util.concurrent.CountDownLatch. 1) v (atom nil)] - (proxy [clojure.lang.AFn clojure.lang.IDeref] [] + (reify :as this + clojure.lang.IDeref (deref [] (.await d) @v) + clojure.lang.IFn (invoke [x] (locking d (if (pos? (.getCount d)) @@ -4678,3 +4755,4 @@ (recur (conj ret (first items)) (next items)) ret))))) +
\ No newline at end of file diff --git a/src/clj/clojure/core_deftype.clj b/src/clj/clojure/core_deftype.clj new file mode 100644 index 00000000..c675a012 --- /dev/null +++ b/src/clj/clojure/core_deftype.clj @@ -0,0 +1,661 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +; which can be found in the file epl-v10.html at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +(in-ns 'clojure.core) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; reify/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- parse-opts [s] + (loop [opts {} [k v & rs :as s] s] + (if (keyword? k) + (recur (assoc opts k v) rs) + [opts s]))) + +(defn- parse-impls [specs] + (loop [ret {} s specs] + (if (seq s) + (recur (assoc ret (first s) (take-while seq? (next s))) + (drop-while seq? (next s))) + ret))) + +(defn- parse-opts+specs [opts+specs] + (let [[opts specs] (parse-opts opts+specs) + impls (parse-impls specs) + interfaces (-> (map #(if (var? (resolve %)) + (:on (deref (resolve %))) + %) + (keys impls)) + set + (disj 'Object 'java.lang.Object) + vec) + methods (mapcat #(map (fn [[nm [& args] & body]] + `(~nm [~(:as opts) ~@args] ~@body)) %) + (vals impls))] + [interfaces methods])) + +(defmacro reify + "reify is a macro with the following structure: + + (reify options* specs*) + + Currently there is only one option: + + :as this-name + + which can be used to provide a name to refer to the target + object ('this' in Java/C# parlance) within the method bodies, if + needed. + + Each spec consists of the protocol or interface name followed by zero + or more method bodies: + + protocol-or-interface-or-Object + (methodName [args*] body)* + + Methods should be supplied for all methods of the desired + protocol(s) and interface(s). You can also define overrides for + methods of Object. Note that no parameter is supplied to correspond + to the target object ('this' in Java parlance). Thus methods for + protocols will take one fewer arguments than do the + protocol functions. + + The return type can be indicated by a type hint on the method name, + and arg types can be indicated by a type hint on arg names. If you + leave out all hints, reify will try to match on same name/arity + method in the protocol(s)/interface(s) - this is preferred. If you + supply any hints at all, no inference is done, so all hints (or + default of Object) must be correct, for both arguments and return + type. If a method is overloaded in a protocol/interface, multiple + independent method definitions must be supplied. If overloaded with + same arity in an interface you must specify complete hints to + disambiguate - a missing hint implies Object. + + recur works to method heads The method bodies of reify are lexical + closures, and can refer to the surrounding local scope: + + (str (let [f \"foo\"] + (reify Object + (toString [] f)))) + == \"foo\" + + (seq (let [f \"foo\"] + (reify clojure.lang.Seqable + (seq [] (seq f))))) + == (\\f \\o \\o))" + + [& opts+specs] + (let [[interfaces methods] (parse-opts+specs opts+specs)] + `(reify* ~interfaces ~@methods))) + +(defn hash-combine [x y] + (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y))) + +(defn munge [s] + ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s)))) + +(defn- emit-deftype* + "Do not use this directly - use deftype" + [tagname name fields interfaces methods] + (let [tag (keyword (str *ns*) (str tagname)) + classname (symbol (str *ns* "." name)) + interfaces (vec interfaces) + interface-set (set (map resolve interfaces)) + methodname-set (set (map first methods)) + dynamic-type (contains? interface-set clojure.lang.IDynamicType) + implement? (fn [iface] (not (contains? interface-set iface))) + hinted-fields fields + fields (vec (map #(with-meta % nil) fields)) + base-fields fields + fields (conj fields '__meta '__extmap)] + (letfn + [(eqhash [[i m]] + (if (not (or (contains? methodname-set 'equals) (contains? methodname-set 'hashCode))) + [i + (conj m + `(hashCode [~'this] (-> ~tag hash ~@(map #(list `hash-combine %) (remove #{'__meta} fields)))) + `(equals [~'this ~'o] + (boolean + (or (identical? ~'this ~'o) + (when (instance? clojure.lang.IDynamicType ~'o) + (let [~'o ~(with-meta 'o {:tag 'clojure.lang.IDynamicType})] + (and (= ~tag (.getDynamicType ~'o)) + ~@(map (fn [fld] `(= ~fld (.getDynamicField ~'o ~(keyword fld) ~'this))) base-fields) + (= ~'__extmap (.getExtensionMap ~'o)))))))))] + [i m])) + (iobj [[i m]] + (if (and (implement? clojure.lang.IObj) (implement? clojure.lang.IMeta)) + [(conj i 'clojure.lang.IObj) + (conj m `(meta [~'this] ~'__meta) + `(withMeta [~'this ~'m] (new ~tagname ~@(replace {'__meta 'm} fields))))] + [i m])) + (ilookup [[i m]] + (if (not (methodname-set 'valAt)) + [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) + (conj m `(valAt [~'this k#] (.valAt ~'this k# nil)) + `(valAt [~'this k# else#] + (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) + base-fields) + (get ~'__extmap k# else#))) + `(getLookupThunk [~'this k#] + (case k# + ~@(mapcat + (fn [fld] + (let [cstr (str (clojure.core/name classname) "$__lookup__" (clojure.core/name fld))] + [(keyword fld) + `(-> ~cstr (Class/forName) (.newInstance))])) + base-fields) + nil)))] + [i m])) + (idynamictype [[i m]] + [(conj i 'clojure.lang.IDynamicType) + (conj m + `(getDynamicType [~'this] ~tag) + `(getExtensionMap [~'this] ~'__extmap) + `(getDynamicField [~'this k# else#] + (condp identical? k# ~@(mapcat (fn [fld] [(keyword fld) fld]) base-fields) + (get ~'__extmap k# else#))))]) + (imap [[i m]] + (if (and (interface-set clojure.lang.IPersistentMap) (not (methodname-set 'assoc))) + [i + (conj m + `(count [~'this] (+ ~(count base-fields) (count ~'__extmap))) + `(empty [~'this] (throw (UnsupportedOperationException. (str "Can't create empty: " ~(str classname))))) + `(cons [~'this e#] (let [[k# v#] e#] (.assoc ~'this k# v#))) + `(equiv [~'this o#] (.equals ~'this o#)) + `(containsKey [~'this k#] (not (identical? ~'this (.valAt ~'this k# ~'this)))) + `(entryAt [~'this k#] (let [v# (.valAt ~'this k# ~'this)] + (when-not (identical? ~'this v#) + (clojure.lang.MapEntry. k# v#)))) + `(seq [~'this] (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] + ~'__extmap)) + (let [gk (gensym) gv (gensym)] + `(assoc [~'this ~gk ~gv] + (condp identical? ~gk + ~@(mapcat (fn [fld] + [(keyword fld) (list* `new tagname (replace {fld gv} fields))]) + base-fields) + (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap ~gk ~gv))))) + `(without [~'this k#] (if (contains? #{~@(map keyword base-fields)} k#) + (dissoc (with-meta (into {} ~'this) ~'__meta) k#) + (new ~tagname ~@(remove #{'__extmap} fields) + (not-empty (dissoc ~'__extmap k#))))))] + [i m]))] + (let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap idynamictype)] + `(deftype* ~tagname ~classname ~(conj hinted-fields '__meta '__extmap) + :implements ~(vec i) + ~@m))))) + +(defmacro deftype + "Alpha - subject to change + + (deftype name [fields*] options* specs*) + + Currently there is only one option: + + :as this-name + + which can be used to provide a name to refer to the target + object ('this' in Java/C# parlance) within the method bodies, if + needed. + + Each spec consists of a protocol or interface name followed by zero + or more method bodies: + + protocol-or-interface-or-Object + (methodName [args*] body)* + + Dynamically generates compiled bytecode for an anonymous class with + the given fields, and, optionally, methods for protocols and/or + interfaces. The Name will be used to create a dynamic type tag + keyword of the form :current.ns/Name. This tag will be returned + from (type an-instance). + + A factory function of current.ns/Name will be defined, + overloaded on 2 arities, the first taking the designated fields in + the same order specified, and the second taking the fields followed + by a metadata map (nil for none) and an extension field map (nil for + none). + + The class will have the (immutable) fields named by fields, which + can have type hints. Protocols/interfaces and methods are + optional. The only methods that can be supplied are those declared + in the protocols/interfaces. Note that method bodies are not + closures, the local environment includes only the named fields, and + those fields can be accessed directy. + + Method definitions take the form: + + (methodname [args*] body) + + The argument and return types can be hinted on the arg and + methodname symbols. If not supplied, they will be inferred, so type + hints should be reserved for disambiguation. + + Methods should be supplied for all methods of the desired + protocol(s) and interface(s). You can also define overrides for + methods of Object. Note that no parameter is supplied to correspond + to the target object ('this' in Java parlance). Thus methods for + protocols will take one fewer arguments than do the + protocol functions. + + In the method bodies, the (unqualified) name can be used to name the + class (for calls to new, instance? etc). + + The class will have implementations of two (clojure.lang) interfaces + generated automatically: IObj (metadata support), ILookup (get and + keyword lookup for fields). If you specify IPersistentMap as an + interface, but don't define methods for it, an implementation will + be generated automatically. + + In addition, unless you supply a version of hashCode or equals, + deftype/class will define type-and-value-based equality and + hashCode. + + When AOT compiling, generates compiled bytecode for a class with the + given name (a symbol), prepends the current ns as the package, and + writes the .class file to the *compile-path* directory. + + Two constructors will be defined, one taking the designated fields + followed by a metadata map (nil for none) and an extension field + map (nil for none), and one taking only the fields (using nil for + meta and extension fields). + + When dynamically evaluated, the class will have a generated name." + + [name [& fields] & opts+specs] + (let [gname (if *compile-files* name (gensym (str name "__"))) + [interfaces methods] (parse-opts+specs opts+specs) + classname (symbol (str *ns* "." gname)) + tag (keyword (str *ns*) (str name)) + hinted-fields fields + fields (vec (map #(with-meta % nil) fields))] + `(do + ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods) + (defmethod print-method ~tag [o# w#] + ((var print-deftype) ~(vec (map #(-> % str keyword) fields)) o# w#)) + (defn ~name + ([~@fields] (new ~classname ~@fields nil nil)) + ([~@fields meta# extmap#] (new ~classname ~@fields meta# extmap#)))))) + +(defn- print-deftype [fields, #^clojure.lang.IDynamicType o, #^Writer w] + (print-meta o w) + (.write w "#:") + (.write w (str (name (.getDynamicType o)))) + (print-map + (concat + (map #(clojure.lang.MapEntry. % (.getDynamicField o % nil)) fields) + (.getExtensionMap o)) + pr-on w)) + + +;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;; + +(defn dtype + "Returns the dynamic type of x, or its Class if none" + [x] + (if (instance? clojure.lang.IDynamicType x) + (let [x #^ clojure.lang.IDynamicType x] + (.getDynamicType x)) + (class x))) + +(defn- expand-method-impl-cache [#^clojure.lang.MethodImplCache cache c f] + (let [cs (into {} (remove (fn [[c f]] (nil? f)) (map vec (partition 2 (.table cache))))) + cs (assoc cs c f) + [shift mask] (min-hash (keys cs)) + table (make-array Object (* 2 (inc mask))) + table (reduce (fn [#^objects t [c f]] + (let [i (* 2 (int (shift-mask shift mask (hash c))))] + (aset t i c) + (aset t (inc i) f) + t)) + table cs)] + (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) shift mask table))) + +(defn- super-chain [#^Class c] + (when c + (cons c (super-chain (.getSuperclass c))))) + +(defn find-protocol-impl [protocol x] + (if (and (:on-interface protocol) (instance? (:on-interface protocol) x)) + x + (let [t (dtype x) + c (class x) + impl #(get (:impls protocol) %)] + (or (impl t) + (impl c) + (and c (or (first (remove nil? (map impl (butlast (super-chain c))))) + (first (remove nil? (map impl (disj (supers c) Object)))) + (impl Object))))))) + +(defn find-protocol-method [protocol methodk x] + (get (find-protocol-impl protocol x) methodk)) + +(defn extends? + "Returns true if atype explicitly extends protocol" + [protocol atype] + (when (get (:impls protocol) atype) true)) + +(defn extenders + "Returns a collection of the types explicitly extending protocol" + [protocol] + (keys (:impls protocol))) + +(defn satisfies? + "Returns true if x satisfies the protocol" + [protocol x] + (when + (or (and (:on-interface protocol) (instance? (:on-interface protocol) x)) + (find-protocol-impl protocol x)) + true)) + +(defn -cache-protocol-fn [#^clojure.lang.AFunction pf x] + (let [cache (.__methodImplCache pf) + f (find-protocol-method (.protocol cache) (.methodk cache) x)] + (when-not f + (throw (IllegalArgumentException. (str "No implementation of method: " (.methodk cache) + " of protocol: " (:var (.protocol cache)) + " found for class: " (if (nil? x) "nil" (.getName (class x))))))) + (set! (.__methodImplCache pf) (expand-method-impl-cache cache (class x) f)) + f)) + +(defn- emit-method-builder [on-interface method on-method arglists] + (let [methodk (keyword method) + gthis (with-meta (gensym) {:tag 'clojure.lang.AFunction})] + `(fn [cache#] + (let [#^clojure.lang.AFunction f# + (fn ~gthis + ~@(map + (fn [args] + (let [gargs (map #(gensym (str "g__" % "__")) args) + target (first gargs)] + `([~@gargs] + (~@(if on-interface + `(if (instance? ~on-interface ~target) + (. ~(with-meta target {:tag on-interface}) ~(or on-method method) ~@(rest gargs))) + `(do)) + (let [cache# (.__methodImplCache ~gthis)] + (if (clojure.lang.Util/identical (clojure.lang.Util/classOf ~target) + (.lastClass cache#)) + ((.lastImpl cache#) ~@gargs) + (let [f# (or (.fnFor cache# (clojure.lang.Util/classOf ~target)) + (-cache-protocol-fn ~gthis ~target))] + (f# ~@gargs)))))))) + arglists))] + (set! (.__methodImplCache f#) cache#) + f#)))) + +(defn -reset-methods [protocol] + (doseq [[#^clojure.lang.Var v build] (:method-builders protocol)] + (let [cache (clojure.lang.MethodImplCache. protocol (keyword (.sym v)))] + (.bindRoot v (build cache))))) + +(defn- assert-same-protocol [protocol-var method-syms] + (doseq [m method-syms] + (let [v (resolve m) + p (:protocol (meta v))] + (when-not (or (nil? v) (= protocol-var p)) + (binding [*out* *err*] + (println "Warning: protocol" protocol-var "is overwriting" + (if p + (str "method " (.sym v) " of protocol " (.sym p)) + (str "function " (.sym v))))))))) + +(defn- emit-protocol [name opts+sigs] + (let [iname (symbol (str (munge *ns*) "." (munge name))) + [opts sigs] + (loop [opts {:on (list 'quote iname) :on-interface iname} sigs opts+sigs] + (condp #(%1 %2) (first sigs) + string? (recur (assoc opts :doc (first sigs)) (next sigs)) + keyword? (recur (assoc opts (first sigs) (second sigs)) (nnext sigs)) + [opts sigs])) + sigs (reduce (fn [m s] + (let [mname (with-meta (first s) nil) + [arglists doc] + (loop [as [] rs (rest s)] + (if (vector? (first rs)) + (recur (conj as (first rs)) (next rs)) + [(seq as) (first rs)]))] + (when (some #{0} (map count arglists)) + (throw (IllegalArgumentException. (str "Protocol fn: " mname " must take at least one arg")))) + (assoc m (keyword mname) + {:name (vary-meta mname assoc :doc doc :arglists arglists) + :arglists arglists + :doc doc}))) + {} sigs) + meths (mapcat (fn [sig] + (let [m (munge (:name sig))] + (map #(vector m (vec (repeat (dec (count %))'Object)) 'Object) + (:arglists sig)))) + (vals sigs))] + `(do + (defonce ~name {}) + (gen-interface :name ~iname :methods ~meths) + (alter-meta! (var ~name) assoc :doc ~(:doc opts)) + (#'assert-same-protocol (var ~name) '~(map :name (vals sigs))) + (alter-var-root (var ~name) merge + (assoc ~opts + :sigs '~sigs + :var (var ~name) + :method-map + ~(and (:on opts) + (apply hash-map + (mapcat + (fn [s] + [(keyword (:name s)) (keyword (or (:on s) (:name s)))]) + (vals sigs)))) + :method-builders + ~(apply hash-map + (mapcat + (fn [s] + [`(intern *ns* (with-meta '~(:name s) {:protocol (var ~name)})) + (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))]) + (vals sigs))))) + (-reset-methods ~name) + '~name))) + +(defmacro defprotocol + "A protocol is a named set of named methods and their signatures: + (defprotocol AProtocolName + + ;optional doc string + \"A doc string for AProtocol abstraction\" + + ;method signatures + (bar [a b] \"bar docs\") + (baz [a] [a b] [a b c] \"baz docs\")) + + No implementations are provided. Docs can be specified for the + protocol overall and for each method. The above yields a set of + polymorphic functions and a protocol object. All are + namespace-qualified by the ns enclosing the definition The resulting + functions dispatch on the type of their first argument, and thus + must have at least one argument. defprotocol is dynamic, has no + special compile-time effect, and defines no new types or classes + Implementations of the protocol methods can be provided using + extend. + + defprotocol will automatically generate a corresponding interface, + with the same name as the protocol, i.e. given a protocol: + my.ns/Protocol, an interface: my.ns.Protocol. The interface will + have methods corresponding to the protocol functions, and the + protocol will automatically work with instances of the interface. + + Note that you should not use this interface with deftype or + reify, as they support the protocol directly: + + (defprotocol P + (foo [x]) + (bar-me [x] [x y])) + + (deftype Foo [a b c] + P + (foo [] a) + (bar-me [] b) + (bar-me [y] (+ c y))) + + (bar-me (Foo 1 2 3) 42) + + (foo + (let [x 42] + (reify P + (foo [] 17) + (bar-me [] x) + (bar-me [y] x))))" + + [name & opts+sigs] + (emit-protocol name opts+sigs)) + +(defn extend + "Implementations of protocol methods can be provided using the extend construct: + + (extend ::AType ;or AClass or AnInterface + AProtocol + {:foo an-existing-fn + :bar (fn [a b] ...) + :baz (fn ([a]...) ([a b] ...)...)} + BProtocol + {...} + ...) + + + extend takes a type/class (or interface, see below), and one or more + protocol + method map pairs. It will extend the polymorphism of the + prot |