1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/core_deftype.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,769 @@
     1.4 +;   Copyright (c) Rich Hickey. All rights reserved.
     1.5 +;   The use and distribution terms for this software are covered by the
     1.6 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.7 +;   which can be found in the file epl-v10.html at the root of this distribution.
     1.8 +;   By using this software in any fashion, you are agreeing to be bound by
     1.9 +;   the terms of this license.
    1.10 +;   You must not remove this notice, or any other, from this software.
    1.11 +
    1.12 +(in-ns 'clojure.core)
    1.13 +
    1.14 +;;;;;;;;;;;;;;;;;;;;;;;;;;;; definterface ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.15 +
    1.16 +(defn namespace-munge
    1.17 +  "Convert a Clojure namespace name to a legal Java package name."
    1.18 +  {:added "1.2"}
    1.19 +  [ns]
    1.20 +  (.replace (str ns) \- \_))
    1.21 +
    1.22 +;for now, built on gen-interface
    1.23 +(defmacro definterface 
    1.24 +  [name & sigs]
    1.25 +  (let [tag (fn [x] (or (:tag (meta x)) Object))
    1.26 +        psig (fn [[name [& args]]]
    1.27 +               (vector name (vec (map tag args)) (tag name) (map meta args)))
    1.28 +        cname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))]
    1.29 +    `(let [] 
    1.30 +       (gen-interface :name ~cname :methods ~(vec (map psig sigs)))
    1.31 +       (import ~cname))))
    1.32 +
    1.33 +;;;;;;;;;;;;;;;;;;;;;;;;;;;; reify/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.34 +
    1.35 +(defn- parse-opts [s]
    1.36 +  (loop [opts {} [k v & rs :as s] s]
    1.37 +    (if (keyword? k)
    1.38 +      (recur (assoc opts k v) rs)
    1.39 +      [opts s])))
    1.40 +
    1.41 +(defn- parse-impls [specs]
    1.42 +  (loop [ret {} s specs]
    1.43 +    (if (seq s)
    1.44 +      (recur (assoc ret (first s) (take-while seq? (next s)))
    1.45 +             (drop-while seq? (next s)))
    1.46 +      ret)))
    1.47 +
    1.48 +(defn- parse-opts+specs [opts+specs]
    1.49 +  (let [[opts specs] (parse-opts opts+specs)
    1.50 +        impls (parse-impls specs)
    1.51 +        interfaces (-> (map #(if (var? (resolve %)) 
    1.52 +                               (:on (deref (resolve %)))
    1.53 +                               %)
    1.54 +                            (keys impls))
    1.55 +                       set
    1.56 +                       (disj 'Object 'java.lang.Object)
    1.57 +                       vec)
    1.58 +        methods (map (fn [[name params & body]]
    1.59 +                       (cons name (maybe-destructured params body)))
    1.60 +                     (apply concat (vals impls)))]
    1.61 +    (when-let [bad-opts (seq (remove #{:no-print} (keys opts)))]
    1.62 +      (throw (IllegalArgumentException. (apply print-str "Unsupported option(s) -" bad-opts))))
    1.63 +    [interfaces methods opts]))
    1.64 +
    1.65 +(defmacro reify 
    1.66 +  "reify is a macro with the following structure:
    1.67 +
    1.68 + (reify options* specs*)
    1.69 +  
    1.70 +  Currently there are no options.
    1.71 +
    1.72 +  Each spec consists of the protocol or interface name followed by zero
    1.73 +  or more method bodies:
    1.74 +
    1.75 +  protocol-or-interface-or-Object
    1.76 +  (methodName [args+] body)*
    1.77 +
    1.78 +  Methods should be supplied for all methods of the desired
    1.79 +  protocol(s) and interface(s). You can also define overrides for
    1.80 +  methods of Object. Note that the first parameter must be supplied to
    1.81 +  correspond to the target object ('this' in Java parlance). Thus
    1.82 +  methods for interfaces will take one more argument than do the
    1.83 +  interface declarations.  Note also that recur calls to the method
    1.84 +  head should *not* pass the target object, it will be supplied
    1.85 +  automatically and can not be substituted.
    1.86 +
    1.87 +  The return type can be indicated by a type hint on the method name,
    1.88 +  and arg types can be indicated by a type hint on arg names. If you
    1.89 +  leave out all hints, reify will try to match on same name/arity
    1.90 +  method in the protocol(s)/interface(s) - this is preferred. If you
    1.91 +  supply any hints at all, no inference is done, so all hints (or
    1.92 +  default of Object) must be correct, for both arguments and return
    1.93 +  type. If a method is overloaded in a protocol/interface, multiple
    1.94 +  independent method definitions must be supplied.  If overloaded with
    1.95 +  same arity in an interface you must specify complete hints to
    1.96 +  disambiguate - a missing hint implies Object.
    1.97 +
    1.98 +  recur works to method heads The method bodies of reify are lexical
    1.99 +  closures, and can refer to the surrounding local scope:
   1.100 +  
   1.101 +  (str (let [f \"foo\"] 
   1.102 +       (reify Object 
   1.103 +         (toString [this] f))))
   1.104 +  == \"foo\"
   1.105 +
   1.106 +  (seq (let [f \"foo\"] 
   1.107 +       (reify clojure.lang.Seqable 
   1.108 +         (seq [this] (seq f)))))
   1.109 +  == (\\f \\o \\o))"
   1.110 +  {:added "1.2"} 
   1.111 +  [& opts+specs]
   1.112 +  (let [[interfaces methods] (parse-opts+specs opts+specs)]
   1.113 +    (with-meta `(reify* ~interfaces ~@methods) (meta &form))))
   1.114 +
   1.115 +(defn hash-combine [x y] 
   1.116 +  (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y)))
   1.117 +
   1.118 +(defn munge [s]
   1.119 +  ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s))))
   1.120 +
   1.121 +(defn- imap-cons
   1.122 +  [^IPersistentMap this o]
   1.123 +  (cond
   1.124 +   (instance? java.util.Map$Entry o)
   1.125 +     (let [^java.util.Map$Entry pair o]
   1.126 +       (.assoc this (.getKey pair) (.getValue pair)))
   1.127 +   (instance? clojure.lang.IPersistentVector o)
   1.128 +     (let [^clojure.lang.IPersistentVector vec o]
   1.129 +       (.assoc this (.nth vec 0) (.nth vec 1)))
   1.130 +   :else (loop [this this
   1.131 +                o o]
   1.132 +      (if (seq o)
   1.133 +        (let [^java.util.Map$Entry pair (first o)]
   1.134 +          (recur (.assoc this (.getKey pair) (.getValue pair)) (rest o)))
   1.135 +        this))))
   1.136 +
   1.137 +(defn- emit-defrecord 
   1.138 +  "Do not use this directly - use defrecord"
   1.139 +  {:added "1.2"}
   1.140 +  [tagname name fields interfaces methods]
   1.141 +  (let [tag (keyword (str *ns*) (str tagname))
   1.142 +        classname (with-meta (symbol (str *ns* "." name)) (meta name))
   1.143 +        interfaces (vec interfaces)
   1.144 +        interface-set (set (map resolve interfaces))
   1.145 +        methodname-set (set (map first methods))
   1.146 +        hinted-fields fields
   1.147 +        fields (vec (map #(with-meta % nil) fields))
   1.148 +        base-fields fields
   1.149 +        fields (conj fields '__meta '__extmap)]
   1.150 +    (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields))
   1.151 +      (throw (IllegalArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields")))
   1.152 +    (let [gs (gensym)]
   1.153 +    (letfn 
   1.154 +     [(eqhash [[i m]] 
   1.155 +        [i
   1.156 +         (conj m 
   1.157 +               `(hashCode [this#] (clojure.lang.APersistentMap/mapHash this#))
   1.158 +               `(equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs)))])
   1.159 +      (iobj [[i m]] 
   1.160 +            [(conj i 'clojure.lang.IObj)
   1.161 +             (conj m `(meta [this#] ~'__meta)
   1.162 +                   `(withMeta [this# ~gs] (new ~tagname ~@(replace {'__meta gs} fields))))])
   1.163 +      (ilookup [[i m]] 
   1.164 +         [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup)
   1.165 +          (conj m `(valAt [this# k#] (.valAt this# k# nil))
   1.166 +                `(valAt [this# k# else#] 
   1.167 +                   (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) 
   1.168 +                                       base-fields)
   1.169 +                         (get ~'__extmap k# else#)))
   1.170 +                `(getLookupThunk [this# k#]
   1.171 +                   (let [~'gclass (class this#)]              
   1.172 +                     (case k#
   1.173 +                           ~@(let [hinted-target (with-meta 'gtarget {:tag tagname})] 
   1.174 +                               (mapcat 
   1.175 +                                (fn [fld]
   1.176 +                                  [(keyword fld) 
   1.177 +                                   `(reify clojure.lang.ILookupThunk 
   1.178 +                                           (get [~'thunk ~'gtarget] 
   1.179 +                                                (if (identical? (class ~'gtarget) ~'gclass) 
   1.180 +                                                  (. ~hinted-target ~(keyword fld))
   1.181 +                                                  ~'thunk)))])
   1.182 +                                base-fields))
   1.183 +                           nil))))])
   1.184 +      (imap [[i m]] 
   1.185 +            [(conj i 'clojure.lang.IPersistentMap)
   1.186 +             (conj m 
   1.187 +                   `(count [this#] (+ ~(count base-fields) (count ~'__extmap)))
   1.188 +                   `(empty [this#] (throw (UnsupportedOperationException. (str "Can't create empty: " ~(str classname)))))
   1.189 +                   `(cons [this# e#] ((var imap-cons) this# e#))
   1.190 +                   `(equiv [this# ~gs] 
   1.191 +                        (boolean 
   1.192 +                         (or (identical? this# ~gs)
   1.193 +                             (when (identical? (class this#) (class ~gs))
   1.194 +                               (let [~gs ~(with-meta gs {:tag tagname})]
   1.195 +                                 (and  ~@(map (fn [fld] `(= ~fld (. ~gs ~fld))) base-fields)
   1.196 +                                       (= ~'__extmap (. ~gs ~'__extmap))))))))
   1.197 +                   `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#))))
   1.198 +                   `(entryAt [this# k#] (let [v# (.valAt this# k# this#)]
   1.199 +                                            (when-not (identical? this# v#)
   1.200 +                                              (clojure.lang.MapEntry. k# v#))))
   1.201 +                   `(seq [this#] (seq (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] 
   1.202 +                                              ~'__extmap)))
   1.203 +                   `(assoc [this# k# ~gs]
   1.204 +                     (condp identical? k#
   1.205 +                       ~@(mapcat (fn [fld]
   1.206 +                                   [(keyword fld) (list* `new tagname (replace {fld gs} fields))])
   1.207 +                                 base-fields)
   1.208 +                       (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs))))
   1.209 +                   `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#)
   1.210 +                                            (dissoc (with-meta (into {} this#) ~'__meta) k#)
   1.211 +                                            (new ~tagname ~@(remove #{'__extmap} fields) 
   1.212 +                                                 (not-empty (dissoc ~'__extmap k#))))))])
   1.213 +      (ijavamap [[i m]]
   1.214 +                [(conj i 'java.util.Map 'java.io.Serializable)
   1.215 +                 (conj m
   1.216 +                       `(size [this#] (.count this#))
   1.217 +                       `(isEmpty [this#] (= 0 (.count this#)))
   1.218 +                       `(containsValue [this# v#] (boolean (some #{v#} (vals this#))))
   1.219 +                       `(get [this# k#] (.valAt this# k#))
   1.220 +                       `(put [this# k# v#] (throw (UnsupportedOperationException.)))
   1.221 +                       `(remove [this# k#] (throw (UnsupportedOperationException.)))
   1.222 +                       `(putAll [this# m#] (throw (UnsupportedOperationException.)))
   1.223 +                       `(clear [this#] (throw (UnsupportedOperationException.)))
   1.224 +                       `(keySet [this#] (set (keys this#)))
   1.225 +                       `(values [this#] (vals this#))
   1.226 +                       `(entrySet [this#] (set this#)))])
   1.227 +      ]
   1.228 +     (let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap ijavamap)]
   1.229 +       `(deftype* ~tagname ~classname ~(conj hinted-fields '__meta '__extmap) 
   1.230 +          :implements ~(vec i) 
   1.231 +          ~@m))))))
   1.232 +
   1.233 +(defmacro defrecord
   1.234 +  "Alpha - subject to change
   1.235 +  
   1.236 +  (defrecord name [fields*]  options* specs*)
   1.237 +  
   1.238 +  Currently there are no options.
   1.239 +
   1.240 +  Each spec consists of a protocol or interface name followed by zero
   1.241 +  or more method bodies:
   1.242 +
   1.243 +  protocol-or-interface-or-Object
   1.244 +  (methodName [args*] body)*
   1.245 +
   1.246 +  Dynamically generates compiled bytecode for class with the given
   1.247 +  name, in a package with the same name as the current namespace, the
   1.248 +  given fields, and, optionally, methods for protocols and/or
   1.249 +  interfaces.
   1.250 +
   1.251 +  The class will have the (immutable) fields named by
   1.252 +  fields, which can have type hints. Protocols/interfaces and methods
   1.253 +  are optional. The only methods that can be supplied are those
   1.254 +  declared in the protocols/interfaces.  Note that method bodies are
   1.255 +  not closures, the local environment includes only the named fields,
   1.256 +  and those fields can be accessed directy.
   1.257 +
   1.258 +  Method definitions take the form:
   1.259 +
   1.260 +  (methodname [args*] body)
   1.261 +
   1.262 +  The argument and return types can be hinted on the arg and
   1.263 +  methodname symbols. If not supplied, they will be inferred, so type
   1.264 +  hints should be reserved for disambiguation.
   1.265 +
   1.266 +  Methods should be supplied for all methods of the desired
   1.267 +  protocol(s) and interface(s). You can also define overrides for
   1.268 +  methods of Object. Note that a parameter must be supplied to
   1.269 +  correspond to the target object ('this' in Java parlance). Thus
   1.270 +  methods for interfaces will take one more argument than do the
   1.271 +  interface declarations. Note also that recur calls to the method
   1.272 +  head should *not* pass the target object, it will be supplied
   1.273 +  automatically and can not be substituted.
   1.274 +
   1.275 +  In the method bodies, the (unqualified) name can be used to name the
   1.276 +  class (for calls to new, instance? etc).
   1.277 +
   1.278 +  The class will have implementations of several (clojure.lang)
   1.279 +  interfaces generated automatically: IObj (metadata support) and
   1.280 +  IPersistentMap, and all of their superinterfaces.
   1.281 +
   1.282 +  In addition, defrecord will define type-and-value-based equality and
   1.283 +  hashCode.
   1.284 +
   1.285 +  When AOT compiling, generates compiled bytecode for a class with the
   1.286 +  given name (a symbol), prepends the current ns as the package, and
   1.287 +  writes the .class file to the *compile-path* directory.
   1.288 +
   1.289 +  Two constructors will be defined, one taking the designated fields
   1.290 +  followed by a metadata map (nil for none) and an extension field
   1.291 +  map (nil for none), and one taking only the fields (using nil for
   1.292 +  meta and extension fields)."
   1.293 +  {:added "1.2"}
   1.294 +
   1.295 +  [name [& fields] & opts+specs]
   1.296 +  (let [gname name
   1.297 +        [interfaces methods opts] (parse-opts+specs opts+specs)
   1.298 +        classname (symbol (str *ns* "." gname))
   1.299 +        tag (keyword (str *ns*) (str name))
   1.300 +        hinted-fields fields
   1.301 +        fields (vec (map #(with-meta % nil) fields))]
   1.302 +    `(let []
   1.303 +       ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods)
   1.304 +       (defmethod print-method ~classname [o# w#]
   1.305 +           ((var print-defrecord) o# w#))
   1.306 +       (import ~classname)
   1.307 +       #_(defn ~name
   1.308 +         ([~@fields] (new ~classname ~@fields nil nil))
   1.309 +         ([~@fields meta# extmap#] (new ~classname ~@fields meta# extmap#))))))
   1.310 +
   1.311 +(defn- print-defrecord [o ^Writer w]
   1.312 +  (print-meta o w)
   1.313 +  (.write w "#:")
   1.314 +  (.write w (.getName (class o)))
   1.315 +  (print-map
   1.316 +    o
   1.317 +    pr-on w))
   1.318 +
   1.319 +(defn- emit-deftype* 
   1.320 +  "Do not use this directly - use deftype"
   1.321 +  [tagname name fields interfaces methods]
   1.322 +  (let [classname (with-meta (symbol (str *ns* "." name)) (meta name))]
   1.323 +    `(deftype* ~tagname ~classname ~fields 
   1.324 +       :implements ~interfaces 
   1.325 +       ~@methods)))
   1.326 +
   1.327 +(defmacro deftype
   1.328 +  "Alpha - subject to change
   1.329 +  
   1.330 +  (deftype name [fields*]  options* specs*)
   1.331 +  
   1.332 +  Currently there are no options.
   1.333 +
   1.334 +  Each spec consists of a protocol or interface name followed by zero
   1.335 +  or more method bodies:
   1.336 +
   1.337 +  protocol-or-interface-or-Object
   1.338 +  (methodName [args*] body)*
   1.339 +
   1.340 +  Dynamically generates compiled bytecode for class with the given
   1.341 +  name, in a package with the same name as the current namespace, the
   1.342 +  given fields, and, optionally, methods for protocols and/or
   1.343 +  interfaces. 
   1.344 +
   1.345 +  The class will have the (by default, immutable) fields named by
   1.346 +  fields, which can have type hints. Protocols/interfaces and methods
   1.347 +  are optional. The only methods that can be supplied are those
   1.348 +  declared in the protocols/interfaces.  Note that method bodies are
   1.349 +  not closures, the local environment includes only the named fields,
   1.350 +  and those fields can be accessed directy. Fields can be qualified
   1.351 +  with the metadata :volatile-mutable true or :unsynchronized-mutable
   1.352 +  true, at which point (set! afield aval) will be supported in method
   1.353 +  bodies. Note well that mutable fields are extremely difficult to use
   1.354 +  correctly, and are present only to facilitate the building of higher
   1.355 +  level constructs, such as Clojure's reference types, in Clojure
   1.356 +  itself. They are for experts only - if the semantics and
   1.357 +  implications of :volatile-mutable or :unsynchronized-mutable are not
   1.358 +  immediately apparent to you, you should not be using them.
   1.359 +
   1.360 +  Method definitions take the form:
   1.361 +
   1.362 +  (methodname [args*] body)
   1.363 +
   1.364 +  The argument and return types can be hinted on the arg and
   1.365 +  methodname symbols. If not supplied, they will be inferred, so type
   1.366 +  hints should be reserved for disambiguation.
   1.367 +
   1.368 +  Methods should be supplied for all methods of the desired
   1.369 +  protocol(s) and interface(s). You can also define overrides for
   1.370 +  methods of Object. Note that a parameter must be supplied to
   1.371 +  correspond to the target object ('this' in Java parlance). Thus
   1.372 +  methods for interfaces will take one more argument than do the
   1.373 +  interface declarations. Note also that recur calls to the method
   1.374 +  head should *not* pass the target object, it will be supplied
   1.375 +  automatically and can not be substituted.
   1.376 +
   1.377 +  In the method bodies, the (unqualified) name can be used to name the
   1.378 +  class (for calls to new, instance? etc).
   1.379 +
   1.380 +  When AOT compiling, generates compiled bytecode for a class with the
   1.381 +  given name (a symbol), prepends the current ns as the package, and
   1.382 +  writes the .class file to the *compile-path* directory.
   1.383 +
   1.384 +  One constructors will be defined, taking the designated fields."
   1.385 +  {:added "1.2"}
   1.386 +
   1.387 +  [name [& fields] & opts+specs]
   1.388 +  (let [gname name
   1.389 +        [interfaces methods opts] (parse-opts+specs opts+specs)
   1.390 +        classname (symbol (str *ns* "." gname))
   1.391 +        tag (keyword (str *ns*) (str name))
   1.392 +        hinted-fields fields
   1.393 +        fields (vec (map #(with-meta % nil) fields))]
   1.394 +    `(let []
   1.395 +       ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods)
   1.396 +       (import ~classname))))
   1.397 +
   1.398 +
   1.399 +
   1.400 +
   1.401 +;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;;
   1.402 +
   1.403 +(defn- expand-method-impl-cache [^clojure.lang.MethodImplCache cache c f]
   1.404 +  (let [cs (into {} (remove (fn [[c e]] (nil? e)) (map vec (partition 2 (.table cache)))))
   1.405 +        cs (assoc cs c (clojure.lang.MethodImplCache$Entry. c f))
   1.406 +        [shift mask] (min-hash (keys cs))
   1.407 +        table (make-array Object (* 2 (inc mask)))
   1.408 +        table (reduce (fn [^objects t [c e]]
   1.409 +                        (let [i (* 2 (int (shift-mask shift mask (hash c))))]
   1.410 +                          (aset t i c)
   1.411 +                          (aset t (inc i) e)
   1.412 +                          t))
   1.413 +                      table cs)]
   1.414 +    (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) shift mask table)))
   1.415 +
   1.416 +(defn- super-chain [^Class c]
   1.417 +  (when c
   1.418 +    (cons c (super-chain (.getSuperclass c)))))
   1.419 +
   1.420 +(defn- pref
   1.421 +  ([] nil)
   1.422 +  ([a] a) 
   1.423 +  ([^Class a ^Class b]
   1.424 +     (if (.isAssignableFrom a b) b a)))
   1.425 +
   1.426 +(defn find-protocol-impl [protocol x]
   1.427 +  (if (instance? (:on-interface protocol) x)
   1.428 +    x
   1.429 +    (let [c (class x)
   1.430 +          impl #(get (:impls protocol) %)]
   1.431 +      (or (impl c)
   1.432 +          (and c (or (first (remove nil? (map impl (butlast (super-chain c)))))
   1.433 +                     (when-let [t (reduce pref (filter impl (disj (supers c) Object)))]
   1.434 +                       (impl t))
   1.435 +                     (impl Object)))))))
   1.436 +
   1.437 +(defn find-protocol-method [protocol methodk x]
   1.438 +  (get (find-protocol-impl protocol x) methodk))
   1.439 +
   1.440 +(defn- protocol?
   1.441 +  [maybe-p]
   1.442 +  (boolean (:on-interface maybe-p)))
   1.443 +
   1.444 +(defn- implements? [protocol atype]
   1.445 +  (and atype (.isAssignableFrom ^Class (:on-interface protocol) atype)))
   1.446 +
   1.447 +(defn extends? 
   1.448 +  "Returns true if atype extends protocol"
   1.449 +  {:added "1.2"}
   1.450 +  [protocol atype]
   1.451 +  (boolean (or (implements? protocol atype) 
   1.452 +               (get (:impls protocol) atype))))
   1.453 +
   1.454 +(defn extenders 
   1.455 +  "Returns a collection of the types explicitly extending protocol"
   1.456 +  {:added "1.2"}
   1.457 +  [protocol]
   1.458 +  (keys (:impls protocol)))
   1.459 +
   1.460 +(defn satisfies? 
   1.461 +  "Returns true if x satisfies the protocol"
   1.462 +  {:added "1.2"}
   1.463 +  [protocol x]
   1.464 +  (boolean (find-protocol-impl protocol x)))
   1.465 +
   1.466 +(defn -cache-protocol-fn [^clojure.lang.AFunction pf x ^Class c ^clojure.lang.IFn interf]
   1.467 +  (let [cache  (.__methodImplCache pf)
   1.468 +        f (if (.isInstance c x)
   1.469 +            interf 
   1.470 +            (find-protocol-method (.protocol cache) (.methodk cache) x))]
   1.471 +    (when-not f
   1.472 +      (throw (IllegalArgumentException. (str "No implementation of method: " (.methodk cache) 
   1.473 +                                             " of protocol: " (:var (.protocol cache)) 
   1.474 +                                             " found for class: " (if (nil? x) "nil" (.getName (class x)))))))
   1.475 +    (set! (.__methodImplCache pf) (expand-method-impl-cache cache (class x) f))
   1.476 +    f))
   1.477 +
   1.478 +(defn- emit-method-builder [on-interface method on-method arglists]
   1.479 +  (let [methodk (keyword method)
   1.480 +        gthis (with-meta (gensym) {:tag 'clojure.lang.AFunction})
   1.481 +        ginterf (gensym)]
   1.482 +    `(fn [cache#]
   1.483 +       (let [~ginterf
   1.484 +             (fn
   1.485 +               ~@(map 
   1.486 +                  (fn [args]
   1.487 +                    (let [gargs (map #(gensym (str "gf__" % "__")) args)
   1.488 +                          target (first gargs)]
   1.489 +                      `([~@gargs]
   1.490 +                          (. ~(with-meta target {:tag on-interface})  ~(or on-method method) ~@(rest gargs)))))
   1.491 +                  arglists))
   1.492 +             ^clojure.lang.AFunction f#
   1.493 +             (fn ~gthis
   1.494 +               ~@(map 
   1.495 +                  (fn [args]
   1.496 +                    (let [gargs (map #(gensym (str "gf__" % "__")) args)
   1.497 +                          target (first gargs)]
   1.498 +                      `([~@gargs]
   1.499 +                          (let [cache# (.__methodImplCache ~gthis)
   1.500 +                                f# (.fnFor cache# (clojure.lang.Util/classOf ~target))]
   1.501 +                            (if f# 
   1.502 +                              (f# ~@gargs)
   1.503 +                              ((-cache-protocol-fn ~gthis ~target ~on-interface ~ginterf) ~@gargs))))))
   1.504 +                  arglists))]
   1.505 +         (set! (.__methodImplCache f#) cache#)
   1.506 +         f#))))
   1.507 +
   1.508 +(defn -reset-methods [protocol]
   1.509 +  (doseq [[^clojure.lang.Var v build] (:method-builders protocol)]
   1.510 +    (let [cache (clojure.lang.MethodImplCache. protocol (keyword (.sym v)))]
   1.511 +      (.bindRoot v (build cache)))))
   1.512 +
   1.513 +(defn- assert-same-protocol [protocol-var method-syms]
   1.514 +  (doseq [m method-syms]
   1.515 +    (let [v (resolve m)
   1.516 +          p (:protocol (meta v))]
   1.517 +      (when (and v (bound? v) (not= protocol-var p))
   1.518 +        (binding [*out* *err*]
   1.519 +          (println "Warning: protocol" protocol-var "is overwriting"
   1.520 +                   (if p
   1.521 +                     (str "method " (.sym v) " of protocol " (.sym p))
   1.522 +                     (str "function " (.sym v)))))))))
   1.523 +
   1.524 +(defn- emit-protocol [name opts+sigs]
   1.525 +  (let [iname (symbol (str (munge *ns*) "." (munge name)))
   1.526 +        [opts sigs]
   1.527 +        (loop [opts {:on (list 'quote iname) :on-interface iname} sigs opts+sigs]
   1.528 +          (condp #(%1 %2) (first sigs) 
   1.529 +            string? (recur (assoc opts :doc (first sigs)) (next sigs))
   1.530 +            keyword? (recur (assoc opts (first sigs) (second sigs)) (nnext sigs))
   1.531 +            [opts sigs]))
   1.532 +        sigs (reduce (fn [m s]
   1.533 +                       (let [name-meta (meta (first s))
   1.534 +                             mname (with-meta (first s) nil)
   1.535 +                             [arglists doc]
   1.536 +                               (loop [as [] rs (rest s)]
   1.537 +                                 (if (vector? (first rs))
   1.538 +                                   (recur (conj as (first rs)) (next rs))
   1.539 +                                   [(seq as) (first rs)]))]
   1.540 +                         (when (some #{0} (map count arglists))
   1.541 +                           (throw (IllegalArgumentException. (str "Protocol fn: " mname " must take at least one arg"))))
   1.542 +                         (assoc m (keyword mname)
   1.543 +                                (merge name-meta
   1.544 +                                       {:name (vary-meta mname assoc :doc doc :arglists arglists)
   1.545 +                                        :arglists arglists
   1.546 +                                        :doc doc}))))
   1.547 +                     {} sigs)
   1.548 +        meths (mapcat (fn [sig]
   1.549 +                        (let [m (munge (:name sig))]
   1.550 +                          (map #(vector m (vec (repeat (dec (count %))'Object)) 'Object) 
   1.551 +                               (:arglists sig))))
   1.552 +                      (vals sigs))]
   1.553 +  `(do
   1.554 +     (defonce ~name {})
   1.555 +     (gen-interface :name ~iname :methods ~meths)
   1.556 +     (alter-meta! (var ~name) assoc :doc ~(:doc opts))
   1.557 +     (#'assert-same-protocol (var ~name) '~(map :name (vals sigs)))
   1.558 +     (alter-var-root (var ~name) merge 
   1.559 +                     (assoc ~opts 
   1.560 +                       :sigs '~sigs 
   1.561 +                       :var (var ~name)
   1.562 +                       :method-map 
   1.563 +                         ~(and (:on opts)
   1.564 +                               (apply hash-map 
   1.565 +                                      (mapcat 
   1.566 +                                       (fn [s] 
   1.567 +                                         [(keyword (:name s)) (keyword (or (:on s) (:name s)))])
   1.568 +                                       (vals sigs))))
   1.569 +                       :method-builders 
   1.570 +                        ~(apply hash-map 
   1.571 +                                (mapcat 
   1.572 +                                 (fn [s]
   1.573 +                                   [`(intern *ns* (with-meta '~(:name s) (merge '~s {:protocol (var ~name)})))
   1.574 +                                    (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))])
   1.575 +                                 (vals sigs)))))
   1.576 +     (-reset-methods ~name)
   1.577 +     '~name)))
   1.578 +
   1.579 +(defmacro defprotocol 
   1.580 +  "A protocol is a named set of named methods and their signatures:
   1.581 +  (defprotocol AProtocolName
   1.582 +
   1.583 +    ;optional doc string
   1.584 +    \"A doc string for AProtocol abstraction\"
   1.585 +
   1.586 +  ;method signatures
   1.587 +    (bar [this a b] \"bar docs\")
   1.588 +    (baz [this a] [this a b] [this a b c] \"baz docs\"))
   1.589 +
   1.590 +  No implementations are provided. Docs can be specified for the
   1.591 +  protocol overall and for each method. The above yields a set of
   1.592 +  polymorphic functions and a protocol object. All are
   1.593 +  namespace-qualified by the ns enclosing the definition The resulting
   1.594 +  functions dispatch on the type of their first argument, which is
   1.595 +  required and corresponds to the implicit target object ('this' in 
   1.596 +  Java parlance). defprotocol is dynamic, has no special compile-time 
   1.597 +  effect, and defines no new types or classes. Implementations of 
   1.598 +  the protocol methods can be provided using extend.
   1.599 +
   1.600 +  defprotocol will automatically generate a corresponding interface,
   1.601 +  with the same name as the protocol, i.e. given a protocol:
   1.602 +  my.ns/Protocol, an interface: my.ns.Protocol. The interface will
   1.603 +  have methods corresponding to the protocol functions, and the
   1.604 +  protocol will automatically work with instances of the interface.
   1.605 +
   1.606 +  Note that you should not use this interface with deftype or
   1.607 +  reify, as they support the protocol directly:
   1.608 +
   1.609 +  (defprotocol P 
   1.610 +    (foo [this]) 
   1.611 +    (bar-me [this] [this y]))
   1.612 +
   1.613 +  (deftype Foo [a b c] 
   1.614 +   P
   1.615 +    (foo [this] a)
   1.616 +    (bar-me [this] b)
   1.617 +    (bar-me [this y] (+ c y)))
   1.618 +  
   1.619 +  (bar-me (Foo. 1 2 3) 42)
   1.620 +  => 45
   1.621 +
   1.622 +  (foo 
   1.623 +    (let [x 42]
   1.624 +      (reify P 
   1.625 +        (foo [this] 17)
   1.626 +        (bar-me [this] x)
   1.627 +        (bar-me [this y] x))))
   1.628 +  => 17"
   1.629 +  {:added "1.2"} 
   1.630 +  [name & opts+sigs]
   1.631 +  (emit-protocol name opts+sigs))
   1.632 +
   1.633 +(defn extend 
   1.634 +  "Implementations of protocol methods can be provided using the extend construct:
   1.635 +
   1.636 +  (extend AType
   1.637 +    AProtocol
   1.638 +     {:foo an-existing-fn
   1.639 +      :bar (fn [a b] ...)
   1.640 +      :baz (fn ([a]...) ([a b] ...)...)}
   1.641 +    BProtocol 
   1.642 +      {...} 
   1.643 +    ...)
   1.644 + 
   1.645 +  extend takes a type/class (or interface, see below), and one or more
   1.646 +  protocol + method map pairs. It will extend the polymorphism of the
   1.647 +  protocol's methods to call the supplied methods when an AType is
   1.648 +  provided as the first argument. 
   1.649 +
   1.650 +  Method maps are maps of the keyword-ized method names to ordinary
   1.651 +  fns. This facilitates easy reuse of existing fns and fn maps, for
   1.652 +  code reuse/mixins without derivation or composition. You can extend
   1.653 +  an interface to a protocol. This is primarily to facilitate interop
   1.654 +  with the host (e.g. Java) but opens the door to incidental multiple
   1.655 +  inheritance of implementation since a class can inherit from more
   1.656 +  than one interface, both of which extend the protocol. It is TBD how
   1.657 +  to specify which impl to use. You can extend a protocol on nil.
   1.658 +
   1.659 +  If you are supplying the definitions explicitly (i.e. not reusing
   1.660 +  exsting functions or mixin maps), you may find it more convenient to
   1.661 +  use the extend-type or extend-protocol macros.
   1.662 +
   1.663 +  Note that multiple independent extend clauses can exist for the same
   1.664 +  type, not all protocols need be defined in a single extend call.
   1.665 +
   1.666 +  See also:
   1.667 +  extends?, satisfies?, extenders"
   1.668 +  {:added "1.2"} 
   1.669 +  [atype & proto+mmaps]
   1.670 +  (doseq [[proto mmap] (partition 2 proto+mmaps)]
   1.671 +    (when-not (protocol? proto)
   1.672 +      (throw (IllegalArgumentException.
   1.673 +              (str proto " is not a protocol"))))
   1.674 +    (when (implements? proto atype)
   1.675 +      (throw (IllegalArgumentException. 
   1.676 +              (str atype " already directly implements " (:on-interface proto) " for protocol:"  
   1.677 +                   (:var proto)))))
   1.678 +    (-reset-methods (alter-var-root (:var proto) assoc-in [:impls atype] mmap))))
   1.679 +
   1.680 +(defn- emit-impl [[p fs]]
   1.681 +  [p (zipmap (map #(-> % first keyword) fs)
   1.682 +             (map #(cons 'fn (drop 1 %)) fs))])
   1.683 +
   1.684 +(defn- emit-hinted-impl [c [p fs]]
   1.685 +  (let [hint (fn [specs]
   1.686 +               (let [specs (if (vector? (first specs)) 
   1.687 +                                        (list specs) 
   1.688 +                                        specs)]
   1.689 +                 (map (fn [[[target & args] & body]]
   1.690 +                        (cons (apply vector (vary-meta target assoc :tag c) args)
   1.691 +                              body))
   1.692 +                      specs)))]
   1.693 +    [p (zipmap (map #(-> % first keyword) fs)
   1.694 +               (map #(cons 'fn (hint (drop 1 %))) fs))]))
   1.695 +
   1.696 +(defn- emit-extend-type [c specs]
   1.697 +  (let [impls (parse-impls specs)]
   1.698 +    `(extend ~c
   1.699 +             ~@(mapcat (partial emit-hinted-impl c) impls))))
   1.700 +
   1.701 +(defmacro extend-type 
   1.702 +  "A macro that expands into an extend call. Useful when you are
   1.703 +  supplying the definitions explicitly inline, extend-type
   1.704 +  automatically creates the maps required by extend.  Propagates the
   1.705 +  class as a type hint on the first argument of all fns.
   1.706 +
   1.707 +  (extend-type MyType 
   1.708 +    Countable
   1.709 +      (cnt [c] ...)
   1.710 +    Foo
   1.711 +      (bar [x y] ...)
   1.712 +      (baz ([x] ...) ([x y & zs] ...)))
   1.713 +
   1.714 +  expands into:
   1.715 +
   1.716 +  (extend MyType
   1.717 +   Countable
   1.718 +     {:cnt (fn [c] ...)}
   1.719 +   Foo
   1.720 +     {:baz (fn ([x] ...) ([x y & zs] ...))
   1.721 +      :bar (fn [x y] ...)})"
   1.722 +  {:added "1.2"} 
   1.723 +  [t & specs]
   1.724 +  (emit-extend-type t specs))
   1.725 +
   1.726 +(defn- emit-extend-protocol [p specs]
   1.727 +  (let [impls (parse-impls specs)]
   1.728 +    `(do
   1.729 +       ~@(map (fn [[t fs]]
   1.730 +                `(extend-type ~t ~p ~@fs))
   1.731 +              impls))))
   1.732 +
   1.733 +(defmacro extend-protocol 
   1.734 +  "Useful when you want to provide several implementations of the same
   1.735 +  protocol all at once. Takes a single protocol and the implementation
   1.736 +  of that protocol for one or more types. Expands into calls to
   1.737 +  extend-type:
   1.738 +
   1.739 +  (extend-protocol Protocol
   1.740 +    AType
   1.741 +      (foo [x] ...)
   1.742 +      (bar [x y] ...)
   1.743 +    BType
   1.744 +      (foo [x] ...)
   1.745 +      (bar [x y] ...)
   1.746 +    AClass
   1.747 +      (foo [x] ...)
   1.748 +      (bar [x y] ...)
   1.749 +    nil
   1.750 +      (foo [x] ...)
   1.751 +      (bar [x y] ...))
   1.752 +
   1.753 +  expands into:
   1.754 +
   1.755 +  (do
   1.756 +   (clojure.core/extend-type AType Protocol 
   1.757 +     (foo [x] ...) 
   1.758 +     (bar [x y] ...))
   1.759 +   (clojure.core/extend-type BType Protocol 
   1.760 +     (foo [x] ...) 
   1.761 +     (bar [x y] ...))
   1.762 +   (clojure.core/extend-type AClass Protocol 
   1.763 +     (foo [x] ...) 
   1.764 +     (bar [x y] ...))
   1.765 +   (clojure.core/extend-type nil Protocol 
   1.766 +     (foo [x] ...) 
   1.767 +     (bar [x y] ...)))"
   1.768 +  {:added "1.2"}
   1.769 +
   1.770 +  [p & specs]
   1.771 +  (emit-extend-protocol p specs))
   1.772 +