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))