diff options
| -rw-r--r-- | CHANGES | 1 | ||||
| -rw-r--r-- | pygments/lexers/_mapping.py | 1 | ||||
| -rw-r--r-- | pygments/lexers/agile.py | 140 | ||||
| -rw-r--r-- | tests/examplefiles/genclass.clj | 510 |
4 files changed, 650 insertions, 2 deletions
@@ -14,6 +14,7 @@ Version 0.11 * Lighttpd config files * Nginix config files * Gnuplot plotting scripts + * Clojure - Added "Visual Studio" style. diff --git a/pygments/lexers/_mapping.py b/pygments/lexers/_mapping.py index ec195588..c6aa1518 100644 --- a/pygments/lexers/_mapping.py +++ b/pygments/lexers/_mapping.py @@ -31,6 +31,7 @@ LEXERS = { 'CheetahJavascriptLexer': ('pygments.lexers.templates', 'JavaScript+Cheetah', ('js+cheetah', 'javascript+cheetah', 'js+spitfire', 'javascript+spitfire'), (), ('application/x-javascript+cheetah', 'text/x-javascript+cheetah', 'text/javascript+cheetah', 'application/x-javascript+spitfire', 'text/x-javascript+spitfire', 'text/javascript+spitfire')), 'CheetahLexer': ('pygments.lexers.templates', 'Cheetah', ('cheetah', 'spitfire'), ('*.tmpl', '*.spt'), ('application/x-cheetah', 'application/x-spitfire')), 'CheetahXmlLexer': ('pygments.lexers.templates', 'XML+Cheetah', ('xml+cheetah', 'xml+spitfire'), (), ('application/xml+cheetah', 'application/xml+spitfire')), + 'ClojureLexer': ('pygments.lexers.agile', 'Clojure', ('clojure', 'clj'), ('*.clj',), ('text/x-clojure', 'application/x-clojure')), 'CommonLispLexer': ('pygments.lexers.functional', 'Common Lisp', ('common-lisp', 'cl'), ('*.cl', '*.lisp', '*.el'), ('text/x-common-lisp',)), 'CppLexer': ('pygments.lexers.compiled', 'C++', ('cpp', 'c++'), ('*.cpp', '*.hpp', '*.c++', '*.h++', '*.cc', '*.hh', '*.cxx', '*.hxx'), ('text/x-c++hdr', 'text/x-c++src')), 'CppObjdumpLexer': ('pygments.lexers.asm', 'cpp-objdump', ('cpp-objdump', 'c++-objdumb', 'cxx-objdump'), ('*.cpp-objdump', '*.c++-objdump', '*.cxx-objdump'), ('text/x-cpp-objdump',)), diff --git a/pygments/lexers/agile.py b/pygments/lexers/agile.py index 109bffcc..59c91037 100644 --- a/pygments/lexers/agile.py +++ b/pygments/lexers/agile.py @@ -7,7 +7,8 @@ :copyright: 2006-2008 by Georg Brandl, Armin Ronacher, Lukas Meuser, Tim Hatch, Jarrett Billingsley, - Tassilo Schweyer, Steven Hazel, Nick Efford. + Tassilo Schweyer, Steven Hazel, Nick Efford, + Davy Wybiral. :license: BSD, see LICENSE for more details. """ @@ -27,7 +28,7 @@ from pygments import unistring as uni __all__ = ['PythonLexer', 'PythonConsoleLexer', 'PythonTracebackLexer', 'RubyLexer', 'RubyConsoleLexer', 'PerlLexer', 'LuaLexer', - 'MiniDLexer', 'IoLexer', 'TclLexer', 'Python3Lexer'] + 'MiniDLexer', 'IoLexer', 'TclLexer', 'Python3Lexer', 'ClojureLexer'] # b/w compatibility from pygments.lexers.functional import SchemeLexer @@ -1251,3 +1252,138 @@ class TclLexer(RegexLexer): def analyse_text(text): return shebang_matches(text, r'(tcl)') + + +class ClojureLexer(RegexLexer): + """ + Lexer for `Clojure <http://clojure.org/>`_ source code. + + *New in Pygments 0.11.* + """ + name = 'Clojure' + aliases = ['clojure', 'clj'] + filenames = ['*.clj'] + mimetypes = ['text/x-clojure', 'application/x-clojure'] + + keywords = [ + 'fn', 'def', 'defn', 'defmacro', 'defmethod', 'defmulti', 'defn-', + 'defstruct', + 'if', 'cond', + 'let', 'for' + ] + builtins = [ + '.', '..', + '*', '+', '-', '->', '..', '/', '<', '<=', '=', '==', '>', '>=', + 'accessor', 'agent', 'agent-errors', 'aget', 'alength', 'all-ns', + 'alter', 'and', 'append-child', 'apply', 'array-map', 'aset', + 'aset-boolean', 'aset-byte', 'aset-char', 'aset-double', 'aset-float', + 'aset-int', 'aset-long', 'aset-short', 'assert', 'assoc', 'await', + 'await-for', 'bean', 'binding', 'bit-and', 'bit-not', 'bit-or', + 'bit-shift-left', 'bit-shift-right', 'bit-xor', 'boolean', 'branch?', + 'butlast', 'byte', 'cast', 'char', 'children', 'class', + 'clear-agent-errors', 'comment', 'commute', 'comp', 'comparator', + 'complement', 'concat', 'conj', 'cons', 'constantly', + 'construct-proxy', 'contains?', 'count', 'create-ns', 'create-struct', + 'cycle', 'dec', 'deref', 'difference', 'disj', 'dissoc', 'distinct', + 'doall', 'doc', 'dorun', 'doseq', 'dosync', 'dotimes', 'doto', + 'double', 'down', 'drop', 'drop-while', 'edit', 'end?', 'ensure', + 'eval', 'every?', 'false?', 'ffirst', 'file-seq', 'filter', 'find', + 'find-doc', 'find-ns', 'find-var', 'first', 'float', 'flush', + 'fnseq', 'frest', 'gensym', 'get', 'get-proxy-class', + 'hash-map', 'hash-set', 'identical?', 'identity', 'if-let', 'import', + 'in-ns', 'inc', 'index', 'insert-child', 'insert-left', 'insert-right', + 'inspect-table', 'inspect-tree', 'instance?', 'int', 'interleave', + 'intersection', 'into', 'into-array', 'iterate', 'join', 'key', 'keys', + 'keyword', 'keyword?', 'last', 'lazy-cat', 'lazy-cons', 'left', + 'lefts', 'line-seq', 'list', 'list*', 'load', 'load-file', + 'locking', 'long', 'loop', 'macroexpand', 'macroexpand-1', + 'make-array', 'make-node', 'map', 'map-invert', 'map?', 'mapcat', + 'max', 'max-key', 'memfn', 'merge', 'merge-with', 'meta', 'min', + 'min-key', 'name', 'namespace', 'neg?', 'new', 'newline', 'next', + 'nil?', 'node', 'not', 'not-any?', 'not-every?', 'not=', 'ns-imports', + 'ns-interns', 'ns-map', 'ns-name', 'ns-publics', 'ns-refers', + 'ns-resolve', 'ns-unmap', 'nth', 'nthrest', 'or', 'parse', 'partial', + 'path', 'peek', 'pop', 'pos?', 'pr', 'pr-str', 'print', 'print-str', + 'println', 'println-str', 'prn', 'prn-str', 'project', 'proxy', + 'proxy-mappings', 'quot', 'rand', 'rand-int', 'range', 're-find', + 're-groups', 're-matcher', 're-matches', 're-pattern', 're-seq', + 'read', 'read-line', 'reduce', 'ref', 'ref-set', 'refer', 'rem', + 'remove', 'remove-method', 'remove-ns', 'rename', 'rename-keys', + 'repeat', 'replace', 'replicate', 'resolve', 'rest', 'resultset-seq', + 'reverse', 'rfirst', 'right', 'rights', 'root', 'rrest', 'rseq', + 'second', 'select', 'select-keys', 'send', 'send-off', 'seq', + 'seq-zip', 'seq?', 'set', 'short', 'slurp', 'some', 'sort', + 'sort-by', 'sorted-map', 'sorted-map-by', 'sorted-set', + 'special-symbol?', 'split-at', 'split-with', 'str', 'string?', + 'struct', 'struct-map', 'subs', 'subvec', 'symbol', 'symbol?', + 'sync', 'take', 'take-nth', 'take-while', 'test', 'time', 'to-array', + 'to-array-2d', 'tree-seq', 'true?', 'union', 'up', 'update-proxy', + 'val', 'vals', 'var-get', 'var-set', 'var?', 'vector', 'vector-zip', + 'vector?', 'when', 'when-first', 'when-let', 'when-not', + 'with-local-vars', 'with-meta', 'with-open', 'with-out-str', + 'xml-seq', 'xml-zip', 'zero?', 'zipmap', 'zipper'] + + # valid names for identifiers + # well, names can only not consist fully of numbers + # but this should be good enough for now + valid_name = r'[a-zA-Z0-9!$%&*+,/:<=>?@^_~-]+' + + tokens = { + 'root' : [ + # the comments - always starting with semicolon + # and going to the end of the line + (r';.*$', Comment.Single), + + # whitespaces - usually not relevant + (r'\s+', Text), + + # numbers + (r'-?\d+\.\d+', Number.Float), + (r'-?\d+', Number.Integer), + # support for uncommon kinds of numbers - + # have to figure out what the characters mean + #(r'(#e|#i|#b|#o|#d|#x)[\d.]+', Number), + + # strings, symbols and characters + (r'"(\\\\|\\"|[^"])*"', String), + (r"'" + valid_name, String.Symbol), + (r"\\([()/'\".'_!§$%& ?=+-]{1}|[a-zA-Z0-9]+)", String.Char), + + # constants + (r'(#t|#f)', Name.Constant), + + # special operators + (r"('|#|`|,@|,|\.)", Operator), + + # highlight the keywords + ('(%s)' % '|'.join([ + re.escape(entry) + ' ' for entry in keywords]), + Keyword + ), + + # first variable in a quoted string like + # '(this is syntactic sugar) + (r"(?<='\()" + valid_name, Name.Variable), + (r"(?<=#\()" + valid_name, Name.Variable), + + # highlight the builtins + ("(?<=\()(%s)" % '|'.join([ + re.escape(entry) + ' ' for entry in builtins]), + Name.Builtin + ), + + # the remaining functions + (r'(?<=\()' + valid_name, Name.Function), + # find the remaining variables + (valid_name, Name.Variable), + + # Clojure accepts vector notation + (r'(\[|\])', Punctuation), + + # Clojure accepts map notation + (r'(\{|\})', Punctuation), + + # the famous parentheses! + (r'(\(|\))', Punctuation), + ], + } diff --git a/tests/examplefiles/genclass.clj b/tests/examplefiles/genclass.clj new file mode 100644 index 00000000..c63da8fd --- /dev/null +++ b/tests/examplefiles/genclass.clj @@ -0,0 +1,510 @@ +; 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) + +) |