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