annotate 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
rev   line source
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 )