Mercurial > lasercutter

comparison src/clojure/genclass.clj @ 10:ef7dbbd6452c

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