diff options
author | Rich Hickey <richhickey@gmail.com> | 2010-04-14 20:15:45 -0400 |
---|---|---|
committer | Rich Hickey <richhickey@gmail.com> | 2010-04-14 20:15:45 -0400 |
commit | 12b5c5996dc2f9943f2fca075e94990a24cd7d37 (patch) | |
tree | 1f5c177fd6652c3026f79d0c237307e8274e0086 | |
parent | 27954e23338287ea5e68728c6c2ce8c393e7965a (diff) |
first cut of deftype/defrecord split
-rw-r--r-- | src/clj/clojure/core_deftype.clj | 286 | ||||
-rw-r--r-- | src/clj/clojure/core_proxy.clj | 2 | ||||
-rw-r--r-- | src/clj/clojure/genclass.clj | 4 | ||||
-rw-r--r-- | src/clj/clojure/gvec.clj | 56 | ||||
-rw-r--r-- | src/jvm/clojure/lang/Compiler.java | 23 | ||||
-rw-r--r-- | src/jvm/clojure/lang/DynamicClassLoader.java | 14 |
6 files changed, 223 insertions, 162 deletions
diff --git a/src/clj/clojure/core_deftype.clj b/src/clj/clojure/core_deftype.clj index c054d6e0..6266c691 100644 --- a/src/clj/clojure/core_deftype.clj +++ b/src/clj/clojure/core_deftype.clj @@ -15,8 +15,11 @@ [name & sigs] (let [tag (fn [x] (or (:tag (meta x)) Object)) psig (fn [[name [& args]]] - (vector name (vec (map tag args)) (tag name)))] - `(gen-interface :name ~(symbol (str *ns* "." name)) :methods ~(vec (map psig sigs))))) + (vector name (vec (map tag args)) (tag name))) + cname (symbol (str *ns* "." name))] + `(do (gen-interface :name ~cname :methods ~(vec (map psig sigs))) + (ns-unmap (find-ns '~(ns-name *ns*)) '~name) + (import ~cname)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; reify/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -104,8 +107,8 @@ (defn munge [s] ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s)))) -(defn- emit-deftype* - "Do not use this directly - use deftype" +(defn- emit-defrecord + "Do not use this directly - use defrecord" [tagname name fields interfaces methods] (let [tag (keyword (str *ns*) (str tagname)) classname (symbol (str *ns* "." name)) @@ -118,95 +121,77 @@ fields (vec (map #(with-meta % nil) fields)) base-fields fields fields (conj fields '__meta '__extmap)] + (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields)) + (throw (IllegalArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields"))) (letfn [(eqhash [[i m]] - (if (not (or (contains? methodname-set 'equals) (contains? methodname-set 'hashCode))) - [i - (conj m - `(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) - (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])) + [i + (conj m + `(hashCode [~'this] (-> ~tag hash ~@(map #(list `hash-combine %) (remove #{'__meta} fields)))) + `(equals [~'this ~'o] + (boolean + (or (identical? ~'this ~'o) + (when (identical? (class ~'this) (class ~'o)) + (let [~'o ~(with-meta 'o {:tag tagname})] + (and ~@(map (fn [fld] `(= ~fld (. ~'o ~fld))) base-fields) + (= ~'__extmap (. ~'o ~'__extmap)))))))))]) (iobj [[i m]] - (if (and (implement? clojure.lang.IObj) (implement? clojure.lang.IMeta)) - [(conj i 'clojure.lang.IObj) - (conj m `(meta [~'this] ~'__meta) - `(withMeta [~'this ~'m] (new ~tagname ~@(replace {'__meta 'm} fields))))] - [i m])) + [(conj i 'clojure.lang.IObj) + (conj m `(meta [~'this] ~'__meta) + `(withMeta [~'this ~'m] (new ~tagname ~@(replace {'__meta 'm} fields))))]) (ilookup [[i m]] - (if (not (methodname-set 'valAt)) - [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) - (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#))) - (let [gclass (gensym)] - `(getLookupThunk [~'this k#] - (let [~gclass (class ~'this)] - (case k# - ~@(let [gtarget (gensym) - hinted-target (with-meta gtarget {:tag tagname})] - (mapcat - (fn [fld] - [(keyword fld) - `(reify clojure.lang.ILookupThunk - (get [thunk# ~gtarget] - (if (identical? (class ~gtarget) ~gclass) - (. ~hinted-target ~fld) - thunk#)))]) - base-fields)) - nil)))))] - [i m])) - (idynamictype [[i m]] - [(conj i 'clojure.lang.IDynamicType) - (conj m - `(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#))))]) + [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) + (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 [~'this ~'k] + (let [~'gclass (class ~'this)] + (case ~'k + ~@(let [hinted-target (with-meta 'gtarget {:tag tagname})] + (mapcat + (fn [fld] + [(keyword fld) + `(reify clojure.lang.ILookupThunk + (get [~'thunk ~'gtarget] + (if (identical? (class ~'gtarget) ~'gclass) + (. ~hinted-target ~fld) + ~'thunk)))]) + base-fields)) + nil))))]) (imap [[i m]] - (if (and (interface-set clojure.lang.IPersistentMap) (not (methodname-set 'assoc))) - [i - (conj m - `(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 [~'this] (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] - ~'__extmap)) - (let [gk (gensym) gv (gensym)] - `(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 [~'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#))))))] - [i m]))] - (let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap idynamictype)] + [(conj i 'clojure.lang.IPersistentMap) + (conj m + `(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 [~'this] (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] + ~'__extmap)) + `(assoc [~'this ~'gk__4242 ~'gv__4242] + (condp identical? ~'gk__4242 + ~@(mapcat (fn [fld] + [(keyword fld) (list* `new tagname (replace {fld 'gv__4242} fields))]) + base-fields) + (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap ~'gk__4242 ~'gv__4242)))) + `(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))))))])] + (let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap)] `(deftype* ~tagname ~classname ~(conj hinted-fields '__meta '__extmap) :implements ~(vec i) ~@m))))) -(defmacro deftype +(defmacro defrecord "Alpha - subject to change - (deftype name [fields*] options* specs*) + (defrecord name [fields*] options* specs*) Currently there are no options. @@ -216,11 +201,10 @@ protocol-or-interface-or-Object (methodName [args*] body)* - Dynamically generates compiled bytecode for an anonymous class with - 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). + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or + interfaces. A factory function of current.ns/Name will be defined, overloaded on 2 arities, the first taking the designated fields in @@ -228,20 +212,12 @@ by a metadata map (nil for none) and an extension field map (nil for none). - The class will have the (by default, immutable) fields named by + The class will have the (immutable) fields named by fields, which 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. Fields can be qualified - with the metadata :volatile-mutable true or :unsynchronized-mutable - true, at which point (set! afield aval) will be supported in method - bodies. Note well that mutable fields are extremely difficult to use - correctly, and are present only to facilitate the building of higher - level constructs, such as Clojure's reference types, in Clojure - itself. They are for experts only - if the semantics and - implications of :volatile-mutable or :unsynchronized-mutable are not - immediately apparent to you, you should not be using them. + and those fields can be accessed directy. Method definitions take the form: @@ -263,14 +239,11 @@ 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. + The class will have implementations of several (clojure.lang) + interfaces generated automatically: IObj (metadata support) and + IPersistentMap, and all of their superinterfaces. - In addition, unless you supply a version of hashCode or equals, - deftype/class will define type-and-value-based equality and + In addition, defrecord will define type-and-value-based equality and hashCode. When AOT compiling, generates compiled bytecode for a class with the @@ -280,35 +253,114 @@ 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). - - When dynamically evaluated, the class will have a generated name." + meta and extension fields)." [name [& fields] & opts+specs] - (let [gname (if *compile-files* name (gensym (str name "__"))) + (let [gname name [interfaces methods opts] (parse-opts+specs opts+specs) 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 + ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods) + (defmethod print-method ~classname [o# w#] + ((var print-defrecord) o# w#)) + (ns-unmap (find-ns '~(ns-name *ns*)) '~name) + (import ~classname) + #_(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] +(defn- print-defrecord [o #^Writer w] (print-meta o w) (.write w "#:") - (.write w (str (name (.getDynamicType o)))) + (.write w (.getName (class o))) (print-map - (concat - (map #(clojure.lang.MapEntry. % (.getDynamicField o % nil)) fields) - (.getExtensionMap o)) + o pr-on w)) +(defn- emit-deftype* + "Do not use this directly - use deftype" + [tagname name fields interfaces methods] + (let [classname (symbol (str *ns* "." name))] + `(deftype* ~tagname ~classname ~fields + :implements ~interfaces + ~@methods))) + +(defmacro deftype + "Alpha - subject to change + + (deftype name [fields*] options* specs*) + + Currently there are no options. + + Each spec consists of a protocol or interface name followed by zero + or more method bodies: + + protocol-or-interface-or-Object + (methodName [args*] body)* + + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or + interfaces. + + The class will have the (by default, immutable) fields named by + fields, which 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. Fields can be qualified + with the metadata :volatile-mutable true or :unsynchronized-mutable + true, at which point (set! afield aval) will be supported in method + bodies. Note well that mutable fields are extremely difficult to use + correctly, and are present only to facilitate the building of higher + level constructs, such as Clojure's reference types, in Clojure + itself. They are for experts only - if the semantics and + implications of :volatile-mutable or :unsynchronized-mutable are not + immediately apparent to you, you should not be using them. + + Method definitions take the form: + + (methodname [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 + hints should be reserved for disambiguation. + + 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). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied + automatically and can not be substituted. + + In the method bodies, the (unqualified) name can be used to name the + class (for calls to new, instance? etc). + + 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. + + One constructors will be defined, taking the designated fields." + + [name [& fields] & opts+specs] + (let [gname name ;(if *compile-files* name (gensym (str name "__"))) + [interfaces methods opts] (parse-opts+specs opts+specs) + 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) + (ns-unmap (find-ns '~(ns-name *ns*)) '~name) + (import ~classname)))) + + + ;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/clj/clojure/core_proxy.clj b/src/clj/clojure/core_proxy.clj index c24b69d5..9cbc39a6 100644 --- a/src/clj/clojure/core_proxy.clj +++ b/src/clj/clojure/core_proxy.clj @@ -258,7 +258,7 @@ pname (proxy-name super interfaces)] (or (RT/loadClassForName pname) (let [[cname bytecode] (generate-proxy super interfaces)] - (. #^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) (defineClass pname bytecode)))))) + (. #^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) (defineClass pname bytecode [super interfaces])))))) (defn construct-proxy "Takes a proxy class and any arguments for its superclass ctor and diff --git a/src/clj/clojure/genclass.clj b/src/clj/clojure/genclass.clj index 388efc0a..852314ef 100644 --- a/src/clj/clojure/genclass.clj +++ b/src/clj/clojure/genclass.clj @@ -666,7 +666,7 @@ (if *compile-files* (clojure.lang.Compiler/writeClassFile cname bytecode) (.defineClass #^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) - (str (:name options-map)) bytecode)))) + (str (:name options-map)) bytecode options)))) (comment @@ -681,6 +681,6 @@ [& options] (let [options-map (apply hash-map options) [cname bytecode] (generate-class options-map)] - (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode)))) + (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode options)))) ) diff --git a/src/clj/clojure/gvec.clj b/src/clj/clojure/gvec.clj index f00de920..a47959b0 100644 --- a/src/clj/clojure/gvec.clj +++ b/src/clj/clojure/gvec.clj @@ -14,7 +14,7 @@ (deftype VecNode [edit arr]) -(def EMPTY-NODE (VecNode nil (object-array 32))) +(def EMPTY-NODE (VecNode. nil (object-array 32))) (definterface IVecImpl (#^int tailoff []) @@ -68,7 +68,7 @@ (seq [this] this) clojure.lang.IChunkedSeq - (chunkedFirst [_] (ArrayChunk am anode offset (.alength am anode))) + (chunkedFirst [_] (ArrayChunk. am anode offset (.alength am anode))) (chunkedNext [_] (let [nexti (+ i (.alength am anode))] (when (< nexti (count vec)) @@ -80,9 +80,7 @@ (defmethod print-method ::VecSeq [v w] ((get (methods print-method) clojure.lang.ISeq) v w)) -(deftype Vec [#^clojure.core.ArrayManager am #^int cnt #^int shift root tail] - :no-print true - +(deftype Vec [#^clojure.core.ArrayManager am #^int cnt #^int shift root tail _meta] Object (equals [this o] (cond @@ -110,6 +108,12 @@ clojure.lang.Counted (count [_] cnt) + clojure.lang.IMeta + (meta [_] _meta) + + clojure.lang.IObj + (withMeta [_ m] (new Vec am cnt shift root tail m)) + clojure.lang.Indexed (nth [this i] (let [a (.arrayFor this i)] @@ -126,18 +130,18 @@ (let [new-tail (.array am (inc (.alength am tail)))] (System/arraycopy tail 0 new-tail 0 (.alength am tail)) (.aset am new-tail (.alength am tail) val) - (new Vec am (inc cnt) shift root new-tail (meta this) nil)) - (let [tail-node (VecNode (:edit root) tail)] + (new Vec am (inc cnt) shift root new-tail (meta this))) + (let [tail-node (VecNode. (:edit root) tail)] (if (> (bit-shift-right cnt (int 5)) (bit-shift-left (int 1) shift)) ;overflow root? - (let [new-root (VecNode (:edit root) (object-array 32))] + (let [new-root (VecNode. (:edit root) (object-array 32))] (doto #^objects (:arr new-root) (aset 0 root) (aset 1 (.newPath this (:edit root) shift tail-node))) - (new Vec am (inc cnt) (+ shift (int 5)) new-root (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this) nil)) + (new Vec am (inc cnt) (+ shift (int 5)) new-root (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this))) (new Vec am (inc cnt) shift (.pushTail this shift root tail-node) - (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this) nil))))) + (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this)))))) - (empty [_] (new Vec am 0 5 EMPTY-NODE (.array am 0))) + (empty [_] (new Vec am 0 5 EMPTY-NODE (.array am 0) nil)) (equiv [this o] (cond (or (instance? clojure.lang.IPersistentVector o) (instance? java.util.RandomAccess o)) @@ -161,21 +165,21 @@ (zero? cnt) (throw (IllegalStateException. "Can't pop empty vector")) (= 1 cnt) - (new Vec am 0 5 EMPTY-NODE (.array am 0) (meta this) nil) + (new Vec am 0 5 EMPTY-NODE (.array am 0) (meta this)) (> (- cnt (.tailoff this)) 1) (let [new-tail (.array am (dec (.alength am tail)))] (System/arraycopy tail 0 new-tail 0 (.alength am new-tail)) - (new Vec am (dec cnt) shift root new-tail (meta this) nil)) + (new Vec am (dec cnt) shift root new-tail (meta this))) :else (let [new-tail (.arrayFor this (- cnt 2)) new-root (.popTail this shift root)] (cond (nil? new-root) - (new Vec am (dec cnt) shift EMPTY-NODE new-tail (meta this) nil) + (new Vec am (dec cnt) shift EMPTY-NODE new-tail (meta this)) (and (> shift 5) (nil? (aget #^objects (:arr new-root) 1))) - (new Vec am (dec cnt) (- shift 5) (aget #^objects (:arr new-root) 0) new-tail (meta this) nil) + (new Vec am (dec cnt) (- shift 5) (aget #^objects (:arr new-root) 0) new-tail (meta this)) :else - (new Vec am (dec cnt) shift new-root new-tail (meta this) nil))))) + (new Vec am (dec cnt) shift new-root new-tail (meta this)))))) clojure.lang.IPersistentVector (assocN [this i val] @@ -185,8 +189,8 @@ (let [new-tail (.array am (.alength am tail))] (System/arraycopy tail 0 new-tail 0 (.alength am tail)) (.aset am new-tail (bit-and i (int 0x1f)) val) - (new Vec am cnt shift root new-tail (meta this) nil)) - (new Vec am cnt shift (.doAssoc this shift root i val) tail (meta this) nil)) + (new Vec am cnt shift root new-tail (meta this))) + (new Vec am cnt shift (.doAssoc this shift root i val) tail (meta this))) (= i cnt) (.cons this val) :else (throw (IndexOutOfBoundsException.)))) @@ -221,7 +225,7 @@ (seq [this] (if (zero? cnt) nil - (VecSeq am this (.arrayFor this 0) 0 0))) + (VecSeq. am this (.arrayFor this 0) 0 0))) clojure.lang.Sequential ;marker, no methods @@ -242,7 +246,7 @@ (pushTail [this level parent tailnode] (let [subidx (bit-and (bit-shift-right (dec cnt) level) (int 0x1f)) - ret (VecNode (:edit parent) (aclone #^objects (:arr parent))) + ret (VecNode. (:edit parent) (aclone #^objects (:arr parent))) node-to-insert (if (= level (int 5)) tailnode (let [child (aget #^objects (:arr parent) subidx)] @@ -261,16 +265,16 @@ nil (let [arr (aclone #^objects (:arr node))] (aset arr subidx new-child) - (VecNode (:edit root) arr)))) + (VecNode. (:edit root) arr)))) (zero? subidx) nil :else (let [arr (aclone #^objects (:arr node))] (aset arr subidx nil) - (VecNode (:edit root) arr))))) + (VecNode. (:edit root) arr))))) (newPath [this edit #^int level node] (if (zero? level) node - (let [ret (VecNode edit (object-array 32))] + (let [ret (VecNode. edit (object-array 32))] (aset #^objects (:arr ret) 0 (.newPath this edit (- level (int 5)) node)) ret))) @@ -279,11 +283,11 @@ ;on this branch, array will need val type (let [arr (.aclone am (:arr node))] (.aset am arr (bit-and i (int 0x1f)) val) - (VecNode (:edit node) arr)) + (VecNode. (:edit node) arr)) (let [arr (aclone #^objects (:arr node)) subidx (bit-and (bit-shift-right i level) (int 0x1f))] (aset arr subidx (.doAssoc this (- level (int 5)) (aget arr subidx) i val)) - (VecNode (:edit node) arr)))) + (VecNode. (:edit node) arr)))) java.lang.Iterable (iterator [this] @@ -377,4 +381,4 @@ but stores the values unboxed internally." [t] (let [am #^clojure.core.ArrayManager (ams t)] - (Vec am 0 5 EMPTY-NODE (.array am 0)))) + (Vec. am 0 5 EMPTY-NODE (.array am 0) nil))) diff --git a/src/jvm/clojure/lang/Compiler.java b/src/jvm/clojure/lang/Compiler.java index c4f991d9..aea3b062 100644 --- a/src/jvm/clojure/lang/Compiler.java +++ b/src/jvm/clojure/lang/Compiler.java @@ -3106,6 +3106,7 @@ static public class FnExpr extends ObjExpr{ static Expr parse(C context, ISeq form, String name) throws Exception{ ISeq origForm = form; FnExpr fn = new FnExpr(tagOf(form)); + fn.src = form; ObjMethod enclosingMethod = (ObjMethod) METHOD.deref(); if(((IMeta) form.first()).meta() != null) { @@ -3252,6 +3253,8 @@ static public class ObjExpr implements Expr{ IPersistentVector protocolCallsites; IPersistentVector varCallsites; + Object src; + final static Method voidctor = Method.getMethod("void <init>()"); public final String name(){ @@ -3938,7 +3941,7 @@ static public class ObjExpr implements Expr{ else { loader = (DynamicClassLoader) LOADER.deref(); - compiledClass = loader.defineClass(name, bytecode); + compiledClass = loader.defineClass(name, bytecode, src); } } catch(Exception e) @@ -5977,7 +5980,7 @@ static public class NewInstanceExpr extends ObjExpr{ } static class DeftypeParser implements IParser{ - public Expr parse(C context, Object frm) throws Exception{ + public Expr parse(C context, final Object frm) throws Exception{ ISeq rform = (ISeq) frm; //(deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) rform = RT.next(rform); @@ -5994,8 +5997,9 @@ static public class NewInstanceExpr extends ObjExpr{ rform = rform.next().next(); } - return build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),fields,null,tagname, classname, - (Symbol) RT.get(opts,RT.TAG_KEY),rform); + ObjExpr ret = build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),fields,null,tagname, classname, + (Symbol) RT.get(opts,RT.TAG_KEY),rform, frm); + return ret; } } @@ -6018,7 +6022,7 @@ static public class NewInstanceExpr extends ObjExpr{ rform = RT.next(rform); - Expr ret = build(interfaces, null, null, classname, classname, null, rform); + ObjExpr ret = build(interfaces, null, null, classname, classname, null, rform, frm); if(frm instanceof IObj && ((IObj) frm).meta() != null) return new MetaExpr(ret, (MapExpr) MapExpr .parse(context == C.EVAL ? context : C.EXPRESSION, ((IObj) frm).meta())); @@ -6029,9 +6033,10 @@ static public class NewInstanceExpr extends ObjExpr{ static ObjExpr build(IPersistentVector interfaceSyms, IPersistentVector fieldSyms, Symbol thisSym, String tagName, String className, - Symbol typeTag, ISeq methodForms) throws Exception{ + Symbol typeTag, ISeq methodForms, Object frm) throws Exception{ NewInstanceExpr ret = new NewInstanceExpr(null); + ret.src = frm; ret.name = className; ret.internalName = ret.name.replace('.', '/'); ret.objtype = Type.getObjectType(ret.internalName); @@ -6080,7 +6085,7 @@ static public class NewInstanceExpr extends ObjExpr{ String[] inames = interfaceNames(interfaces); - Class stub = compileStub(slashname(superClass),ret, inames); + Class stub = compileStub(slashname(superClass),ret, inames, frm); Symbol thistag = Symbol.intern(null,stub.getName()); try @@ -6140,7 +6145,7 @@ static public class NewInstanceExpr extends ObjExpr{ * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) * Unmunge the name (using a magic prefix) on any code gen for classes */ - static Class compileStub(String superName, NewInstanceExpr ret, String[] interfaceNames){ + static Class compileStub(String superName, NewInstanceExpr ret, String[] interfaceNames, Object frm){ ClassWriter cw = new ClassWriter(ClassWriter.COMPUTE_MAXS); ClassVisitor cv = cw; cv.visit(V1_5, ACC_PUBLIC + ACC_SUPER, COMPILE_STUB_PREFIX + "/" + ret.internalName, @@ -6205,7 +6210,7 @@ static public class NewInstanceExpr extends ObjExpr{ byte[] bytecode = cw.toByteArray(); DynamicClassLoader loader = (DynamicClassLoader) LOADER.deref(); - return loader.defineClass(COMPILE_STUB_PREFIX + "." + ret.name, bytecode); + return loader.defineClass(COMPILE_STUB_PREFIX + "." + ret.name, bytecode, frm); } static String[] interfaceNames(IPersistentVector interfaces){ diff --git a/src/jvm/clojure/lang/DynamicClassLoader.java b/src/jvm/clojure/lang/DynamicClassLoader.java index 2a7ce676..7c58244e 100644 --- a/src/jvm/clojure/lang/DynamicClassLoader.java +++ b/src/jvm/clojure/lang/DynamicClassLoader.java @@ -22,8 +22,8 @@ import java.lang.ref.WeakReference; public class DynamicClassLoader extends URLClassLoader{ HashMap<Integer, Object[]> constantVals = new HashMap<Integer, Object[]>(); -static ConcurrentHashMap<String, Map.Entry<WeakReference<Class>,Integer> >classCache = - new ConcurrentHashMap<String, Map.Entry<WeakReference<Class>,Integer> >(); +static ConcurrentHashMap<String, Map.Entry<WeakReference<Class>,Object> >classCache = + new ConcurrentHashMap<String, Map.Entry<WeakReference<Class>,Object> >(); static final URL[] EMPTY_URLS = new URL[]{}; @@ -38,22 +38,22 @@ public DynamicClassLoader(ClassLoader parent){ super(EMPTY_URLS,parent); } -public Class defineClass(String name, byte[] bytes){ - Map.Entry<WeakReference<Class>,Integer> ce = classCache.get(name); +public Class defineClass(String name, byte[] bytes, Object srcForm){ + Map.Entry<WeakReference<Class>,Object> ce = classCache.get(name); if(ce != null) { WeakReference<Class> cr = ce.getKey(); Class c = cr.get(); - if(c != null && Arrays.hashCode(bytes) == ce.getValue()) + if((c != null) && srcForm.equals(ce.getValue())) return c; } Class c = defineClass(name, bytes, 0, bytes.length); - classCache.put(name, new MapEntry(new WeakReference(c), Arrays.hashCode(bytes))); + classCache.put(name, new MapEntry(new WeakReference(c), srcForm)); return c; } protected Class<?> findClass(String name) throws ClassNotFoundException{ - Map.Entry<WeakReference<Class>,Integer> ce = classCache.get(name); + Map.Entry<WeakReference<Class>,Object> ce = classCache.get(name); if(ce != null) { WeakReference<Class> cr = ce.getKey(); |