got rid of defclass. deftype now can refer to self-type, will emit same-named class when AOT compiling, thus replacing defclass.

2 files changed, 56 insertions, 87 deletions

diff --git a/src/clj/clojure/core_deftype.clj b/src/clj/clojure/core_deftype.clj
index 7cf2e318..09d59cb7 100644
--- a/src/clj/clojure/core_deftype.clj
+++ b/src/clj/clojure/core_deftype.clj
@@ -13,10 +13,10 @@
 (defn hash-combine [x y] 
   (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y)))
 
-(defn create-defclass* 
-  "Do not use this directly - use defclass/deftype"
-  [name fields interfaces methods]
-  (let [tag (keyword (str *ns*) (str name))
+(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))
@@ -36,15 +36,17 @@
                  `(.equals [~'o] 
                     (boolean 
                      (or (identical? ~'this ~'o)
-                         (when (instance? ~name ~'o)
-                           (let [~'o ~(with-meta 'o {:tag name})]
-                             (and ~@(map (fn [fld] `(= ~fld (. ~'o ~fld))) (remove #{'__meta} fields)))))))))]
+                         (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 ~name ~@(replace {'__meta 'm} fields))))]
+                 `(.withMeta [~'m] (new ~tagname ~@(replace {'__meta 'm} fields))))]
           [i m]))
       (ilookup [[i m]] 
         (if (implement? clojure.lang.ILookup)
@@ -55,6 +57,14 @@
                                                    base-fields)
                            (get ~'__extmap k# else#))))]
           [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#))))])
       (ikeywordlookup [[i m]]
         [(conj i 'clojure.lang.IKeywordLookup)
          (conj m
@@ -85,55 +95,19 @@
                     `(.assoc [~gk ~gv]
                        (condp identical? ~gk
                          ~@(mapcat (fn [fld]
-                                     [(keyword fld) (list* `new name (replace {fld gv} fields))])
+                                     [(keyword fld) (list* `new tagname (replace {fld gv} fields))])
                                    base-fields)
-                         (new ~name ~@(remove #{'__extmap} fields) (assoc ~'__extmap ~gk ~gv)))))
+                         (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 ~name ~@(remove #{'__extmap} fields) 
+                                     (new ~tagname ~@(remove #{'__extmap} fields) 
                                           (not-empty (dissoc ~'__extmap k#))))))]
            [i m]))]
-     (let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap ikeywordlookup)]
-       `(defclass* ~classname ~(conj hinted-fields '__meta '__extmap) 
+     (let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap ikeywordlookup idynamictype)]
+       `(deftype* ~tagname ~classname ~(conj hinted-fields '__meta '__extmap) 
           :implements ~(vec i) 
           ~@m)))))
 
-(defmacro defclass 
-  "Alpha - subject to change
-  
-  When 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 not
-  compiling, does nothing. 
-
-  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). In the method bodies, the (unqualified)
-  name can be used to name the class (for calls to new etc).
-
-  See deftype for a description of fields, methods, equality and
-  generated interfaces."
- 
-  [name [& fields] & [[& interfaces] & methods]]
-  (let [o (gensym)
-        classname (symbol (str *ns* "." name))]
-    `(do
-       ~(create-defclass* name (vec fields) (vec interfaces) methods)
-       (defmethod print-method ~classname [~(with-meta o {:tag classname}) w#]
-         ((var print-defclass)
-            (.__extmap ~o)
-            ~(apply array-map (interleave
-                                (map #(-> % str keyword) fields)
-                                (map #(list '. o %) fields)))
-            ~o w#)))))
-
-(defn- print-defclass [extmap fieldmap o, #^Writer w]
-  (print-meta o w)
-  (.write w "#:")
-  (.write w (.getSimpleName (class o)))
-  (print-map (concat fieldmap extmap) pr-on w))
-
 (defmacro deftype
   "Alpha - subject to change
   
@@ -165,6 +139,9 @@
   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
@@ -174,35 +151,24 @@
   In addition, unless you supply a version of .hashCode or .equals,
   deftype/class will define type-and-value-based equality and hashCode.
 
-  Note that overriding equals and hashCode is not supported at this
-  time for deftype - you must use the generated versions."
+  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 (gensym (str name "__"))
+  (let [gname (if *compile-files* name (gensym (str name "__")))
         classname (symbol (str *ns* "." gname))
         tag (keyword (str *ns*) (str name))
-        interfaces (conj interfaces 'clojure.lang.IDynamicType)
         hinted-fields fields
-        fields (vec (map #(with-meta % nil) fields))
-        methods (conj methods 
-                      `(.getDynamicType [] ~tag)
-                      `(.getExtensionMap [] ~'__extmap)
-                      `(.getDynamicField [k# else#] 
-                         (condp identical? k# ~@(mapcat (fn [fld] [(keyword fld) fld]) fields)
-                                (get ~'__extmap k# else#)))
-                      `(.hashCode [] (-> ~(hash tag) 
-                                          ~@(map #(list `hash-combine %) fields)
-                                          (hash-combine ~'__extmap)))
-                      `(.equals [~'o] 
-                         (boolean 
-                          (or (identical? ~'this ~'o)
-                              (when (instance? clojure.lang.IDynamicType ~'o)
-                                (let [~'o ~(with-meta 'o {:tag 'clojure.lang.IDynamicType})]
-                                  (and (= (.getDynamicType ~'this) (.getDynamicType ~'o)) 
-                                       ~@(map (fn [fld] `(= ~fld (.getDynamicField ~'o ~(keyword fld) ~'this))) fields)
-                                       (= ~'__extmap (.getExtensionMap ~'o)))))))))]
+        fields (vec (map #(with-meta % nil) fields))]
     `(do
-       ~(create-defclass* gname (vec hinted-fields) (vec interfaces) methods)
+       ~(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
@@ -219,6 +185,7 @@
       (.getExtensionMap o))
     pr-on w))
 
+
 ;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn- expand-method-impl-cache [#^clojure.lang.MethodImplCache cache c f]
diff --git a/src/jvm/clojure/lang/Compiler.java b/src/jvm/clojure/lang/Compiler.java
index 5bdfb95c..f57eacfe 100644
--- a/src/jvm/clojure/lang/Compiler.java
+++ b/src/jvm/clojure/lang/Compiler.java
@@ -55,7 +55,7 @@ static final Symbol MONITOR_ENTER = Symbol.create("monitor-enter");
 static final Symbol MONITOR_EXIT = Symbol.create("monitor-exit");
 static final Symbol IMPORT = Symbol.create("clojure.core", "import*");
 //static final Symbol INSTANCE = Symbol.create("instance?");
-static final Symbol DEFCLASS = Symbol.create("defclass*");
+static final Symbol DEFTYPE = Symbol.create("deftype*");
 static final Symbol CASE = Symbol.create("case*");
 
 //static final Symbol THISFN = Symbol.create("thisfn");
@@ -104,7 +104,7 @@ static final public IPersistentMap specials = PersistentHashMap.create(
 		IMPORT, new ImportExpr.Parser(),
 		DOT, new HostExpr.Parser(),
 		ASSIGN, new AssignExpr.Parser(),
-		DEFCLASS, new NewInstanceExpr.DefclassParser(),
+		DEFTYPE, new NewInstanceExpr.DeftypeParser(),
 		REIFY, new NewInstanceExpr.ReifyParser(),
 //		TRY_FINALLY, new TryFinallyExpr.Parser(),
 TRY, new TryExpr.Parser(),
@@ -228,7 +228,6 @@ static final public Var COMPILE_STUB_SYM = Var.create(null);
 static final public Var COMPILE_STUB_CLASS = Var.create(null);
 
 
-
 public enum C{
 	STATEMENT,  //value ignored
 	EXPRESSION, //value required
@@ -3141,7 +3140,7 @@ static public class ObjExpr implements Expr{
 		for(ISeq s = RT.keys(closes); s != null; s = s.next())
 			{
 			LocalBinding lb = (LocalBinding) s.first();
-			if(isDefclass())
+			if(isDeftype())
 				{
 				int access = isVolatile(lb) ? ACC_VOLATILE : (ACC_PUBLIC + ACC_FINAL);
 				if(lb.getPrimitiveType() != null)
@@ -3499,7 +3498,7 @@ static public class ObjExpr implements Expr{
 		return closes.containsKey(lb) && volatiles.contains(lb.sym);
 	}
 
-	boolean isDefclass(){
+	boolean isDeftype(){
 		return fields != null;
 	}
 
@@ -3538,7 +3537,7 @@ static public class ObjExpr implements Expr{
 	}
 
 	public Object eval() throws Exception{
-		if(isDefclass())
+		if(isDeftype())
 			return null;
 		return getCompiledClass().newInstance();
 	}
@@ -3574,7 +3573,7 @@ static public class ObjExpr implements Expr{
 		//emitting a Fn means constructing an instance, feeding closed-overs from enclosing scope, if any
 		//objx arg is enclosing objx, not this
 //		getCompiledClass();
-		if(isDefclass())
+		if(isDeftype())
 			{
 			gen.visitInsn(Opcodes.ACONST_NULL);
 			}
@@ -5375,11 +5374,13 @@ static public class NewInstanceExpr extends ObjExpr{
 		super(tag);
 	}
 
-	static class DefclassParser implements IParser{
+	static class DeftypeParser implements IParser{
 		public Expr parse(C context, Object frm) throws Exception{
 			ISeq rform = (ISeq) frm;
-			//(defclass* classname [fields] :implements [interfaces] :tag tagname methods*)
+			//(deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*)
 			rform = RT.next(rform);
+			String tagname = ((Symbol) rform.first()).toString();
+			rform = rform.next();
 			String classname = ((Symbol) rform.first()).toString();
 			rform = rform.next();
 			IPersistentVector fields = (IPersistentVector) rform.first();
@@ -5391,7 +5392,7 @@ static public class NewInstanceExpr extends ObjExpr{
 				rform = rform.next().next();
 				}
 
-			return build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),fields,THIS,classname,
+			return build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),fields,THIS,tagname, classname,
 			             (Symbol) RT.get(opts,RT.TAG_KEY),rform);
 		}
 	}
@@ -5423,11 +5424,12 @@ static public class NewInstanceExpr extends ObjExpr{
 		rform = RT.next(rform);
 
 
-		return build(interfaces, null, thisSym, classname, null, rform);
+		return build(interfaces, null, thisSym, classname, classname, null, rform);
 	}
 	}
 
-	static ObjExpr build(IPersistentVector interfaceSyms, IPersistentVector fieldSyms, Symbol thisSym, String className,
+	static ObjExpr build(IPersistentVector interfaceSyms, IPersistentVector fieldSyms, Symbol thisSym,
+	                     String tagName, String className,
 	                  Symbol typeTag, ISeq methodForms) throws Exception{
 		NewInstanceExpr ret = new NewInstanceExpr(null);
 
@@ -5495,11 +5497,11 @@ static public class NewInstanceExpr extends ObjExpr{
 					       VARS, PersistentHashMap.EMPTY,
 					       KEYWORD_CALLSITES, PersistentVector.EMPTY
 							));
-			if(ret.isDefclass())
+			if(ret.isDeftype())
 				{
 				Var.pushThreadBindings(RT.map(METHOD, null,
 				                              LOCAL_ENV, ret.fields
-						, COMPILE_STUB_SYM, Symbol.intern(null, stub.getSimpleName())
+						, COMPILE_STUB_SYM, Symbol.intern(null, tagName)
 						, COMPILE_STUB_CLASS, stub));
 				}
 
@@ -5522,7 +5524,7 @@ static public class NewInstanceExpr extends ObjExpr{
 			}
 		finally
 			{
-			if(ret.isDefclass())
+			if(ret.isDeftype())
 				Var.popThreadBindings();
 			Var.popThreadBindings();
 			}