From heller at common-lisp.net Wed Aug 9 16:34:15 2006 From: heller at common-lisp.net (heller) Date: Wed, 9 Aug 2006 12:34:15 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060809163415.243DE2102F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv32656 Modified Files: swank-backend.lisp Log Message: (definterface): Bring the old implementation based on NO-APPLICABLE-METHOD back. --- /project/slime/cvsroot/slime/swank-backend.lisp 2006/04/12 08:43:55 1.98 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2006/08/09 16:34:15 1.99 @@ -113,7 +113,10 @@ Backends implement these functions using DEFIMPLEMENTATION." (check-type documentation string "a documentation string") (flet ((gen-default-impl () - `(defmethod ,name ,args , at default-body))) + `(defmethod no-applicable-method ((_gf (eql #',name)) &rest _rargs) + (declare (ignore _)) + (destructuring-bind ,args rargs + , at default-body)))) `(progn (defgeneric ,name ,args (:documentation ,documentation)) (pushnew ',name *interface-functions*) ,(if (null default-body) @@ -125,12 +128,13 @@ ',name))) (defmacro defimplementation (name args &body body) - `(progn (defmethod ,name ,args , at body) - (if (member ',name *interface-functions*) - (setq *unimplemented-interfaces* - (remove ',name *unimplemented-interfaces*)) - (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) - ',name)) + `(progn + (defmethod ,name ,args , at body) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) + ',name)) (defun warn-unimplemented-interfaces () "Warn the user about unimplemented backend features. @@ -724,7 +728,7 @@ (definterface make-default-inspector () "Return an inspector object suitable for passing to inspect-for-emacs.") -(definterface inspect-for-emacs (object inspector) +(defgeneric inspect-for-emacs (object inspector) "Explain to Emacs how to inspect OBJECT. The argument INSPECTOR is an object representing how to get at From heller at common-lisp.net Wed Aug 9 16:46:10 2006 From: heller at common-lisp.net (heller) Date: Wed, 9 Aug 2006 12:46:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060809164610.DD55F2608B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2301 Modified Files: swank.lisp Log Message: (test-print-arglist): Print a message instead of signalling an error. This should avoid startup problems (in particular with CormanLisp). (setup-stream-indirection): Disable it for now. We should fix it, if there is need for this functionality or just remove it. --- /project/slime/cvsroot/slime/swank.lisp 2006/07/24 14:01:15 1.387 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/09 16:46:10 1.388 @@ -944,13 +944,17 @@ ;;;;; Global redirection setup -(setup-stream-indirection *standard-output*) -(setup-stream-indirection *error-output*) -(setup-stream-indirection *trace-output*) -(setup-stream-indirection *standard-input*) -(setup-stream-indirection *debug-io*) -(setup-stream-indirection *query-io*) -(setup-stream-indirection *terminal-io*) +;; FIXME: This doesn't work with Allegros IDE (MAKE-SYNONYM-STREAM +;; doesn't work with their GUI-streams). Maybe we should just drop this +;; global redirection stuff. +;; +;; (setup-stream-indirection *standard-output*) +;; (setup-stream-indirection *error-output*) +;; (setup-stream-indirection *trace-output*) +;; (setup-stream-indirection *standard-input*) +;; (setup-stream-indirection *debug-io*) +;; (setup-stream-indirection *query-io*) +;; (setup-stream-indirection *terminal-io*) (defparameter *standard-output-streams* '(*standard-output* *error-output* *trace-output*) @@ -2227,18 +2231,23 @@ :print-right-margin print-right-margin :highlight highlight)) -(defun test-print-arglist (list string) - (string= (arglist-to-string list (find-package :swank)) string)) +(defun test-print-arglist () + (flet ((test (list string) + (let* ((p (find-package :swank)) + (actual (arglist-to-string list p))) + (unless (string= actual string) + (format *debug-io* + "Test failed: ~S => ~S~% Expected: ~S" + list actual string))))) + (test '(function cons) "(function cons)") + (test '(quote cons) "(quote cons)") + (test '(&key (function #'+)) "(&key (function #'+))") + (test '(&whole x y z) "(y z)") + (test '(x &aux y z) "(x)") + (test '(x &environment env y) "(x y)") + (test '(&key ((function f))) "(&key ((function f)))"))) -;; Should work: -(progn - (assert (test-print-arglist '(function cons) "(function cons)")) - (assert (test-print-arglist '(quote cons) "(quote cons)")) - (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))")) - (assert (test-print-arglist '(&whole x y z) "(y z)")) - (assert (test-print-arglist '(x &aux y z) "(x)")) - (assert (test-print-arglist '(x &environment env y) "(x y)")) - (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))) +(test-print-arglist) ;;;; Recording and accessing results of computations From heller at common-lisp.net Wed Aug 9 16:53:41 2006 From: heller at common-lisp.net (heller) Date: Wed, 9 Aug 2006 12:53:41 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060809165341.981272B153@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2666 Modified Files: slime.el Log Message: (slime-find-filename-translators): CL:MACHINE-INSTANCE can return nil. Silently accept that case for now. --- /project/slime/cvsroot/slime/slime.el 2006/07/24 14:01:03 1.635 +++ /project/slime/cvsroot/slime/slime.el 2006/08/09 16:53:41 1.636 @@ -165,9 +165,7 @@ :type 'hook :group 'slime-lisp) -(defcustom slime-filename-translations '(("" - identity - identity)) +(defcustom slime-filename-translations nil "Alist of mappings between machine names and filename translation functions. Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). @@ -184,10 +182,6 @@ understand as a filename (this string will be passed to find-file). -The default value of the variable, ((\"\" identity identity)), -simply passes the name unchanged and is fine if emacs and the -lisp share the same file system. - This list will be traversed in order, so multiple matching regexps are possible. @@ -411,7 +405,7 @@ :type '(character) :group 'slime-repl) -(defcustom slime-repl-enable-presentations +(defcustom slime-repl-enable-presentations (cond ((and (not (featurep 'xemacs)) (= emacs-major-version 20)) ;; mouseable text sucks in Emacs 20 nil) @@ -1305,9 +1299,11 @@ filename)) (defun slime-find-filename-translators (hostname) - (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname)) - slime-filename-translations)) - (error "No filename-translations for hostname: %s" hostname))) + (cond ((and hostname slime-filename-translations) + (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname)) + slime-filename-translations)) + (error "No filename-translations for hostname: %s" hostname))) + (t (list #'identity #'identity)))) (defun slime-make-tramp-file-name (username remote-host lisp-filename) "Old (with multi-hops) tramp compatability function" @@ -8421,6 +8417,7 @@ (defun slime-thread-quit () (interactive) + (slime-eval-async `(swank:quit-thread-browser)) (kill-buffer (current-buffer))) (defun slime-thread-kill () From heller at common-lisp.net Wed Aug 9 16:55:48 2006 From: heller at common-lisp.net (heller) Date: Wed, 9 Aug 2006 12:55:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060809165548.ADADD2B153@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2885 Modified Files: swank-lispworks.lisp Log Message: (inspect-for-emacs): Don't use defimplementation here. --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/03/22 16:40:01 1.83 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/08/09 16:55:48 1.84 @@ -632,19 +632,19 @@ (defimplementation make-default-inspector () (make-instance 'lispworks-inspector)) -(defimplementation inspect-for-emacs ((o t) (inspector lispworks-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector lispworks-inspector)) (declare (ignore inspector)) (lispworks-inspect o)) -(defimplementation inspect-for-emacs ((o function) - (inspector lispworks-inspector)) +(defmethod inspect-for-emacs ((o function) + (inspector lispworks-inspector)) (declare (ignore inspector)) (lispworks-inspect o)) ;; FIXME: slot-boundp-using-class in LW works with names so we can't ;; use our method in swank.lisp. -(defimplementation inspect-for-emacs ((o standard-object) - (inspector lispworks-inspector)) +(defmethod inspect-for-emacs ((o standard-object) + (inspector lispworks-inspector)) (declare (ignore inspector)) (lispworks-inspect o)) From heller at common-lisp.net Wed Aug 9 17:01:13 2006 From: heller at common-lisp.net (heller) Date: Wed, 9 Aug 2006 13:01:13 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060809170113.681333200A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4501 Modified Files: swank-scl.lisp swank-corman.lisp swank-cmucl.lisp swank-abcl.lisp swank-openmcl.lisp Log Message: (inspect-for-emacs): Don't use defimplementation for real generics. --- /project/slime/cvsroot/slime/swank-scl.lisp 2006/06/11 11:02:08 1.8 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2006/08/09 17:01:13 1.9 @@ -1744,7 +1744,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defimplementation inspect-for-emacs ((o t) (inspector scl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector scl-inspector)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) --- /project/slime/cvsroot/slime/swank-corman.lisp 2006/04/18 07:47:09 1.7 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2006/08/09 17:01:13 1.8 @@ -402,7 +402,7 @@ collect (funcall callback e) collect ", "))) -(defimplementation inspect-for-emacs ((class standard-class) +(defmethod inspect-for-emacs ((class standard-class) (inspector corman-inspector)) (declare (ignore inspector)) (values "A class." @@ -441,7 +441,7 @@ '("#")) (:newline)))) -(defimplementation inspect-for-emacs ((slot cons) (inspector corman-inspector)) +(defmethod inspect-for-emacs ((slot cons) (inspector corman-inspector)) ;; Inspects slot definitions (declare (ignore corman-inspector)) (if (eq (car slot) :name) @@ -460,7 +460,7 @@ (:newline))) (call-next-method))) -(defimplementation inspect-for-emacs ((pathname pathnames::pathname-internal) +(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal) inspector) (declare (ignore inspector)) (values (if (wild-pathname-p pathname) @@ -478,7 +478,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defimplementation inspect-for-emacs ((o t) (inspector corman-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector corman-inspector)) (cond ((cl::structurep o) (inspect-structure o)) (t (call-next-method)))) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/03/22 16:40:01 1.160 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/08/09 17:01:13 1.161 @@ -1863,7 +1863,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defimplementation inspect-for-emacs ((o t) (inspector cmucl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector cmucl-inspector)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) --- /project/slime/cvsroot/slime/swank-abcl.lisp 2006/06/10 03:27:03 1.38 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2006/08/09 17:01:13 1.39 @@ -435,7 +435,7 @@ #| -(defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector abcl-inspector)) (let* ((class (class-of o)) (slots (mop::class-slots class))) (values (format nil "~A~% is a ~A" o class) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/04/20 09:11:11 1.108 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/09 17:01:13 1.109 @@ -741,7 +741,7 @@ (string (gethash typecode *value2tag*)) (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) -(defimplementation inspect-for-emacs ((o t) (inspector openmcl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector openmcl-inspector)) (declare (ignore inspector)) (let* ((i (inspector::make-inspector o)) (count (inspector::compute-line-count i)) From heller at common-lisp.net Wed Aug 9 17:03:19 2006 From: heller at common-lisp.net (heller) Date: Wed, 9 Aug 2006 13:03:19 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060809170319.1D28832009@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4892 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/07/28 15:05:52 1.923 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/09 17:03:18 1.924 @@ -1,3 +1,21 @@ +2006-08-09 Helmut Eller + + * slime.el (slime-find-filename-translators): CL:MACHINE-INSTANCE + can return nil. Silently accept that case for now. + + * swank.lisp (test-print-arglist): Print a message instead of + signalling an error. This should avoid startup problems, in + particular with CormanLisp. + (setup-stream-indirection): Disable it for now. We should fix it, + if there is a need for this functionality or just remove it. + + * swank-backend.lisp (definterface): Bring the old implementation + based on NO-APPLICABLE-METHOD back. It avoids lots of redefintion + warnings (but it creates more "noise" in backtraces). + + * swank-*.lisp (inspect-for-emacs): Don't use defimplementation + for real generics. + 2006-07-28 Helmut Eller * slime.el (slime-thread-quit): Call swank:quit-thread-browser. From heller at common-lisp.net Wed Aug 9 17:08:01 2006 From: heller at common-lisp.net (heller) Date: Wed, 9 Aug 2006 13:08:01 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060809170801.5637832009@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5527 Modified Files: swank-backend.lisp Log Message: Some fixes to make it actually work. --- /project/slime/cvsroot/slime/swank-backend.lisp 2006/08/09 16:34:15 1.99 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2006/08/09 17:08:01 1.100 @@ -114,8 +114,8 @@ (check-type documentation string "a documentation string") (flet ((gen-default-impl () `(defmethod no-applicable-method ((_gf (eql #',name)) &rest _rargs) - (declare (ignore _)) - (destructuring-bind ,args rargs + (declare (ignore _gf)) + (destructuring-bind ,args _rargs , at default-body)))) `(progn (defgeneric ,name ,args (:documentation ,documentation)) (pushnew ',name *interface-functions*) @@ -729,6 +729,7 @@ "Return an inspector object suitable for passing to inspect-for-emacs.") (defgeneric inspect-for-emacs (object inspector) + (:documentation "Explain to Emacs how to inspect OBJECT. The argument INSPECTOR is an object representing how to get at @@ -754,7 +755,7 @@ (:action label lambda) - Render LABEL (a text string) which when clicked will call LAMBDA. - NIL - do nothing.") + NIL - do nothing.")) (defmethod inspect-for-emacs ((object t) (inspector t)) "Generic method for inspecting any kind of object. From heller at common-lisp.net Thu Aug 10 11:53:36 2006 From: heller at common-lisp.net (heller) Date: Thu, 10 Aug 2006 07:53:36 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060810115336.524B62817C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12591 Modified Files: swank-backend.lisp swank-cmucl.lisp swank-sbcl.lisp swank-clisp.lisp swank-lispworks.lisp swank-corman.lisp swank-scl.lisp swank-abcl.lisp swank-ecl.lisp swank.lisp Log Message: swank-backend.lisp (definterface): Drop that incredibly unportable CLOS stuff. Use plists and plain functions instead. Update backends accordingly. --- /project/slime/cvsroot/slime/swank-backend.lisp 2006/08/09 17:08:01 1.100 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2006/08/10 11:53:35 1.101 @@ -112,24 +112,47 @@ Backends implement these functions using DEFIMPLEMENTATION." (check-type documentation string "a documentation string") - (flet ((gen-default-impl () - `(defmethod no-applicable-method ((_gf (eql #',name)) &rest _rargs) - (declare (ignore _gf)) - (destructuring-bind ,args _rargs - , at default-body)))) - `(progn (defgeneric ,name ,args (:documentation ,documentation)) - (pushnew ',name *interface-functions*) - ,(if (null default-body) - `(pushnew ',name *unimplemented-interfaces*) - (gen-default-impl)) - ;; see - (eval-when (:compile-toplevel :load-toplevel :execute) - (export ',name :swank-backend)) - ',name))) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args , at default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(, at req , at opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not implementated" ',name))))) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + ;; see + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank-backend)) + ',name))) (defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) `(progn - (defmethod ,name ,args , at body) + (setf (get ',name 'implementation) (lambda ,args , at body)) (if (member ',name *interface-functions*) (setq *unimplemented-interfaces* (remove ',name *unimplemented-interfaces*)) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/08/09 17:01:13 1.161 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/08/10 11:53:35 1.162 @@ -98,16 +98,16 @@ (sys:invalidate-descriptor fd) (ext:close-socket fd))) -(defimplementation accept-connection (socket &key - (external-format :iso-latin-1-unix) - (buffering :full) - timeout) +(defimplementation accept-connection (socket &key + external-format buffering timeout) (declare (ignore timeout)) - (unless (eq external-format ':iso-latin-1-unix) - (remove-fd-handlers socket) - (remove-sigio-handlers socket) - (assert (eq external-format ':iso-latin-1-unix))) - (make-socket-io-stream (ext:accept-tcp-connection socket) buffering)) + (let ((ef (or external-format :iso-latin-1-unix)) + (buffering (or buffering :full))) + (unless (eq ef ':iso-latin-1-unix) + (remove-fd-handlers socket) + (remove-sigio-handlers socket) + (error "External format ~S not supported" ef)) + (make-socket-io-stream (ext:accept-tcp-connection socket) buffering))) ;;;;; Sockets @@ -1276,18 +1276,15 @@ (list symbol)))) ((:defined) (ext:info :alien-type :definition symbol)) - (:unknown - (return-from describe-definition - (format nil "Unknown alien type: ~S" symbol)))))))) + (:unknown :unkown)))))) ;;;;; Argument lists -(defimplementation arglist ((name symbol)) - (arglist (or (macro-function name) - (symbol-function name)))) - -(defimplementation arglist ((fun function)) - (function-arglist fun)) +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) (defun function-arglist (fun) (let ((arglist @@ -1708,9 +1705,12 @@ (values :initarg :values :reader breakpoint.values)) (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) -(defimplementation condition-extras ((c breakpoint)) - ;; simply pop up the source buffer - `((:short-frame-source 0))) +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:short-frame-source 0))) + (t '()))) (defun signal-breakpoint (breakpoint frame) "Signal a breakpoint condition for BREAKPOINT in FRAME. @@ -2050,8 +2050,8 @@ ;; available again. (mp::startup-idle-and-top-level-loops)) - (defimplementation spawn (fn &key (name "Anonymous")) - (mp:make-process fn :name name)) + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) (defvar *thread-id-counter* 0) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/07/15 11:03:29 1.159 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/08/10 11:53:35 1.160 @@ -60,10 +60,12 @@ (sb-bsd-sockets:socket-close socket)) (defimplementation accept-connection (socket &key - (external-format :iso-latin-1-unix) - (buffering :full) timeout) + external-format + buffering timeout) (declare (ignore timeout)) - (make-socket-io-stream (accept socket) external-format buffering)) + (make-socket-io-stream (accept socket) + (or external-format :iso-latin-1-unix) + (or buffering :full))) (defvar *sigio-handlers* '() "List of (key . fn) pairs to be called on SIGIO.") @@ -135,7 +137,7 @@ (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) -(defmethod call-without-interrupts (fn) +(defimplementation call-without-interrupts (fn) (declare (type function fn)) (sb-sys:without-interrupts (funcall fn))) @@ -234,10 +236,11 @@ ;;; Utilities -(defimplementation arglist ((fname t)) +(defimplementation arglist (fname) (sb-introspect:function-arglist fname)) -(defimplementation function-name ((f function)) +(defimplementation function-name (f) + (check-type f function) (sb-impl::%fun-name f)) (defvar *buffer-name* nil) @@ -934,23 +937,22 @@ (defimplementation spawn (fn &key name) (sb-thread:make-thread fn :name name)) - (defimplementation startup-multiprocessing ()) - (defimplementation thread-id (thread) - (sb-thread:with-mutex (*thread-id-map-lock*) - (loop for id being the hash-key in *thread-id-map* - using (hash-value thread-pointer) - do - (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) - (cond ((null maybe-thread) - ;; the value is gc'd, remove it manually - (remhash id *thread-id-map*)) - ((eq thread maybe-thread) - (return-from thread-id id))))) - ;; lazy numbering - (let ((id (next-thread-id))) - (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) - id))) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) (defimplementation find-thread (id) (sb-thread:with-mutex (*thread-id-map-lock*) @@ -1040,7 +1042,7 @@ mutex)))))))) - ;;; Auto-flush streams +;;; Auto-flush streams ;; XXX race conditions (defvar *auto-flush-streams* '()) --- /project/slime/cvsroot/slime/swank-clisp.lisp 2006/03/22 16:40:01 1.58 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2006/08/10 11:53:35 1.59 @@ -125,9 +125,9 @@ (ext:make-encoding :charset charset :line-terminator :unix))) (defimplementation accept-connection (socket - &key (external-format :iso-latin-1-unix) - buffering timeout) + &key external-format buffering timeout) (declare (ignore buffering timeout)) + (setq external-format (or external-format :iso-latin-1-unix)) (socket:socket-accept socket :buffered nil ;; XXX should be t :element-type 'character @@ -239,7 +239,7 @@ (let* (;;(sys::*break-count* (1+ sys::*break-count*)) ;;(sys::*driver* debugger-loop-fn) ;;(sys::*fasoutput-stream* nil) - (*sldb-backtrace* (nthcdr 6 (sldb-backtrace)))) + (*sldb-backtrace* (nthcdr 5 (sldb-backtrace)))) (funcall debugger-loop-fn))) (defun nth-frame (index) @@ -363,11 +363,9 @@ (sys::redo-eval-frame (car (nth-frame index)))) (defimplementation frame-source-location-for-emacs (index) - (let ((f (car (nth-frame index)))) - (list :error (format nil "Cannot find source for frame: ~A ~A ~A" - f - (sys::eval-frame-p f) - (sys::the-frame))))) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (car (nth-frame index))))) ;;; Profiling --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/08/09 16:55:48 1.84 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/08/10 11:53:35 1.85 @@ -66,10 +66,9 @@ (comm::close-socket (socket-fd socket))) (defimplementation accept-connection (socket - &key (external-format :iso-latin-1-unix) - buffering timeout) + &key external-format buffering timeout) (declare (ignore buffering timeout)) - (assert (eq external-format :iso-latin-1-unix)) + (assert (member external-format '(nil :iso-latin-1-unix))) (let* ((fd (comm::get-fd-from-socket socket))) (assert (/= fd -1)) (make-instance 'comm:socket-stream :socket fd :direction :io --- /project/slime/cvsroot/slime/swank-corman.lisp 2006/08/09 17:01:13 1.8 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2006/08/10 11:53:35 1.9 @@ -238,10 +238,9 @@ (close socket)) (defimplementation accept-connection (socket - &key (external-format :iso-latin-1-unix) - buffering timeout) + &key external-format buffering timeout) (declare (ignore buffering timeout)) - (ecase external-format + (ecase (or external-format :iso-latin-1-unix) (:iso-latin-1-unix (sockets:make-socket-stream (sockets:accept-socket socket))))) --- /project/slime/cvsroot/slime/swank-scl.lisp 2006/08/09 17:01:13 1.9 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2006/08/10 11:53:35 1.10 @@ -36,11 +36,10 @@ (defimplementation close-socket (socket) (ext:close-socket (socket-fd socket))) -(defimplementation accept-connection (socket &key - (external-format :iso-latin-1-unix) - (buffering :full) - (timeout nil)) +(defimplementation accept-connection (socket + &key external-format buffering timeout) (let ((external-format (or external-format :iso-latin-1-unix)) + (buffering (or buffering :full)) (fd (socket-fd socket))) (loop (let ((ready (sys:wait-until-fd-usable fd :input timeout))) @@ -1168,21 +1167,19 @@ (list symbol)))) ((:defined) (ext:info :alien-type :definition symbol)) - (:unknown - (return-from describe-definition - (format nil "Unknown alien type: ~S" symbol)))))))) + (:unknown :unknown)))))) ;;;;; Argument lists -(defimplementation arglist ((name symbol)) - (cond ((and (symbolp name) (macro-function name)) - (arglist (macro-function name))) - ((fboundp name) - (arglist (fdefinition name))) +(defimplementation arglist (fun) + (cond ((and (symbolp fun) (macro-function fun)) + (arglist (macro-function fun))) + ((fboundp fun) + (function-arglist (fdefinition fun))) (t :not-available))) -(defimplementation arglist ((fun function)) +(defun function-arglist (fun function) (flet ((compiled-function-arglist (x) (let ((args (kernel:%function-arglist x))) (if args @@ -1588,6 +1585,7 @@ (values :initarg :values :reader breakpoint.values)) (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) +#+nil (defimplementation condition-extras ((c breakpoint)) ;; simply pop up the source buffer `((:short-frame-source 0))) @@ -1933,10 +1931,11 @@ (incf *thread-id-counter*))))) (defimplementation find-thread (id) - (thread:map-over-threads - #'(lambda (thread) - (when (eql (getf (thread:thread-plist thread) 'id) id) - (return-from find-thread thread))))) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) (defimplementation thread-name (thread) (princ-to-string (thread:thread-name thread))) --- /project/slime/cvsroot/slime/swank-abcl.lisp 2006/08/09 17:01:13 1.39 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2006/08/10 11:53:35 1.40 @@ -134,9 +134,9 @@ (ext:server-socket-close socket)) (defimplementation accept-connection (socket - &key (external-format :iso-latin-1-unix) buffering timeout) + &key external-format buffering timeout) (declare (ignore buffering timeout)) - (assert (eq external-format :iso-latin-1-unix)) + (assert (member external-format '(nil :iso-latin-1-unix))) (ext:get-socket-stream (ext:socket-accept socket))) ;;;; Unix signals @@ -159,12 +159,11 @@ ;;;; Misc - -(defimplementation arglist ((symbol t)) - (multiple-value-bind (arglist present) - (sys::arglist symbol) - (if present arglist :not-available))) - +(defimplementation arglist (fun) + (cond ((symbolp fun) + (multiple-value-bind (arglist present) (sys::arglist fun) + (if present arglist :not-available))) + (t :not-available))) (defimplementation function-name (function) (nth-value 2 (function-lambda-expression function))) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2006/03/22 16:40:01 1.5 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2006/08/10 11:53:35 1.6 @@ -15,11 +15,6 @@ :specializer-direct-methods :compute-applicable-methods-using-classes)) -#+nil -(ffi:clines " -#include -#include ") - ;;;; TCP Server @@ -45,7 +40,7 @@ (sb-bsd-sockets:socket-close socket)) (defimplementation accept-connection (socket - &key (external-format :iso-latin-1-unix) + &key external-format buffering timeout) (declare (ignore buffering timeout)) (assert (eq external-format :iso-latin-1-unix)) @@ -166,7 +161,7 @@ (t :not-available))))) :not-available)) -(defimplementation function-name ((f function)) +(defimplementation function-name (f) (si:compiled-function-name f)) (defimplementation macroexpand-all (form) --- /project/slime/cvsroot/slime/swank.lisp 2006/08/09 16:46:10 1.388 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/10 11:53:35 1.389 @@ -1457,7 +1457,7 @@ (let ((index 0) (need-space nil)) (labels ((print-arg (arg) - (etypecase arg + (typecase arg (arglist ; destructuring pattern (print-arglist arg)) (optional-arg @@ -2236,9 +2236,8 @@ (let* ((p (find-package :swank)) (actual (arglist-to-string list p))) (unless (string= actual string) - (format *debug-io* - "Test failed: ~S => ~S~% Expected: ~S" - list actual string))))) + (warn "Test failed: ~S => ~S~% Expected: ~S" + list actual string))))) (test '(function cons) "(function cons)") (test '(quote cons) "(quote cons)") (test '(&key (function #'+)) "(&key (function #'+))") @@ -3422,7 +3421,7 @@ Once a word has been completely matched, the chunks are pushed onto the special variable *ALL-CHUNKS* and the function returns." - (declare (optimize speed) + (declare ;;(optimize speed) (fixnum short-index initial-full-index) (simple-string short full) (special *all-chunks*)) From heller at common-lisp.net Thu Aug 10 11:54:46 2006 From: heller at common-lisp.net (heller) Date: Thu, 10 Aug 2006 07:54:46 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060810115446.A54E42D024@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12724 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2006/08/09 17:03:18 1.924 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/10 11:54:46 1.925 @@ -1,3 +1,9 @@ +2006-08-10 Helmut Eller + + * swank-backend.lisp (definterface): Drop that incredibly + unportable CLOS stuff. Use plists and plain functions instead. + Update backends accordingly. + 2006-08-09 Helmut Eller * slime.el (slime-find-filename-translators): CL:MACHINE-INSTANCE From heller at common-lisp.net Thu Aug 10 18:55:52 2006 From: heller at common-lisp.net (heller) Date: Thu, 10 Aug 2006 14:55:52 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060810185552.6AD13710E8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18809 Modified Files: swank-allegro.lisp Log Message: (fspec-definition-locations): Improve handling of (:internal ... n) like fspecs. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2006/07/28 15:04:53 1.89 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2006/08/10 18:55:51 1.90 @@ -407,7 +407,10 @@ (list (list (list nil fspec) (make-location (list :buffer file) - (list :position position)))))) + (list :position position t)))))) + ((and (listp fspec) (eq (car fspec) :internal)) + (destructuring-bind (_internal next _n) fspec + (fspec-definition-locations next))) (t (let ((defs (excl::find-source-file fspec))) (if (null defs) From heller at common-lisp.net Thu Aug 10 18:56:52 2006 From: heller at common-lisp.net (heller) Date: Thu, 10 Aug 2006 14:56:52 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060810185652.E498C762F6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18857 Modified Files: slime.el Log Message: (slime-restart-inferior-lisp-aux): Remove the interactive spec. --- /project/slime/cvsroot/slime/slime.el 2006/08/09 16:53:41 1.636 +++ /project/slime/cvsroot/slime/slime.el 2006/08/10 18:56:52 1.637 @@ -4237,7 +4237,6 @@ (:one-liner "Restart *inferior-lisp* and reconnect SLIME.")) (defun slime-restart-inferior-lisp-aux () - (interactive) (assert (slime-inferior-process) () "No inferior lisp process") (slime-eval-async '(swank:quit-lisp)) (set-process-filter (slime-connection) nil) From heller at common-lisp.net Thu Aug 10 18:57:45 2006 From: heller at common-lisp.net (heller) Date: Thu, 10 Aug 2006 14:57:45 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060810185745.E1D9D403D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18883 Modified Files: swank-openmcl.lisp Log Message: (accept-connection, arglist): Some updates for changed definterface implementation. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/09 17:01:13 1.109 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/10 18:57:45 1.110 @@ -166,11 +166,11 @@ (defimplementation close-socket (socket) (close socket)) -(defimplementation accept-connection (socket - &key (external-format :iso-latin-1-unix) - buffering timeout) +(defimplementation accept-connection (socket + &key external-format buffering timeout) (declare (ignore buffering timeout)) - (assert (eq external-format :iso-latin-1-unix)) + (let ((ef (or external-format :iso-latin-1-unix))) + (assert (eq ef :iso-latin-1-unix))) (ccl:accept-connection socket :wait t)) (defimplementation emacs-connected () @@ -247,10 +247,13 @@ ;;; Evaluation -(defimplementation arglist ((fname symbol)) - (ccl:arglist fname)) +(defimplementation arglist (fname) + (arglist% fname)) -(defmethod arglist ((f function)) +(defmethod arglist% ((f symbol)) + (ccl:arglist f)) + +(defmethod arglist% ((f function)) (ccl:arglist (ccl:function-name f))) (defimplementation function-name (function) From heller at common-lisp.net Thu Aug 10 19:00:50 2006 From: heller at common-lisp.net (heller) Date: Thu, 10 Aug 2006 15:00:50 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060810190050.C636F4043@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv19336 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/10 11:54:46 1.925 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/10 19:00:50 1.926 @@ -1,5 +1,11 @@ 2006-08-10 Helmut Eller + * swank-allegro.lisp (fspec-definition-locations): Improve + handling of (:internal ... n) like fspecs. + + * slime.el (slime-restart-inferior-lisp-aux): Remove the + interactive spec. + * swank-backend.lisp (definterface): Drop that incredibly unportable CLOS stuff. Use plists and plain functions instead. Update backends accordingly. From heller at common-lisp.net Fri Aug 11 16:25:59 2006 From: heller at common-lisp.net (heller) Date: Fri, 11 Aug 2006 12:25:59 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060811162559.BA4A03A008@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12911 Modified Files: swank.lisp Log Message: (close-connection, swank-error): Include backtraces in our own errors. (simple-serve-requests): Don't enter the debugger (recursively) if the connection is closed. --- /project/slime/cvsroot/slime/swank.lisp 2006/08/10 11:53:35 1.389 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/11 16:25:59 1.390 @@ -253,10 +253,18 @@ "Return the value of *SWANK-STATE-STACK*." *swank-state-stack*) -(define-condition slime-protocol-error (error) - ((condition :initarg :condition :reader slime-protocol-error.condition)) +;; A conditions to include backtrace information +(define-condition swank-error (error) + ((condition :initarg :condition :reader swank-error.condition) + (backtrace :initarg :backtrace :reader swank-error.backtrace)) (:report (lambda (condition stream) - (format stream "~A" (slime-protocol-error.condition condition))))) + (princ (swank-error.condition condition) stream)))) + +(defun make-swank-error (condition) + (let ((bt (ignore-errors + (call-with-debugging-environment + (lambda ()(backtrace 0 nil)))))) + (make-condition 'swank-error :condition condition :backtrace bt))) (add-hook *new-connection-hook* 'notify-backend-of-connection) (defun notify-backend-of-connection (connection) @@ -424,7 +432,7 @@ (serve-connection socket style dont-close external-format))) (ecase style (:spawn - (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close)) + (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close)) :name "Swank")) ((:fd-handler :sigio) (add-fd-handler socket (lambda () (serve)))) @@ -556,7 +564,8 @@ (defun current-socket-io () (connection.socket-io *emacs-connection*)) -(defun close-connection (c &optional condition) +(defun close-connection (c &optional condition backtrace) + (format *debug-io* "~&;; swank:close-connection: ~A~%" condition) (let ((cleanup (connection.cleanup c))) (when cleanup (funcall cleanup c))) @@ -565,15 +574,17 @@ (close (connection.dedicated-output c))) (setf *connections* (remove c *connections*)) (run-hook *connection-closed-hook* c) - (when condition + (when (and condition (not (typep condition 'end-of-file))) (finish-output *debug-io*) (format *debug-io* "~&;; Event history start:~%") (dump-event-history *debug-io*) (format *debug-io* ";; Event history end.~%~ + ;; Backtrace:~%~{~A~%~}~ ;; Connection to Emacs lost. [~%~ ;; condition: ~A~%~ ;; type: ~S~%~ ;; encoding: ~S style: ~S dedicated: ~S]~%" + backtrace (escape-non-ascii (safe-condition-message condition) ) (type-of condition) (connection.external-format c) @@ -582,9 +593,14 @@ (finish-output *debug-io*))) (defmacro with-reader-error-handler ((connection) &body body) - `(handler-case (progn , at body) - (slime-protocol-error (e) - (close-connection ,connection e)))) + (let ((con (gensym))) + `(let ((,con ,connection)) + (handler-case + (progn , at body) + (swank-error (e) + (close-connection ,con + (swank-error.condition e) + (swank-error.backtrace e))))))) (defslimefun simple-break () (with-simple-restart (continue "Continue from interrupt.") @@ -729,8 +745,7 @@ (kill-thread thread))))) (defun repl-loop (connection) - (with-connection (connection) - (loop (handle-request connection)))) + (loop (handle-request connection))) (defun process-available-input (stream fn) (loop while (and (open-stream-p stream) @@ -784,19 +799,12 @@ ;;;;;; Simple sequential IO (defun simple-serve-requests (connection) - (with-reader-error-handler (connection) - (unwind-protect - (loop - (with-connection (connection) - (with-simple-restart (abort-request "") - (do () - ((wait-until-readable (connection.socket-io connection)))))) - (handle-request connection)) - (close-connection connection)))) - -(defun wait-until-readable (stream) - (unread-char (read-char stream) stream) - t) + (unwind-protect + (with-simple-restart (close-connection "Close SLIME connection") + (with-reader-error-handler (connection) + (loop + (handle-request connection)))) + (close-connection connection))) (defun read-from-socket-io () (let ((event (decode-message (current-socket-io)))) @@ -1052,19 +1060,16 @@ (receive)) (defun decode-message (stream) - "Read an S-expression from STREAM using the SLIME protocol. -If a protocol error occurs then a SLIME-PROTOCOL-ERROR is signalled." + "Read an S-expression from STREAM using the SLIME protocol." (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*))) - (handler-case - (let* ((length (decode-message-length stream)) - (string (make-string length)) - (pos (read-sequence string stream))) - (assert (= pos length) () - "Short read: length=~D pos=~D" length pos) - (log-event "READ: ~S~%" string) - (read-form string)) - (serious-condition (c) - (error (make-condition 'slime-protocol-error :condition c)))))) + (handler-bind ((error (lambda (c) (error (make-swank-error c))))) + (let* ((length (decode-message-length stream)) + (string (make-string length)) + (pos (read-sequence string stream))) + (assert (= pos length) () + "Short read: length=~D pos=~D" length pos) + (log-event "READ: ~S~%" string) + (read-form string))))) (defun decode-message-length (stream) (let ((buffer (make-string 6))) From heller at common-lisp.net Fri Aug 11 16:26:20 2006 From: heller at common-lisp.net (heller) Date: Fri, 11 Aug 2006 12:26:20 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060811162620.2AEC84617B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13014 Modified Files: swank-cmucl.lisp Log Message: (startup-idle-and-top-level-loops): Initialize MP if only once. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/08/10 11:53:35 1.162 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/08/11 16:26:20 1.163 @@ -2048,7 +2048,8 @@ (defimplementation startup-idle-and-top-level-loops () ;; Threads magic: this never returns! But top-level becomes ;; available again. - (mp::startup-idle-and-top-level-loops)) + (unless mp::*initial-process* + (mp::startup-idle-and-top-level-loops))) (defimplementation spawn (fn &key name) (mp:make-process fn :name (or name "Anonymous"))) From heller at common-lisp.net Fri Aug 11 16:27:36 2006 From: heller at common-lisp.net (heller) Date: Fri, 11 Aug 2006 12:27:36 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060811162736.E86C353036@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13109 Modified Files: slime.el Log Message: Test disconnecting. --- /project/slime/cvsroot/slime/slime.el 2006/08/10 18:56:52 1.637 +++ /project/slime/cvsroot/slime/slime.el 2006/08/11 16:27:36 1.638 @@ -2427,7 +2427,7 @@ (while t (unless (eq (process-status conn) 'open) (error "Lisp connection closed unexpectedly")) - (accept-process-output nil 0 10000))))))) + (slime-accept-process-output nil 0.01))))))) (defun slime-eval-async (sexp &optional cont package) "Evaluate EXPR on the superior Lisp and call CONT with the result." @@ -2469,7 +2469,7 @@ (when (slime-rex-continuations) (let ((tag (caar (slime-rex-continuations)))) (while (find tag (slime-rex-continuations) :key #'car) - (accept-process-output nil 0 100000))))) + (slime-accept-process-output nil 0.1))))) (defun slime-ping () "Check that communication works." @@ -4232,11 +4232,12 @@ (slime-oos (slime-read-system-name) "COMPILE-OP" :force t))) (:one-liner "Recompile (but not load) an ASDF system.")) -(defslime-repl-shortcut slime-restart-inferior-lisp ("restart-inferior-lisp") - (:handler 'slime-restart-inferior-lisp-aux) +(defslime-repl-shortcut nil ("restart-inferior-lisp") + (:handler 'slime-restart-inferior-lisp) (:one-liner "Restart *inferior-lisp* and reconnect SLIME.")) -(defun slime-restart-inferior-lisp-aux () +(defun slime-restart-inferior-lisp () + (interactive) (assert (slime-inferior-process) () "No inferior lisp process") (slime-eval-async '(swank:quit-lisp)) (set-process-filter (slime-connection) nil) @@ -9489,7 +9490,7 @@ (setq slime-tests nil) (defun slime-check-top-level (&optional test-name) - (accept-process-output nil 0 50) + (slime-accept-process-output nil 0.001) (slime-check "At the top level (no debugging or pending RPCs)" (slime-at-top-level-p))) @@ -9503,11 +9504,10 @@ (cond ((time-less-p end (current-time)) (error "Timeout waiting for condition: %S" name)) (t - ;; tell the debugger to enter recursive edits - (let ((slime-stack-eval-tags (cons 'wait slime-stack-eval-tags))) - ;; XXX if a process-filter enters a recursive-edit, we - ;; hang forever - (accept-process-output nil 0 10000))))))) + ;; XXX if a process-filter enters a recursive-edit, we + ;; hang forever + (save-excursion + (slime-accept-process-output nil 0.1))))))) (defun slime-sync-to-top-level (timeout) (slime-wait-condition "top-level" #'slime-at-top-level-p timeout)) @@ -9590,7 +9590,7 @@ "Lookup the argument list for FUNCTION-NAME. Confirm that EXPECTED-ARGLIST is displayed." '(("swank:start-server" - "(swank:start-server port-file &key \\((style \\*communication-style\\*)\\|style\\)[ \n]+dont-close[ \n]+(external-format \\*coding-system\\*))") + "(swank:start-server port-file &key \\((style swank:\\*communication-style\\*)\\|style\\)[ \n]+dont-close[ \n]+(external-format swank::\\*coding-system\\*))") ("swank::compound-prefix-match" "(swank::compound-prefix-match prefix target)") ("swank::create-socket" @@ -9646,14 +9646,14 @@ " (cl-user::bar)) ) - (slime-check-top-level) + (slime-check-top-level) (with-temp-buffer (lisp-mode) (insert program) (setq slime-buffer-package ":swank") (slime-compile-string (buffer-string) 1) (setq slime-buffer-package ":cl-user") - (slime-sync-to-top-level 15) + (slime-sync-to-top-level 5) (goto-char (point-max)) (slime-previous-note) (slime-check error-location-correct @@ -9680,7 +9680,7 @@ (slime-eval-async 'no-such-variable))))))) (let ((sldb-hook (cons debug-hook sldb-hook))) (slime-eval-async 'no-such-variable) - (slime-sync-to-top-level 15) + (slime-sync-to-top-level 5) (slime-check-top-level) (slime-check ("Maximum depth reached (%S) is %S." debug-hook-max-depth depth) @@ -9692,7 +9692,7 @@ '(()) (slime-check-top-level) (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") - (accept-process-output nil 1) + (slime-accept-process-output nil 1) (slime-check "In eval state." (slime-busy-p)) (slime-interrupt) (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) @@ -9732,7 +9732,7 @@ (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) (slime-interactive-eval "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))") - (while (not done) (accept-process-output)) + (while (not done) (slime-accept-process-output)) (slime-sync-to-top-level 5) (slime-check-top-level) (let ((message (current-message))) @@ -9743,7 +9743,7 @@ () "Test interrupting a loop that sends a lot of output to Emacs." '(()) - (accept-process-output nil 1) + (slime-accept-process-output nil 1) (slime-check-top-level) (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) (cl:finish-output))) @@ -9945,7 +9945,7 @@ () "Test if BREAK invokes SLDB." '(()) - (accept-process-output nil 1) + (slime-accept-process-output nil 1) (slime-check-top-level) (slime-compile-string (prin1-to-string '(cl:defun cl-user::foo () (cl:break))) @@ -9959,7 +9959,7 @@ 5) (with-current-buffer (sldb-get-default-buffer) (sldb-quit)) - (accept-process-output nil 1) + (slime-accept-process-output nil 1) (slime-sync-to-top-level 5)) (def-slime-test user-interrupt @@ -9976,7 +9976,34 @@ (with-current-buffer (sldb-get-default-buffer) (sldb-quit)) (slime-sync-to-top-level 5)) - + +(def-slime-test disconnect + () + "Close the connetion. +Confirm that the subprocess continues gracefully. +Reconnect afterwards." + '(()) + (slime-check-top-level) + (let* ((c (slime-connection)) + (p (slime-inferior-process c))) + (with-current-buffer (process-buffer p) + (erase-buffer)) + (delete-process c) + (assert (equal (process-status c) 'closed) nil "Connection not closed") + (slime-accept-process-output nil 0.1) + (assert (equal (process-status p) 'run) nil "Subprocess not running") + (with-current-buffer (process-buffer p) + (assert (< (buffer-size) 500) t "Unusual output")) + (slime-inferior-connect p (slime-inferior-lisp-args p)) + (lexical-let ((hook nil)) + (setq hook (lambda () + (remove-hook 'slime-connected-hook hook))) + (add-hook 'slime-connected-hook hook) + (while (member hook slime-connected-hook) + (sit-for 0.5) + (slime-accept-process-output nil 0.1))) + (slime-test-expect "We are connected again" p (slime-inferior-process)))) + ;;;; Utilities @@ -10205,6 +10232,17 @@ `(unless (fboundp ',name) (defun ,name , at rest)))) +(defun slime-accept-process-output (&optional process timeout) + "Like `accept-process-output' but the TIMEOUT argument can be a float." + (cond ((or (featurep 'xemacs) + (> emacs-major-version 21)) + (accept-process-output process timeout)) + (t + (accept-process-output process + (truncate timeout) + ;; Emacs 21 uses microsecs; Emacs 22 millisecs + (truncate (* timeout 1000000)))))) + (put 'slime-defun-if-undefined 'lisp-indent-function 2) (slime-defun-if-undefined next-single-char-property-change From heller at common-lisp.net Fri Aug 11 16:29:11 2006 From: heller at common-lisp.net (heller) Date: Fri, 11 Aug 2006 12:29:11 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060811162911.69EDE5B013@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13164 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2006/08/10 19:00:50 1.926 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/11 16:29:11 1.927 @@ -1,3 +1,15 @@ +2006-08-11 Helmut Eller + + * swank.lisp (close-connection, swank-error): Include backtraces + in our own errors. + (simple-serve-requests): Don't try to enter the + debugger if the connection is closed. + + * slime.el (disconnect): Test disconnecting. + + * swank-cmucl.lisp (startup-idle-and-top-level-loops): Initialize + MP only once. + 2006-08-10 Helmut Eller * swank-allegro.lisp (fspec-definition-locations): Improve From heller at common-lisp.net Mon Aug 14 05:19:10 2006 From: heller at common-lisp.net (heller) Date: Mon, 14 Aug 2006 01:19:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060814051910.C2FB83A008@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv25852 Modified Files: swank-openmcl.lisp Log Message: Fix some breakage caused by the new defimplementation. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/10 18:57:45 1.110 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/14 05:19:09 1.111 @@ -308,19 +308,20 @@ (compile-file filename :load load-p)))) (defimplementation frame-var-value (frame var) - (map-backtrace - #'(lambda(frame-number p context lfun pc) - (when (= frame frame-number) - (return-from frame-var-value - (multiple-value-bind (total vsp parent-vsp) - (ccl::count-values-in-frame p context) - (loop for count below total - with varcount = -1 - for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp)) - when name do (incf varcount) - until (= varcount var) - finally (return value)) - )))))) + (block frame-var-value + (map-backtrace + #'(lambda(frame-number p context lfun pc) + (when (= frame frame-number) + (return-from frame-var-value + (multiple-value-bind (total vsp parent-vsp) + (ccl::count-values-in-frame p context) + (loop for count below total + with varcount = -1 + for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp)) + when name do (incf varcount) + until (= varcount var) + finally (return value)) + ))))))) (defun xref-locations (relation name &optional (inverse nil)) (loop for xref in (if inverse @@ -512,44 +513,46 @@ (princ frame stream)) (defimplementation frame-locals (index) - (map-backtrace - (lambda (frame-number p context lfun pc) - (when (= frame-number index) - (multiple-value-bind (count vsp parent-vsp) - (ccl::count-values-in-frame p context) - (let (result) - (dotimes (i count) - (multiple-value-bind (var type name) - (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) - (declare (ignore type)) - (when name - (push (list - :name name - :id 0 - :value var) - result)))) - (return-from frame-locals (nreverse result)))))))) + (block frame-locals + (map-backtrace + (lambda (frame-number p context lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p context) + (let (result) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list + :name name + :id 0 + :value var) + result)))) + (return-from frame-locals (nreverse result))))))))) (defimplementation frame-catch-tags (index &aux my-frame) - (map-backtrace - (lambda (frame-number p context lfun pc) - (declare (ignore pc lfun)) - (if (= frame-number index) - (setq my-frame p) - (when my-frame - (return-from frame-catch-tags - (loop for catch = (ccl::%catch-top (ccl::%current-tcr)) then (ccl::next-catch catch) - while catch - for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp - for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell) - until (ccl::%stack< p csp context) - when (ccl::%stack< my-frame csp context) - collect (cond - ((symbolp tag) - tag) - ((and (listp tag) - (typep (car tag) 'restart)) - `(:restart ,(restart-name (car tag)))))))))))) + (block frame-catch-tags + (map-backtrace + (lambda (frame-number p context lfun pc) + (declare (ignore pc lfun)) + (if (= frame-number index) + (setq my-frame p) + (when my-frame + (return-from frame-catch-tags + (loop for catch = (ccl::%catch-top (ccl::%current-tcr)) then (ccl::next-catch catch) + while catch + for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp + for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell) + until (ccl::%stack< p csp context) + when (ccl::%stack< my-frame csp context) + collect (cond + ((symbolp tag) + tag) + ((and (listp tag) + (typep (car tag) 'restart)) + `(:restart ,(restart-name (car tag))))))))))))) (defimplementation disassemble-frame (the-frame-number) (let ((function-to-disassemble nil)) @@ -614,32 +617,34 @@ function in a debugger frame. In OpenMCL, we are not able to find the precise position of the frame, but we do attempt to give at least the filename containing it." - (map-backtrace - (lambda (frame-number p context lfun pc) - (declare (ignore p context pc)) - (when (and (= frame-number index) lfun) - (return-from frame-source-location-for-emacs - (function-source-location lfun)))))) + (block frame-source-location-for-emacs + (map-backtrace + (lambda (frame-number p context lfun pc) + (declare (ignore p context pc)) + (when (and (= frame-number index) lfun) + (return-from frame-source-location-for-emacs + (function-source-location lfun))))))) (defimplementation eval-in-frame (form index) - (map-backtrace - (lambda (frame-number p context lfun pc) - (when (= frame-number index) - (multiple-value-bind (count vsp parent-vsp) - (ccl::count-values-in-frame p context) - (let ((bindings nil)) - (dotimes (i count) - (multiple-value-bind (var type name) - (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) - (declare (ignore type)) - (when name - (push (list name `',var) bindings)) - )) - (return-from eval-in-frame - (eval `(let ,bindings - (declare (ignorable ,@(mapcar 'car bindings))) - ,form))) - )))))) + (block eval-in-frame + (map-backtrace + (lambda (frame-number p context lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p context) + (let ((bindings nil)) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list name `',var) bindings)) + )) + (return-from eval-in-frame + (eval `(let ,bindings + (declare (ignorable ,@(mapcar 'car bindings))) + ,form))) + ))))))) (defimplementation return-from-frame (index form) (let ((values (multiple-value-list (eval-in-frame form index)))) From heller at common-lisp.net Mon Aug 14 05:20:16 2006 From: heller at common-lisp.net (heller) Date: Mon, 14 Aug 2006 01:20:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060814052016.1DBD949006@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv25899 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/11 16:29:11 1.927 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/14 05:20:14 1.928 @@ -1,3 +1,8 @@ +2006-08-14 Helmut Eller + + * swank-openmcl.lisp: Fix some breakage caused by the new + defimplementation. + 2006-08-11 Helmut Eller * swank.lisp (close-connection, swank-error): Include backtraces From heller at common-lisp.net Mon Aug 14 20:24:40 2006 From: heller at common-lisp.net (heller) Date: Mon, 14 Aug 2006 16:24:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060814202440.A9DD53D003@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv1911 Modified Files: slime.el Log Message: (slime-accept-process-output-supports-floats): New variable to cache the result of calling accept-process-output with a float as timeout argument. Not all Emacs version support that and if the call raises an error we know that it's not supported. (slime-accept-process-output): Use it. --- /project/slime/cvsroot/slime/slime.el 2006/08/11 16:27:36 1.638 +++ /project/slime/cvsroot/slime/slime.el 2006/08/14 20:24:40 1.639 @@ -10232,10 +10232,12 @@ `(unless (fboundp ',name) (defun ,name , at rest)))) +(defvar slime-accept-process-output-supports-floats + (ignore-errors (accept-process-output nil 0.0) t)) + (defun slime-accept-process-output (&optional process timeout) "Like `accept-process-output' but the TIMEOUT argument can be a float." - (cond ((or (featurep 'xemacs) - (> emacs-major-version 21)) + (cond (slime-accept-process-output-supports-floats (accept-process-output process timeout)) (t (accept-process-output process From heller at common-lisp.net Mon Aug 14 20:31:55 2006 From: heller at common-lisp.net (heller) Date: Mon, 14 Aug 2006 16:31:55 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060814203155.2C0CB7C006@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3614 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/14 05:20:14 1.928 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/14 20:31:54 1.929 @@ -1,5 +1,9 @@ 2006-08-14 Helmut Eller + * slime.el (slime-accept-process-output): Use brute-force to + detect whether accept-process-output can be called with a float as + timeout arg. + * swank-openmcl.lisp: Fix some breakage caused by the new defimplementation. From heller at common-lisp.net Mon Aug 14 20:44:20 2006 From: heller at common-lisp.net (heller) Date: Mon, 14 Aug 2006 16:44:20 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060814204420.55DDA52001@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3927 Modified Files: swank-openmcl.lisp Log Message: More fixes. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/14 05:19:09 1.111 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2006/08/14 20:44:20 1.112 @@ -177,10 +177,9 @@ (setq ccl::*interactive-abort-process* ccl::*current-process*)) (defimplementation make-stream-interactive (stream) - nil) - -(defmethod make-stream-interactive ((stream ccl:fundamental-output-stream)) - (push stream ccl::*auto-flush-streams*)) + (typecase stream + (ccl:fundamental-output-stream + (push stream ccl::*auto-flush-streams*)))) ;;; Unix signals @@ -743,7 +742,7 @@ (defimplementation make-default-inspector () (make-instance 'openmcl-inspector)) -(defmethod describe-primitive-type (thing) +(defimplementation describe-primitive-type (thing) (let ((typecode (ccl::typecode thing))) (if (gethash typecode *value2tag*) (string (gethash typecode *value2tag*)) From mkoeppe at common-lisp.net Sat Aug 19 15:39:27 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 19 Aug 2006 11:39:27 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060819153927.43B2C671A3@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31434 Modified Files: slime.el Log Message: (slime-parse-extended-operator-name/apply): New. (slime-extended-operator-name-parser-alist): Add it to the alist. --- /project/slime/cvsroot/slime/slime.el 2006/08/14 20:24:40 1.639 +++ /project/slime/cvsroot/slime/slime.el 2006/08/19 15:39:26 1.640 @@ -10154,7 +10154,8 @@ ("WARN" . slime-parse-extended-operator-name/make-instance) ("CERROR" . slime-parse-extended-operator-name/cerror) ("CHANGE-CLASS" . slime-parse-extended-operator-name/cerror) - ("DEFMETHOD" . slime-parse-extended-operator-name/defmethod))) + ("DEFMETHOD" . slime-parse-extended-operator-name/defmethod) + ("APPLY" . slime-parse-extended-operator-name/apply))) (defun slime-parse-extended-operator-name/make-instance (name) (let ((str (slime-sexp-at-point))) @@ -10163,6 +10164,13 @@ name)))) name) +(defun slime-parse-extended-operator-name/apply (name) + (let ((str (slime-sexp-at-point))) + (when (string-match "^#?'\\(.*\\)" str) + (setq name (list :make-instance (match-string 1 str) + name)))) + name) + (defun slime-parse-extended-operator-name/cerror (name) (let ((continue-string-sexp (slime-sexp-at-point)) (class-sexp (progn (forward-sexp) (forward-char 1) (slime-sexp-at-point)))) From mkoeppe at common-lisp.net Sat Aug 19 15:39:48 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 19 Aug 2006 11:39:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060819153948.C18FF69143@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31491 Modified Files: swank.lisp Log Message: (compute-enriched-decoded-arglist): Add method for handling APPLY. --- /project/slime/cvsroot/slime/swank.lisp 2006/08/11 16:25:59 1.390 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/19 15:39:48 1.391 @@ -2033,6 +2033,38 @@ nil))) (values decoded-arglist determining-args t))) +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply)) + argument-forms) + (let ((function-name-form (car argument-forms))) + (when (and (listp function-name-form) + (= (length function-name-form) 2) + (member (car function-name-form) '(quote function))) + (let ((function-name (cadr function-name-form))) + (when (valid-operator-symbol-p function-name) + (let ((function-arglist + (compute-enriched-decoded-arglist function-name + (cdr argument-forms)))) + (return-from compute-enriched-decoded-arglist + (values (make-arglist :required-args + (list 'function) + :optional-args + (append + (mapcar #'(lambda (arg) + (make-optional-arg arg nil)) + (arglist.required-args function-arglist)) + (arglist.optional-args function-arglist)) + :key-p + (arglist.key-p function-arglist) + :keyword-args + (arglist.keyword-args function-arglist) + :rest + 'args + :allow-other-keys-p + (arglist.allow-other-keys-p function-arglist)) + (list function-name-form) + t))))))) + (call-next-method)) + (defslimefun arglist-for-insertion (name) (with-buffer-syntax () (let ((symbol (parse-symbol name))) From mkoeppe at common-lisp.net Sat Aug 19 15:40:02 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 19 Aug 2006 11:40:02 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060819154002.F2B03710E8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31516 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/14 20:31:54 1.929 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/19 15:40:02 1.930 @@ -1,3 +1,11 @@ +2006-08-19 Matthias Koeppe + + * slime.el (slime-parse-extended-operator-name/apply): New. + (slime-extended-operator-name-parser-alist): Add it to the alist. + + * swank.lisp (compute-enriched-decoded-arglist): Add method for + handling APPLY. + 2006-08-14 Helmut Eller * slime.el (slime-accept-process-output): Use brute-force to From mkoeppe at common-lisp.net Sat Aug 19 16:27:28 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 19 Aug 2006 12:27:28 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060819162728.A5E0B1E007@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv8698 Modified Files: swank.lisp Log Message: (*nil-surrogate*): New. (save-presented-object, lookup-presented-object): Distinguish between a saved NIL and a garbage-collected object that was replaced by NIL in the weak hash table. --- /project/slime/cvsroot/slime/swank.lisp 2006/08/19 15:39:48 1.391 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/19 16:27:28 1.392 @@ -2305,20 +2305,36 @@ (defvar *presentation-counter* 0 "identifier counter") +(defvar *nil-surrogate* (make-symbol "nil-surrogate")) + ;; XXX thread safety? (defun save-presented-object (object) "Save OBJECT and return the assigned id. If OBJECT was saved previously return the old id." - (or (gethash object *object-to-presentation-id*) - (let ((id (incf *presentation-counter*))) - (setf (gethash id *presentation-id-to-object*) object) - (setf (gethash object *object-to-presentation-id*) id) - id))) + (let ((object (if (null object) *nil-surrogate* object))) + ;; We store *nil-surrogate* instead of nil, to distinguish it from + ;; an object that was garbage collected. + (or (gethash object *object-to-presentation-id*) + (let ((id (incf *presentation-counter*))) + (setf (gethash id *presentation-id-to-object*) object) + (setf (gethash object *object-to-presentation-id*) id) + id)))) (defun lookup-presented-object (id) "Retrieve the object corresponding to ID. The secondary value indicates the absence of an entry." - (gethash id *presentation-id-to-object*)) + (multiple-value-bind (object foundp) + (gethash id *presentation-id-to-object*) + (cond + ((eql object *nil-surrogate*) + ;; A stored nil object + (values nil t)) + ((null object) + ;; Object that was replaced by nil in the weak hash table + ;; when the object was garbage collected. + (values nil nil)) + (t + (values object foundp))))) (defslimefun get-repl-result (id) "Get the result of the previous REPL evaluation with ID." From mkoeppe at common-lisp.net Sun Aug 20 09:36:59 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 20 Aug 2006 05:36:59 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060820093659.CDE7F7D00C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31901 Modified Files: swank.lisp Log Message: (compute-enriched-decoded-arglist with-open-file): Add an IGNORE declaration. --- /project/slime/cvsroot/slime/swank.lisp 2006/08/19 16:27:28 1.392 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/20 09:36:59 1.393 @@ -2022,6 +2022,7 @@ (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file)) argument-forms) + (declare (ignore argument-forms)) (multiple-value-bind (decoded-arglist determining-args) (call-next-method) (let ((first-arg (first (arglist.required-args decoded-arglist))) From mkoeppe at common-lisp.net Sun Aug 20 09:37:14 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sun, 20 Aug 2006 05:37:14 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060820093714.31E577D0B7@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31923 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/19 15:40:02 1.930 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/20 09:37:13 1.931 @@ -1,3 +1,12 @@ +2006-08-20 Matthias Koeppe + + * swank.lisp (*nil-surrogate*): New. + (save-presented-object, lookup-presented-object): Distinguish + between a saved NIL and a garbage-collected object that was + replaced by NIL in the weak hash table. + (compute-enriched-decoded-arglist with-open-file): Add an IGNORE + declaration. + 2006-08-19 Matthias Koeppe * slime.el (slime-parse-extended-operator-name/apply): New. From mkoeppe at common-lisp.net Tue Aug 22 09:31:10 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 22 Aug 2006 05:31:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060822093110.C705A32008@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv300 Modified Files: swank.lisp Log Message: (lookup-presented-object): Handle presentation ids (:frame-var frame index), (:inspected-part part-index). (init-inspector): New optional argument, reset. --- /project/slime/cvsroot/slime/swank.lisp 2006/08/20 09:36:59 1.393 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/22 09:31:10 1.394 @@ -2324,18 +2324,35 @@ (defun lookup-presented-object (id) "Retrieve the object corresponding to ID. The secondary value indicates the absence of an entry." - (multiple-value-bind (object foundp) - (gethash id *presentation-id-to-object*) - (cond - ((eql object *nil-surrogate*) - ;; A stored nil object - (values nil t)) - ((null object) - ;; Object that was replaced by nil in the weak hash table - ;; when the object was garbage collected. - (values nil nil)) - (t - (values object foundp))))) + (etypecase id + (integer + ;; + (multiple-value-bind (object foundp) + (gethash id *presentation-id-to-object*) + (cond + ((eql object *nil-surrogate*) + ;; A stored nil object + (values nil t)) + ((null object) + ;; Object that was replaced by nil in the weak hash table + ;; when the object was garbage collected. + (values nil nil)) + (t + (values object foundp))))) + (cons + (destructure-case id + ((:frame-var frame index) + (handler-case + (frame-var-value frame index) + (:no-error (value) + (values value t)) + (t (condition) + (declare (ignore condition)) + (values nil nil)))) + ((:inspected-part part-index) + (if (< part-index (length *inspectee-parts*)) + (values (inspector-nth-part part-index) t) + (values nil nil))))))) (defslimefun get-repl-result (id) "Get the result of the previous REPL evaluation with ID." @@ -4584,9 +4601,10 @@ *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) -(defslimefun init-inspector (string) +(defslimefun init-inspector (string &optional (reset t)) (with-buffer-syntax () - (reset-inspector) + (when reset + (reset-inspector)) (inspect-object (eval (read-from-string string))))) (defun print-part-to-string (value) From mkoeppe at common-lisp.net Tue Aug 22 09:31:41 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 22 Aug 2006 05:31:41 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060822093141.4789E3A009@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv428 Modified Files: slime.el Log Message: (slime-inspector-insert-ispec): Mark up all values of inspected parts as presentations. (sldb-insert-locals): Mark up the values of local variables as presentations. (slime-remove-presentation-properties): Fix for read-only buffers. (slime-copy-presentation-at-point): Make it work when the current buffer is not the REPL buffer. (slime-menu-choices-for-presentation): Describe into a separate buffer, not the REPL. New menu item, pretty-print. (slime-presentation-expression): Handle presentation ids that are not numbers. (slime-inspect-presented-object): Don't reset the inspector if already in the inspector buffer. --- /project/slime/cvsroot/slime/slime.el 2006/08/19 15:39:26 1.640 +++ /project/slime/cvsroot/slime/slime.el 2006/08/22 09:31:40 1.641 @@ -2867,15 +2867,16 @@ (overlay-put overlay 'keymap slime-presentation-map)))) (defun slime-remove-presentation-properties (from to presentation) - (remove-text-properties from to - `(,presentation t rear-nonsticky t)) - (when (eq (get-text-property from 'slime-repl-presentation) presentation) - (remove-text-properties from (1+ from) `(slime-repl-presentation t))) - (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) - (remove-text-properties (1- to) to `(slime-repl-presentation t))) - (dolist (overlay (overlays-at from)) - (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) - (delete-overlay overlay)))) + (let ((inhibit-read-only t)) + (remove-text-properties from to + `(,presentation t rear-nonsticky t)) + (when (eq (get-text-property from 'slime-repl-presentation) presentation) + (remove-text-properties from (1+ from) `(slime-repl-presentation t))) + (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) + (remove-text-properties (1- to) to `(slime-repl-presentation t))) + (dolist (overlay (overlays-at from)) + (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) + (delete-overlay overlay))))) (defun slime-insert-presentation (result output-id) (let ((start (point))) @@ -3233,18 +3234,20 @@ (slime-presentation-around-point point) (unless presentation (error "No presentation at click")) - (flet ((do-insertion () - (when (not (string-match "\\s-" - (buffer-substring (1- (point)) (point)))) - (insert " ")) - (insert (buffer-substring start end)) - (when (and (not (eolp)) (not (looking-at "\\s-"))) - (insert " ")))) - (if (>= (point) slime-repl-prompt-start-mark) - (do-insertion) + (let ((presentation-text (buffer-substring start end))) + (slime-switch-to-output-buffer) + (flet ((do-insertion () + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (insert presentation-text) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " ")))) + (if (>= (point) slime-repl-prompt-start-mark) + (do-insertion) (save-excursion (goto-char (point-max)) - (do-insertion))))))))) + (do-insertion)))))))))) (defvar slime-presentation-map (make-sparse-keymap)) @@ -3282,8 +3285,16 @@ ,(savel `(lambda () (interactive) ;; XXX remove call to describe. - (slime-eval '(cl:describe - (swank::lookup-presented-object ',what)))))) + (slime-eval-describe + '(swank::describe-to-string + (swank::lookup-presented-object ',what)))))) + ("Pretty-print" . + ,(savel `(lambda () + (interactive) + (slime-eval-describe + '(swank::swank-pprint + (cl:list + (swank::lookup-presented-object ',what))))))) ("Copy to input" . ,(savel 'slime-copy-presentation-at-point)) ,@(let ((nchoice 0)) (mapcar @@ -3399,8 +3410,13 @@ "Return a string that contains a CL s-expression accessing the presented object." (let ((id (slime-presentation-id presentation))) - ;; Make sure it works even if *read-base* is not 10. - (format "(swank:get-repl-result #10r%d)" id))) + (etypecase id + (number + ;; Make sure it works even if *read-base* is not 10. + (format "(swank:get-repl-result #10r%d)" id)) + (list + ;; for frame variables and inspector parts + (format "(swank:get-repl-result '%s)" id))))) (defun slime-buffer-substring-with-reified-output (start end) (let ((str-props (buffer-substring start end)) @@ -8216,7 +8232,10 @@ (insert prefix (in-sldb-face local-name name)) (unless (zerop id) (insert (in-sldb-face local-name (format "#%d" id)))) - (insert " = " (in-sldb-face local-value value))) + (insert " = ") + (slime-insert-presentation + (in-sldb-face local-value value) + `(:frame-var ,frame ,i))) (insert "\n")))) (defun sldb-inspect-var () @@ -8589,7 +8608,10 @@ (defvar slime-saved-window-config) (defun slime-inspect-presented-object (id) - (slime-inspect `(swank::init-inspector ,(format "(swank::lookup-presented-object '%s)" id)))) + (let ((reset-p (not (eq major-mode 'slime-inspector-mode)))) + (slime-inspect `(swank::init-inspector + ,(format "(swank::lookup-presented-object '%s)" id) + ,reset-p)))) (defun slime-inspect (form) "Eval an expression and inspect the result." @@ -8649,10 +8671,11 @@ (insert ispec) (destructure-case ispec ((:value string id) - (slime-insert-propertized (list 'slime-part-number id - 'mouse-face 'highlight - 'face 'slime-inspector-value-face) - string)) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (slime-insert-presentation string `(:inspected-part ,id)))) ((:action string id) (slime-insert-propertized (list 'slime-action-number id 'mouse-face 'highlight From mkoeppe at common-lisp.net Tue Aug 22 09:34:13 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Tue, 22 Aug 2006 05:34:13 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060822093413.7F52B7C006@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv841 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/20 09:37:13 1.931 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/22 09:34:12 1.932 @@ -1,3 +1,32 @@ +2006-08-21 Matthias Koeppe + + Make the values of local variables in debugger frames and values + of parts in the inspector accessible as presentations. In + particular, this allows to copy # values to the REPL + for further investigation. It also provides a context menu for + the values, offering to inspect, pretty-print, and describe them. + + Note that the presentations are only valid as long as the + corresponding Inspector or Debugger buffer is open. + + * swank.lisp (lookup-presented-object): Handle presentation ids + (:frame-var frame index), (:inspected-part part-index). + (init-inspector): New optional argument, reset. + + * slime.el (slime-inspector-insert-ispec): Mark up all values of + inspected parts as presentations. + (sldb-insert-locals): Mark up the values of local variables as + presentations. + (slime-remove-presentation-properties): Fix for read-only buffers. + (slime-copy-presentation-at-point): Make it work when the current + buffer is not the REPL buffer. + (slime-menu-choices-for-presentation): Describe into a separate + buffer, not the REPL. New menu item, pretty-print. + (slime-presentation-expression): Handle presentation ids that are + not numbers. + (slime-inspect-presented-object): Don't reset the inspector if + already in the inspector buffer. + 2006-08-20 Matthias Koeppe * swank.lisp (*nil-surrogate*): New. @@ -146,7 +175,6 @@ * swank.lisp (keywords-of-operator): New support function for writing user-defined `extra-keywords' methods. ->>>>>>> 1.922 2006-07-11 Helmut Eller * swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak From mkoeppe at common-lisp.net Thu Aug 24 12:15:33 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Thu, 24 Aug 2006 08:15:33 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060824121533.DDA2F38004@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13188 Modified Files: slime.el Log Message: (slime-ensure-presentation-overlay): Provide a help-echo for presentations, showing the mouse bindings. (slime-presentation-around-click): New function. (slime-copy-or-inspect-presentation-at-mouse) (slime-inspect-presentation-at-mouse) (slime-copy-presentation-at-mouse) (slime-describe-presentation-at-mouse) (slime-pretty-print-presentation-at-mouse): New commands. (slime-copy-presentation-at-point): Removed (misnomer). (slime-presentation-map): Bind mouse-2 to slime-copy-or-inspect-presentation-at-mouse, so the right thing is done in REPL buffers and in Inspector and Debugger buffers. (slime-menu-choices-for-presentation): Use the new commands here instead of inline lambdas. (sldb-inspect-in-frame): Use slime-read-object here, so if point is in a presentation in the debugger buffer, inspect it immediately just like slime-inspect does. (slime-inspect-presented-object): Removed. (slime-inspect): Don't expect that "swank:init-inspector" is already part of the form. Accept an optional arg "no-reset". (slime-read-object): Don't add "swank:init-inspector" to the read form; slime-inspect now adds it. --- /project/slime/cvsroot/slime/slime.el 2006/08/22 09:31:40 1.641 +++ /project/slime/cvsroot/slime/slime.el 2006/08/24 12:15:33 1.642 @@ -2863,6 +2863,10 @@ (let ((overlay (make-overlay start end (current-buffer) t nil))) (overlay-put overlay 'slime-repl-presentation presentation) (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) + (overlay-put overlay 'help-echo + (if (eq major-mode 'slime-repl-mode) + "mouse-2: copy to input; mouse-3: menu" + "mouse-2: inspect; mouse-3: menu")) (overlay-put overlay 'face 'slime-repl-inputed-output-face) (overlay-put overlay 'keymap slime-presentation-map)))) @@ -3224,38 +3228,84 @@ (when any-change (undo-boundary))))) -(defun slime-copy-presentation-at-point (event) +(defun slime-presentation-around-click (event) + "Return the presentation around the position of the mouse-click EVENT. +If there is no presentation, signal an error. +Also return the start position, end position, and buffer of the presentation." + (when (and (featurep 'xemacs) (not (button-press-event-p event))) + (error "Command must be bound to a button-press-event")) + (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event)))) + (with-current-buffer (window-buffer window) + (multiple-value-bind (presentation start end) + (slime-presentation-around-point point) + (unless presentation + (error "No presentation at click")) + (values presentation start end (current-buffer)))))) + +(defun slime-copy-or-inspect-presentation-at-mouse (event) + (interactive "e") ; no "@" -- we don't want to select the clicked-at window + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (if (with-current-buffer buffer + (eq major-mode 'slime-repl-mode)) + (slime-copy-presentation-at-mouse event) + (slime-inspect-presentation-at-mouse event)))) + +(defun slime-inspect-presentation-at-mouse (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((reset-p + (with-current-buffer buffer + (not (eq major-mode 'slime-inspector-mode))))) + (slime-inspect (slime-presentation-expression presentation) + (not reset-p))))) + +(defun slime-copy-presentation-at-mouse (event) (interactive "e") - (unless (and (featurep 'xemacs) (not (button-press-event-p event))) - (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) - (window (if (featurep 'xemacs) (event-window event) (caadr event)))) - (with-current-buffer (window-buffer window) - (multiple-value-bind (presentation start end) - (slime-presentation-around-point point) - (unless presentation - (error "No presentation at click")) - (let ((presentation-text (buffer-substring start end))) - (slime-switch-to-output-buffer) - (flet ((do-insertion () - (when (not (string-match "\\s-" - (buffer-substring (1- (point)) (point)))) - (insert " ")) - (insert presentation-text) - (when (and (not (eolp)) (not (looking-at "\\s-"))) - (insert " ")))) - (if (>= (point) slime-repl-prompt-start-mark) - (do-insertion) - (save-excursion - (goto-char (point-max)) - (do-insertion)))))))))) + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (unless (eql major-mode 'slime-repl-mode) + (slime-switch-to-output-buffer)) + (flet ((do-insertion () + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (insert presentation-text) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " ")))) + (if (>= (point) slime-repl-prompt-start-mark) + (do-insertion) + (save-excursion + (goto-char (point-max)) + (do-insertion))))))) + +(defun slime-describe-presentation-at-mouse (event) + (interactive "@e") + (multiple-value-bind (presentation) (slime-presentation-around-click event) + (slime-eval-describe + `(swank::describe-to-string + (swank::lookup-presented-object ',(slime-presentation-id presentation)))))) + +(defun slime-pretty-print-presentation-at-mouse (event) + (interactive "@e") + (multiple-value-bind (presentation) (slime-presentation-around-click event) + (slime-eval-describe + `(swank::swank-pprint + (cl:list + (swank::lookup-presented-object ',(slime-presentation-id presentation))))))) (defvar slime-presentation-map (make-sparse-keymap)) -(define-key slime-presentation-map [mouse-2] 'slime-copy-presentation-at-point) +(define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse) (define-key slime-presentation-map [mouse-3] 'slime-presentation-menu) (when (featurep 'xemacs) - (define-key slime-presentation-map [button2] 'slime-copy-presentation-at-point) + (define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse) (define-key slime-presentation-map [button3] 'slime-presentation-menu)) ;; protocol for handling up a menu. @@ -3278,24 +3328,10 @@ (list `(,(if (featurep 'xemacs) " " "") ("" - ("Inspect" . ,(savel `(lambda () - (interactive) - (slime-inspect-presented-object ',what)))) - ("Describe" . - ,(savel `(lambda () - (interactive) - ;; XXX remove call to describe. - (slime-eval-describe - '(swank::describe-to-string - (swank::lookup-presented-object ',what)))))) - ("Pretty-print" . - ,(savel `(lambda () - (interactive) - (slime-eval-describe - '(swank::swank-pprint - (cl:list - (swank::lookup-presented-object ',what))))))) - ("Copy to input" . ,(savel 'slime-copy-presentation-at-point)) + ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse)) + ("Describe" . ,(savel 'slime-describe-presentation-at-mouse)) + ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse)) + ("Copy to input" . ,(savel 'slime-copy-presentation-at-mouse)) ,@(let ((nchoice 0)) (mapcar (lambda (choice) @@ -8165,9 +8201,8 @@ (defun sldb-inspect-in-frame (string) "Prompt for an expression and inspect it in the selected frame." - (interactive (list (slime-read-from-minibuffer - "Inspect in frame (evaluated): " - (slime-sexp-at-point)))) + (interactive (list (slime-read-object + "Inspect in frame (evaluated): "))) (let ((number (sldb-frame-number-at-point))) (slime-eval-async `(swank:inspect-in-frame ,string ,number) 'slime-open-inspector))) @@ -8607,25 +8642,22 @@ (defvar slime-inspector-mark-stack '()) (defvar slime-saved-window-config) -(defun slime-inspect-presented-object (id) - (let ((reset-p (not (eq major-mode 'slime-inspector-mode)))) - (slime-inspect `(swank::init-inspector - ,(format "(swank::lookup-presented-object '%s)" id) - ,reset-p)))) - -(defun slime-inspect (form) +(defun slime-inspect (form &optional no-reset) "Eval an expression and inspect the result." (interactive (list (slime-read-object "Inspect value (evaluated): "))) - (slime-eval-async form 'slime-open-inspector)) + (slime-eval-async `(swank:init-inspector ,form ,(not no-reset)) + 'slime-open-inspector)) (defun slime-read-object (prompt) + "Read a Common Lisp expression from the minibuffer, providing +defaults from the s-expression at point. If point is within a +presentation, don't prompt, just return the presentation." (multiple-value-bind (presentation start end) (slime-presentation-around-point (point)) - `(swank:init-inspector - ,(if presentation - (slime-presentation-expression presentation) - (slime-read-from-minibuffer "Inspect value (evaluated): " - (slime-sexp-at-point)))))) + (if presentation + (slime-presentation-expression presentation) + (slime-read-from-minibuffer prompt + (slime-sexp-at-point))))) (define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector" (set-syntax-table lisp-mode-syntax-table) From mkoeppe at common-lisp.net Thu Aug 24 12:15:59 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Thu, 24 Aug 2006 08:15:59 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060824121559.CF3A939011@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13241 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/22 09:34:12 1.932 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/24 12:15:59 1.933 @@ -1,3 +1,28 @@ +2006-08-24 Matthias Koeppe + + * slime.el (slime-ensure-presentation-overlay): Provide a + help-echo for presentations, showing the mouse bindings. + (slime-presentation-around-click): New function. + (slime-copy-or-inspect-presentation-at-mouse) + (slime-inspect-presentation-at-mouse) + (slime-copy-presentation-at-mouse) + (slime-describe-presentation-at-mouse) + (slime-pretty-print-presentation-at-mouse): New commands. + (slime-copy-presentation-at-point): Removed (misnomer). + (slime-presentation-map): Bind mouse-2 to + slime-copy-or-inspect-presentation-at-mouse, so the right thing is + done in REPL buffers and in Inspector and Debugger buffers. + (slime-menu-choices-for-presentation): Use the new commands here + instead of inline lambdas. + (sldb-inspect-in-frame): Use slime-read-object here, so if point + is in a presentation in the debugger buffer, inspect it + immediately just like slime-inspect does. + (slime-inspect-presented-object): Removed. + (slime-inspect): Don't expect that "swank:init-inspector" is + already part of the form. Accept an optional arg "no-reset". + (slime-read-object): Don't add "swank:init-inspector" to the read + form; slime-inspect now adds it. + 2006-08-21 Matthias Koeppe Make the values of local variables in debugger frames and values From mkoeppe at common-lisp.net Fri Aug 25 15:44:07 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 25 Aug 2006 11:44:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060825154407.7B2587D0B4@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5985 Modified Files: swank.lisp Log Message: (lookup-presented-object): Fix for OpenMCL 1.0 [ppc32], which requires that the :NO-ERROR clause is last in HANDLER-CASE. --- /project/slime/cvsroot/slime/swank.lisp 2006/08/22 09:31:10 1.394 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/25 15:44:07 1.395 @@ -2344,11 +2344,11 @@ ((:frame-var frame index) (handler-case (frame-var-value frame index) - (:no-error (value) - (values value t)) (t (condition) (declare (ignore condition)) - (values nil nil)))) + (values nil nil)) + (:no-error (value) + (values value t)))) ((:inspected-part part-index) (if (< part-index (length *inspectee-parts*)) (values (inspector-nth-part part-index) t) From mkoeppe at common-lisp.net Fri Aug 25 15:44:46 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 25 Aug 2006 11:44:46 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060825154446.585E87C016@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6043 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/24 12:15:59 1.933 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/25 15:44:45 1.934 @@ -1,3 +1,9 @@ +2006-08-25 Kai Kaminski + + * swank.lisp (lookup-presented-object): Fix for OpenMCL 1.0 + [ppc32], which requires that the :NO-ERROR clause is last in + HANDLER-CASE. + 2006-08-24 Matthias Koeppe * slime.el (slime-ensure-presentation-overlay): Provide a From mkoeppe at common-lisp.net Sat Aug 26 12:11:07 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 26 Aug 2006 08:11:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060826121107.351B455338@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3659 Modified Files: slime.el Log Message: (slime-repl-return-behaviour): Fix the defcustom type, so Emacs 21.3 does not signal an error when creating a customization buffer containing this variable. --- /project/slime/cvsroot/slime/slime.el 2006/08/24 12:15:33 1.642 +++ /project/slime/cvsroot/slime/slime.el 2006/08/26 12:11:06 1.643 @@ -437,8 +437,8 @@ :send-only-if-after-complete - If the current expression is complete and point is after the expression it is sent, otherwise a newline is inserted." - :type '(choice (const :send-if-complete) - (const :send-only-if-after-complete)) + :type '(choice (const :tag "Send if complete" :value :send-if-complete) + (const :tag "Send only if after complete" :value :send-only-if-after-complete)) :group 'slime-repl) From mkoeppe at common-lisp.net Sat Aug 26 12:11:21 2006 From: mkoeppe at common-lisp.net (mkoeppe) Date: Sat, 26 Aug 2006 08:11:21 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060826121121.D4FEE5831A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3704 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/25 15:44:45 1.934 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/26 12:11:21 1.935 @@ -1,3 +1,9 @@ +2006-08-26 Matthias Koeppe + + * slime.el (slime-repl-return-behaviour): Fix the defcustom type, + so Emacs 21.3 does not signal an error when creating a + customization buffer containing this variable. + 2006-08-25 Kai Kaminski * swank.lisp (lookup-presented-object): Fix for OpenMCL 1.0 From heller at common-lisp.net Sun Aug 27 11:01:43 2006 From: heller at common-lisp.net (heller) Date: Sun, 27 Aug 2006 07:01:43 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060827110143.C70F850014@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28542 Modified Files: swank.lisp Log Message: (input-available-p, process-available-input): Use READ-CHAR-NO-HANG instead of LISTEN because LISTEN suddenly returns false in SBCL 0.9.?? even if we are called from a fd-handler and the OPEN-STREAM-P returns true. --- /project/slime/cvsroot/slime/swank.lisp 2006/08/25 15:44:07 1.395 +++ /project/slime/cvsroot/slime/swank.lisp 2006/08/27 11:01:43 1.396 @@ -748,10 +748,19 @@ (loop (handle-request connection))) (defun process-available-input (stream fn) - (loop while (and (open-stream-p stream) - (listen stream)) + (loop while (input-available-p stream) do (funcall fn))) +(defun input-available-p (stream) + ;; return true iff we can read from STREAM without waiting or if we + ;; hit EOF + (let ((c (read-char-no-hang stream nil :eof))) + (cond ((not c) nil) + ((eq c :eof) t) + (t + (unread-char c stream) + t)))) + ;;;;;; Signal driven IO (defun install-sigio-handler (connection) @@ -781,15 +790,15 @@ ((eq (car *swank-state-stack*) :read-next-form)) (t (process-available-input client #'read-from-emacs))))) - ;; handle sigint - (install-debugger-globally - (lambda (c h) - (with-reader-error-handler (connection) - (block debugger - (with-connection (connection) - (swank-debugger-hook c h) - (return-from debugger)) - (abort))))) + ;;;; handle sigint + ;;(install-debugger-globally + ;; (lambda (c h) + ;; (with-reader-error-handler (connection) + ;; (block debugger + ;; (with-connection (connection) + ;; (swank-debugger-hook c h) + ;; (return-from debugger)) + ;; (abort))))) (add-fd-handler client #'handler) (handler)))) @@ -5034,8 +5043,5 @@ (load source-file) nil))) (and (next-method-p) (call-next-method)))))) - -;; Local Variables: -;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) -;; End: +;;; swank.lisp ends here From heller at common-lisp.net Sun Aug 27 11:03:37 2006 From: heller at common-lisp.net (heller) Date: Sun, 27 Aug 2006 07:03:37 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20060827110337.3E72B58319@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28794 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2006/08/26 12:11:21 1.935 +++ /project/slime/cvsroot/slime/ChangeLog 2006/08/27 11:03:37 1.936 @@ -1,3 +1,10 @@ +2006-08-27 Helmut Eller + + * swank.lisp (input-available-p, process-available-input): Use + READ-CHAR-NO-HANG instead of LISTEN because LISTEN suddenly + returns false in SBCL 0.9.?? even if we are called from a + fd-handler and the OPEN-STREAM-P returns true. + 2006-08-26 Matthias Koeppe * slime.el (slime-repl-return-behaviour): Fix the defcustom type,