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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; proxy ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    12 

    13 (import

    14  '(clojure.asm ClassWriter ClassVisitor Opcodes Type) 

    15  '(java.lang.reflect Modifier Constructor)

    16  '(clojure.asm.commons Method GeneratorAdapter)

    17  '(clojure.lang IProxy Reflector DynamicClassLoader IPersistentMap PersistentHashMap RT))

    18 

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

    20   [(. meth (getName)) (seq (. meth (getParameterTypes))) (. meth getReturnType)])

    21 

    22 (defn- most-specific [rtypes]

    23   (or (some (fn [t] (when (every? #(isa? t %) rtypes) t)) rtypes)

    24     (throw (Exception. "Incompatible return types"))))

    25 

    26 (defn- group-by-sig [coll]

    27  "takes a collection of [msig meth] and returns a seq of maps from return-types to meths."

    28   (vals (reduce (fn [m [msig meth]]

    29                   (let [rtype (peek msig)

    30                         argsig (pop msig)]

    31                     (assoc m argsig (assoc (m argsig {}) rtype meth))))

    32           {} coll)))

    33 

    34 (defn proxy-name

    35  {:tag String} 

    36  [^Class super interfaces]

    37   (let [inames (into (sorted-set) (map #(.getName ^Class %) interfaces))]

    38     (apply str (.replace (str *ns*) \- \_) ".proxy"

    39       (interleave (repeat "$")

    40         (concat

    41           [(.getName super)]

    42           (map #(subs % (inc (.lastIndexOf ^String % "."))) inames)

    43           [(Integer/toHexString (hash inames))])))))

    44 

    45 (defn- generate-proxy [^Class super interfaces]

    46   (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))

    47         cname (.replace (proxy-name super interfaces) \. \/) ;(str "clojure/lang/" (gensym "Proxy__"))

    48         ctype (. Type (getObjectType cname))

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

    50         fmap "__clojureFnMap"

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

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

    53                             (into-array (map totype cs))

    54                             (make-array Type 0)))

    55         super-type ^Type (totype super)

    56         imap-type ^Type (totype IPersistentMap)

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

    58         obj-type (totype Object)

    59         sym-type (totype clojure.lang.Symbol)

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

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

    62         gen-bridge 

    63         (fn [^java.lang.reflect.Method meth ^java.lang.reflect.Method dest]

    64             (let [pclasses (. meth (getParameterTypes))

    65                   ptypes (to-types pclasses)

    66                   rtype ^Type (totype (. meth (getReturnType)))

    67                   m (new Method (. meth (getName)) rtype ptypes)

    68                   dtype (totype (.getDeclaringClass dest))

    69                   dm (new Method (. dest (getName)) (totype (. dest (getReturnType))) (to-types (. dest (getParameterTypes))))

    70                   gen (new GeneratorAdapter (bit-or (. Opcodes ACC_PUBLIC) (. Opcodes ACC_BRIDGE)) m nil nil cv)]

    71               (. gen (visitCode))

    72               (. gen (loadThis))

    73               (dotimes [i (count ptypes)]

    74                   (. gen (loadArg i)))

    75               (if (-> dest .getDeclaringClass .isInterface)

    76                 (. gen (invokeInterface dtype dm))

    77                 (. gen (invokeVirtual dtype dm)))

    78               (. gen (returnValue))

    79               (. gen (endMethod))))

    80         gen-method

    81         (fn [^java.lang.reflect.Method meth else-gen]

    82             (let [pclasses (. meth (getParameterTypes))

    83                   ptypes (to-types pclasses)

    84                   rtype ^Type (totype (. meth (getReturnType)))

    85                   m (new Method (. meth (getName)) rtype ptypes)

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

    87                   else-label (. gen (newLabel))

    88                   end-label (. gen (newLabel))

    89                   decl-type (. Type (getType (. meth (getDeclaringClass))))]

    90               (. gen (visitCode))

    91               (if (> (count pclasses) 18)

    92                 (else-gen gen m)

    93                 (do

    94                   (. gen (loadThis))

    95                   (. gen (getField ctype fmap imap-type))

    96                   

    97                   (. gen (push (. meth (getName))))

    98                                         ;lookup fn in map

    99                   (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)"))))

   100                   (. gen (dup))

   101                   (. gen (ifNull else-label))

   102                                         ;if found

   103                   (.checkCast gen ifn-type)

   104                   (. gen (loadThis))

   105                                         ;box args

   106                   (dotimes [i (count ptypes)]

   107                       (. gen (loadArg i))

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

   109                                         ;call fn

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

   111                                                         (into-array (cons obj-type 

   112                                                                           (replicate (count ptypes) obj-type))))))

   113                                         ;unbox return

   114                   (. gen (unbox rtype))

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

   116                     (. gen (pop)))

   117                   (. gen (goTo end-label))

   118                   

   119                                         ;else call supplied alternative generator

   120                   (. gen (mark else-label))

   121                   (. gen (pop))

   122                   

   123                   (else-gen gen m)

   124                   

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

   126               (. gen (returnValue))

   127               (. gen (endMethod))))]

   128     

   129                                         ;start class definition

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

   131                  cname nil (iname super) 

   132                  (into-array (map iname (cons IProxy interfaces)))))

   133                                         ;add field for fn mappings

   134     (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE))

   135                       fmap (. imap-type (getDescriptor)) nil nil))          

   136                                         ;add ctors matching/calling super's

   137     (doseq [^Constructor ctor (. super (getDeclaredConstructors))]

   138         (when-not (. Modifier (isPrivate (. ctor (getModifiers))))

   139           (let [ptypes (to-types (. ctor (getParameterTypes)))

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

   141                 gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]

   142             (. gen (visitCode))

   143                                         ;call super ctor

   144             (. gen (loadThis))

   145             (. gen (dup))

   146             (. gen (loadArgs))

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

   148             

   149             (. gen (returnValue))

   150             (. gen (endMethod)))))

   151                                         ;add IProxy methods

   152     (let [m (. Method (getMethod "void __initClojureFnMappings(clojure.lang.IPersistentMap)"))

   153           gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]

   154       (. gen (visitCode))

   155       (. gen (loadThis))

   156       (. gen (loadArgs))

   157       (. gen (putField ctype fmap imap-type))

   158       

   159       (. gen (returnValue))

   160       (. gen (endMethod)))

   161     (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)"))

   162           gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]

   163       (. gen (visitCode))

   164       (. gen (loadThis))

   165       (. gen (dup))

   166       (. gen (getField ctype fmap imap-type))

   167       (.checkCast gen (totype clojure.lang.IPersistentCollection))

   168       (. gen (loadArgs))

   169       (. gen (invokeInterface (totype clojure.lang.IPersistentCollection)

   170                               (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)"))))

   171       (. gen (checkCast imap-type))

   172       (. gen (putField ctype fmap imap-type))

   173       

   174       (. gen (returnValue))

   175       (. gen (endMethod)))

   176     (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()"))

   177           gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]

   178       (. gen (visitCode))

   179       (. gen (loadThis))

   180       (. gen (getField ctype fmap imap-type))

   181       (. gen (returnValue))

   182       (. gen (endMethod)))

   183     

   184                                         ;calc set of supers' non-private instance methods

   185     (let [[mm considered]

   186             (loop [mm {} considered #{} c super]

   187               (if c

   188                 (let [[mm considered]

   189                       (loop [mm mm 

   190                              considered considered 

   191                              meths (concat 

   192                                     (seq (. c (getDeclaredMethods)))

   193                                     (seq (. c (getMethods))))]

   194                         (if (seq meths)

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

   196                                 mods (. meth (getModifiers))

   197                                 mk (method-sig meth)]

   198                             (if (or (considered mk)

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

   200                                     ;(. Modifier (isPrivate mods)) 

   201                                     (. Modifier (isStatic mods))

   202                                     (. Modifier (isFinal mods))

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

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

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

   206                           [mm considered]))]

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

   208                 [mm considered]))

   209           ifaces-meths (into {} 

   210                          (for [^Class iface interfaces meth (. iface (getMethods))

   211                                :let [msig (method-sig meth)] :when (not (considered msig))]

   212                            {msig meth}))

   213           mgroups (group-by-sig (concat mm ifaces-meths))

   214           rtypes (map #(most-specific (keys %)) mgroups)

   215           mb (map #(vector (%1 %2) (vals (dissoc %1 %2))) mgroups rtypes)

   216           bridge? (reduce into #{} (map second mb))

   217           ifaces-meths (remove bridge? (vals ifaces-meths))

   218           mm (remove bridge? (vals mm))]

   219                                         ;add methods matching supers', if no mapping -> call super

   220       (doseq [[^java.lang.reflect.Method dest bridges] mb

   221               ^java.lang.reflect.Method meth bridges]

   222           (gen-bridge meth dest))

   223       (doseq [^java.lang.reflect.Method meth mm]

   224           (gen-method meth 

   225                       (fn [^GeneratorAdapter gen ^Method m]

   226                           (. gen (loadThis))

   227                                         ;push args

   228                         (. gen (loadArgs))

   229                                         ;call super

   230                         (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 

   231                                                 (. super-type (getInternalName))

   232                                                 (. m (getName))

   233                                                 (. m (getDescriptor)))))))

   234       

   235                                         ;add methods matching interfaces', if no mapping -> throw

   236       (doseq [^java.lang.reflect.Method meth ifaces-meths]

   237                 (gen-method meth 

   238                             (fn [^GeneratorAdapter gen ^Method m]

   239                                 (. gen (throwException ex-type (. m (getName))))))))

   240     

   241                                         ;finish class def

   242     (. cv (visitEnd))

   243     [cname (. cv toByteArray)]))

   244 

   245 (defn- get-super-and-interfaces [bases]

   246   (if (. ^Class (first bases) (isInterface))

   247     [Object bases]

   248     [(first bases) (next bases)]))

   249 

   250 (defn get-proxy-class 

   251   "Takes an optional single class followed by zero or more

   252   interfaces. If not supplied class defaults to Object.  Creates an

   253   returns an instance of a proxy class derived from the supplied

   254   classes. The resulting value is cached and used for any subsequent

   255   requests for the same class set. Returns a Class object."

   256   {:added "1.0"}

   257   [& bases]

   258     (let [[super interfaces] (get-super-and-interfaces bases)

   259           pname (proxy-name super interfaces)]

   260       (or (RT/loadClassForName pname)

   261           (let [[cname bytecode] (generate-proxy super interfaces)]

   262             (. ^DynamicClassLoader (deref clojure.lang.Compiler/LOADER) (defineClass pname bytecode [super interfaces]))))))

   263 

   264 (defn construct-proxy

   265   "Takes a proxy class and any arguments for its superclass ctor and

   266   creates and returns an instance of the proxy."

   267   {:added "1.0"}

   268   [c & ctor-args]

   269     (. Reflector (invokeConstructor c (to-array ctor-args))))

   270 

   271 (defn init-proxy

   272   "Takes a proxy instance and a map of strings (which must

   273   correspond to methods of the proxy superclass/superinterfaces) to

   274   fns (which must take arguments matching the corresponding method,

   275   plus an additional (explicit) first arg corresponding to this, and

   276   sets the proxy's fn map."

   277   {:added "1.0"}

   278   [^IProxy proxy mappings]

   279     (. proxy (__initClojureFnMappings mappings)))

   280 

   281 (defn update-proxy

   282   "Takes a proxy instance and a map of strings (which must

   283   correspond to methods of the proxy superclass/superinterfaces) to

   284   fns (which must take arguments matching the corresponding method,

   285   plus an additional (explicit) first arg corresponding to this, and

   286   updates (via assoc) the proxy's fn map. nil can be passed instead of

   287   a fn, in which case the corresponding method will revert to the

   288   default behavior. Note that this function can be used to update the

   289   behavior of an existing instance without changing its identity."

   290   {:added "1.0"}

   291   [^IProxy proxy mappings]

   292     (. proxy (__updateClojureFnMappings mappings)))

   293 

   294 (defn proxy-mappings

   295   "Takes a proxy instance and returns the proxy's fn map."

   296   {:added "1.0"}

   297   [^IProxy proxy]

   298     (. proxy (__getClojureFnMappings)))

   299 

   300 (defmacro proxy

   301   "class-and-interfaces - a vector of class names

   302 

   303   args - a (possibly empty) vector of arguments to the superclass

   304   constructor.

   305 

   306   f => (name [params*] body) or

   307   (name ([params*] body) ([params+] body) ...)

   308 

   309   Expands to code which creates a instance of a proxy class that

   310   implements the named class/interface(s) by calling the supplied

   311   fns. A single class, if provided, must be first. If not provided it

   312   defaults to Object.

   313 

   314   The interfaces names must be valid interface types. If a method fn

   315   is not provided for a class method, the superclass methd will be

   316   called. If a method fn is not provided for an interface method, an

   317   UnsupportedOperationException will be thrown should it be

   318   called. Method fns are closures and can capture the environment in

   319   which proxy is called. Each method fn takes an additional implicit

   320   first arg, which is bound to 'this. Note that while method fns can

   321   be provided to override protected methods, they have no other access

   322   to protected members, nor to super, as these capabilities cannot be

   323   proxied."

   324   {:added "1.0"}

   325   [class-and-interfaces args & fs]

   326    (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %)))) 

   327                     class-and-interfaces)

   328          [super interfaces] (get-super-and-interfaces bases)

   329          compile-effect (when *compile-files*

   330                           (let [[cname bytecode] (generate-proxy super interfaces)]

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

   332          pc-effect (apply get-proxy-class bases)

   333          pname (proxy-name super interfaces)]

   334      ;remember the class to prevent it from disappearing before use

   335      (intern *ns* (symbol pname) pc-effect)

   336      `(let [;pc# (get-proxy-class ~@class-and-interfaces)

   337             p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)]   

   338         (init-proxy p#

   339          ~(loop [fmap {} fs fs]

   340             (if fs

   341               (let [[sym & meths] (first fs)

   342                     meths (if (vector? (first meths))

   343                             (list meths)

   344                             meths)

   345                     meths (map (fn [[params & body]]

   346                                    (cons (apply vector 'this params) body))

   347                                meths)]

   348                 (if-not (contains? fmap (name sym))		  

   349                 (recur (assoc fmap (name sym) (cons `fn meths)) (next fs))

   350 		           (throw (IllegalArgumentException.

   351 			              (str "Method '" (name sym) "' redefined")))))

   352               fmap)))

   353         p#)))

   354 

   355 (defn proxy-call-with-super [call this meth]

   356  (let [m (proxy-mappings this)]

   357     (update-proxy this (assoc m meth nil))

   358     (let [ret (call)]

   359       (update-proxy this m)

   360       ret)))

   361 

   362 (defmacro proxy-super 

   363   "Use to call a superclass method in the body of a proxy method. 

   364   Note, expansion captures 'this"

   365   {:added "1.0"}

   366   [meth & args]

   367  `(proxy-call-with-super (fn [] (. ~'this ~meth ~@args))  ~'this ~(name meth)))

   368 

   369 (defn bean

   370   "Takes a Java object and returns a read-only implementation of the

   371   map abstraction based upon its JavaBean properties."

   372   {:added "1.0"}

   373   [^Object x]

   374   (let [c (. x (getClass))

   375 	pmap (reduce (fn [m ^java.beans.PropertyDescriptor pd]

   376 			 (let [name (. pd (getName))

   377 			       method (. pd (getReadMethod))]

   378 			   (if (and method (zero? (alength (. method (getParameterTypes)))))

   379 			     (assoc m (keyword name) (fn [] (clojure.lang.Reflector/prepRet (. method (invoke x nil)))))

   380 			     m)))

   381 		     {}

   382 		     (seq (.. java.beans.Introspector

   383 			      (getBeanInfo c)

   384 			      (getPropertyDescriptors))))

   385 	v (fn [k] ((pmap k)))

   386         snapshot (fn []

   387                    (reduce (fn [m e]

   388                              (assoc m (key e) ((val e))))

   389                            {} (seq pmap)))]

   390     (proxy [clojure.lang.APersistentMap]

   391            []

   392       (containsKey [k] (contains? pmap k))

   393       (entryAt [k] (when (contains? pmap k) (new clojure.lang.MapEntry k (v k))))

   394       (valAt ([k] (v k))

   395 	     ([k default] (if (contains? pmap k) (v k) default)))

   396       (cons [m] (conj (snapshot) m))

   397       (count [] (count pmap))

   398       (assoc [k v] (assoc (snapshot) k v))

   399       (without [k] (dissoc (snapshot) k))

   400       (seq [] ((fn thisfn [plseq]

   401 		  (lazy-seq

   402                    (when-let [pseq (seq plseq)]

   403                      (cons (new clojure.lang.MapEntry (first pseq) (v (first pseq)))

   404                            (thisfn (rest pseq)))))) (keys pmap))))))

   405 

   406 

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