rlm@10: ;   Copyright (c) Rich Hickey. All rights reserved.
rlm@10: ;   The use and distribution terms for this software are covered by the
rlm@10: ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
rlm@10: ;   which can be found in the file epl-v10.html at the root of this distribution.
rlm@10: ;   By using this software in any fashion, you are agreeing to be bound by
rlm@10: ;   the terms of this license.
rlm@10: ;   You must not remove this notice, or any other, from this software.
rlm@10: 
rlm@10: (in-ns 'clojure.core)
rlm@10: 
rlm@10: (import '(java.lang.reflect Modifier Constructor)
rlm@10:         '(clojure.asm ClassWriter ClassVisitor Opcodes Type)
rlm@10:         '(clojure.asm.commons Method GeneratorAdapter)
rlm@10:         '(clojure.lang IPersistentMap))
rlm@10: 
rlm@10: ;(defn method-sig [^java.lang.reflect.Method meth]
rlm@10: ;  [(. meth (getName)) (seq (. meth (getParameterTypes)))])
rlm@10: 
rlm@10: (defn- non-private-methods [^Class c]
rlm@10:   (loop [mm {}
rlm@10:          considered #{}
rlm@10:          c c]
rlm@10:     (if c
rlm@10:       (let [[mm considered]
rlm@10:             (loop [mm mm
rlm@10:                    considered considered
rlm@10:                    meths (seq (concat
rlm@10:                                 (seq (. c (getDeclaredMethods)))
rlm@10:                                 (seq (. c (getMethods)))))]
rlm@10:               (if meths
rlm@10:                 (let [^java.lang.reflect.Method meth (first meths)
rlm@10:                       mods (. meth (getModifiers))
rlm@10:                       mk (method-sig meth)]
rlm@10:                   (if (or (considered mk)
rlm@10:                           (not (or (Modifier/isPublic mods) (Modifier/isProtected mods)))
rlm@10:                           ;(. Modifier (isPrivate mods))
rlm@10:                           (. Modifier (isStatic mods))
rlm@10:                           (. Modifier (isFinal mods))
rlm@10:                           (= "finalize" (.getName meth)))
rlm@10:                     (recur mm (conj considered mk) (next meths))
rlm@10:                     (recur (assoc mm mk meth) (conj considered mk) (next meths))))
rlm@10:                 [mm considered]))]
rlm@10:         (recur mm considered (. c (getSuperclass))))
rlm@10:       mm)))
rlm@10: 
rlm@10: (defn- ctor-sigs [^Class super]
rlm@10:   (for [^Constructor ctor (. super (getDeclaredConstructors))
rlm@10:         :when (not (. Modifier (isPrivate (. ctor (getModifiers)))))]
rlm@10:     (apply vector (. ctor (getParameterTypes)))))
rlm@10: 
rlm@10: (defn- escape-class-name [^Class c]
rlm@10:   (.. (.getSimpleName c) 
rlm@10:       (replace "[]" "<>")))
rlm@10: 
rlm@10: (defn- overload-name [mname pclasses]
rlm@10:   (if (seq pclasses)
rlm@10:     (apply str mname (interleave (repeat \-) 
rlm@10:                                  (map escape-class-name pclasses)))
rlm@10:     (str mname "-void")))
rlm@10: 
rlm@10: (defn- ^java.lang.reflect.Field find-field [^Class c f]
rlm@10:   (let [start-class c]
rlm@10:     (loop [c c]
rlm@10:       (if (= c Object)
rlm@10:         (throw (new Exception (str "field, " f ", not defined in class, " start-class ", or its ancestors")))
rlm@10:         (let [dflds (.getDeclaredFields c)
rlm@10:               rfld (first (filter #(= f (.getName ^java.lang.reflect.Field %)) dflds))]
rlm@10:           (or rfld (recur (.getSuperclass c))))))))
rlm@10: 
rlm@10: ;(distinct (map first(keys (mapcat non-private-methods [Object IPersistentMap]))))
rlm@10: 
rlm@10: (def ^{:private true} prim->class
rlm@10:      {'int Integer/TYPE
rlm@10:       'long Long/TYPE
rlm@10:       'float Float/TYPE
rlm@10:       'double Double/TYPE
rlm@10:       'void Void/TYPE
rlm@10:       'short Short/TYPE
rlm@10:       'boolean Boolean/TYPE
rlm@10:       'byte Byte/TYPE
rlm@10:       'char Character/TYPE})
rlm@10: 
rlm@10: (defn- ^Class the-class [x] 
rlm@10:   (cond 
rlm@10:    (class? x) x
rlm@10:    (contains? prim->class x) (prim->class x)
rlm@10:    :else (let [strx (str x)]
rlm@10:            (clojure.lang.RT/classForName 
rlm@10:             (if (some #{\. \[} strx)
rlm@10:               strx
rlm@10:               (str "java.lang." strx))))))
rlm@10: 
rlm@10: ;; someday this can be made codepoint aware
rlm@10: (defn- valid-java-method-name
rlm@10:   [^String s]
rlm@10:   (= s (clojure.lang.Compiler/munge s)))
rlm@10: 
rlm@10: (defn- validate-generate-class-options
rlm@10:   [{:keys [methods]}]
rlm@10:   (let [[mname] (remove valid-java-method-name (map (comp str first) methods))]
rlm@10:     (when mname (throw (IllegalArgumentException. (str "Not a valid method name: " mname))))))
rlm@10: 
rlm@10: (defn- generate-class [options-map]
rlm@10:   (validate-generate-class-options options-map)
rlm@10:   (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)}
rlm@10:         {:keys [name extends implements constructors methods main factory state init exposes 
rlm@10:                 exposes-methods prefix load-impl-ns impl-ns post-init]} 
rlm@10:           (merge default-options options-map)
rlm@10:         name-meta (meta name)
rlm@10:         name (str name)
rlm@10:         super (if extends (the-class extends) Object)
rlm@10:         interfaces (map the-class implements)
rlm@10:         supers (cons super interfaces)
rlm@10:         ctor-sig-map (or constructors (zipmap (ctor-sigs super) (ctor-sigs super)))
rlm@10:         cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
rlm@10:         cname (. name (replace "." "/"))
rlm@10:         pkg-name name
rlm@10:         impl-pkg-name (str impl-ns)
rlm@10:         impl-cname (.. impl-pkg-name (replace "." "/") (replace \- \_))
rlm@10:         ctype (. Type (getObjectType cname))
rlm@10:         iname (fn [^Class c] (.. Type (getType c) (getInternalName)))
rlm@10:         totype (fn [^Class c] (. Type (getType c)))
rlm@10:         to-types (fn [cs] (if (pos? (count cs))
rlm@10:                             (into-array (map totype cs))
rlm@10:                             (make-array Type 0)))
rlm@10:         obj-type ^Type (totype Object)
rlm@10:         arg-types (fn [n] (if (pos? n)
rlm@10:                             (into-array (replicate n obj-type))
rlm@10:                             (make-array Type 0)))
rlm@10:         super-type ^Type (totype super)
rlm@10:         init-name (str init)
rlm@10:         post-init-name (str post-init)
rlm@10:         factory-name (str factory)
rlm@10:         state-name (str state)
rlm@10:         main-name "main"
rlm@10:         var-name (fn [s] (clojure.lang.Compiler/munge (str s "__var")))
rlm@10:         class-type  (totype Class)
rlm@10:         rt-type  (totype clojure.lang.RT)
rlm@10:         var-type ^Type (totype clojure.lang.Var)
rlm@10:         ifn-type (totype clojure.lang.IFn)
rlm@10:         iseq-type (totype clojure.lang.ISeq)
rlm@10:         ex-type  (totype java.lang.UnsupportedOperationException)
rlm@10:         all-sigs (distinct (concat (map #(let[[m p] (key %)] {m [p]}) (mapcat non-private-methods supers))
rlm@10:                                    (map (fn [[m p]] {(str m) [p]}) methods)))
rlm@10:         sigs-by-name (apply merge-with concat {} all-sigs)
rlm@10:         overloads (into {} (filter (fn [[m s]] (next s)) sigs-by-name))
rlm@10:         var-fields (concat (when init [init-name]) 
rlm@10:                            (when post-init [post-init-name])
rlm@10:                            (when main [main-name])
rlm@10:                            ;(when exposes-methods (map str (vals exposes-methods)))
rlm@10:                            (distinct (concat (keys sigs-by-name)
rlm@10:                                              (mapcat (fn [[m s]] (map #(overload-name m (map the-class %)) s)) overloads)
rlm@10:                                              (mapcat (comp (partial map str) vals val) exposes))))
rlm@10:         emit-get-var (fn [^GeneratorAdapter gen v]
rlm@10:                        (let [false-label (. gen newLabel)
rlm@10:                              end-label (. gen newLabel)]
rlm@10:                          (. gen getStatic ctype (var-name v) var-type)
rlm@10:                          (. gen dup)
rlm@10:                          (. gen invokeVirtual var-type (. Method (getMethod "boolean isBound()")))
rlm@10:                          (. gen ifZCmp (. GeneratorAdapter EQ) false-label)
rlm@10:                          (. gen invokeVirtual var-type (. Method (getMethod "Object get()")))
rlm@10:                          (. gen goTo end-label)
rlm@10:                          (. gen mark false-label)
rlm@10:                          (. gen pop)
rlm@10:                          (. gen visitInsn (. Opcodes ACONST_NULL))
rlm@10:                          (. gen mark end-label)))
rlm@10:         emit-unsupported (fn [^GeneratorAdapter gen ^Method m]
rlm@10:                            (. gen (throwException ex-type (str (. m (getName)) " ("
rlm@10:                                                                impl-pkg-name "/" prefix (.getName m)
rlm@10:                                                                " not defined?)"))))
rlm@10:         emit-forwarding-method
rlm@10:         (fn [name pclasses rclass as-static else-gen]
rlm@10:           (let [mname (str name)
rlm@10:                 pmetas (map meta pclasses)
rlm@10:                 pclasses (map the-class pclasses)
rlm@10:                 rclass (the-class rclass)
rlm@10:                 ptypes (to-types pclasses)
rlm@10:                 rtype ^Type (totype rclass)
rlm@10:                 m (new Method mname rtype ptypes)
rlm@10:                 is-overload (seq (overloads mname))
rlm@10:                 gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (if as-static (. Opcodes ACC_STATIC) 0)) 
rlm@10:                          m nil nil cv)
rlm@10:                 found-label (. gen (newLabel))
rlm@10:                 else-label (. gen (newLabel))
rlm@10:                 end-label (. gen (newLabel))]
rlm@10:             (add-annotations gen (meta name))
rlm@10:             (dotimes [i (count pmetas)]
rlm@10:               (add-annotations gen (nth pmetas i) i))
rlm@10:             (. gen (visitCode))
rlm@10:             (if (> (count pclasses) 18)
rlm@10:               (else-gen gen m)
rlm@10:               (do
rlm@10:                 (when is-overload
rlm@10:                   (emit-get-var gen (overload-name mname pclasses))
rlm@10:                   (. gen (dup))
rlm@10:                   (. gen (ifNonNull found-label))
rlm@10:                   (. gen (pop)))
rlm@10:                 (emit-get-var gen mname)
rlm@10:                 (. gen (dup))
rlm@10:                 (. gen (ifNull else-label))
rlm@10:                 (when is-overload
rlm@10:                   (. gen (mark found-label)))
rlm@10:                                         ;if found
rlm@10:                 (.checkCast gen ifn-type)
rlm@10:                 (when-not as-static
rlm@10:                   (. gen (loadThis)))
rlm@10:                                         ;box args
rlm@10:                 (dotimes [i (count ptypes)]
rlm@10:                   (. gen (loadArg i))
rlm@10:                   (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
rlm@10:                                         ;call fn
rlm@10:                 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 
rlm@10:                                                       (to-types (replicate (+ (count ptypes)
rlm@10:                                                                               (if as-static 0 1)) 
rlm@10:                                                                            Object)))))
rlm@10:                                         ;(into-array (cons obj-type 
rlm@10:                                         ;                 (replicate (count ptypes) obj-type))))))
rlm@10:                                         ;unbox return
rlm@10:                 (. gen (unbox rtype))
rlm@10:                 (when (= (. rtype (getSort)) (. Type VOID))
rlm@10:                   (. gen (pop)))
rlm@10:                 (. gen (goTo end-label))
rlm@10:                 
rlm@10:                                         ;else call supplied alternative generator
rlm@10:                 (. gen (mark else-label))
rlm@10:                 (. gen (pop))
rlm@10:                 
rlm@10:                 (else-gen gen m)
rlm@10:             
rlm@10:                 (. gen (mark end-label))))
rlm@10:             (. gen (returnValue))
rlm@10:             (. gen (endMethod))))
rlm@10:         ]
rlm@10:                                         ;start class definition
rlm@10:     (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
rlm@10:                  cname nil (iname super)
rlm@10:                  (when-let [ifc (seq interfaces)]
rlm@10:                    (into-array (map iname ifc)))))
rlm@10: 
rlm@10:                                         ; class annotations
rlm@10:     (add-annotations cv name-meta)
rlm@10:     
rlm@10:                                         ;static fields for vars
rlm@10:     (doseq [v var-fields]
rlm@10:       (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_FINAL) (. Opcodes ACC_STATIC))
rlm@10:                         (var-name v) 
rlm@10:                         (. var-type getDescriptor)
rlm@10:                         nil nil)))
rlm@10:     
rlm@10:                                         ;instance field for state
rlm@10:     (when state
rlm@10:       (. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL))
rlm@10:                         state-name 
rlm@10:                         (. obj-type getDescriptor)
rlm@10:                         nil nil)))
rlm@10:     
rlm@10:                                         ;static init to set up var fields and load init
rlm@10:     (let [gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 
rlm@10:                    (. Method getMethod "void <clinit> ()")
rlm@10:                    nil nil cv)]
rlm@10:       (. gen (visitCode))
rlm@10:       (doseq [v var-fields]
rlm@10:         (. gen push impl-pkg-name)
rlm@10:         (. gen push (str prefix v))
rlm@10:         (. gen (invokeStatic var-type (. Method (getMethod "clojure.lang.Var internPrivate(String,String)"))))
rlm@10:         (. gen putStatic ctype (var-name v) var-type))
rlm@10:       
rlm@10:       (when load-impl-ns
rlm@10:         (. gen push "clojure.core")
rlm@10:         (. gen push "load")
rlm@10:         (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.Var var(String,String)"))))
rlm@10:         (. gen push (str "/" impl-cname))
rlm@10:         (. gen (invokeInterface ifn-type (new Method "invoke" obj-type (to-types [Object]))))
rlm@10: ;        (. gen push (str (.replace impl-pkg-name \- \_) "__init"))
rlm@10: ;        (. gen (invokeStatic class-type (. Method (getMethod "Class forName(String)"))))
rlm@10:         (. gen pop))
rlm@10: 
rlm@10:       (. gen (returnValue))
rlm@10:       (. gen (endMethod)))
rlm@10:     
rlm@10:                                         ;ctors
rlm@10:     (doseq [[pclasses super-pclasses] ctor-sig-map]
rlm@10:       (let [pclasses (map the-class pclasses)
rlm@10:             super-pclasses (map the-class super-pclasses)
rlm@10:             ptypes (to-types pclasses)
rlm@10:             super-ptypes (to-types super-pclasses)
rlm@10:             m (new Method "<init>" (. Type VOID_TYPE) ptypes)
rlm@10:             super-m (new Method "<init>" (. Type VOID_TYPE) super-ptypes)
rlm@10:             gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
rlm@10:             no-init-label (. gen newLabel)
rlm@10:             end-label (. gen newLabel)
rlm@10:             no-post-init-label (. gen newLabel)
rlm@10:             end-post-init-label (. gen newLabel)
rlm@10:             nth-method (. Method (getMethod "Object nth(Object,int)"))
rlm@10:             local (. gen newLocal obj-type)]
rlm@10:         (. gen (visitCode))
rlm@10:         
rlm@10:         (if init
rlm@10:           (do
rlm@10:             (emit-get-var gen init-name)
rlm@10:             (. gen dup)
rlm@10:             (. gen ifNull no-init-label)
rlm@10:             (.checkCast gen ifn-type)
rlm@10:                                         ;box init args
rlm@10:             (dotimes [i (count pclasses)]
rlm@10:               (. gen (loadArg i))
rlm@10:               (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
rlm@10:                                         ;call init fn
rlm@10:             (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 
rlm@10:                                                   (arg-types (count ptypes)))))
rlm@10:                                         ;expecting [[super-ctor-args] state] returned
rlm@10:             (. gen dup)
rlm@10:             (. gen push 0)
rlm@10:             (. gen (invokeStatic rt-type nth-method))
rlm@10:             (. gen storeLocal local)
rlm@10:             
rlm@10:             (. gen (loadThis))
rlm@10:             (. gen dupX1)
rlm@10:             (dotimes [i (count super-pclasses)]
rlm@10:               (. gen loadLocal local)
rlm@10:               (. gen push i)
rlm@10:               (. gen (invokeStatic rt-type nth-method))
rlm@10:               (. clojure.lang.Compiler$HostExpr (emitUnboxArg nil gen (nth super-pclasses i))))
rlm@10:             (. gen (invokeConstructor super-type super-m))
rlm@10:             
rlm@10:             (if state
rlm@10:               (do
rlm@10:                 (. gen push 1)
rlm@10:                 (. gen (invokeStatic rt-type nth-method))
rlm@10:                 (. gen (putField ctype state-name obj-type)))
rlm@10:               (. gen pop))
rlm@10:             
rlm@10:             (. gen goTo end-label)
rlm@10:                                         ;no init found
rlm@10:             (. gen mark no-init-label)
rlm@10:             (. gen (throwException ex-type (str impl-pkg-name "/" prefix init-name " not defined")))
rlm@10:             (. gen mark end-label))
rlm@10:           (if (= pclasses super-pclasses)
rlm@10:             (do
rlm@10:               (. gen (loadThis))
rlm@10:               (. gen (loadArgs))
rlm@10:               (. gen (invokeConstructor super-type super-m)))
rlm@10:             (throw (new Exception ":init not specified, but ctor and super ctor args differ"))))
rlm@10: 
rlm@10:         (when post-init
rlm@10:           (emit-get-var gen post-init-name)
rlm@10:           (. gen dup)
rlm@10:           (. gen ifNull no-post-init-label)
rlm@10:           (.checkCast gen ifn-type)
rlm@10:           (. gen (loadThis))
rlm@10:                                        ;box init args
rlm@10:           (dotimes [i (count pclasses)]
rlm@10:             (. gen (loadArg i))
rlm@10:             (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
rlm@10:                                        ;call init fn
rlm@10:           (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 
rlm@10:                                                 (arg-types (inc (count ptypes))))))
rlm@10:           (. gen pop)
rlm@10:           (. gen goTo end-post-init-label)
rlm@10:                                        ;no init found
rlm@10:           (. gen mark no-post-init-label)
rlm@10:           (. gen (throwException ex-type (str impl-pkg-name "/" prefix post-init-name " not defined")))
rlm@10:           (. gen mark end-post-init-label))
rlm@10: 
rlm@10:         (. gen (returnValue))
rlm@10:         (. gen (endMethod))
rlm@10:                                         ;factory
rlm@10:         (when factory
rlm@10:           (let [fm (new Method factory-name ctype ptypes)
rlm@10:                 gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 
rlm@10:                          fm nil nil cv)]
rlm@10:             (. gen (visitCode))
rlm@10:             (. gen newInstance ctype)
rlm@10:             (. gen dup)
rlm@10:             (. gen (loadArgs))
rlm@10:             (. gen (invokeConstructor ctype m))            
rlm@10:             (. gen (returnValue))
rlm@10:             (. gen (endMethod))))))
rlm@10:     
rlm@10:                                         ;add methods matching supers', if no fn -> call super
rlm@10:     (let [mm (non-private-methods super)]
rlm@10:       (doseq [^java.lang.reflect.Method meth (vals mm)]
rlm@10:              (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false
rlm@10:                                      (fn [^GeneratorAdapter gen ^Method m]
rlm@10:                                        (. gen (loadThis))
rlm@10:                                         ;push args
rlm@10:                                        (. gen (loadArgs))
rlm@10:                                         ;call super
rlm@10:                                        (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 
rlm@10:                                                                (. super-type (getInternalName))
rlm@10:                                                                (. m (getName))
rlm@10:                                                                (. m (getDescriptor)))))))
rlm@10:                                         ;add methods matching interfaces', if no fn -> throw
rlm@10:       (reduce (fn [mm ^java.lang.reflect.Method meth]
rlm@10:                 (if (contains? mm (method-sig meth))
rlm@10:                   mm
rlm@10:                   (do
rlm@10:                     (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false
rlm@10:                                             emit-unsupported)
rlm@10:                     (assoc mm (method-sig meth) meth))))
rlm@10:               mm (mapcat #(.getMethods ^Class %) interfaces))
rlm@10:                                         ;extra methods
rlm@10:        (doseq [[mname pclasses rclass :as msig] methods]
rlm@10:          (emit-forwarding-method mname pclasses rclass (:static (meta msig))
rlm@10:                                  emit-unsupported))
rlm@10:                                         ;expose specified overridden superclass methods
rlm@10:        (doseq [[local-mname ^java.lang.reflect.Method m] (reduce (fn [ms [[name _ _] m]]
rlm@10:                               (if (contains? exposes-methods (symbol name))
rlm@10:                                 (conj ms [((symbol name) exposes-methods) m])
rlm@10:                                 ms)) [] (seq mm))]
rlm@10:          (let [ptypes (to-types (.getParameterTypes m))
rlm@10:                rtype (totype (.getReturnType m))
rlm@10:                exposer-m (new Method (str local-mname) rtype ptypes)
rlm@10:                target-m (new Method (.getName m) rtype ptypes)
rlm@10:                gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) exposer-m nil nil cv)]
rlm@10:            (. gen (loadThis))
rlm@10:            (. gen (loadArgs))
rlm@10:            (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 
rlm@10:                                    (. super-type (getInternalName))
rlm@10:                                    (. target-m (getName))
rlm@10:                                    (. target-m (getDescriptor))))
rlm@10:            (. gen (returnValue))
rlm@10:            (. gen (endMethod)))))
rlm@10:                                         ;main
rlm@10:     (when main
rlm@10:       (let [m (. Method getMethod "void main (String[])")
rlm@10:             gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 
rlm@10:                      m nil nil cv)
rlm@10:             no-main-label (. gen newLabel)
rlm@10:             end-label (. gen newLabel)]
rlm@10:         (. gen (visitCode))
rlm@10: 
rlm@10:         (emit-get-var gen main-name)
rlm@10:         (. gen dup)
rlm@10:         (. gen ifNull no-main-label)
rlm@10:         (.checkCast gen ifn-type)
rlm@10:         (. gen loadArgs)
rlm@10:         (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.ISeq seq(Object)"))))
rlm@10:         (. gen (invokeInterface ifn-type (new Method "applyTo" obj-type 
rlm@10:                                               (into-array [iseq-type]))))
rlm@10:         (. gen pop)
rlm@10:         (. gen goTo end-label)
rlm@10:                                         ;no main found
rlm@10:         (. gen mark no-main-label)
rlm@10:         (. gen (throwException ex-type (str impl-pkg-name "/" prefix main-name " not defined")))
rlm@10:         (. gen mark end-label)
rlm@10:         (. gen (returnValue))
rlm@10:         (. gen (endMethod))))
rlm@10:                                         ;field exposers
rlm@10:     (doseq [[f {getter :get setter :set}] exposes]
rlm@10:       (let [fld (find-field super (str f))
rlm@10:             ftype (totype (.getType fld))
rlm@10:             static? (Modifier/isStatic (.getModifiers fld))
rlm@10:             acc (+ Opcodes/ACC_PUBLIC (if static? Opcodes/ACC_STATIC 0))]
rlm@10:         (when getter
rlm@10:           (let [m (new Method (str getter) ftype (to-types []))
rlm@10:                 gen (new GeneratorAdapter acc m nil nil cv)]
rlm@10:             (. gen (visitCode))
rlm@10:             (if static?
rlm@10:               (. gen getStatic ctype (str f) ftype)
rlm@10:               (do
rlm@10:                 (. gen loadThis)
rlm@10:                 (. gen getField ctype (str f) ftype)))
rlm@10:             (. gen (returnValue))
rlm@10:             (. gen (endMethod))))
rlm@10:         (when setter
rlm@10:           (let [m (new Method (str setter) Type/VOID_TYPE (into-array [ftype]))
rlm@10:                 gen (new GeneratorAdapter acc m nil nil cv)]
rlm@10:             (. gen (visitCode))
rlm@10:             (if static?
rlm@10:               (do
rlm@10:                 (. gen loadArgs)
rlm@10:                 (. gen putStatic ctype (str f) ftype))
rlm@10:               (do
rlm@10:                 (. gen loadThis)
rlm@10:                 (. gen loadArgs)
rlm@10:                 (. gen putField ctype (str f) ftype)))
rlm@10:             (. gen (returnValue))
rlm@10:             (. gen (endMethod))))))
rlm@10:                                         ;finish class def
rlm@10:     (. cv (visitEnd))
rlm@10:     [cname (. cv (toByteArray))]))
rlm@10: 
rlm@10: (defmacro gen-class 
rlm@10:   "When compiling, generates compiled bytecode for a class with the
rlm@10:   given package-qualified :name (which, as all names in these
rlm@10:   parameters, can be a string or symbol), and writes the .class file
rlm@10:   to the *compile-path* directory.  When not compiling, does
rlm@10:   nothing. The gen-class construct contains no implementation, as the
rlm@10:   implementation will be dynamically sought by the generated class in
rlm@10:   functions in an implementing Clojure namespace. Given a generated
rlm@10:   class org.mydomain.MyClass with a method named mymethod, gen-class
rlm@10:   will generate an implementation that looks for a function named by 
rlm@10:   (str prefix mymethod) (default prefix: \"-\") in a
rlm@10:   Clojure namespace specified by :impl-ns
rlm@10:   (defaults to the current namespace). All inherited methods,
rlm@10:   generated methods, and init and main functions (see :methods, :init,
rlm@10:   and :main below) will be found similarly prefixed. By default, the
rlm@10:   static initializer for the generated class will attempt to load the
rlm@10:   Clojure support code for the class as a resource from the classpath,
rlm@10:   e.g. in the example case, ``org/mydomain/MyClass__init.class``. This
rlm@10:   behavior can be controlled by :load-impl-ns
rlm@10: 
rlm@10:   Note that methods with a maximum of 18 parameters are supported.
rlm@10: 
rlm@10:   In all subsequent sections taking types, the primitive types can be
rlm@10:   referred to by their Java names (int, float etc), and classes in the
rlm@10:   java.lang package can be used without a package qualifier. All other
rlm@10:   classes must be fully qualified.
rlm@10: 
rlm@10:   Options should be a set of key/value pairs, all except for :name are optional:
rlm@10: 
rlm@10:   :name aname
rlm@10: 
rlm@10:   The package-qualified name of the class to be generated
rlm@10: 
rlm@10:   :extends aclass
rlm@10: 
rlm@10:   Specifies the superclass, the non-private methods of which will be
rlm@10:   overridden by the class. If not provided, defaults to Object.
rlm@10: 
rlm@10:   :implements [interface ...]
rlm@10: 
rlm@10:   One or more interfaces, the methods of which will be implemented by the class.
rlm@10: 
rlm@10:   :init name
rlm@10: 
rlm@10:   If supplied, names a function that will be called with the arguments
rlm@10:   to the constructor. Must return [ [superclass-constructor-args] state] 
rlm@10:   If not supplied, the constructor args are passed directly to
rlm@10:   the superclass constructor and the state will be nil
rlm@10: 
rlm@10:   :constructors {[param-types] [super-param-types], ...}
rlm@10: 
rlm@10:   By default, constructors are created for the generated class which
rlm@10:   match the signature(s) of the constructors for the superclass. This
rlm@10:   parameter may be used to explicitly specify constructors, each entry
rlm@10:   providing a mapping from a constructor signature to a superclass
rlm@10:   constructor signature. When you supply this, you must supply an :init
rlm@10:   specifier. 
rlm@10: 
rlm@10:   :post-init name
rlm@10: 
rlm@10:   If supplied, names a function that will be called with the object as
rlm@10:   the first argument, followed by the arguments to the constructor.
rlm@10:   It will be called every time an object of this class is created,
rlm@10:   immediately after all the inherited constructors have completed.
rlm@10:   It's return value is ignored.
rlm@10: 
rlm@10:   :methods [ [name [param-types] return-type], ...]
rlm@10: 
rlm@10:   The generated class automatically defines all of the non-private
rlm@10:   methods of its superclasses/interfaces. This parameter can be used
rlm@10:   to specify the signatures of additional methods of the generated
rlm@10:   class. Static methods can be specified with ^{:static true} in the
rlm@10:   signature's metadata. Do not repeat superclass/interface signatures
rlm@10:   here.
rlm@10: 
rlm@10:   :main boolean
rlm@10: 
rlm@10:   If supplied and true, a static public main function will be generated. It will
rlm@10:   pass each string of the String[] argument as a separate argument to
rlm@10:   a function called (str prefix main).
rlm@10: 
rlm@10:   :factory name
rlm@10: 
rlm@10:   If supplied, a (set of) public static factory function(s) will be
rlm@10:   created with the given name, and the same signature(s) as the
rlm@10:   constructor(s).
rlm@10:   
rlm@10:   :state name
rlm@10: 
rlm@10:   If supplied, a public final instance field with the given name will be
rlm@10:   created. You must supply an :init function in order to provide a
rlm@10:   value for the state. Note that, though final, the state can be a ref
rlm@10:   or agent, supporting the creation of Java objects with transactional
rlm@10:   or asynchronous mutation semantics.
rlm@10: 
rlm@10:   :exposes {protected-field-name {:get name :set name}, ...}
rlm@10: 
rlm@10:   Since the implementations of the methods of the generated class
rlm@10:   occur in Clojure functions, they have no access to the inherited
rlm@10:   protected fields of the superclass. This parameter can be used to
rlm@10:   generate public getter/setter methods exposing the protected field(s)
rlm@10:   for use in the implementation.
rlm@10: 
rlm@10:   :exposes-methods {super-method-name exposed-name, ...}
rlm@10: 
rlm@10:   It is sometimes necessary to call the superclass' implementation of an
rlm@10:   overridden method.  Those methods may be exposed and referred in 
rlm@10:   the new method implementation by a local name.
rlm@10: 
rlm@10:   :prefix string
rlm@10: 
rlm@10:   Default: \"-\" Methods called e.g. Foo will be looked up in vars called
rlm@10:   prefixFoo in the implementing ns.
rlm@10: 
rlm@10:   :impl-ns name
rlm@10: 
rlm@10:   Default: the name of the current ns. Implementations of methods will be 
rlm@10:   looked up in this namespace.
rlm@10: 
rlm@10:   :load-impl-ns boolean
rlm@10: 
rlm@10:   Default: true. Causes the static initializer for the generated class
rlm@10:   to reference the load code for the implementing namespace. Should be
rlm@10:   true when implementing-ns is the default, false if you intend to
rlm@10:   load the code via some other method."
rlm@10:   {:added "1.0"}
rlm@10:   
rlm@10:   [& options]
rlm@10:     (when *compile-files*
rlm@10:       (let [options-map (into {} (map vec (partition 2 options)))
rlm@10:             [cname bytecode] (generate-class options-map)]
rlm@10:         (clojure.lang.Compiler/writeClassFile cname bytecode))))
rlm@10: 
rlm@10: ;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;;
rlm@10: ;; based on original contribution by Chris Houser
rlm@10: 
rlm@10: (defn- ^Type asm-type
rlm@10:   "Returns an asm Type object for c, which may be a primitive class
rlm@10:   (such as Integer/TYPE), any other class (such as Double), or a
rlm@10:   fully-qualified class name given as a string or symbol
rlm@10:   (such as 'java.lang.String)"
rlm@10:   [c]
rlm@10:   (if (or (instance? Class c) (prim->class c))
rlm@10:     (Type/getType (the-class c))
rlm@10:     (let [strx (str c)]
rlm@10:       (Type/getObjectType 
rlm@10:        (.replace (if (some #{\.} strx)
rlm@10:                    strx
rlm@10:                    (str "java.lang." strx)) 
rlm@10:                  "." "/")))))
rlm@10: 
rlm@10: (defn- generate-interface
rlm@10:   [{:keys [name extends methods]}]
rlm@10:   (let [iname (.replace (str name) "." "/")
rlm@10:         cv (ClassWriter. ClassWriter/COMPUTE_MAXS)]
rlm@10:     (. cv visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC 
rlm@10:                                 Opcodes/ACC_ABSTRACT
rlm@10:                                 Opcodes/ACC_INTERFACE)
rlm@10:        iname nil "java/lang/Object"
rlm@10:        (when (seq extends)
rlm@10:          (into-array (map #(.getInternalName (asm-type %)) extends))))
rlm@10:     (add-annotations cv (meta name))
rlm@10:     (doseq [[mname pclasses rclass pmetas] methods]
rlm@10:       (let [mv (. cv visitMethod (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
rlm@10:                   (str mname)
rlm@10:                   (Type/getMethodDescriptor (asm-type rclass) 
rlm@10:                                             (if pclasses
rlm@10:                                               (into-array Type (map asm-type pclasses))
rlm@10:                                               (make-array Type 0)))
rlm@10:                   nil nil)]
rlm@10:         (add-annotations mv (meta mname))
rlm@10:         (dotimes [i (count pmetas)]
rlm@10:           (add-annotations mv (nth pmetas i) i))
rlm@10:         (. mv visitEnd)))
rlm@10:     (. cv visitEnd)
rlm@10:     [iname (. cv toByteArray)]))
rlm@10: 
rlm@10: (defmacro gen-interface
rlm@10:   "When compiling, generates compiled bytecode for an interface with
rlm@10:   the given package-qualified :name (which, as all names in these
rlm@10:   parameters, can be a string or symbol), and writes the .class file
rlm@10:   to the *compile-path* directory.  When not compiling, does nothing.
rlm@10:  
rlm@10:   In all subsequent sections taking types, the primitive types can be
rlm@10:   referred to by their Java names (int, float etc), and classes in the
rlm@10:   java.lang package can be used without a package qualifier. All other
rlm@10:   classes must be fully qualified.
rlm@10:  
rlm@10:   Options should be a set of key/value pairs, all except for :name are
rlm@10:   optional:
rlm@10: 
rlm@10:   :name aname
rlm@10: 
rlm@10:   The package-qualified name of the class to be generated
rlm@10: 
rlm@10:   :extends [interface ...]
rlm@10: 
rlm@10:   One or more interfaces, which will be extended by this interface.
rlm@10: 
rlm@10:   :methods [ [name [param-types] return-type], ...]
rlm@10: 
rlm@10:   This parameter is used to specify the signatures of the methods of
rlm@10:   the generated interface.  Do not repeat superinterface signatures
rlm@10:   here."
rlm@10:   {:added "1.0"}
rlm@10: 
rlm@10:   [& options]
rlm@10:     (let [options-map (apply hash-map options)
rlm@10:           [cname bytecode] (generate-interface options-map)]
rlm@10:       (if *compile-files*
rlm@10:         (clojure.lang.Compiler/writeClassFile cname bytecode)
rlm@10:         (.defineClass ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) 
rlm@10:                       (str (:name options-map)) bytecode options)))) 
rlm@10: 
rlm@10: (comment
rlm@10: 
rlm@10: (defn gen-and-load-class 
rlm@10:   "Generates and immediately loads the bytecode for the specified
rlm@10:   class. Note that a class generated this way can be loaded only once
rlm@10:   - the JVM supports only one class with a given name per
rlm@10:   classloader. Subsequent to generation you can import it into any
rlm@10:   desired namespaces just like any other class. See gen-class for a
rlm@10:   description of the options."
rlm@10:   {:added "1.0"}
rlm@10: 
rlm@10:   [& options]
rlm@10:   (let [options-map (apply hash-map options)
rlm@10:         [cname bytecode] (generate-class options-map)]
rlm@10:     (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode options))))
rlm@10: 
rlm@10: )