diff -r 088cc188dc26 swank-abcl.lisp
--- a/swank-abcl.lisp	Sun Aug 02 14:57:23 2009 +0200
+++ b/swank-abcl.lisp	Mon Aug 03 15:37:15 2009 +0200
@@ -16,7 +16,8 @@
 
 (defun sys::break (&optional (format-control "BREAK called") 
                    &rest format-arguments)
-  (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls)))
+  (let ((*saved-backtrace* (sys:backtrace)))
+    (declare (ignore *saved-backtrace*))
     (with-simple-restart (continue "Return from BREAK.")
       (invoke-debugger
        (sys::%make-condition 'simple-condition
@@ -42,11 +43,24 @@
 
 ;(defun class-finalized-p (class) t)
 
-(defun slot-definition-documentation (slot) #+nil (documentation slot 't))
-(defun slot-definition-type (slot) t)
-(defun class-prototype (class))
-(defun generic-function-declarations (gf))
-(defun specializer-direct-methods (spec) (mop::class-direct-methods spec))
+(defun slot-definition-documentation (slot) 
+  (declare (ignore slot))
+  #+nil (documentation slot 't))
+
+(defun slot-definition-type (slot) 
+  (declare (ignore slot)) 
+  t)
+
+(defun class-prototype (class) 
+  (declare (ignore class))
+  nil)
+
+(defun generic-function-declarations (gf)
+  (declare (ignore gf))
+  nil)
+      
+(defun specializer-direct-methods (spec) 
+  (mop::class-direct-methods spec))
 
 (defun slot-definition-name (slot)
   (mop::%slot-definition-name slot))
@@ -61,9 +75,11 @@
   (mop::%method-function method))
 
 (defun slot-boundp-using-class (class object slotdef)
+  (declare (ignore class)) ; FIXME
   (system::slot-boundp object (slot-definition-name slotdef)))
 
 (defun slot-value-using-class (class object slotdef)
+  (declare (ignore class)) ; FIXME
   (system::slot-value object (slot-definition-name slotdef)))
 
 (import-to-swank-mop
@@ -119,7 +135,7 @@
 
 
 (defimplementation preferred-communication-style ()
-  nil)
+  :spawn)
 
 (defimplementation create-socket (host port)
   (ext:make-server-socket port))
@@ -212,7 +228,7 @@
   (nth-value 2 (function-lambda-expression function)))
 
 (defimplementation macroexpand-all (form)
-  (macroexpand form))
+  (ext:macroexpand-all form))
 
 (defimplementation describe-symbol-for-emacs (symbol)
   (let ((result '()))
@@ -256,26 +272,28 @@
 
 (defvar *sldb-topframe*)
 
-(defun backtrace-as-list-ignoring-swank-calls ()
-  (let ((list (ext:backtrace-as-list)))
-    (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1)))))
-
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
-  (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame)))
+  (let* ((+magic-token+ (intern "SWANK-DEBUGGER-HOOK" 'swank))
+         (*sldb-topframe* (second (member +magic-token+ (sys:backtrace)
+                                          :key #'(lambda (frame)
+                                                   (car (sys:frame-to-list frame)))))))
     (funcall debugger-loop-fn)))
 
+(defun backtrace (start end)
+  "Like SYS:BACKTRACE-AS-LIST but without initial SWANK frames."
+  (let ((backtrace (sys:backtrace)))
+    (subseq (or (member *sldb-topframe* backtrace) backtrace)
+            start end)))
+
 (defun nth-frame (index)
-  (nth index (backtrace-as-list-ignoring-swank-calls)))
+  (nth index (backtrace 0 nil)))
 
 (defimplementation compute-backtrace (start end)
   (let ((end (or end most-positive-fixnum)))
-    (loop for f in (subseq (backtrace-as-list-ignoring-swank-calls) start end)
-          collect f)))
+    (backtrace start end)))
 
 (defimplementation print-frame (frame stream)
-  (write-string (string-trim '(#\space #\newline)
-                             (prin1-to-string frame))
-                stream))
+  (write-string (sys:frame-to-string frame) stream))
 
 (defimplementation frame-locals (index)
   `(,(list :name "??" :id 0 :value "??")))
@@ -481,89 +499,199 @@
                     slots)))
 |#
 
+;;; Improved inspection of Java objects -- Orignally by Russel McManus
+(defmethod emacs-inspect ((java:java-object java:java-object))
+  ;; Not trusting ABCL's MOP discriminators, we use "old-fashioned" functions.
+  (emacs-inspect-java java:java-object))
+
+(defun emacs-inspect-java (java-object)
+  (flet ((jtypep (class-name)
+           (java:jinstance-of-p java-object (java:jclass class-name))))
+    (cond ((jtypep "java.lang.Class") 
+           (emacs-inspect-java-class java-object))
+          ((jtypep "java.lang.reflect.Method")
+           (emacs-inspect-java-method java-object))
+          ((jtypep "java.lang.Throwable")
+           (emacs-inspect-java-throwable java-object))
+          (t 
+           (emacs-inspect-java-object java-object)))))
+
+(defun 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 
+     `("Java Class: " ,(princ-to-string jclass) (: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 "~D: ~A ~A(~{~A~^,~}): ~&~4T" 
+                            i 
+                            (jclass->name (java:jmethod-return-type method))
+                            (java:jmethod-name method)
+                            args)
+                    (:value ,method)
+                    (:newline)))))))
+
+(defun emacs-inspect-java-object (jobject)
+  (let* ((jclass 
+          (java:jobject-class jobject))
+         (fields 
+          (coerce (java:jclass-fields jclass) 'list))
+         (to-string 
+          (or (java:jcall (java:jmethod (java:jclass "java.lang.Object") "toString") jobject)
+              "")))
+    (append 
+     `("Java Object: " ,(princ-to-string jobject) (:newline))
+     (when (> 0 (length to-string))
+       `("toString(): "  ,to-string (:newline)))
+     `("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 "~D: ~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 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 (lambda (arg)
+                    (java:jclass-name arg))
+                  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 "~D: ~20A : " i arg) 
+                                (:value ,arg) (:newline))))
+       `("Arguments: none" (:newline))))))
+
+(defun emacs-inspect-java-throwable (throwable)
+  (let ((message (java:jcall (java:jmethod (java:jclass "java.lang.Throwable")
+                                 "getMessage")
+                   throwable))
+        (cause (java:jcall (java:jmethod (java:jclass "java.lang.Throwable")
+                                 "getCause")
+                   throwable)))
+  (append 
+   (when message
+     `("getMessage(): " ,message (:newline)))
+   (when cause
+     `("getCause(): " ,cause (:newline)))
+   `,(emacs-inspect-java-object throwable))))
+        
+
 ;;;; Multithreading
 
-(defimplementation startup-multiprocessing ()
-  #+nil(mp:start-scheduler))
+(defimplementation spawn (fn &key name)
+  (threads:make-thread (lambda () (funcall fn)) :name name))
 
-(defimplementation spawn (fn &key name)
-  (ext:make-thread (lambda () (funcall fn)) :name name))
-
-(defvar *thread-props-lock* (ext:make-thread-lock))
-
-(defvar *thread-props* (make-hash-table) ; should be a weak table
+(defvar *thread-plists* (make-hash-table) ; should be a weak table
   "A hashtable mapping threads to a plist.")
 
 (defvar *thread-id-counter* 0)
 
 (defimplementation thread-id (thread)
-  (ext:with-thread-lock (*thread-props-lock*)
-    (or (getf (gethash thread *thread-props*) 'id)
-        (setf (getf (gethash thread *thread-props*) 'id)
+  (threads:synchronized-on *thread-plists*
+    (or (getf (gethash thread *thread-plists*) 'id)
+        (setf (getf (gethash thread *thread-plists*) 'id)
               (incf *thread-id-counter*)))))
 
 (defimplementation find-thread (id)
   (find id (all-threads) 
         :key (lambda (thread)
-                (getf (gethash thread *thread-props*) 'id))))
+                (getf (gethash thread *thread-plists*) 'id))))
 
 (defimplementation thread-name (thread)
-  (ext:thread-name thread))
+  (threads:thread-name thread))
 
 (defimplementation thread-status (thread)
-  (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
+  (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
+
+;; XXX should be a weak hash table
+(defparameter *thread-description-map* (make-hash-table)) 
+
+(defimplementation thread-description (thread) 
+  (synchronized-on *thread-description-map*
+    (or (gethash thread *thread-description-map*)
+        "No description available.")))
+
+(defimplementation set-thread-description (thread description) 
+  (synchronized-on *thread-description-map*
+    (setf (gethash thread *thread-description-map*) description)))
 
 (defimplementation make-lock (&key name)
-  (ext:make-thread-lock))
+  (declare (ignore name))
+  (threads:make-thread-lock))
 
 (defimplementation call-with-lock-held (lock function)
-  (ext:with-thread-lock (lock) (funcall function)))
+  (threads:with-thread-lock (lock) (funcall function)))
 
 (defimplementation current-thread ()
-  (ext:current-thread))
+  (threads:current-thread))
 
 (defimplementation all-threads ()
-  (copy-list (ext:mapcar-threads #'identity)))
+  (copy-list (threads:mapcar-threads #'identity)))
+
+(defimplementation thread-alive-p (thread)
+  (member thread (all-threads)))
 
 (defimplementation interrupt-thread (thread fn)
-  (ext:interrupt-thread thread fn))
+  (threads:interrupt-thread thread fn)) 
 
 (defimplementation kill-thread (thread)
-  (ext:destroy-thread thread))
+  (threads:destroy-thread thread))
 
 (defstruct mailbox 
-  (mutex (ext:make-mutex))
   (queue '()))
 
 (defun mailbox (thread)
   "Return THREAD's mailbox."
-  (ext:with-thread-lock (*thread-props-lock*)
-    (or (getf (gethash thread *thread-props*) 'mailbox)
-        (setf (getf (gethash thread *thread-props*) 'mailbox)
+  (threads:synchronized-on *thread-plists*
+    (or (getf (gethash thread *thread-plists*) 'mailbox)
+        (setf (getf (gethash thread *thread-plists*) 'mailbox)
               (make-mailbox)))))
 
-(defimplementation send (thread object)
+(defimplementation send (thread message)
   (let ((mbox (mailbox thread)))
-    (ext:with-mutex ((mailbox-mutex mbox))
+    (threads:synchronized-on mbox
       (setf (mailbox-queue mbox) 
-            (nconc (mailbox-queue mbox) (list message))))))
+            (nconc (mailbox-queue mbox) (list message)))
+      (threads:object-notify-all mbox))))
 
-#+(or)
-(defimplementation receive-if (thread &optional timeout)
+(defimplementation receive-if (test &optional timeout)
   (let* ((mbox (mailbox (current-thread))))
     (assert (or (not timeout) (eq timeout t)))
     (loop
      (check-slime-interrupts)
-     (ext:with-mutex ((mailbox-mutex mbox))
+     (threads:synchronized-on mbox
        (let* ((q (mailbox-queue mbox))
               (tail (member-if test q)))
          (when tail 
            (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
-           (return (car tail))))
+           (return (car tail)))
        (when (eq timeout t) (return (values nil t)))
-       ;;(java:jcall (java:jmethod "java.lang.Object" "wait") 
-       ;;            (mailbox-mutex mbox) 1000)
-       ))))
+       (threads:object-wait mbox 0.3))))))
 
 (defimplementation quit-lisp ()
   (ext:exit))
