19 files changed, 3129 insertions, 907 deletions

diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj
index 89929e02..aa22ba9c 100644
--- a/src/clj/clojure/core.clj
+++ b/src/clj/clojure/core.clj
@@ -241,7 +241,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))
 
@@ -447,8 +448,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
@@ -509,8 +508,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
@@ -1965,6 +1962,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."
@@ -2213,7 +2214,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"
@@ -2341,6 +2346,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*))
@@ -2938,7 +2944,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))
@@ -2950,11 +2956,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)
@@ -3688,10 +3694,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"
@@ -3873,7 +3880,7 @@
   [fmt & args]
   (print (apply format fmt args)))
 
-(def gen-class)
+(declare gen-class)
 
 (defmacro with-loading-context [& body]
   `((fn loading# [] 
@@ -4005,7 +4012,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
@@ -4280,10 +4287,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
@@ -4464,10 +4467,90 @@
   "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 "core_deftype")
 (load "genclass")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; futures (needs proxy);;;;;;;;;;;;;;;;;;
@@ -4478,13 +4561,13 @@
   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] []
-      (deref [] (.get fut))
-      (get ([] (.get fut))
-           ([timeout unit] (.get fut timeout unit)))
-      (isCancelled [] (.isCancelled fut))
-      (isDone [] (.isDone fut))
-      (cancel [interrupt?] (.cancel fut interrupt?)))))
+    (reify [clojure.lang.IDeref java.util.concurrent.Future]
+      (.deref [] (.get fut))
+      (.get [] (.get fut))
+      (.get [timeout unit] (.get fut timeout unit))
+      (.isCancelled [] (.isCancelled fut))
+      (.isDone [] (.isDone fut))
+      (.cancel [interrupt?] (.cancel fut interrupt?)))))
   
 (defmacro future
   "Takes a body of expressions and yields a future object that will
@@ -4536,16 +4619,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 ;;;;;;;;;;;;;;;;;;;;;;
 
@@ -4591,9 +4664,9 @@
   []
   (let [d (java.util.concurrent.CountDownLatch. 1)
         v (atom nil)]
-    (proxy [clojure.lang.AFn clojure.lang.IDeref] []
-      (deref [] (.await d) @v)
-      (invoke [x]
+    (reify this [clojure.lang.IFn clojure.lang.IDeref]
+      (.deref [] (.await d) @v)
+      (.invoke [x]
         (locking d
           (if (pos? (.getCount d))
             (do (reset! v x)
@@ -4679,3 +4752,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..e68f5874
--- /dev/null
+++ b/src/clj/clojure/core_deftype.clj
@@ -0,0 +1,515 @@
+;   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)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;; defclass/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn hash-combine [x y] 
+  (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y)))
+
+(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 [] (-> ~tag hash ~@(map #(list `hash-combine %) (remove #{'__meta} fields))))
+                 `(.equals [~'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 [] ~'__meta)
+                 `(.withMeta [~'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 [k#] (.valAt ~'this k# nil))
+                 `(.valAt [k# else#] 
+                    (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) 
+                                                   base-fields)
+                           (get ~'__extmap k# else#)))
+                 `(.getLookupThunk [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 [] ~tag)
+               `(.getExtensionMap [] ~'__extmap)
+               `(.getDynamicField [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 [] (+ ~(count base-fields) (count ~'__extmap)))
+                  `(.empty [] (throw (UnsupportedOperationException. (str "Can't create empty: " ~(str classname)))))
+                  `(.cons [e#] (let [[k# v#] e#] (.assoc ~'this k# v#)))
+                  `(.equiv [o#] (.equals ~'this o#))
+                  `(.containsKey [k#] (not (identical? ~'this (.valAt ~'this k# ~'this))))
+                  `(.entryAt [k#] (let [v# (.valAt ~'this k# ~'this)]
+                                     (when-not (identical? ~'this v#)
+                                       (clojure.lang.MapEntry. k# v#))))
+                  `(.seq [] (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] 
+                                     ~'__extmap))
+                  (let [gk (gensym) gv (gensym)]
+                    `(.assoc [~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 [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
+  
+  Dynamically generates compiled bytecode for an anonymous class with
+  the given fields, and, optionally, interfaces and methods. 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. Interfaces and methods are optional. The only
+  methods that can be supplied are those declared in the interfaces.
+  'this' is impliclty bound to the target object (i.e. same meaning as
+  in Java). Note that method bodies are not closures, the local
+  environment includes only the named fields, and those fields can be
+  accessed directy, i.e. with just foo, instead of (.foo this).
+
+  Method definitions take the form:
+
+  (.methodname [args] body) ;note the dot on the methodname!
+
+  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.
+
+  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. When
+  dynamically evaluated, the class will have a generated name.
+
+  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)."
+
+  [name [& fields] & [[& interfaces] & methods]]
+  (let [gname (if *compile-files* name (gensym (str name "__")))
+        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- 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 protocol) (instance? (:on protocol) x))
+    x
+  (let [t (type 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 protocol) (instance? (:on 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 [[opts sigs]
+        (loop [opts {:on nil} 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 (if (vector? (second s)) (list (second s)) (second s))
+                             fx (nth s 2 nil)
+                             doc (when (string? fx) fx)
+                             mopts (apply hash-map (nthnext s (if (string? fx) 3 2)))]
+                         (when (some #{0} (map count arglists))
+                           (throw (IllegalArgumentException. (str "Protocol fn: " mname " must take at least one arg"))))
+                         (assoc m (keyword mname) 
+                                (merge mopts 
+                                       {:name (vary-meta mname assoc :doc doc :arglists arglists)
+                                        :arglists arglists
+                                        :doc doc}))))
+                     {} sigs)]
+  `(do
+     (defonce ~name {})
+     (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 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."
+
+  [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
+  protocol's methods to call the supplied methods when an AType is
+  provided as the first argument. Note that deftype types are specified
+  using their keyword tags:
+
+  ::MyType or :my.ns/MyType
+
+  Method maps are maps of the keyword-ized method names to ordinary
+  fns. This facilitates easy reuse of existing fns and fn maps, for
+  code reuse/mixins without derivation or composition. You can extend
+  an interface to a protocol. This is primarily to facilitate interop
+  with the host (e.g. Java) but opens the door to incidental multiple
+  inheritance of implementation since a class can inherit from more
+  than one interface, both of which extend the protocol. It is TBD how
+  to specify which impl to use. You can extend a protocol on nil.
+
+  If you are supplying the definitions explicitly (i.e. not reusing
+  exsting functions or mixin maps), you may find it more convenient to
+  use the extend-type, extend-class or extend-protocol macros.
+
+  Note that multiple independent extend clauses can exist for the same
+  type, not all protocols need be defined in a single extend call.
+
+  See also:
+  extends?, satisfies?, extenders"
+
+  [atype & proto+mmaps]
+  (doseq [[proto mmap] (partition 2 proto+mmaps)]
+    (-reset-methods (alter-var-root (:var proto) assoc-in [:impls atype] mmap))))
+
+(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- emit-impl [[p fs]]
+  [p (zipmap (map #(-> % first keyword) fs)
+             (map #(cons 'fn (drop 1 %)) fs))])
+
+(defn- emit-hinted-impl [c [p fs]]
+  (let [hint (fn [specs]
+               (let [specs (if (vector? (first specs)) 
+                                        (list specs) 
+                                        specs)]
+                 (map (fn [[[target & args] & body]]
+                        (cons (apply vector (vary-meta target assoc :tag c) args)
+                              body))
+                      specs)))]
+    [p (zipmap (map #(-> % first keyword) fs)
+               (map #(cons 'fn (hint (drop 1 %))) fs))]))
+
+(defn- emit-extend-type [t specs]
+  (let [impls (parse-impls specs)]
+    `(extend ~t
+             ~@(mapcat emit-impl impls))))
+
+(defn- emit-extend-class [c specs]
+  (let [impls (parse-impls specs)]
+    `(extend ~c
+             ~@(mapcat (partial emit-hinted-impl c) impls))))
+
+(defmacro extend-type 
+  "A macro that expands into an extend call. Useful when you are
+  supplying the definitions explicitly inline, extend-type
+  automatically creates the maps required by extend.
+
+  (extend-type ::MyType 
+    Countable
+      (cnt [c] ...)
+    Foo
+      (bar [x y] ...)
+      (baz ([x] ...) ([x y & zs] ...)))
+
+  expands into:
+
+  (extend ::MyType
+   Countable
+     {:cnt (fn [c] ...)}
+   Foo
+     {:baz (fn ([x] ...) ([x y & zs] ...))
+      :bar (fn [x y] ...)})"
+
+  [t & specs]
+  (emit-extend-type t specs))
+
+(defmacro extend-class 
+  "Like extend-type, for the case when the extended type is a
+  class. Propagates the class as a type hint on the first argument of
+  all fns" 
+  [c & specs]
+  (emit-extend-class c specs))
+
+(defn- emit-extend-protocol [p specs]
+  (let [impls (parse-impls specs)]
+    `(do
+       ~@(map (fn [[t fs]]
+                (if (symbol? t)
+                  `(extend-class ~t ~p ~@fs)
+                  `(extend-type ~t ~p ~@fs)))
+              impls))))
+
+(defmacro extend-protocol 
+  "Useful when you want to provide several implementations of the same
+  protocol all at once. Takes a single protocol and the implementation
+  of that protocol for one or more types. Expands into calls to
+  extend-type and extend-class:
+
+  (extend-protocol Protocol
+    ::AType
+      (foo [x] ...)
+      (bar [x y] ...)
+    ::BType
+      (foo [x] ...)
+      (bar [x y] ...)
+    AClass
+      (foo [x] ...)
+      (bar [x y] ...)
+    nil
+      (foo [x] ...)
+      (bar [x y] ...))
+
+  expands into:
+
+  (do
+   (clojure.core/extend-type ::AType Protocol 
+     (foo [x] ...) 
+     (bar [x y] ...))
+   (clojure.core/extend-type ::BType Protocol 
+     (foo [x] ...) 
+     (bar [x y] ...))
+   (clojure.core/extend-class AClass Protocol 
+     (foo [x] ...) 
+     (bar [x y] ...))
+   (clojure.core/extend-type nil Protocol 
+     (foo [x] ...) 
+     (bar [x y] ...)))"
+
+  [p & specs]
+  (emit-extend-protocol p specs))
+
diff --git a/src/clj/clojure/test.clj b/src/clj/clojure/test.clj
index 37cdd7e8..bdebc44a 100644
--- a/src/clj/clojure/test.clj
+++ b/src/clj/clojure/test.clj
@@ -544,7 +544,8 @@ Chas Emerick, Allen Rohner, and Stuart Halloway",
    'is' call 'report' to indicate results.  The argument given to
    'report' will be a map with a :type key.  See the documentation at
    the top of test_is.clj for more information on the types of
-   arguments for 'report'."}
+   arguments for 'report'."
+     :dynamic true}