Mercurial > lasercutter
comparison src/clojure/core_proxy.clj @ 10:ef7dbbd6452c
added clojure source goodness
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Sat, 21 Aug 2010 06:25:44 -0400 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
9:35cf337adfcf | 10:ef7dbbd6452c |
---|---|
1 ; Copyright (c) Rich Hickey. All rights reserved. | |
2 ; The use and distribution terms for this software are covered by the | |
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
4 ; which can be found in the file epl-v10.html at the root of this distribution. | |
5 ; By using this software in any fashion, you are agreeing to be bound by | |
6 ; the terms of this license. | |
7 ; You must not remove this notice, or any other, from this software. | |
8 | |
9 (in-ns 'clojure.core) | |
10 | |
11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; proxy ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
12 | |
13 (import | |
14 '(clojure.asm ClassWriter ClassVisitor Opcodes Type) | |
15 '(java.lang.reflect Modifier Constructor) | |
16 '(clojure.asm.commons Method GeneratorAdapter) | |
17 '(clojure.lang IProxy Reflector DynamicClassLoader IPersistentMap PersistentHashMap RT)) | |
18 | |
19 (defn method-sig [^java.lang.reflect.Method meth] | |
20 [(. meth (getName)) (seq (. meth (getParameterTypes))) (. meth getReturnType)]) | |
21 | |
22 (defn- most-specific [rtypes] | |
23 (or (some (fn [t] (when (every? #(isa? t %) rtypes) t)) rtypes) | |
24 (throw (Exception. "Incompatible return types")))) | |
25 | |
26 (defn- group-by-sig [coll] | |
27 "takes a collection of [msig meth] and returns a seq of maps from return-types to meths." | |
28 (vals (reduce (fn [m [msig meth]] | |
29 (let [rtype (peek msig) | |
30 argsig (pop msig)] | |
31 (assoc m argsig (assoc (m argsig {}) rtype meth)))) | |
32 {} coll))) | |
33 | |
34 (defn proxy-name | |
35 {:tag String} | |
36 [^Class super interfaces] | |
37 (let [inames (into (sorted-set) (map #(.getName ^Class %) interfaces))] | |
38 (apply str (.replace (str *ns*) \- \_) ".proxy" | |
39 (interleave (repeat "$") | |
40 (concat | |
41 [(.getName super)] | |
42 (map #(subs % (inc (.lastIndexOf ^String % "."))) inames) | |
43 [(Integer/toHexString (hash inames))]))))) | |
44 | |
45 (defn- generate-proxy [^Class super interfaces] | |
46 (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS)) | |
47 cname (.replace (proxy-name super interfaces) \. \/) ;(str "clojure/lang/" (gensym "Proxy__")) | |
48 ctype (. Type (getObjectType cname)) | |
49 iname (fn [^Class c] (.. Type (getType c) (getInternalName))) | |
50 fmap "__clojureFnMap" | |
51 totype (fn [^Class c] (. Type (getType c))) | |
52 to-types (fn [cs] (if (pos? (count cs)) | |
53 (into-array (map totype cs)) | |
54 (make-array Type 0))) | |
55 super-type ^Type (totype super) | |
56 imap-type ^Type (totype IPersistentMap) | |
57 ifn-type (totype clojure.lang.IFn) | |
58 obj-type (totype Object) | |
59 sym-type (totype clojure.lang.Symbol) | |
60 rt-type (totype clojure.lang.RT) | |
61 ex-type (totype java.lang.UnsupportedOperationException) | |
62 gen-bridge | |
63 (fn [^java.lang.reflect.Method meth ^java.lang.reflect.Method dest] | |
64 (let [pclasses (. meth (getParameterTypes)) | |
65 ptypes (to-types pclasses) | |
66 rtype ^Type (totype (. meth (getReturnType))) | |
67 m (new Method (. meth (getName)) rtype ptypes) | |
68 dtype (totype (.getDeclaringClass dest)) | |
69 dm (new Method (. dest (getName)) (totype (. dest (getReturnType))) (to-types (. dest (getParameterTypes)))) | |
70 gen (new GeneratorAdapter (bit-or (. Opcodes ACC_PUBLIC) (. Opcodes ACC_BRIDGE)) m nil nil cv)] | |
71 (. gen (visitCode)) | |
72 (. gen (loadThis)) | |
73 (dotimes [i (count ptypes)] | |
74 (. gen (loadArg i))) | |
75 (if (-> dest .getDeclaringClass .isInterface) | |
76 (. gen (invokeInterface dtype dm)) | |
77 (. gen (invokeVirtual dtype dm))) | |
78 (. gen (returnValue)) | |
79 (. gen (endMethod)))) | |
80 gen-method | |
81 (fn [^java.lang.reflect.Method meth else-gen] | |
82 (let [pclasses (. meth (getParameterTypes)) | |
83 ptypes (to-types pclasses) | |
84 rtype ^Type (totype (. meth (getReturnType))) | |
85 m (new Method (. meth (getName)) rtype ptypes) | |
86 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv) | |
87 else-label (. gen (newLabel)) | |
88 end-label (. gen (newLabel)) | |
89 decl-type (. Type (getType (. meth (getDeclaringClass))))] | |
90 (. gen (visitCode)) | |
91 (if (> (count pclasses) 18) | |
92 (else-gen gen m) | |
93 (do | |
94 (. gen (loadThis)) | |
95 (. gen (getField ctype fmap imap-type)) | |
96 | |
97 (. gen (push (. meth (getName)))) | |
98 ;lookup fn in map | |
99 (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)")))) | |
100 (. gen (dup)) | |
101 (. gen (ifNull else-label)) | |
102 ;if found | |
103 (.checkCast gen ifn-type) | |
104 (. gen (loadThis)) | |
105 ;box args | |
106 (dotimes [i (count ptypes)] | |
107 (. gen (loadArg i)) | |
108 (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) | |
109 ;call fn | |
110 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type | |
111 (into-array (cons obj-type | |
112 (replicate (count ptypes) obj-type)))))) | |
113 ;unbox return | |
114 (. gen (unbox rtype)) | |
115 (when (= (. rtype (getSort)) (. Type VOID)) | |
116 (. gen (pop))) | |
117 (. gen (goTo end-label)) | |
118 | |
119 ;else call supplied alternative generator | |
120 (. gen (mark else-label)) | |
121 (. gen (pop)) | |
122 | |
123 (else-gen gen m) | |
124 | |
125 (. gen (mark end-label)))) | |
126 (. gen (returnValue)) | |
127 (. gen (endMethod))))] | |
128 | |
129 ;start class definition | |
130 (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER)) | |
131 cname nil (iname super) | |
132 (into-array (map iname (cons IProxy interfaces))))) | |
133 ;add field for fn mappings | |
134 (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE)) | |
135 fmap (. imap-type (getDescriptor)) nil nil)) | |
136 ;add ctors matching/calling super's | |
137 (doseq [^Constructor ctor (. super (getDeclaredConstructors))] | |
138 (when-not (. Modifier (isPrivate (. ctor (getModifiers)))) | |
139 (let [ptypes (to-types (. ctor (getParameterTypes))) | |
140 m (new Method "<init>" (. Type VOID_TYPE) ptypes) | |
141 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] | |
142 (. gen (visitCode)) | |
143 ;call super ctor | |
144 (. gen (loadThis)) | |
145 (. gen (dup)) | |
146 (. gen (loadArgs)) | |
147 (. gen (invokeConstructor super-type m)) | |
148 | |
149 (. gen (returnValue)) | |
150 (. gen (endMethod))))) | |
151 ;add IProxy methods | |
152 (let [m (. Method (getMethod "void __initClojureFnMappings(clojure.lang.IPersistentMap)")) | |
153 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] | |
154 (. gen (visitCode)) | |
155 (. gen (loadThis)) | |
156 (. gen (loadArgs)) | |
157 (. gen (putField ctype fmap imap-type)) | |
158 | |
159 (. gen (returnValue)) | |
160 (. gen (endMethod))) | |
161 (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)")) | |
162 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] | |
163 (. gen (visitCode)) | |
164 (. gen (loadThis)) | |
165 (. gen (dup)) | |
166 (. gen (getField ctype fmap imap-type)) | |
167 (.checkCast gen (totype clojure.lang.IPersistentCollection)) | |
168 (. gen (loadArgs)) | |
169 (. gen (invokeInterface (totype clojure.lang.IPersistentCollection) | |
170 (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)")))) | |
171 (. gen (checkCast imap-type)) | |
172 (. gen (putField ctype fmap imap-type)) | |
173 | |
174 (. gen (returnValue)) | |
175 (. gen (endMethod))) | |
176 (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()")) | |
177 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] | |
178 (. gen (visitCode)) | |
179 (. gen (loadThis)) | |
180 (. gen (getField ctype fmap imap-type)) | |
181 (. gen (returnValue)) | |
182 (. gen (endMethod))) | |
183 | |
184 ;calc set of supers' non-private instance methods | |
185 (let [[mm considered] | |
186 (loop [mm {} considered #{} c super] | |
187 (if c | |
188 (let [[mm considered] | |
189 (loop [mm mm | |
190 considered considered | |
191 meths (concat | |
192 (seq (. c (getDeclaredMethods))) | |
193 (seq (. c (getMethods))))] | |
194 (if (seq meths) | |
195 (let [^java.lang.reflect.Method meth (first meths) | |
196 mods (. meth (getModifiers)) | |
197 mk (method-sig meth)] | |
198 (if (or (considered mk) | |
199 (not (or (Modifier/isPublic mods) (Modifier/isProtected mods))) | |
200 ;(. Modifier (isPrivate mods)) | |
201 (. Modifier (isStatic mods)) | |
202 (. Modifier (isFinal mods)) | |
203 (= "finalize" (.getName meth))) | |
204 (recur mm (conj considered mk) (next meths)) | |
205 (recur (assoc mm mk meth) (conj considered mk) (next meths)))) | |
206 [mm considered]))] | |
207 (recur mm considered (. c (getSuperclass)))) | |
208 [mm considered])) | |
209 ifaces-meths (into {} | |
210 (for [^Class iface interfaces meth (. iface (getMethods)) | |
211 :let [msig (method-sig meth)] :when (not (considered msig))] | |
212 {msig meth})) | |
213 mgroups (group-by-sig (concat mm ifaces-meths)) | |
214 rtypes (map #(most-specific (keys %)) mgroups) | |
215 mb (map #(vector (%1 %2) (vals (dissoc %1 %2))) mgroups rtypes) | |
216 bridge? (reduce into #{} (map second mb)) | |
217 ifaces-meths (remove bridge? (vals ifaces-meths)) | |
218 mm (remove bridge? (vals mm))] | |
219 ;add methods matching supers', if no mapping -> call super | |
220 (doseq [[^java.lang.reflect.Method dest bridges] mb | |
221 ^java.lang.reflect.Method meth bridges] | |
222 (gen-bridge meth dest)) | |
223 (doseq [^java.lang.reflect.Method meth mm] | |
224 (gen-method meth | |
225 (fn [^GeneratorAdapter gen ^Method m] | |
226 (. gen (loadThis)) | |
227 ;push args | |
228 (. gen (loadArgs)) | |
229 ;call super | |
230 (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) | |
231 (. super-type (getInternalName)) | |
232 (. m (getName)) | |
233 (. m (getDescriptor))))))) | |
234 | |
235 ;add methods matching interfaces', if no mapping -> throw | |
236 (doseq [^java.lang.reflect.Method meth ifaces-meths] | |
237 (gen-method meth | |
238 (fn [^GeneratorAdapter gen ^Method m] | |
239 (. gen (throwException ex-type (. m (getName)))))))) | |
240 | |
241 ;finish class def | |
242 (. cv (visitEnd)) | |
243 [cname (. cv toByteArray)])) | |
244 | |
245 (defn- get-super-and-interfaces [bases] | |
246 (if (. ^Class (first bases) (isInterface)) | |
247 [Object bases] | |
248 [(first bases) (next bases)])) | |
249 | |
250 (defn get-proxy-class | |
251 "Takes an optional single class followed by zero or more | |
252 interfaces. If not supplied class defaults to Object. Creates an | |
253 returns an instance of a proxy class derived from the supplied | |
254 classes. The resulting value is cached and used for any subsequent | |
255 requests for the same class set. Returns a Class object." | |
256 {:added "1.0"} | |
257 [& bases] | |
258 (let [[super interfaces] (get-super-and-interfaces bases) | |
259 pname (proxy-name super interfaces)] | |
260 (or (RT/loadClassForName pname) | |
261 (let [[cname bytecode] (generate-proxy super interfaces)] | |
262 (. ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) (defineClass pname bytecode [super interfaces])))))) | |
263 | |
264 (defn construct-proxy | |
265 "Takes a proxy class and any arguments for its superclass ctor and | |
266 creates and returns an instance of the proxy." | |
267 {:added "1.0"} | |
268 [c & ctor-args] | |
269 (. Reflector (invokeConstructor c (to-array ctor-args)))) | |
270 | |
271 (defn init-proxy | |
272 "Takes a proxy instance and a map of strings (which must | |
273 correspond to methods of the proxy superclass/superinterfaces) to | |
274 fns (which must take arguments matching the corresponding method, | |
275 plus an additional (explicit) first arg corresponding to this, and | |
276 sets the proxy's fn map." | |
277 {:added "1.0"} | |
278 [^IProxy proxy mappings] | |
279 (. proxy (__initClojureFnMappings mappings))) | |
280 | |
281 (defn update-proxy | |
282 "Takes a proxy instance and a map of strings (which must | |
283 correspond to methods of the proxy superclass/superinterfaces) to | |
284 fns (which must take arguments matching the corresponding method, | |
285 plus an additional (explicit) first arg corresponding to this, and | |
286 updates (via assoc) the proxy's fn map. nil can be passed instead of | |
287 a fn, in which case the corresponding method will revert to the | |
288 default behavior. Note that this function can be used to update the | |
289 behavior of an existing instance without changing its identity." | |
290 {:added "1.0"} | |
291 [^IProxy proxy mappings] | |
292 (. proxy (__updateClojureFnMappings mappings))) | |
293 | |
294 (defn proxy-mappings | |
295 "Takes a proxy instance and returns the proxy's fn map." | |
296 {:added "1.0"} | |
297 [^IProxy proxy] | |
298 (. proxy (__getClojureFnMappings))) | |
299 | |
300 (defmacro proxy | |
301 "class-and-interfaces - a vector of class names | |
302 | |
303 args - a (possibly empty) vector of arguments to the superclass | |
304 constructor. | |
305 | |
306 f => (name [params*] body) or | |
307 (name ([params*] body) ([params+] body) ...) | |
308 | |
309 Expands to code which creates a instance of a proxy class that | |
310 implements the named class/interface(s) by calling the supplied | |
311 fns. A single class, if provided, must be first. If not provided it | |
312 defaults to Object. | |
313 | |
314 The interfaces names must be valid interface types. If a method fn | |
315 is not provided for a class method, the superclass methd will be | |
316 called. If a method fn is not provided for an interface method, an | |
317 UnsupportedOperationException will be thrown should it be | |
318 called. Method fns are closures and can capture the environment in | |
319 which proxy is called. Each method fn takes an additional implicit | |
320 first arg, which is bound to 'this. Note that while method fns can | |
321 be provided to override protected methods, they have no other access | |
322 to protected members, nor to super, as these capabilities cannot be | |
323 proxied." | |
324 {:added "1.0"} | |
325 [class-and-interfaces args & fs] | |
326 (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %)))) | |
327 class-and-interfaces) | |
328 [super interfaces] (get-super-and-interfaces bases) | |
329 compile-effect (when *compile-files* | |
330 (let [[cname bytecode] (generate-proxy super interfaces)] | |
331 (clojure.lang.Compiler/writeClassFile cname bytecode))) | |
332 pc-effect (apply get-proxy-class bases) | |
333 pname (proxy-name super interfaces)] | |
334 ;remember the class to prevent it from disappearing before use | |
335 (intern *ns* (symbol pname) pc-effect) | |
336 `(let [;pc# (get-proxy-class ~@class-and-interfaces) | |
337 p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)] | |
338 (init-proxy p# | |
339 ~(loop [fmap {} fs fs] | |
340 (if fs | |
341 (let [[sym & meths] (first fs) | |
342 meths (if (vector? (first meths)) | |
343 (list meths) | |
344 meths) | |
345 meths (map (fn [[params & body]] | |
346 (cons (apply vector 'this params) body)) | |
347 meths)] | |
348 (if-not (contains? fmap (name sym)) | |
349 (recur (assoc fmap (name sym) (cons `fn meths)) (next fs)) | |
350 (throw (IllegalArgumentException. | |
351 (str "Method '" (name sym) "' redefined"))))) | |
352 fmap))) | |
353 p#))) | |
354 | |
355 (defn proxy-call-with-super [call this meth] | |
356 (let [m (proxy-mappings this)] | |
357 (update-proxy this (assoc m meth nil)) | |
358 (let [ret (call)] | |
359 (update-proxy this m) | |
360 ret))) | |
361 | |
362 (defmacro proxy-super | |
363 "Use to call a superclass method in the body of a proxy method. | |
364 Note, expansion captures 'this" | |
365 {:added "1.0"} | |
366 [meth & args] | |
367 `(proxy-call-with-super (fn [] (. ~'this ~meth ~@args)) ~'this ~(name meth))) | |
368 | |
369 (defn bean | |
370 "Takes a Java object and returns a read-only implementation of the | |
371 map abstraction based upon its JavaBean properties." | |
372 {:added "1.0"} | |
373 [^Object x] | |
374 (let [c (. x (getClass)) | |
375 pmap (reduce (fn [m ^java.beans.PropertyDescriptor pd] | |
376 (let [name (. pd (getName)) | |
377 method (. pd (getReadMethod))] | |
378 (if (and method (zero? (alength (. method (getParameterTypes))))) | |
379 (assoc m (keyword name) (fn [] (clojure.lang.Reflector/prepRet (. method (invoke x nil))))) | |
380 m))) | |
381 {} | |
382 (seq (.. java.beans.Introspector | |
383 (getBeanInfo c) | |
384 (getPropertyDescriptors)))) | |
385 v (fn [k] ((pmap k))) | |
386 snapshot (fn [] | |
387 (reduce (fn [m e] | |
388 (assoc m (key e) ((val e)))) | |
389 {} (seq pmap)))] | |
390 (proxy [clojure.lang.APersistentMap] | |
391 [] | |
392 (containsKey [k] (contains? pmap k)) | |
393 (entryAt [k] (when (contains? pmap k) (new clojure.lang.MapEntry k (v k)))) | |
394 (valAt ([k] (v k)) | |
395 ([k default] (if (contains? pmap k) (v k) default))) | |
396 (cons [m] (conj (snapshot) m)) | |
397 (count [] (count pmap)) | |
398 (assoc [k v] (assoc (snapshot) k v)) | |
399 (without [k] (dissoc (snapshot) k)) | |
400 (seq [] ((fn thisfn [plseq] | |
401 (lazy-seq | |
402 (when-let [pseq (seq plseq)] | |
403 (cons (new clojure.lang.MapEntry (first pseq) (v (first pseq))) | |
404 (thisfn (rest pseq)))))) (keys pmap)))))) | |
405 | |
406 | |
407 |