summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRich Hickey <richhickey@gmail.com>2010-04-14 20:15:45 -0400
committerRich Hickey <richhickey@gmail.com>2010-04-14 20:15:45 -0400
commit12b5c5996dc2f9943f2fca075e94990a24cd7d37 (patch)
tree1f5c177fd6652c3026f79d0c237307e8274e0086
parent27954e23338287ea5e68728c6c2ce8c393e7965a (diff)
first cut of deftype/defrecord split
-rw-r--r--src/clj/clojure/core_deftype.clj286
-rw-r--r--src/clj/clojure/core_proxy.clj2
-rw-r--r--src/clj/clojure/genclass.clj4
-rw-r--r--src/clj/clojure/gvec.clj56
-rw-r--r--src/jvm/clojure/lang/Compiler.java23
-rw-r--r--src/jvm/clojure/lang/DynamicClassLoader.java14
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();