source: trunk/abcl/contrib/jss/invoke.lisp @ 13283

Last change on this file since 13283 was 13283, checked in by Mark Evenson, 11 years ago

Removed dependency on jscheme.jar. Now standalone!

Needs substantial testing, vigorous pruning of orphaned code, and
optimization of "new" calling procedures (especially the memoization
facility of INVOKE-FIND-METHOD.

File size: 29.4 KB
Line 
1;; invoke.lisp v1.0
2;;
3;; Copyright (C) 2005 Alan Ruttenberg
4;;
5;; Since most of this code is derivative of the Jscheme System, it is
6;; licensed under the same terms, namely:
7
8;; This software is provided 'as-is', without any express or
9;; implied warranty.
10
11;; In no event will the author be held liable for any damages
12;; arising from the use of this software.
13
14;; Permission is granted to anyone to use this software for any
15;; purpose, including commercial applications, and to alter it
16;; and redistribute it freely, subject to the following
17;; restrictions:
18
19;; 1. The origin of this software must not be misrepresented; you
20;;    must not claim that you wrote the original software. If you
21;;    use this software in a product, an acknowledgment in the
22;;    product documentation would be appreciated but is not
23;;    required.
24
25;; 2. Altered source versions must be plainly marked as such, and
26;;    must not be misrepresented as being the original software.
27
28;; 3. This notice may not be removed or altered from any source
29;;    distribution.
30
31;; This file uses invoke.java from jscheme
32;; (http://jscheme.sourceforge.net/jscheme/src/jsint/Invoke.java).
33;; The easiest way to use it is to download
34;; http://jscheme.sourceforge.net/jscheme/lib/jscheme.jar
35;; and add it to the classpath in the file that invokes abcl.
36
37;; Invoke.java  effectively implements dynamic dispatch of java methods. This
38;; is used to make it real easy, if perhaps less efficient, to write
39;; java code since you don't need to be bothered with imports, or with
40;; figuring out which method to call.  The only time that you need to
41;; know a class name is when you want to call a static method, or a
42;; constructor, and in those cases, you only need to know enough of
43;; the class name that is unique wrt to the classes on your classpath.
44;;
45;; Java methods look like this: #"toString". Java classes are
46;; represented as symbols, which are resolved to the appropriate java
47;; class name. When ambiguous, you need to be more specific. A simple example:
48
49;; (let ((sw (new 'StringWriter)))
50;;   (#"write" sw "Hello ")
51;;   (#"write" sw "World")
52;;   (print (#"toString" sw)))
53
54;; What's happened here? First, all the classes in all the jars in the classpath have
55;; been collected.  For each class a.b.C.d, we have recorded that
56;; b.c.d, b.C.d, C.d, c.d, and d potentially refer to this class. In
57;; your call to new, as long as the symbol can refer to only one class, we use that
58;; class. In this case, it is java.io.StringWriter. You could also have written
59;; (new 'io.stringwriter), (new '|io.StringWriter|), (new 'java.io.StringWriter)...
60
61;; the call (#"write" sw "Hello "), uses the code in invoke.java to
62;; call the method named "write" with the arguments sw and "Hello
63;; ". Invoke.java figures out the right java method to call, and calls
64;; it.
65
66;; If you want to do a raw java call, use #0"toString". Raw calls
67;; return their results as java objects, avoiding doing the usual java
68;; object to lisp object conversions that abcl does.
69
70;; (with-constant-signature ((name jname raw?)*) &body body)
71;; binds a macro which expands to a jcall, promising that the same method
72;; will be called every time. Use this if you are making a lot of calls and
73;; want to avoid the overhead of a the dynamic dispatch.
74;; e.g. (with-constant-signature ((tostring "toString"))
75;;        (time (dotimes (i 10000) (tostring "foo"))))
76;; runs about 3x faster than (time (dotimes (i 10000) (#"toString" "foo")))
77;;
78;; (with-constant-signature ((tostring "toString" t)) ...) will cause the
79;; toString to be a raw java call. see get-all-jar-classnames below for an example.
80;;
81;; Implementation is that the first time the function is called, the
82;; method is looked up based on the arguments passed, and thereafter
83;; that method is called directly.  Doesn't work for static methods at
84;; the moment (lazy)
85;;
86;; (japropos string) finds all class names matching string
87;; (jcmn class-name) lists the names of all methods for the class
88;;
89;; TODO
90;;   - Use a package other than common-lisp-user
91;;   - Make with-constant-signature work for static methods too.
92;;   - #2"toString" to work like function scoped (with-constant-signature ((tostring "toString")) ...)
93;;   - #3"toString" to work like runtime scoped (with-constant-signature ((tostring "toString")) ...)
94;;      (both probably need compiler support to work)
95;;   - Maybe get rid of second " in reader macro. #"toString looks nicer, but might
96;;     confuse lisp mode.
97;;   - write jmap, analogous to map, but can take java collections, java arrays etc.
98;;   - write loop clauses for java collections.
99;;   - Register classes in .class files below classpath directories (when :wild-inferiors works)
100;;   - Make documentation like Edi Weitz
101;;
102;; Thanks: Peter Graves, Jscheme developers, Mike Travers for skij, 
103;; Andras Simon for jfli-abcl which bootstrapped me and taught me how to do
104;; get-all-jar-classnames
105;;
106
107;; changelog
108
109;; Sat January 28, 2006, alanr:
110
111;; Change imports strategy. Only index by last part of class name,
112;; case insensitive. Make the lookup-class-name logic be a bit more
113;; complicated. This substantially reduces the time it takes to do the
114;; auto imports and since class name lookup is relatively infrequent,
115;; and in any case cached, this doesn't effect run time speed.  (did
116;; try caching, but didn't pay - more time was spent reading and
117;; populating large hash table)
118;;
119;; Split class path by ";" in addition to ":" for windows.
120;;
121;; Tested on windows, linux.
122
123;; 2011-05-21 Mark Evenson
124;;   "ported" to native ABCL without needing the jscheme.jar or bsh-2.0b4.jar
125
126(in-package :jss)
127
128;; invoke takes it's arguments in a java array. In order to not cons
129;; one up each time, but to be thread safe, we allocate a static array
130;; of such arrays and save them in threadlocal storage. I'm lazy and
131;; so I just assume you will never call a java method with more than
132;; *max-java-method-args*. Fix this if it is a problem for you. We
133;; don't need to worry about reentrancy as the array is used only
134;; between when we call invoke and when invoke calls the actual
135;; function you care about.
136
137(defvar *max-java-method-args* 20 "Increase if you call java methods with more than 20 arguments")
138
139(defun argvs ()
140  (let ((get (load-time-value (jmethod (jclass "java.lang.ThreadLocal") "get")))
141  (argvs (load-time-value (jnew (jconstructor "java.lang.ThreadLocal"))))
142  (null (load-time-value (make-immediate-object nil :ref))))
143    (let ((res (jcall-raw get argvs)))
144      (if (equal res null)
145    (let ((it (jnew-array "java.lang.Object" *max-java-method-args*)))
146      (dotimes (i *max-java-method-args*)
147        (setf (jarray-ref it i) (jnew-array "java.lang.Object" i)))
148      (jcall (jmethod (jclass "java.lang.ThreadLocal") "set" "java.lang.Object")
149       argvs it)
150      it)
151    res))))
152
153
154(eval-when (:compile-toplevel :load-toplevel :execute)
155  (defvar *do-auto-imports* t))
156
157(defvar *imports-resolved-classes* (make-hash-table :test 'equal))
158
159
160(defun find-java-class (name)
161  (jclass (maybe-resolve-class-against-imports name)))
162
163(defmacro invoke-add-imports (&rest imports)
164  "push these imports onto the search path. If multiple, earlier in list take precedence"
165  `(eval-when (:compile-toplevel :load-toplevel :execute)
166     (clrhash *imports-resolved-classes*)
167     (dolist (i (reverse ',imports))
168       (setq *imports-resolved-classes* (delete i *imports-resolved-classes* :test 'equal))
169       )))
170
171(defun clear-invoke-imports ()
172  (clrhash *imports-resolved-classes*))
173
174(defun maybe-resolve-class-against-imports (classname)
175  (or (gethash classname *imports-resolved-classes*)
176      (let ((found (lookup-class-name classname)))
177  (if found
178      (progn 
179        (setf (gethash classname *imports-resolved-classes*) found)
180        found)
181      (string classname)))))
182
183(defvar *class-name-to-full-case-insensitive* (make-hash-table :test 'equalp))
184
185;; This is the function that calls invoke to call your java method. The first argument is the
186;; method name or 'new. The second is the object you are calling it on, followed by the rest of the
187;; arguments. If the "object" is a symbol, then that symbol is assumed to be a java class, and
188;; a static method on the class is called, otherwise a regular method is called.
189
190(defun invoke (method object &rest args)
191    (invoke-restargs method object args))
192
193(eval-when (:compile-toplevel :load-toplevel :execute)
194  (defvar *invoke-methods*
195    (load-time-value (jcall (jmethod "java.lang.Class" "getMethods" ) (jclass "jsint.Invoke")))))
196
197(defun invoke-restargs (method object args &optional (raw? nil))
198  (let* ((object-as-class-name 
199          (if (symbolp object) (maybe-resolve-class-against-imports object)))
200         (object-as-class 
201          (if object-as-class-name (find-java-class object-as-class-name))))
202    (if (eq method 'new)
203        (apply #'jnew (or object-as-class-name object) args)
204        (if raw?
205            (if (symbolp object)
206                (apply #'jstatic-raw method object-as-class  args)
207                (apply #'jcall-raw method object  args))
208            (if (symbolp object)
209                (apply #'jstatic method object-as-class args)
210                (apply #'jcall method object args))))))
211
212;;; Method name --> Object --> jmethod
213;;;
214(defvar *methods-cache* (make-hash-table :test #'equal))
215
216(defun get-jmethod (method object) 
217  (when (gethash method *methods-cache*)
218    (gethash 
219     (if (symbolp object) (lookup-class-name object) (jobject-class object))
220     (gethash method *methods-cache*))))
221
222(defun set-jmethod (method object jmethod) 
223  (unless (gethash method *methods-cache*)
224    (setf (gethash method *methods-cache*) (make-hash-table :test #'equal)))
225  (setf 
226   (gethash 
227    (if (symbolp object) (lookup-class-name object) (jobject-class object))
228    (gethash method *methods-cache*))
229   jmethod))
230
231(defparameter *last-invoke-find-method-args* nil)
232;;; TODO optimize me!
233(defun invoke-find-method (method object args)
234  (setf *last-invoke-find-method-args* (list method object args))
235  (let ((jmethod (get-jmethod method object)))
236    (unless jmethod
237      (setf jmethod 
238            (if (symbolp object)
239                ;;; static method
240                (apply #'jmethod (lookup-class-name object) 
241                       method (mapcar #'jobject-class args))
242                  ;;; instance method
243                (apply #'jresolve-method 
244                       method object args)))
245      (jcall "setAccessible" jmethod +true+)
246      (set-jmethod method object jmethod))
247    jmethod))
248
249;; This is the reader macro for java methods. it translates the method
250;; into a lambda form that calls invoke. Which is nice because you
251;; can, e.g. do this: (mapcar #"toString" list-of-java-objects). The reader
252;; macro takes one arg. If 0, then jstatic-raw is called, so that abcl doesn't
253;; automagically convert the returned java object into a lisp object. So
254;; #0"toString" returns a java.lang.String object, where as #"toString" returns
255;; a regular lisp string as abcl converts the java string to a lisp string.
256
257
258(eval-when (:compile-toplevel :load-toplevel :execute)
259  (defpackage lambdas (:use))
260  (defvar *lcount* 0))
261
262(eval-when (:compile-toplevel :load-toplevel :execute)
263  (defun read-invoke (stream char arg) 
264    (unread-char char stream)
265    (let ((name (read stream)))
266      (let ((object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet
267            (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)))
268        `(lambda (,object-var &rest ,args-var) 
269           (invoke-restargs ,name  ,object-var ,args-var ,(eql arg 0))))))
270  (set-dispatch-macro-character #\# #\" 'read-invoke))
271
272(defmacro with-constant-signature (fname-jname-pairs &body body)
273  (if (null fname-jname-pairs)
274      `(progn ,@body)
275      (destructuring-bind ((fname jname &optional raw) &rest ignore) fname-jname-pairs
276  (declare (ignore ignore))
277  (let ((varname (gensym)))
278    `(let ((,varname nil))
279       (macrolet ((,fname (&rest args)
280        `(if ,',varname
281             (if ,',raw
282           (jcall-raw ,',varname ,@args)
283           (jcall ,',varname ,@args))
284             (progn
285         (setq ,',varname (invoke-find-method ,',jname ,(car args) (list ,@(rest args))))
286         (if ,',raw
287             (jcall-raw ,',varname ,@args)
288             (jcall ,',varname ,@args))))))
289         (with-constant-signature ,(cdr fname-jname-pairs)
290     ,@body)))))))
291
292(defun lookup-class-name (name)
293  (setq name (string name))
294  (let* (;; cant (last-name-pattern (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$"))
295   ;; reason: bootstrap - the class name would have to be looked up...
296   (last-name-pattern (load-time-value (jstatic (jmethod "java.util.regex.Pattern" "compile"
297                     (jclass "java.lang.String"))
298                  (jclass "java.util.regex.Pattern") 
299                  ".*?([^.]*)$")))
300
301   (last-name 
302    (let ((matcher (#0"matcher" last-name-pattern name)))
303      (#"matches" matcher)
304      (#"group" matcher 1))))
305    (let* ((bucket (gethash last-name *class-name-to-full-case-insensitive*))
306     (bucket-length (length bucket)))
307      (or (find name bucket :test 'equalp)
308    (flet ((matches-end (end full test)
309       (= (+ (or (search end full :from-end t :test test) -10)
310       (length end))
311          (length full)))
312     (ambiguous (choices)
313       (error "Ambiguous class name: ~a can be ~{~a~^, ~}" name choices)))
314      (if (zerop bucket-length)
315    name
316    (let ((matches (loop for el in bucket when (matches-end name el 'char=) collect el)))
317      (if (= (length matches) 1)
318          (car matches)
319          (if (= (length matches) 0)
320        (let ((matches (loop for el in bucket when (matches-end name el 'char-equal) collect el)))
321          (if (= (length matches) 1)
322        (car matches)
323        (if (= (length matches) 0)
324            name
325            (ambiguous matches))))
326        (ambiguous matches))))))))))
327
328(defun get-all-jar-classnames (jar-file-name)
329  (let* ((jar (jnew (jconstructor "java.util.jar.JarFile" (jclass "java.lang.String")) (namestring (truename jar-file-name))))
330         (entries (#"entries" jar)))
331    (with-constant-signature ((matcher "matcher" t) (substring "substring")
332            (jreplace "replace" t) (jlength "length")
333            (matches "matches") (getname "getName" t)
334            (next "nextElement" t) (hasmore "hasMoreElements")
335            (group "group"))
336      (loop while (hasmore entries)
337   for name =  (getname (next entries))
338   with class-pattern = (#"compile" '|java.util.regex.Pattern| "[^$]*\\.class$")
339   with name-pattern = (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$")
340   when (matches (matcher class-pattern name))
341   collect
342     (let* ((fullname (substring (jreplace name #\/ #\.) 0 (- (jlength name) 6)))
343      (matcher (matcher name-pattern fullname))
344      (name (progn (matches matcher) (group matcher 1))))
345       (cons name fullname))
346   ))))
347
348(defun jar-import (file)
349  (when (probe-file file)
350    (loop for (name . full-class-name) in (get-all-jar-classnames file)
351       do 
352   (pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*) 
353      :test 'equal))))
354
355(defun new (class-name &rest args)
356  (invoke-restargs 'new class-name args))
357
358(defvar *running-in-osgi* (ignore-errors (jclass "org.osgi.framework.BundleActivator")))
359
360
361(defun get-java-field (object field &optional (try-harder *running-in-osgi*))
362  (if try-harder
363      (let* ((class (if (symbolp object)
364      (setq object (find-java-class object))
365          (if (equal "java.lang.Class" (jclass-name (jobject-class object)) )
366        object
367      (jobject-class object))))
368       (jfield (if (java-object-p field)
369       field
370           (find field (#"getDeclaredFields" class) :key 'jfield-name :test 'equal))))
371  (#"setAccessible" jfield t)
372  (values (#"get" jfield object) jfield))
373    (if (symbolp object)
374  (let ((class (find-java-class object)))
375          (jfield class field)
376        (jfield field object)))))
377
378;; use #"getSuperclass" and #"getInterfaces" to see whether there are fields in superclasses that we might set
379(defun set-java-field (object field value &optional (try-harder *running-in-osgi*))
380  (if try-harder
381      (let* ((class (if (symbolp object)
382      (setq object (find-java-class object))
383          (if (equal "java.lang.Class" (jclass-name (jobject-class object)) )
384        object
385      (jobject-class object))))
386       (jfield (if (java-object-p field)
387       field
388           (find field (#"getDeclaredFields" class) :key 'jfield-name :test 'equal))))
389  (#"setAccessible" jfield t)
390  (values (#"set" jfield object value) jfield))
391    (if (symbolp object)
392  (let ((class (find-java-class object)))
393    (#"pokeStatic" 'invoke class field value))
394      (#"poke" 'invoke object field value))))
395
396(defconstant +for-name+ 
397  (jmethod "java.lang.Class" "forName" "java.lang.String" "boolean" "java.lang.ClassLoader"))
398
399(defconstant +true+
400  (make-immediate-object t :boolean))
401
402(defun find-java-class (name)
403  (or (jstatic +for-name+ "java.lang.Class" 
404               (maybe-resolve-class-against-imports name) +true+ java::*classloader*)
405      (ignore-errors (jclass (maybe-resolve-class-against-imports name)))))
406
407(defmethod print-object ((obj (jclass "java.lang.Class")) stream) 
408  (print-unreadable-object (obj stream :identity nil)
409    (format stream "java class ~a" (jclass-name obj))))
410
411(defmethod print-object ((obj (jclass "java.lang.reflect.Method")) stream) 
412  (print-unreadable-object (obj stream :identity nil)
413    (format stream "method ~a" (#"toString" obj))))
414
415(defun do-auto-imports ()
416  (flet ((import-class-path (cp)
417     (map nil
418    (lambda(s) 
419      (setq s (jcall "toString" s))
420      (when *load-verbose*
421        (format t ";Importing ~a~%" s))
422      (cond 
423        ((file-directory-p s) )
424        ((equal (pathname-type s) "jar")
425         (jar-import (merge-pathnames (jcall "toString" s) (format nil "~a/" (jstatic "getProperty" "java.lang.System" "user.dir")))))))
426   
427    (jcall "split" cp (string (jstatic "peekStatic" '|jsint.Invoke| (jclass "java.io.File") "pathSeparatorChar")))
428    )))
429    (import-class-path (jcall "getClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|)))
430    (import-class-path (jcall "getBootClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|)))
431    ))
432
433(eval-when (:load-toplevel :execute)
434  (when *do-auto-imports* 
435    (do-auto-imports)))
436
437(defun japropos (string)
438  (setq string (string string))
439  (let ((matches nil))
440    (maphash (lambda(key value) 
441         (declare (ignore key))
442         (loop for class in value
443      when (search string class :test 'string-equal)
444        do (pushnew (list class "Java Class") matches :test 'equal)))
445       *class-name-to-full-case-insensitive*)
446    (loop for (match type) in (sort matches 'string-lessp :key 'car)
447   do (format t "~a: ~a~%" match type))
448    ))
449
450(defun jclass-method-names (class &optional full)
451  (if (java-object-p class)
452      (if (equal (jclass-name (jobject-class class)) "java.lang.Class")
453    (setq class (jclass-name class))
454    (setq class (jclass-name (jobject-class class)))))
455  (union
456   (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getMethods" (find-java-class class))) :test 'equal)
457   (ignore-errors (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getConstructors" (find-java-class class))) :test 'equal))))
458
459(defun jcmn (class &optional full)
460  (if full 
461      (dolist (method (jclass-method-names class t))
462  (format t "~a~%" method))
463      (jclass-method-names class)))
464
465(defun path-to-class (classname)
466  (let ((full (lookup-class-name classname)))
467    (#"toString" 
468     (#"getResource" 
469      (find-java-class full)
470      (concatenate 'string "/" (substitute #\/ #\. full) ".class")))))
471
472;; http://www.javaworld.com/javaworld/javaqa/2003-07/02-qa-0725-classsrc2.html
473
474(defun all-loaded-classes ()
475  (let ((classes-field 
476   (find "classes" (#"getDeclaredFields" (jclass "java.lang.ClassLoader"))
477         :key #"getName" :test 'equal)))
478    (#"setAccessible" classes-field t)
479    (loop for classloader in (mapcar #'first (dump-classpath))
480   append
481   (loop with classesv = (#"get" classes-field classloader)
482      for i below (#"size" classesv)
483      collect (#"getName" (#"elementAt" classesv i)))
484   append
485   (loop with classesv = (#"get" classes-field (#"getParent" classloader))
486      for i below (#"size" classesv)
487      collect (#"getName" (#"elementAt" classesv i))))))
488   
489
490;; Modifiy this from Java.java to add a lisp defined classloader.
491;;     private static Class classForName(String className) throws ClassNotFoundException
492;;     {
493;;         try {
494;;             return Class.forName(className);
495;;         }
496;;         catch (ClassNotFoundException e) {
497;;             return Class.forName(className, true, JavaClassLoader.getPersistentInstance());
498;;         }
499;;     }
500;; http://www.javaworld.com/javaworld/jw-10-1996/jw-10-indepth-p2.html
501
502(defvar *added-to-classpath* nil)
503
504(defvar *inhibit-add-to-classpath* nil)
505
506(defun add-to-classpath (path &optional force)
507  (unless *inhibit-add-to-classpath*
508;;;    (ensure-dynamic-classpath)
509;;;    (clear-invoke-imports)
510    (let ((absolute (namestring (truename path))))
511;;       (when (not (equal (pathname-type absolute) (pathname-type path)))
512;;  (warn "HEY! ~a, ~a ~a, ~a" path (pathname-type path) absolute (pathname-type absolute))
513;;  (setq @ (list path absolute)))
514      ;; NOTE: for jar files, specified as a component, the ".jar" is part of the pathname-name :(
515      (when (or force (not (member absolute *added-to-classpath* :test 'equalp)))
516;;; (#"addClassPath" *classpath-manager* (new 'java.net.url (#"replaceAll" (#"replaceAll" (concatenate 'string "file://" absolute) "\\\\" "/") "C:" "")))
517;;; (#"setClassLoader" '|jsint.Import| (#"getBaseLoader" *classpath-manager*))
518; (format t "path=~a type=~a~%"  absolute (pathname-type absolute))
519        (java:add-to-classpath path)
520  (cond ((equal (pathname-type absolute) "jar")
521         (jar-import absolute))
522        ((file-directory-p absolute)
523         (classfiles-import absolute)))
524  (push absolute *added-to-classpath*)))))
525
526(defun get-dynamic-class-path ()
527  (dump-classpath)
528#+nil
529  (map 'list (lambda(el) 
530         (let ((path (#"toString" el)))
531     (if (eql (search "file:/" path) 0)
532         (subseq path 5)
533         path)))
534       (#"getPathComponents" (#"getClassPath" *classpath-manager*))))
535
536#+nil
537(eval-when (:load-toplevel :execute)
538  (maybe-install-bsh-classloader))
539
540
541
542; http://java.sun.com/j2se/1.5.0/docs/api/java/lang/management/MemoryMXBean.html
543; http://java.sun.com/docs/hotspot/gc/
544; http://www.javaworld.com/javaworld/jw-01-2002/jw-0111-hotspotgc-p2.html
545; http://java.sun.com/docs/hotspot/VMOptions.html
546; http://java.sun.com/docs/hotspot/gc5.0/gc_tuning_5.html
547; http://java.sun.com/docs/hotspot/gc1.4.2/faq.html
548; http://java.sun.com/developer/technicalArticles/Programming/turbo/
549;-XX:MinFreeHeapRatio=
550;-XX:MaxHeapFreeRatio=
551;-XX:NewRatio=
552;-XX:SurvivorRatio=
553;-XX:SoftRefLRUPolicyMSPerMB=10000
554;-XX:+PrintTenuringDistribution
555;-XX:MaxLiveObjectEvacuationRatio
556
557
558(defun java-gc ()
559  (#"gc" (#"getRuntime" 'java.lang.runtime))
560  (#"runFinalization" (#"getRuntime" 'java.lang.runtime))
561  (#"gc" (#"getRuntime" 'java.lang.runtime))
562  (java-room))
563
564(defun java-room ()
565  (let ((rt (#"getRuntime" 'java.lang.runtime)))
566    (values (- (#"totalMemory" rt) (#"freeMemory" rt))
567     (#"totalMemory" rt)
568     (#"freeMemory" rt)
569     (list :used :total :free))))
570
571(defun verbose-gc (&optional (new-value nil new-value-supplied))
572  (if new-value-supplied
573      (progn (#"setVerbose" (#"getMemoryMXBean"  'java.lang.management.ManagementFactory) new-value) new-value)
574      (#"isVerbose" (#"getMemoryMXBean"  'java.lang.management.ManagementFactory))))
575
576(defun all-jars-below (directory) 
577  (loop with q = (system:list-directory directory) 
578     while q for top = (pop q)
579     if (null (pathname-name top)) do (setq q (append q (all-jars-below top))) 
580     if (equal (pathname-type top) "jar") collect top))
581
582(defun all-classfiles-below (directory) 
583  (loop with q = (system:list-directory directory) 
584     while q for top = (pop q)
585     if (null (pathname-name top)) do (setq q (append q (all-classfiles-below top ))) 
586     if (equal (pathname-type top) "class")
587     collect top
588     ))
589
590(defun all-classes-below-directory (directory)
591  (loop for file in (all-classfiles-below directory) collect
592       (format nil "~{~a.~}~a"
593         (subseq (pathname-directory file) (length (pathname-directory directory)))
594         (pathname-name file))
595       ))
596
597(defun classfiles-import (directory)
598  (setq directory (truename directory))
599  (loop for full-class-name in (all-classes-below-directory directory)
600       for name = (#"replaceAll" full-class-name "^.*\\." "")
601     do
602       (pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*) 
603    :test 'equal)))
604
605(defun add-directory-jars-to-class-path (directory recursive-p)
606  (if recursive-p
607      (loop for jar in (all-jars-below directory) do (add-to-classpath jar))
608      (loop for jar in (directory (merge-pathnames "*.jar" directory)) do (add-to-classpath jar))))
609
610(defun need-to-add-directory-jar? (directory recursive-p)
611  (if recursive-p
612      (loop for jar in (all-jars-below directory)
613   do
614     (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal))
615         (return-from need-to-add-directory-jar? t)))
616      (loop for jar in (directory (merge-pathnames "*.jar" directory))
617   do
618     (if (not (member (namestring (truename jar)) *added-to-classpath* :test 'equal))
619         (return-from need-to-add-directory-jar? t))))
620  nil)
621
622(defun set-to-list (set)
623  (declare (optimize (speed 3) (safety 0)))
624  (with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next"))
625    (loop with iterator = (iterator set)
626       while (hasNext iterator)
627       for item = (next iterator)
628       collect item)))
629
630(defun list-to-list (list)
631  (declare (optimize (speed 3) (safety 0)))
632  (with-constant-signature ((isEmpty "isEmpty") (getfirst "getFirst")
633          (getNext "getNext"))
634    (loop until (isEmpty list)
635       collect (getFirst list)
636       do (setq list (getNext list)))))
637
638;; Contribution of Luke Hope. (Thanks!)
639
640(defun iterable-to-list (iterable)
641 (declare (optimize (speed 3) (safety 0)))
642 (let ((it (#"iterator" iterable)))
643   (with-constant-signature ((hasmore "hasMoreElements")
644           (next "nextElement"))
645     (loop while (hasmore it)
646  collect (next it)))))
647
648(defun vector-to-list (vector)
649 (declare (optimize (speed 3) (safety 0)))
650 (with-constant-signature ((hasmore "hasMoreElements")
651         (next "nextElement"))
652     (loop while (hasmore vector)
653  collect (next vector))))
654
655(defun hashmap-to-hashtable (hashmap &rest rest &key (keyfun #'identity) (valfun #'identity) (invert? nil)
656            table 
657             &allow-other-keys )
658  (let ((keyset (#"keySet" hashmap))
659  (table (or table (apply 'make-hash-table
660        (loop for (key value) on rest by #'cddr
661           unless (member key '(:invert? :valfun :keyfun :table)) 
662           collect key and collect value)))))
663    (with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next"))
664      (loop with iterator = (iterator keyset)
665   while (hasNext iterator)
666   for item = (next iterator)
667   do (if invert?
668    (setf (gethash (funcall valfun (#"get" hashmap item)) table) (funcall keyfun item))
669    (setf (gethash (funcall keyfun item) table) (funcall valfun (#"get" hashmap item)))))
670    table)))
671     
672(defun jclass-all-interfaces (class)
673  "Return a list of interfaces the class implements"
674  (unless (java-object-p class)
675    (setq class (find-java-class class)))
676  (loop for aclass = class then (#"getSuperclass" aclass)
677     while aclass
678     append (coerce (#"getInterfaces" aclass) 'list)))
679
680(defun safely (f name)
681  (let ((fname (gensym)))
682    (compile fname
683       `(lambda(&rest args)
684    (with-simple-restart (top-level
685              "Return from lisp method implementation for ~a." ,name)
686      (apply ,f args))))
687    (symbol-function fname)))
688
689(defun jdelegating-interface-implementation (interface dispatch-to &rest method-names-and-defs)
690  "Creates and returns an implementation of a Java interface with
691   methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
692
693   INTERFACE is an interface
694
695   DISPATCH-TO is an existing Java object
696
697   METHOD-NAMES-AND-DEFS is an alternating list of method names
698   (strings) and method definitions (closures).
699
700   For missing methods, a dummy implementation is provided that
701   calls the method on DISPATCH-TO"
702  (let ((implemented-methods
703         (loop for m in method-names-and-defs
704      for i from 0
705      if (evenp i) 
706      do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m
707      else
708      do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))) 
709#+nil   (null (make-immediate-object nil :ref)))
710    (let ((safe-method-names-and-defs 
711     (loop for (name function) on method-names-and-defs by #'cddr
712        collect name collect (safely function name))))
713      (loop for method across
714     (jclass-methods interface :declared nil :public t)
715     for method-name = (jmethod-name method)
716     when (not (member method-name implemented-methods :test #'string=))
717     do
718     (let* ((def  `(lambda
719           (&rest args)
720         (invoke-restargs ,(jmethod-name method) ,dispatch-to args t)
721         )))
722       (push (coerce def 'function) safe-method-names-and-defs)
723       (push method-name safe-method-names-and-defs)))
724      (apply #'java::%jnew-proxy  interface safe-method-names-and-defs))))
725
726
727(defun java-exception-report (condition)
728  (if (and (typep condition 'java-exception)
729     (java-exception-cause condition)
730     (equal (jclass-name (jobject-class (java-exception-cause condition)))
731      "jsint.BacktraceException"))
732      (with-output-to-string (s)
733  (let ((writer (new 'stringwriter)))
734    (#"printStackTrace" (#"getBaseException"(java-exception-cause condition)) (new 'printwriter writer))
735    (write-string (#"replaceFirst" (#"toString" writer) "(?s)\\s*at sun.reflect.*" "") s))
736  )
737      (#"replaceFirst" (princ-to-string condition) "(?s)\\\\s*at jsint.E.*" "")))
738
Note: See TracBrowser for help on using the repository browser.