Mercurial > lasercutter

     1 ;   Copyright (c) Rich Hickey. All rights reserved.

     2 ;   The use and distribution terms for this software are covered by the

     3 ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)

     4 ;   which can be found in the file epl-v10.html at the root of this distribution.

     5 ;   By using this software in any fashion, you are agreeing to be bound by

     6 ;   the terms of this license.

     7 ;   You must not remove this notice, or any other, from this software.

     8 

     9 (in-ns 'clojure.core)

    10 

    11 (import '(java.lang.reflect Modifier Constructor)

    12         '(clojure.asm ClassWriter ClassVisitor Opcodes Type)

    13         '(clojure.asm.commons Method GeneratorAdapter)

    14         '(clojure.lang IPersistentMap))

    15 

    16 ;(defn method-sig [^java.lang.reflect.Method meth]

    17 ;  [(. meth (getName)) (seq (. meth (getParameterTypes)))])

    18 

    19 (defn- non-private-methods [^Class c]

    20   (loop [mm {}

    21          considered #{}

    22          c c]

    23     (if c

    24       (let [[mm considered]

    25             (loop [mm mm

    26                    considered considered

    27                    meths (seq (concat

    28                                 (seq (. c (getDeclaredMethods)))

    29                                 (seq (. c (getMethods)))))]

    30               (if meths

    31                 (let [^java.lang.reflect.Method meth (first meths)

    32                       mods (. meth (getModifiers))

    33                       mk (method-sig meth)]

    34                   (if (or (considered mk)

    35                           (not (or (Modifier/isPublic mods) (Modifier/isProtected mods)))

    36                           ;(. Modifier (isPrivate mods))

    37                           (. Modifier (isStatic mods))

    38                           (. Modifier (isFinal mods))

    39                           (= "finalize" (.getName meth)))

    40                     (recur mm (conj considered mk) (next meths))

    41                     (recur (assoc mm mk meth) (conj considered mk) (next meths))))

    42                 [mm considered]))]

    43         (recur mm considered (. c (getSuperclass))))

    44       mm)))

    45 

    46 (defn- ctor-sigs [^Class super]

    47   (for [^Constructor ctor (. super (getDeclaredConstructors))

    48         :when (not (. Modifier (isPrivate (. ctor (getModifiers)))))]

    49     (apply vector (. ctor (getParameterTypes)))))

    50 

    51 (defn- escape-class-name [^Class c]

    52   (.. (.getSimpleName c) 

    53       (replace "[]" "<>")))

    54 

    55 (defn- overload-name [mname pclasses]

    56   (if (seq pclasses)

    57     (apply str mname (interleave (repeat \-) 

    58                                  (map escape-class-name pclasses)))

    59     (str mname "-void")))

    60 

    61 (defn- ^java.lang.reflect.Field find-field [^Class c f]

    62   (let [start-class c]

    63     (loop [c c]

    64       (if (= c Object)

    65         (throw (new Exception (str "field, " f ", not defined in class, " start-class ", or its ancestors")))

    66         (let [dflds (.getDeclaredFields c)

    67               rfld (first (filter #(= f (.getName ^java.lang.reflect.Field %)) dflds))]

    68           (or rfld (recur (.getSuperclass c))))))))

    69 

    70 ;(distinct (map first(keys (mapcat non-private-methods [Object IPersistentMap]))))

    71 

    72 (def ^{:private true} prim->class

    73      {'int Integer/TYPE

    74       'long Long/TYPE

    75       'float Float/TYPE

    76       'double Double/TYPE

    77       'void Void/TYPE

    78       'short Short/TYPE

    79       'boolean Boolean/TYPE

    80       'byte Byte/TYPE

    81       'char Character/TYPE})

    82 

    83 (defn- ^Class the-class [x] 

    84   (cond 

    85    (class? x) x

    86    (contains? prim->class x) (prim->class x)

    87    :else (let [strx (str x)]

    88            (clojure.lang.RT/classForName 

    89             (if (some #{\. \[} strx)

    90               strx

    91               (str "java.lang." strx))))))

    92 

    93 ;; someday this can be made codepoint aware

    94 (defn- valid-java-method-name

    95   [^String s]

    96   (= s (clojure.lang.Compiler/munge s)))

    97 

    98 (defn- validate-generate-class-options

    99   [{:keys [methods]}]

   100   (let [[mname] (remove valid-java-method-name (map (comp str first) methods))]

   101     (when mname (throw (IllegalArgumentException. (str "Not a valid method name: " mname))))))

   102 

   103 (defn- generate-class [options-map]

   104   (validate-generate-class-options options-map)

   105   (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)}

   106         {:keys [name extends implements constructors methods main factory state init exposes 

   107                 exposes-methods prefix load-impl-ns impl-ns post-init]} 

   108           (merge default-options options-map)

   109         name-meta (meta name)

   110         name (str name)

   111         super (if extends (the-class extends) Object)

   112         interfaces (map the-class implements)

   113         supers (cons super interfaces)

   114         ctor-sig-map (or constructors (zipmap (ctor-sigs super) (ctor-sigs super)))

   115         cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))

   116         cname (. name (replace "." "/"))

   117         pkg-name name

   118         impl-pkg-name (str impl-ns)

   119         impl-cname (.. impl-pkg-name (replace "." "/") (replace \- \_))

   120         ctype (. Type (getObjectType cname))

   121         iname (fn [^Class c] (.. Type (getType c) (getInternalName)))

   122         totype (fn [^Class c] (. Type (getType c)))

   123         to-types (fn [cs] (if (pos? (count cs))

   124                             (into-array (map totype cs))

   125                             (make-array Type 0)))

   126         obj-type ^Type (totype Object)

   127         arg-types (fn [n] (if (pos? n)

   128                             (into-array (replicate n obj-type))

   129                             (make-array Type 0)))

   130         super-type ^Type (totype super)

   131         init-name (str init)

   132         post-init-name (str post-init)

   133         factory-name (str factory)

   134         state-name (str state)

   135         main-name "main"

   136         var-name (fn [s] (clojure.lang.Compiler/munge (str s "__var")))

   137         class-type  (totype Class)

   138         rt-type  (totype clojure.lang.RT)

   139         var-type ^Type (totype clojure.lang.Var)

   140         ifn-type (totype clojure.lang.IFn)

   141         iseq-type (totype clojure.lang.ISeq)

   142         ex-type  (totype java.lang.UnsupportedOperationException)

   143         all-sigs (distinct (concat (map #(let[[m p] (key %)] {m [p]}) (mapcat non-private-methods supers))

   144                                    (map (fn [[m p]] {(str m) [p]}) methods)))

   145         sigs-by-name (apply merge-with concat {} all-sigs)

   146         overloads (into {} (filter (fn [[m s]] (next s)) sigs-by-name))

   147         var-fields (concat (when init [init-name]) 

   148                            (when post-init [post-init-name])

   149                            (when main [main-name])

   150                            ;(when exposes-methods (map str (vals exposes-methods)))

   151                            (distinct (concat (keys sigs-by-name)

   152                                              (mapcat (fn [[m s]] (map #(overload-name m (map the-class %)) s)) overloads)

   153                                              (mapcat (comp (partial map str) vals val) exposes))))

   154         emit-get-var (fn [^GeneratorAdapter gen v]

   155                        (let [false-label (. gen newLabel)

   156                              end-label (. gen newLabel)]

   157                          (. gen getStatic ctype (var-name v) var-type)

   158                          (. gen dup)

   159                          (. gen invokeVirtual var-type (. Method (getMethod "boolean isBound()")))

   160                          (. gen ifZCmp (. GeneratorAdapter EQ) false-label)

   161                          (. gen invokeVirtual var-type (. Method (getMethod "Object get()")))

   162                          (. gen goTo end-label)

   163                          (. gen mark false-label)

   164                          (. gen pop)

   165                          (. gen visitInsn (. Opcodes ACONST_NULL))

   166                          (. gen mark end-label)))

   167         emit-unsupported (fn [^GeneratorAdapter gen ^Method m]

   168                            (. gen (throwException ex-type (str (. m (getName)) " ("

   169                                                                impl-pkg-name "/" prefix (.getName m)

   170                                                                " not defined?)"))))

   171         emit-forwarding-method

   172         (fn [name pclasses rclass as-static else-gen]

   173           (let [mname (str name)

   174                 pmetas (map meta pclasses)

   175                 pclasses (map the-class pclasses)

   176                 rclass (the-class rclass)

   177                 ptypes (to-types pclasses)

   178                 rtype ^Type (totype rclass)

   179                 m (new Method mname rtype ptypes)

   180                 is-overload (seq (overloads mname))

   181                 gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (if as-static (. Opcodes ACC_STATIC) 0)) 

   182                          m nil nil cv)

   183                 found-label (. gen (newLabel))

   184                 else-label (. gen (newLabel))

   185                 end-label (. gen (newLabel))]

   186             (add-annotations gen (meta name))

   187             (dotimes [i (count pmetas)]

   188               (add-annotations gen (nth pmetas i) i))

   189             (. gen (visitCode))

   190             (if (> (count pclasses) 18)

   191               (else-gen gen m)

   192               (do

   193                 (when is-overload

   194                   (emit-get-var gen (overload-name mname pclasses))

   195                   (. gen (dup))

   196                   (. gen (ifNonNull found-label))

   197                   (. gen (pop)))

   198                 (emit-get-var gen mname)

   199                 (. gen (dup))

   200                 (. gen (ifNull else-label))

   201                 (when is-overload

   202                   (. gen (mark found-label)))

   203                                         ;if found

   204                 (.checkCast gen ifn-type)

   205                 (when-not as-static

   206                   (. gen (loadThis)))

   207                                         ;box args

   208                 (dotimes [i (count ptypes)]

   209                   (. gen (loadArg i))

   210                   (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))

   211                                         ;call fn

   212                 (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 

   213                                                       (to-types (replicate (+ (count ptypes)

   214                                                                               (if as-static 0 1)) 

   215                                                                            Object)))))

   216                                         ;(into-array (cons obj-type 

   217                                         ;                 (replicate (count ptypes) obj-type))))))

   218                                         ;unbox return

   219                 (. gen (unbox rtype))

   220                 (when (= (. rtype (getSort)) (. Type VOID))

   221                   (. gen (pop)))

   222                 (. gen (goTo end-label))

   223                 

   224                                         ;else call supplied alternative generator

   225                 (. gen (mark else-label))

   226                 (. gen (pop))

   227                 

   228                 (else-gen gen m)

   229             

   230                 (. gen (mark end-label))))

   231             (. gen (returnValue))

   232             (. gen (endMethod))))

   233         ]

   234                                         ;start class definition

   235     (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))

   236                  cname nil (iname super)

   237                  (when-let [ifc (seq interfaces)]

   238                    (into-array (map iname ifc)))))

   239 

   240                                         ; class annotations

   241     (add-annotations cv name-meta)

   242     

   243                                         ;static fields for vars

   244     (doseq [v var-fields]

   245       (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_FINAL) (. Opcodes ACC_STATIC))

   246                         (var-name v) 

   247                         (. var-type getDescriptor)

   248                         nil nil)))

   249     

   250                                         ;instance field for state

   251     (when state

   252       (. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL))

   253                         state-name 

   254                         (. obj-type getDescriptor)

   255                         nil nil)))

   256     

   257                                         ;static init to set up var fields and load init

   258     (let [gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 

   259                    (. Method getMethod "void <clinit> ()")

   260                    nil nil cv)]

   261       (. gen (visitCode))

   262       (doseq [v var-fields]

   263         (. gen push impl-pkg-name)

   264         (. gen push (str prefix v))

   265         (. gen (invokeStatic var-type (. Method (getMethod "clojure.lang.Var internPrivate(String,String)"))))

   266         (. gen putStatic ctype (var-name v) var-type))

   267       

   268       (when load-impl-ns

   269         (. gen push "clojure.core")

   270         (. gen push "load")

   271         (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.Var var(String,String)"))))

   272         (. gen push (str "/" impl-cname))

   273         (. gen (invokeInterface ifn-type (new Method "invoke" obj-type (to-types [Object]))))

   274 ;        (. gen push (str (.replace impl-pkg-name \- \_) "__init"))

   275 ;        (. gen (invokeStatic class-type (. Method (getMethod "Class forName(String)"))))

   276         (. gen pop))

   277 

   278       (. gen (returnValue))

   279       (. gen (endMethod)))

   280     

   281                                         ;ctors

   282     (doseq [[pclasses super-pclasses] ctor-sig-map]

   283       (let [pclasses (map the-class pclasses)

   284             super-pclasses (map the-class super-pclasses)

   285             ptypes (to-types pclasses)

   286             super-ptypes (to-types super-pclasses)

   287             m (new Method "<init>" (. Type VOID_TYPE) ptypes)

   288             super-m (new Method "<init>" (. Type VOID_TYPE) super-ptypes)

   289             gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)

   290             no-init-label (. gen newLabel)

   291             end-label (. gen newLabel)

   292             no-post-init-label (. gen newLabel)

   293             end-post-init-label (. gen newLabel)

   294             nth-method (. Method (getMethod "Object nth(Object,int)"))

   295             local (. gen newLocal obj-type)]

   296         (. gen (visitCode))

   297         

   298         (if init

   299           (do

   300             (emit-get-var gen init-name)

   301             (. gen dup)

   302             (. gen ifNull no-init-label)

   303             (.checkCast gen ifn-type)

   304                                         ;box init args

   305             (dotimes [i (count pclasses)]

   306               (. gen (loadArg i))

   307               (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))

   308                                         ;call init fn

   309             (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 

   310                                                   (arg-types (count ptypes)))))

   311                                         ;expecting [[super-ctor-args] state] returned

   312             (. gen dup)

   313             (. gen push 0)

   314             (. gen (invokeStatic rt-type nth-method))

   315             (. gen storeLocal local)

   316             

   317             (. gen (loadThis))

   318             (. gen dupX1)

   319             (dotimes [i (count super-pclasses)]

   320               (. gen loadLocal local)

   321               (. gen push i)

   322               (. gen (invokeStatic rt-type nth-method))

   323               (. clojure.lang.Compiler$HostExpr (emitUnboxArg nil gen (nth super-pclasses i))))

   324             (. gen (invokeConstructor super-type super-m))

   325             

   326             (if state

   327               (do

   328                 (. gen push 1)

   329                 (. gen (invokeStatic rt-type nth-method))

   330                 (. gen (putField ctype state-name obj-type)))

   331               (. gen pop))

   332             

   333             (. gen goTo end-label)

   334                                         ;no init found

   335             (. gen mark no-init-label)

   336             (. gen (throwException ex-type (str impl-pkg-name "/" prefix init-name " not defined")))

   337             (. gen mark end-label))

   338           (if (= pclasses super-pclasses)

   339             (do

   340               (. gen (loadThis))

   341               (. gen (loadArgs))

   342               (. gen (invokeConstructor super-type super-m)))

   343             (throw (new Exception ":init not specified, but ctor and super ctor args differ"))))

   344 

   345         (when post-init

   346           (emit-get-var gen post-init-name)

   347           (. gen dup)

   348           (. gen ifNull no-post-init-label)

   349           (.checkCast gen ifn-type)

   350           (. gen (loadThis))

   351                                        ;box init args

   352           (dotimes [i (count pclasses)]

   353             (. gen (loadArg i))

   354             (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))

   355                                        ;call init fn

   356           (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 

   357                                                 (arg-types (inc (count ptypes))))))

   358           (. gen pop)

   359           (. gen goTo end-post-init-label)

   360                                        ;no init found

   361           (. gen mark no-post-init-label)

   362           (. gen (throwException ex-type (str impl-pkg-name "/" prefix post-init-name " not defined")))

   363           (. gen mark end-post-init-label))

   364 

   365         (. gen (returnValue))

   366         (. gen (endMethod))

   367                                         ;factory

   368         (when factory

   369           (let [fm (new Method factory-name ctype ptypes)

   370                 gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 

   371                          fm nil nil cv)]

   372             (. gen (visitCode))

   373             (. gen newInstance ctype)

   374             (. gen dup)

   375             (. gen (loadArgs))

   376             (. gen (invokeConstructor ctype m))            

   377             (. gen (returnValue))

   378             (. gen (endMethod))))))

   379     

   380                                         ;add methods matching supers', if no fn -> call super

   381     (let [mm (non-private-methods super)]

   382       (doseq [^java.lang.reflect.Method meth (vals mm)]

   383              (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false

   384                                      (fn [^GeneratorAdapter gen ^Method m]

   385                                        (. gen (loadThis))

   386                                         ;push args

   387                                        (. gen (loadArgs))

   388                                         ;call super

   389                                        (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 

   390                                                                (. super-type (getInternalName))

   391                                                                (. m (getName))

   392                                                                (. m (getDescriptor)))))))

   393                                         ;add methods matching interfaces', if no fn -> throw

   394       (reduce (fn [mm ^java.lang.reflect.Method meth]

   395                 (if (contains? mm (method-sig meth))

   396                   mm

   397                   (do

   398                     (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false

   399                                             emit-unsupported)

   400                     (assoc mm (method-sig meth) meth))))

   401               mm (mapcat #(.getMethods ^Class %) interfaces))

   402                                         ;extra methods

   403        (doseq [[mname pclasses rclass :as msig] methods]

   404          (emit-forwarding-method mname pclasses rclass (:static (meta msig))

   405                                  emit-unsupported))

   406                                         ;expose specified overridden superclass methods

   407        (doseq [[local-mname ^java.lang.reflect.Method m] (reduce (fn [ms [[name _ _] m]]

   408                               (if (contains? exposes-methods (symbol name))

   409                                 (conj ms [((symbol name) exposes-methods) m])

   410                                 ms)) [] (seq mm))]

   411          (let [ptypes (to-types (.getParameterTypes m))

   412                rtype (totype (.getReturnType m))

   413                exposer-m (new Method (str local-mname) rtype ptypes)

   414                target-m (new Method (.getName m) rtype ptypes)

   415                gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) exposer-m nil nil cv)]

   416            (. gen (loadThis))

   417            (. gen (loadArgs))

   418            (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 

   419                                    (. super-type (getInternalName))

   420                                    (. target-m (getName))

   421                                    (. target-m (getDescriptor))))

   422            (. gen (returnValue))

   423            (. gen (endMethod)))))

   424                                         ;main

   425     (when main

   426       (let [m (. Method getMethod "void main (String[])")

   427             gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) 

   428                      m nil nil cv)

   429             no-main-label (. gen newLabel)

   430             end-label (. gen newLabel)]

   431         (. gen (visitCode))

   432 

   433         (emit-get-var gen main-name)

   434         (. gen dup)

   435         (. gen ifNull no-main-label)

   436         (.checkCast gen ifn-type)

   437         (. gen loadArgs)

   438         (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.ISeq seq(Object)"))))

   439         (. gen (invokeInterface ifn-type (new Method "applyTo" obj-type 

   440                                               (into-array [iseq-type]))))

   441         (. gen pop)

   442         (. gen goTo end-label)

   443                                         ;no main found

   444         (. gen mark no-main-label)

   445         (. gen (throwException ex-type (str impl-pkg-name "/" prefix main-name " not defined")))

   446         (. gen mark end-label)

   447         (. gen (returnValue))

   448         (. gen (endMethod))))

   449                                         ;field exposers

   450     (doseq [[f {getter :get setter :set}] exposes]

   451       (let [fld (find-field super (str f))

   452             ftype (totype (.getType fld))

   453             static? (Modifier/isStatic (.getModifiers fld))

   454             acc (+ Opcodes/ACC_PUBLIC (if static? Opcodes/ACC_STATIC 0))]

   455         (when getter

   456           (let [m (new Method (str getter) ftype (to-types []))

   457                 gen (new GeneratorAdapter acc m nil nil cv)]

   458             (. gen (visitCode))

   459             (if static?

   460               (. gen getStatic ctype (str f) ftype)

   461               (do

   462                 (. gen loadThis)

   463                 (. gen getField ctype (str f) ftype)))

   464             (. gen (returnValue))

   465             (. gen (endMethod))))

   466         (when setter

   467           (let [m (new Method (str setter) Type/VOID_TYPE (into-array [ftype]))

   468                 gen (new GeneratorAdapter acc m nil nil cv)]

   469             (. gen (visitCode))

   470             (if static?

   471               (do

   472                 (. gen loadArgs)

   473                 (. gen putStatic ctype (str f) ftype))

   474               (do

   475                 (. gen loadThis)

   476                 (. gen loadArgs)

   477                 (. gen putField ctype (str f) ftype)))

   478             (. gen (returnValue))

   479             (. gen (endMethod))))))

   480                                         ;finish class def

   481     (. cv (visitEnd))

   482     [cname (. cv (toByteArray))]))

   483 

   484 (defmacro gen-class 

   485   "When compiling, generates compiled bytecode for a class with the

   486   given package-qualified :name (which, as all names in these

   487   parameters, can be a string or symbol), and writes the .class file

   488   to the *compile-path* directory.  When not compiling, does

   489   nothing. The gen-class construct contains no implementation, as the

   490   implementation will be dynamically sought by the generated class in

   491   functions in an implementing Clojure namespace. Given a generated

   492   class org.mydomain.MyClass with a method named mymethod, gen-class

   493   will generate an implementation that looks for a function named by 

   494   (str prefix mymethod) (default prefix: \"-\") in a

   495   Clojure namespace specified by :impl-ns

   496   (defaults to the current namespace). All inherited methods,

   497   generated methods, and init and main functions (see :methods, :init,

   498   and :main below) will be found similarly prefixed. By default, the

   499   static initializer for the generated class will attempt to load the

   500   Clojure support code for the class as a resource from the classpath,

   501   e.g. in the example case, ``org/mydomain/MyClass__init.class``. This

   502   behavior can be controlled by :load-impl-ns

   503 

   504   Note that methods with a maximum of 18 parameters are supported.

   505 

   506   In all subsequent sections taking types, the primitive types can be

   507   referred to by their Java names (int, float etc), and classes in the

   508   java.lang package can be used without a package qualifier. All other

   509   classes must be fully qualified.

   510 

   511   Options should be a set of key/value pairs, all except for :name are optional:

   512 

   513   :name aname

   514 

   515   The package-qualified name of the class to be generated

   516 

   517   :extends aclass

   518 

   519   Specifies the superclass, the non-private methods of which will be

   520   overridden by the class. If not provided, defaults to Object.

   521 

   522   :implements [interface ...]

   523 

   524   One or more interfaces, the methods of which will be implemented by the class.

   525 

   526   :init name

   527 

   528   If supplied, names a function that will be called with the arguments

   529   to the constructor. Must return [ [superclass-constructor-args] state] 

   530   If not supplied, the constructor args are passed directly to

   531   the superclass constructor and the state will be nil

   532 

   533   :constructors {[param-types] [super-param-types], ...}

   534 

   535   By default, constructors are created for the generated class which

   536   match the signature(s) of the constructors for the superclass. This

   537   parameter may be used to explicitly specify constructors, each entry

   538   providing a mapping from a constructor signature to a superclass

   539   constructor signature. When you supply this, you must supply an :init

   540   specifier. 

   541 

   542   :post-init name

   543 

   544   If supplied, names a function that will be called with the object as

   545   the first argument, followed by the arguments to the constructor.

   546   It will be called every time an object of this class is created,

   547   immediately after all the inherited constructors have completed.

   548   It's return value is ignored.

   549 

   550   :methods [ [name [param-types] return-type], ...]

   551 

   552   The generated class automatically defines all of the non-private

   553   methods of its superclasses/interfaces. This parameter can be used

   554   to specify the signatures of additional methods of the generated

   555   class. Static methods can be specified with ^{:static true} in the

   556   signature's metadata. Do not repeat superclass/interface signatures

   557   here.

   558 

   559   :main boolean

   560 

   561   If supplied and true, a static public main function will be generated. It will

   562   pass each string of the String[] argument as a separate argument to

   563   a function called (str prefix main).

   564 

   565   :factory name

   566 

   567   If supplied, a (set of) public static factory function(s) will be

   568   created with the given name, and the same signature(s) as the

   569   constructor(s).

   570   

   571   :state name

   572 

   573   If supplied, a public final instance field with the given name will be

   574   created. You must supply an :init function in order to provide a

   575   value for the state. Note that, though final, the state can be a ref

   576   or agent, supporting the creation of Java objects with transactional

   577   or asynchronous mutation semantics.

   578 

   579   :exposes {protected-field-name {:get name :set name}, ...}

   580 

   581   Since the implementations of the methods of the generated class

   582   occur in Clojure functions, they have no access to the inherited

   583   protected fields of the superclass. This parameter can be used to

   584   generate public getter/setter methods exposing the protected field(s)

   585   for use in the implementation.

   586 

   587   :exposes-methods {super-method-name exposed-name, ...}

   588 

   589   It is sometimes necessary to call the superclass' implementation of an

   590   overridden method.  Those methods may be exposed and referred in 

   591   the new method implementation by a local name.

   592 

   593   :prefix string

   594 

   595   Default: \"-\" Methods called e.g. Foo will be looked up in vars called

   596   prefixFoo in the implementing ns.

   597 

   598   :impl-ns name

   599 

   600   Default: the name of the current ns. Implementations of methods will be 

   601   looked up in this namespace.

   602 

   603   :load-impl-ns boolean

   604 

   605   Default: true. Causes the static initializer for the generated class

   606   to reference the load code for the implementing namespace. Should be

   607   true when implementing-ns is the default, false if you intend to

   608   load the code via some other method."

   609   {:added "1.0"}

   610   

   611   [& options]

   612     (when *compile-files*

   613       (let [options-map (into {} (map vec (partition 2 options)))

   614             [cname bytecode] (generate-class options-map)]

   615         (clojure.lang.Compiler/writeClassFile cname bytecode))))

   616 

   617 ;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;;

   618 ;; based on original contribution by Chris Houser

   619 

   620 (defn- ^Type asm-type

   621   "Returns an asm Type object for c, which may be a primitive class

   622   (such as Integer/TYPE), any other class (such as Double), or a

   623   fully-qualified class name given as a string or symbol

   624   (such as 'java.lang.String)"

   625   [c]

   626   (if (or (instance? Class c) (prim->class c))

   627     (Type/getType (the-class c))

   628     (let [strx (str c)]

   629       (Type/getObjectType 

   630        (.replace (if (some #{\.} strx)

   631                    strx

   632                    (str "java.lang." strx)) 

   633                  "." "/")))))

   634 

   635 (defn- generate-interface

   636   [{:keys [name extends methods]}]

   637   (let [iname (.replace (str name) "." "/")

   638         cv (ClassWriter. ClassWriter/COMPUTE_MAXS)]

   639     (. cv visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC 

   640                                 Opcodes/ACC_ABSTRACT

   641                                 Opcodes/ACC_INTERFACE)

   642        iname nil "java/lang/Object"

   643        (when (seq extends)

   644          (into-array (map #(.getInternalName (asm-type %)) extends))))

   645     (add-annotations cv (meta name))

   646     (doseq [[mname pclasses rclass pmetas] methods]

   647       (let [mv (. cv visitMethod (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)

   648                   (str mname)

   649                   (Type/getMethodDescriptor (asm-type rclass) 

   650                                             (if pclasses

   651                                               (into-array Type (map asm-type pclasses))

   652                                               (make-array Type 0)))

   653                   nil nil)]

   654         (add-annotations mv (meta mname))

   655         (dotimes [i (count pmetas)]

   656           (add-annotations mv (nth pmetas i) i))

   657         (. mv visitEnd)))

   658     (. cv visitEnd)

   659     [iname (. cv toByteArray)]))

   660 

   661 (defmacro gen-interface

   662   "When compiling, generates compiled bytecode for an interface with

   663   the given package-qualified :name (which, as all names in these

   664   parameters, can be a string or symbol), and writes the .class file

   665   to the *compile-path* directory.  When not compiling, does nothing.

   666  

   667   In all subsequent sections taking types, the primitive types can be

   668   referred to by their Java names (int, float etc), and classes in the

   669   java.lang package can be used without a package qualifier. All other

   670   classes must be fully qualified.

   671  

   672   Options should be a set of key/value pairs, all except for :name are

   673   optional:

   674 

   675   :name aname

   676 

   677   The package-qualified name of the class to be generated

   678 

   679   :extends [interface ...]

   680 

   681   One or more interfaces, which will be extended by this interface.

   682 

   683   :methods [ [name [param-types] return-type], ...]

   684 

   685   This parameter is used to specify the signatures of the methods of

   686   the generated interface.  Do not repeat superinterface signatures

   687   here."

   688   {:added "1.0"}

   689 

   690   [& options]

   691     (let [options-map (apply hash-map options)

   692           [cname bytecode] (generate-interface options-map)]

   693       (if *compile-files*

   694         (clojure.lang.Compiler/writeClassFile cname bytecode)

   695         (.defineClass ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) 

   696                       (str (:name options-map)) bytecode options)))) 

   697 

   698 (comment

   699 

   700 (defn gen-and-load-class 

   701   "Generates and immediately loads the bytecode for the specified

   702   class. Note that a class generated this way can be loaded only once

   703   - the JVM supports only one class with a given name per

   704   classloader. Subsequent to generation you can import it into any

   705   desired namespaces just like any other class. See gen-class for a

   706   description of the options."

   707   {:added "1.0"}

   708 

   709   [& options]

   710   (let [options-map (apply hash-map options)

   711         [cname bytecode] (generate-class options-map)]

   712     (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode options))))

   713 

   714 )
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children