1 files changed, 177 insertions, 0 deletions
diff --git a/src/clojure/contrib/gen_interface.clj b/src/clojure/contrib/gen_interface.clj
new file mode 100644
index 00000000..4ab4f26c
--- /dev/null
+++ b/src/clojure/contrib/gen_interface.clj
@@ -0,0 +1,177 @@
+;   Copyright (c) Chris Houser, July 2008. 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.
+
+; Functions for generating interface classes, which can then be loaded
+; or saved to a .class file.
+
+(ns clojure.contrib.gen-interface
+  (:import (clojure.asm ClassWriter Opcodes Type)
+           (java.io File FileOutputStream IOException)))
+
+(defn- asm-type
+  "Returns an asm Type object for c, which may be a primitive class
+  (such as Integer/TYPE), any other class (such as Double), or a
+  fully-qualified class name given as a string or symbol
+  (such as 'java.lang.String)"
+  [c]
+  (if (instance? Class c)
+    (Type/getType c)
+    (Type/getObjectType (.replace (str c) "." "/"))))
+
+(defn- iname
+  "Returns the internal name of given class or class name. Cannot be
+  used for primitive types."
+  [c] (.getInternalName (asm-type c)))
+
+(defstruct #^{:private true} spec-map :cname :iname :extends :methods)
+
+(defn- make-spec
+  "Returns an interface spec object based on the given description.
+   cname is the fully-qualified classname (string or symbol) of the
+   interface to be created.
+   extends is a collection of classes this interface will extend (each
+   may be a string, symbol, or a class). These are followed by the
+   method descriptions, each of which is a vector: [methodName,
+   arg types, return type]"
+  [cname extends & methods]
+  (struct spec-map
+    (str cname)
+    (iname cname)
+    (set (map iname extends))
+    (set (map (fn [[mname pclasses rclass]]
+                  [(str mname)
+                   (map asm-type pclasses)
+                   (asm-type rclass)])
+              methods))))
+
+(defn- spec-from-class
+  "Returns an interface spec object based on the given class."
+  [c]
+  (struct spec-map
+    (.getName c)
+    (iname c)
+    (set (map iname (.getInterfaces c)))
+    (set (map (fn [m]
+                  [(.getName m)
+                   (map asm-type (.getParameterTypes m))
+                   (asm-type (.getReturnType m))])
+              (.getDeclaredMethods c)))))
+
+(def #^{:private true} object-iname (iname Object))
+
+(defn- spec-bytecode
+  "Uses the given interface spec object (such as created by make-spec)
+   to generate a Java interface.  Returns a byte array containing the
+   Java bytecode for the interface.  You'll almost always want to use
+   gen-interface instead."
+  [{:keys [iname extends methods]}]
+  (let [cv (ClassWriter. ClassWriter/COMPUTE_MAXS)]
+    (. cv visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT
+                                Opcodes/ACC_INTERFACE)
+       iname nil object-iname
+       (when (seq extends)
+         (into-array extends)))
+    (doseq [[mname pclasses rclass] methods]
+      (. cv visitMethod (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
+         mname
+         (Type/getMethodDescriptor rclass (if pclasses
+                                            (into-array pclasses)
+                                            (make-array Type 0)))
+         nil nil))
+    (. cv visitEnd)
+    (. cv toByteArray)))
+
+
+(defn- load-interface-bytecode
+  [{:keys [cname] :as spec} bytecode]
+  (let [old-class (try (Class/forName cname) (catch Throwable t nil))]
+    (if old-class
+      (when-not (= spec (spec-from-class old-class))
+        (throw (Exception. (str "A different class named "
+                                cname " already loaded"))))
+      (.. clojure.lang.RT
+          ROOT_CLASSLOADER (defineClass cname bytecode)))))
+
+(defn- save-interface-bytecode
+  [path {:keys [cname]} bytecode]
+  (let [file (File. path (str (.replace cname \. File/separatorChar)
+                              ".class"))]
+    (try
+      (.createNewFile file)
+      (catch IOException e
+        (throw (Exception. (str "Failed to create " file) e))))
+    (with-open [f (FileOutputStream. file)]
+      (.write f bytecode))))
+
+(defn gen-and-load-interface
+  "Uses the given interface description to generate a Java interface
+   and immediately load it.  make-spec-args is the interface
+   description as documented in make-spec.  This function is not
+   generally useful since you'll usually want a .class file in order
+   to write Java code that uses the generated interface -- see
+   gen-interface instead."
+  [& make-spec-args]
+  (let [spec (apply make-spec make-spec-args)]
+    (load-interface-bytecode spec (spec-bytecode spec))))
+
+(defn gen-and-save-interface
+  "Uses the given interface description to generate a Java interface
+   and save it to a .class file.  make-spec-args is the interface
+   description as documented in make-spec.  The .class file will be
+   written into a sub-directory of the given base path (note that the
+   appropriate sub-directories under path must already exist or this
+   will throw an exception).  If you intend to use this interface
+   immediately (for example to refer to it in a later gen-interface or
+   gen-class call), you'll want to use gen-interface instead."
+  [path & make-spec-args]
+  (let [spec (apply make-spec make-spec-args)]
+    (save-interface-bytecode path spec (spec-bytecode spec))))
+
+(defn gen-interface
+  "Uses the given interface description to generate a Java interface,
+   save it to a .class file, and immediately load it so it's ready
+   for use by subsequent gen-interface or gen-class calls.  The .class
+   file will be written into a sub-directory of the given base path.
+   make-spec-args is the interface description as documented in
+   make-spec."
+  [path & make-spec-args]
+  (let [spec (apply make-spec make-spec-args)
+        bytecode (spec-bytecode spec)]
+    (load-interface-bytecode spec bytecode)
+    (save-interface-bytecode path spec bytecode)))
+
+(comment
+
+(gen-interface "/tmp" 'net.n01se.Foo [Appendable]
+               ['foo [] Integer]
+               ['bar [Integer/TYPE String] Double])
+
+; re-genning an identical interface doesn't try to load anything
+(gen-interface "/tmp" 'net.n01se.Foo [Appendable]
+               ['foo [] Integer]
+               ['bar [Integer/TYPE String] Double])
+
+; re-genning a different interface throws an exception
+;(gen-interface "/tmp" 'net.n01se.Foo [Appendable]
+;               ['foo [] Integer])
+
+; gen-and-save-interface is used directly in this example because I
+; want to refer to a class that's not yet defined in this runtime
+; (Other).  This is possible because I specify the class as a quoted
+; symbol, and then don't load it -- but this isn't really recommended.
+; Instead, why not make sure Other is defined -- then you can use
+; gen-interface.
+(gen-and-save-interface "/tmp" 'net.n01se.Bar ['net.n01se.Other Iterable]
+   ['baz [] net.n01se.Foo])
+
+(prn :isInterface (.isInterface (identity net.n01se.Foo)))
+(prn :interfaces (seq (.getGenericInterfaces (identity net.n01se.Foo))))
+(doseq [m (seq (.getMethods (identity net.n01se.Foo)))]
+  (prn m))
+
+)