[slime-devel] abcl special inspector support for java classes, methods, and other good stuff

[Russell McManus]

I hope the format is useable.

Thanks,
-russ

Index: swank-abcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-abcl.lisp,v
retrieving revision 1.63
diff -u -u -8 -p -r1.63 swank-abcl.lisp
--- swank-abcl.lisp	10 Jan 2009 12:25:16 -0000	1.63
+++ swank-abcl.lisp	1 Mar 2009 19:35:33 -0000
@@ -552,8 +552,89 @@ part of *sysdep-pathnames* in swank.load
 
 ;; WORKAROUND: call/initialize accessors at load time
 (let ((c (make-condition 'compiler-condition 
                           :original-condition nil
                           :severity ':note :message "" :location nil))
        (slots `(severity message short-message references location)))
    (dolist (slot slots)
      (funcall slot c)))
+
+;; special inspector support for java objects, methods, and classes
+
+(defun swank-backend::emacs-inspect-java-class (jclass)
+  (flet ((jclass->name (jclass)
+           (let* ((s (java:jclass-name jclass))
+                  (prefix "java.lang.")
+                  (lang-pos (search prefix s)))
+             (if lang-pos
+                 (subseq s (+ lang-pos (length prefix)))
+                 s))))
+    (append 
+     `(,(princ-to-string jclass) " is the Java class named "
+        ,(java:jclass-name jclass)
+        (:newline))
+     `("Constructors: " (:newline))
+     (loop for c across (java:jclass-constructors jclass)
+          for i = 0 then (1+ i)
+          append (let ((args (map 'list #'jclass->name (java:jconstructor-params c))))
+                   `(,(format nil "[~2D] ~{~A~^,~}: ~40T"
+                              i
+                              args)
+                      (:value ,c)
+                      (:newline))))
+     `("Methods" (:newline))
+     (loop for method across (java:jclass-methods jclass)
+        for i = 0 then (1+ i)
+        append (let ((args (mapcar #'jclass->name (coerce (java:jmethod-params method) 'list))))
+                 `(,(format nil "[~2D] ~A ~A(~{~A~^,~}): ~40T" 
+                            i 
+                            (jclass->name (java:jmethod-return-type method))
+                            (java:jmethod-name method)
+                            args)
+                    (:value ,method)
+                    (:newline)))))))
+
+(defun swank-backend::emacs-inspect-java-object (jobject)
+  (let* ((jclass (java:jobject-class jobject))
+         (fields (coerce (java:jclass-fields jclass) 'list)))
+    (append 
+     `(,(princ-to-string jobject) (:newline)
+        " is an instance of Java class " ,(java:jclass-name jclass) 
+        " (" (:value ,jclass) ")" (:newline))
+     `("Fields" (:newline))
+     (loop for field in fields 
+        for i = 0 then (1+ i)
+        append `(,(format nil "[~2D] ~20A : " i (java:jfield-name field)) 
+                  (:value ,(java:jcall (java:jmethod (java:jclass "java.lang.reflect.Field")
+                                           "get"
+                                           (java:jclass "java.lang.Object"))
+                                  field
+                                  jobject))
+                  (:newline))))))
+
+(defun swank-backend::emacs-inspect-java-method (jmethod)
+  (let ((return-type (java:jcall 
+                      (java:jmethod (java:jclass "java.lang.reflect.Method") "getReturnType")
+                      jmethod))
+        (args (coerce (java:jmethod-params jmethod) 'list)))
+    (setf args
+          (mapcar #'java:jclass-name args))
+    (append 
+     `("Java Method: " ,(java:jmethod-name jmethod) (:newline))
+     `("Return Type: " ,(java:jclass-name return-type) ": " (:value ,return-type) (:newline))
+     (if args
+         (append `("Arguments" (:newline))
+                 (loop for arg in args
+                    for i = 0 then (1+ i)
+                    append `(,(format nil "[~2D] ~20A : " i arg) (:value ,arg) (:newline))))
+         `("Arguments: none" (:newline))))))
+
+(defun swank-backend::emacs-inspect-java (java-object)
+  (flet ((is-a (class-name)
+           (java:jinstance-of-p java-object (java:jclass class-name))))
+    (cond ((is-a "java.lang.Class") 
+           (swank-backend::emacs-inspect-java-class java-object))
+          ((is-a "java.lang.reflect.Method")
+           (swank-backend::emacs-inspect-java-method java-object))
+          (t 
+           (swank-backend::emacs-inspect-java-object java-object)))))
+
Index: contrib/swank-fancy-inspector.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp,v
retrieving revision 1.16
diff -u -u -8 -p -r1.16 swank-fancy-inspector.lisp
--- contrib/swank-fancy-inspector.lisp	10 Jan 2009 10:09:47 -0000	1.16
+++ contrib/swank-fancy-inspector.lisp	1 Mar 2009 19:35:34 -0000
@@ -687,16 +687,20 @@ SPECIAL-OPERATOR groups."
                                      (position (file-position stream)))
                                     (lambda ()
                                       (ed-in-emacs `(,pathname :charpos ,position))))
                               :refreshp nil)
                      (:newline))
                    content)
           content))))
 
+#+abcl
+(defmethod emacs-inspect ((java-object java:java-object))
+  (swank-backend::emacs-inspect-java java-object))
+
 (defun common-seperated-spec (list &optional (callback (lambda (v) 
 							 `(:value ,v))))
   (butlast
    (loop
       for i in list
       collect (funcall callback i)
       collect ", ")))