Mercurial > lasercutter
diff src/clojure/genclass.clj @ 10:ef7dbbd6452c
added clojure source goodness
| author | Robert McIntyre <rlm@mit.edu> |
|---|---|
| date | Sat, 21 Aug 2010 06:25:44 -0400 |
| parents | |
| children |
line wrap: on
line diff
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000 1.2 +++ b/src/clojure/genclass.clj Sat Aug 21 06:25:44 2010 -0400 1.3 @@ -0,0 +1,714 @@ 1.4 +; Copyright (c) Rich Hickey. All rights reserved. 1.5 +; The use and distribution terms for this software are covered by the 1.6 +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 1.7 +; which can be found in the file epl-v10.html at the root of this distribution. 1.8 +; By using this software in any fashion, you are agreeing to be bound by 1.9 +; the terms of this license. 1.10 +; You must not remove this notice, or any other, from this software. 1.11 + 1.12 +(in-ns 'clojure.core) 1.13 + 1.14 +(import '(java.lang.reflect Modifier Constructor) 1.15 + '(clojure.asm ClassWriter ClassVisitor Opcodes Type) 1.16 + '(clojure.asm.commons Method GeneratorAdapter) 1.17 + '(clojure.lang IPersistentMap)) 1.18 + 1.19 +;(defn method-sig [^java.lang.reflect.Method meth] 1.20 +; [(. meth (getName)) (seq (. meth (getParameterTypes)))]) 1.21 + 1.22 +(defn- non-private-methods [^Class c] 1.23 + (loop [mm {} 1.24 + considered #{} 1.25 + c c] 1.26 + (if c 1.27 + (let [[mm considered] 1.28 + (loop [mm mm 1.29 + considered considered 1.30 + meths (seq (concat 1.31 + (seq (. c (getDeclaredMethods))) 1.32 + (seq (. c (getMethods)))))] 1.33 + (if meths 1.34 + (let [^java.lang.reflect.Method meth (first meths) 1.35 + mods (. meth (getModifiers)) 1.36 + mk (method-sig meth)] 1.37 + (if (or (considered mk) 1.38 + (not (or (Modifier/isPublic mods) (Modifier/isProtected mods))) 1.39 + ;(. Modifier (isPrivate mods)) 1.40 + (. Modifier (isStatic mods)) 1.41 + (. Modifier (isFinal mods)) 1.42 + (= "finalize" (.getName meth))) 1.43 + (recur mm (conj considered mk) (next meths)) 1.44 + (recur (assoc mm mk meth) (conj considered mk) (next meths)))) 1.45 + [mm considered]))] 1.46 + (recur mm considered (. c (getSuperclass)))) 1.47 + mm))) 1.48 + 1.49 +(defn- ctor-sigs [^Class super] 1.50 + (for [^Constructor ctor (. super (getDeclaredConstructors)) 1.51 + :when (not (. Modifier (isPrivate (. ctor (getModifiers)))))] 1.52 + (apply vector (. ctor (getParameterTypes))))) 1.53 + 1.54 +(defn- escape-class-name [^Class c] 1.55 + (.. (.getSimpleName c) 1.56 + (replace "[]" "<>"))) 1.57 + 1.58 +(defn- overload-name [mname pclasses] 1.59 + (if (seq pclasses) 1.60 + (apply str mname (interleave (repeat \-) 1.61 + (map escape-class-name pclasses))) 1.62 + (str mname "-void"))) 1.63 + 1.64 +(defn- ^java.lang.reflect.Field find-field [^Class c f] 1.65 + (let [start-class c] 1.66 + (loop [c c] 1.67 + (if (= c Object) 1.68 + (throw (new Exception (str "field, " f ", not defined in class, " start-class ", or its ancestors"))) 1.69 + (let [dflds (.getDeclaredFields c) 1.70 + rfld (first (filter #(= f (.getName ^java.lang.reflect.Field %)) dflds))] 1.71 + (or rfld (recur (.getSuperclass c)))))))) 1.72 + 1.73 +;(distinct (map first(keys (mapcat non-private-methods [Object IPersistentMap])))) 1.74 + 1.75 +(def ^{:private true} prim->class 1.76 + {'int Integer/TYPE 1.77 + 'long Long/TYPE 1.78 + 'float Float/TYPE 1.79 + 'double Double/TYPE 1.80 + 'void Void/TYPE 1.81 + 'short Short/TYPE 1.82 + 'boolean Boolean/TYPE 1.83 + 'byte Byte/TYPE 1.84 + 'char Character/TYPE}) 1.85 + 1.86 +(defn- ^Class the-class [x] 1.87 + (cond 1.88 + (class? x) x 1.89 + (contains? prim->class x) (prim->class x) 1.90 + :else (let [strx (str x)] 1.91 + (clojure.lang.RT/classForName 1.92 + (if (some #{\. \[} strx) 1.93 + strx 1.94 + (str "java.lang." strx)))))) 1.95 + 1.96 +;; someday this can be made codepoint aware 1.97 +(defn- valid-java-method-name 1.98 + [^String s] 1.99 + (= s (clojure.lang.Compiler/munge s))) 1.100 + 1.101 +(defn- validate-generate-class-options 1.102 + [{:keys [methods]}] 1.103 + (let [[mname] (remove valid-java-method-name (map (comp str first) methods))] 1.104 + (when mname (throw (IllegalArgumentException. (str "Not a valid method name: " mname)))))) 1.105 + 1.106 +(defn- generate-class [options-map] 1.107 + (validate-generate-class-options options-map) 1.108 + (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)} 1.109 + {:keys [name extends implements constructors methods main factory state init exposes 1.110 + exposes-methods prefix load-impl-ns impl-ns post-init]} 1.111 + (merge default-options options-map) 1.112 + name-meta (meta name) 1.113 + name (str name) 1.114 + super (if extends (the-class extends) Object) 1.115 + interfaces (map the-class implements) 1.116 + supers (cons super interfaces) 1.117 + ctor-sig-map (or constructors (zipmap (ctor-sigs super) (ctor-sigs super))) 1.118 + cv (new ClassWriter (. ClassWriter COMPUTE_MAXS)) 1.119 + cname (. name (replace "." "/")) 1.120 + pkg-name name 1.121 + impl-pkg-name (str impl-ns) 1.122 + impl-cname (.. impl-pkg-name (replace "." "/") (replace \- \_)) 1.123 + ctype (. Type (getObjectType cname)) 1.124 + iname (fn [^Class c] (.. Type (getType c) (getInternalName))) 1.125 + totype (fn [^Class c] (. Type (getType c))) 1.126 + to-types (fn [cs] (if (pos? (count cs)) 1.127 + (into-array (map totype cs)) 1.128 + (make-array Type 0))) 1.129 + obj-type ^Type (totype Object) 1.130 + arg-types (fn [n] (if (pos? n) 1.131 + (into-array (replicate n obj-type)) 1.132 + (make-array Type 0))) 1.133 + super-type ^Type (totype super) 1.134 + init-name (str init) 1.135 + post-init-name (str post-init) 1.136 + factory-name (str factory) 1.137 + state-name (str state) 1.138 + main-name "main" 1.139 + var-name (fn [s] (clojure.lang.Compiler/munge (str s "__var"))) 1.140 + class-type (totype Class) 1.141 + rt-type (totype clojure.lang.RT) 1.142 + var-type ^Type (totype clojure.lang.Var) 1.143 + ifn-type (totype clojure.lang.IFn) 1.144 + iseq-type (totype clojure.lang.ISeq) 1.145 + ex-type (totype java.lang.UnsupportedOperationException) 1.146 + all-sigs (distinct (concat (map #(let[[m p] (key %)] {m [p]}) (mapcat non-private-methods supers)) 1.147 + (map (fn [[m p]] {(str m) [p]}) methods))) 1.148 + sigs-by-name (apply merge-with concat {} all-sigs) 1.149 + overloads (into {} (filter (fn [[m s]] (next s)) sigs-by-name)) 1.150 + var-fields (concat (when init [init-name]) 1.151 + (when post-init [post-init-name]) 1.152 + (when main [main-name]) 1.153 + ;(when exposes-methods (map str (vals exposes-methods))) 1.154 + (distinct (concat (keys sigs-by-name) 1.155 + (mapcat (fn [[m s]] (map #(overload-name m (map the-class %)) s)) overloads) 1.156 + (mapcat (comp (partial map str) vals val) exposes)))) 1.157 + emit-get-var (fn [^GeneratorAdapter gen v] 1.158 + (let [false-label (. gen newLabel) 1.159 + end-label (. gen newLabel)] 1.160 + (. gen getStatic ctype (var-name v) var-type) 1.161 + (. gen dup) 1.162 + (. gen invokeVirtual var-type (. Method (getMethod "boolean isBound()"))) 1.163 + (. gen ifZCmp (. GeneratorAdapter EQ) false-label) 1.164 + (. gen invokeVirtual var-type (. Method (getMethod "Object get()"))) 1.165 + (. gen goTo end-label) 1.166 + (. gen mark false-label) 1.167 + (. gen pop) 1.168 + (. gen visitInsn (. Opcodes ACONST_NULL)) 1.169 + (. gen mark end-label))) 1.170 + emit-unsupported (fn [^GeneratorAdapter gen ^Method m] 1.171 + (. gen (throwException ex-type (str (. m (getName)) " (" 1.172 + impl-pkg-name "/" prefix (.getName m) 1.173 + " not defined?)")))) 1.174 + emit-forwarding-method 1.175 + (fn [name pclasses rclass as-static else-gen] 1.176 + (let [mname (str name) 1.177 + pmetas (map meta pclasses) 1.178 + pclasses (map the-class pclasses) 1.179 + rclass (the-class rclass) 1.180 + ptypes (to-types pclasses) 1.181 + rtype ^Type (totype rclass) 1.182 + m (new Method mname rtype ptypes) 1.183 + is-overload (seq (overloads mname)) 1.184 + gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (if as-static (. Opcodes ACC_STATIC) 0)) 1.185 + m nil nil cv) 1.186 + found-label (. gen (newLabel)) 1.187 + else-label (. gen (newLabel)) 1.188 + end-label (. gen (newLabel))] 1.189 + (add-annotations gen (meta name)) 1.190 + (dotimes [i (count pmetas)] 1.191 + (add-annotations gen (nth pmetas i) i)) 1.192 + (. gen (visitCode)) 1.193 + (if (> (count pclasses) 18) 1.194 + (else-gen gen m) 1.195 + (do 1.196 + (when is-overload 1.197 + (emit-get-var gen (overload-name mname pclasses)) 1.198 + (. gen (dup)) 1.199 + (. gen (ifNonNull found-label)) 1.200 + (. gen (pop))) 1.201 + (emit-get-var gen mname) 1.202 + (. gen (dup)) 1.203 + (. gen (ifNull else-label)) 1.204 + (when is-overload 1.205 + (. gen (mark found-label))) 1.206 + ;if found 1.207 + (.checkCast gen ifn-type) 1.208 + (when-not as-static 1.209 + (. gen (loadThis))) 1.210 + ;box args 1.211 + (dotimes [i (count ptypes)] 1.212 + (. gen (loadArg i)) 1.213 + (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) 1.214 + ;call fn 1.215 + (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 1.216 + (to-types (replicate (+ (count ptypes) 1.217 + (if as-static 0 1)) 1.218 + Object))))) 1.219 + ;(into-array (cons obj-type 1.220 + ; (replicate (count ptypes) obj-type)))))) 1.221 + ;unbox return 1.222 + (. gen (unbox rtype)) 1.223 + (when (= (. rtype (getSort)) (. Type VOID)) 1.224 + (. gen (pop))) 1.225 + (. gen (goTo end-label)) 1.226 + 1.227 + ;else call supplied alternative generator 1.228 + (. gen (mark else-label)) 1.229 + (. gen (pop)) 1.230 + 1.231 + (else-gen gen m) 1.232 + 1.233 + (. gen (mark end-label)))) 1.234 + (. gen (returnValue)) 1.235 + (. gen (endMethod)))) 1.236 + ] 1.237 + ;start class definition 1.238 + (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER)) 1.239 + cname nil (iname super) 1.240 + (when-let [ifc (seq interfaces)] 1.241 + (into-array (map iname ifc))))) 1.242 + 1.243 + ; class annotations 1.244 + (add-annotations cv name-meta) 1.245 + 1.246 + ;static fields for vars 1.247 + (doseq [v var-fields] 1.248 + (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_FINAL) (. Opcodes ACC_STATIC)) 1.249 + (var-name v) 1.250 + (. var-type getDescriptor) 1.251 + nil nil))) 1.252 + 1.253 + ;instance field for state 1.254 + (when state 1.255 + (. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL)) 1.256 + state-name 1.257 + (. obj-type getDescriptor) 1.258 + nil nil))) 1.259 + 1.260 + ;static init to set up var fields and load init 1.261 + (let [gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 1.262 + (. Method getMethod "void <clinit> ()") 1.263 + nil nil cv)] 1.264 + (. gen (visitCode)) 1.265 + (doseq [v var-fields] 1.266 + (. gen push impl-pkg-name) 1.267 + (. gen push (str prefix v)) 1.268 + (. gen (invokeStatic var-type (. Method (getMethod "clojure.lang.Var internPrivate(String,String)")))) 1.269 + (. gen putStatic ctype (var-name v) var-type)) 1.270 + 1.271 + (when load-impl-ns 1.272 + (. gen push "clojure.core") 1.273 + (. gen push "load") 1.274 + (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.Var var(String,String)")))) 1.275 + (. gen push (str "/" impl-cname)) 1.276 + (. gen (invokeInterface ifn-type (new Method "invoke" obj-type (to-types [Object])))) 1.277 +; (. gen push (str (.replace impl-pkg-name \- \_) "__init")) 1.278 +; (. gen (invokeStatic class-type (. Method (getMethod "Class forName(String)")))) 1.279 + (. gen pop)) 1.280 + 1.281 + (. gen (returnValue)) 1.282 + (. gen (endMethod))) 1.283 + 1.284 + ;ctors 1.285 + (doseq [[pclasses super-pclasses] ctor-sig-map] 1.286 + (let [pclasses (map the-class pclasses) 1.287 + super-pclasses (map the-class super-pclasses) 1.288 + ptypes (to-types pclasses) 1.289 + super-ptypes (to-types super-pclasses) 1.290 + m (new Method "<init>" (. Type VOID_TYPE) ptypes) 1.291 + super-m (new Method "<init>" (. Type VOID_TYPE) super-ptypes) 1.292 + gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv) 1.293 + no-init-label (. gen newLabel) 1.294 + end-label (. gen newLabel) 1.295 + no-post-init-label (. gen newLabel) 1.296 + end-post-init-label (. gen newLabel) 1.297 + nth-method (. Method (getMethod "Object nth(Object,int)")) 1.298 + local (. gen newLocal obj-type)] 1.299 + (. gen (visitCode)) 1.300 + 1.301 + (if init 1.302 + (do 1.303 + (emit-get-var gen init-name) 1.304 + (. gen dup) 1.305 + (. gen ifNull no-init-label) 1.306 + (.checkCast gen ifn-type) 1.307 + ;box init args 1.308 + (dotimes [i (count pclasses)] 1.309 + (. gen (loadArg i)) 1.310 + (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) 1.311 + ;call init fn 1.312 + (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 1.313 + (arg-types (count ptypes))))) 1.314 + ;expecting [[super-ctor-args] state] returned 1.315 + (. gen dup) 1.316 + (. gen push 0) 1.317 + (. gen (invokeStatic rt-type nth-method)) 1.318 + (. gen storeLocal local) 1.319 + 1.320 + (. gen (loadThis)) 1.321 + (. gen dupX1) 1.322 + (dotimes [i (count super-pclasses)] 1.323 + (. gen loadLocal local) 1.324 + (. gen push i) 1.325 + (. gen (invokeStatic rt-type nth-method)) 1.326 + (. clojure.lang.Compiler$HostExpr (emitUnboxArg nil gen (nth super-pclasses i)))) 1.327 + (. gen (invokeConstructor super-type super-m)) 1.328 + 1.329 + (if state 1.330 + (do 1.331 + (. gen push 1) 1.332 + (. gen (invokeStatic rt-type nth-method)) 1.333 + (. gen (putField ctype state-name obj-type))) 1.334 + (. gen pop)) 1.335 + 1.336 + (. gen goTo end-label) 1.337 + ;no init found 1.338 + (. gen mark no-init-label) 1.339 + (. gen (throwException ex-type (str impl-pkg-name "/" prefix init-name " not defined"))) 1.340 + (. gen mark end-label)) 1.341 + (if (= pclasses super-pclasses) 1.342 + (do 1.343 + (. gen (loadThis)) 1.344 + (. gen (loadArgs)) 1.345 + (. gen (invokeConstructor super-type super-m))) 1.346 + (throw (new Exception ":init not specified, but ctor and super ctor args differ")))) 1.347 + 1.348 + (when post-init 1.349 + (emit-get-var gen post-init-name) 1.350 + (. gen dup) 1.351 + (. gen ifNull no-post-init-label) 1.352 + (.checkCast gen ifn-type) 1.353 + (. gen (loadThis)) 1.354 + ;box init args 1.355 + (dotimes [i (count pclasses)] 1.356 + (. gen (loadArg i)) 1.357 + (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) 1.358 + ;call init fn 1.359 + (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 1.360 + (arg-types (inc (count ptypes)))))) 1.361 + (. gen pop) 1.362 + (. gen goTo end-post-init-label) 1.363 + ;no init found 1.364 + (. gen mark no-post-init-label) 1.365 + (. gen (throwException ex-type (str impl-pkg-name "/" prefix post-init-name " not defined"))) 1.366 + (. gen mark end-post-init-label)) 1.367 + 1.368 + (. gen (returnValue)) 1.369 + (. gen (endMethod)) 1.370 + ;factory 1.371 + (when factory 1.372 + (let [fm (new Method factory-name ctype ptypes) 1.373 + gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 1.374 + fm nil nil cv)] 1.375 + (. gen (visitCode)) 1.376 + (. gen newInstance ctype) 1.377 + (. gen dup) 1.378 + (. gen (loadArgs)) 1.379 + (. gen (invokeConstructor ctype m)) 1.380 + (. gen (returnValue)) 1.381 + (. gen (endMethod)))))) 1.382 + 1.383 + ;add methods matching supers', if no fn -> call super 1.384 + (let [mm (non-private-methods super)] 1.385 + (doseq [^java.lang.reflect.Method meth (vals mm)] 1.386 + (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false 1.387 + (fn [^GeneratorAdapter gen ^Method m] 1.388 + (. gen (loadThis)) 1.389 + ;push args 1.390 + (. gen (loadArgs)) 1.391 + ;call super 1.392 + (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 1.393 + (. super-type (getInternalName)) 1.394 + (. m (getName)) 1.395 + (. m (getDescriptor))))))) 1.396 + ;add methods matching interfaces', if no fn -> throw 1.397 + (reduce (fn [mm ^java.lang.reflect.Method meth] 1.398 + (if (contains? mm (method-sig meth)) 1.399 + mm 1.400 + (do 1.401 + (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false 1.402 + emit-unsupported) 1.403 + (assoc mm (method-sig meth) meth)))) 1.404 + mm (mapcat #(.getMethods ^Class %) interfaces)) 1.405 + ;extra methods 1.406 + (doseq [[mname pclasses rclass :as msig] methods] 1.407 + (emit-forwarding-method mname pclasses rclass (:static (meta msig)) 1.408 + emit-unsupported)) 1.409 + ;expose specified overridden superclass methods 1.410 + (doseq [[local-mname ^java.lang.reflect.Method m] (reduce (fn [ms [[name _ _] m]] 1.411 + (if (contains? exposes-methods (symbol name)) 1.412 + (conj ms [((symbol name) exposes-methods) m]) 1.413 + ms)) [] (seq mm))] 1.414 + (let [ptypes (to-types (.getParameterTypes m)) 1.415 + rtype (totype (.getReturnType m)) 1.416 + exposer-m (new Method (str local-mname) rtype ptypes) 1.417 + target-m (new Method (.getName m) rtype ptypes) 1.418 + gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) exposer-m nil nil cv)] 1.419 + (. gen (loadThis)) 1.420 + (. gen (loadArgs)) 1.421 + (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 1.422 + (. super-type (getInternalName)) 1.423 + (. target-m (getName)) 1.424 + (. target-m (getDescriptor)))) 1.425 + (. gen (returnValue)) 1.426 + (. gen (endMethod))))) 1.427 + ;main 1.428 + (when main 1.429 + (let [m (. Method getMethod "void main (String[])") 1.430 + gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 1.431 + m nil nil cv) 1.432 + no-main-label (. gen newLabel) 1.433 + end-label (. gen newLabel)] 1.434 + (. gen (visitCode)) 1.435 + 1.436 + (emit-get-var gen main-name) 1.437 + (. gen dup) 1.438 + (. gen ifNull no-main-label) 1.439 + (.checkCast gen ifn-type) 1.440 + (. gen loadArgs) 1.441 + (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.ISeq seq(Object)")))) 1.442 + (. gen (invokeInterface ifn-type (new Method "applyTo" obj-type 1.443 + (into-array [iseq-type])))) 1.444 + (. gen pop) 1.445 + (. gen goTo end-label) 1.446 + ;no main found 1.447 + (. gen mark no-main-label) 1.448 + (. gen (throwException ex-type (str impl-pkg-name "/" prefix main-name " not defined"))) 1.449 + (. gen mark end-label) 1.450 + (. gen (returnValue)) 1.451 + (. gen (endMethod)))) 1.452 + ;field exposers 1.453 + (doseq [[f {getter :get setter :set}] exposes] 1.454 + (let [fld (find-field super (str f)) 1.455 + ftype (totype (.getType fld)) 1.456 + static? (Modifier/isStatic (.getModifiers fld)) 1.457 + acc (+ Opcodes/ACC_PUBLIC (if static? Opcodes/ACC_STATIC 0))] 1.458 + (when getter 1.459 + (let [m (new Method (str getter) ftype (to-types [])) 1.460 + gen (new GeneratorAdapter acc m nil nil cv)] 1.461 + (. gen (visitCode)) 1.462 + (if static? 1.463 + (. gen getStatic ctype (str f) ftype) 1.464 + (do 1.465 + (. gen loadThis) 1.466 + (. gen getField ctype (str f) ftype))) 1.467 + (. gen (returnValue)) 1.468 + (. gen (endMethod)))) 1.469 + (when setter 1.470 + (let [m (new Method (str setter) Type/VOID_TYPE (into-array [ftype])) 1.471 + gen (new GeneratorAdapter acc m nil nil cv)] 1.472 + (. gen (visitCode)) 1.473 + (if static? 1.474 + (do 1.475 + (. gen loadArgs) 1.476 + (. gen putStatic ctype (str f) ftype)) 1.477 + (do 1.478 + (. gen loadThis) 1.479 + (. gen loadArgs) 1.480 + (. gen putField ctype (str f) ftype))) 1.481 + (. gen (returnValue)) 1.482 + (. gen (endMethod)))))) 1.483 + ;finish class def 1.484 + (. cv (visitEnd)) 1.485 + [cname (. cv (toByteArray))])) 1.486 + 1.487 +(defmacro gen-class 1.488 + "When compiling, generates compiled bytecode for a class with the 1.489 + given package-qualified :name (which, as all names in these 1.490 + parameters, can be a string or symbol), and writes the .class file 1.491 + to the *compile-path* directory. When not compiling, does 1.492 + nothing. The gen-class construct contains no implementation, as the 1.493 + implementation will be dynamically sought by the generated class in 1.494 + functions in an implementing Clojure namespace. Given a generated 1.495 + class org.mydomain.MyClass with a method named mymethod, gen-class 1.496 + will generate an implementation that looks for a function named by 1.497 + (str prefix mymethod) (default prefix: \"-\") in a 1.498 + Clojure namespace specified by :impl-ns 1.499 + (defaults to the current namespace). All inherited methods, 1.500 + generated methods, and init and main functions (see :methods, :init, 1.501 + and :main below) will be found similarly prefixed. By default, the 1.502 + static initializer for the generated class will attempt to load the 1.503 + Clojure support code for the class as a resource from the classpath, 1.504 + e.g. in the example case, ``org/mydomain/MyClass__init.class``. This 1.505 + behavior can be controlled by :load-impl-ns 1.506 + 1.507 + Note that methods with a maximum of 18 parameters are supported. 1.508 + 1.509 + In all subsequent sections taking types, the primitive types can be 1.510 + referred to by their Java names (int, float etc), and classes in the 1.511 + java.lang package can be used without a package qualifier. All other 1.512 + classes must be fully qualified. 1.513 + 1.514 + Options should be a set of key/value pairs, all except for :name are optional: 1.515 + 1.516 + :name aname 1.517 + 1.518 + The package-qualified name of the class to be generated 1.519 + 1.520 + :extends aclass 1.521 + 1.522 + Specifies the superclass, the non-private methods of which will be 1.523 + overridden by the class. If not provided, defaults to Object. 1.524 + 1.525 + :implements [interface ...] 1.526 + 1.527 + One or more interfaces, the methods of which will be implemented by the class. 1.528 + 1.529 + :init name 1.530 + 1.531 + If supplied, names a function that will be called with the arguments 1.532 + to the constructor. Must return [ [superclass-constructor-args] state] 1.533 + If not supplied, the constructor args are passed directly to 1.534 + the superclass constructor and the state will be nil 1.535 + 1.536 + :constructors {[param-types] [super-param-types], ...} 1.537 + 1.538 + By default, constructors are created for the generated class which 1.539 + match the signature(s) of the constructors for the superclass. This 1.540 + parameter may be used to explicitly specify constructors, each entry 1.541 + providing a mapping from a constructor signature to a superclass 1.542 + constructor signature. When you supply this, you must supply an :init 1.543 + specifier. 1.544 + 1.545 + :post-init name 1.546 + 1.547 + If supplied, names a function that will be called with the object as 1.548 + the first argument, followed by the arguments to the constructor. 1.549 + It will be called every time an object of this class is created, 1.550 + immediately after all the inherited constructors have completed. 1.551 + It's return value is ignored. 1.552 + 1.553 + :methods [ [name [param-types] return-type], ...] 1.554 + 1.555 + The generated class automatically defines all of the non-private 1.556 + methods of its superclasses/interfaces. This parameter can be used 1.557 + to specify the signatures of additional methods of the generated 1.558 + class. Static methods can be specified with ^{:static true} in the 1.559 + signature's metadata. Do not repeat superclass/interface signatures 1.560 + here. 1.561 + 1.562 + :main boolean 1.563 + 1.564 + If supplied and true, a static public main function will be generated. It will 1.565 + pass each string of the String[] argument as a separate argument to 1.566 + a function called (str prefix main). 1.567 + 1.568 + :factory name 1.569 + 1.570 + If supplied, a (set of) public static factory function(s) will be 1.571 + created with the given name, and the same signature(s) as the 1.572 + constructor(s). 1.573 + 1.574 + :state name 1.575 + 1.576 + If supplied, a public final instance field with the given name will be 1.577 + created. You must supply an :init function in order to provide a 1.578 + value for the state. Note that, though final, the state can be a ref 1.579 + or agent, supporting the creation of Java objects with transactional 1.580 + or asynchronous mutation semantics. 1.581 + 1.582 + :exposes {protected-field-name {:get name :set name}, ...} 1.583 + 1.584 + Since the implementations of the methods of the generated class 1.585 + occur in Clojure functions, they have no access to the inherited 1.586 + protected fields of the superclass. This parameter can be used to 1.587 + generate public getter/setter methods exposing the protected field(s) 1.588 + for use in the implementation. 1.589 + 1.590 + :exposes-methods {super-method-name exposed-name, ...} 1.591 + 1.592 + It is sometimes necessary to call the superclass' implementation of an 1.593 + overridden method. Those methods may be exposed and referred in 1.594 + the new method implementation by a local name. 1.595 + 1.596 + :prefix string 1.597 + 1.598 + Default: \"-\" Methods called e.g. Foo will be looked up in vars called 1.599 + prefixFoo in the implementing ns. 1.600 + 1.601 + :impl-ns name 1.602 + 1.603 + Default: the name of the current ns. Implementations of methods will be 1.604 + looked up in this namespace. 1.605 + 1.606 + :load-impl-ns boolean 1.607 + 1.608 + Default: true. Causes the static initializer for the generated class 1.609 + to reference the load code for the implementing namespace. Should be 1.610 + true when implementing-ns is the default, false if you intend to 1.611 + load the code via some other method." 1.612 + {:added "1.0"} 1.613 + 1.614 + [& options] 1.615 + (when *compile-files* 1.616 + (let [options-map (into {} (map vec (partition 2 options))) 1.617 + [cname bytecode] (generate-class options-map)] 1.618 + (clojure.lang.Compiler/writeClassFile cname bytecode)))) 1.619 + 1.620 +;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;; 1.621 +;; based on original contribution by Chris Houser 1.622 + 1.623 +(defn- ^Type asm-type 1.624 + "Returns an asm Type object for c, which may be a primitive class 1.625 + (such as Integer/TYPE), any other class (such as Double), or a 1.626 + fully-qualified class name given as a string or symbol 1.627 + (such as 'java.lang.String)" 1.628 + [c] 1.629 + (if (or (instance? Class c) (prim->class c)) 1.630 + (Type/getType (the-class c)) 1.631 + (let [strx (str c)] 1.632 + (Type/getObjectType 1.633 + (.replace (if (some #{\.} strx) 1.634 + strx 1.635 + (str "java.lang." strx)) 1.636 + "." "/"))))) 1.637 + 1.638 +(defn- generate-interface 1.639 + [{:keys [name extends methods]}] 1.640 + (let [iname (.replace (str name) "." "/") 1.641 + cv (ClassWriter. ClassWriter/COMPUTE_MAXS)] 1.642 + (. cv visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC 1.643 + Opcodes/ACC_ABSTRACT 1.644 + Opcodes/ACC_INTERFACE) 1.645 + iname nil "java/lang/Object" 1.646 + (when (seq extends) 1.647 + (into-array (map #(.getInternalName (asm-type %)) extends)))) 1.648 + (add-annotations cv (meta name)) 1.649 + (doseq [[mname pclasses rclass pmetas] methods] 1.650 + (let [mv (. cv visitMethod (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) 1.651 + (str mname) 1.652 + (Type/getMethodDescriptor (asm-type rclass) 1.653 + (if pclasses 1.654 + (into-array Type (map asm-type pclasses)) 1.655 + (make-array Type 0))) 1.656 + nil nil)] 1.657 + (add-annotations mv (meta mname)) 1.658 + (dotimes [i (count pmetas)] 1.659 + (add-annotations mv (nth pmetas i) i)) 1.660 + (. mv visitEnd))) 1.661 + (. cv visitEnd) 1.662 + [iname (. cv toByteArray)])) 1.663 + 1.664 +(defmacro gen-interface 1.665 + "When compiling, generates compiled bytecode for an interface with 1.666 + the given package-qualified :name (which, as all names in these 1.667 + parameters, can be a string or symbol), and writes the .class file 1.668 + to the *compile-path* directory. When not compiling, does nothing. 1.669 + 1.670 + In all subsequent sections taking types, the primitive types can be 1.671 + referred to by their Java names (int, float etc), and classes in the 1.672 + java.lang package can be used without a package qualifier. All other 1.673 + classes must be fully qualified. 1.674 + 1.675 + Options should be a set of key/value pairs, all except for :name are 1.676 + optional: 1.677 + 1.678 + :name aname 1.679 + 1.680 + The package-qualified name of the class to be generated 1.681 + 1.682 + :extends [interface ...] 1.683 + 1.684 + One or more interfaces, which will be extended by this interface. 1.685 + 1.686 + :methods [ [name [param-types] return-type], ...] 1.687 + 1.688 + This parameter is used to specify the signatures of the methods of 1.689 + the generated interface. Do not repeat superinterface signatures 1.690 + here." 1.691 + {:added "1.0"} 1.692 + 1.693 + [& options] 1.694 + (let [options-map (apply hash-map options) 1.695 + [cname bytecode] (generate-interface options-map)] 1.696 + (if *compile-files* 1.697 + (clojure.lang.Compiler/writeClassFile cname bytecode) 1.698 + (.defineClass ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) 1.699 + (str (:name options-map)) bytecode options)))) 1.700 + 1.701 +(comment 1.702 + 1.703 +(defn gen-and-load-class 1.704 + "Generates and immediately loads the bytecode for the specified 1.705 + class. Note that a class generated this way can be loaded only once 1.706 + - the JVM supports only one class with a given name per 1.707 + classloader. Subsequent to generation you can import it into any 1.708 + desired namespaces just like any other class. See gen-class for a 1.709 + description of the options." 1.710 + {:added "1.0"} 1.711 + 1.712 + [& options] 1.713 + (let [options-map (apply hash-map options) 1.714 + [cname bytecode] (generate-class options-map)] 1.715 + (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode options)))) 1.716 + 1.717 +)