From trittweiler at common-lisp.net Sun Aug 3 12:05:18 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 3 Aug 2008 08:05:18 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080803120518.1982231063@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv23083 Modified Files: slime.el ChangeLog Log Message: * slime.el: Make code related to temp buffers more consistent. (slime-with-output-to-temp-buffer): Docstring update. New keyarg :connection to specify whether the current connection should be stored buffer-locally. New key arg :emacs-snapshot to explicitly pass the snapshot to be stored. The created buffer is not automatically set to slime-mode anymore. (slime-temp-buffer-mode): Add `C-c C-z', and `M-.' bindings to all temp buffers. (slime-list-compiler-notes): Use `slime-with-output-to-...', rename the buffer from "*compiler notes*" to "*SLIME Compiler-Notes*". (slime-compiler-notes-mode-map): Remove explicit binding of "q", as it's inherited from the temp buffer. (slime-edit-value-callback): Use `slime-with-output-to-...'. (slime-show-apropos): Adapted to above changes. (slime-macroexpansion-minor-mode): Removed "q" binding, as it's inherited. (slime-eval-macroexpand): Adapted. Rename buffer from "*SLIME macroexpansion*" to "*SLIME Macroexpansion*". (slime-list-connections): Use `slime-with-output-to-...', rename buffer from "*SLIME connections*" to "*SLIME Connections*". --- /project/slime/cvsroot/slime/slime.el 2008/07/31 08:31:30 1.953 +++ /project/slime/cvsroot/slime/slime.el 2008/08/03 12:05:09 1.954 @@ -954,24 +954,44 @@ (current-buffer)))) ;; Interface -(defmacro* slime-with-output-to-temp-buffer ((name &key mode reusep) +(defmacro* slime-with-output-to-temp-buffer ((name &key mode emacs-snapshot + connection reusep) package &rest body) - "Similar to `with-output-to-temp-buffer'. -Also saves the current state of Emacs (window configuration &c), -and inherits the current `slime-connection' in a buffer-local -variable. Cf. `slime-get-temp-buffer-create'" - `(let ((connection (slime-connection)) - (standard-output (slime-get-temp-buffer-create ,name :mode ',mode - :reusep ,reusep))) - (prog1 (with-current-buffer standard-output - ;; set explicitely to NIL in case the buffer got reused. (REUSEP) - (let ((buffer-read-only nil)) , at body)) + "Similar to `with-output-to-temp-buffer', but also remembers +Slime-related stuff. Used to implement Slime's Description, +Apropos, Macroexpand &c buffers. + +`name' is the name of the buffer to be created. + +`package' is the package that's associated with the buffer. + +`mode' is the major the temporary buffer should be set to. If +desired, you can enable additional minor-modes explicitly in the +body. + +`emacs-snapshot' is the Emacs state (window configuration &c.) +that should be restored when the user quits the temporary buffer. +If not explictly passed, a snapshot of the current state is taken +and saved. + +`connection' is the Slime connection that should be stored +buffer-locally. If nil, no explicit connection is associated with +the buffer. If t, the current connection is taken. + +If `reusep' is t, an already existing buffer won't be killed, and +recreated." + `(let ((standard-output + (slime-get-temp-buffer-create ,name :mode ',mode + :emacs-snapshot ,emacs-snapshot + :reusep ,reusep))) + (prog1 (with-current-buffer standard-output + (let ((buffer-read-only nil)) ; in case the buffer is reused. + , at body)) (with-current-buffer standard-output - (setq slime-buffer-connection connection) (setq slime-buffer-package ,package) + (setq slime-buffer-connection + ,(if (eq connection 't) `(slime-connection) connection)) (goto-char (point-min)) - (slime-mode 1) - (set-syntax-table lisp-mode-syntax-table) (setq buffer-read-only t))))) (put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2) @@ -979,8 +999,10 @@ (define-minor-mode slime-temp-buffer-mode "Mode for displaying read only stuff" nil - " temp" - '(("q" . slime-temp-buffer-quit))) + " Tmp" + '(("q" . slime-temp-buffer-quit) + ("\C-c\C-z" . slime-switch-to-output-buffer) + ("\M-." . slime-edit-definition))) ;; Interface (defun slime-temp-buffer-quit (&optional kill-buffer-p) @@ -4077,18 +4099,16 @@ "Show the compiler notes NOTES in tree view." (interactive (list (slime-compiler-notes))) (with-temp-message "Preparing compiler note tree..." - (with-current-buffer - (slime-get-temp-buffer-create "*compiler notes*" - :mode 'slime-compiler-notes-mode - :emacs-snapshot emacs-snapshot) - (let ((inhibit-read-only t)) - (erase-buffer) - (when (null notes) - (insert "[no notes]")) - (dolist (tree (slime-compiler-notes-to-tree notes)) - (slime-tree-insert tree "") - (insert "\n"))) - (setq buffer-read-only t) + (slime-with-output-to-temp-buffer ("*SLIME Compiler-Notes*" + :mode slime-compiler-notes-mode + :emacs-snapshot emacs-snapshot) + nil + (erase-buffer) + (when (null notes) + (insert "[no notes]")) + (dolist (tree (slime-compiler-notes-to-tree notes)) + (slime-tree-insert tree "") + (insert "\n")) (goto-char (point-min))))) (defun slime-alistify (list key test) @@ -4152,7 +4172,7 @@ (defvar slime-compiler-notes-mode-map) (define-derived-mode slime-compiler-notes-mode fundamental-mode - "Compiler Notes" + "Compiler-Notes" "\\\ \\{slime-compiler-notes-mode-map}" (slime-set-truncate-lines)) @@ -4160,8 +4180,7 @@ (slime-define-keys slime-compiler-notes-mode-map ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details) ([return] 'slime-compiler-notes-default-action-or-show-details) - ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse) - ("q" 'slime-temp-buffer-quit)) + ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse)) (defun slime-compiler-notes-default-action-or-show-details/mouse (event) "Invoke the action pointed at by the mouse, or show details." @@ -5339,8 +5358,8 @@ fn))) (defun slime-show-description (string package) - (slime-with-output-to-temp-buffer ("*SLIME Description*") - package (princ string))) + (slime-with-output-to-temp-buffer ("*SLIME Description*") package + (princ string))) (defun slime-eval-describe (form) "Evaluate FORM in Lisp and display the result in a new buffer." @@ -5484,18 +5503,16 @@ (define-minor-mode slime-edit-value-mode "Mode for editing a Lisp value." nil - " edit" + " Edit-Value" '(("\C-c\C-c" . slime-edit-value-commit))) (defun slime-edit-value-callback (form-string current-value package) (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))) - (with-current-buffer (slime-get-temp-buffer-create name :mode 'lisp-mode) + (slime-with-output-to-temp-buffer (name :mode lisp-mode :connection t) package (slime-mode 1) (slime-temp-buffer-mode -1) ; don't want binding of 'q' (slime-edit-value-mode 1) (setq slime-edit-form-string form-string) - (setq slime-buffer-connection (slime-connection)) - (setq slime-buffer-package package) (insert current-value)))) (defun slime-edit-value-commit () @@ -5892,16 +5909,17 @@ (defun slime-show-apropos (plists string package summary) (if (null plists) (message "No apropos matches for %S" string) - (slime-with-output-to-temp-buffer ("*SLIME Apropos*" :mode apropos-mode) + (slime-with-output-to-temp-buffer ("*SLIME Apropos*" :mode apropos-mode + :connection t) package - (set-syntax-table lisp-mode-syntax-table) - (slime-mode t) (if (boundp 'header-line-format) (setq header-line-format summary) (insert summary "\n\n")) (slime-set-truncate-lines) (slime-print-apropos plists)))) +(eval-when-compile (require 'apropos)) + (defvar slime-apropos-label-properties (progn (require 'apropos) @@ -5914,8 +5932,6 @@ mouse-face highlight)) (list (symbol-value 'apropos-label-face))))))) -(eval-when-compile (require 'apropos)) - (defun slime-print-apropos (plists) (dolist (plist plists) (let ((designator (plist-get plist :designator))) @@ -6290,9 +6306,8 @@ (define-minor-mode slime-macroexpansion-minor-mode "SLIME mode for macroexpansion" nil - " temp" - '(("q" . slime-temp-buffer-quit) - ("g" . slime-macroexpand-again))) + " Macroexpand" + '(("g" . slime-macroexpand-again))) (flet ((remap (from to) (dolist (mapping (where-is-internal from slime-mode-map)) @@ -6340,8 +6355,9 @@ (lambda (expansion) (slime-with-output-to-temp-buffer ;; reusep for preserving `undo' functionality. - ("*SLIME macroexpansion*" :mode lisp-mode :reusep t) package - (slime-macroexpansion-minor-mode) + ("*SLIME Macroexpansion*" :mode lisp-mode :reusep t :connection t) package + (slime-mode 1) + (slime-macroexpansion-minor-mode 1) (erase-buffer) (insert expansion) (goto-char (point-min)) @@ -7359,7 +7375,7 @@ ;;;;; Major mode (define-derived-mode slime-thread-control-mode fundamental-mode - "thread-control" + "Slime-Threads" "SLIME Thread Control Panel Mode. \\{slime-thread-control-mode-map}" @@ -7400,7 +7416,7 @@ ;;;;; Connection listing (define-derived-mode slime-connection-list-mode fundamental-mode - "connection-list" + "Slime-Connections" "SLIME Connection List Mode. \\{slime-connection-list-mode-map}" @@ -7447,14 +7463,11 @@ (defun slime-list-connections () "Display a list of all connections." (interactive) - (when (get-buffer "*SLIME connections*") - (kill-buffer "*SLIME connections*")) - (with-current-buffer - (slime-get-temp-buffer-create "*SLIME connections*" - :mode 'slime-connection-list-mode) - (slime-draw-connection-list) - (setq buffer-read-only t) - (pop-to-buffer (current-buffer)))) + (when (get-buffer "*SLIME Connections*") + (kill-buffer "*SLIME Connections*")) + (slime-with-output-to-temp-buffer ("*SLIME Connections*" + :mode slime-connection-list-mode) nil + (slime-draw-connection-list))) (defun slime-update-connection-list () "Display a list of all connections." --- /project/slime/cvsroot/slime/ChangeLog 2008/07/31 08:31:32 1.1379 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/03 12:05:11 1.1380 @@ -1,5 +1,31 @@ 2008-07-27 Tobias C. Rittweiler + * slime.el: Make code related to temp buffers more consistent. + + (slime-with-output-to-temp-buffer): Docstring update. New keyarg + :connection to specify whether the current connection should be + stored buffer-locally. New key arg :emacs-snapshot to explicitly + pass the snapshot to be stored. The created buffer is not + automatically set to slime-mode anymore. + (slime-temp-buffer-mode): Add `C-c C-z', and `M-.' bindings to all + temp buffers. + + (slime-list-compiler-notes): Use `slime-with-output-to-...', + rename the buffer from "*compiler notes*" to "*SLIME + Compiler-Notes*". + (slime-compiler-notes-mode-map): Remove explicit binding of "q", + as it's inherited from the temp buffer. + (slime-edit-value-callback): Use `slime-with-output-to-...'. + (slime-show-apropos): Adapted to above changes. + (slime-macroexpansion-minor-mode): Removed "q" binding, as it's + inherited. + (slime-eval-macroexpand): Adapted. Rename buffer from "*SLIME + macroexpansion*" to "*SLIME Macroexpansion*". + (slime-list-connections): Use `slime-with-output-to-...', rename + buffer from "*SLIME connections*" to "*SLIME Connections*". + +2008-07-27 Tobias C. Rittweiler + * slime.el (make-slime-buffer-location): New. (make-slime-file-location): New. From trittweiler at common-lisp.net Sun Aug 3 13:30:11 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 3 Aug 2008 09:30:11 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080803133011.7896B7A001@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9097 Modified Files: ChangeLog Log Message: fix changelog date --- /project/slime/cvsroot/slime/ChangeLog 2008/08/03 12:05:11 1.1380 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/03 13:30:10 1.1381 @@ -1,4 +1,4 @@ -2008-07-27 Tobias C. Rittweiler +2008-08-03 Tobias C. Rittweiler * slime.el: Make code related to temp buffers more consistent. From trittweiler at common-lisp.net Sun Aug 3 13:31:54 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 3 Aug 2008 09:31:54 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080803133154.7E7082E2D9@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv9286/contrib Modified Files: slime-presentations.el ChangeLog Log Message: * slime-presentations.el (slime-presentation-around-or-before-point): Guard against the case being used at the start of a buffer. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/04/06 10:02:24 1.15 +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/08/03 13:31:54 1.16 @@ -271,7 +271,7 @@ (let ((object (or object (current-buffer)))) (multiple-value-bind (presentation start end whole-p) (slime-presentation-around-point point object) - (if presentation + (if (or presentation (= point (point-min))) (values presentation start end whole-p) (slime-presentation-around-point (1- point) object))))) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/07/31 08:37:22 1.112 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/03 13:31:54 1.113 @@ -1,3 +1,8 @@ +2008-08-03 Tobias C. Rittweiler + + * slime-presentations.el (slime-presentation-around-or-before-point): + Guard against the case being used at the start of a buffer. + 2008-07-31 Tobias C. Rittweiler * slime-mdot-fu.el: New contrib. Makes M-. work on local definitions. From heller at common-lisp.net Sun Aug 3 18:23:10 2008 From: heller at common-lisp.net (heller) Date: Sun, 3 Aug 2008 14:23:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080803182310.CF0FB16@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv8826 Modified Files: ChangeLog slime.el swank-allegro.lisp swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp swank.lisp Log Message: Add some flow-control. * swank.lisp (make-output-function): Synchronize with Emacs on every 100th chunk of output. (wait-for-event,wait-for-event/event-loop,event-match-p): New functions. Used to selectively wait for some events and to queue the other events. (dispatch-event, read-from-socket-io): Tag non-queueable events with :call. (read-from-control-thread, read-from-emacs): Process :call events only; enqueue the others. (*log-output*): Don't use synonym-streams here. Dereference the symbol until we get at the real stream. (log-event): Escape non-ascii characters more carefully. * swank-backend.lisp (receive-if): New function. Update backends accordingly. (not yet for ABCL and SCL) * slime.el (slime-dispatch-event): Handle ping event. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/03 13:30:10 1.1381 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/03 18:23:09 1.1382 @@ -1,3 +1,26 @@ +2008-08-03 Helmut Eller + + Add some flow-control. + + * swank.lisp (make-output-function): Synchronize with Emacs on + every 100th chunk of output. + (wait-for-event,wait-for-event/event-loop,event-match-p): New + functions. Used to selectively wait for some events and to queue + the other events. + (dispatch-event, read-from-socket-io): Tag non-queueable events + with :call. + (read-from-control-thread, read-from-emacs): Process + :call events only; enqueue the others. + + (*log-output*): Don't use synonym-streams here. Dereference the + symbol until we get at the real stream. + (log-event): Escape non-ascii characters more carefully. + + * swank-backend.lisp (receive-if): New function. + Update backends accordingly. (not yet for ABCL and SCL) + + * slime.el (slime-dispatch-event): Handle ping event. + 2008-08-03 Tobias C. Rittweiler * slime.el: Make code related to temp buffers more consistent. --- /project/slime/cvsroot/slime/slime.el 2008/08/03 12:05:09 1.954 +++ /project/slime/cvsroot/slime/slime.el 2008/08/03 18:23:10 1.955 @@ -2337,7 +2337,9 @@ (slime-background-message "%s" message)) ((:debug-condition thread message) (assert thread) - (message "%s" message)))))) + (message "%s" message)) + ((:ping thread tag) + (slime-send `(:emacs-pong ,thread ,tag))))))) (defun slime-send (sexp) "Send SEXP directly over the wire on the current connection." --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/07/04 22:59:53 1.103 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/03 18:23:10 1.104 @@ -674,11 +674,6 @@ (defimplementation send (thread message) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) - (mp:process-wait-with-timeout - "yielding before sending" 0.1 - (lambda () - (mp:with-process-lock (mutex) - (< (length (mailbox.queue mbox)) 10)))) (mp:with-process-lock (mutex) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message)))))) @@ -690,6 +685,17 @@ (mp:with-process-lock (mutex) (pop (mailbox.queue mbox))))) +(defimplementation receive-if (test) + (let ((mbox (mailbox mp:*current-process*))) + (mp:process-wait "receive-if" + (lambda () (some test (mailbox.queue mbox)))) + (mp:with-process-lock ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (assert tail) + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (car tail))))) + (defimplementation quit-lisp () (excl:exit 0 :quiet t)) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/07/26 23:05:59 1.135 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/03 18:23:10 1.136 @@ -36,6 +36,7 @@ #:emacs-inspect #:label-value-line #:label-value-line* + #:with-struct )) @@ -1020,6 +1021,9 @@ (definterface receive () "Return the next message from current thread's mailbox.") +(definterface receive-if (predicate) + "Return the first message satisfiying PREDICATE.") + (definterface toggle-trace (spec) "Toggle tracing of the function(s) given with SPEC. SPEC can be: --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/04/17 14:56:43 1.69 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/03 18:23:10 1.70 @@ -667,6 +667,10 @@ #+lisp=cl (ext:quit) #-lisp=cl (lisp:quit)) +(defimplementation thread-id (thread) + (declare (ignore thread)) + 0) + ;;;; Weak hashtables (defimplementation make-weak-key-hash-table (&rest args) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/06/02 18:24:41 1.181 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/03 18:23:10 1.182 @@ -2110,6 +2110,19 @@ (mp:with-lock-held (mutex) (pop (mailbox.queue mbox))))) + (defimplementation receive-if (test) + (let ((mbox (mailbox mp:*current-process*))) + (mp:process-wait "receive-if" + (lambda (mbox test) + (some test (mailbox.queue mbox))) + mbox test) + (mp:with-lock-held ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (assert tail) + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (car tail))))) + ) ;; #+mp --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/07/02 10:02:57 1.100 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/03 18:23:10 1.101 @@ -744,7 +744,20 @@ (mp:make-mailbox))))) (defimplementation receive () - (mp:mailbox-read (mailbox mp:*current-process*))) + (receive-if (constantly t))) + +(defimplementation receive-if (test) + (loop + (let* ((self mp:*current-process*) + (q (getf (mp:process-plist self) 'queue)) + (tail (member-if test q))) + (cond (tail + (setf (getf (mp:process-plist self) 'queue) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (t + (setf (getf (mp:process-plist self) 'queue) + (nconc q (list (mp:mailbox-read (mailbox self)))))))))) (defimplementation send (thread object) (mp:mailbox-send (mailbox thread) object)) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/04/17 14:56:43 1.125 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/03 18:23:10 1.126 @@ -959,12 +959,20 @@ (ccl:signal-semaphore (mailbox.semaphore mbox))))) (defimplementation receive () + (receive-if (constantly t))) + +(defimplementation receive-if (test) (let* ((mbox (mailbox ccl:*current-process*)) (mutex (mailbox.mutex mbox))) - (ccl:wait-on-semaphore (mailbox.semaphore mbox)) - (ccl:with-lock-grabbed (mutex) - (assert (mailbox.queue mbox)) - (pop (mailbox.queue mbox))))) + (loop + (ccl:with-lock-grabbed (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (ccl:wait-on-semaphore (mailbox.semaphore mbox))))) (defimplementation quit-lisp () (ccl::quit)) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/07/29 11:03:25 1.201 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/03 18:23:10 1.202 @@ -1295,6 +1295,18 @@ (t (sb-thread:condition-wait (mailbox.waitqueue mbox) mutex)))))))) + (defimplementation receive-if (test) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (loop + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (cond (tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (t (sb-thread:condition-wait (mailbox.waitqueue mbox) + mutex)))))))) ;; Auto-flush streams --- /project/slime/cvsroot/slime/swank.lisp 2008/07/26 23:05:59 1.548 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/03 18:23:10 1.549 @@ -358,7 +358,12 @@ ;;;;; Logging (defvar *log-events* nil) -(defvar *log-output* *error-output*) +(defvar *log-output* + (labels ((ref (x) + (cond ((typep x 'synonym-stream) + (ref (symbol-value (synonym-stream-symbol x)))) + (t x)))) + (ref *error-output*))) (defvar *event-history* (make-array 40 :initial-element nil) "A ring buffer to record events for better error messages.") (defvar *event-history-index* 0) @@ -377,7 +382,8 @@ (setf *event-history-index* (mod (1+ *event-history-index*) (length *event-history*)))) (when *log-events* - (apply #'format *log-output* format-string args) + (write-string (escape-non-ascii (format nil "~?" format-string args)) + *log-output*) (force-output *log-output*))))) (defun event-history-to-list () @@ -394,7 +400,10 @@ (cond ((stringp event) (write-string (escape-non-ascii event) stream)) ((null event)) - (t (format stream "Unexpected event: ~A~%" event)))) + (t + (write-string + (escape-non-ascii (format nil "Unexpected event: ~A~%" event)) + stream)))) (defun escape-non-ascii (string) "Return a string like STRING but with non-ascii chars escaped." @@ -701,40 +710,38 @@ (defun open-streams (connection) "Return the 5 streams for IO redirection: DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" - (multiple-value-bind (output-fn dedicated-output) - (make-output-function connection) - (let ((input-fn - (lambda () - (with-connection (connection) - (with-simple-restart (abort-read - "Abort reading input from Emacs.") - (read-user-input-from-emacs)))))) - (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) - (let ((out (or dedicated-output out))) - (let ((io (make-two-way-stream in out))) - (mapc #'make-stream-interactive (list in out io)) - (let ((repl-results - (make-output-stream-for-target connection :repl-result))) - (values dedicated-output in out io repl-results)))))))) + (let ((output-fn (make-output-function connection)) + (input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs)))))) + (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) + (let* ((dedicated-output (if *use-dedicated-output-stream* + (open-dedicated-output-stream + (connection.socket-io connection)))) + (out (or dedicated-output out)) + (io (make-two-way-stream in out)) + (repl-results (make-output-stream-for-target connection + :repl-result))) + (mapc #'make-stream-interactive (list in out io)) + (values dedicated-output in out io repl-results))))) +;; FIXME: if wait-for-event aborts the event will stay in the queue forever. (defun make-output-function (connection) - "Create function to send user output to Emacs. -This function may open a dedicated socket to send output. It -returns two values: the output function, and the dedicated -stream (or NIL if none was created)." - (if *use-dedicated-output-stream* - (let ((stream (open-dedicated-output-stream - (connection.socket-io connection)))) - (values (lambda (string) - (write-string string stream) - (force-output stream)) - stream)) - (values (lambda (string) - (with-connection (connection) - (with-simple-restart - (abort "Abort sending output to Emacs.") - (send-to-emacs `(:write-string ,string))))) - nil))) + "Create function to send user output to Emacs." + (let ((max 100) (i 0) (tag 0)) + (lambda (string) + (with-connection (connection) + (with-simple-restart (abort "Abort sending output to Emacs.") + (when (= i max) + (setf tag (mod (1+ tag) 1000)) + (send-to-emacs `(:ping ,(thread-id (current-thread)) ,tag)) + (wait-for-event `(:emacs-pong ,tag)) + (setf i 0)) + (incf i) + (send-to-emacs `(:write-string ,string))))))) (defun make-output-function-for-target (connection target) "Create a function to send user output to a specific TARGET in Emacs." @@ -922,7 +929,7 @@ ((:emacs-rex form package thread-id id) (let ((thread (thread-for-evaluation thread-id))) (push thread *active-threads*) - (send thread `(eval-for-emacs ,form ,package ,id)))) + (send thread `(:call eval-for-emacs ,form ,package ,id)))) ((:return thread &rest args) (let ((tail (member thread *active-threads*))) (setq *active-threads* (nconc (ldiff *active-threads* tail) @@ -940,14 +947,16 @@ ((:read-aborted thread &rest args) (encode-message `(:read-aborted ,(thread-id thread) , at args) socket-io)) ((:emacs-return-string thread-id tag string) - (send (find-thread thread-id) `(take-input ,tag ,string))) + (send (find-thread thread-id) `(:call take-input ,tag ,string))) ((:eval thread &rest args) (encode-message `(:eval ,(thread-id thread) , at args) socket-io)) ((:emacs-return thread-id tag value) - (send (find-thread thread-id) `(take-input ,tag ,value))) + (send (find-thread thread-id) `(:call take-input ,tag ,value))) + ((:emacs-pong thread-id tag) + (send (find-thread thread-id) `(:emacs-pong ,tag))) (((:write-string :presentation-start :presentation-end :new-package :new-features :ed :%apply :indentation-update - :eval-no-wait :background-message :inspect) + :eval-no-wait :background-message :inspect :ping) &rest _) (declare (ignore _)) (encode-message event socket-io)))) @@ -1061,16 +1070,19 @@ (destructure-case event ((:emacs-rex form package thread id) (declare (ignore thread)) - `(eval-for-emacs ,form ,package ,id)) + `(:call eval-for-emacs ,form ,package ,id)) ((:emacs-interrupt thread) (declare (ignore thread)) - '(simple-break)) + '(:call simple-break)) ((:emacs-return-string thread tag string) (declare (ignore thread)) - `(take-input ,tag ,string)) + `(:call take-input ,tag ,string)) ((:emacs-return thread tag value) (declare (ignore thread)) - `(take-input ,tag ,value))))) + `(:call take-input ,tag ,value)) + ((:emacs-pong thread tag) + (declare (ignore thread)) + `(:emacs-pong ,tag))))) (defun send-to-socket-io (event) (log-event "DISPATCHING: ~S~%" event) @@ -1089,7 +1101,7 @@ (((:write-string :new-package :new-features :debug-condition :presentation-start :presentation-end :indentation-update :ed :%apply :eval-no-wait - :background-message :inspect) + :background-message :inspect :ping) &rest _) (declare (ignore _)) (send event))))) @@ -1130,7 +1142,8 @@ (make-connection :socket-io socket-io :read #'read-from-socket-io :send #'send-to-socket-io - :serve-requests #'simple-serve-requests))))) + :serve-requests #'simple-serve-requests)) + ))) (setf (connection.communication-style c) style) (initialize-streams-for-connection c) (setf success t) @@ -1315,6 +1328,8 @@ (defmacro with-thread-description (description &body body) `(call-with-thread-description ,description #'(lambda () , at body))) +(defvar *event-queue* '()) + (defun read-from-emacs () "Read and process a request from Emacs." (flet ((request-to-string (req) @@ -1331,10 +1346,47 @@ ;; created by swank are currently doing. (with-thread-description (truncate-string (request-to-string request) 55) (apply #'funcall request)) - (apply #'funcall request))))) + (destructure-case request + ((:call . args) (apply #'funcall args)) + (t (setf *event-queue* + (nconc *event-queue* (list request))))))))) + +(defun wait-for-event (pattern) + (log-event "wait-for-event: %S~%" pattern) + (case (connection.communication-style *emacs-connection*) + (:spawn (receive-if (lambda (e) (event-match-p e pattern)))) + (t (wait-for-event/event-loop pattern)))) + +(defun wait-for-event/event-loop (pattern) + (loop + (let ((tail (member-if (lambda (e) (event-match-p e pattern)) + *event-queue*))) + (cond (tail + (setq *event-queue* + (nconc (ldiff *event-queue* tail) (cdr tail))) + (return (car tail))) + (t + (let ((event (read-from-socket-io))) + (cond ((event-match-p event pattern) (return event)) + ((eq (car event) :call) + (apply #'funcall (cdr event))) + (t + (setf *event-queue* + (nconc *event-queue* (list event))))))))))) + +(defun event-match-p (event pattern) + (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) + (member pattern '(nil t))) + (equal event pattern)) + ((symbolp pattern) t) + ((consp pattern) + (and (consp event) + (and (event-match-p (car event) (car pattern)) + (event-match-p (cdr event) (cdr pattern))))) + (t (error "Invalid pattern: ~S" pattern)))) (defun read-from-control-thread () - (receive)) + (cdr (receive-if (lambda (e) (event-match-p e '(:call . _)))))) (defun decode-message (stream) "Read an S-expression from STREAM using the SLIME protocol." From heller at common-lisp.net Sun Aug 3 19:20:51 2008 From: heller at common-lisp.net (heller) Date: Sun, 3 Aug 2008 15:20:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080803192051.5FB52710E4@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv19513 Modified Files: swank.lisp Log Message: (reader-from-emacs): Use &rest in destructure-case for CCL's sake. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/03 18:23:10 1.549 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/03 19:20:51 1.550 @@ -1347,7 +1347,7 @@ (with-thread-description (truncate-string (request-to-string request) 55) (apply #'funcall request)) (destructure-case request - ((:call . args) (apply #'funcall args)) + ((:call &rest args) (apply #'funcall args)) (t (setf *event-queue* (nconc *event-queue* (list request))))))))) From heller at common-lisp.net Sun Aug 3 19:24:09 2008 From: heller at common-lisp.net (heller) Date: Sun, 3 Aug 2008 15:24:09 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080803192409.672B62200F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv19697 Modified Files: swank-openmcl.lisp Log Message: (*in-receive-if*): New variable. (receive-if): Use *in-receive-if* to recognize when wait-on-semaphore was interrupted and receive-if is called recursively. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/03 18:23:10 1.126 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/03 19:24:09 1.127 @@ -961,6 +961,8 @@ (defimplementation receive () (receive-if (constantly t))) +(defvar *in-receive-if* nil) + (defimplementation receive-if (test) (let* ((mbox (mailbox ccl:*current-process*)) (mutex (mailbox.mutex mbox))) @@ -971,8 +973,11 @@ (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (when *in-receive-if* + (ccl:signal-semaphore (mailbox.semaphore mbox))) (return (car tail))))) - (ccl:wait-on-semaphore (mailbox.semaphore mbox))))) + (let ((*in-receive-if* t)) + (ccl:wait-on-semaphore (mailbox.semaphore mbox)))))) (defimplementation quit-lisp () (ccl::quit)) From heller at common-lisp.net Mon Aug 4 09:10:49 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 05:10:49 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804091049.D157A7439C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31539 Modified Files: slime.el Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/slime.el 2008/08/03 18:23:10 1.955 +++ /project/slime/cvsroot/slime/slime.el 2008/08/04 09:10:38 1.956 @@ -3171,7 +3171,8 @@ (interactive) (set-marker slime-repl-last-input-start-mark nil) (let ((inhibit-read-only t)) - (delete-region (point-min) (slime-repl-input-line-beginning-position)) + (delete-region (point-min) slime-repl-prompt-start-mark) + (delete-region slime-output-start slime-output-end) (goto-char slime-repl-input-start-mark)) (run-hooks 'slime-repl-clear-buffer-hook)) From heller at common-lisp.net Mon Aug 4 09:12:05 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 05:12:05 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804091205.3D5E83001D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31845 Modified Files: slime.el Log Message: (slime-with-output-to-temp-buffer): Add read-only argument. (slime-temp-buffer): Renamed from slime-get-temp-buffer-create. Drop noselect argument. --- /project/slime/cvsroot/slime/slime.el 2008/08/04 09:10:38 1.956 +++ /project/slime/cvsroot/slime/slime.el 2008/08/04 09:12:05 1.957 @@ -909,16 +909,43 @@ "The emacs snapshot \"fingerprint\" after displaying the buffer.")) ;; Interface -(defun* slime-get-temp-buffer-create (name &key mode noselectp reusep - emacs-snapshot) - "Return a fresh temporary buffer called NAME in MODE. +(defmacro* slime-with-output-to-temp-buffer ((name &key mode connection + (read-only t) + reusep emacs-snapshot) + package &rest body) + "Similar to `with-output-to-temp-buffer'. +Bind standard-output and initialize some buffer-local variables. + +NAME is the name of the buffer to be created. +PACKAGE is the value `slime-buffer-package'. +CONNECTION is the value for `slime-buffer-connection'. +If nil, no explicit connection is associated with +the buffer. If t, the current connection is taken. + +MODE is the major mode the buffer should be set to. +READ-ONLY makes the buffer read-only. + +If REUSEP is t, an already existing buffer won't be killed." + `(let ((standard-output + (slime-temp-buffer ,name #',mode ,reusep ,emacs-snapshot)) + (connection% ,(if (eq connection t) + '(slime-connection) + connection)) + (package% ,package)) + (with-current-buffer standard-output + (setq slime-buffer-package package%) + ,@(if connection '((setq slime-buffer-connection connection%))) + , at body + ,@(if read-only '((setq buffer-read-only t)))))) + +(put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2) + +(defun slime-temp-buffer (name mode reusep emacs-snapshot) + "Return a temporary buffer called NAME in MODE. The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing `q' in the buffer will restore the window configuration to the way it is when the buffer was created, i.e. when this function was called. -If NOSELECTP is true, then the buffer is shown by `display-buffer', -otherwise it is shown and selected by `pop-to-buffer'. - If REUSEP is true and a buffer does already exist with name NAME, then the buffer will be reused instead of being killed. @@ -926,12 +953,10 @@ state of Emacs after closing the temporary buffer. Otherwise, the current state will be saved and later restored. " - (let ((snapshot (or emacs-snapshot (slime-current-emacs-snapshot))) - (buffer (get-buffer name))) - (when (and buffer (not reusep)) - (kill-buffer name) - (setq buffer nil)) - (with-current-buffer (or buffer (get-buffer-create name)) + (let ((snapshot (or emacs-snapshot (slime-current-emacs-snapshot)))) + (when (and (not reusep) (get-buffer name)) + (kill-buffer (get-buffer name))) + (with-current-buffer (get-buffer-create name) (when mode (let ((original-configuration slime-temp-buffer-saved-emacs-snapshot) (original-fingerprint slime-temp-buffer-saved-fingerprint)) @@ -939,63 +964,12 @@ (setq slime-temp-buffer-saved-emacs-snapshot original-configuration) (setq slime-temp-buffer-saved-fingerprint original-fingerprint))) (slime-temp-buffer-mode 1) - (let ((window (get-buffer-window (current-buffer)))) - (if window - (unless noselectp - (select-window window)) - (progn - (if noselectp - (display-buffer (current-buffer) t) - (pop-to-buffer (current-buffer)) - (selected-window)) - (setq slime-temp-buffer-saved-emacs-snapshot snapshot) - (setq slime-temp-buffer-saved-fingerprint - (slime-current-emacs-snapshot-fingerprint))))) + (setq slime-temp-buffer-saved-emacs-snapshot snapshot) + (setq slime-temp-buffer-saved-fingerprint + (slime-current-emacs-snapshot-fingerprint)) + (pop-to-buffer (current-buffer)) (current-buffer)))) -;; Interface -(defmacro* slime-with-output-to-temp-buffer ((name &key mode emacs-snapshot - connection reusep) - package &rest body) - "Similar to `with-output-to-temp-buffer', but also remembers -Slime-related stuff. Used to implement Slime's Description, -Apropos, Macroexpand &c buffers. - -`name' is the name of the buffer to be created. - -`package' is the package that's associated with the buffer. - -`mode' is the major the temporary buffer should be set to. If -desired, you can enable additional minor-modes explicitly in the -body. - -`emacs-snapshot' is the Emacs state (window configuration &c.) -that should be restored when the user quits the temporary buffer. -If not explictly passed, a snapshot of the current state is taken -and saved. - -`connection' is the Slime connection that should be stored -buffer-locally. If nil, no explicit connection is associated with -the buffer. If t, the current connection is taken. - -If `reusep' is t, an already existing buffer won't be killed, and -recreated." - `(let ((standard-output - (slime-get-temp-buffer-create ,name :mode ',mode - :emacs-snapshot ,emacs-snapshot - :reusep ,reusep))) - (prog1 (with-current-buffer standard-output - (let ((buffer-read-only nil)) ; in case the buffer is reused. - , at body)) - (with-current-buffer standard-output - (setq slime-buffer-package ,package) - (setq slime-buffer-connection - ,(if (eq connection 't) `(slime-connection) connection)) - (goto-char (point-min)) - (setq buffer-read-only t))))) - -(put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2) - (define-minor-mode slime-temp-buffer-mode "Mode for displaying read only stuff" nil @@ -5511,7 +5485,8 @@ (defun slime-edit-value-callback (form-string current-value package) (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))) - (slime-with-output-to-temp-buffer (name :mode lisp-mode :connection t) package + (slime-with-output-to-temp-buffer (name :mode lisp-mode :connection t + :read-only nil) package (slime-mode 1) (slime-temp-buffer-mode -1) ; don't want binding of 'q' (slime-edit-value-mode 1) @@ -7466,8 +7441,6 @@ (defun slime-list-connections () "Display a list of all connections." (interactive) - (when (get-buffer "*SLIME Connections*") - (kill-buffer "*SLIME Connections*")) (slime-with-output-to-temp-buffer ("*SLIME Connections*" :mode slime-connection-list-mode) nil (slime-draw-connection-list))) @@ -7956,7 +7929,7 @@ (def-slime-selector-method ?c "SLIME connections buffer." (slime-list-connections) - "*SLIME connections*") + "*SLIME Connections*") (def-slime-selector-method ?t "SLIME threads buffer." From heller at common-lisp.net Mon Aug 4 09:13:06 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 05:13:06 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804091306.C67295C18B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv32161 Modified Files: ChangeLog swank-lispworks.lisp Log Message: * swank-lispworks.lisp (receive-if): Handle interrupts. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/03 18:23:09 1.1382 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 09:13:06 1.1383 @@ -1,3 +1,13 @@ +2008-08-04 Helmut Eller + + * swank-lispworks.lisp (receive-if): Handle interrupts. + + * slime.el (slime-repl-clear-buffer): Delete stuff after the + prompt too. + (slime-with-output-to-temp-buffer): Add read-only argument. + (slime-temp-buffer): Renamed from slime-get-temp-buffer-create. + Drop noselect argument. + 2008-08-03 Helmut Eller Add some flow-control. --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/03 18:23:10 1.101 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/04 09:13:06 1.102 @@ -735,32 +735,48 @@ (defimplementation thread-alive-p (thread) (mp:process-alive-p thread)) +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock :name "thread mailbox")) + (queue '() :type list)) + (defvar *mailbox-lock* (mp:make-lock)) (defun mailbox (thread) (mp:with-lock (*mailbox-lock*) (or (getf (mp:process-plist thread) 'mailbox) (setf (getf (mp:process-plist thread) 'mailbox) - (mp:make-mailbox))))) + (make-mailbox))))) (defimplementation receive () - (receive-if (constantly t))) + (let* ((mbox (mailbox mp:*current-process*)) + (lock (mailbox.mutex mbox))) + (loop + (mp:process-wait "receive" #'mailbox.queue mbox) + (mp:without-interrupts + (mp:with-lock (lock "receive/try" 0.1) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))))))) (defimplementation receive-if (test) - (loop - (let* ((self mp:*current-process*) - (q (getf (mp:process-plist self) 'queue)) - (tail (member-if test q))) - (cond (tail - (setf (getf (mp:process-plist self) 'queue) - (nconc (ldiff q tail) (cdr tail))) - (return (car tail))) - (t - (setf (getf (mp:process-plist self) 'queue) - (nconc q (list (mp:mailbox-read (mailbox self)))))))))) - -(defimplementation send (thread object) - (mp:mailbox-send (mailbox thread) object)) + (let* ((mbox (mailbox mp:*current-process*)) + (lock (mailbox.mutex mbox))) + (loop + (mp:process-wait "receive-if" + (lambda () (some test (mailbox.queue mbox)))) + (mp:without-interrupts + (mp:with-lock (lock "receive-if/try" 0.1) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (mp:without-interrupts + (mp:with-lock ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))))))) ;;; Some intergration with the lispworks environment From heller at common-lisp.net Mon Aug 4 20:25:16 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202516.1B8F0610B6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13060 Modified Files: slime.el Log Message: (slime-io-speed-test): Minor changes. --- /project/slime/cvsroot/slime/slime.el 2008/08/04 09:12:05 1.957 +++ /project/slime/cvsroot/slime/slime.el 2008/08/04 20:25:15 1.958 @@ -2532,13 +2532,13 @@ (when profile (elp-instrument-package "slime-")) (kill-buffer (slime-output-buffer)) - ;;(display-buffer (slime-output-buffer)) + (switch-to-buffer (slime-output-buffer)) (delete-other-windows) (sit-for 0) - (slime-repl-send-string "(swank:io-speed-test 5000 1)") + (slime-repl-send-string "(swank:io-speed-test 4000 1)") (let ((proc (slime-inferior-process))) (when proc - (switch-to-buffer (process-buffer proc)) + (display-buffer (process-buffer proc) t) (goto-char (point-max))))) (defvar slime-write-string-function 'slime-repl-write-string) @@ -9818,6 +9818,7 @@ slime-log-event slime-events-buffer slime-write-string + slime-repl-emit slime-output-buffer slime-connection-output-buffer slime-output-filter From heller at common-lisp.net Mon Aug 4 20:25:24 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:24 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202524.844DE6A12A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13086 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (eval-for-emacs): Don't flush streams here as that may now block. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 09:13:06 1.1383 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:23 1.1384 @@ -1,5 +1,8 @@ 2008-08-04 Helmut Eller + * swank.lisp (eval-for-emacs): Don't flush streams here as that + may now block. + * swank-lispworks.lisp (receive-if): Handle interrupts. * slime.el (slime-repl-clear-buffer): Delete stuff after the --- /project/slime/cvsroot/slime/swank.lisp 2008/08/03 19:20:51 1.550 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/04 20:25:24 1.551 @@ -731,16 +731,18 @@ ;; FIXME: if wait-for-event aborts the event will stay in the queue forever. (defun make-output-function (connection) "Create function to send user output to Emacs." - (let ((max 100) (i 0) (tag 0)) + (let ((max 100) (i 0) (tag 0) (l 0)) (lambda (string) (with-connection (connection) (with-simple-restart (abort "Abort sending output to Emacs.") - (when (= i max) + (when (or (= i max) (> l (* 80 20 5))) (setf tag (mod (1+ tag) 1000)) (send-to-emacs `(:ping ,(thread-id (current-thread)) ,tag)) (wait-for-event `(:emacs-pong ,tag)) - (setf i 0)) + (setf i 0) + (setf l 0)) (incf i) + (incf l (length string)) (send-to-emacs `(:write-string ,string))))))) (defun make-output-function-for-target (connection target) @@ -1443,8 +1445,7 @@ (prin1-to-string object)))) (defun force-user-output () - (force-output (connection.user-io *emacs-connection*)) - (finish-output (connection.user-output *emacs-connection*))) + (force-output (connection.user-io *emacs-connection*))) (defun clear-user-input () (clear-input (connection.user-input *emacs-connection*))) @@ -1544,14 +1545,14 @@ :prompt ,(package-string-for-prompt *package*)) :version ,*swank-wire-protocol-version*)) -(defslimefun io-speed-test (&optional (n 5000) (m 1)) +(defslimefun io-speed-test (&optional (n 1000) (m 1)) (let* ((s *standard-output*) (*trace-output* (make-broadcast-stream s *log-output*))) (time (progn (dotimes (i n) (format s "~D abcdefghijklm~%" i) (when (zerop (mod n m)) - (force-output s))) + (finish-output s))) (finish-output s) (when *emacs-connection* (eval-in-emacs '(message "done."))))) @@ -1760,9 +1761,7 @@ ;;(setq result (apply (car form) (cdr form))) (setq result (eval form)) (run-hook *pre-reply-hook*) - (finish-output) (setq ok t)) - (force-user-output) (send-to-emacs `(:return ,(current-thread) ,(if ok `(:ok ,result) From heller at common-lisp.net Mon Aug 4 20:25:29 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:29 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202529.40AC316@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13147 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (receive,receive-if): Test for new messages in a loop. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:23 1.1384 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:28 1.1385 @@ -1,5 +1,8 @@ 2008-08-04 Helmut Eller + * swank-cmucl.lisp (receive,receive-if): Test for new messages in + a loop. + * swank.lisp (eval-for-emacs): Don't flush streams here as that may now block. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/03 18:23:10 1.182 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/04 20:25:28 1.183 @@ -2097,31 +2097,35 @@ (make-mailbox))))) (defimplementation send (thread message) - (let* ((mbox (mailbox thread)) - (mutex (mailbox.mutex mbox))) - (mp:with-lock-held (mutex) - (setf (mailbox.queue mbox) - (nconc (mailbox.queue mbox) (list message)))))) + (let* ((mbox (mailbox thread))) + (sys:without-interrupts + (mp:with-lock-held ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))))))) (defimplementation receive () - (let* ((mbox (mailbox mp:*current-process*)) - (mutex (mailbox.mutex mbox))) - (mp:process-wait "receive" #'mailbox.queue mbox) - (mp:with-lock-held (mutex) - (pop (mailbox.queue mbox))))) + (let* ((mbox (mailbox mp:*current-process*))) + (loop + (mp:process-wait "receive" #'mailbox.queue mbox) + (sys:without-interrupts + (mp:with-lock-held ((mailbox.mutex mbox)) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))))))) (defimplementation receive-if (test) (let ((mbox (mailbox mp:*current-process*))) - (mp:process-wait "receive-if" - (lambda (mbox test) - (some test (mailbox.queue mbox))) - mbox test) - (mp:with-lock-held ((mailbox.mutex mbox)) - (let* ((q (mailbox.queue mbox)) - (tail (member-if test q))) - (assert tail) - (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) - (car tail))))) + (loop + (mp:process-wait "receive-if" + (lambda () (some test (mailbox.queue mbox)))) + (sys:without-interrupts + (mp:with-lock-held ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))))))) + ) ;; #+mp From heller at common-lisp.net Mon Aug 4 20:25:33 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:33 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202533.904047913E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13188 Modified Files: ChangeLog swank-scl.lisp Log Message: * swank-scl.lisp (receive-if): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:28 1.1385 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:33 1.1386 @@ -1,5 +1,7 @@ 2008-08-04 Helmut Eller + * swank-scl.lisp (receive-if): Implemented. + * swank-cmucl.lisp (receive,receive-if): Test for new messages in a loop. --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/04/17 14:56:43 1.19 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/04 20:25:33 1.20 @@ -1994,6 +1994,20 @@ (when winp (return message)))))) +(defimplementation receive-if (test) + (let ((mbox (mailbox thread:*thread*))) + (loop + (mp:process-wait "receive-if" + (lambda () (some test (mailbox-queue mbox)))) + (sys:without-interrupts + (mp:with-lock-held ((mailbox-lock mbox)) + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))))))) + (defimplementation emacs-connected ()) From heller at common-lisp.net Mon Aug 4 20:25:38 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:38 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202538.8777B2F00A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13217 Modified Files: ChangeLog swank-gray.lisp swank-lispworks.lisp swank-sbcl.lisp Log Message: * swank-gray.lisp (slime-output-stream): Add a slot "interactive-p" which should be true for streams which are flushed periodically by the Lisp system. Update the relevant accordingly. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:33 1.1386 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:37 1.1387 @@ -1,5 +1,9 @@ 2008-08-04 Helmut Eller + * swank-gray.lisp (slime-output-stream): Add a slot + "interactive-p" which should be true for streams which are flushed + periodically by the Lisp system. Update the relevant accordingly. + * swank-scl.lisp (receive-if): Implemented. * swank-cmucl.lisp (receive,receive-if): Test for new messages in --- /project/slime/cvsroot/slime/swank-gray.lisp 2006/04/12 08:43:55 1.10 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/04 20:25:38 1.11 @@ -15,7 +15,8 @@ (buffer :initform (make-string 8000)) (fill-pointer :initform 0) (column :initform 0) - (last-flush-time :initform (get-internal-real-time)) + ;; true if the Lisp system flushes this stream periodically + (interactive-p :initform nil) (lock :initform (make-recursive-lock :name "buffer write lock")))) (defmethod stream-write-char ((stream slime-output-stream) char) @@ -43,27 +44,19 @@ 75) (defmethod stream-finish-output ((stream slime-output-stream)) - (call-with-recursive-lock-held - (slot-value stream 'lock) - (lambda () - (with-slots (buffer fill-pointer output-fn last-flush-time) stream - (let ((end fill-pointer)) - (unless (zerop end) - (funcall output-fn (subseq buffer 0 end)) - (setf fill-pointer 0))) - (setf last-flush-time (get-internal-real-time))))) + (with-slots (buffer lock fill-pointer output-fn) stream + (call-with-recursive-lock-held + lock + (lambda () + (unless (zerop fill-pointer) + (funcall output-fn (subseq buffer 0 fill-pointer)) + (setf fill-pointer 0))))) nil) (defmethod stream-force-output ((stream slime-output-stream)) - (call-with-recursive-lock-held - (slot-value stream 'lock) - (lambda () - (with-slots (last-flush-time fill-pointer) stream - (let ((now (get-internal-real-time))) - (when (> (/ (- now last-flush-time) - (coerce internal-time-units-per-second 'double-float)) - 0.2) - (finish-output stream)))))) + (with-slots (interactive-p) stream + (unless interactive-p + (stream-finish-output stream))) nil) (defmethod stream-fresh-line ((stream slime-output-stream)) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/04 09:13:06 1.102 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/04 20:25:38 1.103 @@ -800,7 +800,9 @@ nil) (let ((lw:*handle-warn-on-redefinition* :warn)) (defmethod stream:stream-soft-force-output ((o (eql stream))) - (force-output o))))) + (force-output o)) + (when (typep stream 'slime-output-stream) + (setf (slot-value stream 'interactive-p) t))))) (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) (apply (swank-sym :y-or-n-p-in-emacs) msg args)) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/03 18:23:10 1.202 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/04 20:25:38 1.203 @@ -1328,7 +1328,9 @@ (unless *auto-flush-thread* (setq *auto-flush-thread* (sb-thread:make-thread #'flush-streams - :name "auto-flush-thread")))))) + :name "auto-flush-thread"))))) + (when (typep stream 'slime-output-stream) + (setf (slot-value stream 'interactive-p) t))) (defun flush-streams () (loop From heller at common-lisp.net Mon Aug 4 20:25:42 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:42 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202542.B53C73E057@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13281 Modified Files: ChangeLog swank-allegro.lisp swank-openmcl.lisp Log Message: Set interactive-p for CCL and ACL. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:37 1.1387 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:42 1.1388 @@ -2,7 +2,8 @@ * swank-gray.lisp (slime-output-stream): Add a slot "interactive-p" which should be true for streams which are flushed - periodically by the Lisp system. Update the relevant accordingly. + periodically by the Lisp system. Update the relevant backends + accordingly. * swank-scl.lisp (receive-if): Implemented. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/03 18:23:10 1.104 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/04 20:25:42 1.105 @@ -125,7 +125,9 @@ (describe (find-class symbol))))) (defimplementation make-stream-interactive (stream) - (setf (interactive-stream-p stream) t)) + (setf (interactive-stream-p stream) t) + (when (typep stream 'slime-output-stream) + (setf (slot-value stream 'interactive-p) t))) ;;;; Debugger --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/03 19:24:09 1.127 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/04 20:25:42 1.128 @@ -194,9 +194,9 @@ (setq ccl::*interactive-abort-process* ccl::*current-process*)) (defimplementation make-stream-interactive (stream) - (typecase stream - (ccl:fundamental-output-stream - (push stream ccl::*auto-flush-streams*)))) + (when (typep stream 'slime-output-stream) + (push stream ccl::*auto-flush-streams*) + (setf (slot-value stream 'interactive-p) t))) ;;; Unix signals From heller at common-lisp.net Mon Aug 4 20:25:45 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:45 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202545.C51025C189@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13326 Modified Files: slime.el Log Message: (slime-repl-clear-buffer): Recenter at the end. --- /project/slime/cvsroot/slime/slime.el 2008/08/04 20:25:15 1.958 +++ /project/slime/cvsroot/slime/slime.el 2008/08/04 20:25:45 1.959 @@ -3147,7 +3147,8 @@ (let ((inhibit-read-only t)) (delete-region (point-min) slime-repl-prompt-start-mark) (delete-region slime-output-start slime-output-end) - (goto-char slime-repl-input-start-mark)) + (goto-char slime-repl-input-start-mark) + (recenter)) (run-hooks 'slime-repl-clear-buffer-hook)) (defun slime-repl-clear-output () From heller at common-lisp.net Mon Aug 4 20:25:51 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202551.99789610B6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13391 Modified Files: ChangeLog swank-clisp.lisp Log Message: Updates for CLISP-2.46. Patch by Masayuki Onjo. * swank-clisp.lisp (fspec-pathname, fspec-location): The structure of (documentation symbol 'sys::file) used to be (path . lines) but is now ((type path . lines) ...). --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:42 1.1388 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:49 1.1389 @@ -1,5 +1,15 @@ +2008-08-04 Masayuki Onjo + + Updates for CLISP-2.46. + + * swank-clisp.lisp (fspec-pathname, fspec-location): The structure + of (documentation symbol 'sys::file) used to be (path . lines) + but is now ((type path . lines) ...). + 2008-08-04 Helmut Eller + + * swank-gray.lisp (slime-output-stream): Add a slot "interactive-p" which should be true for streams which are flushed periodically by the Lisp system. Update the relevant backends --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/03 18:23:10 1.70 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/04 20:25:50 1.71 @@ -212,12 +212,14 @@ (:function (describe (symbol-function symbol))) (:class (describe (find-class symbol))))) -(defun fspec-pathname (symbol) - (let ((path (documentation symbol 'sys::file)) +(defun fspec-pathname (spec) + (let ((path spec) + type lines) (when (consp path) - (psetq path (car path) - lines (cdr path))) + (psetq type (car path) + path (cadr path) + lines (cddr path))) (when (and path (member (pathname-type path) custom:*compiled-file-types* :test #'equal)) @@ -225,24 +227,26 @@ (loop for suffix in custom:*source-file-types* thereis (probe-file (make-pathname :defaults path :type suffix))))) - (values path lines))) + (values path type lines))) -(defun fspec-location (fspec) - (multiple-value-bind (file lines) +(defun fspec-location (name fspec) + (multiple-value-bind (file type lines) (fspec-pathname fspec) - (cond (file - (multiple-value-bind (truename c) (ignore-errors (truename file)) - (cond (truename - (make-location (list :file (namestring truename)) - (if (consp lines) - (list* :line lines) - (list :function-name (string fspec))))) - (t (list :error (princ-to-string c)))))) - (t (list :error (format nil "No source information available for: ~S" - fspec)))))) + (list (if type (list name type) name) + (cond (file + (multiple-value-bind (truename c) (ignore-errors (truename file)) + (cond (truename + (make-location (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string fspec))) + (list :snippet (format nil "~A" type)))) + (t (list :error (princ-to-string c)))))) + (t (list :error (format nil "No source information available for: ~S" + fspec))))))) (defimplementation find-definitions (name) - (list (list name (fspec-location name)))) + (mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file))) (defun trim-whitespace (string) (string-trim #(#\newline #\space #\tab) string)) @@ -573,9 +577,8 @@ (load fasl-file)) nil)))) -(defimplementation swank-compile-string (string &key buffer position directory - debug) - (declare (ignore directory debug)) +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-offset* position)) @@ -600,7 +603,7 @@ (defun xref-results (symbols) (let ((xrefs '())) (dolist (symbol symbols) - (push (list symbol (fspec-location symbol)) xrefs)) + (push (fspec-location symbol symbol) xrefs)) xrefs)) (when (find-package :swank-loader) From heller at common-lisp.net Mon Aug 4 20:25:55 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:55 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804202555.95819710E4@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13424 Modified Files: ChangeLog Log Message: Fix whitespace. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:49 1.1389 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:55 1.1390 @@ -8,8 +8,6 @@ 2008-08-04 Helmut Eller - - * swank-gray.lisp (slime-output-stream): Add a slot "interactive-p" which should be true for streams which are flushed periodically by the Lisp system. Update the relevant backends From heller at common-lisp.net Mon Aug 4 20:25:57 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 16:25:57 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080804202557.196DE72194@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv13458/contrib Modified Files: ChangeLog slime-asdf.el Log Message: * slime-asdf.el: Load swank-asdf. This should avoid the rude disconnect if asdf wasn't loaded. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/03 13:31:54 1.113 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/04 20:25:57 1.114 @@ -1,3 +1,8 @@ +2008-08-04 Adam Bozanich + + * slime-asdf.el: Load swank-asdf. + This should avoid the rude disconnect if asdf wasn't loaded. + 2008-08-03 Tobias C. Rittweiler * slime-presentations.el (slime-presentation-around-or-before-point): --- /project/slime/cvsroot/slime/contrib/slime-asdf.el 2008/07/19 11:39:23 1.4 +++ /project/slime/cvsroot/slime/contrib/slime-asdf.el 2008/08/04 20:25:57 1.5 @@ -17,6 +17,7 @@ ;; NOTE: `system-name' is a predefined variable in Emacs. Try to ;; avoid it as local variable name. +(slime-require :swank-asdf) (defun slime-load-system (&optional system) "Compile and load an ASDF system. From heller at common-lisp.net Mon Aug 4 21:38:08 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Aug 2008 17:38:08 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080804213808.189BC742F2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3451 Modified Files: ChangeLog swank-allegro.lisp swank-clisp.lisp swank-gray.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp Log Message: * swank-gray.lisp (slime-output-stream): Undo last change. Make force-output and finish-output do the same. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 20:25:55 1.1390 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/04 21:38:07 1.1391 @@ -1,3 +1,8 @@ +2008-08-04 Helmut Eller + + * swank-gray.lisp (slime-output-stream): Undo last change. + Make force-output and finish-output do the same. + 2008-08-04 Masayuki Onjo Updates for CLISP-2.46. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/04 20:25:42 1.105 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/04 21:38:07 1.106 @@ -125,9 +125,7 @@ (describe (find-class symbol))))) (defimplementation make-stream-interactive (stream) - (setf (interactive-stream-p stream) t) - (when (typep stream 'slime-output-stream) - (setf (slot-value stream 'interactive-p) t))) + (setf (interactive-stream-p stream) t)) ;;;; Debugger --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/04 20:25:50 1.71 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/04 21:38:07 1.72 @@ -577,8 +577,9 @@ (load fasl-file)) nil)))) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-offset* position)) --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/04 20:25:38 1.11 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/04 21:38:07 1.12 @@ -15,57 +15,43 @@ (buffer :initform (make-string 8000)) (fill-pointer :initform 0) (column :initform 0) - ;; true if the Lisp system flushes this stream periodically - (interactive-p :initform nil) (lock :initform (make-recursive-lock :name "buffer write lock")))) +(defmacro with-slime-output-stream (stream &body body) + `(with-slots (lock output-fn buffer fill-pointer column) ,stream + (call-with-recursive-lock-held lock (lambda () , at body)))) + (defmethod stream-write-char ((stream slime-output-stream) char) - (call-with-recursive-lock-held - (slot-value stream 'lock) - (lambda () - (with-slots (buffer fill-pointer column) stream - (setf (schar buffer fill-pointer) char) - (incf fill-pointer) - (incf column) - (when (char= #\newline char) - (setf column 0) - (force-output stream)) - (when (= fill-pointer (length buffer)) - (finish-output stream))))) + (with-slime-output-stream stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (when (char= #\newline char) + (setf column 0)) + (when (= fill-pointer (length buffer)) + (finish-output stream))) char) (defmethod stream-line-column ((stream slime-output-stream)) - (call-with-recursive-lock-held - (slot-value stream 'lock) - (lambda () - (slot-value stream 'column)))) + (with-slime-output-stream stream column)) (defmethod stream-line-length ((stream slime-output-stream)) 75) (defmethod stream-finish-output ((stream slime-output-stream)) - (with-slots (buffer lock fill-pointer output-fn) stream - (call-with-recursive-lock-held - lock - (lambda () - (unless (zerop fill-pointer) - (funcall output-fn (subseq buffer 0 fill-pointer)) - (setf fill-pointer 0))))) + (with-slime-output-stream stream + (unless (zerop fill-pointer) + (funcall output-fn (subseq buffer 0 fill-pointer)) + (setf fill-pointer 0))) nil) (defmethod stream-force-output ((stream slime-output-stream)) - (with-slots (interactive-p) stream - (unless interactive-p - (stream-finish-output stream))) - nil) + (stream-finish-output stream)) (defmethod stream-fresh-line ((stream slime-output-stream)) - (call-with-recursive-lock-held - (slot-value stream 'lock) - (lambda () - (with-slots (column) stream - (cond ((zerop column) nil) - (t (terpri stream) t)))))) + (with-slime-output-stream stream + (cond ((zerop column) nil) + (t (terpri stream) t)))) (defclass slime-input-stream (fundamental-character-input-stream) ((output-stream :initarg :output-stream) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/04 20:25:38 1.103 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/04 21:38:07 1.104 @@ -800,9 +800,7 @@ nil) (let ((lw:*handle-warn-on-redefinition* :warn)) (defmethod stream:stream-soft-force-output ((o (eql stream))) - (force-output o)) - (when (typep stream 'slime-output-stream) - (setf (slot-value stream 'interactive-p) t))))) + (force-output o))))) (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) (apply (swank-sym :y-or-n-p-in-emacs) msg args)) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/04 20:25:42 1.128 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/04 21:38:07 1.129 @@ -194,9 +194,9 @@ (setq ccl::*interactive-abort-process* ccl::*current-process*)) (defimplementation make-stream-interactive (stream) - (when (typep stream 'slime-output-stream) - (push stream ccl::*auto-flush-streams*) - (setf (slot-value stream 'interactive-p) t))) + (typecase stream + (ccl:fundamental-output-stream + (push stream ccl::*auto-flush-streams*)))) ;;; Unix signals --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/04 20:25:38 1.203 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/04 21:38:07 1.204 @@ -1311,7 +1311,7 @@ ;; Auto-flush streams (defvar *auto-flush-interval* 0.15 - "How often to flush interactive streams. This valu is passed + "How often to flush interactive streams. This value is passed directly to cl:sleep.") (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush")) @@ -1328,9 +1328,7 @@ (unless *auto-flush-thread* (setq *auto-flush-thread* (sb-thread:make-thread #'flush-streams - :name "auto-flush-thread"))))) - (when (typep stream 'slime-output-stream) - (setf (slot-value stream 'interactive-p) t))) + :name "auto-flush-thread")))))) (defun flush-streams () (loop From heller at common-lisp.net Tue Aug 5 17:38:40 2008 From: heller at common-lisp.net (heller) Date: Tue, 5 Aug 2008 13:38:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080805173840.4547D22009@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21202 Modified Files: swank-backend.lisp swank-gray.lisp Log Message: * swank-gray.lisp (stream-write-string): New method. * swank-backend.lisp (*gray-stream-symbols*): Include write-string. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/03 18:23:10 1.136 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/05 17:38:39 1.137 @@ -194,6 +194,7 @@ (defvar *gray-stream-symbols* '(:fundamental-character-output-stream :stream-write-char + :stream-write-string :stream-fresh-line :stream-force-output :stream-finish-output --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/04 21:38:07 1.12 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/05 17:38:40 1.13 @@ -32,6 +32,29 @@ (finish-output stream))) char) +(defmethod stream-write-string ((stream slime-output-stream) string + &optional start end) + (with-slime-output-stream stream + (let* ((start (or start 0)) + (end (or end (length string))) + (len (length buffer)) + (count (- end start)) + (free (- len fill-pointer))) + (when (>= count free) + (stream-finish-output stream)) + (cond ((< count len) + (replace buffer string :start1 fill-pointer + :start2 start :end2 end) + (incf fill-pointer count)) + (t + (funcall output-fn (subseq string start end)))) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf column (if last-newline + (- end last-newline 1) + (+ column count)))))) + string) + (defmethod stream-line-column ((stream slime-output-stream)) (with-slime-output-stream stream column)) From heller at common-lisp.net Tue Aug 5 17:38:45 2008 From: heller at common-lisp.net (heller) Date: Tue, 5 Aug 2008 13:38:45 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080805173845.7F39E22033@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21228 Modified Files: ChangeLog swank-backend.lisp swank-ecl.lisp swank-gray.lisp swank-sbcl.lisp Log Message: Drop distinction between "recursive" and non-recursive locks. * swank-backend.lisp (make-recursive-lock) (call-with-recursive-lock-held): Deleted. Make the default locks "recursive" instead. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/04 21:38:07 1.1391 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:44 1.1392 @@ -1,3 +1,14 @@ +2008-08-05 Helmut Eller + + * swank-backend.lisp (make-recursive-lock) + (call-with-recursive-lock-held): Deleted. Make the default locks + "recursive" instead. + + * swank-gray.lisp (stream-write-string): New method. + + * swank-backend.lisp (*gray-stream-symbols*): Include + write-string. + 2008-08-04 Helmut Eller * swank-gray.lisp (slime-output-stream): Undo last change. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/05 17:38:39 1.137 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/05 17:38:44 1.138 @@ -969,7 +969,8 @@ (definterface make-lock (&key name) "Make a lock for thread synchronization. -Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time." +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time +but that thread may hold it more than once." (declare (ignore name)) :null-lock) @@ -979,24 +980,6 @@ (type function function)) (funcall function)) -(definterface make-recursive-lock (&key name) - "Make a lock for thread synchronization. -Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD) -at a time, but that thread may hold it more than once." - (cons nil (make-lock :name name))) - -(definterface call-with-recursive-lock-held (lock function) - "Call FUNCTION with LOCK held, queueing if necessary." - (if (eql (car lock) (current-thread)) - (funcall function) - (call-with-lock-held (cdr lock) - (lambda () - (unwind-protect - (progn - (setf (car lock) (current-thread)) - (funcall function)) - (setf (car lock) nil)))))) - (definterface current-thread () "Return the currently executing thread." 0) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/05/08 22:55:02 1.23 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/05 17:38:44 1.24 @@ -487,13 +487,6 @@ (declare (type function function)) (mp:with-lock (lock) (funcall function))) - (defimplementation make-recursive-lock (&key name) - (mp:make-lock :name name)) - - (defimplementation call-with-recursive-lock-held (lock function) - (declare (type function function)) - (mp:with-lock (lock) (funcall function))) - (defimplementation current-thread () mp:*current-process*) @@ -549,38 +542,34 @@ "How often to flush interactive streams. This valu is passed directly to cl:sleep.") - (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush")) + (defvar *auto-flush-lock* (make-lock :name "auto flush")) (defvar *auto-flush-thread* nil) (defvar *auto-flush-streams* '()) (defimplementation make-stream-interactive (stream) - (call-with-recursive-lock-held - *auto-flush-lock* - (lambda () - (pushnew stream *auto-flush-streams*) - (unless *auto-flush-thread* - (setq *auto-flush-thread* - (spawn #'flush-streams - :name "auto-flush-thread")))))) + (mp:with-lock (*auto-flush-lock*) + (pushnew stream *auto-flush-streams*) + (unless *auto-flush-thread* + (setq *auto-flush-thread* + (spawn #'flush-streams + :name "auto-flush-thread"))))) (defmethod stream-finish-output ((stream stream)) (finish-output stream)) (defun flush-streams () (loop - (call-with-recursive-lock-held - *auto-flush-lock* - (lambda () - (setq *auto-flush-streams* - (remove-if (lambda (x) - (not (and (open-stream-p x) - (output-stream-p x)))) - *auto-flush-streams*)) - (dolist (i *auto-flush-streams*) - (ignore-errors (stream-finish-output i)) - (ignore-errors (finish-output i))))) + (mp:with-lock (*auto-flush-lock*) + (setq *auto-flush-streams* + (remove-if (lambda (x) + (not (and (open-stream-p x) + (output-stream-p x)))) + *auto-flush-streams*)) + (dolist (i *auto-flush-streams*) + (ignore-errors (stream-finish-output i)) + (ignore-errors (finish-output i)))) (sleep *auto-flush-interval*))) ) --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/05 17:38:40 1.13 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/05 17:38:44 1.14 @@ -15,11 +15,11 @@ (buffer :initform (make-string 8000)) (fill-pointer :initform 0) (column :initform 0) - (lock :initform (make-recursive-lock :name "buffer write lock")))) + (lock :initform (make-lock :name "buffer write lock")))) (defmacro with-slime-output-stream (stream &body body) `(with-slots (lock output-fn buffer fill-pointer column) ,stream - (call-with-recursive-lock-held lock (lambda () , at body)))) + (call-with-lock-held lock (lambda () , at body)))) (defmethod stream-write-char ((stream slime-output-stream) char) (with-slime-output-stream stream --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/04 21:38:07 1.204 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/05 17:38:44 1.205 @@ -1235,13 +1235,6 @@ (defimplementation call-with-lock-held (lock function) (declare (type function function)) - (sb-thread:with-mutex (lock) (funcall function))) - - (defimplementation make-recursive-lock (&key name) - (sb-thread:make-mutex :name name)) - - (defimplementation call-with-recursive-lock-held (lock function) - (declare (type function function)) (sb-thread:with-recursive-lock (lock) (funcall function))) (defimplementation current-thread () @@ -1314,33 +1307,29 @@ "How often to flush interactive streams. This value is passed directly to cl:sleep.") - (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush")) + (defvar *auto-flush-lock* (sb-thread:make-mutex :name "auto flush")) (defvar *auto-flush-thread* nil) (defvar *auto-flush-streams* '()) (defimplementation make-stream-interactive (stream) - (call-with-recursive-lock-held - *auto-flush-lock* - (lambda () - (pushnew stream *auto-flush-streams*) - (unless *auto-flush-thread* - (setq *auto-flush-thread* - (sb-thread:make-thread #'flush-streams - :name "auto-flush-thread")))))) + (sb-thread:with-mutex (*auto-flush-lock*) + (pushnew stream *auto-flush-streams*) + (unless *auto-flush-thread* + (setq *auto-flush-thread* + (sb-thread:make-thread #'flush-streams + :name "auto-flush-thread"))))) (defun flush-streams () (loop - (call-with-recursive-lock-held - *auto-flush-lock* - (lambda () - (setq *auto-flush-streams* - (remove-if (lambda (x) - (not (and (open-stream-p x) - (output-stream-p x)))) - *auto-flush-streams*)) - (mapc #'finish-output *auto-flush-streams*))) + (sb-thread:with-mutex (*auto-flush-lock*) + (setq *auto-flush-streams* + (remove-if (lambda (x) + (not (and (open-stream-p x) + (output-stream-p x)))) + *auto-flush-streams*)) + (mapc #'finish-output *auto-flush-streams*)) (sleep *auto-flush-interval*))) ) From heller at common-lisp.net Tue Aug 5 17:38:49 2008 From: heller at common-lisp.net (heller) Date: Tue, 5 Aug 2008 13:38:49 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080805173849.61FFB2E1D8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21272 Modified Files: ChangeLog swank-backend.lisp Log Message: * swank-backend.lisp (thread-id): Add a default implementation which works with the default implementation of current-thread. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:44 1.1392 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:49 1.1393 @@ -3,6 +3,8 @@ * swank-backend.lisp (make-recursive-lock) (call-with-recursive-lock-held): Deleted. Make the default locks "recursive" instead. + (thread-id): Add a default implementation which works + with the default implementation of current-thread. * swank-gray.lisp (stream-write-string): New method. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/05 17:38:44 1.138 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/05 17:38:49 1.139 @@ -937,7 +937,8 @@ "Return an Emacs-parsable object to identify THREAD. Ids should be comparable with equal, i.e.: - (equal (thread-id ) (thread-id )) <==> (eq )") + (equal (thread-id ) (thread-id )) <==> (eq )" + thread) (definterface find-thread (id) "Return the thread for ID. From heller at common-lisp.net Tue Aug 5 17:38:55 2008 From: heller at common-lisp.net (heller) Date: Tue, 5 Aug 2008 13:38:55 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080805173855.6DC49340CC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21323 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (encode-message): Inhibit interrupts while writing the length and the body. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:49 1.1393 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:53 1.1394 @@ -1,5 +1,8 @@ 2008-08-05 Helmut Eller + * swank.lisp (encode-message): Inhibit interrupts + while writing the length and the body. + * swank-backend.lisp (make-recursive-lock) (call-with-recursive-lock-held): Deleted. Make the default locks "recursive" instead. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/04 20:25:24 1.551 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/05 17:38:53 1.552 @@ -1430,9 +1430,10 @@ (let* ((string (prin1-to-string-for-emacs message)) (length (length string))) (log-event "WRITE: ~A~%" string) - (let ((*print-pretty* nil)) - (format stream "~6,'0x" length)) - (write-string string stream) + (without-interrupts + (let ((*print-pretty* nil)) + (format stream "~6,'0x" length)) + (write-string string stream)) ;;(terpri stream) (finish-output stream))) From heller at common-lisp.net Tue Aug 5 17:38:59 2008 From: heller at common-lisp.net (heller) Date: Tue, 5 Aug 2008 13:38:59 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080805173859.C6292340FE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21364 Modified Files: ChangeLog swank-lispworks.lisp Log Message: * swank-lispworks.lisp (make-stream-interactive): Run our own thread to periodically flush streams instead of relying on soft-force-output. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:53 1.1394 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:59 1.1395 @@ -1,5 +1,9 @@ 2008-08-05 Helmut Eller + * swank-lispworks.lisp (make-stream-interactive): Run our own + thread to periodically flush streams instead of relying on + soft-force-output. + * swank.lisp (encode-message): Inhibit interrupts while writing the length and the body. --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/04 21:38:07 1.104 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/05 17:38:59 1.105 @@ -795,12 +795,29 @@ (defmethod env-internals:environment-display-debugger (env) *debug-io*))) +(defvar *auto-flush-interval* 0.15) +(defvar *auto-flush-lock* (mp:make-lock :name "auto-flush-lock")) +(defvar *auto-flush-thread* nil) +(defvar *auto-flush-streams* '()) + (defimplementation make-stream-interactive (stream) - (unless (find-method #'stream:stream-soft-force-output nil `((eql ,stream)) - nil) - (let ((lw:*handle-warn-on-redefinition* :warn)) - (defmethod stream:stream-soft-force-output ((o (eql stream))) - (force-output o))))) + (mp:with-lock (*auto-flush-lock*) + (pushnew stream *auto-flush-streams*) + (unless *auto-flush-thread* + (setq *auto-flush-thread* + (mp:process-run-function "auto-flush-thread [SWANK]" () + #'flush-streams))))) + +(defun flush-streams () + (loop + (mp:with-lock (*auto-flush-lock*) + (setq *auto-flush-streams* + (remove-if (lambda (x) + (not (and (open-stream-p x) + (output-stream-p x)))) + *auto-flush-streams*)) + (mapc #'finish-output *auto-flush-streams*)) + (sleep *auto-flush-interval*))) (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) (apply (swank-sym :y-or-n-p-in-emacs) msg args)) From heller at common-lisp.net Tue Aug 5 18:19:34 2008 From: heller at common-lisp.net (heller) Date: Tue, 5 Aug 2008 14:19:34 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080805181934.672862F04A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv2266 Modified Files: ChangeLog slime.el Log Message: Prevent typeout messages to be scribbled into random buffers. Patch from Michael Weber. * slime-typeout-frame.el (slime-typeout-message-aux): prevent typeout messages from scribbling into any buffer which happens to be in the typeout window (slime-typeout-buffer): new function; changed buffer name to "*SLIME Typeout*" (slime-make-typeout-frame): use it (slime-ensure-typeout-frame): ensure typeout buffer is visible --- /project/slime/cvsroot/slime/ChangeLog 2008/08/05 17:38:59 1.1395 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/05 18:19:33 1.1396 @@ -1,5 +1,8 @@ 2008-08-05 Helmut Eller + * slime.el (slime-with-output-to-temp-buffer): Make sure that we + don't make the wrong buffer read-only. + * swank-lispworks.lisp (make-stream-interactive): Run our own thread to periodically flush streams instead of relying on soft-force-output. --- /project/slime/cvsroot/slime/slime.el 2008/08/04 20:25:45 1.959 +++ /project/slime/cvsroot/slime/slime.el 2008/08/05 18:19:34 1.960 @@ -928,14 +928,13 @@ If REUSEP is t, an already existing buffer won't be killed." `(let ((standard-output (slime-temp-buffer ,name #',mode ,reusep ,emacs-snapshot)) - (connection% ,(if (eq connection t) - '(slime-connection) - connection)) + (connection% ,(if (eq connection t) '(slime-connection) connection)) (package% ,package)) (with-current-buffer standard-output (setq slime-buffer-package package%) ,@(if connection '((setq slime-buffer-connection connection%))) , at body + (assert (eq (current-buffer) standard-output)) ,@(if read-only '((setq buffer-read-only t)))))) (put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2) @@ -9134,7 +9133,8 @@ (return-from outta 42)))) (dotimes (i ,times) (break) - (sleep 0.2))))))))) + (sleep 0.2)))))) + ))) (dolist (test tests) (let ((name (car test)) (definition (cdr test))) From heller at common-lisp.net Tue Aug 5 18:19:34 2008 From: heller at common-lisp.net (heller) Date: Tue, 5 Aug 2008 14:19:34 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080805181934.A718B30027@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv2266/contrib Modified Files: ChangeLog slime-typeout-frame.el Log Message: Prevent typeout messages to be scribbled into random buffers. Patch from Michael Weber. * slime-typeout-frame.el (slime-typeout-message-aux): prevent typeout messages from scribbling into any buffer which happens to be in the typeout window (slime-typeout-buffer): new function; changed buffer name to "*SLIME Typeout*" (slime-make-typeout-frame): use it (slime-ensure-typeout-frame): ensure typeout buffer is visible --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/04 20:25:57 1.114 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/05 18:19:34 1.115 @@ -1,3 +1,13 @@ +2008-08-05 Michael Weber + + * slime-typeout-frame.el (slime-typeout-message-aux): prevent + typeout messages from scribbling into any buffer which happens to + be in the typeout window + (slime-typeout-buffer): new function; changed buffer name to + "*SLIME Typeout*" + (slime-make-typeout-frame): use it + (slime-ensure-typeout-frame): ensure typeout buffer is visible + 2008-08-04 Adam Bozanich * slime-asdf.el: Load swank-asdf. --- /project/slime/cvsroot/slime/contrib/slime-typeout-frame.el 2008/01/27 10:17:34 1.6 +++ /project/slime/cvsroot/slime/contrib/slime-typeout-frame.el 2008/08/05 18:19:34 1.7 @@ -8,8 +8,7 @@ ;; Add something like this to your .emacs: ;; ;; (add-to-list 'load-path "") -;; (add-hook 'slime-load-hook (lambda () (require 'slime-typeout-frame))) -;; +;; (slime-setup '(slime-typeout-frame)) ;;;; Typeout frame @@ -24,14 +23,20 @@ '((height . 10) (minibuffer . nil)) "The typeout frame properties (passed to `make-frame').") +(defun slime-typeout-buffer () + (with-current-buffer (get-buffer-create "*SLIME Typeout*") + (setq buffer-read-only t) + (current-buffer))) + (defun slime-typeout-active-p () (and slime-typeout-window (window-live-p slime-typeout-window))) (defun slime-typeout-message-aux (format-string &rest format-args) (slime-ensure-typeout-frame) - (with-current-buffer (window-buffer slime-typeout-window) - (let ((msg (apply #'format format-string format-args))) + (with-current-buffer (slime-typeout-buffer) + (let ((inhibit-read-only t) + (msg (apply #'format format-string format-args))) (unless (string= msg "") (erase-buffer) (insert msg))))) @@ -50,13 +55,16 @@ (let ((frame (make-frame slime-typeout-frame-properties))) (save-selected-window (select-window (frame-selected-window frame)) - (switch-to-buffer "*SLIME-Typeout*") + (switch-to-buffer (slime-typeout-buffer)) (setq slime-typeout-window (selected-window))))) (defun slime-ensure-typeout-frame () "Create the typeout frame unless it already exists." (interactive) - (unless (slime-typeout-active-p) + (if (slime-typeout-active-p) + (save-selected-window + (select-window slime-typeout-window) + (switch-to-buffer (slime-typeout-buffer))) (slime-make-typeout-frame))) (defun slime-typeout-autodoc-message (doc) From nsiivola at common-lisp.net Wed Aug 6 09:17:01 2008 From: nsiivola at common-lisp.net (nsiivola) Date: Wed, 6 Aug 2008 05:17:01 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080806091701.65D324E011@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6601 Modified Files: ChangeLog swank-sbcl.lisp Log Message: No SBCL style-warnings for definitions inside EVAL-WHEN :COMPILE-TOPLEVEL --- /project/slime/cvsroot/slime/ChangeLog 2008/08/05 18:19:33 1.1396 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/06 09:16:54 1.1397 @@ -1,3 +1,14 @@ +2008-08-06 Nikodemus Siivola + + * swank-sbcl.lisp (handle-notification-condition): resignal + warnings as-is before replacing with COMPILER-CONDITION so that + handlers higher up the stack can muffle them should they choose + to. This silences redefinition warnings for definitions inside + EVAL-WHEN :COMPILE-TOPLEVEL in newish SBCLs when compiling the + file for a second time. + (call-with-compilation-hooks): STYLE-WARNINGs are WARNINGs, and + don't need a separate handler. + 2008-08-05 Helmut Eller * slime.el (slime-with-output-to-temp-buffer): Make sure that we --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/05 17:38:44 1.205 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 09:16:55 1.206 @@ -313,10 +313,13 @@ C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to craft our own error messages, which can omit a lot of redundant information." - (let ((context (sb-c::find-error-context nil))) - (unless (eq condition *previous-compiler-condition*) - (setq *previous-compiler-condition* condition) - (signal-compiler-condition condition context)))) + (unless (or (eq condition *previous-compiler-condition*)) + ;; First resignal warnings, so that outer handlers -- which may choose to + ;; muffle this -- get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition condition (sb-c::find-error-context nil)))) (defun signal-compiler-condition (condition context) (signal (make-condition @@ -409,7 +412,6 @@ (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination) (sb-c:compiler-error #'handle-notification-condition) (sb-ext:compiler-note #'handle-notification-condition) - (style-warning #'handle-notification-condition) (warning #'handle-notification-condition)) (funcall function))) From heller at common-lisp.net Wed Aug 6 19:51:29 2008 From: heller at common-lisp.net (heller) Date: Wed, 6 Aug 2008 15:51:29 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080806195129.BC6B1702EF@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15074 Modified Files: ChangeLog swank-backend.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp swank.lisp Log Message: Queue interrupts in various places. * swank-backend.lisp (*pending-slime-interrupts*): New variable. (check-slime-interrupts): New function. * swank-lispworks.lisp (receive-if): Use it. * swank-sbcl.lisp, swank-openmcl.lisp: Ditto. * swank.lisp (*slime-interrupts-enabled*): New variable. (with-slime-interrupts, without-slime-interrupts): New macros. (invoke-or-queue-interrupt): New function. (interrupt-worker-thread, eval-for-emacs, swank-debugger-hook) (debug-nth-thread, wait-for-event, read-from-emacs): Use them. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/06 09:16:54 1.1397 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:29 1.1398 @@ -9,6 +9,23 @@ (call-with-compilation-hooks): STYLE-WARNINGs are WARNINGs, and don't need a separate handler. +2008-08-06 Helmut Eller + + Queue interrupts in various places. + + * swank-backend.lisp (*pending-slime-interrupts*): New variable. + (check-slime-interrupts): New function. + + * swank-lispworks.lisp (receive-if): Use it. + + * swank-sbcl.lisp, swank-openmcl.lisp: Ditto. + + * swank.lisp (*slime-interrupts-enabled*): New variable. + (with-slime-interrupts, without-slime-interrupts): New macros. + (invoke-or-queue-interrupt): New function. + (interrupt-worker-thread, eval-for-emacs, swank-debugger-hook) + (debug-nth-thread, wait-for-event, read-from-emacs): Use them. + 2008-08-05 Helmut Eller * slime.el (slime-with-output-to-temp-buffer): Make sure that we --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/05 17:38:49 1.139 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/06 19:51:29 1.140 @@ -32,6 +32,9 @@ #:unbound-slot-filler #:declaration-arglist #:type-specifier-arglist + ;; interrupt macro for the backend + #:*pending-slime-interrupts* + #:check-slime-interrupts ;; inspector related symbols #:emacs-inspect #:label-value-line @@ -1009,6 +1012,16 @@ (definterface receive-if (predicate) "Return the first message satisfiying PREDICATE.") +(defvar *pending-slime-interrupts*) + +(defun check-slime-interrupts () + "Execute pending interrupts if any. +This should be called periodically in operations which +can take a long time to complete." + (when (and (boundp '*pending-slime-interrupts*) + *pending-slime-interrupts*) + (funcall (pop *pending-slime-interrupts*)))) + (definterface toggle-trace (spec) "Toggle tracing of the function(s) given with SPEC. SPEC can be: --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/05 17:38:59 1.105 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/06 19:51:29 1.106 @@ -751,32 +751,31 @@ (let* ((mbox (mailbox mp:*current-process*)) (lock (mailbox.mutex mbox))) (loop - (mp:process-wait "receive" #'mailbox.queue mbox) - (mp:without-interrupts - (mp:with-lock (lock "receive/try" 0.1) - (when (mailbox.queue mbox) - (return (pop (mailbox.queue mbox))))))))) + (check-slime-interrupts) + (mp:with-lock (lock "receive/try") + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))) + (mp:process-wait-with-timeout "receive" 0.2 #'mailbox.queue mbox)))) (defimplementation receive-if (test) (let* ((mbox (mailbox mp:*current-process*)) (lock (mailbox.mutex mbox))) (loop - (mp:process-wait "receive-if" - (lambda () (some test (mailbox.queue mbox)))) - (mp:without-interrupts - (mp:with-lock (lock "receive-if/try" 0.1) - (let* ((q (mailbox.queue mbox)) - (tail (member-if test q))) - (when tail - (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) - (return (car tail))))))))) + (check-slime-interrupts) + (mp:with-lock (lock "receive-if/try") + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (mp:process-wait-with-timeout + "receive-if" 0.2 (lambda () (some test (mailbox.queue mbox))))))) (defimplementation send (thread message) (let ((mbox (mailbox thread))) - (mp:without-interrupts - (mp:with-lock ((mailbox.mutex mbox)) - (setf (mailbox.queue mbox) - (nconc (mailbox.queue mbox) (list message))))))) + (mp:with-lock ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) ;;; Some intergration with the lispworks environment --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/04 21:38:07 1.129 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/06 19:51:29 1.130 @@ -961,23 +961,19 @@ (defimplementation receive () (receive-if (constantly t))) -(defvar *in-receive-if* nil) - (defimplementation receive-if (test) (let* ((mbox (mailbox ccl:*current-process*)) (mutex (mailbox.mutex mbox))) - (loop + (loop + (check-slime-interrupts) (ccl:with-lock-grabbed (mutex) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) - (when *in-receive-if* - (ccl:signal-semaphore (mailbox.semaphore mbox))) (return (car tail))))) - (let ((*in-receive-if* t)) - (ccl:wait-on-semaphore (mailbox.semaphore mbox)))))) + (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 0.2)))) (defimplementation quit-lisp () (ccl::quit)) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 09:16:55 1.206 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 19:51:29 1.207 @@ -1281,27 +1281,22 @@ (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) (defimplementation receive () - (let* ((mbox (mailbox (current-thread))) - (mutex (mailbox.mutex mbox))) - (sb-thread:with-mutex (mutex) - (loop - (let ((q (mailbox.queue mbox))) - (cond (q (return (pop (mailbox.queue mbox)))) - (t (sb-thread:condition-wait (mailbox.waitqueue mbox) - mutex)))))))) + (receive-if (constantly t))) (defimplementation receive-if (test) - (let* ((mbox (mailbox (current-thread))) - (mutex (mailbox.mutex mbox))) - (sb-thread:with-mutex (mutex) - (loop + (let ((mbox (mailbox (current-thread)))) + (loop + (check-slime-interrupts) + (sb-thread:with-mutex ((mailbox.mutex mbox)) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) - (cond (tail - (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) - (return (car tail))) - (t (sb-thread:condition-wait (mailbox.waitqueue mbox) - mutex)))))))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (handler-case (sb-ext:with-timeout 0.2 + (sb-thread:condition-wait (mailbox.waitqueue mbox) + mutex)) + (sb-ext:timeout ())))))) ;; Auto-flush streams --- /project/slime/cvsroot/slime/swank.lisp 2008/08/05 17:38:53 1.552 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/06 19:51:29 1.553 @@ -849,14 +849,43 @@ (swank-error.backtrace e))))))) (progn , at body)))))) -(defslimefun simple-break () +(defvar *slime-interrupts-enabled*) + +(defmacro with-slime-interrupts (&body body) + `(progn + (check-slime-interrupts) + (let ((*slime-interrupts-enabled* t) + (*pending-slime-interrupts* '())) + (multiple-value-prog1 (progn , at body) + (check-slime-interrupts))))) + +(defmacro without-slime-interrupts (&body body) + `(progn + (check-slime-interrupts) + (let ((*slime-interrupts-enabled* nil) + (*pending-slime-interrupts* '())) + (multiple-value-prog1 (progn , at body) + (check-slime-interrupts))))) + +(defun invoke-or-queue-interrupt (function) + (cond ((not (boundp '*slime-interrupts-enabled*)) + (without-slime-interrupts + (funcall function))) + (*slime-interrupts-enabled* + (funcall function)) + ((cddr *pending-slime-interrupts*) + (simple-break "Two many queued interrupts")) + (t + (push function *pending-slime-interrupts*)))) + +(defslimefun simple-break (&optional (message "Interrupt from Emacs")) (with-simple-restart (continue "Continue from interrupt.") (call-with-debugger-hook #'swank-debugger-hook (lambda () (invoke-debugger - (make-condition 'simple-error - :format-control "Interrupt from Emacs"))))) + (make-condition 'simple-error :format-control "~a" + :format-arguments (list message)))))) nil) ;;;;;; Thread based communication @@ -899,7 +928,9 @@ (defun interrupt-worker-thread (id) (let ((thread (or (find-worker-thread id) (repl-thread *emacs-connection*)))) - (interrupt-thread thread #'simple-break))) + (interrupt-thread thread + (lambda () + (invoke-or-queue-interrupt #'simple-break))))) (defun thread-for-evaluation (id) "Find or create a thread to evaluate the next request." @@ -1321,11 +1352,21 @@ (funcall function))) (defun call-with-thread-description (description thunk) - (let* ((thread (current-thread)) - (old-description (thread-description thread))) - (set-thread-description thread description) - (unwind-protect (funcall thunk) - (set-thread-description thread old-description)))) + ;; For `M-x slime-list-threads': Display what threads + ;; created by swank are currently doing. + (flet ((request-to-string (req) + (remove #\Newline + (string-trim '(#\Space #\Tab) + (prin1-to-string req)))) + (truncate-string (str n) + (format nil "~A..." (subseq str 0 (min (length str) n))))) + (let* ((thread (current-thread)) + (old-description (thread-description thread))) + (set-thread-description thread + (truncate-string (request-to-string description) + 55)) + (unwind-protect (funcall thunk) + (set-thread-description thread old-description))))) (defmacro with-thread-description (description &body body) `(call-with-thread-description ,description #'(lambda () , at body))) @@ -1334,29 +1375,22 @@ (defun read-from-emacs () "Read and process a request from Emacs." - (flet ((request-to-string (req) - (remove #\Newline - (string-trim '(#\Space #\Tab) - (prin1-to-string req)))) - (truncate-string (str n) - (if (> (length str) n) - (format nil "~A..." (subseq str 0 n)) - str))) - (let ((request (funcall (connection.read *emacs-connection*)))) - (if (eq *communication-style* :spawn) - ;; For `M-x slime-list-threads': Display what threads - ;; created by swank are currently doing. - (with-thread-description (truncate-string (request-to-string request) 55) - (apply #'funcall request)) - (destructure-case request + (let ((request (without-slime-interrupts + (funcall (connection.read *emacs-connection*))))) + (if (eq *communication-style* :spawn) + (with-thread-description request + (apply #'funcall request)) + (destructure-case request ((:call &rest args) (apply #'funcall args)) (t (setf *event-queue* - (nconc *event-queue* (list request))))))))) + (nconc *event-queue* (list request)))))))) (defun wait-for-event (pattern) (log-event "wait-for-event: %S~%" pattern) (case (connection.communication-style *emacs-connection*) - (:spawn (receive-if (lambda (e) (event-match-p e pattern)))) + (:spawn + (without-slime-interrupts + (receive-if (lambda (e) (event-match-p e pattern))))) (t (wait-for-event/event-loop pattern)))) (defun wait-for-event/event-loop (pattern) @@ -1760,7 +1794,7 @@ (check-type *buffer-readtable* readtable) ;; APPLY would be cleaner than EVAL. ;;(setq result (apply (car form) (cdr form))) - (setq result (eval form)) + (setq result (with-slime-interrupts (eval form))) (run-hook *pre-reply-hook*) (setq ok t)) (send-to-emacs `(:return ,(current-thread) @@ -2006,11 +2040,12 @@ then waits to handle further requests from Emacs. Eventually returns after Emacs causes a restart to be invoked." (declare (ignore hook)) - (cond (*emacs-connection* - (debug-in-emacs condition)) - ((default-connection) - (with-connection ((default-connection)) - (debug-in-emacs condition))))) + (without-slime-interrupts + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition)))))) (defvar *global-debugger* t "Non-nil means the Swank debugger hook will be installed globally.") @@ -2991,8 +3026,10 @@ (let ((connection *emacs-connection*)) (interrupt-thread (nth-thread index) (lambda () - (with-connection (connection) - (simple-break)))))) + (invoke-or-queue-interrupt + (lambda () + (with-connection (connection) + (simple-break)))))))) (defslimefun kill-nth-thread (index) (kill-thread (nth-thread index))) From heller at common-lisp.net Wed Aug 6 19:51:35 2008 From: heller at common-lisp.net (heller) Date: Wed, 6 Aug 2008 15:51:35 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080806195135.9FCB975188@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15128 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-show-apropos): Use lisp-syntax-table to make M-. more useful. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:29 1.1398 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:35 1.1399 @@ -11,6 +11,11 @@ 2008-08-06 Helmut Eller + * slime.el (slime-show-apropos): Use lisp-syntax-table to make + M-. more useful. + +2008-08-06 Helmut Eller + Queue interrupts in various places. * swank-backend.lisp (*pending-slime-interrupts*): New variable. --- /project/slime/cvsroot/slime/slime.el 2008/08/05 18:19:34 1.960 +++ /project/slime/cvsroot/slime/slime.el 2008/08/06 19:51:35 1.961 @@ -5865,11 +5865,9 @@ (slime-eval-async `(swank:apropos-list-for-emacs ,string ,only-external-p ,case-sensitive-p ',package) - (lexical-let ((string string) - (package buffer-package) - (summary (slime-apropos-summary string case-sensitive-p - package only-external-p))) - (lambda (r) (slime-show-apropos r string package summary)))))) + (slime-rcurry #'slime-show-apropos string buffer-package + (slime-apropos-summary string case-sensitive-p + package only-external-p))))) (defun slime-apropos-all () "Shortcut for (slime-apropos nil nil)" @@ -5894,7 +5892,9 @@ (setq header-line-format summary) (insert summary "\n\n")) (slime-set-truncate-lines) - (slime-print-apropos plists)))) + (slime-print-apropos plists) + (set-syntax-table lisp-mode-syntax-table) + (goto-char (point-min))))) (eval-when-compile (require 'apropos)) From heller at common-lisp.net Wed Aug 6 19:51:39 2008 From: heller at common-lisp.net (heller) Date: Wed, 6 Aug 2008 15:51:39 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080806195139.C8A5879143@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15173 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (short-backtrace): New function. (thread-description): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:35 1.1399 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:39 1.1400 @@ -11,6 +11,9 @@ 2008-08-06 Helmut Eller + * swank-sbcl.lisp (short-backtrace): New function. + (thread-description): Use it. + * slime.el (slime-show-apropos): Use lisp-syntax-table to make M-. more useful. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 19:51:29 1.207 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 19:51:39 1.208 @@ -451,6 +451,7 @@ (defimplementation swank-compile-string (string &key buffer position directory debug) + (declare (ignorable debug)) (let ((*buffer-name* buffer) (*buffer-offset* position) (*buffer-substring* string) @@ -1226,12 +1227,31 @@ (defimplementation thread-description (thread) (sb-thread:with-mutex (*thread-descr-map-lock*) - (or (gethash thread *thread-description-map*) ""))) + (or (gethash thread *thread-description-map*) + (short-backtrace thread 6 10)))) (defimplementation set-thread-description (thread description) (sb-thread:with-mutex (*thread-descr-map-lock*) - (setf (gethash thread *thread-description-map*) description)))) - + (setf (gethash thread *thread-description-map*) description))) + + (defun short-backtrace (thread start count) + (let ((self (current-thread)) + (tag (get-internal-real-time))) + (sb-thread:interrupt-thread + thread + (lambda () + (let* ((frames (nthcdr start (sb-debug:backtrace-as-list count)))) + (send self (cons tag frames))))) + (handler-case + (sb-ext:with-timeout 0.1 + (let ((frames (cdr (receive-if (lambda (msg) + (eq (car msg) tag))))) + (*print-pretty* nil)) + (format nil "~{~a~^ <- ~}" (mapcar #'car frames)))) + (sb-ext:timeout () "")))) + + ) + (defimplementation make-lock (&key name) (sb-thread:make-mutex :name name)) From heller at common-lisp.net Wed Aug 6 21:50:38 2008 From: heller at common-lisp.net (heller) Date: Wed, 6 Aug 2008 17:50:38 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080806215038.09DC13E05B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15616 Modified Files: swank-sbcl.lisp Log Message: (receive-if): Fix typo. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 19:51:39 1.208 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 21:50:37 1.209 @@ -1304,10 +1304,11 @@ (receive-if (constantly t))) (defimplementation receive-if (test) - (let ((mbox (mailbox (current-thread)))) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) (loop (check-slime-interrupts) - (sb-thread:with-mutex ((mailbox.mutex mbox)) + (sb-thread:with-mutex (mutex) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail From heller at common-lisp.net Thu Aug 7 07:53:48 2008 From: heller at common-lisp.net (heller) Date: Thu, 7 Aug 2008 03:53:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080807075348.57ED84E011@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv30250 Modified Files: ChangeLog slime.el swank-allegro.lisp swank-cmucl.lisp swank-lispworks.lisp swank-scl.lisp Log Message: * swank-allegro.lisp:(receive-if): Periodically check for interrupts. * swank-cmucl.lisp, swank-scl.lisp: ditto. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/06 19:51:39 1.1400 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/07 07:53:47 1.1401 @@ -1,3 +1,8 @@ +2008-08-07 Helmut Eller + + * swank-allegro.lisp, swank-cmucl.lisp, + swank-scl.lisp (receive-if): Periodically check for interrupts. + 2008-08-06 Nikodemus Siivola * swank-sbcl.lisp (handle-notification-condition): resignal --- /project/slime/cvsroot/slime/slime.el 2008/08/06 19:51:35 1.961 +++ /project/slime/cvsroot/slime/slime.el 2008/08/07 07:53:47 1.962 @@ -6333,7 +6333,8 @@ (lambda (expansion) (slime-with-output-to-temp-buffer ;; reusep for preserving `undo' functionality. - ("*SLIME Macroexpansion*" :mode lisp-mode :reusep t :connection t) package + ("*SLIME Macroexpansion*" :mode lisp-mode + :reusep t :connection t :read-only nil) package (slime-mode 1) (slime-macroexpansion-minor-mode 1) (erase-buffer) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/04 21:38:07 1.106 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/07 07:53:47 1.107 @@ -661,8 +661,9 @@ (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) (defstruct (mailbox (:conc-name mailbox.)) - (mutex (mp:make-process-lock :name "process mailbox")) - (queue '() :type list)) + (lock (mp:make-process-lock :name "process mailbox")) + (queue '() :type list) + (gate (mp:make-gate))) (defun mailbox (thread) "Return THREAD's mailbox." @@ -672,29 +673,28 @@ (make-mailbox))))) (defimplementation send (thread message) - (let* ((mbox (mailbox thread)) - (mutex (mailbox.mutex mbox))) - (mp:with-process-lock (mutex) - (setf (mailbox.queue mbox) - (nconc (mailbox.queue mbox) (list message)))))) + (let* ((mbox (mailbox thread))) + (mp:with-process-lock ((mailbox.lock mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:open-gate (mailbox.gate mbox))))) (defimplementation receive () - (let* ((mbox (mailbox mp:*current-process*)) - (mutex (mailbox.mutex mbox))) - (mp:process-wait "receive" #'mailbox.queue mbox) - (mp:with-process-lock (mutex) - (pop (mailbox.queue mbox))))) + (receive-if (constantly t))) (defimplementation receive-if (test) (let ((mbox (mailbox mp:*current-process*))) - (mp:process-wait "receive-if" - (lambda () (some test (mailbox.queue mbox)))) - (mp:with-process-lock ((mailbox.mutex mbox)) - (let* ((q (mailbox.queue mbox)) - (tail (member-if test q))) - (assert tail) - (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) - (car tail))))) + (loop + (check-slime-interrupts) + (mp:with-process-lock ((mailbox.lock mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (mp:close-gate (mailbox.gate mbox)))) + (mp:process-wait-with-timeout "receive-if" 0.5 + #'mp:gate-open-p (mailbox.gate mbox))))) (defimplementation quit-lisp () (excl:exit 0 :quiet t)) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/04 20:25:28 1.183 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/07 07:53:47 1.184 @@ -2097,34 +2097,28 @@ (make-mailbox))))) (defimplementation send (thread message) + (check-slime-interrupts) (let* ((mbox (mailbox thread))) - (sys:without-interrupts - (mp:with-lock-held ((mailbox.mutex mbox)) - (setf (mailbox.queue mbox) - (nconc (mailbox.queue mbox) (list message))))))) + (mp:with-lock-held ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) (defimplementation receive () - (let* ((mbox (mailbox mp:*current-process*))) - (loop - (mp:process-wait "receive" #'mailbox.queue mbox) - (sys:without-interrupts - (mp:with-lock-held ((mailbox.mutex mbox)) - (when (mailbox.queue mbox) - (return (pop (mailbox.queue mbox))))))))) + (receive-if (constantly t))) (defimplementation receive-if (test) (let ((mbox (mailbox mp:*current-process*))) (loop - (mp:process-wait "receive-if" - (lambda () (some test (mailbox.queue mbox)))) - (sys:without-interrupts - (mp:with-lock-held ((mailbox.mutex mbox)) - (let* ((q (mailbox.queue mbox)) - (tail (member-if test q))) - (when tail - (setf (mailbox.queue mbox) - (nconc (ldiff q tail) (cdr tail))) - (return (car tail))))))))) + (check-slime-interrupts) + (mp:with-lock-held ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (mp:process-wait-with-timeout + "receive-if" 0.5 (lambda () (some test (mailbox.queue mbox))))))) ) ;; #+mp --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/06 19:51:29 1.106 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/07 07:53:47 1.107 @@ -34,7 +34,7 @@ (when (fboundp 'dspec::define-dspec-alias) (dspec::define-dspec-alias defimplementation (name args &rest body) - `(defmethod ,name ,args , at body))) + `(defun ,name ,args , at body))) ;;; TCP server @@ -748,14 +748,7 @@ (make-mailbox))))) (defimplementation receive () - (let* ((mbox (mailbox mp:*current-process*)) - (lock (mailbox.mutex mbox))) - (loop - (check-slime-interrupts) - (mp:with-lock (lock "receive/try") - (when (mailbox.queue mbox) - (return (pop (mailbox.queue mbox))))) - (mp:process-wait-with-timeout "receive" 0.2 #'mailbox.queue mbox)))) + (receive-if (constantly t))) (defimplementation receive-if (test) (let* ((mbox (mailbox mp:*current-process*)) --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/04 20:25:33 1.20 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/07 07:53:47 1.21 @@ -1969,44 +1969,27 @@ (defimplementation send (thread message) (let* ((mbox (mailbox thread)) (lock (mailbox-lock mbox))) - (sys:without-interrupts - (thread:with-lock-held (lock "Mailbox Send") - (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) - (list message))))) - (mp:process-wakeup thread) - message)) - + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message)))) + (mp:process-wakeup thread))) + (defimplementation receive () - (let* ((mbox (mailbox thread:*thread*)) - (lock (mailbox-lock mbox))) - (loop - (mp:process-wait-with-timeout "Mailbox read wait" 1 - #'(lambda () (mailbox-queue mbox))) - (multiple-value-bind (message winp) - (sys:without-interrupts - (mp:with-lock-held (lock "Mailbox read") - (let ((queue (mailbox-queue mbox))) - (cond (queue - (setf (mailbox-queue mbox) (cdr queue)) - (values (car queue) t)) - (t - (values nil nil)))))) - (when winp - (return message)))))) + (receive-if (constantly t))) (defimplementation receive-if (test) (let ((mbox (mailbox thread:*thread*))) (loop - (mp:process-wait "receive-if" - (lambda () (some test (mailbox-queue mbox)))) - (sys:without-interrupts - (mp:with-lock-held ((mailbox-lock mbox)) - (let* ((q (mailbox-queue mbox)) - (tail (member-if test q))) - (when tail - (setf (mailbox-queue mbox) - (nconc (ldiff q tail) (cdr tail))) - (return (car tail))))))))) + (check-slime-interrupts) + (mp:with-lock-held ((mailbox-lock mbox)) + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (mp:process-wait-with-timeout + "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox))))))) From heller at common-lisp.net Thu Aug 7 08:10:01 2008 From: heller at common-lisp.net (heller) Date: Thu, 7 Aug 2008 04:10:01 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080807081001.EABAC75187@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv1536 Modified Files: swank-allegro.lisp Log Message: Fix typo. --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/07 07:53:47 1.107 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/07 08:10:01 1.108 @@ -663,7 +663,7 @@ (defstruct (mailbox (:conc-name mailbox.)) (lock (mp:make-process-lock :name "process mailbox")) (queue '() :type list) - (gate (mp:make-gate))) + (gate (mp:make-gate nil))) (defun mailbox (thread) "Return THREAD's mailbox." From trittweiler at common-lisp.net Thu Aug 7 10:13:25 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 7 Aug 2008 06:13:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080807101325.AE4EE1A0C0@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv26463 Modified Files: slime.el ChangeLog Log Message: Mode-Line will now display a buffer's connection, and a buffer's package. Furthermore, stale connections will also be indicated. * slime.el: (slime-update-modeline-package): Renamed to `slime-extended-modeline'. (slime-modeline-string), (slime-modeline-connection-name), (slime-modeline-connection-state): New variables. (slime-update-modeline-package): Renamed to `slime-compute-modeline-package'. (slime-compute-modeline-connection): New. (sime-compute-modeline-connection-state): New. (slime-compute-modeline-string): New. (slime-update-modeline-string): New. (slime-shall-we-update-modeline-p): New. (slime-update-modeline): New. Run periodically by idle timer. (slime-mode, slime-temp-buffer-mode): Install extended mode-line. (slime-stale-connection-p, slime-debugged-connection-p): New. (slime-compute-connection-state): New. (slime-connection-state-as-string): New. (slime-state-name): Removed. (slime-set-state): Removed. (slime-length>): Fix typecase. --- /project/slime/cvsroot/slime/slime.el 2008/08/07 07:53:47 1.962 +++ /project/slime/cvsroot/slime/slime.el 2008/08/07 10:13:25 1.963 @@ -133,9 +133,10 @@ :type 'boolean :group 'slime-ui) -(defcustom slime-update-modeline-package t - "Automatically update the Lisp package name in the minibuffer. -This is done with a text-search that runs on an idle timer." +(defcustom slime-extended-modeline t + "If non-nil, display various information in the mode line of a +Lisp buffer. The information includes the current connection of +that buffer, the buffer package, and some state indication." :type 'boolean :group 'slime-ui) @@ -425,20 +426,31 @@ ;; Fake binding to coax `define-minor-mode' to create the keymap '((" " 'undefined))) + (make-variable-buffer-local - (defvar slime-modeline-package nil - "The Lisp package to show in the modeline. -This is automatically updated based on the buffer/point.")) + (defvar slime-modeline-string nil + "The string that should be displayed in the modeline if +`slime-extended-modeline' is true, and which indicates the +current connection, package and state of a Lisp buffer. +The string is periodically updated by an idle timer.")) -(defun slime-update-modeline-package () - (ignore-errors - (when (and slime-update-modeline-package - (memq major-mode slime-lisp-modes) - slime-mode) - (let ((package (slime-current-package))) - (when package - (setq slime-modeline-package - (slime-pretty-package-name package))))))) + +;;; These are used to keep track of old values, so we can determine +;;; whether the mode line has changed, and should be updated. +(make-variable-buffer-local + (defvar slime-modeline-package nil)) +(make-variable-buffer-local + (defvar slime-modeline-connection-name nil)) +(make-variable-buffer-local + (defvar slime-modeline-connection-state nil)) + +(defun slime-compute-modeline-package () + (when (memq major-mode slime-lisp-modes) + (let* ((pkg (slime-current-package)) + (pretty-pkg )) + (if pkg + (slime-pretty-package-name pkg) + nil)))) (defun slime-pretty-package-name (name) "Return a pretty version of a package name NAME." @@ -449,16 +461,58 @@ (t name)))) (format "%s" (read name)))) -(when slime-update-modeline-package - (run-with-idle-timer 0.2 0.2 'slime-update-modeline-package)) +(defun slime-compute-modeline-connection () + (let ((conn (slime-current-connection))) + (if (or (null conn) (slime-stale-connection-p conn)) + nil + (slime-connection-name conn)))) + +(defun slime-compute-modeline-connection-state () + (let ((new-state (slime-compute-connection-state (slime-current-connection)))) + (if (eq new-state :connected) + nil ; normal case, so don't display anything in the mode line. + (slime-connection-state-as-string new-state)))) + +(defun slime-compute-modeline-string (conn state pkg) + (concat (when (or conn pkg) "[") + (when conn (format "CON:%s" conn)) + (when state (format "{%s}" state)) + (when (and (or conn state) pkg) ", ") + (when pkg (format "PKG:%s" pkg)) + (when (or conn pkg) "]"))) + +(defun slime-update-modeline-string () + (let ((old-pkg slime-modeline-package) + (old-conn slime-modeline-connection-name) + (old-state slime-modeline-connection-state)) + (let ((new-pkg (slime-compute-modeline-package)) + (new-conn (slime-compute-modeline-connection)) + (new-state (slime-compute-modeline-connection-state))) + (when (or (not (equal old-pkg new-pkg)) + (not (equal old-conn new-conn)) + (not (equal old-state new-state))) + (setq slime-modeline-package new-pkg) + (setq slime-modeline-connection-name new-conn) + (setq slime-modeline-connection-state new-state) + (setq slime-modeline-string + (slime-compute-modeline-string new-conn new-state new-pkg)) + (force-mode-line-update t))))) + +(defun slime-shall-we-update-modeline-p () + (and slime-extended-modeline + (or slime-mode slime-temp-buffer-mode))) + +(defun slime-update-modeline () + (when (slime-shall-we-update-modeline-p) + (slime-update-modeline-string))) + +(run-with-idle-timer 0.2 0.2 'slime-update-modeline) ;; Setup the mode-line to say when we're in slime-mode, and which CL ;; package we think the current buffer belongs to. (add-to-list 'minor-mode-alist '(slime-mode - (" Slime" - ((slime-modeline-package (":" slime-modeline-package) "") - slime-state-name)))) + (" Slime" slime-modeline-string))) ;;;;; Key bindings @@ -972,7 +1026,7 @@ (define-minor-mode slime-temp-buffer-mode "Mode for displaying read only stuff" nil - " Tmp" + (" Slime-Tmp" slime-modeline-string) '(("q" . slime-temp-buffer-quit) ("\C-c\C-z" . slime-switch-to-output-buffer) ("\M-." . slime-edit-definition))) @@ -1337,8 +1391,6 @@ (let ((file (slime-swank-port-file))) (unless (active-minibuffer-window) (message "Polling %S.. (Abort with `M-x slime-abort-connection'.)" file)) - (unless (slime-connected-p) - (slime-set-state (format "[polling:%S]" attempt))) (slime-cancel-connect-retry-timer) (cond ((and (file-exists-p file) (> (nth 7 (file-attributes file)) 0)) ; file size @@ -1590,8 +1642,7 @@ (defun slime-net-sentinel (process message) (message "Lisp connection closed unexpectedly: %s" message) - (slime-net-close process) - (slime-set-state "[not connected]" process)) + (slime-net-close process)) ;;; Socket input is handled by `slime-net-filter', which decodes any ;;; complete messages and hands them off to the event dispatcher. @@ -1778,18 +1829,25 @@ (put 'slime-with-connection-buffer 'lisp-indent-function 1) -(defvar slime-state-name "[??]" - "Name of the current state of `slime-default-connection'. -Just used for informational display in the mode-line.") - -(defun slime-set-state (name &optional connection) - "Set the current connection's informational state name. -If this is the default connection then the state will be displayed in -the modeline." - (when (or (not (slime-connected-p)) - (eq (or connection (slime-connection)) slime-default-connection)) - (setq slime-state-name name) - (force-mode-line-update))) + +(defun slime-compute-connection-state (conn) + (cond ((null conn) :disconnected) + ((slime-stale-connection-p conn) :stale) + ((slime-debugged-connection-p conn) :debugged) + ((and (slime-use-sigint-for-interrupt conn) + (slime-busy-p conn)) :busy) + ((eq slime-buffer-connection conn) :local) + (t :connected))) + +(defun slime-connection-state-as-string (state) + (case state + (:connected "") + (:disconnected "not connected") + (:busy "busy..") + (:debugged "debugged..") + (:stale "stale") + (:local "local") + )) ;;; Connection-local variables: @@ -1922,7 +1980,6 @@ (slime-connection-name) (slime-generate-connection-name name))) (destructuring-bind (&key instance type version) machine (setf (slime-machine-instance) instance))) - (setq slime-state-name "") ; FIXME (let ((args (when-let (p (slime-inferior-process)) (slime-inferior-lisp-args p)))) (when-let (name (plist-get args ':name)) @@ -2194,15 +2251,22 @@ (error "Not connected. Use `%s' to start a Lisp." (substitute-command-keys "\\[slime]")))) -(defun slime-busy-p () +(defun slime-stale-connection-p (conn) + (not (memq conn slime-net-processes))) + +(defun slime-debugged-connection-p (conn) + (and (sldb-debugged-continuations conn) t)) + +(defun slime-busy-p (&optional conn) "True if Lisp has outstanding requests. Debugged requests are ignored." - (let ((debugged (sldb-debugged-continuations (slime-connection)))) + (let ((debugged (sldb-debugged-continuations (or conn (slime-connection))))) (remove-if (lambda (id) (memq id debugged)) (slime-rex-continuations) :key #'car))) + ;; dummy defvar for compiler (defvar slime-repl-read-mode) @@ -2249,7 +2313,6 @@ ((:write-string output &optional target) (slime-write-string output target)) ((:emacs-rex form package thread continuation) - (slime-set-state "|eval...") (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) (message "; pipelined request... %S" form)) (let ((id (incf (slime-continuation-counter)))) @@ -2259,8 +2322,6 @@ (let ((rec (assq id (slime-rex-continuations)))) (cond (rec (setf (slime-rex-continuations) (remove rec (slime-rex-continuations))) - (when (null (slime-rex-continuations)) - (slime-set-state "")) (funcall (cdr rec) value)) (t (error "Unexpected reply: %S %S" id value))))) @@ -9274,7 +9335,7 @@ "Return non-nil if (> (length LIST) N)." (etypecase seq (list (nthcdr n seq)) - (seq (> (length seq) n)))) + (sequence (> (length seq) n)))) (defun slime-trim-whitespace (str) (save-match-data --- /project/slime/cvsroot/slime/ChangeLog 2008/08/07 07:53:47 1.1401 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/07 10:13:25 1.1402 @@ -1,3 +1,32 @@ +2008-08-07 Tobias C. Rittweiler + + Mode-Line will now display a buffer's connection, and a buffer's + package. Furthermore, stale connections will also be indicated. + + * slime.el: (slime-update-modeline-package): Renamed to + `slime-extended-modeline'. + (slime-modeline-string), + (slime-modeline-connection-name), + (slime-modeline-connection-state): New variables. + (slime-update-modeline-package): Renamed to + `slime-compute-modeline-package'. + (slime-compute-modeline-connection): New. + (sime-compute-modeline-connection-state): New. + (slime-compute-modeline-string): New. + (slime-update-modeline-string): New. + (slime-shall-we-update-modeline-p): New. + (slime-update-modeline): New. Run periodically by idle timer. + + (slime-mode, slime-temp-buffer-mode): Install extended mode-line. + + (slime-stale-connection-p, slime-debugged-connection-p): New. + (slime-compute-connection-state): New. + (slime-connection-state-as-string): New. + (slime-state-name): Removed. + (slime-set-state): Removed. + + (slime-length>): Fix typecase. + 2008-08-07 Helmut Eller * swank-allegro.lisp, swank-cmucl.lisp, From trittweiler at common-lisp.net Thu Aug 7 14:06:04 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 7 Aug 2008 10:06:04 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080807140604.9BB732F002@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22073 Modified Files: slime.el ChangeLog Log Message: * slime.el (def-slime-test narrowing): Adapted to recent changes of `slime-with-output-to-temp-buffer'. --- /project/slime/cvsroot/slime/slime.el 2008/08/07 10:13:25 1.963 +++ /project/slime/cvsroot/slime/slime.el 2008/08/07 14:06:04 1.964 @@ -8668,9 +8668,11 @@ (slime-with-output-to-temp-buffer (random-buffer-name) nil (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name) - (equal (buffer-name (current-buffer)) random-buffer-name)) - (slime-temp-buffer-quit)) - (kill-buffer random-buffer-name) + (equal (buffer-name (current-buffer)) random-buffer-name))) + (with-current-buffer random-buffer-name + ;; Notice that we cannot quit the buffer within the the extent + ;; of slime-with-output-to-temp-buffer. + (slime-temp-buffer-quit t)) (slime-check ("Checking that we've got back from `%s'" random-buffer-name) (and (eq (current-buffer) tmpbuffer) (= (point) defun-pos))) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/07 10:13:25 1.1402 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/07 14:06:04 1.1403 @@ -1,5 +1,10 @@ 2008-08-07 Tobias C. Rittweiler + * slime.el (def-slime-test narrowing): Adapted to recent changes + of `slime-with-output-to-temp-buffer'. + +2008-08-07 Tobias C. Rittweiler + Mode-Line will now display a buffer's connection, and a buffer's package. Furthermore, stale connections will also be indicated. From heller at common-lisp.net Thu Aug 7 14:10:25 2008 From: heller at common-lisp.net (heller) Date: Thu, 7 Aug 2008 10:10:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080807141025.873983D0B8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22931 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-with-temp-buffer): Renamed from slime-with-output-to-temp-buffer. Initialize the buffer local buffer variables before and after running BODY, so that we don't need the mode argument. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/07 14:06:04 1.1403 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/07 14:10:25 1.1404 @@ -1,3 +1,10 @@ +2008-08-07 Helmut Eller + + * slime.el (slime-with-temp-buffer): Renamed from + slime-with-output-to-temp-buffer. Initialize the buffer local + buffer variables before and after running BODY, so that we don't + need the mode argument. + 2008-08-07 Tobias C. Rittweiler * slime.el (def-slime-test narrowing): Adapted to recent changes --- /project/slime/cvsroot/slime/slime.el 2008/08/07 14:06:04 1.964 +++ /project/slime/cvsroot/slime/slime.el 2008/08/07 14:10:25 1.965 @@ -963,10 +963,9 @@ "The emacs snapshot \"fingerprint\" after displaying the buffer.")) ;; Interface -(defmacro* slime-with-output-to-temp-buffer ((name &key mode connection - (read-only t) - reusep emacs-snapshot) - package &rest body) +(defmacro* slime-with-temp-buffer ((name package &key (connection t) + emacs-snapshot) + &rest body) "Similar to `with-output-to-temp-buffer'. Bind standard-output and initialize some buffer-local variables. @@ -976,52 +975,41 @@ If nil, no explicit connection is associated with the buffer. If t, the current connection is taken. -MODE is the major mode the buffer should be set to. -READ-ONLY makes the buffer read-only. - -If REUSEP is t, an already existing buffer won't be killed." - `(let ((standard-output - (slime-temp-buffer ,name #',mode ,reusep ,emacs-snapshot)) - (connection% ,(if (eq connection t) '(slime-connection) connection)) - (package% ,package)) +If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous +state of Emacs after closing the temporary buffer. Otherwise, the +current state will be saved and later restored." + `(let* ((vars% (list ,package + ,(if (eq connection t) '(slime-connection) connection) + ,(or emacs-snapshot '(slime-current-emacs-snapshot)))) + (standard-output (slime-temp-buffer ,name vars%))) (with-current-buffer standard-output - (setq slime-buffer-package package%) - ,@(if connection '((setq slime-buffer-connection connection%))) - , at body - (assert (eq (current-buffer) standard-output)) - ,@(if read-only '((setq buffer-read-only t)))))) + (prog1 (progn , at body) + (assert (eq (current-buffer) standard-output)) + (setq buffer-read-only t) + (slime-init-temp-buffer vars%))))) -(put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2) +(put 'slime-with-temp-buffer 'lisp-indent-function 1) -(defun slime-temp-buffer (name mode reusep emacs-snapshot) +(defun slime-temp-buffer (name buffer-vars) "Return a temporary buffer called NAME in MODE. -The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing -`q' in the buffer will restore the window configuration to the way it -is when the buffer was created, i.e. when this function was called. - -If REUSEP is true and a buffer does already exist with name NAME, -then the buffer will be reused instead of being killed. - -If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous -state of Emacs after closing the temporary buffer. Otherwise, the -current state will be saved and later restored. -" - (let ((snapshot (or emacs-snapshot (slime-current-emacs-snapshot)))) - (when (and (not reusep) (get-buffer name)) - (kill-buffer (get-buffer name))) - (with-current-buffer (get-buffer-create name) - (when mode - (let ((original-configuration slime-temp-buffer-saved-emacs-snapshot) - (original-fingerprint slime-temp-buffer-saved-fingerprint)) - (funcall mode) - (setq slime-temp-buffer-saved-emacs-snapshot original-configuration) - (setq slime-temp-buffer-saved-fingerprint original-fingerprint))) - (slime-temp-buffer-mode 1) - (setq slime-temp-buffer-saved-emacs-snapshot snapshot) - (setq slime-temp-buffer-saved-fingerprint - (slime-current-emacs-snapshot-fingerprint)) - (pop-to-buffer (current-buffer)) - (current-buffer)))) +The buffer also uses the minor-mode `slime-temp-buffer-mode'. +Pressing `q' in the buffer will restore the window configuration +to the way it is when the buffer was created, i.e. when this +function was called." + (when (and (get-buffer name) (kill-buffer (get-buffer name)))) + (with-current-buffer (get-buffer-create name) + (set-syntax-table lisp-mode-syntax-table) + (prog1 (pop-to-buffer (current-buffer)) + (slime-init-temp-buffer buffer-vars)))) + +(defun slime-init-temp-buffer (buffer-vars) + (slime-temp-buffer-mode 1) + (setq slime-temp-buffer-saved-fingerprint + (slime-current-emacs-snapshot-fingerprint)) + (multiple-value-setq (slime-buffer-package + slime-buffer-connection + slime-temp-buffer-saved-emacs-snapshot) + buffer-vars)) (define-minor-mode slime-temp-buffer-mode "Mode for displaying read only stuff" @@ -3631,7 +3619,7 @@ (defun slime-list-repl-short-cuts () (interactive) - (slime-with-output-to-temp-buffer ("*slime-repl-help*") nil + (slime-with-temp-buffer ("*slime-repl-help*" nil) (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string< :key (lambda (x) (car (slime-repl-shortcut.names x)))))) @@ -4137,11 +4125,10 @@ "Show the compiler notes NOTES in tree view." (interactive (list (slime-compiler-notes))) (with-temp-message "Preparing compiler note tree..." - (slime-with-output-to-temp-buffer ("*SLIME Compiler-Notes*" - :mode slime-compiler-notes-mode + (slime-with-temp-buffer ("*SLIME Compiler-Notes*" nil :emacs-snapshot emacs-snapshot) - nil (erase-buffer) + (slime-compiler-notes-mode) (when (null notes) (insert "[no notes]")) (dolist (tree (slime-compiler-notes-to-tree notes)) @@ -5395,15 +5382,15 @@ (t (message "%s" value))))) fn))) -(defun slime-show-description (string package) - (slime-with-output-to-temp-buffer ("*SLIME Description*") package - (princ string))) - (defun slime-eval-describe (form) "Evaluate FORM in Lisp and display the result in a new buffer." - (lexical-let ((package (slime-current-package))) - (slime-eval-with-transcript - form (lambda (string) (slime-show-description string package))))) + (slime-eval-async form (slime-rcurry #'slime-show-description + (slime-current-package)))) + +(defun slime-show-description (string package) + (slime-with-temp-buffer ("*SLIME Description*" package) + (princ string) + (goto-char (point-min)))) (defun slime-insert-transcript-delimiter (string) (with-current-buffer (slime-output-buffer) @@ -5546,11 +5533,13 @@ (defun slime-edit-value-callback (form-string current-value package) (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))) - (slime-with-output-to-temp-buffer (name :mode lisp-mode :connection t - :read-only nil) package + (with-current-buffer (slime-with-temp-buffer (name package) + (current-buffer)) + (lisp-mode) (slime-mode 1) (slime-temp-buffer-mode -1) ; don't want binding of 'q' (slime-edit-value-mode 1) + (setq buffer-read-only nil) (setq slime-edit-form-string form-string) (insert current-value)))) @@ -5946,9 +5935,8 @@ (defun slime-show-apropos (plists string package summary) (if (null plists) (message "No apropos matches for %S" string) - (slime-with-output-to-temp-buffer ("*SLIME Apropos*" :mode apropos-mode - :connection t) - package + (slime-with-temp-buffer ("*SLIME Apropos*" package) + (apropos-mode) (if (boundp 'header-line-format) (setq header-line-format summary) (insert summary "\n\n")) @@ -6353,12 +6341,13 @@ (define-key slime-macroexpansion-minor-mode-map mapping to)))) (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace) (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace) - (remap 'undo '(lambda (&optional arg) - (interactive) - (let ((buffer-read-only nil)) - (when (fboundp 'slime-remove-edits) - (slime-remove-edits (point-min) (point-max))) - (undo arg))))) + (remap 'advertised-undo + '(lambda (&optional arg) + (interactive) + (let ((inhibit-read-only t)) + (when (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (undo arg))))) (defun slime-sexp-at-point-for-macroexpansion () "Essentially like SLIME-SEXP-AT-POINT-OR-ERROR, but behaves a @@ -6381,28 +6370,33 @@ (list string bounds))) (defvar slime-eval-macroexpand-expression nil - "Specifies the last macroexpansion preformed. This variable - specifies both what was expanded and how.") + "Specifies the last macroexpansion preformed. +This variable specifies both what was expanded and how.") (defun slime-eval-macroexpand (expander &optional string) - (unless string - (setf string (first (slime-sexp-at-point-for-macroexpansion)))) - (setf slime-eval-macroexpand-expression `(,expander ,string)) - (lexical-let ((package (slime-current-package))) - (slime-eval-async - slime-eval-macroexpand-expression - (lambda (expansion) - (slime-with-output-to-temp-buffer - ;; reusep for preserving `undo' functionality. - ("*SLIME Macroexpansion*" :mode lisp-mode - :reusep t :connection t :read-only nil) package - (slime-mode 1) - (slime-macroexpansion-minor-mode 1) - (erase-buffer) - (insert expansion) - (goto-char (point-min)) - (indent-sexp) - (font-lock-fontify-buffer)))))) + (let ((string (or string + (car (slime-sexp-at-point-for-macroexpansion))))) + (setq slime-eval-macroexpand-expression `(,expander ,string)) + (slime-eval-async slime-eval-macroexpand-expression + (slime-rcurry #'slime-show-macroexpansion + (slime-create-macroexpansion-buffer))))) + +(defun slime-show-macroexpansion (expansion buffer) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert expansion) + (goto-char (point-min)) + (indent-sexp) + (font-lock-fontify-buffer))) + +(defun slime-create-macroexpansion-buffer () + (let ((name "*SLIME Macroexpansion*")) + (slime-with-temp-buffer (name (slime-current-package)) + (lisp-mode) + (slime-mode 1) + (slime-macroexpansion-minor-mode 1) + (current-buffer)))) (defun slime-eval-macroexpand-inplace (expander) "Substitutes the current sexp at place with its macroexpansion. @@ -6466,8 +6460,9 @@ (defun slime-macroexpand-again () "Reperform the last macroexpansion." (interactive) - (slime-eval-macroexpand (first slime-eval-macroexpand-expression) - (second slime-eval-macroexpand-expression))) + (slime-eval-async slime-eval-macroexpand-expression + (slime-rcurry #'slime-show-macroexpansion + (current-buffer)))) ;;;; Subprocess control @@ -7503,8 +7498,8 @@ (defun slime-list-connections () "Display a list of all connections." (interactive) - (slime-with-output-to-temp-buffer ("*SLIME Connections*" - :mode slime-connection-list-mode) nil + (slime-with-temp-buffer ("*SLIME Connections*" nil) + (slime-connection-list-mode) (slime-draw-connection-list))) (defun slime-update-connection-list () @@ -8666,7 +8661,7 @@ (slime-check "Checking that narrowing succeeded." (slime-buffer-narrowed-p)) - (slime-with-output-to-temp-buffer (random-buffer-name) nil + (slime-with-temp-buffer (random-buffer-name nil) (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name) (equal (buffer-name (current-buffer)) random-buffer-name))) (with-current-buffer random-buffer-name From trittweiler at common-lisp.net Thu Aug 7 14:49:51 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 7 Aug 2008 10:49:51 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080807144951.D872C7A014@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv5053/contrib Modified Files: slime-mdot-fu.el ChangeLog Log Message: * slime-mdot-fu.el: Works for LET bindings now also. (def-slime-test find-local-definitions.1): New test case. --- /project/slime/cvsroot/slime/contrib/slime-mdot-fu.el 2008/07/31 08:37:22 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-mdot-fu.el 2008/08/07 14:49:51 1.2 @@ -10,7 +10,8 @@ (defvar slime-binding-ops-alist '((flet &bindings &body) (labels &bindings &body) - (macrolet &bindings &body))) + (macrolet &bindings &body) + (let &bindings &body))) (defun slime-lookup-binding-op (op) (assoc* op slime-binding-ops-alist :test 'equalp :key 'symbol-name)) @@ -75,6 +76,48 @@ (remove-hook 'slime-edit-definition-hooks 'slime-edit-local-definition)) + + +(def-slime-test find-local-definitions.1 + (buffer-sexpr definition target-regexp) + "Check that finding local definitions work." + '(((defun foo (x) + (let ((y (+ x 1))) + (- x y *HERE*))) + y + "(y (+ x 1))") + + ((defun bar (x) + (flet ((foo (z) (+ x z))) + (* x (foo *HERE*)))) + foo + "(foo (z) (+ x z))") + + ((defun quux (x) + (flet ((foo (z) (+ x z))) + (let ((foo (- 1 x))) + (+ x foo *HERE*)))) + foo + "(foo (- 1 x)") + + ((defun zurp (x) + (macrolet ((frob (x y) `(quux ,x ,y))) + (frob x *HERE*))) + frob + "(frob (x y)")) + (slime-check-top-level) + (with-temp-buffer + (let ((tmpbuf (current-buffer))) + (insert (prin1-to-string buffer-sexpr)) + (search-backward "*HERE*") + (slime-edit-local-definition (prin1-to-string definition)) + (slime-sync) + (slime-check "Check that we didnt leave the temp buffer." + (eq (current-buffer) tmpbuf)) + (slime-check "Check that we are at the local definition." + (looking-at (regexp-quote target-regexp)))))) + + (provide 'slime-mdot-fu) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/05 18:19:34 1.115 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/07 14:49:51 1.116 @@ -1,3 +1,8 @@ +2008-08-07 Tobias C. Rittweiler + + * slime-mdot-fu.el: Works for LET bindings now also. + (def-slime-test find-local-definitions.1): New test case. + 2008-08-05 Michael Weber * slime-typeout-frame.el (slime-typeout-message-aux): prevent From trittweiler at common-lisp.net Thu Aug 7 15:24:08 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 7 Aug 2008 11:24:08 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080807152408.2C7F511CF@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18320/contrib Modified Files: slime-fancy.el ChangeLog Log Message: * slime-fancy.el: Add slime-mdot-fu and slime-package-fu. --- /project/slime/cvsroot/slime/contrib/slime-fancy.el 2008/02/10 17:09:51 1.5 +++ /project/slime/cvsroot/slime/contrib/slime-fancy.el 2008/08/07 15:24:08 1.6 @@ -70,4 +70,13 @@ (require 'slime-references) (slime-references-init) +;; Makes M-. work on local definitions, too. +(require 'slime-mdot-fu) +(slime-mdot-fu-init) + +;; Add/Remove a symbol at point from the relevant DEFPACKAGE form +;; via C-c x. +(require 'slime-package-fu) +(slime-package-fu-init) + (provide 'slime-fancy) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/07 14:49:51 1.116 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/07 15:24:08 1.117 @@ -1,5 +1,9 @@ 2008-08-07 Tobias C. Rittweiler + * slime-fancy.el: Add slime-mdot-fu and slime-package-fu. + +2008-08-07 Tobias C. Rittweiler + * slime-mdot-fu.el: Works for LET bindings now also. (def-slime-test find-local-definitions.1): New test case. From trittweiler at common-lisp.net Thu Aug 7 15:54:41 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 7 Aug 2008 11:54:41 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080807155441.1158269006@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv25673 Modified Files: slime.el ChangeLog Log Message: Previously, M-p at the REPL deleted the input if no match could be found in the history. Now the input is untouched. * slime.el (slime-repl-history-replace): Ditch delete-at-end-p argument. (slime-repl-next-input, slime-repl-previous-input): Adapted. (slime-repl-forward-input, slime-repl-backward-input): Ditto. --- /project/slime/cvsroot/slime/slime.el 2008/08/07 14:10:25 1.965 +++ /project/slime/cvsroot/slime/slime.el 2008/08/07 15:54:37 1.966 @@ -3275,12 +3275,10 @@ (defvar slime-repl-history-pattern nil "The regexp most recently used for finding input history.") -(defun slime-repl-history-replace (direction &optional regexp delete-at-end-p) +(defun slime-repl-history-replace (direction &optional regexp) "Replace the current input with the next line in DIRECTION. DIRECTION is 'forward' or 'backward' (in the history list). -If REGEXP is non-nil, only lines matching REGEXP are considered. -If DELETE-AT-END-P is non-nil then remove the string if the end of the -history is reached." +If REGEXP is non-nil, only lines matching REGEXP are considered." (setq slime-repl-history-pattern regexp) (let* ((min-pos -1) (max-pos (length slime-repl-input-history)) @@ -3300,9 +3298,7 @@ (setq msg "Wrapped history"))) (when (or (<= pos min-pos) (<= max-pos pos)) (when regexp - (setq msg (concat msg "; no matching item"))) - (when delete-at-end-p - (slime-repl-replace-input ""))) + (setq msg (concat msg "; no matching item")))) ;;(message "%s [%d %d %s]" msg start-pos pos regexp) (message "%s%s" msg (cond ((not regexp) "") (t (format "; current regexp: %s" regexp)))) @@ -3335,23 +3331,23 @@ same search pattern for this command. Otherwise use the current input as search pattern." (interactive) - (slime-repl-history-replace 'backward (slime-repl-history-pattern t) t)) + (slime-repl-history-replace 'backward (slime-repl-history-pattern t))) (defun slime-repl-next-input () "Cycle forwards through input history. See `slime-repl-previous-input'." (interactive) - (slime-repl-history-replace 'forward (slime-repl-history-pattern t) t)) + (slime-repl-history-replace 'forward (slime-repl-history-pattern t))) (defun slime-repl-forward-input () "Cycle forwards through input history." (interactive) - (slime-repl-history-replace 'forward (slime-repl-history-pattern) t)) + (slime-repl-history-replace 'forward (slime-repl-history-pattern))) (defun slime-repl-backward-input () "Cycle backwards through input history." (interactive) - (slime-repl-history-replace 'backward (slime-repl-history-pattern) t)) + (slime-repl-history-replace 'backward (slime-repl-history-pattern))) (defun slime-repl-previous-matching-input (regexp) (interactive "sPrevious element matching (regexp): ") --- /project/slime/cvsroot/slime/ChangeLog 2008/08/07 14:10:25 1.1404 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/07 15:54:40 1.1405 @@ -1,3 +1,13 @@ +2008-08-07 Tobias C. Rittweiler + + Previously, M-p at the REPL deleted the input if no match could be + found in the history. Now the input is untouched. + + * slime.el (slime-repl-history-replace): Ditch delete-at-end-p + argument. + (slime-repl-next-input, slime-repl-previous-input): Adapted. + (slime-repl-forward-input, slime-repl-backward-input): Ditto. + 2008-08-07 Helmut Eller * slime.el (slime-with-temp-buffer): Renamed from From heller at common-lisp.net Thu Aug 7 17:07:23 2008 From: heller at common-lisp.net (heller) Date: Thu, 7 Aug 2008 13:07:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080807170723.1662E7E011@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17788 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-with-temp-buffer): By default, no longer inherit the current connection. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/07 15:54:40 1.1405 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/07 17:07:22 1.1406 @@ -1,3 +1,8 @@ +2008-08-07 Helmut Eller + + * slime.el (slime-with-temp-buffer): By default, no longer inherit + the current connection. + 2008-08-07 Tobias C. Rittweiler Previously, M-p at the REPL deleted the input if no match could be --- /project/slime/cvsroot/slime/slime.el 2008/08/07 15:54:37 1.966 +++ /project/slime/cvsroot/slime/slime.el 2008/08/07 17:07:22 1.967 @@ -963,8 +963,8 @@ "The emacs snapshot \"fingerprint\" after displaying the buffer.")) ;; Interface -(defmacro* slime-with-temp-buffer ((name package &key (connection t) - emacs-snapshot) +(defmacro* slime-with-temp-buffer ((name &optional package + connection emacs-snapshot) &rest body) "Similar to `with-output-to-temp-buffer'. Bind standard-output and initialize some buffer-local variables. @@ -978,7 +978,7 @@ If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous state of Emacs after closing the temporary buffer. Otherwise, the current state will be saved and later restored." - `(let* ((vars% (list ,package + `(let* ((vars% (list ,(if (eq package t) '(slime-current-package) package) ,(if (eq connection t) '(slime-connection) connection) ,(or emacs-snapshot '(slime-current-emacs-snapshot)))) (standard-output (slime-temp-buffer ,name vars%))) @@ -3615,7 +3615,7 @@ (defun slime-list-repl-short-cuts () (interactive) - (slime-with-temp-buffer ("*slime-repl-help*" nil) + (slime-with-temp-buffer ("*slime-repl-help*") (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string< :key (lambda (x) (car (slime-repl-shortcut.names x)))))) @@ -4121,8 +4121,7 @@ "Show the compiler notes NOTES in tree view." (interactive (list (slime-compiler-notes))) (with-temp-message "Preparing compiler note tree..." - (slime-with-temp-buffer ("*SLIME Compiler-Notes*" nil - :emacs-snapshot emacs-snapshot) + (slime-with-temp-buffer ("*SLIME Compiler-Notes*" nil nil emacs-snapshot) (erase-buffer) (slime-compiler-notes-mode) (when (null notes) @@ -5529,7 +5528,7 @@ (defun slime-edit-value-callback (form-string current-value package) (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))) - (with-current-buffer (slime-with-temp-buffer (name package) + (with-current-buffer (slime-with-temp-buffer (name package t) (current-buffer)) (lisp-mode) (slime-mode 1) @@ -5931,7 +5930,7 @@ (defun slime-show-apropos (plists string package summary) (if (null plists) (message "No apropos matches for %S" string) - (slime-with-temp-buffer ("*SLIME Apropos*" package) + (slime-with-temp-buffer ("*SLIME Apropos*" package t) (apropos-mode) (if (boundp 'header-line-format) (setq header-line-format summary) @@ -6388,7 +6387,7 @@ (defun slime-create-macroexpansion-buffer () (let ((name "*SLIME Macroexpansion*")) - (slime-with-temp-buffer (name (slime-current-package)) + (slime-with-temp-buffer (name t t) (lisp-mode) (slime-mode 1) (slime-macroexpansion-minor-mode 1) @@ -7494,7 +7493,7 @@ (defun slime-list-connections () "Display a list of all connections." (interactive) - (slime-with-temp-buffer ("*SLIME Connections*" nil) + (slime-with-temp-buffer ("*SLIME Connections*") (slime-connection-list-mode) (slime-draw-connection-list))) @@ -8657,7 +8656,7 @@ (slime-check "Checking that narrowing succeeded." (slime-buffer-narrowed-p)) - (slime-with-temp-buffer (random-buffer-name nil) + (slime-with-temp-buffer (random-buffer-name) (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name) (equal (buffer-name (current-buffer)) random-buffer-name))) (with-current-buffer random-buffer-name From trittweiler at common-lisp.net Fri Aug 8 08:59:34 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 04:59:34 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808085934.1C70A6D239@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv19862 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-create-macroexpansion-buffer): Make fontifying case insensitive as the result from macroexpansion is most likely printed all upper-case. --- /project/slime/cvsroot/slime/slime.el 2008/08/07 17:07:22 1.967 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 08:59:22 1.968 @@ -6391,6 +6391,7 @@ (lisp-mode) (slime-mode 1) (slime-macroexpansion-minor-mode 1) + (setq font-lock-keywords-case-fold-search t) (current-buffer)))) (defun slime-eval-macroexpand-inplace (expander) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/07 17:07:22 1.1406 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 08:59:25 1.1407 @@ -1,3 +1,9 @@ +2008-08-08 Tobias C. Rittweiler + + * slime.el (slime-create-macroexpansion-buffer): Make fontifying + case insensitive as the result from macroexpansion is most likely + printed all upper-case. + 2008-08-07 Helmut Eller * slime.el (slime-with-temp-buffer): By default, no longer inherit From heller at common-lisp.net Fri Aug 8 09:34:42 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 05:34:42 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808093442.E23882F00A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv27389 Modified Files: ChangeLog slime.el Log Message: * slime.el (test disconnect): Call slime-inferior-process with explicit connection argument to avoid clashes with buffer-local connections. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 08:59:25 1.1407 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 09:34:41 1.1408 @@ -1,3 +1,9 @@ +2008-08-08 Helmut Eller + + * slime.el (test disconnect): Call slime-inferior-process + with explicit connection argument to avoid clashes with + buffer-local connections. + 2008-08-08 Tobias C. Rittweiler * slime.el (slime-create-macroexpansion-buffer): Make fontifying --- /project/slime/cvsroot/slime/slime.el 2008/08/08 08:59:22 1.968 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 09:34:41 1.969 @@ -991,7 +991,7 @@ (put 'slime-with-temp-buffer 'lisp-indent-function 1) (defun slime-temp-buffer (name buffer-vars) - "Return a temporary buffer called NAME in MODE. + "Return a temporary buffer called NAME. The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing `q' in the buffer will restore the window configuration to the way it is when the buffer was created, i.e. when this @@ -1021,8 +1021,9 @@ ;; Interface (defun slime-temp-buffer-quit (&optional kill-buffer-p) - "Get rid of the current (temp) buffer without asking. Restore the -window configuration unless it was changed since we last activated the buffer." + "Get rid of the current (temp) buffer without asking. +Restore the window configuration unless it was changed since we +last activated the buffer." (interactive) (let ((snapshot slime-temp-buffer-saved-emacs-snapshot) (temp-buffer (current-buffer))) @@ -9305,7 +9306,8 @@ (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)))) + (slime-test-expect "We are connected again" p + (slime-inferior-process slime-default-connection)))) ;;;; Utilities From heller at common-lisp.net Fri Aug 8 11:36:13 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 07:36:13 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808113613.5A0E916219@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22154 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 09:34:41 1.1408 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 11:36:12 1.1409 @@ -28,7 +28,7 @@ 2008-08-07 Helmut Eller * slime.el (slime-with-temp-buffer): Renamed from - slime-with-output-to-temp-buffer. Initialize the buffer local + slime-with-output-to-temp-buffer. Initialize the buffer local buffer variables before and after running BODY, so that we don't need the mode argument. From heller at common-lisp.net Fri Aug 8 11:37:19 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 07:37:19 -0400 (EDT) Subject: [slime-cvs] CVS CVSROOT Message-ID: <20080808113719.ECC0338067@common-lisp.net> Update of /project/slime/cvsroot/CVSROOT In directory clnet:/tmp/cvs-serv22240 Modified Files: loginfo Log Message: *** empty log message *** --- /project/slime/cvsroot/CVSROOT/loginfo 2006/02/10 17:22:14 1.5 +++ /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 11:37:19 1.6 @@ -7,7 +7,7 @@ # If the repository name does not match any of the regular expressions in this # file, the "DEFAULT" line is used, if it is specified. # -# If the name ALL appears as a regular expression it is always used +u# If the name ALL appears as a regular expression it is always used # in addition to the first matching regex or DEFAULT. # # You may specify a format string as part of the @@ -28,4 +28,5 @@ #DEFAULT /custom/bin/cvslog.py slime-cvs at common-lisp.net %{sVv} #DEFAULT /project/slime/bin/cvslog.sh slime-cvs at common-lisp.net slime-devel at common-lisp.net -DEFAULT cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} +DEFAULT cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} +ALL PATH=$PATH:/home/heller/bin/ hg convert --datesort ~heller/slime-cvs ~heller/slime-hg From heller at common-lisp.net Fri Aug 8 11:38:22 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 07:38:22 -0400 (EDT) Subject: [slime-cvs] CVS CVSROOT Message-ID: <20080808113822.AE99E6D239@common-lisp.net> Update of /project/slime/cvsroot/CVSROOT In directory clnet:/tmp/cvs-serv22338 Modified Files: loginfo Log Message: Convert CVS to hg on commit. --- /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 11:37:19 1.6 +++ /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 11:38:22 1.7 @@ -7,7 +7,7 @@ # If the repository name does not match any of the regular expressions in this # file, the "DEFAULT" line is used, if it is specified. # -u# If the name ALL appears as a regular expression it is always used +# If the name ALL appears as a regular expression it is always used # in addition to the first matching regex or DEFAULT. # # You may specify a format string as part of the @@ -28,5 +28,5 @@ #DEFAULT /custom/bin/cvslog.py slime-cvs at common-lisp.net %{sVv} #DEFAULT /project/slime/bin/cvslog.sh slime-cvs at common-lisp.net slime-devel at common-lisp.net -DEFAULT cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} +DEFAULT cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} ALL PATH=$PATH:/home/heller/bin/ hg convert --datesort ~heller/slime-cvs ~heller/slime-hg From heller at common-lisp.net Fri Aug 8 11:43:16 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 07:43:16 -0400 (EDT) Subject: [slime-cvs] CVS CVSROOT Message-ID: <20080808114316.B7AB039622@common-lisp.net> Update of /project/slime/cvsroot/CVSROOT In directory clnet:/tmp/cvs-serv25101 Modified Files: loginfo Log Message: That didn't work. Try a script. --- /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 11:38:22 1.7 +++ /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 11:43:16 1.8 @@ -29,4 +29,4 @@ #DEFAULT /project/slime/bin/cvslog.sh slime-cvs at common-lisp.net slime-devel at common-lisp.net DEFAULT cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} -ALL PATH=$PATH:/home/heller/bin/ hg convert --datesort ~heller/slime-cvs ~heller/slime-hg +ALL /home/heller/bin/convert-to-hg.sh From heller at common-lisp.net Fri Aug 8 11:44:16 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 07:44:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808114416.E66804204D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv25266 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 11:36:12 1.1409 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 11:44:14 1.1410 @@ -28,7 +28,7 @@ 2008-08-07 Helmut Eller * slime.el (slime-with-temp-buffer): Renamed from - slime-with-output-to-temp-buffer. Initialize the buffer local + slime-with-output-to-temp-buffer. Initialize the buffer local buffer variables before and after running BODY, so that we don't need the mode argument. From heller at common-lisp.net Fri Aug 8 13:43:41 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 09:43:41 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808134341.A92993C206@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv26769 Modified Files: ChangeLog swank-abcl.lisp swank-allegro.lisp swank-backend.lisp swank-ecl.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp swank-scl.lisp swank.lisp Log Message: Spawn the auto-flush thread in the front end. This removes some copy&paste code in various backends. * swank.lisp (auto-flush-loop): New function. (open-streams): Use it. * swank-backend.lisp (make-stream-interactive): Deleted. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 11:44:14 1.1410 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 13:43:33 1.1411 @@ -1,5 +1,14 @@ 2008-08-08 Helmut Eller + Spawn the auto-flush thread in the front end. + This removes some copy&paste code in various backends. + + * swank.lisp (auto-flush-loop): New function. + (open-streams): Use it. + * swank-backend.lisp (make-stream-interactive): Deleted. + +2008-08-08 Helmut Eller + * slime.el (test disconnect): Call slime-inferior-process with explicit connection argument to avoid clashes with buffer-local connections. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/04/17 14:56:43 1.49 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/08 13:43:33 1.50 @@ -524,30 +524,6 @@ (defimplementation receive () (ext:mailbox-read (mailbox (ext:current-thread)))) -;;; Auto-flush streams - -;; XXX race conditions -(defvar *auto-flush-streams* '()) - -(defvar *auto-flush-thread* nil) - -(defimplementation make-stream-interactive (stream) - (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*)) - (unless *auto-flush-thread* - (setq *auto-flush-thread* - (ext:make-thread #'flush-streams - :name "auto-flush-thread")))) - -(defun flush-streams () - (loop - (setq *auto-flush-streams* - (remove-if (lambda (x) - (not (and (open-stream-p x) - (output-stream-p x)))) - *auto-flush-streams*)) - (mapc #'finish-output *auto-flush-streams*) - (sleep 0.15))) - (defimplementation quit-lisp () (ext:exit)) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/07 08:10:01 1.108 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/08 13:43:33 1.109 @@ -124,9 +124,6 @@ (:class (describe (find-class symbol))))) -(defimplementation make-stream-interactive (stream) - (setf (interactive-stream-p stream) t)) - ;;;; Debugger (defvar *sldb-topframe*) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/06 19:51:29 1.140 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/08 13:43:33 1.141 @@ -453,15 +453,6 @@ The streams are returned as two values.") -(definterface make-stream-interactive (stream) - "Do any necessary setup to make STREAM work interactively. -This is called for each stream used for interaction with the user -\(e.g. *standard-output*). An implementation could setup some -implementation-specific functions to control output flushing at the -like." - (declare (ignore stream)) - nil) - ;;;; Documentation --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/05 17:38:44 1.24 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/08 13:43:33 1.25 @@ -537,40 +537,8 @@ ;interrupt-process will halt this if it takes longer than 1sec (sleep 1))))) - ;; Auto-flush streams - (defvar *auto-flush-interval* 0.15 - "How often to flush interactive streams. This valu is passed - directly to cl:sleep.") - - (defvar *auto-flush-lock* (make-lock :name "auto flush")) - - (defvar *auto-flush-thread* nil) - - (defvar *auto-flush-streams* '()) - - (defimplementation make-stream-interactive (stream) - (mp:with-lock (*auto-flush-lock*) - (pushnew stream *auto-flush-streams*) - (unless *auto-flush-thread* - (setq *auto-flush-thread* - (spawn #'flush-streams - :name "auto-flush-thread"))))) - (defmethod stream-finish-output ((stream stream)) (finish-output stream)) - (defun flush-streams () - (loop - (mp:with-lock (*auto-flush-lock*) - (setq *auto-flush-streams* - (remove-if (lambda (x) - (not (and (open-stream-p x) - (output-stream-p x)))) - *auto-flush-streams*)) - (dolist (i *auto-flush-streams*) - (ignore-errors (stream-finish-output i)) - (ignore-errors (finish-output i)))) - (sleep *auto-flush-interval*))) - ) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/07 07:53:47 1.107 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/08 13:43:33 1.108 @@ -787,29 +787,6 @@ (defmethod env-internals:environment-display-debugger (env) *debug-io*))) -(defvar *auto-flush-interval* 0.15) -(defvar *auto-flush-lock* (mp:make-lock :name "auto-flush-lock")) -(defvar *auto-flush-thread* nil) -(defvar *auto-flush-streams* '()) - -(defimplementation make-stream-interactive (stream) - (mp:with-lock (*auto-flush-lock*) - (pushnew stream *auto-flush-streams*) - (unless *auto-flush-thread* - (setq *auto-flush-thread* - (mp:process-run-function "auto-flush-thread [SWANK]" () - #'flush-streams))))) - -(defun flush-streams () - (loop - (mp:with-lock (*auto-flush-lock*) - (setq *auto-flush-streams* - (remove-if (lambda (x) - (not (and (open-stream-p x) - (output-stream-p x)))) - *auto-flush-streams*)) - (mapc #'finish-output *auto-flush-streams*)) - (sleep *auto-flush-interval*))) (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) (apply (swank-sym :y-or-n-p-in-emacs) msg args)) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/06 19:51:29 1.130 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/08 13:43:33 1.131 @@ -193,11 +193,6 @@ (defimplementation emacs-connected () (setq ccl::*interactive-abort-process* ccl::*current-process*)) -(defimplementation make-stream-interactive (stream) - (typecase stream - (ccl:fundamental-output-stream - (push stream ccl::*auto-flush-streams*)))) - ;;; Unix signals (defimplementation call-without-interrupts (fn) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/06 21:50:37 1.209 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/08 13:43:33 1.210 @@ -1319,37 +1319,6 @@ mutex)) (sb-ext:timeout ())))))) - ;; Auto-flush streams - - (defvar *auto-flush-interval* 0.15 - "How often to flush interactive streams. This value is passed - directly to cl:sleep.") - - (defvar *auto-flush-lock* (sb-thread:make-mutex :name "auto flush")) - - (defvar *auto-flush-thread* nil) - - (defvar *auto-flush-streams* '()) - - (defimplementation make-stream-interactive (stream) - (sb-thread:with-mutex (*auto-flush-lock*) - (pushnew stream *auto-flush-streams*) - (unless *auto-flush-thread* - (setq *auto-flush-thread* - (sb-thread:make-thread #'flush-streams - :name "auto-flush-thread"))))) - - (defun flush-streams () - (loop - (sb-thread:with-mutex (*auto-flush-lock*) - (setq *auto-flush-streams* - (remove-if (lambda (x) - (not (and (open-stream-p x) - (output-stream-p x)))) - *auto-flush-streams*)) - (mapc #'finish-output *auto-flush-streams*)) - (sleep *auto-flush-interval*))) - ) (defimplementation quit-lisp () --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/07 07:53:47 1.21 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/08 13:43:33 1.22 @@ -349,11 +349,6 @@ (input (make-slime-input-stream input-fn output))) (values input output))) -(defimplementation make-stream-interactive (stream) - (when (or (typep stream 'slime-input-stream) - (typep stream 'slime-output-stream)) - (setf (slot-value stream 'interactive) t))) - ;;;; Compilation Commands --- /project/slime/cvsroot/slime/swank.lisp 2008/08/06 19:51:29 1.553 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/08 13:43:33 1.554 @@ -725,7 +725,9 @@ (io (make-two-way-stream in out)) (repl-results (make-output-stream-for-target connection :repl-result))) - (mapc #'make-stream-interactive (list in out io)) + (when (eq (connection.communication-style connection) :spawn) + (spawn (lambda () (auto-flush-loop out)) + :name "auto-flush-thread")) (values dedicated-output in out io repl-results))))) ;; FIXME: if wait-for-event aborts the event will stay in the queue forever. @@ -916,6 +918,16 @@ (setf (connection.repl-thread connection) (spawn-repl-thread connection "new-repl-thread")))))) +(defvar *auto-flush-interval* 0.2) + +(defun auto-flush-loop (stream) + (loop + (when (not (and (open-stream-p stream) + (output-stream-p stream))) + (return nil)) + (finish-output stream) + (sleep *auto-flush-interval*))) + (defun find-worker-thread (id) (etypecase id ((member t) From trittweiler at common-lisp.net Fri Aug 8 14:08:15 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 10:08:15 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808140815.7CF1116219@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv764 Modified Files: slime.el ChangeLog Log Message: * slime.el: Make the threads browser use `slime-with-temp-buffer'. (slime-temp-buffer-quit-function): New buffer-local variable. Defaults to `slime-temp-buffer-quit'. (slime-temp-buffer-mode): `q' invokes above variable now. (slime-threads-buffer-name): New variable. (slime-list-threads): Use slime-with-temp-buffer. (slime-update-threads-buffer): New. Lifted from slime-list-threads. (slime-thread-quit): Renamed to slime-quit-threads-buffer. --- /project/slime/cvsroot/slime/slime.el 2008/08/08 09:34:41 1.969 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 14:08:13 1.970 @@ -1015,10 +1015,19 @@ "Mode for displaying read only stuff" nil (" Slime-Tmp" slime-modeline-string) - '(("q" . slime-temp-buffer-quit) + '(("q" . slime-temp-buffer-quit-function) ("\C-c\C-z" . slime-switch-to-output-buffer) ("\M-." . slime-edit-definition))) +(make-variable-buffer-local + (defvar slime-temp-buffer-quit-function 'slime-temp-buffer-quit + "The function that is used to quit a temporary popup buffer.")) + +(defun slime-temp-buffer-quit-function (&optional kill-buffer-p) + "Wrapper to invoke the value of `slime-temp-buffer-quit-function'." + (interactive) + (funcall slime-temp-buffer-quit-function kill-buffer-p)) + ;; Interface (defun slime-temp-buffer-quit (&optional kill-buffer-p) "Get rid of the current (temp) buffer without asking. @@ -7377,20 +7386,31 @@ ;;;; Thread control panel +(defvar slime-threads-buffer-name "*SLIME Threads*") + (defun slime-list-threads () "Display a list of threads." (interactive) - (let ((threads (slime-eval '(swank:list-threads)))) - (with-current-buffer (get-buffer-create "*slime-threads*") + (let ((name slime-threads-buffer-name)) + (slime-with-temp-buffer (name nil t) (slime-thread-control-mode) + (setq slime-temp-buffer-quit-function 'slime-quit-threads-buffer) + (slime-update-threads-buffer)))) + +(defun slime-quit-threads-buffer (&optional _) + (slime-eval-async `(swank:quit-thread-browser)) + (slime-temp-buffer-quit t)) + +(defun slime-update-threads-buffer () + (interactive) + (let ((threads (slime-eval '(swank:list-threads)))) + (with-current-buffer slime-threads-buffer-name (let ((inhibit-read-only t)) (erase-buffer) (loop for idx from 0 for (id name status desc) in threads do (slime-thread-insert idx name status desc id)) - (goto-char (point-min)) - (setq buffer-read-only t) - (pop-to-buffer (current-buffer)))))) + (goto-char (point-min)))))) (defun slime-thread-insert (idx name status summary id) (slime-propertize-region `(thread-id ,idx) @@ -7407,24 +7427,20 @@ ;;;;; Major mode (define-derived-mode slime-thread-control-mode fundamental-mode - "Slime-Threads" + "Threads" "SLIME Thread Control Panel Mode. -\\{slime-thread-control-mode-map}" +\\{slime-thread-control-mode-map} +\\{slime-temp-buffer-mode-map}" (when slime-truncate-lines (set (make-local-variable 'truncate-lines) t))) (slime-define-keys slime-thread-control-mode-map ("a" 'slime-thread-attach) ("d" 'slime-thread-debug) - ("g" 'slime-list-threads) - ("k" 'slime-thread-kill) - ("q" 'slime-thread-quit)) + ("g" 'slime-update-threads-buffer) + ("k" 'slime-thread-kill)) -(defun slime-thread-quit () - (interactive) - (slime-eval-async `(swank:quit-thread-browser)) - (kill-buffer (current-buffer))) (defun slime-thread-kill () (interactive) @@ -7988,7 +8004,7 @@ (def-slime-selector-method ?t "SLIME threads buffer." (slime-list-threads) - "*slime-threads*") + slime-threads-buffer-name) (defun slime-recently-visited-buffer (mode) "Return the most recently visited buffer whose major-mode is MODE. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 13:43:33 1.1411 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 14:08:14 1.1412 @@ -1,3 +1,17 @@ +2008-08-08 Tobias C. Rittweiler + + * slime.el: Make the threads browser use `slime-with-temp-buffer'. + + (slime-temp-buffer-quit-function): New buffer-local + variable. Defaults to `slime-temp-buffer-quit'. + (slime-temp-buffer-mode): `q' invokes above variable now. + + (slime-threads-buffer-name): New variable. + (slime-list-threads): Use slime-with-temp-buffer. + (slime-update-threads-buffer): New. Lifted from + slime-list-threads. + (slime-thread-quit): Renamed to slime-quit-threads-buffer. + 2008-08-08 Helmut Eller Spawn the auto-flush thread in the front end. From heller at common-lisp.net Fri Aug 8 15:01:07 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 11:01:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808150107.7CE3B5204F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/home/heller/slime-cvs Modified Files: test.sh Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/test.sh 2008/03/04 15:48:40 1.10 +++ /project/slime/cvsroot/slime/test.sh 2008/08/08 15:01:05 1.11 @@ -2,6 +2,7 @@ # Run the SLIME test suite inside screen, saving the results to a file. + # This script's exit status is the number of tests failed. If no tests # fail then no output is printed. If at least one test fails then a # one-line summary is printed. From heller at common-lisp.net Fri Aug 8 15:01:23 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 11:01:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808150123.C8EA716@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/home/heller/slime-cvs Modified Files: test.sh Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/test.sh 2008/08/08 15:01:05 1.11 +++ /project/slime/cvsroot/slime/test.sh 2008/08/08 15:01:23 1.12 @@ -2,7 +2,6 @@ # Run the SLIME test suite inside screen, saving the results to a file. - # This script's exit status is the number of tests failed. If no tests # fail then no output is printed. If at least one test fails then a # one-line summary is printed. From heller at common-lisp.net Fri Aug 8 15:02:04 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 11:02:04 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808150204.BCDE47A000@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/home/heller/slime-cvs Modified Files: test.sh Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/test.sh 2008/08/08 15:01:23 1.12 +++ /project/slime/cvsroot/slime/test.sh 2008/08/08 15:02:04 1.13 @@ -2,6 +2,7 @@ # Run the SLIME test suite inside screen, saving the results to a file. + # This script's exit status is the number of tests failed. If no tests # fail then no output is printed. If at least one test fails then a # one-line summary is printed. From trittweiler at common-lisp.net Fri Aug 8 16:13:54 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 12:13:54 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808161354.E43813C206@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv1382 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-compiler-notes-mode, slime-connection-ist-mode): Add slime-temp-buffer-mode-map to docstring. --- /project/slime/cvsroot/slime/slime.el 2008/08/08 14:12:35 1.971 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 16:13:53 1.972 @@ -4204,7 +4204,9 @@ (define-derived-mode slime-compiler-notes-mode fundamental-mode "Compiler-Notes" "\\\ -\\{slime-compiler-notes-mode-map}" +\\{slime-compiler-notes-mode-map} +\\{slime-temp-buffer-mode-map} +" (slime-set-truncate-lines)) (slime-define-keys slime-compiler-notes-mode-map @@ -7467,7 +7469,8 @@ "Slime-Connections" "SLIME Connection List Mode. -\\{slime-connection-list-mode-map}" +\\{slime-connection-list-mode-map} +\\{slime-temp-buffer-mode-map}" (when slime-truncate-lines (set (make-local-variable 'truncate-lines) t))) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 14:12:35 1.1413 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 16:13:54 1.1414 @@ -1,5 +1,10 @@ 2008-08-08 Tobias C. Rittweiler + * slime.el (slime-compiler-notes-mode, slime-connection-ist-mode): + Add slime-temp-buffer-mode-map to docstring. + +2008-08-08 Tobias C. Rittweiler + * slime.el (slime-connections-buffer-name): New variable. (slime-list-connections): Use it. (def-slime-selector ?c): Ditto From trittweiler at common-lisp.net Fri Aug 8 17:09:07 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 13:09:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808170907.E1FF01603B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18539 Modified Files: slime.el ChangeLog Log Message: * slime.el: Rename slime's temp-buffer to popup-buffer. (defun slime-update-modeline () --- /project/slime/cvsroot/slime/slime.el 2008/08/08 16:13:53 1.972 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 17:09:07 1.973 @@ -500,7 +500,7 @@ (defun slime-shall-we-update-modeline-p () (and slime-extended-modeline - (or slime-mode slime-temp-buffer-mode))) + (or slime-mode slime-popup-buffer-mode))) (defun slime-update-modeline () (when (slime-shall-we-update-modeline-p) @@ -953,21 +953,22 @@ ;;;;; Temporary popup buffers (make-variable-buffer-local - (defvar slime-temp-buffer-saved-emacs-snapshot nil - "The snapshot of the current state in Emacs before the temp-buffer + (defvar slime-popup-buffer-saved-emacs-snapshot nil + "The snapshot of the current state in Emacs before the popup-buffer was displayed, so that this state can be restored later on. -Buffer local in temp-buffers.")) +Buffer local in popup-buffers.")) (make-variable-buffer-local - (defvar slime-temp-buffer-saved-fingerprint nil + (defvar slime-popup-buffer-saved-fingerprint nil "The emacs snapshot \"fingerprint\" after displaying the buffer.")) ;; Interface -(defmacro* slime-with-temp-buffer ((name &optional package - connection emacs-snapshot) - &rest body) +(defmacro* slime-with-popup-buffer ((name &optional package + connection emacs-snapshot) + &rest body) "Similar to `with-output-to-temp-buffer'. Bind standard-output and initialize some buffer-local variables. +Restore window configuration when closed. NAME is the name of the buffer to be created. PACKAGE is the value `slime-buffer-package'. @@ -981,18 +982,18 @@ `(let* ((vars% (list ,(if (eq package t) '(slime-current-package) package) ,(if (eq connection t) '(slime-connection) connection) ,(or emacs-snapshot '(slime-current-emacs-snapshot)))) - (standard-output (slime-temp-buffer ,name vars%))) + (standard-output (slime-popup-buffer ,name vars%))) (with-current-buffer standard-output (prog1 (progn , at body) (assert (eq (current-buffer) standard-output)) (setq buffer-read-only t) - (slime-init-temp-buffer vars%))))) + (slime-init-popup-buffer vars%))))) -(put 'slime-with-temp-buffer 'lisp-indent-function 1) +(put 'slime-with-popup-buffer 'lisp-indent-function 1) -(defun slime-temp-buffer (name buffer-vars) +(defun slime-popup-buffer (name buffer-vars) "Return a temporary buffer called NAME. -The buffer also uses the minor-mode `slime-temp-buffer-mode'. +The buffer also uses the minor-mode `slime-popup-buffer-mode'. Pressing `q' in the buffer will restore the window configuration to the way it is when the buffer was created, i.e. when this function was called." @@ -1000,49 +1001,49 @@ (with-current-buffer (get-buffer-create name) (set-syntax-table lisp-mode-syntax-table) (prog1 (pop-to-buffer (current-buffer)) - (slime-init-temp-buffer buffer-vars)))) + (slime-init-popup-buffer buffer-vars)))) -(defun slime-init-temp-buffer (buffer-vars) - (slime-temp-buffer-mode 1) - (setq slime-temp-buffer-saved-fingerprint +(defun slime-init-popup-buffer (buffer-vars) + (slime-popup-buffer-mode 1) + (setq slime-popup-buffer-saved-fingerprint (slime-current-emacs-snapshot-fingerprint)) (multiple-value-setq (slime-buffer-package slime-buffer-connection - slime-temp-buffer-saved-emacs-snapshot) + slime-popup-buffer-saved-emacs-snapshot) buffer-vars)) -(define-minor-mode slime-temp-buffer-mode +(define-minor-mode slime-popup-buffer-mode "Mode for displaying read only stuff" nil (" Slime-Tmp" slime-modeline-string) - '(("q" . slime-temp-buffer-quit-function) + '(("q" . slime-popup-buffer-quit-function) ("\C-c\C-z" . slime-switch-to-output-buffer) ("\M-." . slime-edit-definition))) (make-variable-buffer-local - (defvar slime-temp-buffer-quit-function 'slime-temp-buffer-quit + (defvar slime-popup-buffer-quit-function 'slime-popup-buffer-quit "The function that is used to quit a temporary popup buffer.")) -(defun slime-temp-buffer-quit-function (&optional kill-buffer-p) - "Wrapper to invoke the value of `slime-temp-buffer-quit-function'." +(defun slime-popup-buffer-quit-function (&optional kill-buffer-p) + "Wrapper to invoke the value of `slime-popup-buffer-quit-function'." (interactive) - (funcall slime-temp-buffer-quit-function kill-buffer-p)) + (funcall slime-popup-buffer-quit-function kill-buffer-p)) ;; Interface -(defun slime-temp-buffer-quit (&optional kill-buffer-p) +(defun slime-popup-buffer-quit (&optional kill-buffer-p) "Get rid of the current (temp) buffer without asking. Restore the window configuration unless it was changed since we last activated the buffer." (interactive) - (let ((snapshot slime-temp-buffer-saved-emacs-snapshot) - (temp-buffer (current-buffer))) - (setq slime-temp-buffer-saved-emacs-snapshot nil) + (let ((snapshot slime-popup-buffer-saved-emacs-snapshot) + (popup-buffer (current-buffer))) + (setq slime-popup-buffer-saved-emacs-snapshot nil) (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) - slime-temp-buffer-saved-fingerprint)) + slime-popup-buffer-saved-fingerprint)) (slime-set-emacs-snapshot snapshot) (bury-buffer)) (when kill-buffer-p - (kill-buffer temp-buffer)))) + (kill-buffer popup-buffer)))) ;;;;; Filename translation ;;; @@ -3625,7 +3626,7 @@ (defun slime-list-repl-short-cuts () (interactive) - (slime-with-temp-buffer ("*slime-repl-help*") + (slime-with-popup-buffer ("*slime-repl-help*") (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string< :key (lambda (x) (car (slime-repl-shortcut.names x)))))) @@ -4131,7 +4132,7 @@ "Show the compiler notes NOTES in tree view." (interactive (list (slime-compiler-notes))) (with-temp-message "Preparing compiler note tree..." - (slime-with-temp-buffer ("*SLIME Compiler-Notes*" nil nil emacs-snapshot) + (slime-with-popup-buffer ("*SLIME Compiler-Notes*" nil nil emacs-snapshot) (erase-buffer) (slime-compiler-notes-mode) (when (null notes) @@ -4205,7 +4206,7 @@ "Compiler-Notes" "\\\ \\{slime-compiler-notes-mode-map} -\\{slime-temp-buffer-mode-map} +\\{slime-popup-buffer-mode-map} " (slime-set-truncate-lines)) @@ -5395,7 +5396,7 @@ (slime-current-package)))) (defun slime-show-description (string package) - (slime-with-temp-buffer ("*SLIME Description*" package) + (slime-with-popup-buffer ("*SLIME Description*" package) (princ string) (goto-char (point-min)))) @@ -5540,11 +5541,11 @@ (defun slime-edit-value-callback (form-string current-value package) (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))) - (with-current-buffer (slime-with-temp-buffer (name package t) + (with-current-buffer (slime-with-popup-buffer (name package t) (current-buffer)) (lisp-mode) (slime-mode 1) - (slime-temp-buffer-mode -1) ; don't want binding of 'q' + (slime-popup-buffer-mode -1) ; don't want binding of 'q' (slime-edit-value-mode 1) (setq buffer-read-only nil) (setq slime-edit-form-string form-string) @@ -5562,7 +5563,7 @@ ,value) (lambda (_) (with-current-buffer buffer - (slime-temp-buffer-quit t)))))))) + (slime-popup-buffer-quit t)))))))) ;;;; Tracing @@ -5942,7 +5943,7 @@ (defun slime-show-apropos (plists string package summary) (if (null plists) (message "No apropos matches for %S" string) - (slime-with-temp-buffer ("*SLIME Apropos*" package t) + (slime-with-popup-buffer ("*SLIME Apropos*" package t) (apropos-mode) (if (boundp 'header-line-format) (setq header-line-format summary) @@ -6399,7 +6400,7 @@ (defun slime-create-macroexpansion-buffer () (let ((name "*SLIME Macroexpansion*")) - (slime-with-temp-buffer (name t t) + (slime-with-popup-buffer (name t t) (lisp-mode) (slime-mode 1) (slime-macroexpansion-minor-mode 1) @@ -7394,14 +7395,14 @@ "Display a list of threads." (interactive) (let ((name slime-threads-buffer-name)) - (slime-with-temp-buffer (name nil t) + (slime-with-popup-buffer (name nil t) (slime-thread-control-mode) - (setq slime-temp-buffer-quit-function 'slime-quit-threads-buffer) + (setq slime-popup-buffer-quit-function 'slime-quit-threads-buffer) (slime-update-threads-buffer)))) (defun slime-quit-threads-buffer (&optional _) (slime-eval-async `(swank:quit-thread-browser)) - (slime-temp-buffer-quit t)) + (slime-popup-buffer-quit t)) (defun slime-update-threads-buffer () (interactive) @@ -7433,7 +7434,7 @@ "SLIME Thread Control Panel Mode. \\{slime-thread-control-mode-map} -\\{slime-temp-buffer-mode-map}" +\\{slime-popup-buffer-mode-map}" (when slime-truncate-lines (set (make-local-variable 'truncate-lines) t))) @@ -7470,7 +7471,7 @@ "SLIME Connection List Mode. \\{slime-connection-list-mode-map} -\\{slime-temp-buffer-mode-map}" +\\{slime-popup-buffer-mode-map}" (when slime-truncate-lines (set (make-local-variable 'truncate-lines) t))) @@ -7516,7 +7517,7 @@ (defun slime-list-connections () "Display a list of all connections." (interactive) - (slime-with-temp-buffer (slime-connections-buffer-name) + (slime-with-popup-buffer (slime-connections-buffer-name) (slime-connection-list-mode) (slime-draw-connection-list))) @@ -8679,13 +8680,13 @@ (slime-check "Checking that narrowing succeeded." (slime-buffer-narrowed-p)) - (slime-with-temp-buffer (random-buffer-name) + (slime-with-popup-buffer (random-buffer-name) (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name) (equal (buffer-name (current-buffer)) random-buffer-name))) (with-current-buffer random-buffer-name ;; Notice that we cannot quit the buffer within the the extent ;; of slime-with-output-to-temp-buffer. - (slime-temp-buffer-quit t)) + (slime-popup-buffer-quit t)) (slime-check ("Checking that we've got back from `%s'" random-buffer-name) (and (eq (current-buffer) tmpbuffer) (= (point) defun-pos))) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 16:13:54 1.1414 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 17:09:07 1.1415 @@ -1,5 +1,9 @@ 2008-08-08 Tobias C. Rittweiler + * slime.el: Rename slime's temp-buffer to popup-buffer. + +2008-08-08 Tobias C. Rittweiler + * slime.el (slime-compiler-notes-mode, slime-connection-ist-mode): Add slime-temp-buffer-mode-map to docstring. From heller at common-lisp.net Fri Aug 8 18:20:54 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 14:20:54 -0400 (EDT) Subject: [slime-cvs] CVS CVSROOT Message-ID: <20080808182054.A94567C059@common-lisp.net> Update of /project/slime/cvsroot/CVSROOT In directory clnet:/tmp/cvs-serv7204 Modified Files: loginfo Log Message: *** empty log message *** --- /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 11:43:16 1.8 +++ /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 18:20:46 1.9 @@ -29,4 +29,4 @@ #DEFAULT /project/slime/bin/cvslog.sh slime-cvs at common-lisp.net slime-devel at common-lisp.net DEFAULT cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} -ALL /home/heller/bin/convert-to-hg.sh +#ALL /home/heller/bin/convert-to-hg.sh From trittweiler at common-lisp.net Fri Aug 8 19:25:07 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 15:25:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808192507.86FFF3700D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv26121 Modified Files: slime.el Log Message: * slime.el: Make xref buffers use `slime-with-popup-buffer', nee `slime-with-temp-buffer'. (slime-with-xref-buffer): Rewritten using a popup buffer. (slime-init-xref-buffer): Removed. (slime-display-xref-buffer): Removed. --- /project/slime/cvsroot/slime/slime.el 2008/08/08 17:09:07 1.973 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 19:25:07 1.974 @@ -965,7 +965,7 @@ ;; Interface (defmacro* slime-with-popup-buffer ((name &optional package connection emacs-snapshot) - &rest body) + &body body) "Similar to `with-output-to-temp-buffer'. Bind standard-output and initialize some buffer-local variables. Restore window configuration when closed. @@ -1039,7 +1039,7 @@ (popup-buffer (current-buffer))) (setq slime-popup-buffer-saved-emacs-snapshot nil) (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) - slime-popup-buffer-saved-fingerprint)) + slime-popup-buffer-saved-fingerprint))) (slime-set-emacs-snapshot snapshot) (bury-buffer)) (when kill-buffer-p @@ -6018,7 +6018,7 @@ (defvar slime-xref-saved-emacs-snapshot nil "Buffer local variable in xref windows.") -(define-derived-mode slime-xref-mode lisp-mode "xref" +(define-derived-mode slime-xref-mode lisp-mode "Xref" "slime-xref-mode: Major mode for cross-referencing. \\\ The most important commands: @@ -6026,7 +6026,9 @@ \\[slime-show-xref] - Display referenced source and keep xref window. \\[slime-goto-xref] - Jump to referenced source and dismiss xref window. -\\{slime-xref-mode-map}" +\\{slime-xref-mode-map} +\\{slime-popup-buffer-mode-map} +" (setq font-lock-defaults nil) (setq delayed-mode-hooks nil) (slime-mode -1)) @@ -6036,7 +6038,6 @@ ([return] 'slime-show-xref) ("\C-m" 'slime-show-xref) (" " 'slime-goto-xref) - ("q" 'slime-xref-quit) ("n" 'slime-next-line/not-add-newlines) ("p" 'previous-line) ("\C-c\C-c" 'slime-recompile-xref) @@ -6047,13 +6048,6 @@ (let ((next-line-add-newlines nil)) (next-line 1))) -;; FIXME: binding SLDB keys in xref buffer? -luke -(dolist (spec slime-keys) - (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec - (when sldb - (let ((key (if prefixed (concat slime-prefix-key key) key))) - (define-key slime-xref-mode-map key command))))) - ;;;;; XREF results buffer and window management @@ -6064,47 +6058,34 @@ (buffer-list)) (error "No XREF buffer"))) -(defun slime-init-xref-buffer (package ref-type symbol) - "Initialize the current buffer for displaying XREF information." - (slime-xref-mode) - (setq buffer-read-only nil) - (erase-buffer) - (setq slime-buffer-package package) - (slime-set-truncate-lines)) - -;; XXX: unused function -(defun slime-display-xref-buffer () - "Display the XREF results buffer in a window and select it." - (let* ((buffer (slime-xref-buffer)) - (window (get-buffer-window buffer))) - (if (and window (window-live-p window)) - (select-window window) - (select-window (display-buffer buffer t)) - (shrink-window-if-larger-than-buffer)))) - -(defmacro* slime-with-xref-buffer ((package ref-type symbol &key emacs-snapshot) +(defmacro* slime-with-xref-buffer ((xref-type symbol &optional package emacs-snapshot) &body body) "Execute BODY in a xref buffer, then show that buffer." - (let ((type (gensym "TYPE+")) (sym (gensym "SYM+")) - (pkg (gensym "PKG+")) (snapshot (gensym "SNAPSHOT+"))) - `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package)) - ;; We don't want the the xref buffer to be the current buffer - ;; in the snapshot, so we gotta take the snapshot here. - (let ((,snapshot (or ,emacs-snapshot (slime-current-emacs-snapshot)))) - (with-current-buffer (get-buffer-create - (format "*XREF[%s: %s]*" ,type ,sym)) - (prog2 (progn - (slime-init-xref-buffer ,pkg ,type ,sym) - (make-local-variable 'slime-xref-saved-emacs-snapshot) - (setq slime-xref-saved-emacs-snapshot ,snapshot)) - (progn , at body) - (setq buffer-read-only t) - (select-window (or (get-buffer-window (current-buffer) t) - (display-buffer (current-buffer) t))) - (shrink-window-if-larger-than-buffer))))))) + (let ((xref-buffer-name (format "*XREF[%s: %s]*" xref-type symbol))) + `(slime-with-popup-buffer (,xref-buffer-name ,package t ,emacs-snapshot) + (slime-xref-mode) + (slime-set-truncate-lines) + (setq slime-popup-buffer-quit-function 'slime-xref-quit) + (erase-buffer) + (prog1 (progn , at body) + (assert (equal (buffer-name) ,xref-buffer-name)) + (shrink-window-if-larger-than-buffer))))) (put 'slime-with-xref-buffer 'lisp-indent-function 1) +(defun slime-xref-quit (&optional _) + "Kill the current xref buffer and restore the window configuration." + (interactive) + (slime-xref-cleanup) + (slime-popup-buffer-quit)) + +(defun slime-xref-cleanup () + "Delete overlays created by xref mode and kill the xref buffer." + (sldb-delete-overlays) + (let ((buffer (current-buffer))) + (delete-windows-on buffer) + (kill-buffer buffer))) + (defun slime-insert-xrefs (xref-alist) "Insert XREF-ALIST in the current-buffer. XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). @@ -6127,7 +6108,7 @@ (if (null xrefs) (message "No references found for %s." symbol) (setq slime-next-location-function 'slime-goto-next-xref) - (slime-with-xref-buffer (package type symbol :emacs-snapshot emacs-snapshot) + (slime-with-xref-buffer (type symbol package emacs-snapshot) (slime-insert-xrefs xrefs) (goto-char (point-min)) (forward-line) @@ -6259,17 +6240,6 @@ (error "No context for finding locations.")) (funcall slime-next-location-function)) -(defun slime-xref-quit () - "Kill the current xref buffer and restore the window configuration." - (interactive) - (let ((snapshot slime-xref-saved-emacs-snapshot)) - (slime-xref-cleanup) - (slime-set-emacs-snapshot snapshot))) - -(defun foo (&optional p) - (interactive "p") - (message "%S" p)) - (defun slime-recompile-xref (&optional raw-prefix-arg) (interactive "P") (let* ((prefix-arg (and raw-prefix-arg (prefix-numeric-value raw-prefix-arg))) @@ -6328,13 +6298,6 @@ ((nil) :failure) (t result)))))))) -(defun slime-xref-cleanup () - "Delete overlays created by xref mode and kill the xref buffer." - (sldb-delete-overlays) - (let ((buffer (current-buffer))) - (delete-windows-on buffer) - (kill-buffer buffer))) - ;;;; Macroexpansion From heller at common-lisp.net Fri Aug 8 19:42:46 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 15:42:46 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808194246.15E683701B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv30461 Modified Files: swank.lisp Log Message: (spawn-threads-for-connection): Simplify. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/08 13:43:33 1.554 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/08 19:42:45 1.555 @@ -875,31 +875,31 @@ (funcall function))) (*slime-interrupts-enabled* (funcall function)) - ((cddr *pending-slime-interrupts*) + ((cdr *pending-slime-interrupts*) (simple-break "Two many queued interrupts")) (t (push function *pending-slime-interrupts*)))) -(defslimefun simple-break (&optional (message "Interrupt from Emacs")) - (with-simple-restart (continue "Continue from interrupt.") - (call-with-debugger-hook - #'swank-debugger-hook - (lambda () - (invoke-debugger - (make-condition 'simple-error :format-control "~a" - :format-arguments (list message)))))) - nil) +(defslimefun simple-break (&optional (fstring "Interrupt from Emacs") + &rest args) + (call-with-debugger-hook + #'swank-debugger-hook + (lambda () + (cerror "Return from break." "~?" fstring args)))) ;;;;;; Thread based communication (defvar *active-threads* '()) -(defun read-loop (control-thread input-stream connection) +(defun read-loop (connection) (with-reader-error-handler (connection) - (loop (send control-thread (decode-message input-stream))))) - -(defun dispatch-loop (socket-io connection) - (let ((*emacs-connection* connection)) + (let ((input-stream (connection.socket-io connection)) + (control-thread (connection.control-thread connection))) + (loop (send control-thread (decode-message input-stream)))))) + +(defun dispatch-loop (connection) + (let ((*emacs-connection* connection) + (socket-io (connection.socket-io connection))) (handler-bind ((error (lambda (e) (if *debug-on-swank-error* (invoke-debugger e) @@ -1007,26 +1007,18 @@ (encode-message event socket-io)))) (defun spawn-threads-for-connection (connection) - (macrolet ((without-debugger-hook (&body body) - `(call-with-debugger-hook nil (lambda () , at body)))) - (let* ((socket-io (connection.socket-io connection)) - (control-thread (spawn (lambda () - (without-debugger-hook - (dispatch-loop socket-io connection))) - :name "control-thread"))) - (setf (connection.control-thread connection) control-thread) - (let ((reader-thread (spawn (lambda () - (let ((go (receive))) - (assert (eq go 'accept-input))) - (without-debugger-hook - (read-loop control-thread socket-io - connection))) - :name "reader-thread")) - (repl-thread (spawn-repl-thread connection "repl-thread"))) - (setf (connection.repl-thread connection) repl-thread) - (setf (connection.reader-thread connection) reader-thread) - (send reader-thread 'accept-input) - connection)))) + (setf (connection.control-thread connection) + (spawn (lambda () (control-thread connection)) + :name "control-thread")) + connection) + +(defun control-thread (connection) + (with-connection-slots connection + (setf control-thread (current-thread)) + (setf repl-thread (spawn-repl-thread connection "repl-thread")) + (setf reader-thread (spawn (lambda () (read-loop connection)) + :name "reader-thread")) + (dispatch-loop connection))) (defun cleanup-connection-threads (connection) (let ((threads (list (connection.repl-thread connection) From heller at common-lisp.net Fri Aug 8 19:42:51 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 15:42:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808194251.CD16D38012@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv30484 Modified Files: ChangeLog swank-backend.lisp swank.lisp Log Message: Unify event dispatching for single and multi-threaded cases. * swank.lisp (send-to-control-thread,read-from-control-thread) (send-to-socket-io,read-from-socket-io): Deleted. (send-event, read-event, send-to-emacs) (signal-interrupt, use-threads-p): New functions. And more random changes. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 17:09:07 1.1415 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 19:42:51 1.1416 @@ -29,6 +29,16 @@ 2008-08-08 Helmut Eller + Unify event dispatching for single and multi-threaded cases. + + * swank.lisp (send-to-control-thread,read-from-control-thread) + (send-to-socket-io,read-from-socket-io): Deleted. + (send-event, read-event, send-to-emacs) + (signal-interrupt, use-threads-p): New functions. + And more random changes. + +2008-08-08 Helmut Eller + Spawn the auto-flush thread in the front end. This removes some copy&paste code in various backends. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/08 13:43:33 1.141 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/08 19:42:51 1.142 @@ -937,7 +937,8 @@ (definterface find-thread (id) "Return the thread for ID. ID should be an id previously obtained with THREAD-ID. -Can return nil if the thread no longer exists.") +Can return nil if the thread no longer exists." + (current-thread)) (definterface thread-name (thread) "Return the name of THREAD. @@ -998,7 +999,8 @@ "Send OBJECT to thread THREAD.") (definterface receive () - "Return the next message from current thread's mailbox.") + "Return the next message from current thread's mailbox." + (receive-if (constantly t))) (definterface receive-if (predicate) "Return the first message satisfiying PREDICATE.") --- /project/slime/cvsroot/slime/swank.lisp 2008/08/08 19:42:45 1.555 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/08 19:42:51 1.556 @@ -223,10 +223,6 @@ ;; (SERVE-REQUESTS ) serves all pending requests ;; from Emacs. (serve-requests (missing-arg) :type function) - ;; (READ) is called to read and return one message from Emacs. - (read (missing-arg) :type function) - ;; (SEND OBJECT) is called to send one message to Emacs. - (send (missing-arg) :type function) ;; (CLEANUP ) is called when the connection is ;; closed. (cleanup nil :type (or null function)) @@ -276,10 +272,13 @@ (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))) + (make-condition 'swank-error :condition condition + :backtrace (safe-backtrace))) + +(defun safe-backtrace () + (ignore-errors + (call-with-debugging-environment + (lambda () (backtrace 0 nil))))) (add-hook *new-connection-hook* 'notify-backend-of-connection) (defun notify-backend-of-connection (connection) @@ -338,6 +337,17 @@ '() `((t (error "destructure-case failed: ~S" ,tmp)))))))) +(defmacro with-struct* ((conc-name get obj) &body body) + (let ((var (gensym))) + `(let ((,var ,obj)) + (macrolet ((,get (slot) + (let ((getter (intern (concatenate 'string + ',(string conc-name) + (string slot)) + (symbol-package ',conc-name)))) + `(,getter ,',var)))) + , at body)))) + (defmacro with-temp-package (var &body body) "Execute BODY with VAR bound to a temporary package. The package is deleted before returning." @@ -354,6 +364,9 @@ (setf (gethash ,var ,seen-ht) t) , at body))))) +(defun use-threads-p () + (eq (connection.communication-style *emacs-connection*) :spawn)) + ;;;;; Logging @@ -802,7 +815,7 @@ (defun current-socket-io () (connection.socket-io *emacs-connection*)) -(defun close-connection (c &optional condition backtrace) +(defun close-connection (c condition backtrace) (format *log-output* "~&;; swank:close-connection: ~A~%" condition) (let ((cleanup (connection.cleanup c))) (when cleanup @@ -836,20 +849,20 @@ want to debug swank internals.") (defmacro with-reader-error-handler ((connection) &body body) - (let ((con (gensym)) - (blck (gensym))) - `(let ((,con ,connection)) - (block ,blck - (handler-bind ((swank-error - (lambda (e) - (if *debug-on-swank-error* - (invoke-debugger e) - (return-from ,blck - (close-connection - ,con - (swank-error.condition e) - (swank-error.backtrace e))))))) - (progn , at body)))))) + (let ((var (gensym))) + `(let ((,var ,connection)) + (handler-case (progn , at body) + (swank-error (condition) + (close-connection ,var + (swank-error.condition condition) + (swank-error.backtrace condition))))))) + +(defmacro with-panic-handler (&body body) + `(handler-bind ((serious-condition + (lambda (condition) + (close-connection *emacs-connection* condition + (safe-backtrace))))) + . ,body)) (defvar *slime-interrupts-enabled*) @@ -892,31 +905,15 @@ (defvar *active-threads* '()) (defun read-loop (connection) - (with-reader-error-handler (connection) - (let ((input-stream (connection.socket-io connection)) - (control-thread (connection.control-thread connection))) + (let ((input-stream (connection.socket-io connection)) + (control-thread (connection.control-thread connection))) + (with-reader-error-handler (connection) (loop (send control-thread (decode-message input-stream)))))) (defun dispatch-loop (connection) - (let ((*emacs-connection* connection) - (socket-io (connection.socket-io connection))) - (handler-bind ((error (lambda (e) - (if *debug-on-swank-error* - (invoke-debugger e) - (return-from dispatch-loop - (close-connection connection e)))))) - (loop (dispatch-event (receive) socket-io))))) - -(defun repl-thread (connection) - (let ((thread (connection.repl-thread connection))) - (when (not thread) - (log-event "ERROR: repl-thread is nil")) - (assert thread) - (cond ((thread-alive-p thread) - thread) - (t - (setf (connection.repl-thread connection) - (spawn-repl-thread connection "new-repl-thread")))))) + (let ((*emacs-connection* connection)) + (with-panic-handler + (loop (dispatch-event (read-event)))))) (defvar *auto-flush-interval* 0.2) @@ -928,19 +925,30 @@ (finish-output stream) (sleep *auto-flush-interval*))) +(defun find-repl-thread (connection) + (cond ((not (use-threads-p)) + (current-thread)) + (t + (let ((thread (connection.repl-thread connection))) + (assert thread) + (cond ((thread-alive-p thread) thread) + (t + (setf (connection.repl-thread connection) + (spawn-repl-thread connection "new-repl-thread")))))))) + (defun find-worker-thread (id) (etypecase id ((member t) (car *active-threads*)) ((member :repl-thread) - (repl-thread *emacs-connection*)) + (find-repl-thread *emacs-connection*)) (fixnum (find-thread id)))) (defun interrupt-worker-thread (id) (let ((thread (or (find-worker-thread id) - (repl-thread *emacs-connection*)))) - (interrupt-thread thread + (find-repl-thread *emacs-connection*)))) + (signal-interrupt thread (lambda () (invoke-or-queue-interrupt #'simple-break))))) @@ -949,9 +957,10 @@ (let ((c *emacs-connection*)) (etypecase id ((member t) - (spawn-worker-thread c)) + (cond ((use-threads-p) (spawn-worker-thread c)) + (t (current-thread)))) ((member :repl-thread) - (repl-thread c)) + (find-repl-thread c)) (fixnum (find-thread id))))) @@ -967,9 +976,10 @@ (repl-loop connection))) :name name)) -(defun dispatch-event (event socket-io) +(defun dispatch-event (event &optional (socket-io (current-socket-io))) "Handle an event triggered either by Emacs or within Lisp." - (log-event "DISPATCHING: ~S~%" event) + (log-event "dispatch-event: ~s~%" event) + (flet ((send (thread event) (send-event thread event))) (destructure-case event ((:emacs-rex form package thread-id id) (let ((thread (thread-for-evaluation thread-id))) @@ -1004,7 +1014,62 @@ :eval-no-wait :background-message :inspect :ping) &rest _) (declare (ignore _)) - (encode-message event socket-io)))) + (encode-message event socket-io))))) + +(defvar *event-queue* '()) + +(defun send-event (thread event) + (log-event "send-event: ~s ~s~%" thread event) + (cond ((use-threads-p) (send thread event)) + (t (setf *event-queue* (nconc *event-queue* (list event)))))) + +(defun read-event () + (log-event "read-event: ~a~%" (current-socket-io)) + (cond ((use-threads-p) (receive)) + (t (decode-message (current-socket-io))))) + +(defun send-to-emacs (event) + "Send EVENT to Emacs." + (cond ((use-threads-p) + (send (connection.control-thread *emacs-connection*) event)) + (t (dispatch-event event)))) + +(defun signal-interrupt (thread interrupt) + (log-event "singal-interrupt~%") + (cond ((use-threads-p) (interrupt-thread thread interrupt)) + (t (funcall interrupt)))) + +(defun wait-for-event (pattern) + (log-event "wait-for-event: ~s~%" pattern) + (cond ((use-threads-p) + (without-slime-interrupts + (receive-if (lambda (e) (event-match-p e pattern))))) + (t + (wait-for-event/event-loop pattern)))) + +(defun wait-for-event/event-loop (pattern) + (loop + (let ((tail (member-if (lambda (e) (event-match-p e pattern)) + *event-queue*))) + (when tail + (setq *event-queue* + (nconc (ldiff *event-queue* tail) (cdr tail))) + (return (car tail)))) + ;; could also say: (dispatch-event (read-event)) + (let ((event (read-event))) + (cond ((event-match-p event pattern) (return event)) + (t (dispatch-event event)))))) + +(defun event-match-p (event pattern) + (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) + (member pattern '(nil t))) + (equal event pattern)) + ((symbolp pattern) t) + ((consp pattern) + (and (consp event) + (and (event-match-p (car event) (car pattern)) + (event-match-p (cdr event) (cdr pattern))))) + (t (error "Invalid pattern: ~S" pattern)))) (defun spawn-threads-for-connection (connection) (setf (connection.control-thread connection) @@ -1013,12 +1078,12 @@ connection) (defun control-thread (connection) - (with-connection-slots connection - (setf control-thread (current-thread)) - (setf repl-thread (spawn-repl-thread connection "repl-thread")) - (setf reader-thread (spawn (lambda () (read-loop connection)) - :name "reader-thread")) - (dispatch-loop connection))) + (with-struct* (connection. @ connection) + (setf (@ control-thread) (current-thread)) + (setf (@ repl-thread) (spawn-repl-thread connection "repl-thread")) + (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) + :name "reader-thread")) + (dispatch-loop connection))) (defun cleanup-connection-threads (connection) (let ((threads (list (connection.repl-thread connection) @@ -1099,49 +1164,7 @@ (with-reader-error-handler (connection) (loop (handle-request connection)))) - (close-connection connection))) - -(defun read-from-socket-io () - (let ((event (decode-message (current-socket-io)))) - (log-event "DISPATCHING: ~S~%" event) - (destructure-case event - ((:emacs-rex form package thread id) - (declare (ignore thread)) - `(:call eval-for-emacs ,form ,package ,id)) - ((:emacs-interrupt thread) - (declare (ignore thread)) - '(:call simple-break)) - ((:emacs-return-string thread tag string) - (declare (ignore thread)) - `(:call take-input ,tag ,string)) - ((:emacs-return thread tag value) - (declare (ignore thread)) - `(:call take-input ,tag ,value)) - ((:emacs-pong thread tag) - (declare (ignore thread)) - `(:emacs-pong ,tag))))) - -(defun send-to-socket-io (event) - (log-event "DISPATCHING: ~S~%" event) - (flet ((send (o) - (without-interrupts - (encode-message o (current-socket-io))))) - (destructure-case event - (((:debug-activate :debug :debug-return :read-string :read-aborted - :y-or-n-p :eval) - thread &rest args) - (declare (ignore thread)) - (send `(,(car event) 0 , at args))) - ((:return thread &rest args) - (declare (ignore thread)) - (send `(:return , at args))) - (((:write-string :new-package :new-features :debug-condition - :presentation-start :presentation-end - :indentation-update :ed :%apply :eval-no-wait - :background-message :inspect :ping) - &rest _) - (declare (ignore _)) - (send event))))) + (close-connection connection nil (safe-backtrace)))) (defun initialize-streams-for-connection (connection) (multiple-value-bind (dedicated in out io repl-results) @@ -1159,26 +1182,18 @@ (let ((c (ecase style (:spawn (make-connection :socket-io socket-io - :read #'read-from-control-thread - :send #'send-to-control-thread :serve-requests #'spawn-threads-for-connection :cleanup #'cleanup-connection-threads)) (:sigio (make-connection :socket-io socket-io - :read #'read-from-socket-io - :send #'send-to-socket-io :serve-requests #'install-sigio-handler :cleanup #'deinstall-sigio-handler)) (:fd-handler (make-connection :socket-io socket-io - :read #'read-from-socket-io - :send #'send-to-socket-io :serve-requests #'install-fd-handler :cleanup #'deinstall-fd-handler)) ((nil) (make-connection :socket-io socket-io - :read #'read-from-socket-io - :send #'send-to-socket-io :serve-requests #'simple-serve-requests)) ))) (setf (connection.communication-style c) style) @@ -1375,58 +1390,9 @@ (defmacro with-thread-description (description &body body) `(call-with-thread-description ,description #'(lambda () , at body))) -(defvar *event-queue* '()) - (defun read-from-emacs () "Read and process a request from Emacs." - (let ((request (without-slime-interrupts - (funcall (connection.read *emacs-connection*))))) - (if (eq *communication-style* :spawn) - (with-thread-description request - (apply #'funcall request)) - (destructure-case request - ((:call &rest args) (apply #'funcall args)) - (t (setf *event-queue* - (nconc *event-queue* (list request)))))))) - -(defun wait-for-event (pattern) - (log-event "wait-for-event: %S~%" pattern) - (case (connection.communication-style *emacs-connection*) - (:spawn - (without-slime-interrupts - (receive-if (lambda (e) (event-match-p e pattern))))) - (t (wait-for-event/event-loop pattern)))) - -(defun wait-for-event/event-loop (pattern) - (loop - (let ((tail (member-if (lambda (e) (event-match-p e pattern)) - *event-queue*))) - (cond (tail - (setq *event-queue* - (nconc (ldiff *event-queue* tail) (cdr tail))) - (return (car tail))) - (t - (let ((event (read-from-socket-io))) - (cond ((event-match-p event pattern) (return event)) - ((eq (car event) :call) [39 lines skipped] From trittweiler at common-lisp.net Fri Aug 8 20:19:48 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 16:19:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808201948.2BA831A0EC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3871 Modified Files: ChangeLog Log Message: * slime.el: Make xref buffers use `slime-with-popup-buffer', nee `slime-with-temp-buffer'. (slime-with-xref-buffer): Rewritten using a popup buffer. (slime-init-xref-buffer): Removed. (slime-display-xref-buffer): Removed. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 19:42:51 1.1416 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 20:19:47 1.1417 @@ -1,5 +1,14 @@ 2008-08-08 Tobias C. Rittweiler + * slime.el: Make xref buffers use `slime-with-popup-buffer', + nee `slime-with-temp-buffer'. + + (slime-with-xref-buffer): Rewritten using a popup buffer. + (slime-init-xref-buffer): Removed. + (slime-display-xref-buffer): Removed. + +2008-08-08 Tobias C. Rittweiler + * slime.el: Rename slime's temp-buffer to popup-buffer. 2008-08-08 Tobias C. Rittweiler From trittweiler at common-lisp.net Fri Aug 8 21:06:49 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 17:06:49 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808210649.4AE257A014@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18248 Modified Files: slime.el Log Message: fix parenthesis error in slime.el --- /project/slime/cvsroot/slime/slime.el 2008/08/08 19:25:07 1.974 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 21:06:49 1.975 @@ -1043,7 +1043,7 @@ (slime-set-emacs-snapshot snapshot) (bury-buffer)) (when kill-buffer-p - (kill-buffer popup-buffer)))) + (kill-buffer popup-buffer))) ;;;;; Filename translation ;;; From trittweiler at common-lisp.net Fri Aug 8 21:13:43 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 17:13:43 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808211343.CFF8055358@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv19851 Modified Files: slime.el Log Message: Fix indentation error. --- /project/slime/cvsroot/slime/slime.el 2008/08/08 21:06:49 1.975 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 21:13:43 1.976 @@ -1039,11 +1039,11 @@ (popup-buffer (current-buffer))) (setq slime-popup-buffer-saved-emacs-snapshot nil) (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) - slime-popup-buffer-saved-fingerprint))) + slime-popup-buffer-saved-fingerprint)) (slime-set-emacs-snapshot snapshot) (bury-buffer)) (when kill-buffer-p - (kill-buffer popup-buffer))) + (kill-buffer popup-buffer)))) ;;;;; Filename translation ;;; From heller at common-lisp.net Fri Aug 8 21:34:17 2008 From: heller at common-lisp.net (heller) Date: Fri, 8 Aug 2008 17:34:17 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808213417.F3EE72F00A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv26111 Modified Files: ChangeLog swank.lisp Log Message: Use wait-for-event instead of catch/throw where needed. * swank.lisp (read-user-input-from-emacs, y-or-n-p-in-emacs) (eval-in-emacs): Use wait-for-event. (make-tag): Replaces intern-catch-tag. (take-input): Deleted. (dispatch-event): Remove some redundancy. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 20:19:47 1.1417 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 21:34:17 1.1418 @@ -1,3 +1,13 @@ +2008-08-08 Helmut Eller + + Use wait-for-event instead of catch/throw where needed. + + * swank.lisp (read-user-input-from-emacs, y-or-n-p-in-emacs) + (eval-in-emacs): Use wait-for-event. + (make-tag): Replaces intern-catch-tag. + (take-input): Deleted. + (dispatch-event): Remove some redundancy. + 2008-08-08 Tobias C. Rittweiler * slime.el: Make xref buffers use `slime-with-popup-buffer', --- /project/slime/cvsroot/slime/swank.lisp 2008/08/08 19:42:51 1.556 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/08 21:34:17 1.557 @@ -367,6 +367,9 @@ (defun use-threads-p () (eq (connection.communication-style *emacs-connection*) :spawn)) +(defun current-thread-id () + (thread-id (current-thread))) + ;;;;; Logging @@ -752,7 +755,7 @@ (with-simple-restart (abort "Abort sending output to Emacs.") (when (or (= i max) (> l (* 80 20 5))) (setf tag (mod (1+ tag) 1000)) - (send-to-emacs `(:ping ,(thread-id (current-thread)) ,tag)) + (send-to-emacs `(:ping ,(current-thread-id) ,tag)) (wait-for-event `(:emacs-pong ,tag)) (setf i 0) (setf l 0)) @@ -976,45 +979,32 @@ (repl-loop connection))) :name name)) -(defun dispatch-event (event &optional (socket-io (current-socket-io))) +(defun dispatch-event (event) "Handle an event triggered either by Emacs or within Lisp." (log-event "dispatch-event: ~s~%" event) - (flet ((send (thread event) (send-event thread event))) (destructure-case event ((:emacs-rex form package thread-id id) (let ((thread (thread-for-evaluation thread-id))) (push thread *active-threads*) - (send thread `(:call eval-for-emacs ,form ,package ,id)))) + (send-event thread `(:emacs-rex ,form ,package ,id)))) ((:return thread &rest args) (let ((tail (member thread *active-threads*))) (setq *active-threads* (nconc (ldiff *active-threads* tail) - (cdr tail)))) - (encode-message `(:return , at args) socket-io)) + (cdr tail)))) + (encode-message `(:return , at args) (current-socket-io))) ((:emacs-interrupt thread-id) (interrupt-worker-thread thread-id)) - (((:debug :debug-condition :debug-activate :debug-return) - thread &rest args) - (encode-message `(,(car event) ,(thread-id thread) , at args) socket-io)) - ((:read-string thread &rest args) - (encode-message `(:read-string ,(thread-id thread) , at args) socket-io)) - ((:y-or-n-p thread &rest args) - (encode-message `(:y-or-n-p ,(thread-id thread) , at args) socket-io)) - ((:read-aborted thread &rest args) - (encode-message `(:read-aborted ,(thread-id thread) , at args) socket-io)) - ((:emacs-return-string thread-id tag string) - (send (find-thread thread-id) `(:call take-input ,tag ,string))) - ((:eval thread &rest args) - (encode-message `(:eval ,(thread-id thread) , at args) socket-io)) - ((:emacs-return thread-id tag value) - (send (find-thread thread-id) `(:call take-input ,tag ,value))) - ((:emacs-pong thread-id tag) - (send (find-thread thread-id) `(:emacs-pong ,tag))) - (((:write-string :presentation-start :presentation-end - :new-package :new-features :ed :%apply :indentation-update - :eval-no-wait :background-message :inspect :ping) + (((:write-string + :debug :debug-condition :debug-activate :debug-return + :presentation-start :presentation-end + :new-package :new-features :ed :%apply :indentation-update + :eval :eval-no-wait :background-message :inspect :ping + :y-or-n-p :read-string :read-aborted) &rest _) (declare (ignore _)) - (encode-message event socket-io))))) + (encode-message event (current-socket-io))) + (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args) + (send-event (find-thread thread-id) (cons (car event) args))))) (defvar *event-queue* '()) @@ -1053,14 +1043,12 @@ *event-queue*))) (when tail (setq *event-queue* - (nconc (ldiff *event-queue* tail) (cdr tail))) + (nconc (ldiff *event-queue* tail) (cdr tail))) (return (car tail)))) - ;; could also say: (dispatch-event (read-event)) - (let ((event (read-event))) - (cond ((event-match-p event pattern) (return event)) - (t (dispatch-event event)))))) + (dispatch-event (read-event)))) (defun event-match-p (event pattern) + (log-event "event-match-p: ~s ~s~%" event pattern) (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) (member pattern '(nil t))) (equal event pattern)) @@ -1392,7 +1380,7 @@ (defun read-from-emacs () "Read and process a request from Emacs." - (apply #'funcall (cdr (wait-for-event `(:call . _))))) + (apply #'eval-for-emacs (cdr (wait-for-event `(:emacs-rex . _))))) (defun decode-message (stream) "Read an S-expression from STREAM using the SLIME protocol." @@ -1448,36 +1436,29 @@ (defun clear-user-input () (clear-input (connection.user-input *emacs-connection*))) -(defvar *read-input-catch-tag* 0) +(defvar *tag-counter* 0) -(defun intern-catch-tag (tag) - ;; fixnums aren't eq in ABCL, so we use intern to create tags - (intern (format nil "~D" tag) :swank)) +(defun make-tag () + (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22)))) (defun read-user-input-from-emacs () - (let ((tag (incf *read-input-catch-tag*))) + (let ((tag (make-tag))) (force-output) - (send-to-emacs `(:read-string ,(current-thread) ,tag)) + (send-to-emacs `(:read-string ,(current-thread-id) ,tag)) (let ((ok nil)) (unwind-protect - (prog1 (catch (intern-catch-tag tag) - (loop (read-from-emacs))) + (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value))) (setq ok t)) (unless ok - (send-to-emacs `(:read-aborted ,(current-thread) ,tag))))))) + (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag))))))) (defun y-or-n-p-in-emacs (format-string &rest arguments) "Like y-or-n-p, but ask in the Emacs minibuffer." - (let ((tag (incf *read-input-catch-tag*)) + (let ((tag (make-tag)) (question (apply #'format nil format-string arguments))) (force-output) - (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question)) - (catch (intern-catch-tag tag) - (loop (read-from-emacs))))) - -(defslimefun take-input (tag input) - "Return the string INPUT to the continuation TAG." - (throw (intern-catch-tag tag) input)) + (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question)) + (caddr (wait-for-event `(:emacs-return ,tag result))))) (defun process-form-for-emacs (form) "Returns a string which emacs will read as equivalent to @@ -1507,15 +1488,13 @@ (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) (t (force-output) - (let* ((tag (incf *read-input-catch-tag*)) - (value (catch (intern-catch-tag tag) - (send-to-emacs - `(:eval ,(current-thread) ,tag - ,(process-form-for-emacs form))) - (loop (read-from-emacs))))) - (destructure-case value - ((:ok value) value) - ((:abort) (abort))))))) + (let ((tag (make-tag))) + (send-to-emacs `(:eval ,(current-thread-id) ,tag + ,(process-form-for-emacs form))) + (let ((value (caddr (wait-for-event `(:emacs-return ,tag result))))) + (destructure-case value + ((:ok value) value) + ((:abort) (abort)))))))) (defvar *swank-wire-protocol-version* nil "The version of the swank/slime communication protocol.") @@ -2057,23 +2036,23 @@ (unwind-protect (catch 'sldb-enter-default-debugger (send-to-emacs - (list* :debug (current-thread) level + (list* :debug (current-thread-id) level (debugger-info-for-emacs 0 *sldb-initial-frames*))) (loop (catch 'sldb-loop-catcher (with-simple-restart (abort "Return to sldb level ~D." level) - (send-to-emacs (list :debug-activate (current-thread) + (send-to-emacs (list :debug-activate (current-thread-id) level)) (handler-bind ((sldb-condition #'handle-sldb-condition)) (read-from-emacs)))))) - (send-to-emacs `(:debug-return - ,(current-thread) ,level ,*sldb-stepping-p*)))) + (send-to-emacs `(:debug-return + ,(current-thread-id) ,level ,*sldb-stepping-p*)))) (defun handle-sldb-condition (condition) "Handle an internal debugger condition. Rather than recursively debug the debugger (a dangerous idea!), these conditions are simply reported." (let ((real-condition (original-condition condition))) - (send-to-emacs `(:debug-condition ,(current-thread) + (send-to-emacs `(:debug-condition ,(current-thread-id) ,(princ-to-string real-condition)))) (throw 'sldb-loop-catcher nil)) From trittweiler at common-lisp.net Fri Aug 8 22:46:54 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 8 Aug 2008 18:46:54 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080808224654.CBA743800E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17590 Modified Files: slime.el ChangeLog Log Message: * slime.el: Fixing `q' in Xref buffers. (slime-popup-buffer-snapshot-unchanged-p): New. (slime-popup-buffer-restore-snapshot): New. (slime-xref-quit): Can't use slime-popup-buffer directly. Instead implement its own quit behaviour using the above functions. --- /project/slime/cvsroot/slime/slime.el 2008/08/08 21:13:43 1.976 +++ /project/slime/cvsroot/slime/slime.el 2008/08/08 22:46:54 1.977 @@ -1035,16 +1035,23 @@ Restore the window configuration unless it was changed since we last activated the buffer." (interactive) - (let ((snapshot slime-popup-buffer-saved-emacs-snapshot) - (popup-buffer (current-buffer))) - (setq slime-popup-buffer-saved-emacs-snapshot nil) - (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) - slime-popup-buffer-saved-fingerprint)) - (slime-set-emacs-snapshot snapshot) + (let ((popup-buffer (current-buffer))) + (if (slime-popup-buffer-snapshot-unchanged-p) + (slime-popup-buffer-restore-snapshot) (bury-buffer)) + (setq slime-popup-buffer-saved-emacs-snapshot nil) (when kill-buffer-p (kill-buffer popup-buffer)))) +(defun slime-popup-buffer-snapshot-unchanged-p () + (let ((snapshot slime-popup-buffer-saved-emacs-snapshot)) + (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) + slime-popup-buffer-saved-fingerprint)))) + +(defun slime-popup-buffer-restore-snapshot () + (slime-set-emacs-snapshot slime-popup-buffer-saved-emacs-snapshot)) + + ;;;;; Filename translation ;;; ;;; Filenames passed between Emacs and Lisp should be translated using @@ -6077,14 +6084,17 @@ "Kill the current xref buffer and restore the window configuration." (interactive) (slime-xref-cleanup) - (slime-popup-buffer-quit)) + ;; We can't simply use `slime-popup-buffer-quit' because we also + ;; want the Xref window be deleted. + (if (slime-popup-buffer-snapshot-unchanged-p) + (slime-popup-buffer-restore-snapshot) + (let ((buffer (current-buffer))) + (delete-windows-on buffer) + (kill-buffer buffer)))) (defun slime-xref-cleanup () "Delete overlays created by xref mode and kill the xref buffer." - (sldb-delete-overlays) - (let ((buffer (current-buffer))) - (delete-windows-on buffer) - (kill-buffer buffer))) + (sldb-delete-overlays)) (defun slime-insert-xrefs (xref-alist) "Insert XREF-ALIST in the current-buffer. @@ -6208,7 +6218,7 @@ "Goto the cross-referenced location at point." (interactive) (let ((location (slime-xref-location-at-point))) - (slime-xref-cleanup) + (slime-xref-quit) (slime-pop-to-location location))) (defun slime-show-xref () --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 21:34:17 1.1418 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/08 22:46:54 1.1419 @@ -1,3 +1,12 @@ +2008-08-08 Tobias C. Rittweiler + + * slime.el: Fixing `q' in Xref buffers. + + (slime-popup-buffer-snapshot-unchanged-p): New. + (slime-popup-buffer-restore-snapshot): New. + (slime-xref-quit): Can't use slime-popup-buffer directly. Instead + implement its own quit behaviour using the above functions. + 2008-08-08 Helmut Eller Use wait-for-event instead of catch/throw where needed. From trittweiler at common-lisp.net Sat Aug 9 10:49:48 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sat, 9 Aug 2008 06:49:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809104948.EB48E2F002@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10687 Modified Files: slime.el ChangeLog Log Message: M-x slime doesn't destroy the window layout anymore when you switch windows/frames while the connection is being set up. * slime.el (slime-hide-inferior-lisp-buffer): Search for the inferior-lisp buffer's window in all frames. (slime-repl-update-banner): Do not pop to the REPL buffer. --- /project/slime/cvsroot/slime/slime.el 2008/08/08 22:46:54 1.977 +++ /project/slime/cvsroot/slime/slime.el 2008/08/09 10:49:48 1.978 @@ -1448,7 +1448,7 @@ "Display the REPL buffer instead of the *inferior-lisp* buffer." (let* ((buffer (if (slime-process) (process-buffer (slime-process)))) - (window (if buffer (get-buffer-window buffer))) + (window (if buffer (get-buffer-window buffer t))) (repl-buffer (slime-output-buffer t)) (repl-window (get-buffer-window repl-buffer))) (when buffer @@ -2488,8 +2488,7 @@ (goto-char (point-max)) (slime-mark-output-start) (slime-mark-input-start) - (slime-repl-insert-prompt) - (pop-to-buffer (current-buffer))) + (slime-repl-insert-prompt)) (defun slime-repl-insert-banner () (when (zerop (buffer-size)) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/08 22:46:54 1.1419 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 10:49:48 1.1420 @@ -1,3 +1,12 @@ +2008-08-09 Tobias C. Rittweiler + + M-x slime doesn't destroy the window layout anymore when you + switch windows/frames while the connection is being set up. + + * slime.el (slime-hide-inferior-lisp-buffer): Search for the + inferior-lisp buffer's window in all frames. + (slime-repl-update-banner): Do not pop to the REPL buffer. + 2008-08-08 Tobias C. Rittweiler * slime.el: Fixing `q' in Xref buffers. From heller at common-lisp.net Sat Aug 9 19:56:52 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:56:52 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195652.8630E3C206@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20505 Modified Files: ChangeLog swank-lispworks.lisp Log Message: * swank-lispworks.lisp (disassemble-frame): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 10:49:48 1.1420 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:56:52 1.1421 @@ -16,6 +16,10 @@ (slime-xref-quit): Can't use slime-popup-buffer directly. Instead implement its own quit behaviour using the above functions. +2008-08-09 Helmut Eller + + * swank-lispworks.lisp (disassemble-frame): Implemented. + 2008-08-08 Helmut Eller Use wait-for-event instead of catch/throw where needed. --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/08 13:43:33 1.108 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:56:52 1.109 @@ -220,10 +220,10 @@ (defmethod env-internals:environment-display-debugger ((env slime-env)) *debug-io*) -(defimplementation call-with-debugger-hook (hook fun) - (let ((*debugger-hook* hook)) - (env:with-environment ((slime-env hook '())) - (funcall fun)))) +;;(defimplementation call-with-debugger-hook (hook fun) +;; (let ((*debugger-hook* hook)) +;; (env:with-environment ((slime-env hook '())) +;; (funcall fun)))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) @@ -346,6 +346,12 @@ (let ((frame (nth-frame frame-number))) (dbg::restart-frame frame :same-args t))) +(defimplementation disassemble-frame (frame-number) + (let* ((frame (nth-frame frame-number))) + (when (dbg::call-frame-p frame) + (let ((function (dbg::get-call-frame-function frame))) + (disassemble function))))) + ;;; Definition finding (defun frame-location (dspec callee-name) From heller at common-lisp.net Sat Aug 9 19:57:00 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:57:00 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195700.74E224507D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20543 Modified Files: ChangeLog slime.el swank-lispworks.lisp swank-sbcl.lisp swank.lisp Log Message: Display the "Use default debugger" restart more prominently. * swank.lisp (swank-debugger-hook): Bind a user visible restart to invoke the native debugger. (*global-debugger*): Make this nil by default. (sldb-loop): Minor cleanups. (sldb-break-with-default-debugger): Invoke the native debugger on top of the slime debugger. * slime.el (sldb-setup): Always pop to the debugger buffer. (sldb-activate): Optionally select the window. * swank-sbcl.lisp (sb-thread::get-foreground): Override this as the default implementation is unusable for Slime. * swank-lispworks.lisp (environment-display-notifier): Just return t. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:56:52 1.1421 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:56:59 1.1422 @@ -18,6 +18,26 @@ 2008-08-09 Helmut Eller + Display the "Use default debugger" restart more prominently. + + * swank.lisp (swank-debugger-hook): Bind a user visible restart + to invoke the native debugger. + (*global-debugger*): Make this nil by default. + (sldb-loop): Minor cleanups. + (sldb-break-with-default-debugger): Invoke the native debugger + on top of the slime debugger. + + * slime.el (sldb-setup): Always pop to the debugger buffer. + (sldb-activate): Optionally select the window. + + * swank-sbcl.lisp (sb-thread::get-foreground): Override this + as the default implementation is unusable for Slime. + + * swank-lispworks.lisp (environment-display-notifier): Just + return t. + +2008-08-09 Helmut Eller + * swank-lispworks.lisp (disassemble-frame): Implemented. 2008-08-08 Helmut Eller --- /project/slime/cvsroot/slime/slime.el 2008/08/09 10:49:48 1.978 +++ /project/slime/cvsroot/slime/slime.el 2008/08/09 19:57:00 1.979 @@ -2331,9 +2331,9 @@ (funcall (cdr rec) value)) (t (error "Unexpected reply: %S %S" id value))))) - ((:debug-activate thread level) + ((:debug-activate thread level select) (assert thread) - (sldb-activate thread level)) + (sldb-activate thread level select)) ((:debug thread level condition restarts frames conts) (assert thread) (sldb-setup thread level condition restarts frames conts)) @@ -6727,26 +6727,33 @@ (setq sldb-backtrace-start-marker (point-marker)) (save-excursion (sldb-insert-frames (sldb-prune-initial-frames frames) t)) - (run-hooks 'sldb-hook) - (pop-to-buffer (current-buffer)) - (sldb-recenter-region (point-min) (point)) - (setq buffer-read-only t) - (when (and slime-stack-eval-tags - ;; (y-or-n-p "Enter recursive edit? ") - ) - (message "Entering recursive edit..") - (recursive-edit))))) + (run-hooks 'sldb-hook)) + (pop-to-buffer (current-buffer)) + (sldb-recenter-region (point-min) (point)) + (setq buffer-read-only t) + (when (and slime-stack-eval-tags + ;; (y-or-n-p "Enter recursive edit? ") + ) + (message "Entering recursive edit..") + (recursive-edit)))) -(defun sldb-activate (thread level) +(defun sldb-activate (thread level select) "Display the debugger buffer for THREAD. If LEVEL isn't the same as in the buffer, reinitialize the buffer." - (unless (let ((b (sldb-find-buffer thread))) - (and b (with-current-buffer b (equal sldb-level level)))) - (slime-rex (thread level) - ('(swank:debugger-info-for-emacs 0 10) - nil thread) - ((:ok result) - (apply #'sldb-setup thread level result))))) + (or (let ((buffer (sldb-find-buffer thread))) + (when buffer + (with-current-buffer buffer + (when (equal sldb-level level) + (when select (pop-to-buffer (current-buffer))) + t)))) + (sldb-reinitialize thread level))) + +(defun sldb-reinitialize (thread level) + (slime-rex (thread level) + ('(swank:debugger-info-for-emacs 0 10) + nil thread) + ((:ok result) + (apply #'sldb-setup thread level result)))) (defun sldb-exit (thread level &optional stepping) "Exit from the debug level LEVEL." --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:56:52 1.109 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:57:00 1.110 @@ -220,15 +220,28 @@ (defmethod env-internals:environment-display-debugger ((env slime-env)) *debug-io*) -;;(defimplementation call-with-debugger-hook (hook fun) -;; (let ((*debugger-hook* hook)) -;; (env:with-environment ((slime-env hook '())) -;; (funcall fun)))) +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook)) + (env:with-environment ((slime-env hook '())) + (funcall fun)))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) (setf (env:environment) (slime-env function '()))) +(defmethod env-internals:environment-display-notifier + ((env slime-env) &key restarts condition) + (declare (ignore restarts)) + ;;(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*) + (values t nil) + ) + +(defmethod env-internals:environment-display-debugger ((env slime-env)) + *debug-io*) + +(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) + (apply (swank-sym :y-or-n-p-in-emacs) msg args)) + (defvar *sldb-top-frame*) (defun interesting-frame-p (frame) @@ -783,19 +796,7 @@ (defimplementation emacs-connected () (when (eq (eval (swank-sym :*communication-style*)) nil) - (set-sigint-handler)) - ;; pop up the slime debugger by default - (let ((lw:*handle-warn-on-redefinition* :warn)) - (defmethod env-internals:environment-display-notifier - (env &key restarts condition) - (declare (ignore restarts)) - (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)) - (defmethod env-internals:environment-display-debugger (env) - *debug-io*))) - - -(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) - (apply (swank-sym :y-or-n-p-in-emacs) msg args)) + (set-sigint-handler))) ;;;; Weak hashtables --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/08 13:43:33 1.210 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/09 19:57:00 1.211 @@ -1319,6 +1319,19 @@ mutex)) (sb-ext:timeout ())))))) + #-non-broken-terminal-sessions + (progn + (defvar *native-wait-for-terminal* #'sb-thread::get-foreground) + (sb-ext:with-unlocked-packages (sb-thread) + (defun sb-thread::get-foreground () + (ignore-errors + (format *debug-io* ";; SWANK: sb-thread::get-foreground ...~%") + (finish-output *debug-io*)) + (or (and (typep *debug-io* 'two-way-stream) + (typep (two-way-stream-input-stream *debug-io*) + 'slime-input-stream)) + (funcall *native-wait-for-terminal*))))) + ) (defimplementation quit-lisp () --- /project/slime/cvsroot/slime/swank.lisp 2008/08/08 21:34:17 1.557 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/09 19:57:00 1.558 @@ -1983,13 +1983,18 @@ after Emacs causes a restart to be invoked." (declare (ignore hook)) (without-slime-interrupts - (cond (*emacs-connection* - (debug-in-emacs condition)) - ((default-connection) - (with-connection ((default-connection)) - (debug-in-emacs condition)))))) + (restart-case + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition)))) + (default-debugger (&optional v) + :report "Use default debugger." (declare (ignore v)) + (let ((*debugger-hook* nil)) + (invoke-debugger condition)))))) -(defvar *global-debugger* t +(defvar *global-debugger* nil "Non-nil means the Swank debugger hook will be installed globally.") (add-hook *new-connection-hook* 'install-debugger) @@ -2034,18 +2039,18 @@ (defun sldb-loop (level) (unwind-protect - (catch 'sldb-enter-default-debugger - (send-to-emacs - (list* :debug (current-thread-id) level - (debugger-info-for-emacs 0 *sldb-initial-frames*))) - (loop (catch 'sldb-loop-catcher - (with-simple-restart (abort "Return to sldb level ~D." level) - (send-to-emacs (list :debug-activate (current-thread-id) - level)) - (handler-bind ((sldb-condition #'handle-sldb-condition)) - (read-from-emacs)))))) - (send-to-emacs `(:debug-return - ,(current-thread-id) ,level ,*sldb-stepping-p*)))) + (loop + (with-simple-restart (abort "Return to sldb level ~D." level) + (send-to-emacs + (list* :debug (current-thread-id) level + (debugger-info-for-emacs 0 *sldb-initial-frames*))) + (loop + (send-to-emacs (list :debug-activate (current-thread-id) level nil)) + (handler-case (read-from-emacs) + (sldb-condition (c) + (handle-sldb-condition c)))))) + (send-to-emacs `(:debug-return + ,(current-thread-id) ,level ,*sldb-stepping-p*)))) (defun handle-sldb-condition (condition) "Handle an internal debugger condition. @@ -2053,8 +2058,7 @@ conditions are simply reported." (let ((real-condition (original-condition condition))) (send-to-emacs `(:debug-condition ,(current-thread-id) - ,(princ-to-string real-condition)))) - (throw 'sldb-loop-catcher nil)) + ,(princ-to-string real-condition))))) (defvar *sldb-condition-printer* #'format-sldb-condition "Function called to print a condition to an SLDB buffer.") @@ -2089,8 +2093,11 @@ ;;;;; SLDB entry points (defslimefun sldb-break-with-default-debugger () - "Invoke the default debugger by returning from our debugger-loop." - (throw 'sldb-enter-default-debugger nil)) + "Invoke the default debugger." + (call-with-debugger-hook + nil (lambda () (invoke-debugger *swank-debugger-condition*))) + (send-to-emacs + (list :debug-activate (current-thread-id) *sldb-level* t))) (defslimefun backtrace (start end) "Return a list ((I FRAME) ...) of frames from START to END. From heller at common-lisp.net Sat Aug 9 19:57:07 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:57:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195707.3B3268315D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20604 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-simple-completions): Bind slime-current-thread to t so that completion is peformed in a fresh thread. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:56:59 1.1422 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:06 1.1423 @@ -27,7 +27,9 @@ (sldb-break-with-default-debugger): Invoke the native debugger on top of the slime debugger. - * slime.el (sldb-setup): Always pop to the debugger buffer. + * slime.el (slime-simple-completions): Bind slime-current-thread + to t so that completion is peformed in a fresh thread. + (sldb-setup): Always pop to the debugger buffer. (sldb-activate): Optionally select the window. * swank-sbcl.lisp (sb-thread::get-foreground): Override this --- /project/slime/cvsroot/slime/slime.el 2008/08/09 19:57:00 1.979 +++ /project/slime/cvsroot/slime/slime.el 2008/08/09 19:57:06 1.980 @@ -5094,7 +5094,9 @@ (mapcar (lambda (x) (cons x nil)) list)) (defun slime-simple-completions (prefix) - (slime-eval `(swank:simple-completions ,prefix ',(slime-current-package)))) + (let ((slime-current-thread t)) + (slime-eval + `(swank:simple-completions ,prefix ',(slime-current-package))))) ;;;; Edit definition From heller at common-lisp.net Sat Aug 9 19:57:12 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:57:12 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195712.DDE3A63091@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20636 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (*maximum-pipelined-output-chunks*): New variable --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:06 1.1423 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:12 1.1424 @@ -18,6 +18,10 @@ 2008-08-09 Helmut Eller + * swank.lisp (*maximum-pipelined-output-chunks*): New variable + +2008-08-09 Helmut Eller + Display the "Use default debugger" restart more prominently. * swank.lisp (swank-debugger-hook): Bind a user visible restart --- /project/slime/cvsroot/slime/swank.lisp 2008/08/09 19:57:00 1.558 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/09 19:57:12 1.559 @@ -746,14 +746,17 @@ :name "auto-flush-thread")) (values dedicated-output in out io repl-results))))) +(defvar *maximum-pipelined-output-chunks* 20) + ;; FIXME: if wait-for-event aborts the event will stay in the queue forever. (defun make-output-function (connection) "Create function to send user output to Emacs." - (let ((max 100) (i 0) (tag 0) (l 0)) + (let ((i 0) (tag 0) (l 0)) (lambda (string) (with-connection (connection) (with-simple-restart (abort "Abort sending output to Emacs.") - (when (or (= i max) (> l (* 80 20 5))) + (when (or (= i *maximum-pipelined-output-chunks*) + (> l (* 80 20 5))) (setf tag (mod (1+ tag) 1000)) (send-to-emacs `(:ping ,(current-thread-id) ,tag)) (wait-for-event `(:emacs-pong ,tag)) From heller at common-lisp.net Sat Aug 9 19:57:17 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:57:17 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195717.E4206A146@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20668 Modified Files: ChangeLog swank-lispworks.lisp Log Message: * swank-lispworks.lisp (defimplementation): Record location. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:12 1.1424 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:17 1.1425 @@ -18,6 +18,10 @@ 2008-08-09 Helmut Eller + * swank-lispworks.lisp (defimplementation): Record location. + +2008-08-09 Helmut Eller + * swank.lisp (*maximum-pipelined-output-chunks*): New variable 2008-08-09 Helmut Eller --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:57:00 1.110 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:57:17 1.111 @@ -32,9 +32,15 @@ (defun swank-mop:eql-specializer-object (eql-spec) (second eql-spec)) -(when (fboundp 'dspec::define-dspec-alias) - (dspec::define-dspec-alias defimplementation (name args &rest body) - `(defun ,name ,args , at body))) +(eval-when (:compile-toplevel :execute :load-toplevel) + (defvar *original-defimplementation* (macro-function 'defimplementation)) + (defmacro defimplementation (&whole whole name args &body body + &environment env) + (declare (ignore args body)) + `(progn + (dspec:record-definition '(defun ,name) (dspec:location) + :check-redefinition-p nil) + ,(funcall *original-defimplementation* whole env)))) ;;; TCP server @@ -212,14 +218,19 @@ :io-bindings io-bindings :debugger-hoook hook)) -(defmethod env-internals:environment-display-notifier +(defmethod env-internals:environment-display-notifier ((env slime-env) &key restarts condition) - (declare (ignore restarts)) - (funcall (slot-value env 'debugger-hook) condition *debugger-hook*)) + (declare (ignore restarts condition)) + ;;(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*) + (values t nil) + ) (defmethod env-internals:environment-display-debugger ((env slime-env)) *debug-io*) +(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) + (apply (swank-sym :y-or-n-p-in-emacs) msg args)) + (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook)) (env:with-environment ((slime-env hook '())) @@ -229,19 +240,6 @@ (setq *debugger-hook* function) (setf (env:environment) (slime-env function '()))) -(defmethod env-internals:environment-display-notifier - ((env slime-env) &key restarts condition) - (declare (ignore restarts)) - ;;(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*) - (values t nil) - ) - -(defmethod env-internals:environment-display-debugger ((env slime-env)) - *debug-io*) - -(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) - (apply (swank-sym :y-or-n-p-in-emacs) msg args)) - (defvar *sldb-top-frame*) (defun interesting-frame-p (frame) From heller at common-lisp.net Sat Aug 9 19:57:23 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:57:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195723.202BD3C207@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20706 Modified Files: ChangeLog swank.lisp Log Message: Fixes for heap dumping. * swank.lisp (*log-output*): Don't initialize at load-time, otherwise the stream would end up in a heap image. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:17 1.1425 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:22 1.1426 @@ -18,6 +18,13 @@ 2008-08-09 Helmut Eller + Fixes for heap dumping. + + * swank.lisp (*log-output*): Don't initialize at load-time, + otherwise the stream would end up in a heap image. + +2008-08-09 Helmut Eller + * swank-lispworks.lisp (defimplementation): Record location. 2008-08-09 Helmut Eller --- /project/slime/cvsroot/slime/swank.lisp 2008/08/09 19:57:12 1.559 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/09 19:57:22 1.560 @@ -374,12 +374,18 @@ ;;;;; Logging (defvar *log-events* nil) -(defvar *log-output* - (labels ((ref (x) +(defvar *log-output* nil) ; should be nil for image dumpers + +(defun init-log-output () + (labels ((deref (x) (cond ((typep x 'synonym-stream) - (ref (symbol-value (synonym-stream-symbol x)))) + (deref (symbol-value (synonym-stream-symbol x)))) (t x)))) - (ref *error-output*))) + (unless *log-output* + (setq *log-output* (deref *error-output*))))) + +(add-hook *after-init-hook* 'init-log-output) + (defvar *event-history* (make-array 40 :initial-element nil) "A ring buffer to record events for better error messages.") (defvar *event-history-index* 0) @@ -611,6 +617,7 @@ (defun setup-server (port announce-fn style dont-close external-format) (declare (type function announce-fn)) + (init-log-output) (let* ((socket (create-socket *loopback-interface* port)) (local-port (local-port socket))) (funcall announce-fn local-port) From heller at common-lisp.net Sat Aug 9 19:57:31 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:57:31 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195731.C16245D1C1@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20740 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-quit-lisp): Optionally send kill signal. (slime-quit-connection-at-point): Disconnect after some timeout. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:22 1.1426 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:31 1.1427 @@ -18,6 +18,11 @@ 2008-08-09 Helmut Eller + * slime.el (slime-quit-lisp): Optionally send kill signal. + (slime-quit-connection-at-point): Disconnect after some timeout. + +2008-08-09 Helmut Eller + Fixes for heap dumping. * swank.lisp (*log-output*): Don't initialize at load-time, --- /project/slime/cvsroot/slime/slime.el 2008/08/09 19:57:06 1.980 +++ /project/slime/cvsroot/slime/slime.el 2008/08/09 19:57:31 1.981 @@ -2319,6 +2319,7 @@ ((:write-string output &optional target) (slime-write-string output target)) ((:emacs-rex form package thread continuation) + (slime-check-eval-form form) (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) (message "; pipelined request... %S" form)) (let ((id (incf (slime-continuation-counter)))) @@ -6459,14 +6460,18 @@ (defun slime-quit () (error "Not implemented properly. Use `slime-interrupt' instead.")) -(defun slime-quit-lisp (&optional keep-buffers) +(defun slime-quit-lisp (&optional kill) "Quit lisp, kill the inferior process and associated buffers." - (interactive) + (interactive "P") (slime-eval-async '(swank:quit-lisp)) - (let ((connection (slime-connection))) + (let* ((connection (slime-connection)) + (process (slime-inferior-process connection))) (kill-buffer (slime-output-buffer)) (set-process-filter connection nil) - (set-process-sentinel connection 'slime-quit-sentinel))) + (set-process-sentinel connection 'slime-quit-sentinel) + (when (and kill process) + (sleep-for 0.2) + (kill-process process)))) (defun slime-quit-sentinel (process message) (assert (process-status process) 'closed) @@ -7476,9 +7481,13 @@ (defun slime-quit-connection-at-point (connection) (interactive (list (slime-connection-at-point))) - (let ((slime-dispatching-connection connection)) - (slime-quit-lisp) + (let ((slime-dispatching-connection connection) + (end (time-add (current-time) (seconds-to-time 3)))) + (slime-quit-lisp t) (while (memq connection slime-net-processes) + (when (time-less-p end (current-time)) + (message "Quit timeout expired. Disconnecting.") + (delete-process connection)) (sit-for 0 100))) (slime-update-connection-list)) From heller at common-lisp.net Sat Aug 9 19:57:38 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 15:57:38 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809195738.2D4C4A146@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20788 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:31 1.1427 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:37 1.1428 @@ -1,21 +1,3 @@ -2008-08-09 Tobias C. Rittweiler - - M-x slime doesn't destroy the window layout anymore when you - switch windows/frames while the connection is being set up. - - * slime.el (slime-hide-inferior-lisp-buffer): Search for the - inferior-lisp buffer's window in all frames. - (slime-repl-update-banner): Do not pop to the REPL buffer. - -2008-08-08 Tobias C. Rittweiler - - * slime.el: Fixing `q' in Xref buffers. - - (slime-popup-buffer-snapshot-unchanged-p): New. - (slime-popup-buffer-restore-snapshot): New. - (slime-xref-quit): Can't use slime-popup-buffer directly. Instead - implement its own quit behaviour using the above functions. - 2008-08-09 Helmut Eller * slime.el (slime-quit-lisp): Optionally send kill signal. @@ -38,7 +20,8 @@ 2008-08-09 Helmut Eller - Display the "Use default debugger" restart more prominently. + Display the "Use default debugger" restart more prominently + for testing. * swank.lisp (swank-debugger-hook): Bind a user visible restart to invoke the native debugger. @@ -62,6 +45,24 @@ * swank-lispworks.lisp (disassemble-frame): Implemented. +2008-08-09 Tobias C. Rittweiler + + M-x slime doesn't destroy the window layout anymore when you + switch windows/frames while the connection is being set up. + + * slime.el (slime-hide-inferior-lisp-buffer): Search for the + inferior-lisp buffer's window in all frames. + (slime-repl-update-banner): Do not pop to the REPL buffer. + +2008-08-08 Tobias C. Rittweiler + + * slime.el: Fixing `q' in Xref buffers. + + (slime-popup-buffer-snapshot-unchanged-p): New. + (slime-popup-buffer-restore-snapshot): New. + (slime-xref-quit): Can't use slime-popup-buffer directly. Instead + implement its own quit behaviour using the above functions. + 2008-08-08 Helmut Eller Use wait-for-event instead of catch/throw where needed. From heller at common-lisp.net Sat Aug 9 20:15:09 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Aug 2008 16:15:09 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080809201509.829BF4E01C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv30190 Modified Files: slime.el Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/slime.el 2008/08/09 19:57:31 1.981 +++ /project/slime/cvsroot/slime/slime.el 2008/08/09 20:15:09 1.982 @@ -2319,7 +2319,6 @@ ((:write-string output &optional target) (slime-write-string output target)) ((:emacs-rex form package thread continuation) - (slime-check-eval-form form) (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) (message "; pipelined request... %S" form)) (let ((id (incf (slime-continuation-counter)))) From heller at common-lisp.net Mon Aug 11 07:36:55 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:36:55 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073655.B9C603700D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17883 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (invoke-slime-debugger): New function. Analagous to cl:invoke-debugger. (swank-debugger-hook): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/09 19:57:37 1.1428 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:36:52 1.1429 @@ -1,3 +1,9 @@ +2008-08-10 Helmut Eller + + * swank.lisp (invoke-slime-debugger): New function. + Analagous to cl:invoke-debugger. + (swank-debugger-hook): Use it. + 2008-08-09 Helmut Eller * slime.el (slime-quit-lisp): Optionally send kill signal. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/09 19:57:22 1.560 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:36:52 1.561 @@ -22,6 +22,7 @@ #:ed-in-emacs #:inspect-in-emacs #:print-indentation-lossage + #:invoke-slime-debugger #:swank-debugger-hook #:emacs-inspect ;;#:inspect-slot-for-emacs @@ -1986,23 +1987,25 @@ ;;;; Debugger -(defun swank-debugger-hook (condition hook) - "Debugger function for binding *DEBUGGER-HOOK*. -Sends a message to Emacs declaring that the debugger has been entered, +(defun invoke-slime-debugger (condition) + "Sends a message to Emacs declaring that the debugger has been entered, then waits to handle further requests from Emacs. Eventually returns after Emacs causes a restart to be invoked." - (declare (ignore hook)) (without-slime-interrupts - (restart-case - (cond (*emacs-connection* - (debug-in-emacs condition)) - ((default-connection) - (with-connection ((default-connection)) - (debug-in-emacs condition)))) - (default-debugger (&optional v) - :report "Use default debugger." (declare (ignore v)) - (let ((*debugger-hook* nil)) - (invoke-debugger condition)))))) + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition)))))) + +(defun swank-debugger-hook (condition hook) + "Debugger function for binding *DEBUGGER-HOOK*." + (declare (ignore hook)) + (restart-case (invoke-slime-debugger condition) + (default-debugger (&optional v) + :report "Use default debugger." (declare (ignore v)) + (let ((*debugger-hook* nil)) + (invoke-debugger condition))))) (defvar *global-debugger* nil "Non-nil means the Swank debugger hook will be installed globally.") From heller at common-lisp.net Mon Aug 11 07:37:09 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:37:09 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073709.466A8471BC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17906 Modified Files: ChangeLog swank-backend.lisp swank-cmucl.lisp swank-lispworks.lisp swank-sbcl.lisp swank.lisp Log Message: * swank.lisp (wait-for-event): Add timeout argument. This is used for :fd-handler and :sigio style where we only process events as long we don't block. (wait-for-event/event-loop, read-event) (decode-message, receive-if): Ditto. (process-events): Renamed from read-from-emacs. (handle-requests): Renamed from handle-request. Take timeout argument. Update callers. (process-available-input): Deleted. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:36:52 1.1429 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:01 1.1430 @@ -1,5 +1,17 @@ 2008-08-10 Helmut Eller + * swank.lisp (wait-for-event): Add timeout argument. This is used + for :fd-handler and :sigio style where we only process events as + long we don't block. + (wait-for-event/event-loop, read-event) + (decode-message, receive-if): Ditto. + (process-events): Renamed from read-from-emacs. + (handle-requests): Renamed from handle-request. Take timeout + argument. Update callers. + (process-available-input): Deleted. + +2008-08-10 Helmut Eller + * swank.lisp (invoke-slime-debugger): New function. Analagous to cl:invoke-debugger. (swank-debugger-hook): Use it. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/08 19:42:51 1.142 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/11 07:37:01 1.143 @@ -998,11 +998,11 @@ (definterface send (thread object) "Send OBJECT to thread THREAD.") -(definterface receive () +(definterface receive (&optional timeout) "Return the next message from current thread's mailbox." - (receive-if (constantly t))) + (receive-if (constantly t) timeout)) -(definterface receive-if (predicate) +(definterface receive-if (predicate &optional timeout) "Return the first message satisfiying PREDICATE.") (defvar *pending-slime-interrupts*) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/07 07:53:47 1.184 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/11 07:37:02 1.185 @@ -2102,12 +2102,10 @@ (mp:with-lock-held ((mailbox.mutex mbox)) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message)))))) - - (defimplementation receive () - (receive-if (constantly t))) - (defimplementation receive-if (test) + (defimplementation receive-if (test &optional timeout) (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-lock-held ((mailbox.mutex mbox)) @@ -2117,6 +2115,7 @@ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))))) + (when (eq timeout t) (return (values nil t))) (mp:process-wait-with-timeout "receive-if" 0.5 (lambda () (some test (mailbox.queue mbox))))))) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/09 19:57:17 1.111 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/11 07:37:05 1.112 @@ -764,12 +764,10 @@ (setf (getf (mp:process-plist thread) 'mailbox) (make-mailbox))))) -(defimplementation receive () - (receive-if (constantly t))) - -(defimplementation receive-if (test) +(defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox mp:*current-process*)) (lock (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-lock (lock "receive-if/try") @@ -778,6 +776,7 @@ (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))))) + (when (eq timeout t) (return (values nil t))) (mp:process-wait-with-timeout "receive-if" 0.2 (lambda () (some test (mailbox.queue mbox))))))) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/09 19:57:00 1.211 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/11 07:37:06 1.212 @@ -1300,12 +1300,10 @@ (nconc (mailbox.queue mbox) (list message))) (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) - (defimplementation receive () - (receive-if (constantly t))) - - (defimplementation receive-if (test) + (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox (current-thread))) (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (sb-thread:with-mutex (mutex) @@ -1314,6 +1312,7 @@ (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail)))) + (when (eq timeout t) (return (values nil t))) (handler-case (sb-ext:with-timeout 0.2 (sb-thread:condition-wait (mailbox.waitqueue mbox) mutex)) --- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:36:52 1.561 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:07 1.562 @@ -816,15 +816,28 @@ (defvar *sldb-quit-restart* 'abort "What restart should swank attempt to invoke when the user sldb-quits.") -(defun handle-request (connection) - "Read and process one request. The processing is done in the extent -of the toplevel restart." +(defun handle-requests (connection &optional timeout just-one) + "Read and process requests. +The processing is done in the extent of the toplevel restart." (assert (null *swank-state-stack*)) (let ((*swank-state-stack* '(:handle-request))) (with-connection (connection) - (with-simple-restart (abort "Return to SLIME's top level.") - (let ((*sldb-quit-restart* (find-restart 'abort))) - (read-from-emacs)))))) + (progn ; with-reader-error-handler (connection) + (loop + (with-simple-restart (abort "Return to SLIME's top level.") + (let* ((*sldb-quit-restart* (find-restart 'abort)) + (timeout? (process-requests timeout just-one))) + (when (or just-one timeout?) + (return))))))))) + +(defun process-requests (timeout just-one) + "Read and process requests from Emacs." + (loop + (multiple-value-bind (event timeout?) + (wait-for-event `(:emacs-rex . _) timeout) + (when timeout? (return t)) + (apply #'eval-for-emacs (cdr event)) + (when just-one (return nil))))) (defun current-socket-io () (connection.socket-io *emacs-connection*)) @@ -981,7 +994,7 @@ (defun spawn-worker-thread (connection) (spawn (lambda () (with-bindings *default-worker-thread-bindings* - (handle-request connection))) + (handle-requests connection nil t))) :name "worker")) (defun spawn-repl-thread (connection name) @@ -1024,10 +1037,10 @@ (cond ((use-threads-p) (send thread event)) (t (setf *event-queue* (nconc *event-queue* (list event)))))) -(defun read-event () +(defun read-event (&optional timeout) (log-event "read-event: ~a~%" (current-socket-io)) - (cond ((use-threads-p) (receive)) - (t (decode-message (current-socket-io))))) + (cond ((use-threads-p) (receive timeout)) + (t (decode-message (current-socket-io) timeout)))) (defun send-to-emacs (event) "Send EVENT to Emacs." @@ -1040,15 +1053,16 @@ (cond ((use-threads-p) (interrupt-thread thread interrupt)) (t (funcall interrupt)))) -(defun wait-for-event (pattern) - (log-event "wait-for-event: ~s~%" pattern) +(defun wait-for-event (pattern &optional timeout) + (log-event "wait-for-event: ~s ~s~%" pattern timeout) (cond ((use-threads-p) (without-slime-interrupts - (receive-if (lambda (e) (event-match-p e pattern))))) + (receive-if (lambda (e) (event-match-p e pattern)) timeout))) (t - (wait-for-event/event-loop pattern)))) + (wait-for-event/event-loop pattern timeout)))) -(defun wait-for-event/event-loop (pattern) +(defun wait-for-event/event-loop (pattern timeout) + (assert (or (not timeout) (eq timeout t))) (loop (let ((tail (member-if (lambda (e) (event-match-p e pattern)) *event-queue*))) @@ -1056,7 +1070,10 @@ (setq *event-queue* (nconc (ldiff *event-queue* tail) (cdr tail))) (return (car tail)))) - (dispatch-event (read-event)))) + (multiple-value-bind (event timeout?) (read-event timeout) + (log-event "read-event-> ~a ~a~%" event timeout?) + (when timeout? (return (values nil t))) + (dispatch-event event)))) (defun event-match-p (event pattern) (log-event "event-match-p: ~s ~s~%" event pattern) @@ -1095,21 +1112,7 @@ (kill-thread thread))))) (defun repl-loop (connection) - (loop (handle-request connection))) - -(defun process-available-input (stream fn) - (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)))) + (handle-requests connection)) ;;;;;; Signal driven IO @@ -1117,11 +1120,9 @@ (let ((client (connection.socket-io connection))) (flet ((handler () (cond ((null *swank-state-stack*) - (with-reader-error-handler (connection) - (process-available-input - client (lambda () (handle-request connection))))) + (handle-requests connection t)) ((eq (car *swank-state-stack*) :read-next-form)) - (t (process-available-input client #'read-from-emacs))))) + (t (process-requests t nil))))) (add-sigio-handler client #'handler) (handler)))) @@ -1134,12 +1135,9 @@ (let ((client (connection.socket-io connection))) (flet ((handler () (cond ((null *swank-state-stack*) - (with-reader-error-handler (connection) - (process-available-input - client (lambda () (handle-request connection))))) + (handle-requests connection t)) ((eq (car *swank-state-stack*) :read-next-form)) - (t - (process-available-input client #'read-from-emacs))))) + (t (process-requests t nil))))) ;;;; handle sigint ;;(install-debugger-globally ;; (lambda (c h) @@ -1160,9 +1158,7 @@ (defun simple-serve-requests (connection) (unwind-protect (with-simple-restart (close-connection "Close SLIME connection") - (with-reader-error-handler (connection) - (loop - (handle-request connection)))) + (handle-requests connection)) (close-connection connection nil (safe-backtrace)))) (defun initialize-streams-for-connection (connection) @@ -1389,12 +1385,11 @@ (defmacro with-thread-description (description &body body) `(call-with-thread-description ,description #'(lambda () , at body))) -(defun read-from-emacs () - "Read and process a request from Emacs." - (apply #'eval-for-emacs (cdr (wait-for-event `(:emacs-rex . _))))) - -(defun decode-message (stream) +(defun decode-message (stream &optional timeout) "Read an S-expression from STREAM using the SLIME protocol." + (assert (or (not timeout) (eq timeout t))) + (when (and (eq timeout t) (not (input-available-p stream))) + (return-from decode-message (values nil t))) (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*))) (handler-bind ((error (lambda (c) (error (make-swank-error c))))) (let* ((length (decode-message-length stream)) @@ -1403,7 +1398,7 @@ (assert (= pos length) () "Short read: length=~D pos=~D" length pos) (log-event "READ: ~S~%" string) - (read-form string))))) + (values (read-form string) nil))))) (defun decode-message-length (stream) (let ((buffer (make-string 6))) @@ -1416,6 +1411,16 @@ (let ((*package* *swank-io-package*)) (read-from-string string)))) +(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)))) + (defvar *slime-features* nil "The feature list that has been sent to Emacs.") @@ -2059,7 +2064,7 @@ (debugger-info-for-emacs 0 *sldb-initial-frames*))) (loop (send-to-emacs (list :debug-activate (current-thread-id) level nil)) - (handler-case (read-from-emacs) + (handler-case (process-requests nil t) (sldb-condition (c) (handle-sldb-condition c)))))) (send-to-emacs `(:debug-return From heller at common-lisp.net Mon Aug 11 07:37:26 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:37:26 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073726.DF8AB53193@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17980 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (wait-for-event): Add timeout argument. This is used for :fd-handler and :sigio style where we only process events as long as we don't block. (wait-for-event/event-loop, read-event) (decode-message, receive-if): Ditto. (process-requests): Renamed from read-from-emacs. (handle-requests): Renamed from handle-request. Take timeout argument. Update callers. (process-available-input): Deleted. (with-swank-error-handler): Renamed from with-reader-error-handler. (with-connection): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:01 1.1430 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:15 1.1431 @@ -2,13 +2,16 @@ * swank.lisp (wait-for-event): Add timeout argument. This is used for :fd-handler and :sigio style where we only process events as - long we don't block. + long as we don't block. (wait-for-event/event-loop, read-event) (decode-message, receive-if): Ditto. - (process-events): Renamed from read-from-emacs. + (process-requests): Renamed from read-from-emacs. (handle-requests): Renamed from handle-request. Take timeout argument. Update callers. (process-available-input): Deleted. + (with-swank-error-handler): Renamed from + with-reader-error-handler. + (with-connection): Use it. 2008-08-10 Helmut Eller --- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:07 1.562 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:16 1.563 @@ -281,6 +281,32 @@ (call-with-debugging-environment (lambda () (backtrace 0 nil))))) +(defvar *debug-on-swank-error* nil + "When non-nil invoke the system debugger on swank internal errors. +Do not set this to T unless you want to debug swank internals.") + +(defmacro with-swank-error-handler ((connection) &body body) + (let ((var (gensym))) + `(let ((,var ,connection)) + (handler-case + (handler-bind ((swank-error + (lambda (condition) + (when *debug-on-swank-error* + (invoke-default-debugger condition))))) + (progn , at body)) + (swank-error (condition) + (close-connection ,var + (swank-error.condition condition) + (swank-error.backtrace condition))))))) + +(defmacro with-panic-handler ((connection) &body body) + (let ((var (gensym))) + `(let ((,var ,connection)) + (handler-bind ((serious-condition + (lambda (condition) + (close-connection ,var condition (safe-backtrace))))) + . ,body)))) + (add-hook *new-connection-hook* 'notify-backend-of-connection) (defun notify-backend-of-connection (connection) (declare (ignore connection)) @@ -305,10 +331,11 @@ "Execute BODY in the context of CONNECTION." `(call-with-connection ,connection (lambda () , at body))) -(defun call-with-connection (connection fun) +(defun call-with-connection (connection function) (let ((*emacs-connection* connection)) - (with-io-redirection (*emacs-connection*) - (call-with-debugger-hook #'swank-debugger-hook fun)))) + (with-swank-error-handler (*emacs-connection*) + (with-io-redirection (*emacs-connection*) + (call-with-debugger-hook #'swank-debugger-hook function))))) (defmacro without-interrupts (&body body) `(call-without-interrupts (lambda () , at body))) @@ -822,13 +849,12 @@ (assert (null *swank-state-stack*)) (let ((*swank-state-stack* '(:handle-request))) (with-connection (connection) - (progn ; with-reader-error-handler (connection) - (loop - (with-simple-restart (abort "Return to SLIME's top level.") - (let* ((*sldb-quit-restart* (find-restart 'abort)) - (timeout? (process-requests timeout just-one))) - (when (or just-one timeout?) - (return))))))))) + (loop + (with-simple-restart (abort "Return to SLIME's top level.") + (let* ((*sldb-quit-restart* (find-restart 'abort)) + (timeout? (process-requests timeout just-one))) + (when (or just-one timeout?) + (return)))))))) (defun process-requests (timeout just-one) "Read and process requests from Emacs." @@ -870,27 +896,6 @@ *use-dedicated-output-stream*) (finish-output *log-output*))) -(defvar *debug-on-swank-error* nil - "When non-nil internal swank errors will drop to a - debugger (not an sldb buffer). Do not set this to T unless you - want to debug swank internals.") - -(defmacro with-reader-error-handler ((connection) &body body) - (let ((var (gensym))) - `(let ((,var ,connection)) - (handler-case (progn , at body) - (swank-error (condition) - (close-connection ,var - (swank-error.condition condition) - (swank-error.backtrace condition))))))) - -(defmacro with-panic-handler (&body body) - `(handler-bind ((serious-condition - (lambda (condition) - (close-connection *emacs-connection* condition - (safe-backtrace))))) - . ,body)) - (defvar *slime-interrupts-enabled*) (defmacro with-slime-interrupts (&body body) @@ -934,12 +939,12 @@ (defun read-loop (connection) (let ((input-stream (connection.socket-io connection)) (control-thread (connection.control-thread connection))) - (with-reader-error-handler (connection) + (with-swank-error-handler (connection) (loop (send control-thread (decode-message input-stream)))))) (defun dispatch-loop (connection) (let ((*emacs-connection* connection)) - (with-panic-handler + (with-panic-handler (connection) (loop (dispatch-event (read-event)))))) (defvar *auto-flush-interval* 0.2) @@ -1038,7 +1043,6 @@ (t (setf *event-queue* (nconc *event-queue* (list event)))))) (defun read-event (&optional timeout) - (log-event "read-event: ~a~%" (current-socket-io)) (cond ((use-threads-p) (receive timeout)) (t (decode-message (current-socket-io) timeout)))) @@ -1071,12 +1075,10 @@ (nconc (ldiff *event-queue* tail) (cdr tail))) (return (car tail)))) (multiple-value-bind (event timeout?) (read-event timeout) - (log-event "read-event-> ~a ~a~%" event timeout?) (when timeout? (return (values nil t))) (dispatch-event event)))) (defun event-match-p (event pattern) - (log-event "event-match-p: ~s ~s~%" event pattern) (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) (member pattern '(nil t))) (equal event pattern)) @@ -2009,9 +2011,12 @@ (restart-case (invoke-slime-debugger condition) (default-debugger (&optional v) :report "Use default debugger." (declare (ignore v)) - (let ((*debugger-hook* nil)) - (invoke-debugger condition))))) + (invoke-default-debugger)))) +(defun invoke-default-debugger (condition) + (let ((*debugger-hook* nil)) + (invoke-debugger condition))) + (defvar *global-debugger* nil "Non-nil means the Swank debugger hook will be installed globally.") From heller at common-lisp.net Mon Aug 11 07:37:32 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:37:32 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073732.4DAF36F24E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18010 Modified Files: swank.lisp Log Message: (swank-debugger-hook): Fix last change. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:16 1.563 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:31 1.564 @@ -2011,7 +2011,7 @@ (restart-case (invoke-slime-debugger condition) (default-debugger (&optional v) :report "Use default debugger." (declare (ignore v)) - (invoke-default-debugger)))) + (invoke-default-debugger condition)))) (defun invoke-default-debugger (condition) (let ((*debugger-hook* nil)) From heller at common-lisp.net Mon Aug 11 07:37:43 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:37:43 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073743.75F3421059@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18031 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-execute-tests): Call slime-test-should-fail-p before executing the test (which may close the connection). --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:15 1.1431 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:38 1.1432 @@ -1,5 +1,10 @@ 2008-08-10 Helmut Eller + * slime.el (slime-execute-tests): Call slime-test-should-fail-p + before executing the test (which may close the connection). + +2008-08-10 Helmut Eller + * swank.lisp (wait-for-event): Add timeout argument. This is used for :fd-handler and :sigio style where we only process events as long as we don't block. --- /project/slime/cvsroot/slime/slime.el 2008/08/09 20:15:09 1.982 +++ /project/slime/cvsroot/slime/slime.el 2008/08/11 07:37:40 1.983 @@ -2221,11 +2221,11 @@ (sexp package) ((:ok value) (unless (member tag slime-stack-eval-tags) - (error "tag = %S eval-tags = %S sexp = %S" + (error "Reply to canceled synchronous eval request tag=%S sexp=%S" tag slime-stack-eval-tags sexp)) (throw tag (list #'identity value))) ((:abort) - (throw tag (list #'error "Synchronous Lisp Evaluation aborted.")))) + (throw tag (list #'error "Synchronous Lisp Evaluation aborted")))) (let ((debug-on-quit t) (inhibit-quit nil) (conn (slime-connection))) @@ -8388,7 +8388,7 @@ The results are presented in an outline-mode buffer, with the tests that succeeded initially folded away." (interactive) - (assert (not (slime-busy-p))) + (assert (slime-at-top-level-p) () "Pending RPCs or open debuggers.") (slime-create-test-results-buffer) (unwind-protect (slime-execute-tests) @@ -8439,26 +8439,29 @@ (let ((debug-on-error t) (debug-on-quit t)) (apply function input)) - (condition-case err - (apply function input) - (error - (cond ((slime-test-should-fail-p slime-current-test) - (incf slime-expected-failures) - (slime-test-failure "ERROR (expected)" - (format "%S" err))) - (t - (incf slime-unexpected-failures) - (slime-print-check-error err))))))))) - (let ((summary (cond ((and (zerop slime-expected-failures) - (zerop slime-unexpected-failures)) - (format "All %S tests completed successfully." - slime-total-tests)) - (t - (format "Failed on %S (%S expected) of %S tests." - (+ slime-expected-failures - slime-unexpected-failures) - slime-expected-failures - slime-total-tests))))) + (let ((should-fail-p + (slime-test-should-fail-p slime-current-test))) + (condition-case err + (apply function input) + (error + (cond (should-fail-p + (incf slime-expected-failures) + (slime-test-failure "ERROR (expected)" + (format "%S" err))) + (t + (incf slime-unexpected-failures) + (slime-print-check-error err)))))))))) + (let ((summary + (cond ((and (zerop slime-expected-failures) + (zerop slime-unexpected-failures)) + (format "All %S tests completed successfully." + slime-total-tests)) + (t + (format "Failed on %S (%S expected) of %S tests." + (+ slime-expected-failures + slime-unexpected-failures) + slime-expected-failures + slime-total-tests))))) (save-excursion (with-current-buffer slime-test-buffer-name (goto-char (point-min)) @@ -9214,13 +9217,13 @@ (and (slime-sldb-level= 1) (get-buffer-window (sldb-get-default-buffer)))) - 5) + 2) (with-current-buffer (sldb-get-default-buffer) (sldb-continue)) (slime-wait-condition "sldb closed" (lambda () (not (sldb-get-default-buffer))) 0.2))) - (slime-sync-to-top-level 5)))) + (slime-sync-to-top-level 2)))) (def-slime-test locally-bound-debugger-hook () @@ -9310,15 +9313,15 @@ (with-current-buffer (process-buffer p) (assert (< (buffer-size) 500) nil "Unusual output")) (slime-inferior-connect p (slime-inferior-lisp-args p)) - (lexical-let ((hook nil)) + (lexical-let ((hook nil) (p p)) (setq hook (lambda () + (slime-test-expect + "We are connected again" p (slime-inferior-process)) (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 slime-default-connection)))) + (slime-accept-process-output nil 0.1))))) ;;;; Utilities From heller at common-lisp.net Mon Aug 11 07:37:53 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:37:53 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073753.6C058210A5@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18078 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-execute-tests): Call slime-test-should-fail-p before executing the test (which may close the connection). (def-slime-test): Use slime-sync-to-top-level with a timeout. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:38 1.1432 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:49 1.1433 @@ -2,6 +2,7 @@ * slime.el (slime-execute-tests): Call slime-test-should-fail-p before executing the test (which may close the connection). + (def-slime-test): Use slime-sync-to-top-level with a timeout. 2008-08-10 Helmut Eller --- /project/slime/cvsroot/slime/slime.el 2008/08/11 07:37:40 1.983 +++ /project/slime/cvsroot/slime/slime.el 2008/08/11 07:37:50 1.984 @@ -8438,7 +8438,8 @@ (if slime-test-debug-on-error (let ((debug-on-error t) (debug-on-quit t)) - (apply function input)) + (catch 'skip + (apply function input))) (let ((should-fail-p (slime-test-should-fail-p slime-current-test))) (condition-case err @@ -8554,7 +8555,7 @@ `(progn (defun ,fname ,args ,doc - (slime-sync) + (slime-sync-to-top-level 0.3) , at body) (setq slime-tests (append (remove* ',name slime-tests :key 'slime-test.name) @@ -8702,12 +8703,11 @@ )) (slime-check-top-level)) - (def-slime-test find-definition (name buffer-package snippet) "Find the definition of a function or macro in swank.lisp." - '(("read-from-emacs" "SWANK" "(defun read-from-emacs ") - ("swank::read-from-emacs" "CL-USER" "(defun read-from-emacs ") + '(("start-server" "SWANK" "(defun start-server ") + ("swank::start-server" "CL-USER" "(defun start-server ") ("swank:start-server" "CL-USER" "(defun start-server ")) (switch-to-buffer "*scratch*") ; not buffer of definition (slime-check-top-level) @@ -9096,7 +9096,6 @@ 4) \(+ 2 3 4) SWANK> ")) - (slime-sync-to-top-level 2) (with-current-buffer (slime-output-buffer) (setf (slime-lisp-package-prompt-string) "SWANK")) (kill-buffer (slime-output-buffer)) @@ -9183,47 +9182,35 @@ (not (not (get-buffer-window (current-buffer))))))) (def-slime-test break - (times) - "Test if BREAK invokes SLDB." - '((1) (2) (3)) - (slime-accept-process-output nil 1) - (slime-check-top-level) - (let ((tests - `((cl-user::foo . (defun cl-user::foo () - (dotimes (i ,times) - (break) - (sleep 0.2)))) + (times exp) + "Test whether BREAK invokes SLDB." + (let ((exp1 '(break)) + (exp2 ;; Backends should arguably make sure that BREAK does not ;; depend on *DEBUGGER-HOOK*. - (cl-user::bar . (defun cl-user::bar () - (block outta - (let ((*debugger-hook* - #'(lambda (c hook) - (declare (ignore c hook)) - (return-from outta 42)))) - (dotimes (i ,times) - (break) - (sleep 0.2)))))) - ))) - (dolist (test tests) - (let ((name (car test)) - (definition (cdr test))) - (slime-compile-string (prin1-to-string definition) 0) - (slime-sync-to-top-level 2) - (slime-eval-async `(,name)) - (dotimes (i times) - (slime-wait-condition "Debugger visible" - (lambda () - (and (slime-sldb-level= 1) - (get-buffer-window - (sldb-get-default-buffer)))) - 2) - (with-current-buffer (sldb-get-default-buffer) - (sldb-continue)) - (slime-wait-condition "sldb closed" - (lambda () (not (sldb-get-default-buffer))) - 0.2))) - (slime-sync-to-top-level 2)))) + '(block outta + (let ((*debugger-hook* (lambda (c h) (return-from outta 42)))) + (break))))) + `((1 ,exp1) (2 ,exp1) (3 ,exp1) + (1 ,exp2) (2 ,exp2) (3 ,exp2))) + (slime-accept-process-output nil 0.2) + (slime-check-top-level) + (slime-eval-async + `(cl:eval (cl:read-from-string + ,(prin1-to-string `(dotimes (i ,times) ,exp (sleep 0.2)))))) + (dotimes (i times) + (slime-wait-condition "Debugger visible" + (lambda () + (and (slime-sldb-level= 1) + (get-buffer-window + (sldb-get-default-buffer)))) + 1) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "sldb closed" + (lambda () (not (sldb-get-default-buffer))) + 0.2)) + (slime-sync-to-top-level 1)) (def-slime-test locally-bound-debugger-hook () From heller at common-lisp.net Mon Aug 11 07:38:40 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:38:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073840.E2D706A122@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18126 Modified Files: ChangeLog slime.el Log Message: Save repl-history in /tmp, during testing. (slime-temp-directory): New function. (slime-run-tests): Save repl-history in /tmp. (slime-repl-mode): Ignore persistent history if slime-repl-history-file is nil. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:37:49 1.1433 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:38:04 1.1434 @@ -3,6 +3,10 @@ * slime.el (slime-execute-tests): Call slime-test-should-fail-p before executing the test (which may close the connection). (def-slime-test): Use slime-sync-to-top-level with a timeout. + (slime-temp-directory): New function. + (slime-run-tests): Save repl-history in /tmp. + (slime-repl-mode): Ignore persistent history if + slime-repl-history-file is nil. 2008-08-10 Helmut Eller --- /project/slime/cvsroot/slime/slime.el 2008/08/11 07:37:50 1.984 +++ /project/slime/cvsroot/slime/slime.el 2008/08/11 07:38:05 1.985 @@ -1371,12 +1371,14 @@ (defun slime-swank-port-file () "Filename where the SWANK server writes its TCP port number." - (concat (file-name-as-directory - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - (t "/tmp/"))) + (concat (file-name-as-directory (slime-temp-directory)) (format "slime.%S" (emacs-pid)))) +(defun slime-temp-directory () + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + (defun slime-delete-swank-port-file (&optional quiet) (condition-case data (delete-file (slime-swank-port-file)) @@ -2840,8 +2842,9 @@ (setq slime-current-thread :repl-thread) (set (make-local-variable 'scroll-conservatively) 20) (set (make-local-variable 'scroll-margin) 0) - (slime-repl-safe-load-history) - (add-local-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history) + (when slime-repl-history-file + (slime-repl-safe-load-history) + (add-local-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history)) (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories) (slime-setup-command-hooks) ;; At the REPL, we define beginning-of-defun and end-of-defun to be @@ -8391,7 +8394,9 @@ (assert (slime-at-top-level-p) () "Pending RPCs or open debuggers.") (slime-create-test-results-buffer) (unwind-protect - (slime-execute-tests) + (let ((slime-repl-history-file + (expand-file-name "slime-repl-history" (slime-temp-directory)))) + (slime-execute-tests)) (pop-to-buffer slime-test-buffer-name) (goto-char (point-min)) (hide-body) From heller at common-lisp.net Mon Aug 11 07:39:05 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:39:05 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073905.1E66311CE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18392 Modified Files: ChangeLog slime.el Log Message: (slime-quit-lisp-internal): New function. (slime-quit-lisp, slime-restart-inferior-lisp): Use it --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:38:04 1.1434 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:02 1.1435 @@ -7,6 +7,8 @@ (slime-run-tests): Save repl-history in /tmp. (slime-repl-mode): Ignore persistent history if slime-repl-history-file is nil. + (slime-quit-lisp-internal): New function. + (slime-quit-lisp, slime-restart-inferior-lisp): Use it 2008-08-10 Helmut Eller --- /project/slime/cvsroot/slime/slime.el 2008/08/11 07:38:05 1.985 +++ /project/slime/cvsroot/slime/slime.el 2008/08/11 07:39:02 1.986 @@ -3768,9 +3768,7 @@ (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) - (set-process-sentinel (slime-connection) 'slime-restart-sentinel)) + (slime-quit-lisp-internal (slime-connection) 'slime-restart-sentinel t)) (defun slime-restart-sentinel (process message) "Restart the inferior lisp process. @@ -6465,15 +6463,18 @@ (defun slime-quit-lisp (&optional kill) "Quit lisp, kill the inferior process and associated buffers." (interactive "P") - (slime-eval-async '(swank:quit-lisp)) - (let* ((connection (slime-connection)) - (process (slime-inferior-process connection))) - (kill-buffer (slime-output-buffer)) - (set-process-filter connection nil) - (set-process-sentinel connection 'slime-quit-sentinel) - (when (and kill process) - (sleep-for 0.2) - (kill-process process)))) + (slime-quit-lisp-internal (slime-connection) 'slime-quit-sentinel kill)) + +(defun slime-quit-lisp-internal (connection sentinel kill) + (let ((slime-dispatching-connection connection)) + (slime-eval-async '(swank:quit-lisp)) + (let* ((process (slime-inferior-process connection))) + (kill-buffer (slime-output-buffer)) + (set-process-filter connection nil) + (set-process-sentinel connection sentinel) + (when (and kill process) + (sleep-for 0.2) + (kill-process process))))) (defun slime-quit-sentinel (process message) (assert (process-status process) 'closed) From heller at common-lisp.net Mon Aug 11 07:39:14 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:39:14 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073914.DF860232BD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18493 Modified Files: ChangeLog slime.el Log Message: (slime-batch-test): Exit, if the Lisp isn't up and running after 30 secs. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:02 1.1435 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:10 1.1436 @@ -9,6 +9,8 @@ slime-repl-history-file is nil. (slime-quit-lisp-internal): New function. (slime-quit-lisp, slime-restart-inferior-lisp): Use it + (slime-batch-test): Exit, if the Lisp isn't up and running after + 30 secs. 2008-08-10 Helmut Eller --- /project/slime/cvsroot/slime/slime.el 2008/08/11 07:39:02 1.986 +++ /project/slime/cvsroot/slime/slime.el 2008/08/11 07:39:10 1.987 @@ -8421,9 +8421,8 @@ slime-tests))) (read (completing-read "Test: " alist nil t)))) -(defun slime-test-should-fail-p (test) - (member (slime-lisp-implementation-name) - (slime-test.fails-for test))) +(defun slime-test-should-fail-p () + (member slime-lisp-under-test (slime-test.fails-for slime-current-test))) (defun slime-execute-tests () "Execute each test case with each input. @@ -8432,7 +8431,8 @@ (let ((slime-total-tests 0) (slime-expected-passes 0) (slime-unexpected-failures 0) - (slime-expected-failures 0)) + (slime-expected-failures 0) + (slime-lisp-under-test (slime-lisp-implementation-name))) (dolist (slime-current-test slime-tests) (with-struct (slime-test. name (function fname) inputs) slime-current-test @@ -8446,18 +8446,16 @@ (debug-on-quit t)) (catch 'skip (apply function input))) - (let ((should-fail-p - (slime-test-should-fail-p slime-current-test))) - (condition-case err - (apply function input) - (error - (cond (should-fail-p - (incf slime-expected-failures) - (slime-test-failure "ERROR (expected)" - (format "%S" err))) - (t - (incf slime-unexpected-failures) - (slime-print-check-error err)))))))))) + (condition-case err + (apply function input) + (error + (cond ((slime-test-should-fail-p) + (incf slime-expected-failures) + (slime-test-failure "ERROR (expected)" + (format "%S" err))) + (t + (incf slime-unexpected-failures) + (slime-print-check-error err))))))))) (let ((summary (cond ((and (zerop slime-expected-failures) (zerop slime-unexpected-failures)) @@ -8482,8 +8480,13 @@ (let ((slime-test-debug-on-error nil)) (slime) ;; Block until we are up and running. - (while (not (slime-connected-p)) - (sit-for 1)) + (let ((i 0)) + (while (not (slime-connected-p)) + (incf i) + (when (> i 30) + (with-temp-file results-file (insert "Failed to connect.")) + (kill-emacs 255)) + (sit-for 1))) (slime-sync-to-top-level 5) (switch-to-buffer "*scratch*") (let ((failed-tests (slime-run-tests))) @@ -8580,7 +8583,7 @@ (cons `(format , at test-name))))) (if (progn , at body) (slime-print-check-ok ,check-name) - (cond ((slime-test-should-fail-p slime-current-test) + (cond ((slime-test-should-fail-p) (incf slime-expected-failures) (slime-test-failure "FAIL (expected)" ,check-name)) (t @@ -9312,9 +9315,10 @@ "We are connected again" p (slime-inferior-process)) (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-wait-condition "Lisp restarted" + (lambda () + (not (member hook slime-connected-hook))) + 5)))) ;;;; Utilities From heller at common-lisp.net Mon Aug 11 07:39:16 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:39:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073916.D7B0C4507D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18574 Modified Files: swank-lispworks.lisp Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/11 07:37:05 1.112 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/11 07:39:15 1.113 @@ -221,8 +221,8 @@ (defmethod env-internals:environment-display-notifier ((env slime-env) &key restarts condition) (declare (ignore restarts condition)) - ;;(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*) - (values t nil) + (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*) + ;; nil ) (defmethod env-internals:environment-display-debugger ((env slime-env)) From heller at common-lisp.net Mon Aug 11 07:39:22 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:39:22 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073922.A3852671A4@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18687 Modified Files: ChangeLog Log Message: * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown threads. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:10 1.1436 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:21 1.1437 @@ -1,5 +1,8 @@ 2008-08-10 Helmut Eller + * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown + threads. + * slime.el (slime-execute-tests): Call slime-test-should-fail-p before executing the test (which may close the connection). (def-slime-test): Use slime-sync-to-top-level with a timeout. From heller at common-lisp.net Mon Aug 11 07:39:24 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:39:24 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073924.454F767045@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18721 Modified Files: swank-ecl.lisp Log Message: * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown threads. --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/08 13:43:33 1.25 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/11 07:39:23 1.26 @@ -441,6 +441,7 @@ (incf *thread-id-counter*))) (defparameter *thread-id-map* (make-hash-table)) + (defparameter *id-thread-map* (make-hash-table)) (defvar *thread-id-map-lock* (mp:make-lock :name "thread id map lock")) @@ -454,19 +455,22 @@ #'(lambda () (unwind-protect (mp:with-lock (*thread-id-map-lock*) - (setf (gethash id *thread-id-map*) thread)) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id)) (funcall fn) (mp:with-lock (*thread-id-map-lock*) + (remhash thread *id-thread-map*) (remhash id *thread-id-map*))))) (mp:process-enable thread))) (defimplementation thread-id (thread) (block thread-id (mp:with-lock (*thread-id-map-lock*) - (loop for id being the hash-key in *thread-id-map* - using (hash-value thread-pointer) - do (if (eq thread thread-pointer) - (return-from thread-id id)))))) + (or (gethash thread *id-thread-map*) + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id) + id))))) (defimplementation find-thread (id) (mp:with-lock (*thread-id-map-lock*) From heller at common-lisp.net Mon Aug 11 07:39:38 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:39:38 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811073938.38CAE461D2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18740 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (*global-debugger*): Change default back to t. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:21 1.1437 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:28 1.1438 @@ -1,3 +1,7 @@ +2008-08-11 Helmut Eller + + * swank.lisp (*global-debugger*): Change default back to t. + 2008-08-10 Helmut Eller * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown --- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:37:31 1.564 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:39:29 1.565 @@ -2017,7 +2017,7 @@ (let ((*debugger-hook* nil)) (invoke-debugger condition))) -(defvar *global-debugger* nil +(defvar *global-debugger* t "Non-nil means the Swank debugger hook will be installed globally.") (add-hook *new-connection-hook* 'install-debugger) From heller at common-lisp.net Mon Aug 11 07:40:28 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 03:40:28 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811074028.C838E6A122@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18810 Modified Files: ChangeLog swank-allegro.lisp swank-openmcl.lisp Log Message: * swank-openmcl.lisp (receive-if): Support timeout argument. * swank-allegro.lisp (receive-if): Ditto. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:39:28 1.1438 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:40:23 1.1439 @@ -1,5 +1,10 @@ 2008-08-11 Helmut Eller + * swank-openmcl.lisp (receive-if): Support timeout argument. + * swank-allegro.lisp (receive-if): Ditto. + +2008-08-11 Helmut Eller + * swank.lisp (*global-debugger*): Change default back to t. 2008-08-10 Helmut Eller --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/08 13:43:33 1.109 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/08/11 07:40:23 1.110 @@ -676,11 +676,9 @@ (nconc (mailbox.queue mbox) (list message))) (mp:open-gate (mailbox.gate mbox))))) -(defimplementation receive () - (receive-if (constantly t))) - -(defimplementation receive-if (test) +(defimplementation receive-if (test &optional timeout) (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-process-lock ((mailbox.lock mbox)) @@ -690,8 +688,9 @@ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))) (mp:close-gate (mailbox.gate mbox)))) - (mp:process-wait-with-timeout "receive-if" 0.5 - #'mp:gate-open-p (mailbox.gate mbox))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout "receive-if" 0.5 + #'mp:gate-open-p (mailbox.gate mbox))))) (defimplementation quit-lisp () (excl:exit 0 :quiet t)) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/08 13:43:33 1.131 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/11 07:40:23 1.132 @@ -953,12 +953,10 @@ (nconc (mailbox.queue mbox) (list message))) (ccl:signal-semaphore (mailbox.semaphore mbox))))) -(defimplementation receive () - (receive-if (constantly t))) - -(defimplementation receive-if (test) +(defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox ccl:*current-process*)) (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (ccl:with-lock-grabbed (mutex) @@ -968,6 +966,7 @@ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))))) + (when (eq timeout t) (return (values nil t))) (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 0.2)))) (defimplementation quit-lisp () From heller at common-lisp.net Mon Aug 11 17:41:48 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 13:41:48 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811174148.32DBE1D165@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21573 Modified Files: ChangeLog swank-abcl.lisp Log Message: * swank-abcl.lisp (preferred-communication-style): Return nil until we implement receive-if. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 07:40:23 1.1439 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:47 1.1440 @@ -1,5 +1,8 @@ 2008-08-11 Helmut Eller + * swank-abcl.lisp (preferred-communication-style): Return nil + until we implement receive-if. + * swank-openmcl.lisp (receive-if): Support timeout argument. * swank-allegro.lisp (receive-if): Ditto. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/08 13:43:33 1.50 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/11 17:41:47 1.51 @@ -117,14 +117,11 @@ (defimplementation preferred-communication-style () - :spawn) - - + nil) (defimplementation create-socket (host port) (ext:make-server-socket port)) - (defimplementation local-port (socket) (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket)) @@ -511,18 +508,39 @@ (defimplementation kill-thread (thread) (ext:destroy-thread thread)) +(defstruct mailbox + (mutex (ext:make-mutex)) + (queue '())) + (defun mailbox (thread) "Return THREAD's mailbox." (ext:with-thread-lock (*thread-props-lock*) (or (getf (gethash thread *thread-props*) 'mailbox) (setf (getf (gethash thread *thread-props*) 'mailbox) - (ext:make-mailbox))))) + (make-mailbox))))) (defimplementation send (thread object) - (ext:mailbox-send (mailbox thread) object)) - -(defimplementation receive () - (ext:mailbox-read (mailbox (ext:current-thread)))) + (let ((mbox (mailbox thread))) + (ext:with-mutex ((mailbox-mutex mbox)) + (setf (mailbox-queue mbox) + (nconc (mailbox-queue mbox) (list message)))))) + +#+(or) +(defimplementation receive-if (thread &optional timeout) + (let* ((mbox (mailbox (current-thread)))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + (ext:with-mutex ((mailbox-mutex mbox)) + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + ;;(java:jcall (java:jmethod "java.lang.Object" "wait") + ;; (mailbox-mutex mbox) 1000) + )))) (defimplementation quit-lisp () (ext:exit)) From heller at common-lisp.net Mon Aug 11 17:41:56 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 13:41:56 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811174156.5665E2F064@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21594 Modified Files: ChangeLog slime.el swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-ecl.lisp swank-sbcl.lisp swank.lisp Log Message: Improve interrupt safety for single-threaded lisps. * slime.el (slime-interrupt): Send a :emacs-interrupt message together with SIGINT. SIGINT now means "check for new events" instead of "invoke the debugger". * swank-backend.lisp (install-sigint-handler) (call-with-user-break-handler): New functions. * swank.lisp (simple-serve-requests,install-fd-handler): Use it. (read-packet, read-char): New function. Check for interrupts. (wait-for-event/event-loop): Check for interrupts. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:47 1.1440 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:55 1.1441 @@ -1,5 +1,20 @@ 2008-08-11 Helmut Eller + Improve interrupt safety for single-threaded lisps. + + * slime.el (slime-interrupt): Send a :emacs-interrupt message + together with SIGINT. SIGINT now means "check for new events" + instead of "invoke the debugger". + + * swank-backend.lisp (install-sigint-handler) + (call-with-user-break-handler): New functions. + + * swank.lisp (simple-serve-requests,install-fd-handler): Use it. + (read-packet, read-char): New function. Check for interrupts. + (wait-for-event/event-loop): Check for interrupts. + +2008-08-11 Helmut Eller + * swank-abcl.lisp (preferred-communication-style): Return nil until we implement receive-if. --- /project/slime/cvsroot/slime/slime.el 2008/08/11 07:39:10 1.987 +++ /project/slime/cvsroot/slime/slime.el 2008/08/11 17:41:55 1.988 @@ -6454,8 +6454,9 @@ (defun slime-interrupt () "Interrupt Lisp." (interactive) - (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint)) - (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))))) + (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread)) + (when (slime-use-sigint-for-interrupt) + (slime-send-sigint))) (defun slime-quit () (error "Not implemented properly. Use `slime-interrupt' instead.")) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/11 07:37:01 1.143 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/11 17:41:55 1.144 @@ -302,6 +302,17 @@ (definterface getpid () "Return the (Unix) process ID of this superior Lisp.") +(definterface install-sigint-handler (function) + "Call FUNCTION on SIGINT (instead of invoking the debugger). +Return old signal handler." + nil) + +(definterface call-with-user-break-handler (handler function) + "Install the break handler HANDLER while executing FUNCTION." + (let ((old-handler (install-sigint-handler handler))) + (unwind-protect (funcall function) + (install-sigint-handler old-handler)))) + (definterface lisp-implementation-type-name () "Return a short name for the Lisp implementation." (lisp-implementation-type)) --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/04 21:38:07 1.72 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/11 17:41:55 1.73 @@ -99,6 +99,14 @@ #+win32 ((ext:getenv "PID")) ; where does that come from? (t -1)))) +(defimplementation call-with-user-break-handler (handler function) + (handler-bind ((system::simple-interrupt-condition + (lambda (c) + (declare (ignore c)) + (funcall handler) + (continue)))) + (funcall function))) + (defimplementation lisp-implementation-type-name () "clisp") --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/11 07:37:02 1.185 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/11 17:41:55 1.186 @@ -139,6 +139,11 @@ ;;;;; Signal-driven I/O +(defimplementation install-sigint-handler (function) + (sys:enable-interrupt :sigint (lambda (signal code scp) + (declare (ignore signal code scp)) + (funcall function)))) + (defvar *sigio-handlers* '() "List of (key . function) pairs. All functions are called on SIGIO, and the key is used for removing @@ -155,19 +160,28 @@ (defun fcntl (fd command arg) "fcntl(2) - manipulate a file descriptor." (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) - (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error))))) + (cond (ok) + (t (error "fcntl: ~A" (unix:get-unix-error-msg error)))))) (defimplementation add-sigio-handler (socket fn) (set-sigio-handler) (let ((fd (socket-fd socket))) (fcntl fd unix:f-setown (unix:unix-getpid)) - (fcntl fd unix:f-setfl unix:fasync) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) (push (cons fd fn) *sigio-handlers*))) (defimplementation remove-sigio-handlers (socket) (let ((fd (socket-fd socket))) - (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) - (sys:invalidate-descriptor fd))) + (unless (assoc fd *sigio-handlers*) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) + (sys:invalidate-descriptor fd)) + #+(or) + (when (null *sigio-handlers*) + (sys:default-interrupt :sigio)) + )) ;;;;; SERVE-EVENT --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/11 07:39:23 1.26 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/11 17:41:55 1.27 @@ -71,6 +71,18 @@ ;;;; Unix signals +(defimplementation install-sigint-handler (handler) + (let ((old-handler (symbol-function 'si:terminal-interrupt))) + (setf (symbol-function 'si:terminal-interrupt) + (if (consp handler) + (car handler) + (lambda (&rest args) + (declare (ignore args)) + (funcall handler) + (continue)))) + (list old-handler))) + + (defimplementation getpid () (si:getpid)) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/11 07:37:06 1.212 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/11 17:41:55 1.213 @@ -112,6 +112,12 @@ (or external-format :iso-latin-1-unix) (or buffering :full))) +(defimplementation install-sigint-handler (function) + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (&rest args) + (declare (ignore args)) + (funcall function)))) + (defvar *sigio-handlers* '() "List of (key . fn) pairs to be called on SIGIO.") --- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:39:29 1.565 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 17:41:55 1.566 @@ -236,7 +236,10 @@ ;; The communication style used. (communication-style nil :type (member nil :spawn :sigio :fd-handler)) ;; The coding system for network streams. - (coding-system )) + coding-system + ;; The SIGINT handler we should restore when the connection is + ;; closed. + saved-sigint-handler) (defun print-connection (conn stream depth) (declare (ignore depth)) @@ -317,6 +320,45 @@ ;;;;; Helper macros +(defvar *slime-interrupts-enabled*) + +(defmacro with-slime-interrupts (&body body) + `(progn + (check-slime-interrupts) + (let ((*slime-interrupts-enabled* t) + (*pending-slime-interrupts* '())) + (multiple-value-prog1 (progn , at body) + (check-slime-interrupts))))) + +(defmacro without-slime-interrupts (&body body) + `(progn + (check-slime-interrupts) + (let ((*slime-interrupts-enabled* nil) + (*pending-slime-interrupts* '())) + (multiple-value-prog1 (progn , at body) + (check-slime-interrupts))))) + +(defun invoke-or-queue-interrupt (function) + (cond ((not (boundp '*slime-interrupts-enabled*)) + (without-slime-interrupts + (funcall function))) + (*slime-interrupts-enabled* + (funcall function)) + ((cdr *pending-slime-interrupts*) + (simple-break "Two many queued interrupts")) + (t + (push function *pending-slime-interrupts*)))) + +(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args) + (with-simple-restart (continue "Continue from break.") + (invoke-slime-debugger (coerce-to-condition datum args)))) + +(defun coerce-to-condition (datum args) + (etypecase datum + (string (make-condition 'simple-error :format-control datum + :format-arguments args)) + (symbol (apply #'make-condition datum args)))) + (defmacro with-io-redirection ((connection) &body body) "Execute BODY I/O redirection to CONNECTION. If *REDIRECT-IO* is true then all standard I/O streams are redirected." @@ -333,9 +375,10 @@ (defun call-with-connection (connection function) (let ((*emacs-connection* connection)) - (with-swank-error-handler (*emacs-connection*) - (with-io-redirection (*emacs-connection*) - (call-with-debugger-hook #'swank-debugger-hook function))))) + (without-slime-interrupts + (with-swank-error-handler (*emacs-connection*) + (with-io-redirection (*emacs-connection*) + (call-with-debugger-hook #'swank-debugger-hook function)))))) (defmacro without-interrupts (&body body) `(call-without-interrupts (lambda () , at body))) @@ -869,6 +912,7 @@ (connection.socket-io *emacs-connection*)) (defun close-connection (c condition backtrace) + (let ((*debugger-hook* nil)) (format *log-output* "~&;; swank:close-connection: ~A~%" condition) (let ((cleanup (connection.cleanup c))) (when cleanup @@ -894,43 +938,8 @@ (ignore-errors (stream-external-format (connection.socket-io c))) (connection.communication-style c) *use-dedicated-output-stream*) - (finish-output *log-output*))) + (finish-output *log-output*)))) -(defvar *slime-interrupts-enabled*) - -(defmacro with-slime-interrupts (&body body) - `(progn - (check-slime-interrupts) - (let ((*slime-interrupts-enabled* t) - (*pending-slime-interrupts* '())) - (multiple-value-prog1 (progn , at body) - (check-slime-interrupts))))) - -(defmacro without-slime-interrupts (&body body) - `(progn - (check-slime-interrupts) - (let ((*slime-interrupts-enabled* nil) - (*pending-slime-interrupts* '())) - (multiple-value-prog1 (progn , at body) - (check-slime-interrupts))))) - -(defun invoke-or-queue-interrupt (function) - (cond ((not (boundp '*slime-interrupts-enabled*)) - (without-slime-interrupts - (funcall function))) - (*slime-interrupts-enabled* - (funcall function)) - ((cdr *pending-slime-interrupts*) - (simple-break "Two many queued interrupts")) - (t - (push function *pending-slime-interrupts*)))) - -(defslimefun simple-break (&optional (fstring "Interrupt from Emacs") - &rest args) - (call-with-debugger-hook - #'swank-debugger-hook - (lambda () - (cerror "Return from break." "~?" fstring args)))) ;;;;;; Thread based communication @@ -1033,7 +1042,9 @@ (declare (ignore _)) (encode-message event (current-socket-io))) (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args) - (send-event (find-thread thread-id) (cons (car event) args))))) + (send-event (find-thread thread-id) (cons (car event) args))) + (((:end-of-stream)) + (close-connection *emacs-connection* nil (safe-backtrace))))) (defvar *event-queue* '()) @@ -1048,6 +1059,7 @@ (defun send-to-emacs (event) "Send EVENT to Emacs." + ;;(log-event "send-to-emacs: ~a" event) (cond ((use-threads-p) (send (connection.control-thread *emacs-connection*) event)) (t (dispatch-event event)))) @@ -1068,6 +1080,7 @@ (defun wait-for-event/event-loop (pattern timeout) (assert (or (not timeout) (eq timeout t))) (loop + (check-slime-interrupts) (let ((tail (member-if (lambda (e) (event-match-p e pattern)) *event-queue*))) (when tail @@ -1119,48 +1132,49 @@ ;;;;;; Signal driven IO (defun install-sigio-handler (connection) - (let ((client (connection.socket-io connection))) - (flet ((handler () - (cond ((null *swank-state-stack*) - (handle-requests connection t)) - ((eq (car *swank-state-stack*) :read-next-form)) - (t (process-requests t nil))))) - (add-sigio-handler client #'handler) - (handler)))) + (add-sigio-handler (connection.socket-io connection) + (lambda () (process-io-interrupt connection))) + (handle-or-process-requests connection)) + +(defun process-io-interrupt (connection) + (log-event "process-io-interrupt~%") + (invoke-or-queue-interrupt + (lambda () (handle-or-process-requests connection)))) + +(defun handle-or-process-requests (connection) + (log-event "handle-or-process-requests: ~a~%" *swank-state-stack*) + (cond ((null *swank-state-stack*) + (handle-requests connection t)) + ((eq (car *swank-state-stack*) :read-next-form)) + (t (process-requests t nil)))) (defun deinstall-sigio-handler (connection) - (remove-sigio-handlers (connection.socket-io connection))) + (log-event "deinstall-sigio-handler...~%") + (remove-sigio-handlers (connection.socket-io connection)) + (log-event "deinstall-sigio-handler...done~%")) ;;;;;; SERVE-EVENT based IO (defun install-fd-handler (connection) - (let ((client (connection.socket-io connection))) - (flet ((handler () - (cond ((null *swank-state-stack*) - (handle-requests connection t)) - ((eq (car *swank-state-stack*) :read-next-form)) - (t (process-requests t nil))))) - ;;;; 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)))) + (add-fd-handler (connection.socket-io connection) + (lambda () (handle-or-process-requests connection))) + (setf (connection.saved-sigint-handler connection) + (install-sigint-handler (lambda () (process-io-interrupt connection)))) + (handle-or-process-requests connection)) (defun deinstall-fd-handler (connection) - (remove-fd-handlers (connection.socket-io connection))) + (remove-fd-handlers (connection.socket-io connection)) + (install-sigint-handler (connection.saved-sigint-handler connection))) ;;;;;; Simple sequential IO (defun simple-serve-requests (connection) (unwind-protect - (with-simple-restart (close-connection "Close SLIME connection") - (handle-requests connection)) + (call-with-user-break-handler + (lambda () (process-io-interrupt connection)) + (lambda () + (with-simple-restart (close-connection "Close SLIME connection") + (handle-requests connection)))) (close-connection connection nil (safe-backtrace)))) (defun initialize-streams-for-connection (connection) @@ -1390,23 +1404,29 @@ (defun decode-message (stream &optional timeout) "Read an S-expression from STREAM using the SLIME protocol." (assert (or (not timeout) (eq timeout t))) - (when (and (eq timeout t) (not (input-available-p stream))) - (return-from decode-message (values nil t))) + ;;(log-event "decode-message~%") (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*))) (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) - (values (read-form string) nil))))) - -(defun decode-message-length (stream) - (let ((buffer (make-string 6))) - (dotimes (i 6) - (setf (aref buffer i) (read-char stream))) - (parse-integer buffer :radix #x10))) + (let ((c (read-char-no-hang stream nil))) + (cond ((and (not c) timeout) (values nil t)) + (t + (and c (unread-char c stream)) + (values (read-form (read-packet stream)) nil))))))) + +(defun read-packet (stream) + (peek-char nil stream) ; wait while queuing interrupts + (check-slime-interrupts) + (let* ((header (read-chunk stream 6)) + (length (parse-integer header :radix #x10)) + (payload (read-chunk stream length))) + (log-event "READ: ~S~%" payload) + payload)) + +(defun read-chunk (stream length) + (let* ((buffer (make-string length)) + (count (read-sequence buffer stream))) + (assert (= count length) () "Short read: length=~D count=~D" length count) + buffer)) (defun read-form (string) (with-standard-io-syntax From heller at common-lisp.net Mon Aug 11 17:42:03 2008 From: heller at common-lisp.net (heller) Date: Mon, 11 Aug 2008 13:42:03 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080811174203.57A4837017@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21670 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:55 1.1441 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:59 1.1442 @@ -10,7 +10,8 @@ (call-with-user-break-handler): New functions. * swank.lisp (simple-serve-requests,install-fd-handler): Use it. - (read-packet, read-char): New function. Check for interrupts. + (read-packet): New function. Check for interrupts. + (decode-message): Use it. (wait-for-event/event-loop): Check for interrupts. 2008-08-11 Helmut Eller From heller at common-lisp.net Tue Aug 12 12:56:51 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 08:56:51 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080812125651.8370749126@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5774 Modified Files: ChangeLog test.sh Log Message: * test.sh: Use batch mode by default. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:59 1.1442 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:56:51 1.1443 @@ -1,5 +1,9 @@ 2008-08-11 Helmut Eller + * test.sh: Use batch mode by default. + +2008-08-11 Helmut Eller + Improve interrupt safety for single-threaded lisps. * slime.el (slime-interrupt): Send a :emacs-interrupt message --- /project/slime/cvsroot/slime/test.sh 2008/08/08 15:02:04 1.13 +++ /project/slime/cvsroot/slime/test.sh 2008/08/12 12:56:51 1.14 @@ -14,16 +14,23 @@ # are disclaimed. function usage () { - echo "Usage: $name [-v] [-r] " + echo < " +-b disable batch mode +-s use screen to hide emacs +-r show results file +EOF exit 1 } name=$0 +batch_mode=-batch -while getopts vr opt; do +while getopts vrb opt; do case $opt in - v) verbose=true;; + s) use_screen=true;; r) dump_results=true;; + b) batch_mode="";; *) usage;; esac done @@ -50,14 +57,14 @@ cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib $testdir mkfifo $dribble -cmd=($emacs -nw -q -no-site-file --no-site-file +cmd=($emacs -nw -q -no-site-file $batch_mode --no-site-file --eval "(setq debug-on-quit t)" --eval "(add-to-list 'load-path \"$testdir\")" --eval "(require 'slime)" --eval "(setq inferior-lisp-program \"$lisp\")" --eval "(slime-batch-test \"$results\")") -if [ "$verbose" = true ]; then +if [ "$use_screen" = "" ]; then "${cmd[@]}" echo $? > $statusfile else From heller at common-lisp.net Tue Aug 12 12:56:58 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 08:56:58 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080812125658.4A1215F062@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5819 Modified Files: ChangeLog slime.el swank.lisp Log Message: Let SIGINT create a synthetic event. * swank.lisp (install-fd-handler,simple-serve-requests): Dispatch a :emacs-interrupt event in the SIGINT handler. * slime.el (slime-interrupt): Send nothing over the wire when SIGINT is used. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:56:51 1.1443 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:56:57 1.1444 @@ -1,3 +1,13 @@ +2008-08-12 Helmut Eller + + Let SIGINT create a synthetic event. + + * swank.lisp (install-fd-handler,simple-serve-requests): Dispatch + a :emacs-interrupt event in the SIGINT handler. + + * slime.el (slime-interrupt): Send nothing over the wire when + SIGINT is used. + 2008-08-11 Helmut Eller * test.sh: Use batch mode by default. --- /project/slime/cvsroot/slime/slime.el 2008/08/11 17:41:55 1.988 +++ /project/slime/cvsroot/slime/slime.el 2008/08/12 12:56:57 1.989 @@ -6454,9 +6454,8 @@ (defun slime-interrupt () "Interrupt Lisp." (interactive) - (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread)) - (when (slime-use-sigint-for-interrupt) - (slime-send-sigint))) + (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint)) + (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))))) (defun slime-quit () (error "Not implemented properly. Use `slime-interrupt' instead.")) --- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 17:41:55 1.566 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/12 12:56:57 1.567 @@ -1159,7 +1159,11 @@ (add-fd-handler (connection.socket-io connection) (lambda () (handle-or-process-requests connection))) (setf (connection.saved-sigint-handler connection) - (install-sigint-handler (lambda () (process-io-interrupt connection)))) + (install-sigint-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () + (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))))) (handle-or-process-requests connection)) (defun deinstall-fd-handler (connection) @@ -1171,7 +1175,10 @@ (defun simple-serve-requests (connection) (unwind-protect (call-with-user-break-handler - (lambda () (process-io-interrupt connection)) + (lambda () + (invoke-or-queue-interrupt + (lambda () + (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))) (lambda () (with-simple-restart (close-connection "Close SLIME connection") (handle-requests connection)))) @@ -1762,26 +1769,23 @@ "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. Return the result to the continuation ID. Errors are trapped and invoke our debugger." - (call-with-debugger-hook - #'swank-debugger-hook - (lambda () - (let (ok result) - (unwind-protect - (let ((*buffer-package* (guess-buffer-package buffer-package)) - (*buffer-readtable* (guess-buffer-readtable buffer-package)) - (*pending-continuations* (cons id *pending-continuations*))) - (check-type *buffer-package* package) - (check-type *buffer-readtable* readtable) - ;; APPLY would be cleaner than EVAL. - ;;(setq result (apply (car form) (cdr form))) - (setq result (with-slime-interrupts (eval form))) - (run-hook *pre-reply-hook*) - (setq ok t)) - (send-to-emacs `(:return ,(current-thread) - ,(if ok - `(:ok ,result) - `(:abort)) - ,id))))))) + (let (ok result) + (unwind-protect + (let ((*buffer-package* (guess-buffer-package buffer-package)) + (*buffer-readtable* (guess-buffer-readtable buffer-package)) + (*pending-continuations* (cons id *pending-continuations*))) + (check-type *buffer-package* package) + (check-type *buffer-readtable* readtable) + ;; APPLY would be cleaner than EVAL. + ;;(setq result (apply (car form) (cdr form))) + (setq result (with-slime-interrupts (eval form))) + (run-hook *pre-reply-hook*) + (setq ok t)) + (send-to-emacs `(:return ,(current-thread) + ,(if ok + `(:ok ,result) + `(:abort)) + ,id))))) (defvar *echo-area-prefix* "=> " "A prefix that `format-values-for-echo-area' should use.") @@ -2027,8 +2031,9 @@ (defun swank-debugger-hook (condition hook) "Debugger function for binding *DEBUGGER-HOOK*." - (declare (ignore hook)) - (restart-case (invoke-slime-debugger condition) + (restart-case + (call-with-debugger-hook + hook (lambda () (invoke-slime-debugger condition))) (default-debugger (&optional v) :report "Use default debugger." (declare (ignore v)) (invoke-default-debugger condition)))) From heller at common-lisp.net Tue Aug 12 12:57:03 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 08:57:03 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080812125703.C6CD4682C5@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5878 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (with-buffer-syntax): Take package as argument. (defslimefun): Derive the package for exporting from the symbol. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:56:57 1.1444 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:57:02 1.1445 @@ -1,5 +1,10 @@ 2008-08-12 Helmut Eller + * swank.lisp (with-buffer-syntax): Take package as argument. + (defslimefun): Derive the package for exporting from the symbol. + +2008-08-12 Helmut Eller + Let SIGINT create a synthetic event. * swank.lisp (install-fd-handler,simple-serve-requests): Dispatch --- /project/slime/cvsroot/slime/swank.lisp 2008/08/12 12:56:57 1.567 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/12 12:57:02 1.568 @@ -142,7 +142,7 @@ (defun ,name ,arglist , at rest) ;; see (eval-when (:compile-toplevel :load-toplevel :execute) - (export ',name :swank)))) + (export ',name (symbol-package ',name))))) (defun missing-arg () "A function that the compiler knows will never to return a value. @@ -1601,16 +1601,17 @@ (define-special *buffer-readtable* "Readtable associated with the current buffer") -(defmacro with-buffer-syntax ((&rest _) &body body) +(defmacro with-buffer-syntax ((&optional package) &body body) "Execute BODY with appropriate *package* and *readtable* bindings. This should be used for code that is conceptionally executed in an Emacs buffer." - (destructuring-bind () _ - `(call-with-buffer-syntax (lambda () , at body)))) + `(call-with-buffer-syntax ,package (lambda () , at body))) -(defun call-with-buffer-syntax (fun) - (let ((*package* *buffer-package*)) +(defun call-with-buffer-syntax (package fun) + (let ((*package* (if package + (guess-buffer-package package) + *buffer-package*))) ;; Don't shadow *readtable* unnecessarily because that prevents ;; the user from assigning to it. (if (eq *readtable* *buffer-readtable*) @@ -1637,6 +1638,12 @@ (let ((*read-suppress* nil)) (read-from-string string)))) +(defun parse-string (string package) + "Read STRING in PACKAGE." + (with-buffer-syntax (package) + (let ((*read-suppress* nil)) + (read-from-string string)))) + ;; FIXME: deal with #\| etc. hard to do portably. (defun tokenize-symbol (string) "STRING is interpreted as the string representation of a symbol From heller at common-lisp.net Tue Aug 12 12:57:10 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 08:57:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080812125710.0A75A81003@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5912 Modified Files: ChangeLog slime.el swank.lisp Log Message: Finally handle reader-errors without disconnecting. * swank.lisp (decode-message): Convert reader-error conditions into :reader-error events. (dispatch-event): Send :reader-error events to Emacs. * slime.el (slime-dispatch-event): Display reader-errors. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:57:02 1.1445 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:57:09 1.1446 @@ -1,5 +1,15 @@ 2008-08-12 Helmut Eller + Finally handle reader-errors without disconnecting. + + * swank.lisp (decode-message): Convert reader-error conditions + into :reader-error events. + (dispatch-event): Send :reader-error events to Emacs. + + * slime.el (slime-dispatch-event): Display reader-errors. + +2008-08-12 Helmut Eller + * swank.lisp (with-buffer-syntax): Take package as argument. (defslimefun): Derive the package for exporting from the symbol. --- /project/slime/cvsroot/slime/slime.el 2008/08/12 12:56:57 1.989 +++ /project/slime/cvsroot/slime/slime.el 2008/08/12 12:57:09 1.990 @@ -2005,8 +2005,9 @@ (defun slime-check-version (version conn) (or (equal version slime-protocol-version) (equal slime-protocol-version 'ignore) - (yes-or-no-p (format "Version mismatch: %S vs. %S. Continue? " - slime-protocol-version version)) + (yes-or-no-p + (format "Version mismatch: %S (emacs) vs. %S (lisp). Continue? " + slime-protocol-version version)) (slime-net-close conn) (top-level))) @@ -2381,7 +2382,13 @@ (assert thread) (message "%s" message)) ((:ping thread tag) - (slime-send `(:emacs-pong ,thread ,tag))))))) + (slime-send `(:emacs-pong ,thread ,tag))) + ((:reader-error packet condition) + (slime-with-popup-buffer ("*Slime Error*") + (princ (format "Invalid protocol message:\n%s\n\n%S" + condition packet)) + (goto-char (point-min))) + (error "Invalid protocol message")))))) (defun slime-send (sexp) "Send SEXP directly over the wire on the current connection." --- /project/slime/cvsroot/slime/swank.lisp 2008/08/12 12:57:02 1.568 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/12 12:57:09 1.569 @@ -1044,7 +1044,11 @@ (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args) (send-event (find-thread thread-id) (cons (car event) args))) (((:end-of-stream)) - (close-connection *emacs-connection* nil (safe-backtrace))))) + (close-connection *emacs-connection* nil (safe-backtrace))) + ((:reader-error packet condition) + (encode-message `(:reader-error ,packet + ,(safe-condition-message condition)) + (current-socket-io))))) (defvar *event-queue* '()) @@ -1418,7 +1422,10 @@ (cond ((and (not c) timeout) (values nil t)) (t (and c (unread-char c stream)) - (values (read-form (read-packet stream)) nil))))))) + (let ((packet (read-packet stream))) + (handler-case (values (read-form packet) nil) + (reader-error (c) + `(:reader-error ,packet ,c)))))))))) (defun read-packet (stream) (peek-char nil stream) ; wait while queuing interrupts From heller at common-lisp.net Tue Aug 12 12:57:16 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 08:57:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080812125716.65F69A107@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv5971 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-repl-send-input): Disable modification hooks when marking old input. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:57:09 1.1446 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:57:16 1.1447 @@ -1,5 +1,10 @@ 2008-08-12 Helmut Eller + * slime.el (slime-repl-send-input): Disable modification hooks + when marking old input. + +2008-08-12 Helmut Eller + Finally handle reader-errors without disconnecting. * swank.lisp (decode-message): Convert reader-error conditions --- /project/slime/cvsroot/slime/slime.el 2008/08/12 12:57:09 1.990 +++ /project/slime/cvsroot/slime/slime.el 2008/08/12 12:57:16 1.991 @@ -3112,10 +3112,11 @@ (when newline (insert "\n") (slime-repl-show-maximum-output)) - (add-text-properties slime-repl-input-start-mark - (point) - `(slime-repl-old-input - ,(incf slime-repl-old-input-counter))) + (let ((inhibit-modification-hooks t)) + (add-text-properties slime-repl-input-start-mark + (point) + `(slime-repl-old-input + ,(incf slime-repl-old-input-counter)))) (let ((overlay (make-overlay slime-repl-input-start-mark end))) ;; These properties are on an overlay so that they won't be taken ;; by kill/yank. From heller at common-lisp.net Tue Aug 12 13:03:15 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 09:03:15 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080812130315.E745F5F05B@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv9753 Modified Files: ChangeLog Added Files: swank-clipboard.lisp slime-clipboard.el Log Message: Add a simple object clipboard. * swank-clipboard.lisp: New file. * slime-clipboard.el: New file. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/07 15:24:08 1.117 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/12 13:03:15 1.118 @@ -1,3 +1,10 @@ +2008-08-12 Helmut Eller + + Add a simple object clipboard. + + * swank-clipboard.lisp: New file. + * slime-clipboard.el: New file. + 2008-08-07 Tobias C. Rittweiler * slime-fancy.el: Add slime-mdot-fu and slime-package-fu. --- /project/slime/cvsroot/slime/contrib/swank-clipboard.lisp 2008/08/12 13:03:15 NONE +++ /project/slime/cvsroot/slime/contrib/swank-clipboard.lisp 2008/08/12 13:03:15 1.1 ;;; swank-clipboard.lisp --- Object clipboard ;; ;; Written by Helmut Eller in 2008. ;; License: Public Domain (defpackage :swank-clipboard (:use :cl) (:import-from :swank :defslimefun :with-buffer-syntax :destructure-case)) (in-package :swank-clipboard) (defstruct clipboard entries (counter 0)) (defvar *clipboard* (make-clipboard)) (defslimefun add (datum) (let ((value (destructure-case datum ((:string string package) (with-buffer-syntax (package) (eval (read-from-string string)))) ((:inspector part) (swank:inspector-nth-part part)) ((:sldb frame var) (swank-backend:frame-var-value frame var))))) (clipboard-add value) (format nil "Added: ~a" (entry-to-string (1- (length (clipboard-entries *clipboard*))))))) (defslimefun entries () (loop for (ref . value) in (clipboard-entries *clipboard*) collect `(,ref . ,(to-line value)))) (defslimefun delete-entry (entry) (let ((msg (format nil "Deleted: ~a" (entry-to-string entry)))) (clipboard-delete-entry entry) msg)) (defslimefun entry-to-ref (entry) (destructuring-bind (ref . value) (clipboard-entry entry) (list ref (to-line value 5)))) (defun clipboard-add (value) (setf (clipboard-entries *clipboard*) (append (clipboard-entries *clipboard*) (list (cons (incf (clipboard-counter *clipboard*)) value))))) (defun clipboard-ref (ref) (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car))) (cond (tail (cdr (car tail))) (t (error "Invalid clipboard ref: ~s" ref))))) (defun clipboard-entry (entry) (elt (clipboard-entries *clipboard*) entry)) (defun clipboard-delete-entry (index) (let* ((list (clipboard-entries *clipboard*)) (tail (nthcdr index list))) (setf (clipboard-entries *clipboard*) (append (ldiff list tail) (cdr tail))))) (defun entry-to-string (entry) (destructuring-bind (ref . value) (clipboard-entry entry) (format nil "#@~d(~a)" ref (to-line value)))) (defun to-line (object &optional (width 75)) (with-output-to-string (*standard-output*) (write object :right-margin width :lines 1))) --- /project/slime/cvsroot/slime/contrib/slime-clipboard.el 2008/08/12 13:03:15 NONE +++ /project/slime/cvsroot/slime/contrib/slime-clipboard.el 2008/08/12 13:03:15 1.1 ;;; slime-scratch.el --- Object clipboard for SLIME ;; ;; Author: Helmut Eller ;; License: GNU GPL (same license as Emacs) ;; ;; This add a few commands to put objects into a clipboard and ;; to insert textual references to those objects. ;; ;; The clipboard command prefix is C-c @. ;; ;; C-c @ + adds an object to the clipboard ;; C-c @ @ inserts a reference to an object in the clipboard ;; C-c @ ? displays the clipboard ;; ;; This package also also binds the + key in the inspector and ;; debugger to add the object at point to the clipboard. ;; (require 'slime) (slime-require :swank-clipboard) (define-derived-mode slime-clipboard-mode fundamental-mode "Slime-Clipboard" "SLIME Clipboad Mode. \\{slime-clipboard-mode-map}") (slime-define-keys slime-clipboard-mode-map ("g" 'slime-clipboard-redisplay) ((kbd "C-k") 'slime-clipboard-delete-entry) ("i" 'slime-clipboard-inspect)) (defvar slime-clipboard-map (make-sparse-keymap)) (slime-define-keys slime-clipboard-map ("?" 'slime-clipboard-display) ("+" 'slime-clipboard-add) ("@" 'slime-clipboard-ref)) (define-key slime-mode-map (kbd "C-c @") slime-clipboard-map) (define-key slime-repl-mode-map (kbd "C-c @") slime-clipboard-map) (slime-define-keys slime-inspector-mode-map ("+" 'slime-clipboard-add-from-inspector)) (slime-define-keys sldb-mode-map ("+" 'slime-clipboard-add-from-sldb)) (defun slime-clipboard-add (exp package) "Add an object to the clipboard." (interactive (list (slime-read-from-minibuffer "Add to clipboard (evaluated): " (slime-sexp-at-point)) (slime-current-package))) (slime-clipboard-add-internal `(:string ,exp ,package))) (defun slime-clipboard-add-internal (datum) (slime-eval-async `(swank-clipboard:add ',datum) (lambda (result) (message "%s" result)))) (defun slime-clipboard-display () "Display the content of the clipboard." (interactive) (slime-eval-async `(swank-clipboard:entries) #'slime-clipboard-display-entries)) (defun slime-clipboard-display-entries (entries) (slime-with-popup-buffer ("*Slime Clipboard*") (slime-clipboard-mode) (slime-clipboard-insert-entries entries))) (defun slime-clipboard-insert-entries (entries) (let ((fstring "%2s %3s %s\n")) (insert (format fstring "Nr" "Id" "Value") (format fstring "--" "--" "-----" )) (save-excursion (loop for i from 0 for (ref . value) in entries do (slime-insert-propertized `(slime-clipboard-entry ,i slime-clipboard-ref ,ref) (format fstring i ref value)))))) (defun slime-clipboard-redisplay () "Update the clipboard buffer." (interactive) (slime-eval-async `(swank-clipboard:entries) (lambda (entries) (let ((inhibit-read-only t)) (slime-save-coordinates (point) (erase-buffer) (slime-clipboard-insert-entries entries)))))) (defun slime-clipboard-entry-at-point () (or (get-text-property (point) 'slime-clipboard-entry) (error "No clipboard entry at point"))) (defun slime-clipboard-ref-at-point () (or (get-text-property (point) 'slime-clipboard-ref) (error "No clipboard ref at point"))) (defun slime-clipboard-inspect (&optional entry) "Inspect the current clipboard entry." (interactive (list (slime-clipboard-ref-at-point))) (slime-inspect (prin1-to-string `(swank-clipboard::clipboard-ref ,entry)))) (defun slime-clipboard-delete-entry (&optional entry) "Delete the current entry from the clipboard." (interactive (list (slime-clipboard-entry-at-point))) (slime-eval-async `(swank-clipboard:delete-entry ,entry) (lambda (result) (slime-clipboard-redisplay) (message "%s" result)))) (defun slime-clipboard-ref () "Ask for a clipboard entry number and insert a reference to it." (interactive) (slime-clipboard-read-entry-number #'slime-clipboard-insert-ref)) ;; insert a reference to clipboard entry ENTRY at point. The text ;; receives a special 'display property to make it look nicer. We ;; remove this property in a modification when a user tries to modify ;; he real text. (defun slime-clipboard-insert-ref (entry) (destructuring-bind (ref . string) (slime-eval `(swank-clipboard:entry-to-ref ,entry)) (slime-insert-propertized `(display ,(format "#@%d%s" ref string) modification-hooks (slime-clipboard-ref-modified) rear-nonsticky '(modification-hooks)) (format "(swank-clipboard::clipboard-ref %d)" ref)))) (defun slime-clipboard-ref-modified (start end) (when (get-text-property start 'display) (let ((inhibit-modification-hooks t)) (save-excursion (goto-char start) (destructuring-bind (start end) (slime-property-bounds 'display) (remove-list-of-text-properties start end '(display modification-hooks))))))) ;; Read a entry number. ;; Written in CPS because the display the clipboard before reading. (defun slime-clipboard-read-entry-number (k) (slime-eval-async `(swank-clipboard:entries) (slime-rcurry (lambda (entries window-config k) (slime-clipboard-display-entries entries) (let ((entry (unwind-protect (read-from-minibuffer "Entry number: " nil nil t) (set-window-configuration window-config)))) (funcall k entry))) (current-window-configuration) k))) (defun slime-clipboard-add-from-inspector () (interactive) (let ((part (or (get-text-property (point) 'slime-part-number) (error "No part at point")))) (slime-clipboard-add-internal `(:inspector ,part)))) (defun slime-clipboard-add-from-sldb () (interactive) (slime-clipboard-add-internal `(:sldb ,(sldb-frame-number-at-point) ,(sldb-var-number-at-point)))) (provide 'slime-clipboard) From heller at common-lisp.net Tue Aug 12 17:54:30 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 13:54:30 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080812175430.58B38682C5@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv21214/contrib Modified Files: ChangeLog slime-clipboard.el Log Message: * slime-clipboard.el (slime-clipboard-insert-ref): Set read-nonsticky to t to work better with kill/yank. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/12 13:03:15 1.118 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/12 17:54:30 1.119 @@ -1,5 +1,10 @@ 2008-08-12 Helmut Eller + * slime-clipboard.el (slime-clipboard-insert-ref): Set + read-nonsticky to t to work better with kill/yank. + +2008-08-12 Helmut Eller + Add a simple object clipboard. * swank-clipboard.lisp: New file. --- /project/slime/cvsroot/slime/contrib/slime-clipboard.el 2008/08/12 13:03:15 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-clipboard.el 2008/08/12 17:54:30 1.2 @@ -126,7 +126,7 @@ (slime-insert-propertized `(display ,(format "#@%d%s" ref string) modification-hooks (slime-clipboard-ref-modified) - rear-nonsticky '(modification-hooks)) + rear-nonsticky t) (format "(swank-clipboard::clipboard-ref %d)" ref)))) (defun slime-clipboard-ref-modified (start end) @@ -134,9 +134,10 @@ (let ((inhibit-modification-hooks t)) (save-excursion (goto-char start) - (destructuring-bind (start end) (slime-property-bounds 'display) - (remove-list-of-text-properties start end - '(display modification-hooks))))))) + (destructuring-bind (dstart dend) (slime-property-bounds 'display) + (unless (and (= start dstart) (= end dend)) + (remove-list-of-text-properties + dstart dend '(display modification-hooks)))))))) ;; Read a entry number. ;; Written in CPS because the display the clipboard before reading. From heller at common-lisp.net Tue Aug 12 17:54:36 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 13:54:36 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080812175436.2498C81029@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21246 Modified Files: ChangeLog slime.el Log Message: (slime-check-version): Use y-or-n-p. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 12:57:16 1.1447 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 17:54:35 1.1448 @@ -2,6 +2,7 @@ * slime.el (slime-repl-send-input): Disable modification hooks when marking old input. + (slime-check-version): Use y-or-n-p. 2008-08-12 Helmut Eller --- /project/slime/cvsroot/slime/slime.el 2008/08/12 12:57:16 1.991 +++ /project/slime/cvsroot/slime/slime.el 2008/08/12 17:54:35 1.992 @@ -2005,8 +2005,8 @@ (defun slime-check-version (version conn) (or (equal version slime-protocol-version) (equal slime-protocol-version 'ignore) - (yes-or-no-p - (format "Version mismatch: %S (emacs) vs. %S (lisp). Continue? " + (y-or-n-p + (format "Versions differ: %s (slime) vs. %s (swank). Continue? " slime-protocol-version version)) (slime-net-close conn) (top-level))) From heller at common-lisp.net Tue Aug 12 17:54:37 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 13:54:37 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080812175437.F39F718@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv21289/contrib Modified Files: ChangeLog swank-clipboard.lisp Log Message: * swank-clipboard.lisp (:swank-clipboard): List exports to avoid compiler warnings. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/12 17:54:30 1.119 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/12 17:54:37 1.120 @@ -2,6 +2,8 @@ * slime-clipboard.el (slime-clipboard-insert-ref): Set read-nonsticky to t to work better with kill/yank. + * swank-clipboard.lisp (:swank-clipboard): List exports to avoid + compiler warnings. 2008-08-12 Helmut Eller --- /project/slime/cvsroot/slime/contrib/swank-clipboard.lisp 2008/08/12 13:03:15 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-clipboard.lisp 2008/08/12 17:54:37 1.2 @@ -5,7 +5,8 @@ (defpackage :swank-clipboard (:use :cl) - (:import-from :swank :defslimefun :with-buffer-syntax :destructure-case)) + (:import-from :swank :defslimefun :with-buffer-syntax :destructure-case) + (:export :add :delete-entry :entries :entry-to-ref :ref)) (in-package :swank-clipboard) From heller at common-lisp.net Tue Aug 12 17:54:44 2008 From: heller at common-lisp.net (heller) Date: Tue, 12 Aug 2008 13:54:44 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080812175444.799F63800E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21320 Modified Files: ChangeLog swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-loader.lisp swank-sbcl.lisp Log Message: Add a dump-image function to the loader. * swank-loader.lisp (dump-image): New. * swank-backend.lisp (save-image): New interface. * swank-cmucl.lisp, swank-clisp.lisp, swank-sbcl.lisp (save-image): Implemented. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 17:54:35 1.1448 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 17:54:43 1.1449 @@ -1,5 +1,16 @@ 2008-08-12 Helmut Eller + Add a dump-image function to the loader. + + * swank-loader.lisp (dump-image): New. + + * swank-backend.lisp (save-image): New interface. + + * swank-cmucl.lisp, swank-clisp.lisp, swank-sbcl.lisp + (save-image): Implemented. + +2008-08-12 Helmut Eller + * slime.el (slime-repl-send-input): Disable modification hooks when marking old input. (slime-check-version): Use y-or-n-p. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/11 17:41:55 1.144 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/12 17:54:43 1.145 @@ -1097,3 +1097,12 @@ (values . (&rest typespecs)) (vector . (&optional element-type size)) )) + +;;; Heap dumps + +(definterface save-image (filename &optional restart-function) + "Save a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") + + + \ No newline at end of file --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/11 17:41:55 1.73 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/12 17:54:43 1.74 @@ -691,6 +691,12 @@ (defimplementation make-weak-value-hash-table (&rest args) (apply #'make-hash-table :weak :value args)) +(defimplementation save-image (filename &optional restart-function) + (let ((args `(,filename + ,@(if restart-function + `((:init-function ,restart-function)))))) + (apply #'ext:saveinitmem args))) + ;;; Local Variables: ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1) ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/11 17:41:55 1.186 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/12 17:54:44 1.187 @@ -2267,6 +2267,98 @@ (defimplementation make-weak-key-hash-table (&rest args) (apply #'make-hash-table :weak-p t args)) + +;;; Save image + +(defimplementation save-image (filename &optional restart-function) + (multiple-value-bind (pid error) (unix:unix-fork) + (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error))) + (cond ((= pid 0) + (let ((args `(,filename + ,@(if restart-function + `((:init-function ,restart-function)))))) + (apply #'ext:save-lisp args))) + (t + (let ((status (waitpid pid))) + (destructuring-bind (&key exited? status &allow-other-keys) status + (assert (and exited? (equal status 0)) () + "Invalid exit status: ~a" status))))))) + +(defun waitpid (pid) + (alien:with-alien ((status c-call:int)) + (let ((code (alien:alien-funcall + (alien:extern-alien + waitpid (alien:function unix::pid-t + unix::pid-t + (* c-call:int) c-call:int)) + pid (alien:addr status) 0))) + (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) + (t (assert (= code pid)) + (decode-wait-status status)))))) + +(defun decode-wait-status (status) + (let ((output (with-output-to-string (s) + (call-program (list (process-status-program) + (format nil "~d" status)) + :output s)))) + (read-from-string output))) + +(defun call-program (args &key output) + (destructuring-bind (program &rest args) args + (let ((process (ext:run-program program args :output output))) + (when (not program) (error "fork failed")) + (unless (and (eq (ext:process-status process) :exited) + (= (ext:process-exit-code process) 0)) + (error "Non-zero exit status"))))) + +(defvar *process-status-program* nil) + +(defun process-status-program () + (or *process-status-program* + (setq *process-status-program* + (compile-process-status-program)))) + +(defun compile-process-status-program () + (let ((infile (system::pick-temporary-file-name + "/tmp/process-status~d~c.c"))) + (with-open-file (stream infile :direction :output :if-exists :supersede) + (format stream " +#include +#include +#include +#include +#include + +#define FLAG(value) (value ? \"t\" : \"nil\") + +int main (int argc, char** argv) { + assert (argc == 2); + { + char* endptr = NULL; + char* arg = argv[1]; + long int status = strtol (arg, &endptr, 10); + assert (endptr != arg && *endptr == '\\0'); + printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\" + \" :stopped? %s :stopsig %d)\\n\", + FLAG(WIFEXITED(status)), WEXITSTATUS(status), + FLAG(WIFSIGNALED(status)), WTERMSIG(status), + FLAG(WCOREDUMP(status)), + FLAG(WIFSTOPPED(status)), WSTOPSIG(status)); + fflush (NULL); + return 0; + } +} +") + (finish-output stream)) + (let* ((outfile (system::pick-temporary-file-name)) + (args (list "cc" "-o" outfile infile))) + (warn "Running cc: ~{~a ~}~%" args) + (call-program args :output t) + (delete-file infile) + outfile))) + +;; (save-image "/tmp/x.core") + ;; Local Variables: ;; pbook-heading-regexp: "^;;;\\(;+\\)" ;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)" --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/07/23 14:29:10 1.86 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/08/12 17:54:44 1.87 @@ -21,6 +21,7 @@ (cl:defpackage :swank-loader (:use :cl) (:export :init + :dump-image :*source-directory* :*fasl-directory*)) @@ -225,6 +226,10 @@ (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))) (funcall (q "swank::init"))) +(defun dump-image (filename) + (init :setup nil) + (funcall (q "swank-backend:save-image") filename)) + (defun init (&key delete reload load-contribs (setup t)) (when (and delete (find-package :swank)) (mapc #'delete-package '(:swank :swank-io-package :swank-backend))) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/11 17:41:55 1.213 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/12 17:54:44 1.214 @@ -112,6 +112,7 @@ (or external-format :iso-latin-1-unix) (or buffering :full))) +#-win32 (defimplementation install-sigint-handler (function) (sb-sys:enable-interrupt sb-unix:sigint (lambda (&rest args) @@ -1402,3 +1403,17 @@ (defimplementation hash-table-weakness (hashtable) #+#.(swank-backend::sbcl-with-weak-hash-tables) (sb-ext:hash-table-weakness hashtable)) + +#-win32 +(defimplementation save-image (filename &optional restart-function) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (let ((args `(,filename + ,@(if restart-function + `((:toplevel ,restart-function)))))) + (apply #'sb-ext:save-lisp-and-die args))) + (t + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (and (sb-posix:wifexited status) + (zerop (sb-posix:wexitstatus status))))))))) \ No newline at end of file From trittweiler at common-lisp.net Thu Aug 14 11:10:00 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 14 Aug 2008 07:10:00 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080814111000.CD8037A037@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv24426 Modified Files: slime.el ChangeLog Log Message: Xref buffers: `q', and `SPC' will push onto the find-definition stack such that M-, will work afterwards. * slime.el (defstruct slime-emacs-snapshot): Also save the point explicitly. It is implicitly stored already in the window-configuration, but inaccessible therein. (slime-current-emacs-snapshot, slime-set-emacs-snapshot): Adapted. (slime-push-definition-stack-from-snapshot): New. Reason for above changes. (slime-with-popup-buffer): Make sure that the current emacs-snapshot is taken, not only when the :emacs-snapshot argument is NIL at expansion time, but also on runtime. (slime-with-xref-buffer): The name of the Xref buffer was created at expansion time, but must be computed at runtime. Fix that. (slime-xref-quit): Use `slime-push-definition-stack-from-snapshot' (sime-xref-goto): Adapted to also push onto the stack. * slime.el (slime-compute-modeline-package): Cleaned up. (slime-update-modeline-string): Ditto. --- /project/slime/cvsroot/slime/slime.el 2008/08/12 17:54:35 1.992 +++ /project/slime/cvsroot/slime/slime.el 2008/08/14 11:10:00 1.993 @@ -190,7 +190,8 @@ (defcustom slime-find-definitions-function 'slime-find-definitions-rpc "Function to find definitions for a name. -The function is called with the definition name, a string, as its argument." +The function is called with the definition name, a string, as its +argument." :type 'function :group 'slime-mode :options '(slime-find-definitions-rpc @@ -211,7 +212,8 @@ (const :tag "Fuzzy" slime-fuzzy-complete-symbol))) (defcustom slime-when-complete-filename-expand nil - "Use comint-replace-by-expanded-filename instead of comint-dynamic-complete-as-filename to complete file names" + "Use comint-replace-by-expanded-filename instead of +comint-dynamic-complete-as-filename to complete file names" :group 'slime-mode :type 'boolean) @@ -446,11 +448,8 @@ (defun slime-compute-modeline-package () (when (memq major-mode slime-lisp-modes) - (let* ((pkg (slime-current-package)) - (pretty-pkg )) - (if pkg - (slime-pretty-package-name pkg) - nil)))) + (when-let (package (slime-current-package)) + (slime-pretty-package-name package)))) (defun slime-pretty-package-name (name) "Return a pretty version of a package name NAME." @@ -484,19 +483,19 @@ (defun slime-update-modeline-string () (let ((old-pkg slime-modeline-package) (old-conn slime-modeline-connection-name) - (old-state slime-modeline-connection-state)) - (let ((new-pkg (slime-compute-modeline-package)) - (new-conn (slime-compute-modeline-connection)) - (new-state (slime-compute-modeline-connection-state))) - (when (or (not (equal old-pkg new-pkg)) - (not (equal old-conn new-conn)) - (not (equal old-state new-state))) - (setq slime-modeline-package new-pkg) - (setq slime-modeline-connection-name new-conn) - (setq slime-modeline-connection-state new-state) - (setq slime-modeline-string - (slime-compute-modeline-string new-conn new-state new-pkg)) - (force-mode-line-update t))))) + (old-state slime-modeline-connection-state) + (new-pkg (slime-compute-modeline-package)) + (new-conn (slime-compute-modeline-connection)) + (new-state (slime-compute-modeline-connection-state))) + (when (or (not (equal old-pkg new-pkg)) + (not (equal old-conn new-conn)) + (not (equal old-state new-state))) + (setq slime-modeline-package new-pkg) + (setq slime-modeline-connection-name new-conn) + (setq slime-modeline-connection-state new-state) + (setq slime-modeline-string + (slime-compute-modeline-string new-conn new-state new-pkg)) + (force-mode-line-update t)))) (defun slime-shall-we-update-modeline-p () (and slime-extended-modeline @@ -508,8 +507,9 @@ (run-with-idle-timer 0.2 0.2 'slime-update-modeline) -;; Setup the mode-line to say when we're in slime-mode, and which CL -;; package we think the current buffer belongs to. +;; Setup the mode-line to say when we're in slime-mode, which +;; connection is active, and which CL package we think the current +;; buffer belongs to. (add-to-list 'minor-mode-alist '(slime-mode (" Slime" slime-modeline-string))) @@ -901,7 +901,10 @@ narrowedp beg end) (defstruct (slime-emacs-snapshot (:conc-name slime-emacs-snapshot.)) - window-configuration narrowing-configuration) + ;; We explicitly store the value of point even though it's implicitly + ;; stored in the window-configuration because Emacs provides no + ;; way to access the things stored in a window configuration. + window-configuration narrowing-configuration point-marker) (defun slime-current-narrowing-configuration (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -923,15 +926,18 @@ (current-buffer)) (make-slime-emacs-snapshot :window-configuration (current-window-configuration frame) - :narrowing-configuration (slime-current-narrowing-configuration)))) + :narrowing-configuration (slime-current-narrowing-configuration) + :point-marker (point-marker)))) (defun slime-set-emacs-snapshot (snapshot) "Restores the state of Emacs according to the information saved in SNAPSHOT." (let ((window-cfg (slime-emacs-snapshot.window-configuration snapshot)) - (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot))) + (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot)) + (marker (slime-emacs-snapshot.point-marker snapshot))) (set-window-configuration window-cfg) ; restores previously current buffer. - (slime-set-narrowing-configuration narrowing-cfg))) + (slime-set-narrowing-configuration narrowing-cfg) + (goto-char (marker-position marker)))) (defun slime-current-emacs-snapshot-fingerprint (&optional frame) "Return a fingerprint of the current emacs snapshot. @@ -981,7 +987,8 @@ current state will be saved and later restored." `(let* ((vars% (list ,(if (eq package t) '(slime-current-package) package) ,(if (eq connection t) '(slime-connection) connection) - ,(or emacs-snapshot '(slime-current-emacs-snapshot)))) + ;; Defer the decision for NILness until runtime. + (or ,emacs-snapshot (slime-current-emacs-snapshot)))) (standard-output (slime-popup-buffer ,name vars%))) (with-current-buffer standard-output (prog1 (progn , at body) @@ -1044,12 +1051,12 @@ (kill-buffer popup-buffer)))) (defun slime-popup-buffer-snapshot-unchanged-p () - (let ((snapshot slime-popup-buffer-saved-emacs-snapshot)) - (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) - slime-popup-buffer-saved-fingerprint)))) + (equalp (slime-current-emacs-snapshot-fingerprint) + slime-popup-buffer-saved-fingerprint)) (defun slime-popup-buffer-restore-snapshot () - (slime-set-emacs-snapshot slime-popup-buffer-saved-emacs-snapshot)) + (let ((snapshot slime-popup-buffer-saved-emacs-snapshot)) + (assert snapshot) (slime-set-emacs-snapshot snapshot))) ;;;;; Filename translation @@ -5113,6 +5120,11 @@ (defvar slime-find-definition-history-ring (make-ring 20) "History ring recording the definition-finding \"stack\".") +(defun slime-push-definition-stack-from-snapshot (emacs-snapshot) + (with-struct (slime-emacs-snapshot. narrowing-configuration point-marker) + emacs-snapshot + (slime-push-definition-stack point-marker narrowing-configuration))) + (defun slime-push-definition-stack (&optional marker narrowing-configuration) "Add MARKER and NARROWING-CONFIGURATION to the edit-definition history stack. If MARKER is nil, use the current point. If NARROWING-CONFIGURATION is nil, @@ -5187,7 +5199,7 @@ ((slime-length= xrefs 1) ; ((:error "...")) (error "%s" (cadr (slime-xref.location (car xrefs))))) (t - (slime-push-definition-stack) + ;; Xref buffers will themselves push onto the find-definition stack. (slime-show-xrefs file-alist 'definition name (slime-current-package)))))) @@ -5310,7 +5322,8 @@ (defun slime-check-eval-in-emacs-enabled () "Raise an error if `slime-enable-evaluate-in-emacs' isn't true." (unless slime-enable-evaluate-in-emacs - (error "slime-eval-in-emacs disabled for security. Set slime-enable-evaluate-in-emacs true to enable it."))) + (error (concat "slime-eval-in-emacs disabled for security." + "Set slime-enable-evaluate-in-emacs true to enable it.")))) ;;;; `ED' @@ -6068,28 +6081,33 @@ ;;;;; XREF results buffer and window management -(defun slime-xref-buffer () - "Return the XREF results buffer. -If CREATE is non-nil, create it if necessary." - (or (find-if (lambda (b) (string-match "*XREF\\[" (buffer-name b))) - (buffer-list)) - (error "No XREF buffer"))) - (defmacro* slime-with-xref-buffer ((xref-type symbol &optional package emacs-snapshot) &body body) "Execute BODY in a xref buffer, then show that buffer." - (let ((xref-buffer-name (format "*XREF[%s: %s]*" xref-type symbol))) - `(slime-with-popup-buffer (,xref-buffer-name ,package t ,emacs-snapshot) + `(let ((xref-buffer-name% (format "*XREF[%s: %s]*" ,xref-type ,symbol))) + (slime-with-popup-buffer (xref-buffer-name% ,package t ,emacs-snapshot) (slime-xref-mode) (slime-set-truncate-lines) (setq slime-popup-buffer-quit-function 'slime-xref-quit) (erase-buffer) (prog1 (progn , at body) - (assert (equal (buffer-name) ,xref-buffer-name)) + (assert (equal (buffer-name) xref-buffer-name%)) (shrink-window-if-larger-than-buffer))))) (put 'slime-with-xref-buffer 'lisp-indent-function 1) +(defun slime-xref-buffer () + "Return the XREF results buffer. +If CREATE is non-nil, create it if necessary." + (or (find-if (lambda (b) (string-match "*XREF\\[" (buffer-name b))) + (buffer-list)) + (error "No XREF buffer"))) + +(defun slime-xref-saved-snapshot () + (let ((snapshot )) + (assert snapshot) + snaptshot)) + (defun slime-xref-quit (&optional _) "Kill the current xref buffer and restore the window configuration." (interactive) @@ -6098,7 +6116,10 @@ ;; want the Xref window be deleted. (if (slime-popup-buffer-snapshot-unchanged-p) (slime-popup-buffer-restore-snapshot) - (let ((buffer (current-buffer))) + (let ((snapshot slime-popup-buffer-saved-emacs-snapshot) + (buffer (current-buffer))) + ;; Make M-, work after Xref'ing. + (slime-push-definition-stack-from-snapshot snapshot) (delete-windows-on buffer) (kill-buffer buffer)))) @@ -6106,6 +6127,7 @@ "Delete overlays created by xref mode and kill the xref buffer." (sldb-delete-overlays)) + (defun slime-insert-xrefs (xref-alist) "Insert XREF-ALIST in the current-buffer. XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). @@ -6227,9 +6249,11 @@ (defun slime-goto-xref () "Goto the cross-referenced location at point." (interactive) - (let ((location (slime-xref-location-at-point))) - (slime-xref-quit) - (slime-pop-to-location location))) + ;; Notice: We implement it this way so `slime-show-xref' changes the + ;; the window snapshot such that `slime-xref-quit' will push onto + ;; the find-definition-stack. + (slime-show-xref) + (slime-xref-quit)) (defun slime-show-xref () "Display the xref at point in the other window." @@ -7089,9 +7113,10 @@ (slime-show-source-location source-location)))))) (defun slime-show-source-location (source-location &optional no-highlight-p) - (slime-goto-source-location source-location) - (unless no-highlight-p (sldb-highlight-sexp)) - (slime-show-buffer-position (point))) + (save-selected-window ; show the location, but don't hijack focus. + (slime-goto-source-location source-location) + (unless no-highlight-p (sldb-highlight-sexp)) + (slime-show-buffer-position (point)))) (defun sldb-highlight-sexp (&optional start end) "Highlight the first sexp after point." --- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 17:54:43 1.1449 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/14 11:10:00 1.1450 @@ -1,3 +1,27 @@ +2008-08-14 Tobias C. Rittweiler + + Xref buffers: `q', and `SPC' will push onto the find-definition + stack such that M-, will work afterwards. + + * slime.el (defstruct slime-emacs-snapshot): Also save the point + explicitly. It is implicitly stored already in the + window-configuration, but inaccessible therein. + (slime-current-emacs-snapshot, slime-set-emacs-snapshot): Adapted. + (slime-push-definition-stack-from-snapshot): New. Reason for above + changes. + + (slime-with-popup-buffer): Make sure that the current + emacs-snapshot is taken, not only when the :emacs-snapshot + argument is NIL at expansion time, but also on runtime. + + (slime-with-xref-buffer): The name of the Xref buffer was created + at expansion time, but must be computed at runtime. Fix that. + (slime-xref-quit): Use `slime-push-definition-stack-from-snapshot' + (sime-xref-goto): Adapted to also push onto the stack. + + * slime.el (slime-compute-modeline-package): Cleaned up. + (slime-update-modeline-string): Ditto. + 2008-08-12 Helmut Eller Add a dump-image function to the loader. From trittweiler at common-lisp.net Thu Aug 14 11:46:40 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 14 Aug 2008 07:46:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080814114640.5362B5C18B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv32536 Modified Files: slime.el ChangeLog Log Message: Xref buffers: `M-,' in an Xref buffer will now revert to an Emacs state as of before the Xref command. * slime.el (slime-xref-mode-map): Add `slime-xref-retract' as `M-,' (slime-xref-retract): New. Restores the emacs snapshot unconditionally. (slime-xref-quit): Use it. --- /project/slime/cvsroot/slime/slime.el 2008/08/14 11:10:00 1.993 +++ /project/slime/cvsroot/slime/slime.el 2008/08/14 11:46:38 1.994 @@ -6071,7 +6071,8 @@ ("n" 'slime-next-line/not-add-newlines) ("p" 'previous-line) ("\C-c\C-c" 'slime-recompile-xref) - ("\C-c\C-k" 'slime-recompile-all-xrefs)) + ("\C-c\C-k" 'slime-recompile-all-xrefs) + ("\M-," 'slime-xref-retract)) (defun slime-next-line/not-add-newlines () (interactive) @@ -6103,19 +6104,15 @@ (buffer-list)) (error "No XREF buffer"))) -(defun slime-xref-saved-snapshot () - (let ((snapshot )) - (assert snapshot) - snaptshot)) - (defun slime-xref-quit (&optional _) - "Kill the current xref buffer and restore the window configuration." + "Kill the current xref buffer, restore the window configuration +if appropriate." (interactive) (slime-xref-cleanup) ;; We can't simply use `slime-popup-buffer-quit' because we also ;; want the Xref window be deleted. (if (slime-popup-buffer-snapshot-unchanged-p) - (slime-popup-buffer-restore-snapshot) + (slime-xref-retract) (let ((snapshot slime-popup-buffer-saved-emacs-snapshot) (buffer (current-buffer))) ;; Make M-, work after Xref'ing. @@ -6123,11 +6120,20 @@ (delete-windows-on buffer) (kill-buffer buffer)))) +(defun slime-xref-retract () + "Leave the Xref buffer, and make everything as of before." + (interactive) + (slime-xref-cleanup) + (let ((buffer (current-buffer))) + (slime-popup-buffer-restore-snapshot) + (kill-buffer buffer))) + (defun slime-xref-cleanup () "Delete overlays created by xref mode and kill the xref buffer." (sldb-delete-overlays)) + (defun slime-insert-xrefs (xref-alist) "Insert XREF-ALIST in the current-buffer. XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). --- /project/slime/cvsroot/slime/ChangeLog 2008/08/14 11:10:00 1.1450 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/14 11:46:39 1.1451 @@ -1,5 +1,14 @@ 2008-08-14 Tobias C. Rittweiler + Xref buffers: `M-,' in an Xref buffer will now revert to an Emacs + state as of before the Xref command. + + * slime.el (slime-xref-mode-map): Add `slime-xref-retract' as `M-,' + (slime-xref-retract): New. Restores the emacs snapshot unconditionally. + (slime-xref-quit): Use it. + +2008-08-14 Tobias C. Rittweiler + Xref buffers: `q', and `SPC' will push onto the find-definition stack such that M-, will work afterwards. From trittweiler at common-lisp.net Thu Aug 14 14:20:10 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 14 Aug 2008 10:20:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080814142010.84FB250AB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11889 Modified Files: slime.el ChangeLog Log Message: `C-c C-z' now selects an REPL displayed in another frame instead of splitting the current frame, and displaying the REPL in the newly created window. * slime.el (slime-switch-to-output-buffer-search-all-frames): New variable to customize this behaviour, as it may not be optimal for people using multiple screens at once. (slime-switch-to-output-buffer): Adapted. --- /project/slime/cvsroot/slime/slime.el 2008/08/14 11:46:38 1.994 +++ /project/slime/cvsroot/slime/slime.el 2008/08/14 14:20:08 1.995 @@ -2697,14 +2697,30 @@ (insert-before-markers string) (set-marker marker (point))))))) +(defvar slime-switch-to-output-buffer-search-all-frames t + "If t search for an already existing REPL window in all frames, +and if found, select that window instead of creating a new one. + +If you use multiple screens, you may want to set this to nil such +that a window on a different screen won't be selected under the +hood.") + (defun slime-switch-to-output-buffer (&optional connection) - "Select the output buffer, preferably in a different window." - (interactive) - (let ((slime-dispatching-connection (or connection - slime-dispatching-connection))) - (set-buffer (slime-output-buffer)) - (unless (eq (current-buffer) (window-buffer)) - (pop-to-buffer (current-buffer) t)) + "Select the output buffer: If a REPL is already displayed, just +set focus to that window. Otherwise, try to make a new window +displaying the REPL." + (interactive) + (let ((slime-dispatching-connection (or connection + slime-dispatching-connection))) + (let* ((repl-buffer (slime-output-buffer)) + (all-frames-p slime-switch-to-output-buffer-search-all-frames) + (repl-window (get-buffer-window repl-buffer all-frames-p))) + (if repl-window + (progn (select-frame-set-input-focus (window-frame repl-window)) + (select-window repl-window)) + (set-buffer repl-buffer) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t)))) (goto-char (point-max)))) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/14 11:46:39 1.1451 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/14 14:20:09 1.1452 @@ -1,5 +1,16 @@ 2008-08-14 Tobias C. Rittweiler + `C-c C-z' now selects an REPL displayed in another frame instead + of splitting the current frame, and displaying the REPL in the + newly created window. + + * slime.el (slime-switch-to-output-buffer-search-all-frames): New + variable to customize this behaviour, as it may not be optimal for + people using multiple screens at once. + (slime-switch-to-output-buffer): Adapted accordingly. + +2008-08-14 Tobias C. Rittweiler + Xref buffers: `M-,' in an Xref buffer will now revert to an Emacs state as of before the Xref command. From trittweiler at common-lisp.net Thu Aug 14 15:32:40 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 14 Aug 2008 11:32:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080814153240.C3DF0450C6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv29902 Modified Files: ChangeLog Log Message: describe last change set better --- /project/slime/cvsroot/slime/ChangeLog 2008/08/14 14:20:09 1.1452 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/14 15:32:40 1.1453 @@ -1,8 +1,8 @@ 2008-08-14 Tobias C. Rittweiler - `C-c C-z' now selects an REPL displayed in another frame instead - of splitting the current frame, and displaying the REPL in the - newly created window. + If another frame is already displaying a REPL, `C-c C-z' will now + select this window instead of splitting the current frame, and + displaying the REPL in the newly created window. * slime.el (slime-switch-to-output-buffer-search-all-frames): New variable to customize this behaviour, as it may not be optimal for From trittweiler at common-lisp.net Fri Aug 15 09:51:45 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 15 Aug 2008 05:51:45 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080815095145.7C21A7E0C0@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv14131 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-popup-buffer-quit): If not kill, then at least bury the buffer. (slime-list-compiler-notes): Shrink the compiler-notes window. --- /project/slime/cvsroot/slime/slime.el 2008/08/14 14:20:08 1.995 +++ /project/slime/cvsroot/slime/slime.el 2008/08/15 09:51:43 1.996 @@ -1043,12 +1043,12 @@ last activated the buffer." (interactive) (let ((popup-buffer (current-buffer))) - (if (slime-popup-buffer-snapshot-unchanged-p) - (slime-popup-buffer-restore-snapshot) - (bury-buffer)) + (when (slime-popup-buffer-snapshot-unchanged-p) + (slime-popup-buffer-restore-snapshot)) (setq slime-popup-buffer-saved-emacs-snapshot nil) - (when kill-buffer-p - (kill-buffer popup-buffer)))) + (if kill-buffer-p + (kill-buffer popup-buffer) + (bury-buffer popup-buffer)))) (defun slime-popup-buffer-snapshot-unchanged-p () (equalp (slime-current-emacs-snapshot-fingerprint) @@ -4178,6 +4178,7 @@ (dolist (tree (slime-compiler-notes-to-tree notes)) (slime-tree-insert tree "") (insert "\n")) + (shrink-window-if-larger-than-buffer) (goto-char (point-min))))) (defun slime-alistify (list key test) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/14 15:32:40 1.1453 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/15 09:51:44 1.1454 @@ -1,3 +1,9 @@ +2008-08-15 Tobias C. Rittweiler + + * slime.el (slime-popup-buffer-quit): If not kill, then at least + bury the buffer. + (slime-list-compiler-notes): Shrink the compiler-notes window. + 2008-08-14 Tobias C. Rittweiler If another frame is already displaying a REPL, `C-c C-z' will now From trittweiler at common-lisp.net Fri Aug 15 20:48:56 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 15 Aug 2008 16:48:56 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080815204856.0B504232BC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv8306 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-list-compiler-notes): Only shrink if notes tree isn't displayed as being collapsed. --- /project/slime/cvsroot/slime/slime.el 2008/08/15 09:51:43 1.996 +++ /project/slime/cvsroot/slime/slime.el 2008/08/15 20:48:54 1.997 @@ -4175,11 +4175,14 @@ (slime-compiler-notes-mode) (when (null notes) (insert "[no notes]")) - (dolist (tree (slime-compiler-notes-to-tree notes)) - (slime-tree-insert tree "") - (insert "\n")) - (shrink-window-if-larger-than-buffer) - (goto-char (point-min))))) + (let ((collapsed-p)) + (dolist (tree (slime-compiler-notes-to-tree notes)) + (when (slime-tree.collapsed-p tree) (setf collapsed-p t)) + (slime-tree-insert tree "") + (insert "\n")) + (unless collapsed-p + (shrink-window-if-larger-than-buffer)) + (goto-char (point-min)))))) (defun slime-alistify (list key test) "Partition the elements of LIST into an alist. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/15 09:51:44 1.1454 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/15 20:48:54 1.1455 @@ -1,5 +1,10 @@ 2008-08-15 Tobias C. Rittweiler + * slime.el (slime-list-compiler-notes): Only shrink if notes tree + isn't displayed as being collapsed. + +2008-08-15 Tobias C. Rittweiler + * slime.el (slime-popup-buffer-quit): If not kill, then at least bury the buffer. (slime-list-compiler-notes): Shrink the compiler-notes window. From trittweiler at common-lisp.net Fri Aug 15 22:59:10 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 15 Aug 2008 18:59:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080815225910.DE968A148@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18778 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-popup-buffer-quit): Fix regression; we have to invoke `bury-buffer' without an argument to make it switch buffers for us (for the case when the snapshot wasn't restored.) --- /project/slime/cvsroot/slime/slime.el 2008/08/15 20:48:54 1.997 +++ /project/slime/cvsroot/slime/slime.el 2008/08/15 22:59:09 1.998 @@ -1046,9 +1046,10 @@ (when (slime-popup-buffer-snapshot-unchanged-p) (slime-popup-buffer-restore-snapshot)) (setq slime-popup-buffer-saved-emacs-snapshot nil) - (if kill-buffer-p - (kill-buffer popup-buffer) - (bury-buffer popup-buffer)))) + (with-current-buffer popup-buffer + ;; This will switch to another buffer if snapshot wasn't restored. + (bury-buffer) + (when kill-buffer-p (kill-buffer))))) (defun slime-popup-buffer-snapshot-unchanged-p () (equalp (slime-current-emacs-snapshot-fingerprint) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/15 20:48:54 1.1455 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/15 22:59:10 1.1456 @@ -1,5 +1,11 @@ 2008-08-15 Tobias C. Rittweiler + * slime.el (slime-popup-buffer-quit): Fix regression; we have to + invoke `bury-buffer' without an argument to make it switch buffers + for us (for the case when the snapshot wasn't restored.) + +2008-08-15 Tobias C. Rittweiler + * slime.el (slime-list-compiler-notes): Only shrink if notes tree isn't displayed as being collapsed. From heller at common-lisp.net Sun Aug 17 08:31:17 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 04:31:17 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817083117.EBA3A16@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28448 Modified Files: ChangeLog swank-loader.lisp Log Message: * swank-loader.lisp (dump-image): Move this function to the end of the file to stop SBCL from reporting two times the same false alarm. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/15 22:59:10 1.1456 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 08:31:14 1.1457 @@ -1,3 +1,9 @@ +2008-08-15 B.Scott Michel + + * swank-loader.lisp (dump-image): Move this function to the end of + the file to stop SBCL from reporting two times the same false + alarm. + 2008-08-15 Tobias C. Rittweiler * slime.el (slime-popup-buffer-quit): Fix regression; we have to --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/08/12 17:54:44 1.87 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/08/17 08:31:17 1.88 @@ -226,10 +226,6 @@ (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))) (funcall (q "swank::init"))) -(defun dump-image (filename) - (init :setup nil) - (funcall (q "swank-backend:save-image") filename)) - (defun init (&key delete reload load-contribs (setup t)) (when (and delete (find-package :swank)) (mapc #'delete-package '(:swank :swank-io-package :swank-backend))) @@ -241,3 +237,7 @@ (compile-contribs :load t)) (when setup (setup))) + +(defun dump-image (filename) + (init :setup nil) + (funcall (q "swank-backend:save-image") filename)) From heller at common-lisp.net Sun Aug 17 08:31:22 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 04:31:22 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817083122.509842F048@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28472 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (sb-thread::get-foreground): Don't override. Let SBCL people fix this. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 08:31:14 1.1457 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 08:31:22 1.1458 @@ -1,4 +1,9 @@ -2008-08-15 B.Scott Michel +2008-08-17 Helmut Eller + + * swank-sbcl.lisp (sb-thread::get-foreground): Don't override. + Let SBCL people fix this. + +2008-08-17 B.Scott Michel * swank-loader.lisp (dump-image): Move this function to the end of the file to stop SBCL from reporting two times the same false --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/12 17:54:44 1.214 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/17 08:31:22 1.215 @@ -1324,20 +1324,6 @@ (sb-thread:condition-wait (mailbox.waitqueue mbox) mutex)) (sb-ext:timeout ())))))) - - #-non-broken-terminal-sessions - (progn - (defvar *native-wait-for-terminal* #'sb-thread::get-foreground) - (sb-ext:with-unlocked-packages (sb-thread) - (defun sb-thread::get-foreground () - (ignore-errors - (format *debug-io* ";; SWANK: sb-thread::get-foreground ...~%") - (finish-output *debug-io*)) - (or (and (typep *debug-io* 'two-way-stream) - (typep (two-way-stream-input-stream *debug-io*) - 'slime-input-stream)) - (funcall *native-wait-for-terminal*))))) - ) (defimplementation quit-lisp () From heller at common-lisp.net Sun Aug 17 08:31:26 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 04:31:26 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817083126.A0D0D7E0F7@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv28523 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (waitpid): Don't use unix::pid-t, it's only defined for Linux. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 08:31:22 1.1458 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 08:31:26 1.1459 @@ -1,7 +1,10 @@ 2008-08-17 Helmut Eller - * swank-sbcl.lisp (sb-thread::get-foreground): Don't override. - Let SBCL people fix this. + * swank-cmucl.lisp (waitpid): Don't use unix::pid-t, it's only + defined for Linux. + + * swank-sbcl.lisp (sb-thread::get-foreground): Don't override. + Let SBCL people fix this. 2008-08-17 B.Scott Michel --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/12 17:54:44 1.187 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/17 08:31:26 1.188 @@ -2288,8 +2288,7 @@ (alien:with-alien ((status c-call:int)) (let ((code (alien:alien-funcall (alien:extern-alien - waitpid (alien:function unix::pid-t - unix::pid-t + waitpid (alien:function c-call:int c-call:int (* c-call:int) c-call:int)) pid (alien:addr status) 0))) (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) From trittweiler at common-lisp.net Sun Aug 17 22:07:58 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 17 Aug 2008 18:07:58 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817220758.194736F23F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6440 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-switch-to-output-buffer): Fix regression discovered by Ariel Badichi. Programmatic invocation of this function expect this function to also set-buffer to the REPL buffer. Even though that's ugly, we do it for now, and declare it to be a FIXME. (slime-dispatch-event): Don't use `message' for the pipelined request message, but `slime-display-oneliner' which will truncate the form to be displayed. --- /project/slime/cvsroot/slime/slime.el 2008/08/15 22:59:09 1.998 +++ /project/slime/cvsroot/slime/slime.el 2008/08/17 22:07:57 1.999 @@ -2331,7 +2331,7 @@ (slime-write-string output target)) ((:emacs-rex form package thread continuation) (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) - (message "; pipelined request... %S" form)) + (slime-display-oneliner "; pipelined request... %S" form)) (let ((id (incf (slime-continuation-counter)))) (push (cons id continuation) (slime-rex-continuations)) (slime-send `(:emacs-rex ,form ,package ,thread ,id)))) @@ -2716,10 +2716,13 @@ (let* ((repl-buffer (slime-output-buffer)) (all-frames-p slime-switch-to-output-buffer-search-all-frames) (repl-window (get-buffer-window repl-buffer all-frames-p))) + ;; FIXME: I don't think that this function should set the + ;; buffer. We currently do it, because the programmatic + ;; invocations of this function expect this. + (set-buffer repl-buffer) (if repl-window (progn (select-frame-set-input-focus (window-frame repl-window)) (select-window repl-window)) - (set-buffer repl-buffer) (unless (eq (current-buffer) (window-buffer)) (pop-to-buffer (current-buffer) t)))) (goto-char (point-max)))) --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 08:31:26 1.1459 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 22:07:57 1.1460 @@ -1,3 +1,14 @@ +2008-08-15 Tobias C. Rittweiler + + * slime.el (slime-switch-to-output-buffer): Fix regression + discovered by Ariel Badichi. Programmatic invocation of this + function expect this function to also set-buffer to the REPL + buffer. Even though that's ugly, we do it for now, and declare it + to be a FIXME. + (slime-dispatch-event): Don't use `message' for the pipelined + request message, but `slime-display-oneliner' which will truncate + the form to be displayed. + 2008-08-17 Helmut Eller * swank-cmucl.lisp (waitpid): Don't use unix::pid-t, it's only From heller at common-lisp.net Sun Aug 17 23:00:50 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 19:00:50 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817230050.B23C230021@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21085 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-add-local-hook): Renamed from add-local-hook. (slime-switch-to-output-buffer): Drop the connection argument. It was never used. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 22:07:57 1.1460 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:00:46 1.1461 @@ -1,3 +1,9 @@ +2008-08-17 Helmut Eller + + * slime.el (slime-add-local-hook): Renamed from add-local-hook. + (slime-switch-to-output-buffer): Drop the connection argument. It + was never used. + 2008-08-15 Tobias C. Rittweiler * slime.el (slime-switch-to-output-buffer): Fix regression --- /project/slime/cvsroot/slime/slime.el 2008/08/17 22:07:57 1.999 +++ /project/slime/cvsroot/slime/slime.el 2008/08/17 23:00:50 1.1000 @@ -666,8 +666,8 @@ (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." - (add-local-hook 'pre-command-hook 'slime-pre-command-hook) - (add-local-hook 'post-command-hook 'slime-post-command-hook)) + (slime-add-local-hook 'pre-command-hook 'slime-pre-command-hook) + (slime-add-local-hook 'post-command-hook 'slime-post-command-hook)) ;;;; Framework'ey bits @@ -1042,14 +1042,12 @@ Restore the window configuration unless it was changed since we last activated the buffer." (interactive) - (let ((popup-buffer (current-buffer))) + (let ((buffer (current-buffer))) (when (slime-popup-buffer-snapshot-unchanged-p) (slime-popup-buffer-restore-snapshot)) (setq slime-popup-buffer-saved-emacs-snapshot nil) - (with-current-buffer popup-buffer - ;; This will switch to another buffer if snapshot wasn't restored. - (bury-buffer) - (when kill-buffer-p (kill-buffer))))) + (cond (kill-buffer-p (kill-buffer buffer)) + (t (bury-buffer buffer))))) (defun slime-popup-buffer-snapshot-unchanged-p () (equalp (slime-current-emacs-snapshot-fingerprint) @@ -1057,8 +1055,8 @@ (defun slime-popup-buffer-restore-snapshot () (let ((snapshot slime-popup-buffer-saved-emacs-snapshot)) - (assert snapshot) (slime-set-emacs-snapshot snapshot))) - + (assert snapshot) + (slime-set-emacs-snapshot snapshot))) ;;;;; Filename translation ;;; @@ -2233,7 +2231,7 @@ ((:ok value) (unless (member tag slime-stack-eval-tags) (error "Reply to canceled synchronous eval request tag=%S sexp=%S" - tag slime-stack-eval-tags sexp)) + tag sexp)) (throw tag (list #'identity value))) ((:abort) (throw tag (list #'error "Synchronous Lisp Evaluation aborted")))) @@ -2706,7 +2704,7 @@ that a window on a different screen won't be selected under the hood.") -(defun slime-switch-to-output-buffer (&optional connection) +(defun slime-switch-to-output-buffer () "Select the output buffer: If a REPL is already displayed, just set focus to that window. Otherwise, try to make a new window displaying the REPL." @@ -2725,6 +2723,7 @@ (select-window repl-window)) (unless (eq (current-buffer) (window-buffer)) (pop-to-buffer (current-buffer) t)))) + (assert (eq (current-buffer) repl-buffer)) (goto-char (point-max)))) @@ -2878,7 +2877,8 @@ (set (make-local-variable 'scroll-margin) 0) (when slime-repl-history-file (slime-repl-safe-load-history) - (add-local-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history)) + (slime-add-local-hook 'kill-buffer-hook + 'slime-repl-safe-save-merged-history)) (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories) (slime-setup-command-hooks) ;; At the REPL, we define beginning-of-defun and end-of-defun to be @@ -4971,9 +4971,8 @@ t)) (defun slime-complete-delay-restoration () - (make-local-hook 'pre-command-hook) - (add-hook 'pre-command-hook - 'slime-complete-maybe-restore-window-configuration)) + (slime-add-local-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration)) (defun slime-complete-forget-window-configuration () (setq slime-complete-saved-window-configuration nil) @@ -6680,7 +6679,7 @@ (slime-set-truncate-lines) ;; Make original slime-connection "sticky" for SLDB commands in this buffer (setq slime-buffer-connection (slime-connection)) - (add-local-hook 'kill-buffer-hook 'sldb-delete-overlays)) + (slime-add-local-hook 'kill-buffer-hook 'sldb-delete-overlays)) (slime-define-keys sldb-mode-map ("h" 'describe-mode) @@ -8442,6 +8441,8 @@ (defvar slime-test-buffer-name "*Tests*" "The name of the buffer used to display test results.") +(defvar slime-lisp-under-test nil + "The name of Lisp currently executing the tests.") ;; dynamically bound during a single test (defvar slime-current-test) @@ -9658,6 +9659,13 @@ ;; Emacs 21 uses microsecs; Emacs 22 millisecs (if timeout (truncate (* timeout 1000000))))))) +(defun slime-add-local-hook (hook function &optional append) + (cond ((featurep 'xemacs) (add-local-hook hook function append)) + ((< emacs-major-version 21) + (make-local-hook hook) + (add-hook hook function append t)) + (t (add-hook hook function append t)))) + (slime-defun-if-undefined next-single-char-property-change (position prop &optional object limit) (let ((limit (typecase limit @@ -9931,15 +9939,6 @@ (select-window ,window) , at body)) -;;; Stuff only available in XEmacs -(slime-defun-if-undefined add-local-hook (hook function &optional append) - (make-local-hook hook) - (add-hook hook function append t)) - -(slime-defun-if-undefined remove-local-hook (hook function) - (if (local-variable-p hook (current-buffer)) - (remove-hook hook function t))) - ;;;; Finishing up From heller at common-lisp.net Sun Aug 17 23:00:56 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 19:00:56 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817230056.7E8D7601AD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21332 Modified Files: ChangeLog slime.el Log Message: (slime-switch-to-output-buffer-search-all-frames): Deleted. Use display-buffer-reuse-frames instead. (slime-switch-to-output-buffer): Use pop-to-buffer to select the window and frame. Have to set the input-focus manually, though. Might be some window manager issue. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:00:46 1.1461 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:00:55 1.1462 @@ -3,6 +3,11 @@ * slime.el (slime-add-local-hook): Renamed from add-local-hook. (slime-switch-to-output-buffer): Drop the connection argument. It was never used. + (slime-switch-to-output-buffer-search-all-frames): Deleted. Use + display-buffer-reuse-frames instead. + (slime-switch-to-output-buffer): Use pop-to-buffer to select the + window and frame. Have to set the input-focus manually, though. + Might be some window manager issue. 2008-08-15 Tobias C. Rittweiler @@ -25,9 +30,9 @@ 2008-08-17 B.Scott Michel - * swank-loader.lisp (dump-image): Move this function to the end of - the file to stop SBCL from reporting two times the same false - alarm. + * swank-loader.lisp (dump-image): Move this function to the end of + the file to stop SBCL from reporting two times the same false + alarm. 2008-08-15 Tobias C. Rittweiler --- /project/slime/cvsroot/slime/slime.el 2008/08/17 23:00:50 1.1000 +++ /project/slime/cvsroot/slime/slime.el 2008/08/17 23:00:56 1.1001 @@ -2696,35 +2696,15 @@ (insert-before-markers string) (set-marker marker (point))))))) -(defvar slime-switch-to-output-buffer-search-all-frames t - "If t search for an already existing REPL window in all frames, -and if found, select that window instead of creating a new one. - -If you use multiple screens, you may want to set this to nil such -that a window on a different screen won't be selected under the -hood.") - (defun slime-switch-to-output-buffer () - "Select the output buffer: If a REPL is already displayed, just -set focus to that window. Otherwise, try to make a new window -displaying the REPL." - (interactive) - (let ((slime-dispatching-connection (or connection - slime-dispatching-connection))) - (let* ((repl-buffer (slime-output-buffer)) - (all-frames-p slime-switch-to-output-buffer-search-all-frames) - (repl-window (get-buffer-window repl-buffer all-frames-p))) - ;; FIXME: I don't think that this function should set the - ;; buffer. We currently do it, because the programmatic - ;; invocations of this function expect this. - (set-buffer repl-buffer) - (if repl-window - (progn (select-frame-set-input-focus (window-frame repl-window)) - (select-window repl-window)) - (unless (eq (current-buffer) (window-buffer)) - (pop-to-buffer (current-buffer) t)))) - (assert (eq (current-buffer) repl-buffer)) - (goto-char (point-max)))) + "Select the output buffer, when possible in an existing window. + +Hint: You can use `display-buffer-reuse-frames' and +`special-display-buffer-names' to customize the frame in which +the buffer should appear." + (interactive) + (pop-to-buffer (slime-output-buffer)) + (goto-char (point-max))) ;;;; REPL From heller at common-lisp.net Sun Aug 17 23:01:07 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 19:01:07 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817230107.D386D70308@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21383 Modified Files: ChangeLog slime.el swank.lisp Log Message: * slime.el (slime-inspector-show-source): New command. (slime-inspector-mode-map): Bind it to ".". (sldb-highlight-sexp): Use slime-flash-region rather than a permanent overlay. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:00:55 1.1462 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:01:02 1.1463 @@ -1,13 +1,19 @@ 2008-08-17 Helmut Eller + * slime.el (slime-inspector-show-source): New command. + (slime-inspector-mode-map): Bind it to ".". + (sldb-highlight-sexp): Use slime-flash-region rather than a + permanent overlay. + + * swank.lisp (find-source-location-for-emacs): New function. + * slime.el (slime-add-local-hook): Renamed from add-local-hook. (slime-switch-to-output-buffer): Drop the connection argument. It was never used. (slime-switch-to-output-buffer-search-all-frames): Deleted. Use display-buffer-reuse-frames instead. (slime-switch-to-output-buffer): Use pop-to-buffer to select the - window and frame. Have to set the input-focus manually, though. - Might be some window manager issue. + window and frame. 2008-08-15 Tobias C. Rittweiler --- /project/slime/cvsroot/slime/slime.el 2008/08/17 23:00:56 1.1001 +++ /project/slime/cvsroot/slime/slime.el 2008/08/17 23:01:06 1.1002 @@ -7132,10 +7132,7 @@ (sldb-delete-overlays) (let ((start (or start (point))) (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) - (push (make-overlay start (1+ start)) sldb-overlays) - (push (make-overlay (1- end) end) sldb-overlays)) - (dolist (overlay sldb-overlays) - (overlay-put overlay 'face 'secondary-selection))) + (slime-flash-region start end))) (defun sldb-delete-overlays () (mapc #'delete-overlay sldb-overlays) @@ -7867,6 +7864,13 @@ (error "No part at point")))) (slime-eval-describe `(swank:pprint-inspector-part ,part))) +(defun slime-inspector-show-source (part) + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-eval-async + `(swank:find-source-location-for-emacs '(:inspector ,part)) + #'slime-show-source-location)) + (defun slime-inspector-reinspect () (interactive) (slime-eval-async `(swank:inspector-reinspect) @@ -7940,7 +7944,8 @@ ("\C-i" 'slime-inspector-next-inspectable-object) ([(shift tab)] 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X. - ("\M-." 'slime-edit-definition)) + ("\M-." 'slime-edit-definition) + ("." 'slime-inspector-show-source)) ;;;; Buffer selector --- /project/slime/cvsroot/slime/swank.lisp 2008/08/12 12:57:09 1.569 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/17 23:01:06 1.570 @@ -2742,6 +2742,19 @@ (defslimefun find-definition-for-thing (thing) (find-source-location thing)) +(defslimefun find-source-location-for-emacs (spec) + (find-source-location (value-spec-ref spec))) + +(defun value-spec-ref (spec) + (destructure-case spec + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (inspector-nth-part part)) + ((:sldb frame var) + (frame-var-value frame var)))) + (defslimefun find-definitions-for-emacs (name) "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. DSPEC is a string and LOCATION a source location. NAME is a string." From heller at common-lisp.net Sun Aug 17 23:01:13 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 19:01:13 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817230113.467F1D012@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21426 Modified Files: ChangeLog slime.el Log Message: (slime-popup-buffer-quit): Must call bury-buffer without argument. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:01:02 1.1463 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:01:12 1.1464 @@ -4,6 +4,7 @@ (slime-inspector-mode-map): Bind it to ".". (sldb-highlight-sexp): Use slime-flash-region rather than a permanent overlay. + (slime-popup-buffer-quit): Must call bury-buffer without argument. * swank.lisp (find-source-location-for-emacs): New function. --- /project/slime/cvsroot/slime/slime.el 2008/08/17 23:01:06 1.1002 +++ /project/slime/cvsroot/slime/slime.el 2008/08/17 23:01:13 1.1003 @@ -1047,7 +1047,7 @@ (slime-popup-buffer-restore-snapshot)) (setq slime-popup-buffer-saved-emacs-snapshot nil) (cond (kill-buffer-p (kill-buffer buffer)) - (t (bury-buffer buffer))))) + (t (with-current-buffer buffer (bury-buffer)))))) (defun slime-popup-buffer-snapshot-unchanged-p () (equalp (slime-current-emacs-snapshot-fingerprint) From heller at common-lisp.net Sun Aug 17 23:01:20 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Aug 2008 19:01:20 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080817230120.6A9CF30021@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21466 Modified Files: ChangeLog swank.lisp test.sh Log Message: * swank.lisp (install-fd-handler): Bind *emacs-connection* with with-connection, for case when the signal hander is called out of the blue. (swank-debugger-hook): Don't assume that the hook argument is #'swank-debugger-hook itself. * test.sh (usage): Use cat rather not echo for here-documents. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:01:12 1.1464 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:01:18 1.1465 @@ -1,3 +1,13 @@ +2008-08-18 Helmut Eller + + * swank.lisp (install-fd-handler): Bind *emacs-connection* with + with-connection, for case when the signal hander is called out of + the blue. + (swank-debugger-hook): Don't assume that the hook argument is + #'swank-debugger-hook itself. + + * test.sh (usage): Use cat rather not echo for here-documents. + 2008-08-17 Helmut Eller * slime.el (slime-inspector-show-source): New command. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/17 23:01:06 1.570 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/17 23:01:19 1.571 @@ -1167,7 +1167,8 @@ (lambda () (invoke-or-queue-interrupt (lambda () - (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))))) + (with-connection (connection) + (dispatch-event `(:emacs-interrupt ,(current-thread-id))))))))) (handle-or-process-requests connection)) (defun deinstall-fd-handler (connection) @@ -2045,9 +2046,10 @@ (defun swank-debugger-hook (condition hook) "Debugger function for binding *DEBUGGER-HOOK*." + (declare (ignore hook)) (restart-case (call-with-debugger-hook - hook (lambda () (invoke-slime-debugger condition))) + #'swank-debugger-hook (lambda () (invoke-slime-debugger condition))) (default-debugger (&optional v) :report "Use default debugger." (declare (ignore v)) (invoke-default-debugger condition)))) --- /project/slime/cvsroot/slime/test.sh 2008/08/12 12:56:51 1.14 +++ /project/slime/cvsroot/slime/test.sh 2008/08/17 23:01:19 1.15 @@ -14,11 +14,11 @@ # are disclaimed. function usage () { - echo < " --b disable batch mode --s use screen to hide emacs --r show results file + -b disable batch mode + -s use screen to hide emacs + -r show results file EOF exit 1 } @@ -26,7 +26,7 @@ name=$0 batch_mode=-batch -while getopts vrb opt; do +while getopts srb opt; do case $opt in s) use_screen=true;; r) dump_results=true;; From trittweiler at common-lisp.net Mon Aug 18 09:20:21 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 18 Aug 2008 05:20:21 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080818092021.91A3773205@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv6735/contrib Modified Files: slime-presentations.el slime-fuzzy.el ChangeLog Log Message: * slime-fuzzy.el: Rename `add-local-hook' to `slime-add-local-hook'. * slime-presentations.el: Ditto. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/08/03 13:31:54 1.16 +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/08/18 09:20:20 1.17 @@ -858,8 +858,8 @@ (lambda () ;; Respect the syntax text properties of presentation. (set (make-local-variable 'parse-sexp-lookup-properties) t) - (add-local-hook 'after-change-functions - 'slime-after-change-function))) + (slime-add-local-hook 'after-change-functions + 'slime-after-change-function))) (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event) (setq slime-write-string-function 'slime-presentation-write) (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed) --- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2008/03/14 14:33:07 1.7 +++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el 2008/08/18 09:20:20 1.8 @@ -359,7 +359,7 @@ (when (boundp 'window-configuration-change-hook) (add-hook 'window-configuration-change-hook 'slime-fuzzy-window-configuration-change)) - (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort) + (slime-add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort) (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc (when slime-fuzzy-completion-in-place ;; switch back to the original buffer --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/12 17:54:37 1.120 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/18 09:20:21 1.121 @@ -1,3 +1,8 @@ +2008-08-18 Ariel Badichi + + * slime-fuzzy.el: Rename `add-local-hook' to `slime-add-local-hook'. + * slime-presentations.el: Ditto. + 2008-08-12 Helmut Eller * slime-clipboard.el (slime-clipboard-insert-ref): Set From trittweiler at common-lisp.net Wed Aug 20 11:42:47 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 20 Aug 2008 07:42:47 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080820114247.B7A0F55357@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv509/contrib Modified Files: slime-indentation.el ChangeLog Log Message: * contrib/slime-indentation.el: fix indentation of IF forms. --- /project/slime/cvsroot/slime/contrib/slime-indentation.el 2008/04/14 21:31:20 1.2 +++ /project/slime/cvsroot/slime/contrib/slime-indentation.el 2008/08/20 11:42:47 1.3 @@ -1065,7 +1065,7 @@ (flet ((&whole 4 &rest (&whole 1 (&whole 4 &rest 1) &body)) &body)) (labels . flet) (macrolet . flet) - (if (&rest 2)) + (if (&rest 4)) ;; FIXME: Which of those do I really want? ;; (lambda ((&whole 4 &rest 1) &body)) (lambda ((&whole 4 &rest 1) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/18 09:20:21 1.121 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/20 11:42:47 1.122 @@ -1,3 +1,7 @@ +2008-08-20 Lu?s Oliveira + + * contrib/slime-indentation.el: fix indentation of IF forms. + 2008-08-18 Ariel Badichi * slime-fuzzy.el: Rename `add-local-hook' to `slime-add-local-hook'. From trittweiler at common-lisp.net Wed Aug 20 21:46:09 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Wed, 20 Aug 2008 17:46:09 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080820214609.724D35F05C@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv11264/contrib Modified Files: slime-fancy.el ChangeLog Added Files: slime-fontifying-fu.el Log Message: * slime-fontifying-fu.el: New contrib; fontify with-foo and do-foo like standard macros. * slime-fancy.el: Add slime-fontifying-fu. --- /project/slime/cvsroot/slime/contrib/slime-fancy.el 2008/08/07 15:24:08 1.6 +++ /project/slime/cvsroot/slime/contrib/slime-fancy.el 2008/08/20 21:46:09 1.7 @@ -79,4 +79,8 @@ (require 'slime-package-fu) (slime-package-fu-init) +;; Fontify with-foo and do-foo like standard macros. +(require 'slime-fontifying-fu) +(slime-fontifying-fu-init) + (provide 'slime-fancy) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/20 11:42:47 1.122 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/20 21:46:09 1.123 @@ -1,3 +1,10 @@ +2008-08-20 Tobias C. Rittweiler + + * slime-fontifying-fu.el: New contrib; fontify with-foo and do-foo + like standard macros. + + * slime-fancy.el: Add slime-fontifying-fu. + 2008-08-20 Lu?s Oliveira * contrib/slime-indentation.el: fix indentation of IF forms. --- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2008/08/20 21:46:09 NONE +++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el 2008/08/20 21:46:09 1.1 ;;; slime-fontifying-fu.el --- Additional fontification tweaks. ;; ;; Author: Tobias C. Rittweiler ;; ;; License: GNU GPL (same license as Emacs) ;; ;; Fontify WITH-FOO and DO-FOO like standard macros; fontify ;; CHECK-FOO like CHECK-TYPE. (defvar slime-additional-font-lock-keywords '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face))) (defun slime-fontifying-fu-init () (font-lock-add-keywords 'lisp-mode slime-additional-font-lock-keywords)) (defun slime-fontifying-fu-unload () (font-lock-remove-keywords 'lisp-mode slime-additional-font-lock-keywords)) (provide 'slime-fontifying-fu) From trittweiler at common-lisp.net Fri Aug 22 14:28:41 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 22 Aug 2008 10:28:41 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822142841.648325204A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20214 Modified Files: swank.lisp swank-sbcl.lisp swank-backend.lisp Log Message: Compiling a file `let*.lisp' on SBCL via C-c C-k resulted in an error, because it parsed the asterisk to a wild pathname. Fix that. * swank-backend.lisp (definterface parse-emacs-filename): New. PARSE-NAMESTRING by default. * swank-sbcl.lisp (defimplementation parse-emacs-filename): Use SB-EXT:PARSE-NATIVE-NAMESTRING. * swank.lisp (compile-file-for-emacs): Use PARSE-EMACS-FILENAME. (compile-file-if-needed): Ditto. (load-file): Ditto. (swank-require): Ditto. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/17 23:01:19 1.571 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/22 14:28:40 1.572 @@ -2377,9 +2377,10 @@ (let ((*compile-print* nil)) (swank-compiler (lambda () - (swank-compile-file filename load-p - (or (guess-external-format filename) - :default)))))))) + (let ((pathname (parse-emacs-filename filename))) + (swank-compile-file pathname load-p + (or (guess-external-format pathname) + :default))))))))) (defslimefun compile-string-for-emacs (string buffer position directory debug) "Compile STRING (exerpted from BUFFER at POSITION). @@ -2404,17 +2405,18 @@ (file-newer-p source-file fasl-file)))) (defslimefun compile-file-if-needed (filename loadp) - (cond ((requires-compile-p filename) - (compile-file-for-emacs filename loadp)) - (loadp - (load (compile-file-pathname filename)) - nil))) + (let ((pathname (parse-emacs-filename filename))) + (cond ((requires-compile-p pathname) + (compile-file-for-emacs pathname loadp)) + (loadp + (load (compile-file-pathname pathname)) + nil)))) ;;;; Loading (defslimefun load-file (filename) - (to-string (load filename))) + (to-string (load (parse-emacs-filename filename)))) ;;;;; swank-require @@ -2423,7 +2425,9 @@ "Load the module MODULE." (dolist (module (if (listp modules) modules (list modules))) (unless (member (string module) *modules* :test #'string=) - (require module (or filename (module-filename module))))) + (require module (if filename + (parse-emacs-filename filename) + (module-filename module))))) *modules*) (defvar *find-module* 'find-module --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/17 08:31:22 1.215 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/22 14:28:41 1.216 @@ -173,6 +173,12 @@ (:euc-jp "euc-jp" "euc-jp-unix") (:us-ascii "us-ascii" "us-ascii-unix"))) +;; C.f. R.M.Kreuter in <20536.1219412774 at progn.net> on sbcl-general, 2008-08-22. +(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) + +(defimplementation parse-emacs-filename (filename) + (sb-ext:parse-native-namestring filename *physical-pathname-host*)) + (defimplementation find-external-format (coding-system) (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*))) @@ -429,14 +435,14 @@ (defvar *trap-load-time-warnings* nil) -(defimplementation swank-compile-file (filename load-p external-format) +(defimplementation swank-compile-file (pathname load-p external-format) (handler-case (let ((output-file (with-compilation-hooks () - (compile-file filename + (compile-file pathname :external-format external-format)))) (when output-file ;; Cache the latest source file for definition-finding. - (source-cache-get filename (file-write-date filename)) + (source-cache-get pathname (file-write-date pathname)) (when load-p (load output-file)))) (sb-c:fatal-compiler-error () nil))) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/12 17:54:43 1.145 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/22 14:28:41 1.146 @@ -369,8 +369,8 @@ Should return T on successfull compilation, NIL otherwise. ") -(definterface swank-compile-file (filename load-p external-format) - "Compile FILENAME signalling COMPILE-CONDITIONs. +(definterface swank-compile-file (pathname load-p external-format) + "Compile PATHNAME signalling COMPILE-CONDITIONs. If LOAD-P is true, load the file after compilation. EXTERNAL-FORMAT is a value returned by find-external-format or :default. @@ -407,6 +407,11 @@ (location :initarg :location :accessor location))) +(definterface parse-emacs-filename (filename) + "Return a PATHNAME for FILENAME. A filename in Emacs may for example +contain asterisks which should not be translated to wildcards." + (parse-namestring filename)) + (definterface find-external-format (coding-system) "Return a \"external file format designator\" for CODING-SYSTEM. CODING-SYSTEM is Emacs-style coding system name (a string), @@ -415,11 +420,11 @@ :default nil)) -(definterface guess-external-format (filename) - "Detect the external format for the file with name FILENAME. +(definterface guess-external-format (pathname) + "Detect the external format for the file with name pathname. Return nil if the file contains no special markers." ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. - (with-open-file (s filename :if-does-not-exist nil + (with-open-file (s pathname :if-does-not-exist nil :external-format (or (find-external-format "latin-1-unix") :default)) (if s @@ -992,7 +997,7 @@ 0) (definterface all-threads () - "Return a list of all threads.") + "Return a fresh list of all threads.") (definterface thread-alive-p (thread) "Test if THREAD is termintated." From heller at common-lisp.net Fri Aug 22 21:14:53 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:14:53 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211453.6A5983A022@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22649 Modified Files: ChangeLog swank.lisp Log Message: Collect most of the inspector state in a structrure. Truncate the printer output more aggressively. * swank.lisp (inspector-state): New structure. (*istate*): New variable holds the current state. (inspect-object, inspector-content, inspector-nth-part) (inspector-range, inspector-call-nth-action, describe-inspectee): Use it. (inspector-pop, inspector-next): Implemented forward/backward a bit differently. (emacs-inspect/printer-bindings, istate>elisp): New functions. (to-line, truncate-string): New functions. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/17 23:01:18 1.1465 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:14:52 1.1466 @@ -1,3 +1,18 @@ +2008-08-22 Helmut Eller + + Collect most of the inspector state in a structrure. + Truncate the printer output more aggressively. + + * swank.lisp (inspector-state): New structure. + (*istate*): New variable holds the current state. + (inspect-object, inspector-content, inspector-nth-part) + (inspector-range, inspector-call-nth-action, describe-inspectee): + Use it. + (inspector-pop, inspector-next): Implemented forward/backward a + bit differently. + (emacs-inspect/printer-bindings, istate>elisp): New functions. + (to-line, truncate-string): New functions. + 2008-08-18 Helmut Eller * swank.lisp (install-fd-handler): Bind *emacs-connection* with --- /project/slime/cvsroot/slime/swank.lisp 2008/08/22 14:28:40 1.572 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:14:52 1.573 @@ -1934,6 +1934,12 @@ (string (write-string s out)) (character (write-char s out)))))) +(defun truncate-string (string width &optional ellipsis) + (let ((len (length string))) + (cond ((< len width) string) + (ellipsis (cat (subseq string 0 width) ellipsis)) + (t (subseq string 0 width))))) + (defun package-string-for-prompt (package) "Return the shortest nickname (or canonical name) of PACKAGE." (unparse-name @@ -2789,113 +2795,130 @@ ;;;; Inspecting -(defvar *inspectee*) -(defvar *inspectee-content*) -(defvar *inspectee-parts*) -(defvar *inspectee-actions*) -(defvar *inspector-stack*) +(defstruct (inspector-state (:conc-name istate.)) + object + (parts (make-array 10 :adjustable t :fill-pointer 0)) + (actions (make-array 10 :adjustable t :fill-pointer 0)) + content + next previous) + +(defvar *istate* nil) (defvar *inspector-history*) (defun reset-inspector () - (setq *inspectee* nil - *inspectee-content* nil - *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0) - *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) - *inspector-stack* '() + (setq *istate* nil *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) - + (defslimefun init-inspector (string) (with-buffer-syntax () (reset-inspector) (inspect-object (eval (read-from-string string))))) (defun inspect-object (o) - (push (setq *inspectee* o) *inspector-stack*) - (unless (find o *inspector-history*) - (vector-push-extend o *inspector-history*)) - (let ((*print-pretty* nil) ; print everything in the same line - (*print-circle* t) - (*print-readably* nil)) - (setq *inspectee-content* (inspector-content (emacs-inspect o)))) + (let ((previous *istate*) + (content (emacs-inspect/printer-bindings o))) + (unless (find o *inspector-history*) + (vector-push-extend o *inspector-history*)) + (setq *istate* (make-inspector-state :object o :previous previous + :content content)) + (if previous (setf (istate.next previous) *istate*)) + (istate>elisp *istate*))) + +(defun emacs-inspect/printer-bindings (object) + (let ((*print-lines* 1) (*print-right-margin* 75) + (*print-pretty* t) (*print-readably* nil)) + (emacs-inspect object))) + +(defun istate>elisp (istate) (list :title (with-output-to-string (s) - (print-unreadable-object (o s :type t :identity t))) - :id (assign-index o *inspectee-parts*) - :content (content-range *inspectee-content* 0 500))) + (print-unreadable-object ((istate.object istate) + s :type t :identity t))) + :id (assign-index (istate.object istate) (istate.parts istate)) + :content (content-range (inspector-content istate) 0 500))) -(defun inspector-content (specs) - (loop for part in specs collect +(defun inspector-content (istate) + (loop for part in (istate.content istate) collect (etypecase part (string part) (cons (destructure-case part ((:newline) '#.(string #\newline)) ((:value obj &optional str) - (value-part obj str)) + (value-part obj str (istate.parts istate))) ((:action label lambda &key (refreshp t)) - (action-part label lambda refreshp))))))) + (action-part label lambda refreshp + (istate.actions istate)))))))) + +(defun value-part (object string parts) + (list :value + (or string (print-part-to-string object)) + (assign-index object parts))) + +(defun action-part (label lambda refreshp actions) + (list :action label (assign-index (list lambda refreshp) actions))) (defun assign-index (object vector) (let ((index (fill-pointer vector))) (vector-push-extend object vector) index)) -(defun value-part (object string) - (list :value - (or string (print-part-to-string object)) - (assign-index object *inspectee-parts*))) - -(defun action-part (label lambda refreshp) - (list :action label (assign-index (list lambda refreshp) - *inspectee-actions*))) - (defun print-part-to-string (value) - (let ((string (to-string value)) - (pos (position value *inspector-history*))) + (let* ((string (to-line value)) + (pos (position value *inspector-history*))) (if pos (format nil "#~D=~A" pos string) string))) +;; Print OBJECT to a single line. Return the string. +(defun to-line (object &optional (width 75)) + (truncate-string + (with-output-to-string (*standard-output*) + (write object :right-margin width :lines 1)) + 80 "..")) + (defun content-range (list start end) (let* ((len (length list)) (end (min len end))) (list (subseq list start end) len start end))) (defslimefun inspector-nth-part (index) - (aref *inspectee-parts* index)) + (aref (istate.parts *istate*) index)) (defslimefun inspect-nth-part (index) (with-buffer-syntax () (inspect-object (inspector-nth-part index)))) (defslimefun inspector-range (from to) - (content-range *inspectee-content* from to)) + (content-range (inspector-content *istate*) from to)) (defslimefun inspector-call-nth-action (index &rest args) - (destructuring-bind (fun refreshp) (aref *inspectee-actions* index) + (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index) (apply fun args) (if refreshp - (inspect-object (pop *inspector-stack*)) + (inspector-reinspect) ;; tell emacs that we don't want to refresh the inspector buffer nil))) (defslimefun inspector-pop () - "Drop the inspector stack and inspect the second element. -Return nil if there's no second element." + "Inspect the previous object. +Return nil if there's no previous object." (with-buffer-syntax () - (cond ((cdr *inspector-stack*) - (pop *inspector-stack*) - (inspect-object (pop *inspector-stack*))) + (cond ((istate.previous *istate*) + (setq *istate* (istate.previous *istate*)) + (istate>elisp *istate*)) (t nil)))) (defslimefun inspector-next () - "Inspect the next element in the *inspector-history*." + "Inspect the next element in the history of inspected objects.." (with-buffer-syntax () - (let ((pos (position *inspectee* *inspector-history*))) - (cond ((= (1+ pos) (length *inspector-history*)) - nil) - (t (inspect-object (aref *inspector-history* (1+ pos)))))))) + (cond ((istate.next *istate*) + (setq *istate* (istate.next *istate*)) + (istate>elisp *istate*)) + (t nil)))) (defslimefun inspector-reinspect () - (inspect-object *inspectee*)) + (setf (istate.content *istate*) + (emacs-inspect/printer-bindings (istate.object *istate*))) + (istate>elisp *istate*)) (defslimefun quit-inspector () (reset-inspector) @@ -2904,7 +2927,7 @@ (defslimefun describe-inspectee () "Describe the currently inspected object." (with-buffer-syntax () - (describe-to-string *inspectee*))) + (describe-to-string (istate.object *istate*)))) (defslimefun pprint-inspector-part (index) "Pretty-print the currently inspected object." From heller at common-lisp.net Fri Aug 22 21:15:01 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:01 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211501.876553A061@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22683 Modified Files: ChangeLog swank-ecl.lisp Log Message: * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:14:52 1.1466 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:00 1.1467 @@ -1,3 +1,7 @@ +2008-08-22 Stelian Ionescu + + * swank-ecl.lisp: Add a few EVAL-WHENs to fix compilation. + 2008-08-22 Helmut Eller Collect most of the inspector state in a structrure. --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/11 17:41:55 1.27 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/22 21:15:01 1.28 @@ -12,6 +12,7 @@ (defvar *tmp*) +(eval-when (:compile-toplevel) (if (find-package :gray) (import-from :gray *gray-stream-symbols* :swank-backend) (import-from :ext *gray-stream-symbols* :swank-backend)) @@ -21,12 +22,13 @@ :eql-specializer-object :generic-function-declarations :specializer-direct-methods - :compute-applicable-methods-using-classes)) + :compute-applicable-methods-using-classes))) ;;;; TCP Server -(require 'sockets) +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) (defun resolve-hostname (name) (car (sb-bsd-sockets:host-ent-addresses @@ -218,23 +220,24 @@ ;;; Debugging -(import - '(si::*break-env* - si::*ihs-top* - si::*ihs-current* - si::*ihs-base* - si::*frs-base* - si::*frs-top* - si::*tpl-commands* - si::*tpl-level* - si::frs-top - si::ihs-top - si::ihs-fun - si::ihs-env - si::sch-frs-base - si::set-break-env - si::set-current-ihs - si::tpl-commands)) +(eval-when (:compile-toplevel) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) (defvar *backtrace* '()) From heller at common-lisp.net Fri Aug 22 21:15:02 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:02 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080822211502.05E9B610BC@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv22683/contrib Modified Files: ChangeLog swank-listener-hooks.lisp Log Message: * contrib/swank-listener-hooks.lisp: Add missing IN-PACKAGE. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/20 21:46:09 1.123 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/22 21:15:01 1.124 @@ -1,3 +1,7 @@ +2008-08-22 Stelian Ionescu + + * swank-listener-hooks.lisp: Add missing IN-PACKAGE. + 2008-08-20 Tobias C. Rittweiler * slime-fontifying-fu.el: New contrib; fontify with-foo and do-foo --- /project/slime/cvsroot/slime/contrib/swank-listener-hooks.lisp 2007/08/28 13:53:02 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-listener-hooks.lisp 2008/08/22 21:15:01 1.2 @@ -5,6 +5,8 @@ ;; I guess that only Alan Ruttenberg knows how to use this code. It ;; was in swank.lisp for a long time, so here it is. -- Helmut Eller +(in-package :swank) + (defvar *slime-repl-advance-history* nil "In the dynamic scope of a single form typed at the repl, is set to nil to prevent the repl from advancing the history - * ** *** etc.") From heller at common-lisp.net Fri Aug 22 21:15:08 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:08 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211508.578921206C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22802 Modified Files: ChangeLog metering.lisp Log Message: * metering.lisp: Add deftypes for time-type and cons-type, which are not defined in newer versions of CCL. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:00 1.1467 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:07 1.1468 @@ -1,3 +1,8 @@ +2008-08-22 Stas Boukarev + + * metering.lisp: Add deftypes for time-type and cons-type, which + are not defined in newer versions of CCL. + 2008-08-22 Stelian Ionescu * swank-ecl.lisp: Add a few EVAL-WHENs to fix compilation. --- /project/slime/cvsroot/slime/metering.lisp 2005/04/01 20:16:35 1.4 +++ /project/slime/cvsroot/slime/metering.lisp 2008/08/22 21:15:07 1.5 @@ -60,7 +60,7 @@ ;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. ;;; Purely to cut down on stale code (e.g. #+cltl2) in this ;;; version that is bundled with SLIME. -;;; +;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. ;;; ;;; ******************************** @@ -401,6 +401,11 @@ (defconstant time-units-per-second internal-time-units-per-second) +#+openmcl +(progn + (deftype time-type () 'unsigned-byte) + (deftype consing-type () 'unsigned-byte)) + (defmacro get-time () `(the time-type (get-internal-run-time))) From heller at common-lisp.net Fri Aug 22 21:15:13 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:13 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211513.E8B5563095@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22914 Modified Files: ChangeLog swank.lisp Log Message: In backtraces, escape newlines in strings as \n. * swank.lisp (*backtrace-pprint-dispatch-table*): New. (*backtrace-printer-bindings*): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:07 1.1468 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:12 1.1469 @@ -1,3 +1,10 @@ +2008-08-22 Helmut Eller + + In backtraces, escape newlines in strings as \n. + + * swank.lisp (*backtrace-pprint-dispatch-table*): New. + (*backtrace-printer-bindings*): Use it. + 2008-08-22 Stas Boukarev * metering.lisp: Add deftypes for time-type and cons-type, which --- /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:14:52 1.573 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:13 1.574 @@ -109,10 +109,28 @@ (*print-right-margin* . 65)) "A set of printer variables used in the debugger.") +(defvar *backtrace-pprint-dispatch-table* + (let ((table (copy-pprint-dispatch nil))) + (flet ((escape-string (stream string) + (write-char #\" stream) + (loop for c across string do + (case c + (#\" (write-string "\\\"" stream)) + (#\newline (write-string "\\n" stream)) + (#\return (write-string "\\r" stream)) + (t (write-char c stream)))) + (write-char #\" stream))) + (set-pprint-dispatch 'string #'escape-string 0 table) + table))) + (defvar *backtrace-printer-bindings* - `((*print-pretty* . nil) + `((*print-pretty* . t) + (*print-readably* . nil) (*print-level* . 4) - (*print-length* . 6)) + (*print-length* . 6) + (*print-lines* . 1) + (*print-right-margin* . 200) + (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*)) "Pretter settings for printing backtraces.") (defvar *default-worker-thread-bindings* '() From heller at common-lisp.net Fri Aug 22 21:15:19 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:19 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211519.A19BE743EB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22951 Modified Files: ChangeLog swank-backend.lisp swank-cmucl.lisp swank-gray.lisp swank.lisp Log Message: Implement streams with a length limit. Use them to truncate printer output in backtraces. * swank-backend.lisp (make-output-stream, make-input-stream): Split make-fn-streams up into two functions. * swank.lisp (call/truncated-output-to-string): New function. (backtrace, istate>elisp, to-line): Use it. (frame-locals-for-emacs): Use to-line. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:12 1.1469 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:19 1.1470 @@ -1,5 +1,17 @@ 2008-08-22 Helmut Eller + Implement streams with a length limit. + Use them to truncate printer output in backtraces. + + * swank-backend.lisp (make-output-stream, make-input-stream): + Split make-fn-streams up into two functions. + + * swank.lisp (call/truncated-output-to-string): New function. + (backtrace, istate>elisp, to-line): Use it. + (frame-locals-for-emacs): Use to-line. + +2008-08-22 Helmut Eller + In backtraces, escape newlines in strings as \n. * swank.lisp (*backtrace-pprint-dispatch-table*): New. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/22 14:28:41 1.146 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/22 21:15:19 1.147 @@ -458,6 +458,14 @@ ;;;; Streams +(definterface make-output-stream (write-string) + "Return a new character output stream. +The stream calls WRITE-STRING when output is ready.") + +(definterface make-input-stream (read-string) + "Return a new character input stream. +The stream calls READ-STRING when input is needed.") + (definterface make-fn-streams (input-fn output-fn) "Return character input and output streams backended by functions. When input is needed, INPUT-FN is called with no arguments to --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/17 08:31:26 1.188 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/22 21:15:19 1.189 @@ -196,6 +196,12 @@ ;;;; Stream handling ;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004) +(defimplementation make-output-stream (write-string) + (make-slime-output-stream write-string)) + +(defimplementation make-input-stream (read-string) + (make-slime-input-stream read-string)) + (defimplementation make-fn-streams (input-fn output-fn) (let* ((output (make-slime-output-stream output-fn)) (input (make-slime-input-stream input-fn output))) --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/05 17:38:44 1.14 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/22 21:15:19 1.15 @@ -161,6 +161,13 @@ ;;; + +(defimplementation make-output-stream (write-string) + (make-instance 'slime-output-stream :output-fn output-fn)) + +(defimplementation make-input-stream (read-string) + (make-instance 'slime-output-stream :input-fn output-fn)) + (defimplementation make-fn-streams (input-fn output-fn) (let* ((output (make-instance 'slime-output-stream :output-fn output-fn)) --- /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:13 1.574 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:19 1.575 @@ -1485,11 +1485,11 @@ (defun encode-message (message stream) (let* ((string (prin1-to-string-for-emacs message)) (length (length string))) + (assert (<= length #xffffff)) (log-event "WRITE: ~A~%" string) - (without-interrupts - (let ((*print-pretty* nil)) - (format stream "~6,'0x" length)) - (write-string string stream)) + (let ((*print-pretty* nil)) + (format stream "~6,'0x" length)) + (write-string string stream) ;;(terpri stream) (finish-output stream))) @@ -1958,6 +1958,27 @@ (ellipsis (cat (subseq string 0 width) ellipsis)) (t (subseq string 0 width))))) +(defun call/truncated-output-to-string (length function + &optional (ellipsis "..")) + "Call FUNCTION with a new stream, return the output written to the stream. +If FUNCTION tries to write more than LENGTH characters, it will be +aborted and return immediately with the output written so far." + (let ((buffer (make-string (+ length (length ellipsis)))) + (fill-pointer 0)) + (block buffer-full + (flet ((write-output (string) + (let* ((free (- length fill-pointer)) + (count (min free (length string)))) + (replace buffer string :start1 fill-pointer :end2 count) + (incf fill-pointer count) + (when (> (length string) free) + (replace buffer ellipsis :start1 fill-pointer) + (return-from buffer-full buffer))))) + (let ((stream (make-output-stream #'write-output))) + (funcall function stream) + (finish-output stream) + (subseq buffer 0 fill-pointer)))))) + (defun package-string-for-prompt (package) "Return the shortest nickname (or canonical name) of PACKAGE." (unparse-name @@ -2191,13 +2212,16 @@ "Return a list ((I FRAME) ...) of frames from START to END. I is an integer describing and FRAME a string." (loop for frame in (compute-backtrace start end) - for i from start - collect (list i (with-output-to-string (stream) - (handler-case - (with-bindings *backtrace-printer-bindings* - (print-frame frame stream)) - (t () - (format stream "[error printing frame]"))))))) + for i from start collect + (list i + (call/truncated-output-to-string + 100 + (lambda (stream) + (handler-case + (with-bindings *backtrace-printer-bindings* + (print-frame frame stream)) + (t () + (format stream "[error printing frame]")))))))) (defslimefun debugger-info-for-emacs (start end) "Return debugger state, with stack frames from START to END. @@ -2283,7 +2307,7 @@ (mapcar (lambda (frame-locals) (destructuring-bind (&key name id value) frame-locals (list :name (prin1-to-string name) :id id - :value (to-string value)))) + :value (to-line value)))) (frame-locals index)))) (defslimefun frame-catch-tags-for-emacs (frame-index) @@ -2848,9 +2872,11 @@ (emacs-inspect object))) (defun istate>elisp (istate) - (list :title (with-output-to-string (s) - (print-unreadable-object ((istate.object istate) - s :type t :identity t))) + (list :title (call/truncated-output-to-string + 200 + (lambda (s) + (print-unreadable-object ((istate.object istate) + s :type t :identity t)))) :id (assign-index (istate.object istate) (istate.parts istate)) :content (content-range (inspector-content istate) 0 500))) @@ -2889,10 +2915,11 @@ ;; Print OBJECT to a single line. Return the string. (defun to-line (object &optional (width 75)) - (truncate-string - (with-output-to-string (*standard-output*) + (call/truncated-output-to-string + width + (lambda (*standard-output*) (write object :right-margin width :lines 1)) - 80 "..")) + "..")) (defun content-range (list start end) (let* ((len (length list)) (end (min len end))) From heller at common-lisp.net Fri Aug 22 21:15:27 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:27 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211527.19C921127@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv23004 Modified Files: ChangeLog swank.lisp Log Message: Use lazy lists in the inspector. * swank.lisp (lcons): New data type. (lcons*, lcons-car, lcons-cdr, llist-range): New functions. (emacs-inspect array): Use lazy lists. (istate>elisp): The istate.content is now be a lazy list. (iline): New utility. (prepare-range, prepare-part): Replaces inspector-content. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:19 1.1470 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:24 1.1471 @@ -1,5 +1,16 @@ 2008-08-22 Helmut Eller + Use lazy lists in the inspector. + + * swank.lisp (lcons): New data type. + (lcons*, lcons-car, lcons-cdr, llist-range): New functions. + (emacs-inspect array): Use lazy lists. + (istate>elisp): The istate.content is now be a lazy list. + (iline): New utility. + (prepare-range, prepare-part): Replaces inspector-content. + +2008-08-22 Helmut Eller + Implement streams with a length limit. Use them to truncate printer output in backtraces. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:19 1.575 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:24 1.576 @@ -2878,20 +2878,32 @@ (print-unreadable-object ((istate.object istate) s :type t :identity t)))) :id (assign-index (istate.object istate) (istate.parts istate)) - :content (content-range (inspector-content istate) 0 500))) + :content (prepare-range istate 0 500))) -(defun inspector-content (istate) - (loop for part in (istate.content istate) collect - (etypecase part - (string part) - (cons (destructure-case part - ((:newline) - '#.(string #\newline)) - ((:value obj &optional str) - (value-part obj str (istate.parts istate))) - ((:action label lambda &key (refreshp t)) - (action-part label lambda refreshp - (istate.actions istate)))))))) +(defun prepare-range (istate start end) + (let* ((range (content-range (istate.content istate) start end)) + (ps (loop for part in range append (prepare-part part istate)))) + (list ps + (if (< (length ps) (- end start)) + (+ start (length ps)) + (+ end 1000)) + start end))) + +(defun prepare-part (part istate) + (let ((newline '#.(string #\newline))) + (etypecase part + (string (list part)) + (cons (destructure-case part + ((:newline) (list newline)) + ((:value obj &optional str) + (list (value-part obj str (istate.parts istate)))) + ((:action label lambda &key (refreshp t)) + (action-part label lambda refreshp + (istate.actions istate))) + ((:line label value) + (list (princ-to-string label) ": " + (value-part value nil (istate.parts istate)) + newline))))))) (defun value-part (object string parts) (list :value @@ -2922,8 +2934,10 @@ "..")) (defun content-range (list start end) - (let* ((len (length list)) (end (min len end))) - (list (subseq list start end) len start end))) + (typecase list + (list (let ((len (length list))) + (subseq list start (min len end)))) + (lcons (llist-range list start end)))) (defslimefun inspector-nth-part (index) (aref (istate.parts *istate*) index)) @@ -2933,7 +2947,7 @@ (inspect-object (inspector-nth-part index)))) (defslimefun inspector-range (from to) - (content-range (inspector-content *istate*) from to)) + (prepare-range *istate* from to)) (defslimefun inspector-call-nth-action (index &rest args) (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index) @@ -2994,6 +3008,51 @@ (reset-inspector) (inspect-object (frame-var-value frame var)))) +;;;;; Lazy lists + +(defstruct (lcons (:constructor %lcons (car %cdr)) + (:predicate lcons?)) + car + (%cdr nil :type (or null lcons function)) + (forced? nil)) + +(defmacro lcons (car cdr) + `(%lcons ,car (lambda () ,cdr))) + +(defmacro lcons* (car cdr &rest more) + (cond ((null more) `(lcons ,car ,cdr)) + (t `(lcons ,car (lcons* ,cdr , at more))))) + +(defun lcons-cdr (lcons) + (with-struct* (lcons- @ lcons) + (cond ((@ forced?) + (@ %cdr)) + (t + (let ((value (funcall (@ %cdr)))) + (setf (@ forced?) t + (@ %cdr) value)))))) + +(defun llist-range (llist start end) + (llist-take (llist-skip llist start) (- end start))) + +(defun llist-skip (lcons index) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i index) (null l)) + l))) + +(defun llist-take (lcons count) + (let ((result '())) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i count) + (null l))) + (push (lcons-car l) result)) + (nreverse result))) + +(defun iline (label value) + `(:line ,label ,value)) + ;;;;; Lists (defmethod emacs-inspect ((o cons)) @@ -3006,10 +3065,6 @@ ('car (car cons)) ('cdr (cdr cons)))) -;; (inspect-list '#1=(a #1# . #1# )) -;; (inspect-list (list* 'a 'b 'c)) -;; (inspect-list (make-list 10000)) - (defun inspect-list (list) (multiple-value-bind (length tail) (safe-length list) (flet ((frob (title list) @@ -3045,6 +3100,8 @@ ;;;;; Hashtables + + (defmethod emacs-inspect ((ht hash-table)) (append (label-value-line* @@ -3071,17 +3128,19 @@ ;;;;; Arrays (defmethod emacs-inspect ((array array)) - (append - (label-value-line* - ("Dimensions" (array-dimensions array)) - ("Element type" (array-element-type array)) - ("Total size" (array-total-size array)) - ("Adjustable" (adjustable-array-p array))) - (when (array-has-fill-pointer-p array) - (label-value-line "Fill pointer" (fill-pointer array))) - '("Contents:" (:newline)) - (loop for i below (array-total-size array) - append (label-value-line i (row-major-aref array i))))) + (lcons* + (iline "Dimensions" (array-dimensions array)) + (iline "Element type" (array-element-type array)) + (iline "Total size" (array-total-size array)) + (iline "Adjustable" (adjustable-array-p array)) + (iline "Fill pointer" (if (array-has-fill-pointer-p array) + (fill-pointer array))) + "Contents:" '(:newline) + (labels ((k (i max) + (cond ((= i max) '()) + (t (lcons (iline i (row-major-aref array i)) + (k (1+ i) max)))))) + (k 0 (array-total-size array))))) ;;;;; Chars From heller at common-lisp.net Fri Aug 22 21:15:35 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:35 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211535.7F78B2F04E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv23033 Modified Files: ChangeLog slime.el Log Message: Some focus handling in multiframe setups. * slime.el (slime-pop-to-buffer): New function. (slime-switch-to-output-buffer): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:24 1.1471 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:32 1.1472 @@ -1,5 +1,12 @@ 2008-08-22 Helmut Eller + Some focus handling in multiframe setups. + + * slime.el (slime-pop-to-buffer): New function. + (slime-switch-to-output-buffer): Use it. + +2008-08-22 Helmut Eller + Use lazy lists in the inspector. * swank.lisp (lcons): New data type. --- /project/slime/cvsroot/slime/slime.el 2008/08/17 23:01:13 1.1003 +++ /project/slime/cvsroot/slime/slime.el 2008/08/22 21:15:35 1.1004 @@ -2703,7 +2703,7 @@ `special-display-buffer-names' to customize the frame in which the buffer should appear." (interactive) - (pop-to-buffer (slime-output-buffer)) + (slime-pop-to-buffer (slime-output-buffer)) (goto-char (point-max))) @@ -9644,6 +9644,18 @@ ;; Emacs 21 uses microsecs; Emacs 22 millisecs (if timeout (truncate (* timeout 1000000))))))) +(defun slime-pop-to-buffer (buffer &optional other-window norecord) + "Select buffer BUFFER in some window. +This is like `pop-to-buffer' but also sets the input focus +for (somewhat) better multiframe support." + (set-buffer buffer) + (let ((window (display-buffer buffer other-window))) + (select-window window norecord) + ;; select-window doesn't set the input focus + (when (and (not (featurep 'xemacs)) (>= emacs-major-version 22)) + (select-frame-set-input-focus (window-frame window)))) + buffer) + (defun slime-add-local-hook (hook function &optional append) (cond ((featurep 'xemacs) (add-local-hook hook function append)) ((< emacs-major-version 21) From heller at common-lisp.net Fri Aug 22 21:15:36 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Aug 2008 17:15:36 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822211536.E936C3F029@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv23082 Modified Files: swank-gray.lisp Log Message: Fix typos. --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/22 21:15:19 1.15 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/22 21:15:36 1.16 @@ -163,10 +163,10 @@ ;;; (defimplementation make-output-stream (write-string) - (make-instance 'slime-output-stream :output-fn output-fn)) + (make-instance 'slime-output-stream :output-fn write-string)) (defimplementation make-input-stream (read-string) - (make-instance 'slime-output-stream :input-fn output-fn)) + (make-instance 'slime-output-stream :input-fn read-string)) (defimplementation make-fn-streams (input-fn output-fn) (let* ((output (make-instance 'slime-output-stream From trittweiler at common-lisp.net Fri Aug 22 22:58:18 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 22 Aug 2008 18:58:18 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080822225818.460565C192@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18418 Modified Files: ChangeLog Log Message: Forgot to commit ChangeLog entry earlier today. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:32 1.1472 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 22:58:18 1.1473 @@ -46,7 +46,7 @@ 2008-08-22 Helmut Eller - Collect most of the inspector state in a structrure. + Collect most of the inspector state in a structure. Truncate the printer output more aggressively. * swank.lisp (inspector-state): New structure. @@ -59,6 +59,23 @@ (emacs-inspect/printer-bindings, istate>elisp): New functions. (to-line, truncate-string): New functions. +2008-08-22 Tobias C. Rittweiler + + Compiling a file `let*.lisp' on SBCL via C-c C-k resulted in an + error, because it parsed the asterisk to a wild pathname. Fix + that. + + * swank-backend.lisp (definterface parse-emacs-filename): New. + PARSE-NAMESTRING by default. + + * swank-sbcl.lisp (defimplementation parse-emacs-filename): Use + SB-EXT:PARSE-NATIVE-NAMESTRING. + + * swank.lisp (compile-file-for-emacs): Use PARSE-EMACS-FILENAME. + (compile-file-if-needed): Ditto. + (load-file): Ditto. + (swank-require): Ditto. + 2008-08-18 Helmut Eller * swank.lisp (install-fd-handler): Bind *emacs-connection* with From trittweiler at common-lisp.net Mon Aug 25 15:29:50 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Mon, 25 Aug 2008 11:29:50 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080825152950.3EAC1830AA@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv26546 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. (slime-compute-modeline-string): Display "PKG:" before "CON:". --- /project/slime/cvsroot/slime/slime.el 2008/08/22 21:15:35 1.1004 +++ /project/slime/cvsroot/slime/slime.el 2008/08/25 15:29:48 1.1005 @@ -448,8 +448,10 @@ (defun slime-compute-modeline-package () (when (memq major-mode slime-lisp-modes) - (when-let (package (slime-current-package)) - (slime-pretty-package-name package)))) + ;; WHEN-LET is defined later. + (let ((package (slime-current-package))) + (when package + (slime-pretty-package-name package))))) (defun slime-pretty-package-name (name) "Return a pretty version of a package name NAME." @@ -474,10 +476,10 @@ (defun slime-compute-modeline-string (conn state pkg) (concat (when (or conn pkg) "[") + (when pkg (format "PKG:%s" pkg)) + (when (and (or conn state) pkg) ", ") (when conn (format "CON:%s" conn)) (when state (format "{%s}" state)) - (when (and (or conn state) pkg) ", ") - (when pkg (format "PKG:%s" pkg)) (when (or conn pkg) "]"))) (defun slime-update-modeline-string () --- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 22:58:18 1.1473 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/25 15:29:49 1.1474 @@ -1,3 +1,8 @@ +2008-08-25 Tobias C. Rittweiler + + * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. + (slime-compute-modeline-string): Display "PKG:" before "CON:". + 2008-08-22 Helmut Eller Some focus handling in multiframe setups. From heller at common-lisp.net Wed Aug 27 17:52:58 2008 From: heller at common-lisp.net (heller) Date: Wed, 27 Aug 2008 13:52:58 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080827175258.A72C11D16C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16543 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (decode-message): Don't ignore EOF. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/25 15:29:49 1.1474 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:52:58 1.1475 @@ -3,6 +3,10 @@ * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. (slime-compute-modeline-string): Display "PKG:" before "CON:". +2008-08-27 Helmut Eller + + * swank.lisp (decode-message): Don't ignore EOF. + 2008-08-22 Helmut Eller Some focus handling in multiframe setups. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:24 1.576 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/27 17:52:58 1.577 @@ -1190,6 +1190,7 @@ (handle-or-process-requests connection)) (defun deinstall-fd-handler (connection) + (log-event "deinstall-fd-handler~%") (remove-fd-handlers (connection.socket-io connection)) (install-sigint-handler (connection.saved-sigint-handler connection))) @@ -1437,7 +1438,7 @@ ;;(log-event "decode-message~%") (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*))) (handler-bind ((error (lambda (c) (error (make-swank-error c))))) - (let ((c (read-char-no-hang stream nil))) + (let ((c (read-char-no-hang stream))) (cond ((and (not c) timeout) (values nil t)) (t (and c (unread-char c stream)) From heller at common-lisp.net Wed Aug 27 17:53:03 2008 From: heller at common-lisp.net (heller) Date: Wed, 27 Aug 2008 13:53:03 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080827175303.BFDC07B4DD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16567 Modified Files: ChangeLog swank.lisp Log Message: (swank-debugger-hook): Remove the default-debugger restart. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:52:58 1.1475 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:03 1.1476 @@ -6,6 +6,7 @@ 2008-08-27 Helmut Eller * swank.lisp (decode-message): Don't ignore EOF. + (swank-debugger-hook): Remove the default-debugger restart. 2008-08-22 Helmut Eller --- /project/slime/cvsroot/slime/swank.lisp 2008/08/27 17:52:58 1.577 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/27 17:53:03 1.578 @@ -1159,9 +1159,11 @@ (handle-or-process-requests connection)) (defun process-io-interrupt (connection) - (log-event "process-io-interrupt~%") - (invoke-or-queue-interrupt - (lambda () (handle-or-process-requests connection)))) + (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) + (let ((*io-interupt-level* (1+ *io-interupt-level*))) + (invoke-or-queue-interrupt + (lambda () (handle-or-process-requests connection)))) + (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*)) (defun handle-or-process-requests (connection) (log-event "handle-or-process-requests: ~a~%" *swank-state-stack*) @@ -2093,12 +2095,8 @@ (defun swank-debugger-hook (condition hook) "Debugger function for binding *DEBUGGER-HOOK*." (declare (ignore hook)) - (restart-case - (call-with-debugger-hook - #'swank-debugger-hook (lambda () (invoke-slime-debugger condition))) - (default-debugger (&optional v) - :report "Use default debugger." (declare (ignore v)) - (invoke-default-debugger condition)))) + (call-with-debugger-hook #'swank-debugger-hook + (lambda () (invoke-slime-debugger condition)))) (defun invoke-default-debugger (condition) (let ((*debugger-hook* nil)) From heller at common-lisp.net Wed Aug 27 17:53:10 2008 From: heller at common-lisp.net (heller) Date: Wed, 27 Aug 2008 13:53:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080827175310.241EE3C20F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16620 Modified Files: ChangeLog swank-cmucl.lisp swank.lisp Log Message: * swank-cmucl.lisp (remove-sigio-handlers): Fix thinko. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:03 1.1476 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:08 1.1477 @@ -5,6 +5,8 @@ 2008-08-27 Helmut Eller + * swank-cmucl.lisp (remove-sigio-handlers): Fix thinko. + * swank.lisp (decode-message): Don't ignore EOF. (swank-debugger-hook): Remove the default-debugger restart. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/22 21:15:19 1.189 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/27 17:53:08 1.190 @@ -169,19 +169,19 @@ (fcntl fd unix:f-setown (unix:unix-getpid)) (let ((old-flags (fcntl fd unix:f-getfl 0))) (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) + (assert (not (assoc fd *sigio-handlers*))) (push (cons fd fn) *sigio-handlers*))) (defimplementation remove-sigio-handlers (socket) (let ((fd (socket-fd socket))) - (unless (assoc fd *sigio-handlers*) + (when (assoc fd *sigio-handlers*) (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) (let ((old-flags (fcntl fd unix:f-getfl 0))) (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) (sys:invalidate-descriptor fd)) - #+(or) + (assert (not (assoc fd *sigio-handlers*))) (when (null *sigio-handlers*) - (sys:default-interrupt :sigio)) - )) + (sys:default-interrupt :sigio)))) ;;;;; SERVE-EVENT --- /project/slime/cvsroot/slime/swank.lisp 2008/08/27 17:53:03 1.578 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/27 17:53:08 1.579 @@ -357,6 +357,7 @@ (check-slime-interrupts))))) (defun invoke-or-queue-interrupt (function) + (log-event "invoke-or-queue-interrupt: ~a" function) (cond ((not (boundp '*slime-interrupts-enabled*)) (without-slime-interrupts (funcall function))) @@ -365,6 +366,7 @@ ((cdr *pending-slime-interrupts*) (simple-break "Two many queued interrupts")) (t + (log-event "queue-interrupt: ~a" function) (push function *pending-slime-interrupts*)))) (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args) @@ -931,6 +933,7 @@ (defun close-connection (c condition backtrace) (let ((*debugger-hook* nil)) + (log-event "close-connection: ~a ...~%" condition) (format *log-output* "~&;; swank:close-connection: ~A~%" condition) (let ((cleanup (connection.cleanup c))) (when cleanup @@ -956,8 +959,8 @@ (ignore-errors (stream-external-format (connection.socket-io c))) (connection.communication-style c) *use-dedicated-output-stream*) - (finish-output *log-output*)))) - + (finish-output *log-output*)) + (log-event "close-connection ~a ... done.~%" condition))) ;;;;;; Thread based communication @@ -1158,6 +1161,8 @@ (lambda () (process-io-interrupt connection))) (handle-or-process-requests connection)) +(defvar *io-interupt-level* 0) + (defun process-io-interrupt (connection) (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) (let ((*io-interupt-level* (1+ *io-interupt-level*))) @@ -1174,7 +1179,7 @@ (defun deinstall-sigio-handler (connection) (log-event "deinstall-sigio-handler...~%") - (remove-sigio-handlers (connection.socket-io connection)) + (remove-sigio-handlers (connection.socket-io connection)) (log-event "deinstall-sigio-handler...done~%")) ;;;;;; SERVE-EVENT based IO From heller at common-lisp.net Wed Aug 27 17:53:12 2008 From: heller at common-lisp.net (heller) Date: Wed, 27 Aug 2008 13:53:12 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080827175312.A26933C20D@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv16654/contrib Modified Files: ChangeLog swank-arglists.lisp Log Message: * swank-arglists.lisp (variable-desc-for-echo-area): Limit the length to one line to avoid (some) problems with big or circular values. Reported by Stas Boukarev. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/22 21:15:01 1.124 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/08/27 17:53:11 1.125 @@ -1,3 +1,9 @@ +2008-08-27 Helmut Eller + + * swank-arglists.lisp (variable-desc-for-echo-area): Limit the + length to one line to avoid (some) problems with big or circular + values. Reported by Stas Boukarev. + 2008-08-22 Stelian Ionescu * swank-listener-hooks.lisp: Add missing IN-PACKAGE. --- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/04/14 11:36:16 1.21 +++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/08/27 17:53:12 1.22 @@ -476,9 +476,11 @@ (with-buffer-syntax () (let ((sym (parse-symbol variable-name))) (if (and sym (boundp sym)) - (let ((*print-pretty* nil) (*print-level* 4) - (*print-length* 10) (*print-circle* t)) - (format nil "~A => ~A" sym (symbol-value sym))))))) + (let ((*print-pretty* t) (*print-level* 4) + (*print-length* 10) (*print-lines* 1)) + (call/truncated-output-to-string + 75 (lambda (s) + (format s "~A => ~A" sym (symbol-value sym))))))))) (defun decode-required-arg (arg) "ARG can be a symbol or a destructuring pattern." From heller at common-lisp.net Wed Aug 27 17:53:16 2008 From: heller at common-lisp.net (heller) Date: Wed, 27 Aug 2008 13:53:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080827175316.BBB48490A1@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16687 Modified Files: ChangeLog swank-ecl.lisp Log Message: * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to fix loading. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:08 1.1477 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:16 1.1478 @@ -3,6 +3,11 @@ * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. (slime-compute-modeline-string): Display "PKG:" before "CON:". +2008-08-27 Anton Vodonosov + + * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to + fix loading. + 2008-08-27 Helmut Eller * swank-cmucl.lisp (remove-sigio-handlers): Fix thinko. --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/22 21:15:01 1.28 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/27 17:53:16 1.29 @@ -12,7 +12,7 @@ (defvar *tmp*) -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) (if (find-package :gray) (import-from :gray *gray-stream-symbols* :swank-backend) (import-from :ext *gray-stream-symbols* :swank-backend)) @@ -220,7 +220,7 @@ ;;; Debugging -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) (import '(si::*break-env* si::*ihs-top* From heller at common-lisp.net Wed Aug 27 17:53:24 2008 From: heller at common-lisp.net (heller) Date: Wed, 27 Aug 2008 13:53:24 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080827175324.A5269601C8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16729 Modified Files: ChangeLog slime.el Log Message: * slime.el (sldb-setup): Insert "No backtrace" if the backtrace is empty. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:16 1.1478 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:22 1.1479 @@ -3,7 +3,12 @@ * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. (slime-compute-modeline-string): Display "PKG:" before "CON:". -2008-08-27 Anton Vodonosov +2008-08-27 Helmut Eller + + * slime.el (sldb-setup): Insert "No backtrace" if the backtrace is + empty. + +2008-08-27 Anton Vodonosov * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to fix loading. --- /project/slime/cvsroot/slime/slime.el 2008/08/25 15:29:48 1.1005 +++ /project/slime/cvsroot/slime/slime.el 2008/08/27 17:53:22 1.1006 @@ -6779,7 +6779,9 @@ (insert "\n" (in-sldb-face section "Backtrace:") "\n") (setq sldb-backtrace-start-marker (point-marker)) (save-excursion - (sldb-insert-frames (sldb-prune-initial-frames frames) t)) + (if frames + (sldb-insert-frames (sldb-prune-initial-frames frames) t) + (insert "[No backtrace]"))) (run-hooks 'sldb-hook)) (pop-to-buffer (current-buffer)) (sldb-recenter-region (point-min) (point)) From heller at common-lisp.net Wed Aug 27 18:03:46 2008 From: heller at common-lisp.net (heller) Date: Wed, 27 Aug 2008 14:03:46 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080827180346.219B42203C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv24868 Modified Files: ChangeLog Log Message: Fix chronological order. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/27 17:53:22 1.1479 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/27 18:03:45 1.1480 @@ -1,8 +1,3 @@ -2008-08-25 Tobias C. Rittweiler - - * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. - (slime-compute-modeline-string): Display "PKG:" before "CON:". - 2008-08-27 Helmut Eller * slime.el (sldb-setup): Insert "No backtrace" if the backtrace is @@ -20,6 +15,11 @@ * swank.lisp (decode-message): Don't ignore EOF. (swank-debugger-hook): Remove the default-debugger restart. +2008-08-25 Tobias C. Rittweiler + + * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. + (slime-compute-modeline-string): Display "PKG:" before "CON:". + 2008-08-22 Helmut Eller Some focus handling in multiframe setups. From heller at common-lisp.net Sat Aug 30 15:33:20 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:20 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153320.513914507D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4281 Modified Files: ChangeLog swank-abcl.lisp Log Message: * swank-abcl.lisp (make-output-stream, make-input-stream): provides the (trivial) definitions for MAKE-OUTPUT-STREAM and MAKE-INPUT-STREAM for ABCL. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/27 18:03:45 1.1480 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:20 1.1481 @@ -1,3 +1,9 @@ +2008-08-30 Mark Evenson + + * swank-abcl.lisp (make-output-stream, make-input-stream): + provides the (trivial) definitions for MAKE-OUTPUT-STREAM and + MAKE-INPUT-STREAM for ABCL. + 2008-08-27 Helmut Eller * slime.el (sldb-setup): Insert "No backtrace" if the backtrace is --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/11 17:41:47 1.51 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/30 15:33:20 1.52 @@ -24,6 +24,12 @@ :format-arguments format-arguments)))) nil)) +(defimplementation make-output-stream (write-string) + (ext:make-slime-output-stream write-string)) + +(defimplementation make-input-stream (read-string) + (ext:make-slime-input-stream read-string)) + (defimplementation make-fn-streams (input-fn output-fn) (let* ((output (ext:make-slime-output-stream output-fn)) (input (ext:make-slime-input-stream input-fn output))) From heller at common-lisp.net Sat Aug 30 15:33:25 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:25 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153325.31AB6450FA@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4306 Modified Files: ChangeLog swank-backend.lisp Log Message: * swank-backend.lisp (*gray-stream-symbols*): added symbols stream-peek-char, stream-read-line, stream-file-position --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:20 1.1481 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:24 1.1482 @@ -1,7 +1,12 @@ +2008-08-30 Michael Weber + + * swank-backend.lisp (*gray-stream-symbols*): added symbols + stream-peek-char, stream-read-line, stream-file-position + 2008-08-30 Mark Evenson - * swank-abcl.lisp (make-output-stream, make-input-stream): - provides the (trivial) definitions for MAKE-OUTPUT-STREAM and + * swank-abcl.lisp (make-output-stream, make-input-stream): provide + the (trivial) definitions for MAKE-OUTPUT-STREAM and MAKE-INPUT-STREAM for ABCL. 2008-08-27 Helmut Eller --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/22 21:15:19 1.147 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/30 15:33:24 1.148 @@ -203,6 +203,9 @@ :stream-finish-output :fundamental-character-input-stream :stream-read-char + :stream-peek-char + :stream-read-line + :stream-file-position :stream-listen :stream-unread-char :stream-clear-input From heller at common-lisp.net Sat Aug 30 15:33:28 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:28 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153328.01EB8340CC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4335 Modified Files: ChangeLog swank-gray.lisp Log Message: * swank-gray.lisp (make-input-stream): fixed typos --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:24 1.1482 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:28 1.1483 @@ -1,5 +1,9 @@ 2008-08-30 Michael Weber + * swank-gray.lisp (make-input-stream): fixed typos + +2008-08-30 Michael Weber + * swank-backend.lisp (*gray-stream-symbols*): added symbols stream-peek-char, stream-read-line, stream-file-position --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/22 21:15:36 1.16 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/30 15:33:28 1.17 @@ -166,7 +166,9 @@ (make-instance 'slime-output-stream :output-fn write-string)) (defimplementation make-input-stream (read-string) - (make-instance 'slime-output-stream :input-fn read-string)) + (make-instance 'slime-input-stream + :input-fn read-string + :output-stream nil)) (defimplementation make-fn-streams (input-fn output-fn) (let* ((output (make-instance 'slime-output-stream @@ -174,4 +176,4 @@ (input (make-instance 'slime-input-stream :input-fn input-fn :output-stream output))) - (values input output))) \ No newline at end of file + (values input output))) From heller at common-lisp.net Sat Aug 30 15:33:34 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:34 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153334.0331F4507D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4397 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-pop-to-buffer): Drop the norecord argument, since we can't support it easily in Emacs 21. Reported by Christophe Rhodes. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:28 1.1483 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:34 1.1484 @@ -1,3 +1,9 @@ +2008-08-30 Helmut Eller + + * slime.el (slime-pop-to-buffer): Drop the norecord argument, + since we can't support it easily in Emacs 21. + Reported by Christophe Rhodes. + 2008-08-30 Michael Weber * swank-gray.lisp (make-input-stream): fixed typos --- /project/slime/cvsroot/slime/slime.el 2008/08/27 17:53:22 1.1006 +++ /project/slime/cvsroot/slime/slime.el 2008/08/30 15:33:34 1.1007 @@ -9648,15 +9648,18 @@ ;; Emacs 21 uses microsecs; Emacs 22 millisecs (if timeout (truncate (* timeout 1000000))))))) -(defun slime-pop-to-buffer (buffer &optional other-window norecord) +(defun slime-pop-to-buffer (buffer &optional other-window) "Select buffer BUFFER in some window. This is like `pop-to-buffer' but also sets the input focus for (somewhat) better multiframe support." (set-buffer buffer) - (let ((window (display-buffer buffer other-window))) - (select-window window norecord) + (let ((old-frame (selected-frame)) + (window (display-buffer buffer other-window))) + (select-window window) ;; select-window doesn't set the input focus - (when (and (not (featurep 'xemacs)) (>= emacs-major-version 22)) + (when (and (not (featurep 'xemacs)) + (>= emacs-major-version 22) + (not (eq old-frame (selected-frame)))) (select-frame-set-input-focus (window-frame window)))) buffer) From heller at common-lisp.net Sat Aug 30 15:33:40 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153340.C92C170305@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4430 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (prepare-part): Also wrap action elements in a list. Reported by Ariel Badichi and Madhu. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:34 1.1484 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:39 1.1485 @@ -1,5 +1,10 @@ 2008-08-30 Helmut Eller + * swank.lisp (prepare-part): Also wrap action elements + in a list. Reported by Ariel Badichi and Madhu. + +2008-08-30 Helmut Eller + * slime.el (slime-pop-to-buffer): Drop the norecord argument, since we can't support it easily in Emacs 21. Reported by Christophe Rhodes. --- /project/slime/cvsroot/slime/swank.lisp 2008/08/27 17:53:08 1.579 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/30 15:33:39 1.580 @@ -2902,8 +2902,8 @@ ((:value obj &optional str) (list (value-part obj str (istate.parts istate)))) ((:action label lambda &key (refreshp t)) - (action-part label lambda refreshp - (istate.actions istate))) + (list (action-part label lambda refreshp + (istate.actions istate)))) ((:line label value) (list (princ-to-string label) ": " (value-part value nil (istate.parts istate)) From heller at common-lisp.net Sat Aug 30 15:33:46 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:46 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153346.4F679D091@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4468 Modified Files: ChangeLog slime.el Log Message: * slime.el [test](inspector): New test. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:39 1.1485 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:46 1.1486 @@ -1,5 +1,7 @@ 2008-08-30 Helmut Eller + * slime.el [test](inspector): New test. + * swank.lisp (prepare-part): Also wrap action elements in a list. Reported by Ariel Badichi and Madhu. --- /project/slime/cvsroot/slime/slime.el 2008/08/30 15:33:34 1.1007 +++ /project/slime/cvsroot/slime/slime.el 2008/08/30 15:33:46 1.1008 @@ -9243,6 +9243,31 @@ visiblep (not (not (get-buffer-window (current-buffer))))))) +(def-slime-test inspector + (exp) + "Test basic inspector workingness." + '(((let ((h (make-hash-table))) + (loop for i below 10 do (setf (gethash i h) i)) + h)) + ((make-array 10)) + ((make-list 10)) + ('cons) + (#'cons)) + (slime-inspect (prin1-to-string exp)) + (assert (not (slime-inspector-visible-p))) + (slime-wait-condition "Inspector visible" #'slime-inspector-visible-p 5) + (with-current-buffer (window-buffer (selected-window)) + (slime-inspector-quit)) + (slime-wait-condition "Inspector closed" + (lambda () (not (slime-inspector-visible-p))) + 5) + (slime-sync-to-top-level 1)) + +(defun slime-inspector-visible-p () + (let ((buffer (window-buffer (selected-window)))) + (string-match "\\*Slime Inspector\\*" + (buffer-name buffer)))) + (def-slime-test break (times exp) "Test whether BREAK invokes SLDB." From heller at common-lisp.net Sat Aug 30 15:33:50 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:50 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153350.29D03D095@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4502 Modified Files: ChangeLog swank-gray.lisp Log Message: * swank-gray.lisp (slime-input-stream): Remove the output stream slot. Most of the time we can just call force-output. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:46 1.1486 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:49 1.1487 @@ -1,5 +1,8 @@ 2008-08-30 Helmut Eller + * swank-gray.lisp (slime-input-stream): Remove the output stream + slot. Most of the time we can just call force-output. + * slime.el [test](inspector): New test. * swank.lisp (prepare-part): Also wrap action elements --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/30 15:33:28 1.17 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/30 15:33:49 1.18 @@ -77,8 +77,7 @@ (t (terpri stream) t)))) (defclass slime-input-stream (fundamental-character-input-stream) - ((output-stream :initarg :output-stream) - (input-fn :initarg :input-fn) + ((input-fn :initarg :input-fn) (buffer :initform "") (index :initform 0) (lock :initform (make-lock :name "buffer read lock")))) @@ -86,10 +85,8 @@ (call-with-lock-held (slot-value s 'lock) (lambda () - (with-slots (buffer index output-stream input-fn) s + (with-slots (buffer index input-fn) s (when (= index (length buffer)) - (when output-stream - (finish-output output-stream)) (let ((string (funcall input-fn))) (cond ((zerop (length string)) (return-from stream-read-char :eof)) @@ -166,14 +163,11 @@ (make-instance 'slime-output-stream :output-fn write-string)) (defimplementation make-input-stream (read-string) - (make-instance 'slime-input-stream - :input-fn read-string - :output-stream nil)) + (make-instance 'slime-input-stream :input-fn read-string)) (defimplementation make-fn-streams (input-fn output-fn) (let* ((output (make-instance 'slime-output-stream :output-fn output-fn)) (input (make-instance 'slime-input-stream - :input-fn input-fn - :output-stream output))) + :input-fn input-fn))) (values input output))) From heller at common-lisp.net Sat Aug 30 15:33:56 2008 From: heller at common-lisp.net (heller) Date: Sat, 30 Aug 2008 11:33:56 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080830153356.8A1961D170@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4538 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (receive-if): Add #+/-linux to avoid yet more WITH-TIMEOUT related problems. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:49 1.1487 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:56 1.1488 @@ -1,5 +1,8 @@ 2008-08-30 Helmut Eller + * swank-sbcl.lisp (receive-if): Add #+/-linux to avoid yet more + WITH-TIMEOUT related problems. + * swank-gray.lisp (slime-input-stream): Remove the output stream slot. Most of the time we can just call force-output. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/22 14:28:41 1.216 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/30 15:33:56 1.217 @@ -1326,10 +1326,15 @@ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail)))) (when (eq timeout t) (return (values nil t))) + ;; FIXME: with-timeout doesn't work properly on Darwin + #+linux (handler-case (sb-ext:with-timeout 0.2 (sb-thread:condition-wait (mailbox.waitqueue mbox) mutex)) - (sb-ext:timeout ())))))) + (sb-ext:timeout ())) + #-linux + (sb-thread:condition-wait (mailbox.waitqueue mbox) + mutex))))) ) (defimplementation quit-lisp () From heller at common-lisp.net Sun Aug 31 08:49:29 2008 From: heller at common-lisp.net (heller) Date: Sun, 31 Aug 2008 04:49:29 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080831084929.A267FD091@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv14902 Modified Files: ChangeLog Log Message: * swank-backend.lisp (*gray-stream-symbols*): Remove stream-file-position because it's called stream-position in CCL. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/30 15:33:56 1.1488 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/31 08:49:28 1.1489 @@ -1,3 +1,8 @@ +2008-08-31 Helmut Eller + + * swank-backend.lisp (*gray-stream-symbols*): Remove + stream-file-position because it's called stream-position in CCL. + 2008-08-30 Helmut Eller * swank-sbcl.lisp (receive-if): Add #+/-linux to avoid yet more From heller at common-lisp.net Sun Aug 31 11:58:02 2008 From: heller at common-lisp.net (heller) Date: Sun, 31 Aug 2008 07:58:02 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080831115802.2AB877B022@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv19207 Modified Files: ChangeLog swank-abcl.lisp swank-backend.lisp swank-cmucl.lisp swank-gray.lisp swank-scl.lisp swank.lisp Log Message: * swank-backend.lisp (make-input-stream): Remove make-fn-streams. Update callers accordingly. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/31 08:49:28 1.1489 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/31 11:58:01 1.1490 @@ -2,6 +2,8 @@ * swank-backend.lisp (*gray-stream-symbols*): Remove stream-file-position because it's called stream-position in CCL. + (make-input-stream): Remove make-fn-streams. + Update callers accordingly. 2008-08-30 Helmut Eller --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/30 15:33:20 1.52 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/31 11:58:01 1.53 @@ -28,12 +28,8 @@ (ext:make-slime-output-stream write-string)) (defimplementation make-input-stream (read-string) - (ext:make-slime-input-stream read-string)) - -(defimplementation make-fn-streams (input-fn output-fn) - (let* ((output (ext:make-slime-output-stream output-fn)) - (input (ext:make-slime-input-stream input-fn output))) - (values input output))) + (ext:make-slime-input-stream read-string + (make-synonym-stream '*standard-output*))) (defimplementation call-with-compilation-hooks (function) (funcall function)) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/30 15:33:24 1.148 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/31 11:58:01 1.149 @@ -469,17 +469,6 @@ "Return a new character input stream. The stream calls READ-STRING when input is needed.") -(definterface make-fn-streams (input-fn output-fn) - "Return character input and output streams backended by functions. -When input is needed, INPUT-FN is called with no arguments to -return a string. -When output is ready, OUTPUT-FN is called with the output as its -argument. - -Output should be forced to OUTPUT-FN before calling INPUT-FN. - -The streams are returned as two values.") - ;;;; Documentation --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/27 17:53:08 1.190 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/31 11:58:01 1.191 @@ -202,11 +202,6 @@ (defimplementation make-input-stream (read-string) (make-slime-input-stream read-string)) -(defimplementation make-fn-streams (input-fn output-fn) - (let* ((output (make-slime-output-stream output-fn)) - (input (make-slime-input-stream input-fn output))) - (values input output))) - (defstruct (slime-output-stream (:include lisp::lisp-stream (lisp::misc #'sos/misc) @@ -298,16 +293,12 @@ (lisp::misc #'sis/misc)) (:conc-name sis.) (:print-function %print-slime-output-stream) - (:constructor make-slime-input-stream (input-fn sos))) + (:constructor make-slime-input-stream (input-fn))) (input-fn nil :type function) - ;; We know our sibling output stream, so that we can force it before - ;; requesting input. - (sos nil :type slime-output-stream) (buffer "" :type string) (index 0 :type kernel:index)) (defun sis/in (stream eof-errorp eof-value) - (finish-output (sis.sos stream)) (let ((index (sis.index stream)) (buffer (sis.buffer stream))) (when (= index (length buffer)) --- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/30 15:33:49 1.18 +++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/31 11:58:01 1.19 @@ -164,10 +164,3 @@ (defimplementation make-input-stream (read-string) (make-instance 'slime-input-stream :input-fn read-string)) - -(defimplementation make-fn-streams (input-fn output-fn) - (let* ((output (make-instance 'slime-output-stream - :output-fn output-fn)) - (input (make-instance 'slime-input-stream - :input-fn input-fn))) - (values input output))) --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/08 13:43:33 1.22 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/31 11:58:01 1.23 @@ -100,19 +100,17 @@ (index :initarg :index :initform 0 :type fixnum) (position :initarg :position :initform 0 :type integer) (interactive :initarg :interactive :initform nil :type (member nil t)) - (output-stream :initarg :output-stream :initform nil) (input-fn :initarg :input-fn :type function) )) -(defun make-slime-input-stream (input-fn &optional output-stream) +(defun make-slime-input-stream (input-fn) (declare (function input-fn)) (make-instance 'slime-input-stream :in-buffer (make-string 256) :in-head 0 :in-tail 0 :out-buffer "" :buffer "" :index 0 - :input-fn input-fn - :output-stream output-stream)) + :input-fn input-fn)) (defmethod print-object ((s slime-input-stream) stream) (print-unreadable-object (s stream :type t))) @@ -202,11 +200,8 @@ (incf (slot-value stream 'position) copy) copy) (waitp - (let ((output-stream (slot-value stream 'output-stream)) - (input-fn (slot-value stream 'input-fn))) + (let ((input-fn (slot-value stream 'input-fn))) (declare (type function input-fn)) - (when output-stream - (force-output output-stream)) (let ((new-input (funcall input-fn))) (cond ((zerop (length new-input)) -1) @@ -344,10 +339,11 @@ ;;; -(defimplementation make-fn-streams (input-fn output-fn) - (let* ((output (make-slime-output-stream output-fn)) - (input (make-slime-input-stream input-fn output))) - (values input output))) +(defimplementation make-output-stream (output-fn) + (make-slime-output-stream output-fn)) + +(defimplementation make-input-stream (input-fn) + (make-slime-input-stream input-fn)) ;;;; Compilation Commands --- /project/slime/cvsroot/slime/swank.lisp 2008/08/30 15:33:39 1.580 +++ /project/slime/cvsroot/slime/swank.lisp 2008/08/31 11:58:01 1.581 @@ -824,25 +824,26 @@ (defun open-streams (connection) "Return the 5 streams for IO redirection: DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" - (let ((output-fn (make-output-function connection)) - (input-fn - (lambda () - (with-connection (connection) - (with-simple-restart (abort-read - "Abort reading input from Emacs.") - (read-user-input-from-emacs)))))) - (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) - (let* ((dedicated-output (if *use-dedicated-output-stream* - (open-dedicated-output-stream - (connection.socket-io connection)))) - (out (or dedicated-output out)) - (io (make-two-way-stream in out)) - (repl-results (make-output-stream-for-target connection - :repl-result))) - (when (eq (connection.communication-style connection) :spawn) - (spawn (lambda () (auto-flush-loop out)) - :name "auto-flush-thread")) - (values dedicated-output in out io repl-results))))) + (let* ((output-fn (make-output-function connection)) + (input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs))))) + (dedicated-output (if *use-dedicated-output-stream* + (open-dedicated-output-stream + (connection.socket-io connection)))) + (out (make-output-stream output-fn)) + (in (make-input-stream input-fn)) + (out (or dedicated-output out)) + (io (make-two-way-stream in out)) + (repl-results (make-output-stream-for-target connection + :repl-result))) + (when (eq (connection.communication-style connection) :spawn) + (spawn (lambda () (auto-flush-loop out)) + :name "auto-flush-thread")) + (values dedicated-output in out io repl-results))) (defvar *maximum-pipelined-output-chunks* 20) @@ -874,10 +875,7 @@ (defun make-output-stream-for-target (connection target) "Create a stream that sends output to a specific TARGET in Emacs." - (nth-value 1 (make-fn-streams - (lambda () - (error "Should never be called")) - (make-output-function-for-target connection target)))) + (make-output-stream (make-output-function-for-target connection target))) (defun open-dedicated-output-stream (socket-io) "Open a dedicated output connection to the Emacs on SOCKET-IO. From heller at common-lisp.net Sun Aug 31 11:58:09 2008 From: heller at common-lisp.net (heller) Date: Sun, 31 Aug 2008 07:58:09 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080831115809.84A9855356@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv19284 Modified Files: ChangeLog Log Message: Fix changelog entry. --- /project/slime/cvsroot/slime/ChangeLog 2008/08/31 11:58:01 1.1490 +++ /project/slime/cvsroot/slime/ChangeLog 2008/08/31 11:58:09 1.1491 @@ -2,7 +2,7 @@ * swank-backend.lisp (*gray-stream-symbols*): Remove stream-file-position because it's called stream-position in CCL. - (make-input-stream): Remove make-fn-streams. + (make-fn-streams): Deleted. Update callers accordingly. 2008-08-30 Helmut Eller