deftype and reify support direct implementation of protocols

no more . in deftype/reify methods
no more implicit this, must be first param

3 files changed, 136 insertions, 63 deletions

diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj
index 7fa7d8f0..f7add067 100644
--- a/src/clj/clojure/core.clj
+++ b/src/clj/clojure/core.clj
@@ -4564,12 +4564,12 @@
   [#^Callable f]
   (let [fut (.submit clojure.lang.Agent/soloExecutor f)]
     (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?)))))
+      (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
@@ -4666,9 +4666,9 @@
   []
   (let [d (java.util.concurrent.CountDownLatch. 1)
         v (atom nil)]
-    (reify this [clojure.lang.IFn clojure.lang.IDeref]
-      (.deref [] (.await d) @v)
-      (.invoke [x]
+    (reify [clojure.lang.IFn clojure.lang.IDeref]
+      (deref [_] (.await d) @v)
+      (invoke [this x]
         (locking d
           (if (pos? (.getCount d))
             (do (reset! v x)
diff --git a/src/clj/clojure/core_deftype.clj b/src/clj/clojure/core_deftype.clj
index 2f962669..5afdf970 100644
--- a/src/clj/clojure/core_deftype.clj
+++ b/src/clj/clojure/core_deftype.clj
@@ -9,6 +9,48 @@
 (in-ns 'clojure.core)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; defclass/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defmacro reify 
+  "reify is a macro with the following structure:
+
+ (reify [protocols-and-interfaces+]
+   (methodName [this-name 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 a parameter must be supplied to
+  correspond to the target object ('this' in Java parlance). It can
+  have any name whatsoever.
+
+  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 [] 
+         (toString [_] f))))
+  == \"foo\"
+
+  (seq (let [f \"foo\"] 
+       (reify [clojure.lang.Seqable] 
+         (seq [_] (seq f)))))
+  == (\\f \\o \\o)"
+
+  [[& interfaces] & methods]
+  (let [interfaces (map #(if (var? (resolve %)) 
+                           (:on (deref (resolve %)))
+                           %)
+                        interfaces)]
+    `(reify* ~(vec interfaces) ~@methods)))
 
 (defn hash-combine [x y] 
   (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y)))
@@ -35,8 +77,8 @@
         (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] 
+                 `(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)
@@ -48,18 +90,18 @@
       (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))))]
+           (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 [k#] (.valAt ~'this k# nil))
-                 `(.valAt [k# else#] 
+           (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 [k#]
+                 `(getLookupThunk [~'this k#]
                     (case k#
                           ~@(mapcat 
                              (fn [fld]
@@ -72,33 +114,33 @@
       (idynamictype [[i m]]
         [(conj i 'clojure.lang.IDynamicType)
          (conj m
-               `(.getDynamicType [] ~tag)
-               `(.getExtensionMap [] ~'__extmap)
-               `(.getDynamicField [k# else#] 
+               `(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 [] (+ ~(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)]
+                  `(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 [] (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] 
+                  `(seq [~'this] (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] 
                                      ~'__extmap))
                   (let [gk (gensym) gv (gensym)]
-                    `(.assoc [~gk ~gv]
+                    `(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 [k#] (if (contains? #{~@(map keyword base-fields)} k#)
+                  `(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#))))))]
@@ -111,11 +153,13 @@
 (defmacro deftype
   "Alpha - subject to change
   
+  (deftype name [fields*] [protocols-and-interfaces*]? methods*)
+
   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). 
+  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
@@ -124,16 +168,16 @@
   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).
+  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, i.e. with just foo, instead
+  of (.foo this).
 
   Method definitions take the form:
 
-  (.methodname [args] body) ;note the dot on the methodname!
+  (methodname [this-name 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
@@ -148,21 +192,27 @@
   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.
+  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.
+  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)."
+  meta and extension fields).
+
+  When dynamically evaluated, the class will have a generated name."
 
   [name [& fields] & [[& interfaces] & methods]]
-  (let [gname (if *compile-files* name (gensym (str name "__")))
+  (let [gname name ;(if *compile-files* name (gensym (str name "__")))
+        interfaces (map #(if (var? (resolve %)) 
+                           (:on (deref (resolve %)))
+                           %)
+                        interfaces)
         classname (symbol (str *ns* "." gname))
         tag (keyword (str *ns*) (str name))
         hinted-fields fields
@@ -301,7 +351,7 @@
 (defn- emit-protocol [name opts+sigs]
   (let [iname (symbol (str (munge *ns*) "." (munge name)))
         [opts sigs]
-        (loop [opts {:on iname} sigs opts+sigs]
+        (loop [opts {:on (list 'quote 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))
@@ -370,7 +420,34 @@
   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."
+  extend.
+
+  defprotocol will automatically generate a corresponding interface,
+  with the same name as the protocol, i.e. given a protocol
+  my.ns/Protocol, and interface my.ns.MyProtocol. The interface will
+  have methods corresponding to the protocol functions, and the
+  protocol will automatically work with instances of the interface.
+
+  Note that you do not need to 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 [x] a)
+    (bar-me [x] b)
+    (bar-me [x y] (+ c y)))
+  
+  (bar-me (Foo 1 2 3) 42)
+
+  (foo 
+    (let [x 42]
+      (reify [P] 
+        (foo [this] 17)
+        (bar-me [this] x)
+        (bar-me [this y] x))))"
 
   [name & opts+sigs]
   (emit-protocol name opts+sigs))
diff --git a/src/jvm/clojure/lang/Compiler.java b/src/jvm/clojure/lang/Compiler.java
index 1896225b..daef7610 100644
--- a/src/jvm/clojure/lang/Compiler.java
+++ b/src/jvm/clojure/lang/Compiler.java
@@ -62,7 +62,7 @@ static final Symbol CASE = Symbol.create("case*");
 static final Symbol CLASS = Symbol.create("Class");
 static final Symbol NEW = Symbol.create("new");
 static final Symbol THIS = Symbol.create("this");
-static final Symbol REIFY = Symbol.create("reify");
+static final Symbol REIFY = Symbol.create("reify*");
 //static final Symbol UNQUOTE = Symbol.create("unquote");
 //static final Symbol UNQUOTE_SPLICING = Symbol.create("unquote-splicing");
 //static final Symbol SYNTAX_QUOTE = Symbol.create("clojure.core", "syntax-quote");
@@ -5717,7 +5717,7 @@ static public class NewInstanceExpr extends ObjExpr{
 				rform = rform.next().next();
 				}
 
-			return build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),fields,THIS,tagname, classname,
+			return build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),fields,null,tagname, classname,
 			             (Symbol) RT.get(opts,RT.TAG_KEY),rform);
 		}
 	}
@@ -5735,21 +5735,13 @@ static public class NewInstanceExpr extends ObjExpr{
 
 		ISeq rform = RT.next(form);
 
-		//reify might be followed by symbol naming this
-		Symbol thisSym = null;
-		if(RT.first(rform) instanceof Symbol)
-			{
-			thisSym = (Symbol) RT.first(rform);
-			rform = RT.next(rform);
-			}
-
 		IPersistentVector interfaces = (IPersistentVector) RT.first(rform);
 
 
 		rform = RT.next(rform);
 
 
-		return build(interfaces, null, thisSym, classname, classname, null, rform);
+		return build(interfaces, null, null, classname, classname, null, rform);
 	}
 	}
 
@@ -6152,13 +6144,17 @@ public static class NewInstanceMethod extends ObjMethod{
 
 	static NewInstanceMethod parse(ObjExpr objx, ISeq form, Symbol thistag,
 	                               Map overrideables) throws Exception{
-		//(.methodname [args] body...)
+		//(methodname [this-name args*] body...)
 		NewInstanceMethod method = new NewInstanceMethod(objx, (ObjMethod) METHOD.deref());
 		Symbol dotname = (Symbol)RT.first(form);
-		if(!dotname.name.startsWith("."))
-			throw new IllegalArgumentException("Method names must begin with '.': " + dotname);
-		Symbol name = (Symbol) Symbol.intern(null,munge(dotname.name.substring(1))).withMeta(RT.meta(dotname));
+		Symbol name = (Symbol) Symbol.intern(null,munge(dotname.name)).withMeta(RT.meta(dotname));
 		IPersistentVector parms = (IPersistentVector) RT.second(form);
+		if(parms.count() == 0)
+			{
+			throw new IllegalArgumentException("Must supply at least one argument for 'this' in: " + dotname);
+			}
+		Symbol thisName = (Symbol) parms.nth(0);
+		parms = RT.subvec(parms,1,parms.count());
 		ISeq body = RT.next(RT.next(form));
 		try
 			{
@@ -6172,7 +6168,7 @@ public static class NewInstanceMethod extends ObjMethod{
 							NEXT_LOCAL_NUM, 0));
 
 			//register 'this' as local 0
-			registerLocal(Symbol.intern(objx.thisName != null ? objx.thisName : "obj__" + RT.nextID()),
+			registerLocal(thisName,
 			              thistag, null,false);
 
 			PersistentVector argLocals = PersistentVector.EMPTY;