3 ;; Copyright (C) 2005 Alan Ruttenberg
5 ;; Since most of this code is derivative of the Jscheme System, it is
6 ;; licensed under the same terms, namely:
8 ;; This software is provided 'as-is', without any express or
11 ;; In no event will the author be held liable for any damages
12 ;; arising from the use of this software.
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
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
25 ;; 2. Altered source versions must be plainly marked as such, and
26 ;; must not be misrepresented as being the original software.
28 ;; 3. This notice may not be removed or altered from any source
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.
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.
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:
49 ;; (let ((sw (new 'StringWriter)))
50 ;; (#"write" sw "Hello ")
51 ;; (#"write" sw "World")
52 ;; (print (#"toString" sw)))
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)...
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
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.
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")))
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.
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
86 ;; (japropos string) finds all class names matching string
87 ;; (jcmn class-name) lists the names of all methods for the class
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
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
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
109 ;; Sat January 28, 2006, alanr:
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)
119 ;; Split class path by ";" in addition to ":" for windows.
121 ;; Tested on windows, linux.
123 (in-package :cl-user
)
125 ;; invoke takes it's arguments in a java array. In order to not cons
126 ;; one up each time, but to be thread safe, we allocate a static array
127 ;; of such arrays and save them in threadlocal storage. I'm lazy and
128 ;; so I just assume you will never call a java method with more than
129 ;; *max-java-method-args*. Fix this if it is a problem for you. We
130 ;; don't need to worry about reentrancy as the array is used only
131 ;; between when we call invoke and when invoke calls the actual
132 ;; function you care about.
134 (defvar *max-java-method-args
* 20 "Increase if you call java methods with more than 20 arguments")
137 (let ((get (load-time-value (jmethod (jclass "java.lang.ThreadLocal") "get")))
138 (argvs (load-time-value (jnew (jconstructor "java.lang.ThreadLocal"))))
139 (null (load-time-value (make-immediate-object nil
:ref
))))
140 (let ((res (jcall-raw get argvs
)))
142 (let ((it (jnew-array "java.lang.Object" *max-java-method-args
*)))
143 (dotimes (i *max-java-method-args
*)
144 (setf (jarray-ref it i
) (jnew-array "java.lang.Object" i
)))
145 (jcall (jmethod (jclass "java.lang.ThreadLocal") "set" "java.lang.Object")
151 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
152 (defvar *do-auto-imports
* t
))
154 (defvar *imports-resolved-classes
* (make-hash-table :test
'equal
))
155 (defvar *classpath-manager
* nil
)
158 (defun find-java-class (name)
159 (jclass (maybe-resolve-class-against-imports name
)))
161 (defmacro invoke-add-imports
(&rest imports
)
162 "push these imports onto the search path. If multiple, earlier in list take precedence"
163 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
164 (clrhash *imports-resolved-classes
*)
165 (dolist (i (reverse ',imports
))
166 (setq *imports-resolved-classes
* (delete i
*imports-resolved-classes
* :test
'equal
))
169 (defun clear-invoke-imports ()
170 (clrhash *imports-resolved-classes
*))
172 (defun maybe-resolve-class-against-imports (classname)
173 (or (gethash classname
*imports-resolved-classes
*)
174 (let ((found (lookup-class-name classname
)))
177 (setf (gethash classname
*imports-resolved-classes
*) found
)
179 (string classname
)))))
181 (defvar *class-name-to-full-case-insensitive
* (make-hash-table :test
'equalp
))
183 ;; This is the function that calls invoke to call your java method. The first argument is the
184 ;; method name or 'new. The second is the object you are calling it on, followed by the rest of the
185 ;; arguments. If the "object" is a symbol, then that symbol is assumed to be a java class, and
186 ;; a static method on the class is called, otherwise a regular method is called.
188 (defun invoke (method object
&rest args
)
189 (invoke-restargs method object args
))
191 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
192 (defvar *invoke-methods
*
193 (load-time-value (jcall (jmethod "java.lang.Class" "getMethods" ) (jclass "jsint.Invoke")))))
195 (defun invoke-restargs (method object args
&optional
(raw? nil
))
197 ((no-args (load-time-value (jnew-array "java.lang.Object" 0)))
198 (invoke-class (load-time-value (jclass "jsint.Invoke")))
199 (ic (load-time-value (find "invokeConstructor" *invoke-methods
* :key
'jmethod-name
:test
'equal
)))
200 (is (load-time-value (find "invokeStatic" *invoke-methods
* :key
'jmethod-name
:test
'equal
)))
201 (ii (load-time-value (find "invokeInstance" *invoke-methods
* :key
'jmethod-name
:test
'equal
)))
202 (true (load-time-value (make-immediate-object t
:boolean
)))
203 (false (load-time-value (make-immediate-object nil
:boolean
))))
205 ;; these two lookups happen before argv is filled, because they themselves call invoke.)
206 (object-as-class-name (if (symbolp object
) (maybe-resolve-class-against-imports object
)))
207 (object-as-class (if object-as-class-name
(find-java-class object-as-class-name
)))
209 (declare (optimize (speed 3) (safety 0)))
210 (let ((argv (if (null (the list args
))
212 (let ((argv (jarray-ref-raw (argvs) (length (the list args
))))
215 (setf (jarray-ref argv
(incf (the fixnum i
)))
216 (if (eq arg t
) true
(if (eq arg nil
) false arg
))))
220 (jstatic-raw ic invoke-class object-as-class-name argv
))
223 (jstatic-raw is invoke-class object-as-class method argv
)
224 (jstatic-raw ii invoke-class object method argv true
))
226 (jstatic is invoke-class object-as-class method argv
)
227 (jstatic ii invoke-class object method argv true
)
230 ;; (defconstant no-args (load-time-value (jnew-array "java.lang.Object" 0)))
231 ;; (defconstant invoke-class (load-time-value (jclass "jsint.Invoke")))
232 ;; (defconstant ic (load-time-value (find "invokeConstructor" *invoke-methods* :key 'jmethod-name :test 'equal)))
233 ;; (defconstant is (load-time-value (find "invokeStatic" *invoke-methods* :key 'jmethod-name :test 'equal)))
234 ;; (defconstant ii (load-time-value (find "invokeInstance" *invoke-methods* :key 'jmethod-name :test 'equal)))
235 ;; (defconstant true (load-time-value (make-immediate-object t :boolean)))
236 ;; (defconstant false (load-time-value (make-immediate-object nil :boolean)))
238 ;; (defun invoke-restargs (method object args &optional (raw? nil))
239 ;; (let* (;; these two lookups happen before argv is filled, because they themselves call invoke.
240 ;; (object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object)))
241 ;; (object-as-class (if object-as-class-name (find-java-class object-as-class-name)))
243 ;; (declare (optimize (speed 3) (safety 0)))
244 ;; (let ((argv (if (null args)
246 ;; (let ((argv (jarray-ref-raw (argvs) (length args)))
248 ;; (dolist (arg args)
249 ;; (setf (jarray-ref argv (incf (the fixnum i)))
250 ;; (if (eq arg t) true (if (eq arg nil) false arg))))
252 ;; (if (eq method 'new)
254 ;; (jstatic-raw ic invoke-class object-as-class-name argv))
256 ;; (if (symbolp object)
257 ;; (jstatic-raw is invoke-class object-as-class method argv)
258 ;; (jstatic-raw ii invoke-class object method argv true))
259 ;; (if (symbolp object)
260 ;; (jstatic is invoke-class object-as-class method argv)
261 ;; (jstatic ii invoke-class object method argv true)
264 (defun invoke-find-method (method object args
)
265 (let* ((no-args (load-time-value (jnew-array "java.lang.Object" 0)))
266 (invoke-class (load-time-value (jclass "jsint.Invoke")))
267 (ifm (load-time-value (jmethod (jclass "jsint.Invoke") "findMethod" (jclass "[Ljava.lang.Object;") (jclass "[Ljava.lang.Object;"))))
268 (imt (load-time-value (find "methodTable" *invoke-methods
* :key
'jmethod-name
:test
'equal
)))
269 (true (load-time-value (make-immediate-object t
:boolean
)))
270 (false (load-time-value (make-immediate-object nil
:boolean
))))
271 (let ((args (if (null args
)
273 (let ((argv (jarray-ref-raw (argvs) (length args
)))
276 (setf (jarray-ref argv
(incf i
))
277 (if (eq arg t
) true
(if (eq arg nil
) false arg
))))
280 (jstatic ifm invoke-class
(jstatic-raw imt invoke-class
(lookup-class-name object
) method true true
) args
)
281 (jstatic ifm invoke-class
(jstatic-raw imt invoke-class
(jobject-class object
) method false true
) args
)))))
284 ;; This is the reader macro for java methods. it translates the method
285 ;; into a lambda form that calls invoke. Which is nice because you
286 ;; can, e.g. do this: (mapcar #"toString" list-of-java-objects). The reader
287 ;; macro takes one arg. If 0, then jstatic-raw is called, so that abcl doesn't
288 ;; automagically convert the returned java object into a lisp object. So
289 ;; #0"toString" returns a java.lang.String object, where as #"toString" returns
290 ;; a regular lisp string as abcl converts the java string to a lisp string.
293 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
294 (defpackage lambdas
(:use
))
297 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
298 (defun read-invoke (stream char arg
)
299 (unread-char char stream
)
300 (let ((name (read stream
)))
301 (if (and arg
(eql (abs arg
) 1))
302 (let ((cell (intern (format nil
"G~a" (incf *lcount
*)) 'lambdas
))) ; work around bug that gensym here errors when compiling
303 (proclaim `(special ,cell
))
305 `(lambda (object &rest args
)
306 (declare (optimize (speed 3) (safety 0)))
307 (if (boundp ',cell
) ;costing me 10% here because I can't force cell to be bound and hence do null test.
310 (if (null (cdr (the cons args
)))
312 `(jcall-static ,cell object
(car (the cons args
)))
313 `(jcall ,cell object
(car (the cons args
))))
315 `(apply 'jcall-static
,cell object
(the list args
))
316 `(apply 'jcall
,cell object
(the list args
)))))
318 (setq ,cell
(invoke-find-method ,name object args
))
320 `(apply 'jcall-static
,cell object args
)
321 `(apply 'jcall
,cell object args
))))))
322 `(lambda (object &rest args
)
323 (invoke-restargs ,name object args
,(eql arg
0))))))
324 (set-dispatch-macro-character #\
# #\" 'read-invoke
))
326 (defmacro with-constant-signature
(fname-jname-pairs &body body
)
327 (if (null fname-jname-pairs
)
329 (destructuring-bind ((fname jname
&optional raw
) &rest ignore
) fname-jname-pairs
330 (declare (ignore ignore
))
331 (let ((varname (gensym)))
332 `(let ((,varname nil
))
333 (macrolet ((,fname
(&rest args
)
336 (jcall-raw ,',varname
,@args
)
337 (jcall ,',varname
,@args
))
339 (setq ,',varname
(invoke-find-method ,',jname
,(car args
) (list ,@(rest args
))))
341 (jcall-raw ,',varname
,@args
)
342 (jcall ,',varname
,@args
))))))
343 (with-constant-signature ,(cdr fname-jname-pairs
)
346 (defun lookup-class-name (name)
347 (setq name
(string name
))
348 (let* (;; cant (last-name-pattern (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$"))
349 ;; reason: bootstrap - the class name would have to be looked up...
350 (last-name-pattern (load-time-value (jstatic (jmethod "java.util.regex.Pattern" "compile"
351 (jclass "java.lang.String"))
352 (jclass "java.util.regex.Pattern")
356 (let ((matcher (#0"matcher" last-name-pattern name
)))
358 (#"group" matcher
1))))
359 (let* ((bucket (gethash last-name
*class-name-to-full-case-insensitive
*))
360 (bucket-length (length bucket
)))
361 (or (find name bucket
:test
'equalp
)
362 (flet ((matches-end (end full test
)
363 (= (+ (or (search end full
:from-end t
:test test
) -
10)
367 (error "Ambiguous class name: ~a can be ~{~a~^, ~}" name choices
)))
368 (if (zerop bucket-length
)
370 (let ((matches (loop for el in bucket when
(matches-end name el
'char
=) collect el
)))
371 (if (= (length matches
) 1)
373 (if (= (length matches
) 0)
374 (let ((matches (loop for el in bucket when
(matches-end name el
'char-equal
) collect el
)))
375 (if (= (length matches
) 1)
377 (if (= (length matches
) 0)
379 (ambiguous matches
))))
380 (ambiguous matches
))))))))))
382 (defun get-all-jar-classnames (jar-file-name)
383 (let* ((jar (jnew (jconstructor "java.util.jar.JarFile" (jclass "java.lang.String")) (namestring (truename jar-file-name
))))
384 (entries (#"entries" jar
)))
385 (with-constant-signature ((matcher "matcher" t
) (substring "substring")
386 (jreplace "replace" t
) (jlength "length")
387 (matches "matches") (getname "getName" t
)
388 (next "nextElement" t
) (hasmore "hasMoreElements")
390 (loop while
(hasmore entries
)
391 for name
= (getname (next entries
))
392 with class-pattern
= (#"compile" '|java.util.regex.Pattern|
"[^$]*\\.class$")
393 with name-pattern
= (#"compile" '|java.util.regex.Pattern|
".*?([^.]*)$")
394 when
(matches (matcher class-pattern name
))
396 (let* ((fullname (substring (jreplace name
#\
/ #\.
) 0 (- (jlength name
) 6)))
397 (matcher (matcher name-pattern fullname
))
398 (name (progn (matches matcher
) (group matcher
1))))
399 (cons name fullname
))
402 (defun jar-import (file)
403 (when (probe-file file
)
404 (loop for
(name . full-class-name
) in
(get-all-jar-classnames file
)
406 (pushnew full-class-name
(gethash name
*class-name-to-full-case-insensitive
*)
409 (defun new (class-name &rest args
)
410 (invoke-restargs 'new class-name args
))
412 (defun get-java-field (object field
&optional try-harder
)
414 (let* ((class (if (symbolp object
)
415 (setq object
(find-java-class object
))
416 (if (equal "java.lang.Class" (jclass-name (jobject-class object
)) )
418 (jobject-class object
))))
419 (jfield (if (java-object-p field
)
421 (find field
(#"getDeclaredFields" class
) :key
'jfield-name
:test
'equal
))))
422 (#"setAccessible" jfield t
)
423 (values (#"get" jfield object
) jfield
))
425 (let ((class (find-java-class object
)))
426 (#"peekStatic" 'invoke class field
))
427 (#"peek" 'invoke object field
))))
429 (defun set-java-field (object field value
&optional try-harder
)
431 (let* ((class (if (symbolp object
)
432 (setq object
(find-java-class object
))
433 (if (equal "java.lang.Class" (jclass-name (jobject-class object
)) )
435 (jobject-class object
))))
436 (jfield (if (java-object-p field
)
438 (find field
(#"getDeclaredFields" class
) :key
'jfield-name
:test
'equal
))))
439 (#"setAccessible" jfield t
)
440 (values (#"set" jfield object value
) jfield
))
442 (let ((class (find-java-class object
)))
443 (#"pokeStatic" 'invoke class field value
))
444 (#"poke" 'invoke object field value
))))
446 (defun find-java-class (name)
447 (if *classpath-manager
*
448 (#1"classForName" *classpath-manager
* (maybe-resolve-class-against-imports name
))
449 (jclass (maybe-resolve-class-against-imports name
))))
451 (defun do-auto-imports ()
452 (flet ((import-class-path (cp)
455 (setq s
(#"toString" s
))
457 (format t
";Importing ~a~%" s
))
459 ((file-directory-p s
) )
460 ((equal (pathname-type s
) "jar")
461 (jar-import (#"toString" s
)))))
463 (#"split" cp
(string (#"peekStatic" '|jsint.Invoke|
(jclass "java.io.File") "pathSeparatorChar")))
465 (import-class-path (#"getClassPath" (#"getRuntimeMXBean" '|java.lang.management.ManagementFactory|
)))
466 (import-class-path (#"getBootClassPath" (#"getRuntimeMXBean" '|java.lang.management.ManagementFactory|
)))
469 (eval-when (:load-toplevel
:execute
)
470 (when *do-auto-imports
*
473 (defun japropos (string)
474 (setq string
(string string
))
476 (maphash (lambda(key value
)
477 (declare (ignore key
))
478 (loop for class in value
479 when
(search string class
:test
'string-equal
)
480 do
(pushnew (list class
"Java Class") matches
:test
'equal
)))
481 *class-name-to-full-case-insensitive
*)
482 (loop for
(match type
) in
(sort matches
'string-lessp
:key
'car
)
483 do
(format t
"~a: ~a~%" match type
))
486 (defun jclass-method-names (class &optional full
)
487 (if (java-object-p class
)
488 (if (equal (jclass-name (jobject-class class
)) "java.lang.Class")
489 (setq class
(jclass-name class
))
490 (setq class
(jclass-name (jobject-class class
)))))
492 (remove-duplicates (map 'list
(if full
#"toString" 'jmethod-name
) (#"getMethods" (find-java-class class
))) :test
'equal
)
493 (ignore-errors (remove-duplicates (map 'list
(if full
#"toString" 'jmethod-name
) (#"getConstructors" (find-java-class class
))) :test
'equal
))))
495 (defun jcmn (class &optional full
)
497 (dolist (method (jclass-method-names class t
))
498 (format t
"~a~%" method
))
499 (jclass-method-names class
)))
501 (defun path-to-class (classname)
502 (let ((full (lookup-class-name classname
)))
505 (find-java-class full
)
506 (concatenate 'string
"/" (substitute #\
/ #\. full
) ".class")))))
508 ;; http://www.javaworld.com/javaworld/javaqa/2003-07/02-qa-0725-classsrc2.html
510 (defun all-loaded-classes ()
512 (find "classes" (#"getDeclaredFields" (jclass "java.lang.ClassLoader"))
513 :key
#"getName" :test
'equal
)))
514 (#"setAccessible" classes-field t
)
515 (loop for classloader in
516 (list* (#"getClassLoader" (jclass "org.armedbear.lisp.Lisp"))
517 (and *classpath-manager
* (list (#"getBaseLoader" *classpath-manager
*))))
519 (loop with classesv
= (#"get" classes-field classloader
)
520 for i below
(#"size" classesv
)
521 collect
(#"getName" (#"elementAt" classesv i
)))
523 (loop with classesv
= (#"get" classes-field
(#"getParent" classloader
))
524 for i below
(#"size" classesv
)
525 collect
(#"getName" (#"elementAt" classesv i
))))))
528 ;; Modifiy this from Java.java to add a lisp defined classloader.
529 ;; private static Class classForName(String className) throws ClassNotFoundException
532 ;; return Class.forName(className);
534 ;; catch (ClassNotFoundException e) {
535 ;; return Class.forName(className, true, JavaClassLoader.getPersistentInstance());
538 ;; http://www.javaworld.com/javaworld/jw-10-1996/jw-10-indepth-p2.html
540 (defvar *classpath-manager
* nil
)
542 (defvar *added-to-classpath
* nil
)
544 (defun maybe-install-bsh-classloader ()
545 (unless *classpath-manager
*
546 (when (ignore-errors (jclass "bsh.classpath.ClassManagerImpl"))
547 (let* ((urls (jnew-array "java.net.URL" 0))
548 (manager (new 'bsh.classpath.classmanagerimpl
))
549 (bshclassloader (new 'bshclassloader manager urls
)))
550 (#"setClassLoader" 'jsint.import bshclassloader
)
551 (setq *classpath-manager
* manager
)))))
553 (defun ensure-dynamic-classpath ()
554 (assert *classpath-manager
* () "Can't add to classpath unless bean shell jar is in your classpath"))
556 (defun add-to-classpath (path &optional force
)
557 (ensure-dynamic-classpath)
558 (clear-invoke-imports)
559 (let ((absolute (namestring (truename path
))))
560 (unless (and (not force
) (member absolute
*added-to-classpath
* :test
'equalp
))
561 (#"addClassPath" *classpath-manager
* (new 'java.net.url
(#"replaceAll" (#"replaceAll" (concatenate 'string
"file://" absolute
) "\\\\" "/") "C:" "")))
562 (#"setClassLoader" 'jsint.import
(#"getBaseLoader" *classpath-manager
*))
563 (cond ((equal (pathname-type path
) "jar")
565 ((file-directory-p path
)
566 (classfiles-import path
)))
567 (push absolute
*added-to-classpath
*))))
569 (defun get-dynamic-class-path ()
570 (ensure-dynamic-classpath)
571 (map 'list
(lambda(el)
572 (let ((path (#"toString" el
)))
573 (if (eql (search "file:/" path
) 0)
576 (#"getPathComponents" (#"getClassPath" *classpath-manager
*))))
578 (eval-when (:load-toplevel
:execute
)
579 (maybe-install-bsh-classloader))
583 ; http://java.sun.com/j2se/1.5.0/docs/api/java/lang/management/MemoryMXBean.html
584 ; http://java.sun.com/docs/hotspot/gc/
585 ; http://www.javaworld.com/javaworld/jw-01-2002/jw-0111-hotspotgc-p2.html
586 ; http://java.sun.com/docs/hotspot/VMOptions.html
587 ; http://java.sun.com/docs/hotspot/gc5.0/gc_tuning_5.html
588 ; http://java.sun.com/docs/hotspot/gc1.4.2/faq.html
589 ; http://java.sun.com/developer/technicalArticles/Programming/turbo/
590 ;-XX:MinFreeHeapRatio=
591 ;-XX:MaxHeapFreeRatio=
594 ;-XX:SoftRefLRUPolicyMSPerMB=10000
595 ;-XX:+PrintTenuringDistribution
596 ;-XX:MaxLiveObjectEvacuationRatio
600 (#"gc" (#"getRuntime" 'java.lang.runtime
))
601 (#"runFinalization" (#"getRuntime" 'java.lang.runtime
))
602 (#"gc" (#"getRuntime" 'java.lang.runtime
))
606 (let ((rt (#"getRuntime" 'java.lang.runtime
)))
607 (values (- (#"totalMemory" rt
) (#"freeMemory" rt
))
610 (list :used
:total
:free
))))
612 (defun verbose-gc (&optional
(new-value nil new-value-supplied
))
613 (if new-value-supplied
614 (progn (#"setVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory
) new-value
) new-value
)
615 (#"isVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory
))))
617 (defun all-jars-below (directory)
618 (loop with q
= (system:list-directory directory
)
619 while q for top
= (pop q
)
620 if
(null (pathname-name top
)) do
(setq q
(append q
(all-jars-below top
)))
621 if
(equal (pathname-type top
) "jar") collect top
))
623 (defun all-classfiles-below (directory)
624 (loop with q
= (system:list-directory directory
)
625 while q for top
= (pop q
)
626 if
(null (pathname-name top
)) do
(setq q
(append q
(all-classfiles-below top
)))
627 if
(equal (pathname-type top
) "class")
631 (defun all-classes-below-directory (directory)
632 (loop for file in
(all-classfiles-below directory
) collect
633 (format nil
"~{~a.~}~a"
634 (subseq (pathname-directory file
) (length (pathname-directory directory
)))
635 (pathname-name file
))
638 (defun classfiles-import (directory)
639 (setq directory
(truename directory
))
640 (loop for full-class-name in
(all-classes-below-directory directory
)
641 for name
= (#"replaceAll" full-class-name
"^.*\\." "")
643 (pushnew full-class-name
(gethash name
*class-name-to-full-case-insensitive
*)
646 (defun add-directory-jars-to-class-path (directory recursive-p
)
648 (loop for jar in
(all-jars-below directory
) do
(cl-user::add-to-classpath jar
))
649 (loop for jar in
(directory (merge-pathnames "*.jar" directory
)) do
(cl-user::add-to-classpath jar
))))
651 (defun set-to-list (set)
652 (declare (optimize (speed 3) (safety 0)))
653 (with-constant-signature ((iterator "iterator" t
) (hasnext "hasNext") (next "next"))
654 (loop with iterator
= (iterator set
)
655 while
(hasNext iterator
)
656 for item
= (next iterator
)
659 (defun list-to-list (list)
660 (declare (optimize (speed 3) (safety 0)))
661 (with-constant-signature ((isEmpty "isEmpty") (getfirst "getFirst")
663 (loop until
(isEmpty list
)
664 collect
(getFirst list
)
665 do
(setq list
(getNext list
)))))
667 ;; Contribution of Luke Hope. (Thanks!)
669 (defun iterable-to-list (iterable)
670 (declare (optimize (speed 3) (safety 0)))
671 (let ((it (#"iterator" iterable
)))
672 (with-constant-signature ((hasmore "hasMoreElements")
673 (next "nextElement"))
674 (loop while
(hasmore it
)
675 collect
(next it
)))))
677 (defun jclass-all-interfaces (class)
678 "Return a list of interfaces the class implements"
679 (unless (java-object-p class
)
680 (setq class
(find-java-class class
)))
681 (loop for aclass
= class then
(#"getSuperclass" aclass
)
683 append
(coerce (#"getInterfaces" aclass
) 'list
)))
685 (defun jdelegating-interface-implementation (interface dispatch-to
&rest method-names-and-defs
)
686 "Creates and returns an implementation of a Java interface with
687 methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
689 INTERFACE is an interface
691 DISPATCH-TO is an existing Java object
693 METHOD-NAMES-AND-DEFS is an alternating list of method names
694 (strings) and method definitions (closures).
696 For missing methods, a dummy implementation is provided that
697 calls the method on DISPATCH-TO"
698 (let ((implemented-methods
699 (loop for m in method-names-and-defs
702 do
(assert (stringp m
) (m) "Method names must be strings: ~s" m
) and collect m
704 do
(assert (or (symbolp m
) (functionp m
)) (m) "Methods must be function designators: ~s" m
)))
705 (null (make-immediate-object nil
:ref
)))
706 (loop for method across
707 (jclass-methods interface
:declared nil
:public t
)
708 for method-name
= (jmethod-name method
)
709 when
(not (member method-name implemented-methods
:test
#'string
=))
713 (cl-user::invoke-restargs
,(jmethod-name method
) ,dispatch-to args t
)
715 (push (coerce def
'function
) method-names-and-defs
)
716 (push method-name method-names-and-defs
)))
717 (apply #'java
::%jnew-proxy interface method-names-and-defs
)))
720 (defun java-exception-report (condition)
721 (if (and (typep condition
'java-exception
)
722 (java-exception-cause condition
)
723 (equal (jclass-name (jobject-class (java-exception-cause condition
)))
724 "jsint.BacktraceException"))
725 (with-output-to-string (s)
726 (let ((writer (new 'stringwriter
)))
727 (#"printStackTrace" (#"getBaseException"(java-exception-cause condition
)) (new 'printwriter writer
))
728 (write-string (#"replaceFirst" (#"toString" writer
) "(?s)\\s*at sun.reflect.*" "") s
))
730 (#"replaceFirst" (princ-to-string condition
) "(?s)\\\\s*at jsint.E.*" "")))
734 (defclass jar-directory
(static-file) ())
736 (defmethod perform ((operation compile-op
) (c jar-directory
))
737 (cl-user::add-directory-jars-to-class-path
(component-pathname c
) t
))
739 (defmethod perform ((operation load-op
) (c jar-directory
))
740 (cl-user::add-directory-jars-to-class-path
(component-pathname c
) t
))
742 (defmethod operation-done-p ((operation load-op
) (c jar-directory
))
745 (defmethod operation-done-p ((operation compile-op
) (c jar-directory
))
748 (defclass jar-file
(static-file) ())
750 (defmethod perform ((operation compile-op
) (c jar-file
))
751 (cl-user::add-to-classpath
(component-pathname c
)))
753 (defmethod perform ((operation load-op
) (c jar-file
))
754 (cl-user::add-to-classpath
(component-pathname c
)))
756 (defclass jar-file
(static-file) ())
758 (defmethod perform ((operation compile-op
) (c jar-file
))
759 (cl-user::add-to-classpath
(component-pathname c
)))
761 (defmethod perform ((operation load-op
) (c jar-file
))
762 (cl-user::add-to-classpath
(component-pathname c
)))
764 (defclass class-file-directory
(static-file) ())
766 (defmethod perform ((operation compile-op
) (c class-file-directory
))
767 (cl-user::add-to-classpath
(component-pathname c
)))
769 (defmethod perform ((operation load-op
) (c class-file-directory
))
770 (cl-user::add-to-classpath
(component-pathname c
)))
772 ;; ****************************************************************