rlm@10
|
1 ; Copyright (c) Rich Hickey. All rights reserved.
|
rlm@10
|
2 ; The use and distribution terms for this software are covered by the
|
rlm@10
|
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
rlm@10
|
4 ; which can be found in the file epl-v10.html at the root of this distribution.
|
rlm@10
|
5 ; By using this software in any fashion, you are agreeing to be bound by
|
rlm@10
|
6 ; the terms of this license.
|
rlm@10
|
7 ; You must not remove this notice, or any other, from this software.
|
rlm@10
|
8
|
rlm@10
|
9 (in-ns 'clojure.core)
|
rlm@10
|
10
|
rlm@10
|
11 (import '(java.lang.reflect Modifier Constructor)
|
rlm@10
|
12 '(clojure.asm ClassWriter ClassVisitor Opcodes Type)
|
rlm@10
|
13 '(clojure.asm.commons Method GeneratorAdapter)
|
rlm@10
|
14 '(clojure.lang IPersistentMap))
|
rlm@10
|
15
|
rlm@10
|
16 ;(defn method-sig [^java.lang.reflect.Method meth]
|
rlm@10
|
17 ; [(. meth (getName)) (seq (. meth (getParameterTypes)))])
|
rlm@10
|
18
|
rlm@10
|
19 (defn- non-private-methods [^Class c]
|
rlm@10
|
20 (loop [mm {}
|
rlm@10
|
21 considered #{}
|
rlm@10
|
22 c c]
|
rlm@10
|
23 (if c
|
rlm@10
|
24 (let [[mm considered]
|
rlm@10
|
25 (loop [mm mm
|
rlm@10
|
26 considered considered
|
rlm@10
|
27 meths (seq (concat
|
rlm@10
|
28 (seq (. c (getDeclaredMethods)))
|
rlm@10
|
29 (seq (. c (getMethods)))))]
|
rlm@10
|
30 (if meths
|
rlm@10
|
31 (let [^java.lang.reflect.Method meth (first meths)
|
rlm@10
|
32 mods (. meth (getModifiers))
|
rlm@10
|
33 mk (method-sig meth)]
|
rlm@10
|
34 (if (or (considered mk)
|
rlm@10
|
35 (not (or (Modifier/isPublic mods) (Modifier/isProtected mods)))
|
rlm@10
|
36 ;(. Modifier (isPrivate mods))
|
rlm@10
|
37 (. Modifier (isStatic mods))
|
rlm@10
|
38 (. Modifier (isFinal mods))
|
rlm@10
|
39 (= "finalize" (.getName meth)))
|
rlm@10
|
40 (recur mm (conj considered mk) (next meths))
|
rlm@10
|
41 (recur (assoc mm mk meth) (conj considered mk) (next meths))))
|
rlm@10
|
42 [mm considered]))]
|
rlm@10
|
43 (recur mm considered (. c (getSuperclass))))
|
rlm@10
|
44 mm)))
|
rlm@10
|
45
|
rlm@10
|
46 (defn- ctor-sigs [^Class super]
|
rlm@10
|
47 (for [^Constructor ctor (. super (getDeclaredConstructors))
|
rlm@10
|
48 :when (not (. Modifier (isPrivate (. ctor (getModifiers)))))]
|
rlm@10
|
49 (apply vector (. ctor (getParameterTypes)))))
|
rlm@10
|
50
|
rlm@10
|
51 (defn- escape-class-name [^Class c]
|
rlm@10
|
52 (.. (.getSimpleName c)
|
rlm@10
|
53 (replace "[]" "<>")))
|
rlm@10
|
54
|
rlm@10
|
55 (defn- overload-name [mname pclasses]
|
rlm@10
|
56 (if (seq pclasses)
|
rlm@10
|
57 (apply str mname (interleave (repeat \-)
|
rlm@10
|
58 (map escape-class-name pclasses)))
|
rlm@10
|
59 (str mname "-void")))
|
rlm@10
|
60
|
rlm@10
|
61 (defn- ^java.lang.reflect.Field find-field [^Class c f]
|
rlm@10
|
62 (let [start-class c]
|
rlm@10
|
63 (loop [c c]
|
rlm@10
|
64 (if (= c Object)
|
rlm@10
|
65 (throw (new Exception (str "field, " f ", not defined in class, " start-class ", or its ancestors")))
|
rlm@10
|
66 (let [dflds (.getDeclaredFields c)
|
rlm@10
|
67 rfld (first (filter #(= f (.getName ^java.lang.reflect.Field %)) dflds))]
|
rlm@10
|
68 (or rfld (recur (.getSuperclass c))))))))
|
rlm@10
|
69
|
rlm@10
|
70 ;(distinct (map first(keys (mapcat non-private-methods [Object IPersistentMap]))))
|
rlm@10
|
71
|
rlm@10
|
72 (def ^{:private true} prim->class
|
rlm@10
|
73 {'int Integer/TYPE
|
rlm@10
|
74 'long Long/TYPE
|
rlm@10
|
75 'float Float/TYPE
|
rlm@10
|
76 'double Double/TYPE
|
rlm@10
|
77 'void Void/TYPE
|
rlm@10
|
78 'short Short/TYPE
|
rlm@10
|
79 'boolean Boolean/TYPE
|
rlm@10
|
80 'byte Byte/TYPE
|
rlm@10
|
81 'char Character/TYPE})
|
rlm@10
|
82
|
rlm@10
|
83 (defn- ^Class the-class [x]
|
rlm@10
|
84 (cond
|
rlm@10
|
85 (class? x) x
|
rlm@10
|
86 (contains? prim->class x) (prim->class x)
|
rlm@10
|
87 :else (let [strx (str x)]
|
rlm@10
|
88 (clojure.lang.RT/classForName
|
rlm@10
|
89 (if (some #{\. \[} strx)
|
rlm@10
|
90 strx
|
rlm@10
|
91 (str "java.lang." strx))))))
|
rlm@10
|
92
|
rlm@10
|
93 ;; someday this can be made codepoint aware
|
rlm@10
|
94 (defn- valid-java-method-name
|
rlm@10
|
95 [^String s]
|
rlm@10
|
96 (= s (clojure.lang.Compiler/munge s)))
|
rlm@10
|
97
|
rlm@10
|
98 (defn- validate-generate-class-options
|
rlm@10
|
99 [{:keys [methods]}]
|
rlm@10
|
100 (let [[mname] (remove valid-java-method-name (map (comp str first) methods))]
|
rlm@10
|
101 (when mname (throw (IllegalArgumentException. (str "Not a valid method name: " mname))))))
|
rlm@10
|
102
|
rlm@10
|
103 (defn- generate-class [options-map]
|
rlm@10
|
104 (validate-generate-class-options options-map)
|
rlm@10
|
105 (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)}
|
rlm@10
|
106 {:keys [name extends implements constructors methods main factory state init exposes
|
rlm@10
|
107 exposes-methods prefix load-impl-ns impl-ns post-init]}
|
rlm@10
|
108 (merge default-options options-map)
|
rlm@10
|
109 name-meta (meta name)
|
rlm@10
|
110 name (str name)
|
rlm@10
|
111 super (if extends (the-class extends) Object)
|
rlm@10
|
112 interfaces (map the-class implements)
|
rlm@10
|
113 supers (cons super interfaces)
|
rlm@10
|
114 ctor-sig-map (or constructors (zipmap (ctor-sigs super) (ctor-sigs super)))
|
rlm@10
|
115 cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
|
rlm@10
|
116 cname (. name (replace "." "/"))
|
rlm@10
|
117 pkg-name name
|
rlm@10
|
118 impl-pkg-name (str impl-ns)
|
rlm@10
|
119 impl-cname (.. impl-pkg-name (replace "." "/") (replace \- \_))
|
rlm@10
|
120 ctype (. Type (getObjectType cname))
|
rlm@10
|
121 iname (fn [^Class c] (.. Type (getType c) (getInternalName)))
|
rlm@10
|
122 totype (fn [^Class c] (. Type (getType c)))
|
rlm@10
|
123 to-types (fn [cs] (if (pos? (count cs))
|
rlm@10
|
124 (into-array (map totype cs))
|
rlm@10
|
125 (make-array Type 0)))
|
rlm@10
|
126 obj-type ^Type (totype Object)
|
rlm@10
|
127 arg-types (fn [n] (if (pos? n)
|
rlm@10
|
128 (into-array (replicate n obj-type))
|
rlm@10
|
129 (make-array Type 0)))
|
rlm@10
|
130 super-type ^Type (totype super)
|
rlm@10
|
131 init-name (str init)
|
rlm@10
|
132 post-init-name (str post-init)
|
rlm@10
|
133 factory-name (str factory)
|
rlm@10
|
134 state-name (str state)
|
rlm@10
|
135 main-name "main"
|
rlm@10
|
136 var-name (fn [s] (clojure.lang.Compiler/munge (str s "__var")))
|
rlm@10
|
137 class-type (totype Class)
|
rlm@10
|
138 rt-type (totype clojure.lang.RT)
|
rlm@10
|
139 var-type ^Type (totype clojure.lang.Var)
|
rlm@10
|
140 ifn-type (totype clojure.lang.IFn)
|
rlm@10
|
141 iseq-type (totype clojure.lang.ISeq)
|
rlm@10
|
142 ex-type (totype java.lang.UnsupportedOperationException)
|
rlm@10
|
143 all-sigs (distinct (concat (map #(let[[m p] (key %)] {m [p]}) (mapcat non-private-methods supers))
|
rlm@10
|
144 (map (fn [[m p]] {(str m) [p]}) methods)))
|
rlm@10
|
145 sigs-by-name (apply merge-with concat {} all-sigs)
|
rlm@10
|
146 overloads (into {} (filter (fn [[m s]] (next s)) sigs-by-name))
|
rlm@10
|
147 var-fields (concat (when init [init-name])
|
rlm@10
|
148 (when post-init [post-init-name])
|
rlm@10
|
149 (when main [main-name])
|
rlm@10
|
150 ;(when exposes-methods (map str (vals exposes-methods)))
|
rlm@10
|
151 (distinct (concat (keys sigs-by-name)
|
rlm@10
|
152 (mapcat (fn [[m s]] (map #(overload-name m (map the-class %)) s)) overloads)
|
rlm@10
|
153 (mapcat (comp (partial map str) vals val) exposes))))
|
rlm@10
|
154 emit-get-var (fn [^GeneratorAdapter gen v]
|
rlm@10
|
155 (let [false-label (. gen newLabel)
|
rlm@10
|
156 end-label (. gen newLabel)]
|
rlm@10
|
157 (. gen getStatic ctype (var-name v) var-type)
|
rlm@10
|
158 (. gen dup)
|
rlm@10
|
159 (. gen invokeVirtual var-type (. Method (getMethod "boolean isBound()")))
|
rlm@10
|
160 (. gen ifZCmp (. GeneratorAdapter EQ) false-label)
|
rlm@10
|
161 (. gen invokeVirtual var-type (. Method (getMethod "Object get()")))
|
rlm@10
|
162 (. gen goTo end-label)
|
rlm@10
|
163 (. gen mark false-label)
|
rlm@10
|
164 (. gen pop)
|
rlm@10
|
165 (. gen visitInsn (. Opcodes ACONST_NULL))
|
rlm@10
|
166 (. gen mark end-label)))
|
rlm@10
|
167 emit-unsupported (fn [^GeneratorAdapter gen ^Method m]
|
rlm@10
|
168 (. gen (throwException ex-type (str (. m (getName)) " ("
|
rlm@10
|
169 impl-pkg-name "/" prefix (.getName m)
|
rlm@10
|
170 " not defined?)"))))
|
rlm@10
|
171 emit-forwarding-method
|
rlm@10
|
172 (fn [name pclasses rclass as-static else-gen]
|
rlm@10
|
173 (let [mname (str name)
|
rlm@10
|
174 pmetas (map meta pclasses)
|
rlm@10
|
175 pclasses (map the-class pclasses)
|
rlm@10
|
176 rclass (the-class rclass)
|
rlm@10
|
177 ptypes (to-types pclasses)
|
rlm@10
|
178 rtype ^Type (totype rclass)
|
rlm@10
|
179 m (new Method mname rtype ptypes)
|
rlm@10
|
180 is-overload (seq (overloads mname))
|
rlm@10
|
181 gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (if as-static (. Opcodes ACC_STATIC) 0))
|
rlm@10
|
182 m nil nil cv)
|
rlm@10
|
183 found-label (. gen (newLabel))
|
rlm@10
|
184 else-label (. gen (newLabel))
|
rlm@10
|
185 end-label (. gen (newLabel))]
|
rlm@10
|
186 (add-annotations gen (meta name))
|
rlm@10
|
187 (dotimes [i (count pmetas)]
|
rlm@10
|
188 (add-annotations gen (nth pmetas i) i))
|
rlm@10
|
189 (. gen (visitCode))
|
rlm@10
|
190 (if (> (count pclasses) 18)
|
rlm@10
|
191 (else-gen gen m)
|
rlm@10
|
192 (do
|
rlm@10
|
193 (when is-overload
|
rlm@10
|
194 (emit-get-var gen (overload-name mname pclasses))
|
rlm@10
|
195 (. gen (dup))
|
rlm@10
|
196 (. gen (ifNonNull found-label))
|
rlm@10
|
197 (. gen (pop)))
|
rlm@10
|
198 (emit-get-var gen mname)
|
rlm@10
|
199 (. gen (dup))
|
rlm@10
|
200 (. gen (ifNull else-label))
|
rlm@10
|
201 (when is-overload
|
rlm@10
|
202 (. gen (mark found-label)))
|
rlm@10
|
203 ;if found
|
rlm@10
|
204 (.checkCast gen ifn-type)
|
rlm@10
|
205 (when-not as-static
|
rlm@10
|
206 (. gen (loadThis)))
|
rlm@10
|
207 ;box args
|
rlm@10
|
208 (dotimes [i (count ptypes)]
|
rlm@10
|
209 (. gen (loadArg i))
|
rlm@10
|
210 (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
|
rlm@10
|
211 ;call fn
|
rlm@10
|
212 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type
|
rlm@10
|
213 (to-types (replicate (+ (count ptypes)
|
rlm@10
|
214 (if as-static 0 1))
|
rlm@10
|
215 Object)))))
|
rlm@10
|
216 ;(into-array (cons obj-type
|
rlm@10
|
217 ; (replicate (count ptypes) obj-type))))))
|
rlm@10
|
218 ;unbox return
|
rlm@10
|
219 (. gen (unbox rtype))
|
rlm@10
|
220 (when (= (. rtype (getSort)) (. Type VOID))
|
rlm@10
|
221 (. gen (pop)))
|
rlm@10
|
222 (. gen (goTo end-label))
|
rlm@10
|
223
|
rlm@10
|
224 ;else call supplied alternative generator
|
rlm@10
|
225 (. gen (mark else-label))
|
rlm@10
|
226 (. gen (pop))
|
rlm@10
|
227
|
rlm@10
|
228 (else-gen gen m)
|
rlm@10
|
229
|
rlm@10
|
230 (. gen (mark end-label))))
|
rlm@10
|
231 (. gen (returnValue))
|
rlm@10
|
232 (. gen (endMethod))))
|
rlm@10
|
233 ]
|
rlm@10
|
234 ;start class definition
|
rlm@10
|
235 (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
|
rlm@10
|
236 cname nil (iname super)
|
rlm@10
|
237 (when-let [ifc (seq interfaces)]
|
rlm@10
|
238 (into-array (map iname ifc)))))
|
rlm@10
|
239
|
rlm@10
|
240 ; class annotations
|
rlm@10
|
241 (add-annotations cv name-meta)
|
rlm@10
|
242
|
rlm@10
|
243 ;static fields for vars
|
rlm@10
|
244 (doseq [v var-fields]
|
rlm@10
|
245 (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_FINAL) (. Opcodes ACC_STATIC))
|
rlm@10
|
246 (var-name v)
|
rlm@10
|
247 (. var-type getDescriptor)
|
rlm@10
|
248 nil nil)))
|
rlm@10
|
249
|
rlm@10
|
250 ;instance field for state
|
rlm@10
|
251 (when state
|
rlm@10
|
252 (. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL))
|
rlm@10
|
253 state-name
|
rlm@10
|
254 (. obj-type getDescriptor)
|
rlm@10
|
255 nil nil)))
|
rlm@10
|
256
|
rlm@10
|
257 ;static init to set up var fields and load init
|
rlm@10
|
258 (let [gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
|
rlm@10
|
259 (. Method getMethod "void <clinit> ()")
|
rlm@10
|
260 nil nil cv)]
|
rlm@10
|
261 (. gen (visitCode))
|
rlm@10
|
262 (doseq [v var-fields]
|
rlm@10
|
263 (. gen push impl-pkg-name)
|
rlm@10
|
264 (. gen push (str prefix v))
|
rlm@10
|
265 (. gen (invokeStatic var-type (. Method (getMethod "clojure.lang.Var internPrivate(String,String)"))))
|
rlm@10
|
266 (. gen putStatic ctype (var-name v) var-type))
|
rlm@10
|
267
|
rlm@10
|
268 (when load-impl-ns
|
rlm@10
|
269 (. gen push "clojure.core")
|
rlm@10
|
270 (. gen push "load")
|
rlm@10
|
271 (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.Var var(String,String)"))))
|
rlm@10
|
272 (. gen push (str "/" impl-cname))
|
rlm@10
|
273 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type (to-types [Object]))))
|
rlm@10
|
274 ; (. gen push (str (.replace impl-pkg-name \- \_) "__init"))
|
rlm@10
|
275 ; (. gen (invokeStatic class-type (. Method (getMethod "Class forName(String)"))))
|
rlm@10
|
276 (. gen pop))
|
rlm@10
|
277
|
rlm@10
|
278 (. gen (returnValue))
|
rlm@10
|
279 (. gen (endMethod)))
|
rlm@10
|
280
|
rlm@10
|
281 ;ctors
|
rlm@10
|
282 (doseq [[pclasses super-pclasses] ctor-sig-map]
|
rlm@10
|
283 (let [pclasses (map the-class pclasses)
|
rlm@10
|
284 super-pclasses (map the-class super-pclasses)
|
rlm@10
|
285 ptypes (to-types pclasses)
|
rlm@10
|
286 super-ptypes (to-types super-pclasses)
|
rlm@10
|
287 m (new Method "<init>" (. Type VOID_TYPE) ptypes)
|
rlm@10
|
288 super-m (new Method "<init>" (. Type VOID_TYPE) super-ptypes)
|
rlm@10
|
289 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
|
rlm@10
|
290 no-init-label (. gen newLabel)
|
rlm@10
|
291 end-label (. gen newLabel)
|
rlm@10
|
292 no-post-init-label (. gen newLabel)
|
rlm@10
|
293 end-post-init-label (. gen newLabel)
|
rlm@10
|
294 nth-method (. Method (getMethod "Object nth(Object,int)"))
|
rlm@10
|
295 local (. gen newLocal obj-type)]
|
rlm@10
|
296 (. gen (visitCode))
|
rlm@10
|
297
|
rlm@10
|
298 (if init
|
rlm@10
|
299 (do
|
rlm@10
|
300 (emit-get-var gen init-name)
|
rlm@10
|
301 (. gen dup)
|
rlm@10
|
302 (. gen ifNull no-init-label)
|
rlm@10
|
303 (.checkCast gen ifn-type)
|
rlm@10
|
304 ;box init args
|
rlm@10
|
305 (dotimes [i (count pclasses)]
|
rlm@10
|
306 (. gen (loadArg i))
|
rlm@10
|
307 (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
|
rlm@10
|
308 ;call init fn
|
rlm@10
|
309 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type
|
rlm@10
|
310 (arg-types (count ptypes)))))
|
rlm@10
|
311 ;expecting [[super-ctor-args] state] returned
|
rlm@10
|
312 (. gen dup)
|
rlm@10
|
313 (. gen push 0)
|
rlm@10
|
314 (. gen (invokeStatic rt-type nth-method))
|
rlm@10
|
315 (. gen storeLocal local)
|
rlm@10
|
316
|
rlm@10
|
317 (. gen (loadThis))
|
rlm@10
|
318 (. gen dupX1)
|
rlm@10
|
319 (dotimes [i (count super-pclasses)]
|
rlm@10
|
320 (. gen loadLocal local)
|
rlm@10
|
321 (. gen push i)
|
rlm@10
|
322 (. gen (invokeStatic rt-type nth-method))
|
rlm@10
|
323 (. clojure.lang.Compiler$HostExpr (emitUnboxArg nil gen (nth super-pclasses i))))
|
rlm@10
|
324 (. gen (invokeConstructor super-type super-m))
|
rlm@10
|
325
|
rlm@10
|
326 (if state
|
rlm@10
|
327 (do
|
rlm@10
|
328 (. gen push 1)
|
rlm@10
|
329 (. gen (invokeStatic rt-type nth-method))
|
rlm@10
|
330 (. gen (putField ctype state-name obj-type)))
|
rlm@10
|
331 (. gen pop))
|
rlm@10
|
332
|
rlm@10
|
333 (. gen goTo end-label)
|
rlm@10
|
334 ;no init found
|
rlm@10
|
335 (. gen mark no-init-label)
|
rlm@10
|
336 (. gen (throwException ex-type (str impl-pkg-name "/" prefix init-name " not defined")))
|
rlm@10
|
337 (. gen mark end-label))
|
rlm@10
|
338 (if (= pclasses super-pclasses)
|
rlm@10
|
339 (do
|
rlm@10
|
340 (. gen (loadThis))
|
rlm@10
|
341 (. gen (loadArgs))
|
rlm@10
|
342 (. gen (invokeConstructor super-type super-m)))
|
rlm@10
|
343 (throw (new Exception ":init not specified, but ctor and super ctor args differ"))))
|
rlm@10
|
344
|
rlm@10
|
345 (when post-init
|
rlm@10
|
346 (emit-get-var gen post-init-name)
|
rlm@10
|
347 (. gen dup)
|
rlm@10
|
348 (. gen ifNull no-post-init-label)
|
rlm@10
|
349 (.checkCast gen ifn-type)
|
rlm@10
|
350 (. gen (loadThis))
|
rlm@10
|
351 ;box init args
|
rlm@10
|
352 (dotimes [i (count pclasses)]
|
rlm@10
|
353 (. gen (loadArg i))
|
rlm@10
|
354 (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
|
rlm@10
|
355 ;call init fn
|
rlm@10
|
356 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type
|
rlm@10
|
357 (arg-types (inc (count ptypes))))))
|
rlm@10
|
358 (. gen pop)
|
rlm@10
|
359 (. gen goTo end-post-init-label)
|
rlm@10
|
360 ;no init found
|
rlm@10
|
361 (. gen mark no-post-init-label)
|
rlm@10
|
362 (. gen (throwException ex-type (str impl-pkg-name "/" prefix post-init-name " not defined")))
|
rlm@10
|
363 (. gen mark end-post-init-label))
|
rlm@10
|
364
|
rlm@10
|
365 (. gen (returnValue))
|
rlm@10
|
366 (. gen (endMethod))
|
rlm@10
|
367 ;factory
|
rlm@10
|
368 (when factory
|
rlm@10
|
369 (let [fm (new Method factory-name ctype ptypes)
|
rlm@10
|
370 gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
|
rlm@10
|
371 fm nil nil cv)]
|
rlm@10
|
372 (. gen (visitCode))
|
rlm@10
|
373 (. gen newInstance ctype)
|
rlm@10
|
374 (. gen dup)
|
rlm@10
|
375 (. gen (loadArgs))
|
rlm@10
|
376 (. gen (invokeConstructor ctype m))
|
rlm@10
|
377 (. gen (returnValue))
|
rlm@10
|
378 (. gen (endMethod))))))
|
rlm@10
|
379
|
rlm@10
|
380 ;add methods matching supers', if no fn -> call super
|
rlm@10
|
381 (let [mm (non-private-methods super)]
|
rlm@10
|
382 (doseq [^java.lang.reflect.Method meth (vals mm)]
|
rlm@10
|
383 (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false
|
rlm@10
|
384 (fn [^GeneratorAdapter gen ^Method m]
|
rlm@10
|
385 (. gen (loadThis))
|
rlm@10
|
386 ;push args
|
rlm@10
|
387 (. gen (loadArgs))
|
rlm@10
|
388 ;call super
|
rlm@10
|
389 (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL)
|
rlm@10
|
390 (. super-type (getInternalName))
|
rlm@10
|
391 (. m (getName))
|
rlm@10
|
392 (. m (getDescriptor)))))))
|
rlm@10
|
393 ;add methods matching interfaces', if no fn -> throw
|
rlm@10
|
394 (reduce (fn [mm ^java.lang.reflect.Method meth]
|
rlm@10
|
395 (if (contains? mm (method-sig meth))
|
rlm@10
|
396 mm
|
rlm@10
|
397 (do
|
rlm@10
|
398 (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false
|
rlm@10
|
399 emit-unsupported)
|
rlm@10
|
400 (assoc mm (method-sig meth) meth))))
|
rlm@10
|
401 mm (mapcat #(.getMethods ^Class %) interfaces))
|
rlm@10
|
402 ;extra methods
|
rlm@10
|
403 (doseq [[mname pclasses rclass :as msig] methods]
|
rlm@10
|
404 (emit-forwarding-method mname pclasses rclass (:static (meta msig))
|
rlm@10
|
405 emit-unsupported))
|
rlm@10
|
406 ;expose specified overridden superclass methods
|
rlm@10
|
407 (doseq [[local-mname ^java.lang.reflect.Method m] (reduce (fn [ms [[name _ _] m]]
|
rlm@10
|
408 (if (contains? exposes-methods (symbol name))
|
rlm@10
|
409 (conj ms [((symbol name) exposes-methods) m])
|
rlm@10
|
410 ms)) [] (seq mm))]
|
rlm@10
|
411 (let [ptypes (to-types (.getParameterTypes m))
|
rlm@10
|
412 rtype (totype (.getReturnType m))
|
rlm@10
|
413 exposer-m (new Method (str local-mname) rtype ptypes)
|
rlm@10
|
414 target-m (new Method (.getName m) rtype ptypes)
|
rlm@10
|
415 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) exposer-m nil nil cv)]
|
rlm@10
|
416 (. gen (loadThis))
|
rlm@10
|
417 (. gen (loadArgs))
|
rlm@10
|
418 (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL)
|
rlm@10
|
419 (. super-type (getInternalName))
|
rlm@10
|
420 (. target-m (getName))
|
rlm@10
|
421 (. target-m (getDescriptor))))
|
rlm@10
|
422 (. gen (returnValue))
|
rlm@10
|
423 (. gen (endMethod)))))
|
rlm@10
|
424 ;main
|
rlm@10
|
425 (when main
|
rlm@10
|
426 (let [m (. Method getMethod "void main (String[])")
|
rlm@10
|
427 gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
|
rlm@10
|
428 m nil nil cv)
|
rlm@10
|
429 no-main-label (. gen newLabel)
|
rlm@10
|
430 end-label (. gen newLabel)]
|
rlm@10
|
431 (. gen (visitCode))
|
rlm@10
|
432
|
rlm@10
|
433 (emit-get-var gen main-name)
|
rlm@10
|
434 (. gen dup)
|
rlm@10
|
435 (. gen ifNull no-main-label)
|
rlm@10
|
436 (.checkCast gen ifn-type)
|
rlm@10
|
437 (. gen loadArgs)
|
rlm@10
|
438 (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.ISeq seq(Object)"))))
|
rlm@10
|
439 (. gen (invokeInterface ifn-type (new Method "applyTo" obj-type
|
rlm@10
|
440 (into-array [iseq-type]))))
|
rlm@10
|
441 (. gen pop)
|
rlm@10
|
442 (. gen goTo end-label)
|
rlm@10
|
443 ;no main found
|
rlm@10
|
444 (. gen mark no-main-label)
|
rlm@10
|
445 (. gen (throwException ex-type (str impl-pkg-name "/" prefix main-name " not defined")))
|
rlm@10
|
446 (. gen mark end-label)
|
rlm@10
|
447 (. gen (returnValue))
|
rlm@10
|
448 (. gen (endMethod))))
|
rlm@10
|
449 ;field exposers
|
rlm@10
|
450 (doseq [[f {getter :get setter :set}] exposes]
|
rlm@10
|
451 (let [fld (find-field super (str f))
|
rlm@10
|
452 ftype (totype (.getType fld))
|
rlm@10
|
453 static? (Modifier/isStatic (.getModifiers fld))
|
rlm@10
|
454 acc (+ Opcodes/ACC_PUBLIC (if static? Opcodes/ACC_STATIC 0))]
|
rlm@10
|
455 (when getter
|
rlm@10
|
456 (let [m (new Method (str getter) ftype (to-types []))
|
rlm@10
|
457 gen (new GeneratorAdapter acc m nil nil cv)]
|
rlm@10
|
458 (. gen (visitCode))
|
rlm@10
|
459 (if static?
|
rlm@10
|
460 (. gen getStatic ctype (str f) ftype)
|
rlm@10
|
461 (do
|
rlm@10
|
462 (. gen loadThis)
|
rlm@10
|
463 (. gen getField ctype (str f) ftype)))
|
rlm@10
|
464 (. gen (returnValue))
|
rlm@10
|
465 (. gen (endMethod))))
|
rlm@10
|
466 (when setter
|
rlm@10
|
467 (let [m (new Method (str setter) Type/VOID_TYPE (into-array [ftype]))
|
rlm@10
|
468 gen (new GeneratorAdapter acc m nil nil cv)]
|
rlm@10
|
469 (. gen (visitCode))
|
rlm@10
|
470 (if static?
|
rlm@10
|
471 (do
|
rlm@10
|
472 (. gen loadArgs)
|
rlm@10
|
473 (. gen putStatic ctype (str f) ftype))
|
rlm@10
|
474 (do
|
rlm@10
|
475 (. gen loadThis)
|
rlm@10
|
476 (. gen loadArgs)
|
rlm@10
|
477 (. gen putField ctype (str f) ftype)))
|
rlm@10
|
478 (. gen (returnValue))
|
rlm@10
|
479 (. gen (endMethod))))))
|
rlm@10
|
480 ;finish class def
|
rlm@10
|
481 (. cv (visitEnd))
|
rlm@10
|
482 [cname (. cv (toByteArray))]))
|
rlm@10
|
483
|
rlm@10
|
484 (defmacro gen-class
|
rlm@10
|
485 "When compiling, generates compiled bytecode for a class with the
|
rlm@10
|
486 given package-qualified :name (which, as all names in these
|
rlm@10
|
487 parameters, can be a string or symbol), and writes the .class file
|
rlm@10
|
488 to the *compile-path* directory. When not compiling, does
|
rlm@10
|
489 nothing. The gen-class construct contains no implementation, as the
|
rlm@10
|
490 implementation will be dynamically sought by the generated class in
|
rlm@10
|
491 functions in an implementing Clojure namespace. Given a generated
|
rlm@10
|
492 class org.mydomain.MyClass with a method named mymethod, gen-class
|
rlm@10
|
493 will generate an implementation that looks for a function named by
|
rlm@10
|
494 (str prefix mymethod) (default prefix: \"-\") in a
|
rlm@10
|
495 Clojure namespace specified by :impl-ns
|
rlm@10
|
496 (defaults to the current namespace). All inherited methods,
|
rlm@10
|
497 generated methods, and init and main functions (see :methods, :init,
|
rlm@10
|
498 and :main below) will be found similarly prefixed. By default, the
|
rlm@10
|
499 static initializer for the generated class will attempt to load the
|
rlm@10
|
500 Clojure support code for the class as a resource from the classpath,
|
rlm@10
|
501 e.g. in the example case, ``org/mydomain/MyClass__init.class``. This
|
rlm@10
|
502 behavior can be controlled by :load-impl-ns
|
rlm@10
|
503
|
rlm@10
|
504 Note that methods with a maximum of 18 parameters are supported.
|
rlm@10
|
505
|
rlm@10
|
506 In all subsequent sections taking types, the primitive types can be
|
rlm@10
|
507 referred to by their Java names (int, float etc), and classes in the
|
rlm@10
|
508 java.lang package can be used without a package qualifier. All other
|
rlm@10
|
509 classes must be fully qualified.
|
rlm@10
|
510
|
rlm@10
|
511 Options should be a set of key/value pairs, all except for :name are optional:
|
rlm@10
|
512
|
rlm@10
|
513 :name aname
|
rlm@10
|
514
|
rlm@10
|
515 The package-qualified name of the class to be generated
|
rlm@10
|
516
|
rlm@10
|
517 :extends aclass
|
rlm@10
|
518
|
rlm@10
|
519 Specifies the superclass, the non-private methods of which will be
|
rlm@10
|
520 overridden by the class. If not provided, defaults to Object.
|
rlm@10
|
521
|
rlm@10
|
522 :implements [interface ...]
|
rlm@10
|
523
|
rlm@10
|
524 One or more interfaces, the methods of which will be implemented by the class.
|
rlm@10
|
525
|
rlm@10
|
526 :init name
|
rlm@10
|
527
|
rlm@10
|
528 If supplied, names a function that will be called with the arguments
|
rlm@10
|
529 to the constructor. Must return [ [superclass-constructor-args] state]
|
rlm@10
|
530 If not supplied, the constructor args are passed directly to
|
rlm@10
|
531 the superclass constructor and the state will be nil
|
rlm@10
|
532
|
rlm@10
|
533 :constructors {[param-types] [super-param-types], ...}
|
rlm@10
|
534
|
rlm@10
|
535 By default, constructors are created for the generated class which
|
rlm@10
|
536 match the signature(s) of the constructors for the superclass. This
|
rlm@10
|
537 parameter may be used to explicitly specify constructors, each entry
|
rlm@10
|
538 providing a mapping from a constructor signature to a superclass
|
rlm@10
|
539 constructor signature. When you supply this, you must supply an :init
|
rlm@10
|
540 specifier.
|
rlm@10
|
541
|
rlm@10
|
542 :post-init name
|
rlm@10
|
543
|
rlm@10
|
544 If supplied, names a function that will be called with the object as
|
rlm@10
|
545 the first argument, followed by the arguments to the constructor.
|
rlm@10
|
546 It will be called every time an object of this class is created,
|
rlm@10
|
547 immediately after all the inherited constructors have completed.
|
rlm@10
|
548 It's return value is ignored.
|
rlm@10
|
549
|
rlm@10
|
550 :methods [ [name [param-types] return-type], ...]
|
rlm@10
|
551
|
rlm@10
|
552 The generated class automatically defines all of the non-private
|
rlm@10
|
553 methods of its superclasses/interfaces. This parameter can be used
|
rlm@10
|
554 to specify the signatures of additional methods of the generated
|
rlm@10
|
555 class. Static methods can be specified with ^{:static true} in the
|
rlm@10
|
556 signature's metadata. Do not repeat superclass/interface signatures
|
rlm@10
|
557 here.
|
rlm@10
|
558
|
rlm@10
|
559 :main boolean
|
rlm@10
|
560
|
rlm@10
|
561 If supplied and true, a static public main function will be generated. It will
|
rlm@10
|
562 pass each string of the String[] argument as a separate argument to
|
rlm@10
|
563 a function called (str prefix main).
|
rlm@10
|
564
|
rlm@10
|
565 :factory name
|
rlm@10
|
566
|
rlm@10
|
567 If supplied, a (set of) public static factory function(s) will be
|
rlm@10
|
568 created with the given name, and the same signature(s) as the
|
rlm@10
|
569 constructor(s).
|
rlm@10
|
570
|
rlm@10
|
571 :state name
|
rlm@10
|
572
|
rlm@10
|
573 If supplied, a public final instance field with the given name will be
|
rlm@10
|
574 created. You must supply an :init function in order to provide a
|
rlm@10
|
575 value for the state. Note that, though final, the state can be a ref
|
rlm@10
|
576 or agent, supporting the creation of Java objects with transactional
|
rlm@10
|
577 or asynchronous mutation semantics.
|
rlm@10
|
578
|
rlm@10
|
579 :exposes {protected-field-name {:get name :set name}, ...}
|
rlm@10
|
580
|
rlm@10
|
581 Since the implementations of the methods of the generated class
|
rlm@10
|
582 occur in Clojure functions, they have no access to the inherited
|
rlm@10
|
583 protected fields of the superclass. This parameter can be used to
|
rlm@10
|
584 generate public getter/setter methods exposing the protected field(s)
|
rlm@10
|
585 for use in the implementation.
|
rlm@10
|
586
|
rlm@10
|
587 :exposes-methods {super-method-name exposed-name, ...}
|
rlm@10
|
588
|
rlm@10
|
589 It is sometimes necessary to call the superclass' implementation of an
|
rlm@10
|
590 overridden method. Those methods may be exposed and referred in
|
rlm@10
|
591 the new method implementation by a local name.
|
rlm@10
|
592
|
rlm@10
|
593 :prefix string
|
rlm@10
|
594
|
rlm@10
|
595 Default: \"-\" Methods called e.g. Foo will be looked up in vars called
|
rlm@10
|
596 prefixFoo in the implementing ns.
|
rlm@10
|
597
|
rlm@10
|
598 :impl-ns name
|
rlm@10
|
599
|
rlm@10
|
600 Default: the name of the current ns. Implementations of methods will be
|
rlm@10
|
601 looked up in this namespace.
|
rlm@10
|
602
|
rlm@10
|
603 :load-impl-ns boolean
|
rlm@10
|
604
|
rlm@10
|
605 Default: true. Causes the static initializer for the generated class
|
rlm@10
|
606 to reference the load code for the implementing namespace. Should be
|
rlm@10
|
607 true when implementing-ns is the default, false if you intend to
|
rlm@10
|
608 load the code via some other method."
|
rlm@10
|
609 {:added "1.0"}
|
rlm@10
|
610
|
rlm@10
|
611 [& options]
|
rlm@10
|
612 (when *compile-files*
|
rlm@10
|
613 (let [options-map (into {} (map vec (partition 2 options)))
|
rlm@10
|
614 [cname bytecode] (generate-class options-map)]
|
rlm@10
|
615 (clojure.lang.Compiler/writeClassFile cname bytecode))))
|
rlm@10
|
616
|
rlm@10
|
617 ;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;;
|
rlm@10
|
618 ;; based on original contribution by Chris Houser
|
rlm@10
|
619
|
rlm@10
|
620 (defn- ^Type asm-type
|
rlm@10
|
621 "Returns an asm Type object for c, which may be a primitive class
|
rlm@10
|
622 (such as Integer/TYPE), any other class (such as Double), or a
|
rlm@10
|
623 fully-qualified class name given as a string or symbol
|
rlm@10
|
624 (such as 'java.lang.String)"
|
rlm@10
|
625 [c]
|
rlm@10
|
626 (if (or (instance? Class c) (prim->class c))
|
rlm@10
|
627 (Type/getType (the-class c))
|
rlm@10
|
628 (let [strx (str c)]
|
rlm@10
|
629 (Type/getObjectType
|
rlm@10
|
630 (.replace (if (some #{\.} strx)
|
rlm@10
|
631 strx
|
rlm@10
|
632 (str "java.lang." strx))
|
rlm@10
|
633 "." "/")))))
|
rlm@10
|
634
|
rlm@10
|
635 (defn- generate-interface
|
rlm@10
|
636 [{:keys [name extends methods]}]
|
rlm@10
|
637 (let [iname (.replace (str name) "." "/")
|
rlm@10
|
638 cv (ClassWriter. ClassWriter/COMPUTE_MAXS)]
|
rlm@10
|
639 (. cv visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC
|
rlm@10
|
640 Opcodes/ACC_ABSTRACT
|
rlm@10
|
641 Opcodes/ACC_INTERFACE)
|
rlm@10
|
642 iname nil "java/lang/Object"
|
rlm@10
|
643 (when (seq extends)
|
rlm@10
|
644 (into-array (map #(.getInternalName (asm-type %)) extends))))
|
rlm@10
|
645 (add-annotations cv (meta name))
|
rlm@10
|
646 (doseq [[mname pclasses rclass pmetas] methods]
|
rlm@10
|
647 (let [mv (. cv visitMethod (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
|
rlm@10
|
648 (str mname)
|
rlm@10
|
649 (Type/getMethodDescriptor (asm-type rclass)
|
rlm@10
|
650 (if pclasses
|
rlm@10
|
651 (into-array Type (map asm-type pclasses))
|
rlm@10
|
652 (make-array Type 0)))
|
rlm@10
|
653 nil nil)]
|
rlm@10
|
654 (add-annotations mv (meta mname))
|
rlm@10
|
655 (dotimes [i (count pmetas)]
|
rlm@10
|
656 (add-annotations mv (nth pmetas i) i))
|
rlm@10
|
657 (. mv visitEnd)))
|
rlm@10
|
658 (. cv visitEnd)
|
rlm@10
|
659 [iname (. cv toByteArray)]))
|
rlm@10
|
660
|
rlm@10
|
661 (defmacro gen-interface
|
rlm@10
|
662 "When compiling, generates compiled bytecode for an interface with
|
rlm@10
|
663 the given package-qualified :name (which, as all names in these
|
rlm@10
|
664 parameters, can be a string or symbol), and writes the .class file
|
rlm@10
|
665 to the *compile-path* directory. When not compiling, does nothing.
|
rlm@10
|
666
|
rlm@10
|
667 In all subsequent sections taking types, the primitive types can be
|
rlm@10
|
668 referred to by their Java names (int, float etc), and classes in the
|
rlm@10
|
669 java.lang package can be used without a package qualifier. All other
|
rlm@10
|
670 classes must be fully qualified.
|
rlm@10
|
671
|
rlm@10
|
672 Options should be a set of key/value pairs, all except for :name are
|
rlm@10
|
673 optional:
|
rlm@10
|
674
|
rlm@10
|
675 :name aname
|
rlm@10
|
676
|
rlm@10
|
677 The package-qualified name of the class to be generated
|
rlm@10
|
678
|
rlm@10
|
679 :extends [interface ...]
|
rlm@10
|
680
|
rlm@10
|
681 One or more interfaces, which will be extended by this interface.
|
rlm@10
|
682
|
rlm@10
|
683 :methods [ [name [param-types] return-type], ...]
|
rlm@10
|
684
|
rlm@10
|
685 This parameter is used to specify the signatures of the methods of
|
rlm@10
|
686 the generated interface. Do not repeat superinterface signatures
|
rlm@10
|
687 here."
|
rlm@10
|
688 {:added "1.0"}
|
rlm@10
|
689
|
rlm@10
|
690 [& options]
|
rlm@10
|
691 (let [options-map (apply hash-map options)
|
rlm@10
|
692 [cname bytecode] (generate-interface options-map)]
|
rlm@10
|
693 (if *compile-files*
|
rlm@10
|
694 (clojure.lang.Compiler/writeClassFile cname bytecode)
|
rlm@10
|
695 (.defineClass ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER)
|
rlm@10
|
696 (str (:name options-map)) bytecode options))))
|
rlm@10
|
697
|
rlm@10
|
698 (comment
|
rlm@10
|
699
|
rlm@10
|
700 (defn gen-and-load-class
|
rlm@10
|
701 "Generates and immediately loads the bytecode for the specified
|
rlm@10
|
702 class. Note that a class generated this way can be loaded only once
|
rlm@10
|
703 - the JVM supports only one class with a given name per
|
rlm@10
|
704 classloader. Subsequent to generation you can import it into any
|
rlm@10
|
705 desired namespaces just like any other class. See gen-class for a
|
rlm@10
|
706 description of the options."
|
rlm@10
|
707 {:added "1.0"}
|
rlm@10
|
708
|
rlm@10
|
709 [& options]
|
rlm@10
|
710 (let [options-map (apply hash-map options)
|
rlm@10
|
711 [cname bytecode] (generate-class options-map)]
|
rlm@10
|
712 (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode options))))
|
rlm@10
|
713
|
rlm@10
|
714 )
|