Changes to shore up the shortcomings and fix bugs found in defrecord …

…read/print form from 1.3.0-alpha7. See CLJ-800

Signed-off-by: Stuart Halloway <stu@thinkrelevance.com>

src/clj/clojure/core_deftype.clj

@@ -229,6 +229,31 @@
           :implements ~(vec i) 
           ~@m))))))
 
+(defn- build-positional-factory
+  "Used to build a positional factory for a given type/record.  Because of the
+  limitation of 20 arguments to Clojure functions, this factory needs to be
+  constructed to deal with more arguments.  It does this by building a straight
+  forward type/record ctor call in the <=20 case, and a call to the same
+  ctor pulling the extra args out of the & overage parameter.  Finally, the
+  arity is constrained to the number of expected fields and an ArityException
+  will be thrown at runtime if the actual arg count does not match."
+  [nom classname fields]
+  (let [fn-name (symbol (str '-> nom))
+        [field-args over] (split-at 20 fields)
+        field-count (count fields)
+        arg-count (count field-args)
+        over-count (count over)]
+    `(defn ~fn-name
+       [~@field-args ~@(if (seq over) '[& overage] [])]
+       ~(if (seq over)
+          `(if (= (count ~'overage) ~over-count)
+             (new ~classname
+                  ~@field-args
+                  ~@(for [i (range 0 (count over))]
+                      (list `nth 'overage i)))
+             (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name))))
+          `(new ~classname ~@field-args)))))
+
 (defmacro defrecord
   "Alpha - subject to change
   
@@ -301,17 +326,16 @@
     `(let []
        ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods)
        (import ~classname)
-       (defn ~(symbol (str '-> name))
-         ([~@fields] (new ~classname ~@fields nil nil))
-         ([~@fields meta# extmap#] (new ~classname ~@fields meta# extmap#)))
-       (defn ~(symbol (str 'map-> name))
+       ~(build-positional-factory gname classname fields)
+       (defn ~(symbol (str 'map-> gname))
          ([m#] (~(symbol (str classname "/create")) m#)))
        ~classname)))
 
 (defn- emit-deftype* 
   "Do not use this directly - use deftype"
   [tagname name fields interfaces methods]
-  (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))]
+  (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))
+        interfaces (conj interfaces 'clojure.lang.IType)]
     `(deftype* ~tagname ~classname ~fields 
        :implements ~interfaces 
        ~@methods)))
@@ -382,32 +406,14 @@
         ns-part (namespace-munge *ns*)
         classname (symbol (str ns-part "." gname))
         hinted-fields fields
-        fields (vec (map #(with-meta % nil) fields))]
+        fields (vec (map #(with-meta % nil) fields))
+        [field-args over] (split-at 20 fields)]
     `(let []
        ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods)
        (import ~classname)
-       (defmethod print-method ~classname [o# w#]
-         ((var print-deftype) o# w#))
-       (defmethod print-dup ~classname [o# w#]
-         ((var printdup-deftype) o# w#))
-       (defn ~(symbol (str '-> name))
-         ([~@fields] (new ~classname ~@fields)))
+       ~(build-positional-factory gname classname fields)
        ~classname)))
 
-(defn- print-deftype [o ^Writer w]
-  (.write w "#")
-  (.write w (.getName (class o)))
-  (let [basii (for [fld (map str (clojure.lang.Reflector/invokeStaticMethod (class o) "getBasis" (to-array [])))]
-                (clojure.lang.Reflector/getInstanceField o fld))]
-    (print-sequential "[" pr-on ", " "]" basii w)))
-
-(defn- printdup-deftype [o ^Writer w]
-  (.write w "#")
-  (.write w (.getName (class o)))
-  (let [basii (for [fld (map str (clojure.lang.Reflector/invokeStaticMethod (class o) "getBasis" (to-array [])))]
-                (clojure.lang.Reflector/getInstanceField o fld))]
-    (print-sequential "[" pr-on ", " "]" basii w)))
-
 ;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defn- expand-method-impl-cache [^clojure.lang.MethodImplCache cache c f]

src/clj/clojure/core_print.clj

@@ -214,6 +214,8 @@
   (print-map m print-dup w)
   (.write w ")"))
 
+;; Records
+
 (defmethod print-method clojure.lang.IRecord [r, ^Writer w]
   (print-meta r w)
   (.write w "#")
@@ -235,6 +237,22 @@
 (prefer-method print-dup clojure.lang.IRecord clojure.lang.IPersistentCollection)
 (prefer-method print-dup clojure.lang.IRecord java.util.Map)
 
+;; Types
+
+(defn- print-deftype [o ^Writer w]
+  (.write w "#")
+  (.write w (.getName (class o)))
+  (let [basii (for [fld (map str (clojure.lang.Reflector/invokeStaticMethod (class o) "getBasis" (to-array [])))]
+                (clojure.lang.Reflector/getInstanceField o fld))]
+    (print-sequential "[" pr-on ", " "]" basii w)))
+
+(defmethod print-method clojure.lang.IType [o ^Writer w]
+  (print-deftype o w))
+
+(defmethod print-dup clojure.lang.IType [o ^Writer w]
+  (print-deftype o w))
+
+
 (defmethod print-method clojure.lang.IPersistentSet [s, ^Writer w]
   (print-meta s w)
   (print-sequential "#{" pr-on " " "}" (seq s) w))

src/jvm/clojure/lang/Compiler.java

@@ -4295,17 +4295,34 @@ else if(value instanceof Var)
 			gen.push(var.sym.toString());
 			gen.invokeStatic(RT_TYPE, Method.getMethod("clojure.lang.Var var(String,String)"));
 			}
-		else if(value instanceof IRecord)
+		else if(value instanceof IType)
 			{
-			Method createMethod = Method.getMethod(value.getClass().getName() + " create(clojure.lang.IPersistentMap)");
-			List entries = new ArrayList();
-			for(Map.Entry entry : (Set<Map.Entry>) ((Map) value).entrySet())
+			Method ctor = new Method("<init>", Type.getConstructorDescriptor(value.getClass().getConstructors()[0]));
+			gen.newInstance(Type.getType(value.getClass()));
+			gen.dup();
+			IPersistentVector fields = (IPersistentVector) Reflector.invokeStaticMethod(value.getClass(), "getBasis", new Object[]{});
+			for(ISeq s = RT.seq(fields); s != null; s = s.next())
 				{
-				entries.add(entry.getKey());
-				entries.add(entry.getValue());
+				Symbol field = (Symbol) s.first();
+				Class k = tagClass(tagOf(field));
+				Object val = Reflector.getInstanceField(value, field.name);
+				emitValue(val, gen);
+
+				if(k.isPrimitive())
+					{
+					Type b = Type.getType(boxClass(k));
+					String p = Type.getType(k).getDescriptor();
+					String n = k.getName();
+
+					gen.invokeVirtual(b, new Method(n+"Value", "()"+p));
+					}
 				}
-			emitListAsObjectArray(entries, gen);
-			gen.invokeStatic(RT_TYPE, Method.getMethod("clojure.lang.IPersistentMap map(Object[])"));
+			gen.invokeConstructor(Type.getType(value.getClass()), ctor);
+			}
+		else if(value instanceof IRecord)
+			{
+			Method createMethod = Method.getMethod(value.getClass().getName() + " create(clojure.lang.IPersistentMap)");
+            emitValue(PersistentArrayMap.create((java.util.Map) value), gen);
 			gen.invokeStatic(getType(value.getClass()), createMethod);
 			}
 		else if(value instanceof IPersistentMap)
@@ -6142,6 +6159,8 @@ else if(form instanceof IPersistentVector)
 				return VectorExpr.parse(context, (IPersistentVector) form);
 		else if(form instanceof IRecord)
 				return new ConstantExpr(form);
+		else if(form instanceof IType)
+				return new ConstantExpr(form);
 		else if(form instanceof IPersistentMap)
 				return MapExpr.parse(context, (IPersistentMap) form);
 		else if(form instanceof IPersistentSet)
@@ -6376,12 +6395,13 @@ public static Object eval(Object form, boolean freshLoader) {
 					eval(RT.first(s), false);
 				return eval(RT.first(s), false);
 				}
-			else if(form instanceof IPersistentCollection
-			        && !(RT.first(form) instanceof Symbol
-			             && ((Symbol) RT.first(form)).name.startsWith("def")))
+			else if((form instanceof IType) ||
+					(form instanceof IPersistentCollection
+					&& !(RT.first(form) instanceof Symbol
+						&& ((Symbol) RT.first(form)).name.startsWith("def"))))
 				{
 				ObjExpr fexpr = (ObjExpr) analyze(C.EXPRESSION, RT.list(FN, PersistentVector.EMPTY, form),
-				                                  "eval" + RT.nextID());
+													"eval" + RT.nextID());
 				IFn fn = (IFn) fexpr.eval();
 				return fn.invoke();
 				}
@@ -7809,23 +7829,22 @@ static Class boxClass(Class p) {
 			return p;
 
 		Class c = null;
-		Type  t = Type.getType(p);
 
-		if(t == Type.INT_TYPE)
+		if(p == Integer.TYPE)
 			c = Integer.class;
-		else if(t == Type.LONG_TYPE)
+		else if(p == Long.TYPE)
 			c = Long.class;
-		else if(t == Type.FLOAT_TYPE)
+		else if(p == Float.TYPE)
 			c = Float.class;
-		else if(t == Type.DOUBLE_TYPE)
+		else if(p == Double.TYPE)
 			c = Double.class;
-		else if(t == Type.CHAR_TYPE)
+		else if(p == Character.TYPE)
 			c = Character.class;
-		else if(t == Type.SHORT_TYPE)
+		else if(p == Short.TYPE)
 			c = Short.class;
-		else if(t == Type.BYTE_TYPE)
+		else if(p == Byte.TYPE)
 			c = Byte.class;
-		else if(t == Type.BOOLEAN_TYPE)
+		else if(p == Boolean.TYPE)
 			c = Boolean.class;
 
 		return c;

src/jvm/clojure/lang/IType.java

@@ -0,0 +1,14 @@
+/**
+ *   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.
+ **/
+
+package clojure.lang;
+
+public interface IType {
+}

src/jvm/clojure/lang/LispReader.java

@@ -1148,9 +1148,13 @@ public Object invoke(Object reader, Object firstChar){
 
 		Object recordName = read(r, true, null, false);
 		Class recordClass = RT.classForName(recordName.toString());
-		int ch = read1(r);
 		char endch;
 		boolean shortForm = true;
+		int ch = read1(r);
+
+		// flush whitespace
+		//while(isWhitespace(ch))
+		//	ch = read1(r);
 
 		// A defrecord ctor can take two forms. Check for map->R version first.
 		if(ch == '{')
@@ -1177,61 +1181,21 @@ else if (ch == '[')
 			if(!ctorFound)
 				throw Util.runtimeException("Unexpected number of constructor arguments to " + recordClass.toString() + ": got " + recordEntries.length);
 
-            ret = Reflector.invokeConstructor(recordClass, RT.seqToArray(resolveEach(recordEntries)));
+			ret = Reflector.invokeConstructor(recordClass, recordEntries);
 			}
 		else
 			{
-            ret = Reflector.invokeStaticMethod(recordClass, "create", new Object[]{RT.map(RT.seqToArray(resolveEach(recordEntries)))});
-			}
-
-	return ret;
-	}
 
-	static public ISeq resolveEach(Object[] a) {
-		ISeq ret = null;
-		for(int i = a.length - 1; i >= 0; --i)
-			ret = (ISeq) RT.cons(resolve(a[i]), ret);
-		return ret;
-	}
-
-	static private Object resolve(Object o) {
-		if(o instanceof Symbol)
-			{
-			try
+			IPersistentMap vals = RT.map(recordEntries);
+			for(ISeq s = RT.keys(vals); s != null; s = s.next())
 				{
-				return RT.classForName(o.toString());
+				if(!(s.first() instanceof Keyword))
+					throw Util.runtimeException("Unreadable defrecord form: key must be of type clojure.lang.Keyword, got " + s.first().toString());
 				}
-			catch(Exception cfe)
-				{
-				throw new IllegalArgumentException("Constructor literal can only contain constants or statics. "
-													+ o.toString()
-													+ " does not name a known class.");
-				}
-            }
-		else if(o instanceof ISeq)
-			{
-			Symbol fs = (Symbol) RT.first(o);
-
-			if(fs == null && o == PersistentList.EMPTY)
-				{
-				return o;
-				}
-
-			throw new IllegalArgumentException("Constructor literal can only contain constants or statics. " + o.toString());
+			ret = Reflector.invokeStaticMethod(recordClass, "create", new Object[]{vals});
 			}
-		else if(o instanceof IPersistentCollection && ((IPersistentCollection) o).count() == 0 ||
-				o instanceof IPersistentCollection ||
-				o instanceof Number  ||
-				o instanceof String  ||
-				o instanceof Keyword ||
-				o instanceof Symbol  ||
-				o == Boolean.TRUE    ||
-				o == Boolean.FALSE   ||
-				o == null) {
-			return o;
-		}
-		else
-			throw new IllegalArgumentException("Constructor literal can only contain constants or statics. " + o.toString());
+
+	return ret;
 	}
 }