@@ -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] src/clj/clojure/core_deftype.clj @@ -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(); } src/jvm/clojure/lang/Compiler.java 451390fc83bcd3a35144d62a173553572b7ad6d4 Rich Hickey richhickey@gmail.com http://github.com/richhickey/clojure/commit/292836f87260fdb994d25a98ef65b4edebf9d09e 292836f87260fdb994d25a98ef65b4edebf9d09e 2009-11-12T09:52:37-08:00 2009-11-12T09:52:37-08:00 got rid of defclass. deftype now can refer to self-type, will emit same-named class when AOT compiling, thus replacing defclass. ca65997ff79c04e6f72280f8b2e36d4dbd915dad Rich Hickey richhickey@gmail.com