511 lines
21 KiB
Clojure
511 lines
21 KiB
Clojure
; Copyright (c) Rich Hickey. All rights reserved.
|
|
; The use and distribution terms for this software are covered by the
|
|
; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
|
|
; which can be found in the file CPL.TXT at the root of this distribution.
|
|
; By using this software in any fashion, you are agreeing to be bound by
|
|
; the terms of this license.
|
|
; You must not remove this notice, or any other, from this software.
|
|
|
|
(in-ns 'clojure)
|
|
|
|
(import '(java.lang.reflect Modifier Constructor)
|
|
'(clojure.asm ClassWriter ClassVisitor Opcodes Type)
|
|
'(clojure.asm.commons Method GeneratorAdapter)
|
|
'(clojure.lang IPersistentMap))
|
|
|
|
;(defn method-sig [#^java.lang.reflect.Method meth]
|
|
; [(. meth (getName)) (seq (. meth (getParameterTypes)))])
|
|
|
|
(defn- non-private-methods [#^Class c]
|
|
(loop [mm {}
|
|
considered #{}
|
|
c c]
|
|
(if c
|
|
(let [[mm considered]
|
|
(loop [mm mm
|
|
considered considered
|
|
meths (concat
|
|
(seq (. c (getDeclaredMethods)))
|
|
(seq (. c (getMethods))))]
|
|
(if meths
|
|
(let [#^Method meth (first meths)
|
|
mods (. meth (getModifiers))
|
|
mk (method-sig meth)]
|
|
(if (or (considered mk)
|
|
(. Modifier (isPrivate mods))
|
|
(. Modifier (isStatic mods))
|
|
(. Modifier (isFinal mods)))
|
|
(recur mm (conj considered mk) (rest meths))
|
|
(recur (assoc mm mk meth) (conj considered mk) (rest meths))))
|
|
[mm considered]))]
|
|
(recur mm considered (. c (getSuperclass))))
|
|
mm)))
|
|
|
|
(defn- ctor-sigs [super]
|
|
(for [#^Constructor ctor (. super (getDeclaredConstructors))
|
|
:when (not (. Modifier (isPrivate (. ctor (getModifiers)))))]
|
|
(apply vector (. ctor (getParameterTypes)))))
|
|
|
|
(defn- escape-class-name [c]
|
|
(.. (.getSimpleName c)
|
|
(replace "[]" "<>")))
|
|
|
|
(defn- overload-name [mname pclasses]
|
|
(if (seq pclasses)
|
|
(apply str mname (interleave (repeat \-)
|
|
(map escape-class-name pclasses)))
|
|
(str mname "-void")))
|
|
|
|
;(distinct (map first(keys (mapcat non-private-methods [Object IPersistentMap]))))
|
|
|
|
(defn gen-class
|
|
"Generates compiled bytecode for a class with the given
|
|
package-qualified cname (which, as all names in these parameters, can
|
|
be a string or symbol). The gen-class construct contains no
|
|
implementation, as the implementation will be dynamically sought by
|
|
the generated class in functions in a corresponding Clojure
|
|
namespace. Given a generated class org.mydomain.MyClass, methods
|
|
will be implemented that look for same-named functions in a Clojure
|
|
namespace called org.domain.MyClass. The init and main
|
|
functions (see below) will be found similarly. The static
|
|
initializer for the generated class will attempt to load the Clojure
|
|
support code for the class as a resource from the claspath, e.g. in
|
|
the example case, org/mydomain/MyClass.clj
|
|
|
|
Returns a map containing :name and :bytecode. Most uses will be
|
|
satisfied by the higher-level gen-and-load-class and
|
|
gen-and-store-class functions, which generate and immediately load,
|
|
or generate and store to disk, respectively.
|
|
|
|
Options should be a set of key/value pairs, all of which are optional:
|
|
|
|
:extends aclass
|
|
|
|
Specifies the superclass, the non-private methods of which will be
|
|
overridden by the class. If not provided, defaults to Object.
|
|
|
|
:implements [interface ...]
|
|
|
|
One or more interfaces, the methods of which will be implemented by the class.
|
|
|
|
:init name
|
|
|
|
If supplied, names a function that will be called with the arguments
|
|
to the constructor. Must return [[superclass-constructor-args] state]
|
|
If not supplied, the constructor args are passed directly to
|
|
the superclass constructor and the state will be nil
|
|
|
|
:constructors {[param-types] [super-param-types], ...}
|
|
|
|
By default, constructors are created for the generated class which
|
|
match the signature(s) of the constructors for the superclass. This
|
|
parameter may be used to explicitly specify constructors, each entry
|
|
providing a mapping from a constructor signature to a superclass
|
|
constructor signature. When you supply this, you must supply an :init
|
|
specifier.
|
|
|
|
:methods [[name [param-types] return-type], ...]
|
|
|
|
The generated class automatically defines all of the non-private
|
|
methods of its superclasses/interfaces. This parameter can be used
|
|
to specify the signatures of additional methods of the generated
|
|
class. Do not repeat superclass/interface signatures here.
|
|
|
|
:main boolean
|
|
|
|
If supplied and true, a static public main function will be
|
|
generated. It will pass each string of the String[] argument as a
|
|
separate argument to a function called 'main.
|
|
|
|
:factory name
|
|
|
|
If supplied, a (set of) public static factory function(s) will be
|
|
created with the given name, and the same signature(s) as the
|
|
constructor(s).
|
|
|
|
:state name
|
|
|
|
If supplied, a public final instance field with the given name will be
|
|
created. You must supply an :init function in order to provide a
|
|
value for the state. Note that, though final, the state can be a ref
|
|
or agent, supporting the creation of Java objects with transactional
|
|
or asynchronous mutation semantics.
|
|
|
|
:exposes {protected-field-name {:get name :set name}, ...}
|
|
|
|
Since the implementations of the methods of the generated class
|
|
occur in Clojure functions, they have no access to the inherited
|
|
protected fields of the superclass. This parameter can be used to
|
|
generate public getter/setter methods exposing the protected field(s)
|
|
for use in the implementation."
|
|
|
|
[cname & options]
|
|
(let [name (str cname)
|
|
{:keys [extends implements constructors methods main factory state init exposes]} (apply hash-map options)
|
|
super (or extends Object)
|
|
interfaces implements
|
|
supers (cons super (seq interfaces))
|
|
ctor-sig-map (or constructors (zipmap (ctor-sigs super) (ctor-sigs super)))
|
|
cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
|
|
cname (. name (replace "." "/"))
|
|
ctype (. Type (getObjectType cname))
|
|
iname (fn [c] (.. Type (getType c) (getInternalName)))
|
|
totype (fn [c] (. Type (getType c)))
|
|
to-types (fn [cs] (if (pos? (count cs))
|
|
(into-array (map totype cs))
|
|
(make-array Type 0)))
|
|
obj-type (totype Object)
|
|
arg-types (fn [n] (if (pos? n)
|
|
(into-array (replicate n obj-type))
|
|
(make-array Type 0)))
|
|
super-type (totype super)
|
|
init-name (str init)
|
|
factory-name (str factory)
|
|
state-name (str state)
|
|
main-name "main"
|
|
var-name (fn [s] (str s "__var"))
|
|
rt-type (totype clojure.lang.RT)
|
|
var-type (totype clojure.lang.Var)
|
|
ifn-type (totype clojure.lang.IFn)
|
|
iseq-type (totype clojure.lang.ISeq)
|
|
ex-type (totype java.lang.UnsupportedOperationException)
|
|
all-sigs (distinct (concat (map #(let[[m p] (key %)] {m [p]}) (mapcat non-private-methods supers))
|
|
(map (fn [[m p]] {(str m) [p]}) methods)))
|
|
sigs-by-name (apply merge-with concat {} all-sigs)
|
|
overloads (into {} (filter (fn [[m s]] (rest s)) sigs-by-name))
|
|
var-fields (concat (and init [init-name])
|
|
(and main [main-name])
|
|
(distinct (concat (keys sigs-by-name)
|
|
(mapcat (fn [[m s]] (map #(overload-name m %) s)) overloads)
|
|
(mapcat (comp (partial map str) vals val) exposes))))
|
|
emit-get-var (fn [gen v]
|
|
(let [false-label (. gen newLabel)
|
|
end-label (. gen newLabel)]
|
|
(. gen getStatic ctype (var-name v) var-type)
|
|
(. gen dup)
|
|
(. gen invokeVirtual var-type (. Method (getMethod "boolean isBound()")))
|
|
(. gen ifZCmp (. GeneratorAdapter EQ) false-label)
|
|
(. gen invokeVirtual var-type (. Method (getMethod "Object get()")))
|
|
(. gen goTo end-label)
|
|
(. gen mark false-label)
|
|
(. gen pop)
|
|
(. gen visitInsn (. Opcodes ACONST_NULL))
|
|
(. gen mark end-label)))
|
|
emit-forwarding-method
|
|
(fn [mname pclasses rclass else-gen]
|
|
(let [ptypes (to-types pclasses)
|
|
rtype (totype rclass)
|
|
m (new Method mname rtype ptypes)
|
|
is-overload (overloads mname)
|
|
gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
|
|
found-label (. gen (newLabel))
|
|
else-label (. gen (newLabel))
|
|
end-label (. gen (newLabel))]
|
|
(. gen (visitCode))
|
|
(when is-overload
|
|
(emit-get-var gen (overload-name mname pclasses))
|
|
(. gen (dup))
|
|
(. gen (ifNonNull found-label))
|
|
(. gen (pop)))
|
|
(emit-get-var gen mname)
|
|
(. gen (dup))
|
|
(. gen (ifNull else-label))
|
|
(when is-overload
|
|
(. gen (mark found-label)))
|
|
;if found
|
|
(. gen (loadThis))
|
|
;box args
|
|
(dotimes i (count ptypes)
|
|
(. gen (loadArg i))
|
|
(. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
|
|
;call fn
|
|
(. gen (invokeInterface ifn-type (new Method "invoke" obj-type
|
|
(into-array (cons obj-type
|
|
(replicate (count ptypes) obj-type))))))
|
|
;unbox return
|
|
(. gen (unbox rtype))
|
|
(when (= (. rtype (getSort)) (. Type VOID))
|
|
(. gen (pop)))
|
|
(. gen (goTo end-label))
|
|
|
|
;else call supplied alternative generator
|
|
(. gen (mark else-label))
|
|
(. gen (pop))
|
|
|
|
(else-gen gen m)
|
|
|
|
(. gen (mark end-label))
|
|
(. gen (returnValue))
|
|
(. gen (endMethod))))
|
|
]
|
|
;start class definition
|
|
(. cv (visit (. Opcodes V1_5) (. Opcodes ACC_PUBLIC)
|
|
cname nil (iname super)
|
|
(when interfaces
|
|
(into-array (map iname interfaces)))))
|
|
|
|
;static fields for vars
|
|
(doseq v var-fields
|
|
(. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL) (. Opcodes ACC_STATIC))
|
|
(var-name v)
|
|
(. var-type getDescriptor)
|
|
nil nil)))
|
|
|
|
;instance field for state
|
|
(when state
|
|
(. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL))
|
|
state-name
|
|
(. obj-type getDescriptor)
|
|
nil nil)))
|
|
|
|
;static init to set up var fields and load clj
|
|
(let [gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
|
|
(. Method getMethod "void <clinit> ()")
|
|
nil nil cv)]
|
|
(. gen (visitCode))
|
|
(doseq v var-fields
|
|
(. gen push name)
|
|
(. gen push v)
|
|
(. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.Var var(String,String)"))))
|
|
(. gen putStatic ctype (var-name v) var-type))
|
|
|
|
(. gen push ctype)
|
|
(. gen push (str (. name replace \. (. java.io.File separatorChar)) ".clj"))
|
|
(. gen (invokeStatic rt-type (. Method (getMethod "void loadResourceScript(Class,String)"))))
|
|
|
|
(. gen (returnValue))
|
|
(. gen (endMethod)))
|
|
|
|
;ctors
|
|
(doseq [pclasses super-pclasses] ctor-sig-map
|
|
(let [ptypes (to-types pclasses)
|
|
super-ptypes (to-types super-pclasses)
|
|
m (new Method "<init>" (. Type VOID_TYPE) ptypes)
|
|
super-m (new Method "<init>" (. Type VOID_TYPE) super-ptypes)
|
|
gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
|
|
no-init-label (. gen newLabel)
|
|
end-label (. gen newLabel)
|
|
nth-method (. Method (getMethod "Object nth(Object,int)"))
|
|
local (. gen newLocal obj-type)]
|
|
(. gen (visitCode))
|
|
|
|
(if init
|
|
(do
|
|
(emit-get-var gen init-name)
|
|
(. gen dup)
|
|
(. gen ifNull no-init-label)
|
|
;box init args
|
|
(dotimes i (count pclasses)
|
|
(. gen (loadArg i))
|
|
(. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
|
|
;call init fn
|
|
(. gen (invokeInterface ifn-type (new Method "invoke" obj-type
|
|
(arg-types (count ptypes)))))
|
|
;expecting [[super-ctor-args] state] returned
|
|
(. gen dup)
|
|
(. gen push 0)
|
|
(. gen (invokeStatic rt-type nth-method))
|
|
(. gen storeLocal local)
|
|
|
|
(. gen (loadThis))
|
|
(. gen dupX1)
|
|
(dotimes i (count super-pclasses)
|
|
(. gen loadLocal local)
|
|
(. gen push i)
|
|
(. gen (invokeStatic rt-type nth-method))
|
|
(. clojure.lang.Compiler$HostExpr (emitUnboxArg nil gen (nth super-pclasses i))))
|
|
(. gen (invokeConstructor super-type super-m))
|
|
|
|
(if state
|
|
(do
|
|
(. gen push 1)
|
|
(. gen (invokeStatic rt-type nth-method))
|
|
(. gen (putField ctype state-name obj-type)))
|
|
(. gen pop))
|
|
|
|
(. gen goTo end-label)
|
|
;no init found
|
|
(. gen mark no-init-label)
|
|
(. gen (throwException ex-type (str init-name " not defined")))
|
|
(. gen mark end-label))
|
|
(if (= pclasses super-pclasses)
|
|
(do
|
|
(. gen (loadThis))
|
|
(. gen (loadArgs))
|
|
(. gen (invokeConstructor super-type super-m)))
|
|
(throw (new Exception ":init not specified, but ctor and super ctor args differ"))))
|
|
|
|
(. gen (returnValue))
|
|
(. gen (endMethod))
|
|
;factory
|
|
(when factory
|
|
(let [fm (new Method factory-name ctype ptypes)
|
|
gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
|
|
fm nil nil cv)]
|
|
(. gen (visitCode))
|
|
(. gen newInstance ctype)
|
|
(. gen dup)
|
|
(. gen (loadArgs))
|
|
(. gen (invokeConstructor ctype m))
|
|
(. gen (returnValue))
|
|
(. gen (endMethod))))))
|
|
|
|
;add methods matching supers', if no fn -> call super
|
|
(let [mm (non-private-methods super)]
|
|
(doseq #^java.lang.reflect.Method meth (vals mm)
|
|
(emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth)
|
|
(fn [gen m]
|
|
(. gen (loadThis))
|
|
;push args
|
|
(. gen (loadArgs))
|
|
;call super
|
|
(. gen (visitMethodInsn (. Opcodes INVOKESPECIAL)
|
|
(. super-type (getInternalName))
|
|
(. m (getName))
|
|
(. m (getDescriptor)))))))
|
|
;add methods matching interfaces', if no fn -> throw
|
|
(doseq #^Class iface interfaces
|
|
(doseq #^java.lang.reflect.Method meth (. iface (getMethods))
|
|
(when-not (contains? mm (method-sig meth))
|
|
(emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth)
|
|
(fn [gen m]
|
|
(. gen (throwException ex-type (. m (getName)))))))))
|
|
;extra methods
|
|
(doseq [mname pclasses rclass :as msig] methods
|
|
(emit-forwarding-method (str mname) pclasses rclass
|
|
(fn [gen m]
|
|
(. gen (throwException ex-type (. m (getName))))))))
|
|
|
|
;main
|
|
(when main
|
|
(let [m (. Method getMethod "void main (String[])")
|
|
gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC))
|
|
m nil nil cv)
|
|
no-main-label (. gen newLabel)
|
|
end-label (. gen newLabel)]
|
|
(. gen (visitCode))
|
|
|
|
(emit-get-var gen main-name)
|
|
(. gen dup)
|
|
(. gen ifNull no-main-label)
|
|
(. gen loadArgs)
|
|
(. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.ISeq seq(Object)"))))
|
|
(. gen (invokeInterface ifn-type (new Method "applyTo" obj-type
|
|
(into-array [iseq-type]))))
|
|
(. gen pop)
|
|
(. gen goTo end-label)
|
|
;no main found
|
|
(. gen mark no-main-label)
|
|
(. gen (throwException ex-type (str main-name " not defined")))
|
|
(. gen mark end-label)
|
|
(. gen (returnValue))
|
|
(. gen (endMethod))))
|
|
;field exposers
|
|
(doseq [f {getter :get setter :set}] exposes
|
|
(let [fld (.getField super (str f))
|
|
ftype (totype (.getType fld))]
|
|
(when getter
|
|
(let [m (new Method (str getter) ftype (to-types []))
|
|
gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
|
|
(. gen (visitCode))
|
|
(. gen loadThis)
|
|
(. gen getField ctype (str f) ftype)
|
|
(. gen (returnValue))
|
|
(. gen (endMethod))))
|
|
(when setter
|
|
(let [m (new Method (str setter) (. Type VOID_TYPE) (into-array [ftype]))
|
|
gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
|
|
(. gen (visitCode))
|
|
(. gen loadThis)
|
|
(. gen loadArgs)
|
|
(. gen putField ctype (str f) ftype)
|
|
(. gen (returnValue))
|
|
(. gen (endMethod))))))
|
|
;finish class def
|
|
(. cv (visitEnd))
|
|
{:name name :bytecode (. cv (toByteArray))}))
|
|
|
|
(defn gen-and-load-class
|
|
"Generates and immediately loads the bytecode for the specified
|
|
class. Note that a class generated this way can be loaded only once
|
|
- the JVM supports only one class with a given name per
|
|
classloader. Subsequent to generation you can import it into any
|
|
desired namespaces just like any other class. See gen-class for a
|
|
description of the options."
|
|
|
|
[name & options]
|
|
(let [{:keys [name bytecode]}
|
|
(apply gen-class (str name) options)]
|
|
(.. clojure.lang.RT ROOT_CLASSLOADER (defineClass (str name) bytecode))))
|
|
|
|
(defn gen-and-save-class
|
|
"Generates the bytecode for the named class and stores in a .class
|
|
file in a subpath of the supplied path, the directories for which
|
|
must already exist. See gen-class for a description of the options"
|
|
|
|
[path name & options]
|
|
(let [{:keys [name bytecode]} (apply gen-class (str name) options)
|
|
file (java.io.File. path (str (. name replace \. (. java.io.File separatorChar)) ".class"))]
|
|
(.createNewFile file)
|
|
(with-open f (java.io.FileOutputStream. file)
|
|
(.write f bytecode))))
|
|
|
|
(comment
|
|
;usage
|
|
(gen-class
|
|
package-qualified-name
|
|
;all below are optional
|
|
:extends aclass
|
|
:implements [interface ...]
|
|
:constructors {[param-types] [super-param-types], }
|
|
:methods [[name [param-types] return-type], ]
|
|
:main boolean
|
|
:factory name
|
|
:state name
|
|
:init name
|
|
:exposes {protected-field {:get name :set name}, })
|
|
|
|
;(gen-and-load-class
|
|
(clojure/gen-and-save-class
|
|
"/Users/rich/Downloads"
|
|
'fred.lucy.Ethel
|
|
:extends clojure.lang.Box ;APersistentMap
|
|
:implements [clojure.lang.IPersistentMap]
|
|
:state 'state
|
|
;:constructors {[Object] [Object]}
|
|
;:init 'init
|
|
:main true
|
|
:factory 'create
|
|
:methods [['foo [Object] Object]
|
|
['foo [] Object]]
|
|
:exposes {'val {:get 'getVal :set 'setVal}})
|
|
|
|
(in-ns 'fred.lucy.Ethel__2276)
|
|
(clojure/refer 'clojure :exclude '(assoc seq count cons))
|
|
(defn init [n] [[] n])
|
|
(defn foo
|
|
([this] :foo)
|
|
([this x] x))
|
|
(defn main [x y] (println x y))
|
|
(in-ns 'user)
|
|
(def ethel (new fred.lucy.Ethel__2276 42))
|
|
(def ethel (fred.lucy.Ethel__2276.create 21))
|
|
(fred.lucy.Ethel__2276.main (into-array ["lucy" "ricky"]))
|
|
(.state ethel)
|
|
(.foo ethel 7)
|
|
(.foo ethel)
|
|
(.getVal ethel)
|
|
(.setVal ethel 12)
|
|
|
|
(gen-class org.clojure.MyComparator :implements [Comparator])
|
|
(in-ns 'org.clojure.MyComparator)
|
|
(defn compare [this x y] ...)
|
|
|
|
(load-file "/Users/rich/dev/clojure/src/genclass.clj")
|
|
|
|
(clojure/gen-and-save-class "/Users/rich/dev/clojure/gen/"
|
|
'org.clojure.ClojureServlet
|
|
:extends javax.servlet.http.HttpServlet)
|
|
|
|
)
|