From lgorrie at common-lisp.net Mon Dec 1 16:47:58 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 01 Dec 2003 11:47:58 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30662 Modified Files: slime.el Log Message: (slime-repl-return): Goto end of input area before inserting newline. (slime-autodoc-message-ok-p): Test to see if a documentation message should be printed (returns nil if the minibuffer/echo-area is already being used). (slime-log-events): When nil, don't log events to *slime-events*. This works-around a problem Raymond Toy has when starting SLIME under XEmacs. Still investigating.. Date: Mon Dec 1 11:47:58 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.120 slime/slime.el:1.121 --- slime/slime.el:1.120 Sun Nov 30 02:58:45 2003 +++ slime/slime.el Mon Dec 1 11:47:58 2003 @@ -1160,22 +1160,27 @@ (error "The SLIME protocol reached an inconsistent state.")) + +(defvar slime-log-events t + "*Log protocol events to the *slime-events* buffer.") + ;;;;; Event logging to *slime-events* (defun slime-log-event (event) - (with-current-buffer (slime-events-buffer) - ;; trim? - (when (> (buffer-size) 100000) - (goto-char (/ (buffer-size) 2)) - (beginning-of-defun) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (save-excursion - (pp event (current-buffer)) - (when (equal event '(activate)) - (backward-char 1) - (insert (format " ; %s" (slime-state-name (slime-current-state)))))) - (hs-hide-block-at-point) - (goto-char (point-max)))) + (when slime-log-events + (with-current-buffer (slime-events-buffer) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (beginning-of-defun) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (save-excursion + (pp event (current-buffer)) + (when (equal event '(activate)) + (backward-char 1) + (insert (format " ; %s" (slime-state-name (slime-current-state)))))) + (hs-hide-block-at-point) + (goto-char (point-max))))) (defun slime-events-buffer () (or (get-buffer "*slime-events*") @@ -1646,6 +1651,7 @@ (insert "\n")) ((slime-input-complete-p slime-repl-input-start-mark slime-repl-input-end-mark) + (goto-char slime-repl-input-end-mark) (insert "\n") (slime-repl-send-input)) (t @@ -2360,12 +2366,20 @@ When `slime-autodoc-mode' is non-nil, print apropos information about the symbol at point if applicable." (assert slime-mode) - (when (and (slime-connected-p) (not (slime-busy-p))) + (when (and (slime-connected-p) (slime-autodoc-message-ok-p) (not (slime-busy-p))) (condition-case err (slime-autodoc) (error (setq slime-autodoc-mode nil) (message "Error: %S; slime-autodoc-mode now disabled." err))))) + +(defun slime-autodoc-message-ok-p () + "Return true if printing a message is currently okay (shouldn't annoy the user)." + (and (null (current-message)) + (not executing-kbd-macro) + (not (and (boundp 'edebug-active) edebug-active)) + (not cursor-in-echo-area) + (not (eq (selected-window) (minibuffer-window))))) ;;; Typeout frame From lgorrie at common-lisp.net Mon Dec 1 16:48:18 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 01 Dec 2003 11:48:18 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30785 Modified Files: ChangeLog Log Message: Date: Mon Dec 1 11:48:18 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.124 slime/ChangeLog:1.125 --- slime/ChangeLog:1.124 Sun Nov 30 03:20:40 2003 +++ slime/ChangeLog Mon Dec 1 11:48:18 2003 @@ -1,3 +1,14 @@ +2003-12-01 Luke Gorrie + + * slime.el (slime-repl-return): Goto end of input area before + inserting newline. + (slime-autodoc-message-ok-p): Test to see if a documentation + message should be printed (returns nil if the + minibuffer/echo-area is already being used). + (slime-log-events): When nil, don't log events to + *slime-events*. This works-around a problem Raymond Toy has when + starting SLIME under XEmacs. Still investigating.. + 2003-11-29 Helmut Eller * slime.el: Rewrite the xref code to work with other source From lgorrie at common-lisp.net Mon Dec 1 20:16:55 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 01 Dec 2003 15:16:55 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26769 Modified Files: slime.el Log Message: (slime-repl-return): Goto end of input area before inserting newline. (slime-autodoc-message-ok-p): Test to see if a documentation message should be printed (returns nil if the minibuffer/echo-area is already being used). (slime-log-events): When nil, don't log events to (slime-symbol-at-point): Skip back over whitespace before looking for the symbol. (slime-autodoc-delay): New configurable to specify the delay before printing an autodoc message (default 0.2 secs). (slime-ensure-typeout-frame): New function to call create a typeout frame unless it already exists. Suitable to run on slime-mode-hook if you always want to have a typeout window. Date: Mon Dec 1 15:16:55 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.121 slime/slime.el:1.122 --- slime/slime.el:1.121 Mon Dec 1 11:47:58 2003 +++ slime/slime.el Mon Dec 1 15:16:55 2003 @@ -429,11 +429,8 @@ (setq slime-pre-command-actions nil)) (defun slime-post-command-hook () - (when slime-mode - (when (slime-connected-p) - (slime-process-available-input)) - (when slime-autodoc-mode - (slime-autodoc-post-command-hook)))) + (when (and slime-mode (slime-connected-p)) + (slime-process-available-input))) (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." @@ -615,8 +612,10 @@ (defun slime-symbol-at-point () "Return the symbol at point, otherwise nil." - (let ((string (thing-at-point 'symbol))) - (if string (intern (substring-no-properties string)) nil))) + (save-excursion + (skip-syntax-backward "-") + (let ((string (thing-at-point 'symbol))) + (if string (intern (substring-no-properties string)) nil)))) (defun slime-symbol-name-at-point () "Return the name of the symbol at point, otherwise nil." @@ -2318,7 +2317,8 @@ (interactive) (cond ((and arg (not (eq -1 arg))) (setq slime-autodoc-mode t)) ((eq -1 arg) (setq slime-autodoc-mode nil)) - (t (setq slime-autodoc-mode (not slime-autodoc-mode))))) + (t (setq slime-autodoc-mode (not slime-autodoc-mode)))) + (when slime-autodoc-mode (slime-autodoc-start-timer))) (defun slime-autodoc () "Print some apropos information about the code at point, if applicable." @@ -2326,7 +2326,7 @@ (let ((name (symbol-name sym)) (cache-key (slime-qualify-cl-symbol-name sym))) (or (when-let (documentation (slime-get-cached-autodoc cache-key)) - (message documentation) + (slime-background-message documentation) t) ;; Asynchronously fetch, cache, and display arglist (slime-arglist @@ -2337,7 +2337,7 @@ (unless (string-match "" arglist) (setq arglist (slime-format-arglist name arglist)) (slime-update-autodoc-cache cache-key arglist) - (message arglist))))))))) + (slime-background-message arglist))))))))) (defun slime-get-cached-autodoc (symbol-name) "Return the cached autodoc documentation for SYMBOL-NAME, or nil." @@ -2361,12 +2361,29 @@ (put (intern symbol-name) 'slime-autodoc-cache documentation))) documentation) -(defun slime-autodoc-post-command-hook () - "Function to be called after each Emacs command in a slime-mode buffer. + +;;;; Asynchronous message idle timer + +(defvar slime-autodoc-idle-timer nil + "Idle timer for the next autodoc message.") + +(defvar slime-autodoc-delay 0.2 + "*Delay before autodoc messages are fetched and displayed, in seconds.") + +(defun slime-autodoc-start-timer () + "*(Re)start the timer that prints autodocs every `slime-autodoc-delay' seconds." + (interactive) + (when slime-autodoc-idle-timer + (cancel-timer slime-autodoc-idle-timer)) + (setq slime-autodoc-idle-timer + (run-with-idle-timer slime-autodoc-delay slime-autodoc-delay + 'slime-autodoc-timer-hook))) + +(defun slime-autodoc-timer-hook () + "Function to be called after each Emacs becomes idle. When `slime-autodoc-mode' is non-nil, print apropos information about the symbol at point if applicable." - (assert slime-mode) - (when (and (slime-connected-p) (slime-autodoc-message-ok-p) (not (slime-busy-p))) + (when (slime-autodoc-message-ok-p) (condition-case err (slime-autodoc) (error @@ -2375,11 +2392,15 @@ (defun slime-autodoc-message-ok-p () "Return true if printing a message is currently okay (shouldn't annoy the user)." - (and (null (current-message)) + (and slime-mode + slime-autodoc-mode + (null (current-message)) (not executing-kbd-macro) (not (and (boundp 'edebug-active) edebug-active)) (not cursor-in-echo-area) - (not (eq (selected-window) (minibuffer-window))))) + (not (eq (selected-window) (minibuffer-window))) + (slime-connected-p) + (not (slime-busy-p)))) ;;; Typeout frame @@ -2412,6 +2433,12 @@ (select-window (frame-selected-window frame)) (switch-to-buffer "*SLIME-Typeout*") (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) + (slime-make-typeout-frame))) ;;; Completion From lgorrie at common-lisp.net Mon Dec 1 20:18:37 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 01 Dec 2003 15:18:37 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27227 Modified Files: ChangeLog Log Message: Date: Mon Dec 1 15:18:37 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.125 slime/ChangeLog:1.126 --- slime/ChangeLog:1.125 Mon Dec 1 11:48:18 2003 +++ slime/ChangeLog Mon Dec 1 15:18:36 2003 @@ -6,6 +6,14 @@ message should be printed (returns nil if the minibuffer/echo-area is already being used). (slime-log-events): When nil, don't log events to + (slime-symbol-at-point): Skip back over whitespace before + looking for the symbol. + (slime-autodoc-delay): New configurable to specify the delay + before printing an autodoc message (default 0.2 secs). + (slime-ensure-typeout-frame): New function to call create a + typeout frame unless it already exists. Suitable to run on + slime-mode-hook if you always want to have a typeout window. + (slime-log-events): New variable. When nil don't log to events to *slime-events*. This works-around a problem Raymond Toy has when starting SLIME under XEmacs. Still investigating.. From lgorrie at common-lisp.net Mon Dec 1 21:44:06 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 01 Dec 2003 16:44:06 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv351 Modified Files: ChangeLog Log Message: typo fix Date: Mon Dec 1 16:44:06 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.126 slime/ChangeLog:1.127 --- slime/ChangeLog:1.126 Mon Dec 1 15:18:36 2003 +++ slime/ChangeLog Mon Dec 1 16:44:05 2003 @@ -5,7 +5,6 @@ (slime-autodoc-message-ok-p): Test to see if a documentation message should be printed (returns nil if the minibuffer/echo-area is already being used). - (slime-log-events): When nil, don't log events to (slime-symbol-at-point): Skip back over whitespace before looking for the symbol. (slime-autodoc-delay): New configurable to specify the delay @@ -13,7 +12,7 @@ (slime-ensure-typeout-frame): New function to call create a typeout frame unless it already exists. Suitable to run on slime-mode-hook if you always want to have a typeout window. - (slime-log-events): New variable. When nil don't log to events to + (slime-log-events): When nil, don't log events to *slime-events*. This works-around a problem Raymond Toy has when starting SLIME under XEmacs. Still investigating.. From heller at common-lisp.net Mon Dec 1 22:12:40 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:12:40 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12149 Modified Files: swank-openmcl.lisp Log Message: (find-function-locations): Return all methods for generic functions. Doens't work very well if multiple methos are in the same file. (swank-accept-connection): Don't create an extra thread, call request-loop directly. Date: Mon Dec 1 17:12:40 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.25 slime/swank-openmcl.lisp:1.26 --- slime/swank-openmcl.lisp:1.25 Sun Nov 30 03:15:26 2003 +++ slime/swank-openmcl.lisp Mon Dec 1 17:12:39 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.25 2003/11/30 08:15:26 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.26 2003/12/01 22:12:39 heller Exp $ ;;; ;;; @@ -90,13 +90,9 @@ "Accept one Swank TCP connection on SOCKET and then close it. Run the connection handler in a new thread." (let ((socket (ccl:accept-connection server-socket :wait t))) - (close server-socket) - (ccl:process-run-function - (list :name (format nil "Swank Client ~D" (ccl:socket-os-fd socket)) - :initial-bindings `((*emacs-io* . ',socket))) - #'request-loop))) + (request-loop socket))) -(defun request-loop () +(defun request-loop (*emacs-io*) "Thread function for a single Swank connection. Processes requests until the remote Emacs goes away." (unwind-protect @@ -221,7 +217,7 @@ (start-frame-number 0) (end-frame-number most-positive-fixnum)) "Call FUNCTION passing information about each stack frame -from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." (let ((tcr (ccl::%current-tcr)) (frame-number 0) (top-stack-frame (or *swank-debugger-stack-frame* @@ -319,18 +315,26 @@ (declare (ignore index)) nil) +(defun source-info-first-file-name (info) + (etypecase info + ((or pathname string) (namestring (truename info))) + (cons + (etypecase (car info) + (cons (source-info-first-file-name (car info))) + (standard-method (source-info-first-file-name (cdr info))) + ((member function) (source-info-first-file-name (cdr info))) + ((member method) (source-info-first-file-name (cdr info))) + ((or pathname string) (namestring (truename (car info)))))))) + (defun function-source-location (symbol) "Return a plist containing a source location for the function named SYMBOL." - (let ((source-info (ccl::%source-files symbol))) - ;; This is not entirely correct---%SOURCE-FILES can apparently - ;; return a list under some circumstances... - (cond ((and source-info (atom source-info)) - (let ((filename (namestring (truename source-info)))) - (make-location - (list :file filename) - (list :function-name (symbol-name symbol))))) - (t (list :error (format nil "No source infor for ~S" symbol)))))) + (let ((source-info (ccl::source-file-or-files symbol nil nil nil))) + (if source-info + (make-location + (list :file (source-info-first-file-name source-info)) + (list :function-name (symbol-name symbol))) + (list :error (format nil "No source infor for ~S" symbol))))) (defmethod frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the @@ -416,8 +420,39 @@ (function-source-location (from-string fname))) (defslimefun find-function-locations (fname) - (list (function-source-location-for-emacs fname))) + (let* ((symbol (from-string fname)) + (symbol-name (string symbol)) + (info (ccl::source-file-or-files symbol nil nil nil)) + (locations '())) + (labels ((frob (pathname position) + (multiple-value-bind (truename c) (truename pathname) + (cond (c + (push (list :error (princ-to-string c)) locations)) + (t + (push (make-location (list :file (namestring truename)) + position) + locations))))) + (frob* (list position) + (etypecase list + (cons (dolist (file list) (frob file position))) + ((or string pathname) (frob list position))))) + (etypecase info + (null (return-from find-function-locations + (list + (list :error + (format nil "No source info available for ~A" fname))))) + ((or string pathname) (frob info (list :function-name fname))) + (cons + (dolist (i info) + (etypecase (car i) + ((member method) + (loop for (m . files) in (cdr i) + do (frob* files + (list :function-name symbol-name)))) + ((member function) + (frob* (cdr i) + (list :function-name fname)))))))) + locations)) ;;; Macroexpansion - (defslimefun-unimplemented swank-macroexpand-all (string)) From heller at common-lisp.net Mon Dec 1 22:15:03 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:15:03 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13661 Modified Files: slime.el Log Message: (slime-create-note-overlay, slime-sexp-depth): The priority property is unused. Remove it. Date: Mon Dec 1 17:15:03 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.122 slime/slime.el:1.123 --- slime/slime.el:1.122 Mon Dec 1 15:16:55 2003 +++ slime/slime.el Mon Dec 1 17:15:02 2003 @@ -1968,7 +1968,6 @@ (let ((overlay (make-overlay start end))) (flet ((putp (name value) (overlay-put overlay name value))) (putp 'slime note) - (putp 'priority (slime-sexp-depth start)) (putp 'face (slime-severity-face severity)) (putp 'severity severity) (unless (emacs-20-p) @@ -1976,17 +1975,6 @@ (putp 'help-echo message) overlay))) -(defun slime-sexp-depth (position) - "Return the number of sexps containing POSITION." - (let ((n 0)) - (save-excursion - (goto-char position) - (ignore-errors - (while t - (backward-up-list 1) - (incf n)))) - n)) - (defun slime-merge-note-into-overlay (overlay severity message) "Merge another compiler note into an existing overlay. The help text describes both notes, and the highest of the severities @@ -2002,8 +1990,7 @@ If the location's sexp is a list spanning multiple lines, then the region around the first element is used." (let ((location (getf note :location))) - (unless (equal location '(:null)) - (slime-goto-source-location location))) + (slime-goto-source-location location)) (let ((start (point))) (slime-forward-sexp) (if (slime-same-line-p start (point)) @@ -2541,7 +2528,7 @@ (if (fboundp 'temp-minibuffer-message) ;; XEmacs (temp-minibuffer-message text) (minibuffer-message text)) - (message text)))) + (message "%s" text)))) (defun slime-completing-read-internal (string default-package flag) ;; We misuse the predicate argument to pass the default-package. @@ -3840,7 +3827,7 @@ (with-current-buffer slime-test-buffer-name (goto-char (point-min)) (insert summary "\n\n"))) - (message summary) + (message "%s" summary) slime-failed-tests)))) (defun slime-batch-test (results-file) From heller at common-lisp.net Mon Dec 1 22:17:16 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:17:16 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14376 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Dec 1 17:17:16 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.127 slime/ChangeLog:1.128 --- slime/ChangeLog:1.127 Mon Dec 1 16:44:05 2003 +++ slime/ChangeLog Mon Dec 1 17:17:16 2003 @@ -1,3 +1,14 @@ +2003-12-01 Helmut Eller + + * slime.el (slime-create-note-overlay, slime-sexp-depth): The + 'priority' property is unused. Remove it. + + * swank-openmcl.lisp (find-function-locations): Return all methods + for generic functions. Doesn't work very well if multiple methods + are in the same file. + (swank-accept-connection): Don't create an extra thread, call + request-loop directly. + 2003-12-01 Luke Gorrie * slime.el (slime-repl-return): Goto end of input area before From heller at common-lisp.net Mon Dec 1 22:30:07 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:30:07 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20370 Modified Files: swank-cmucl.lisp Log Message: (invoke-nth-restart): Use invoke-restart-interactively. Date: Mon Dec 1 17:30:04 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.30 slime/swank-cmucl.lisp:1.31 --- slime/swank-cmucl.lisp:1.30 Sun Nov 30 03:09:44 2003 +++ slime/swank-cmucl.lisp Mon Dec 1 17:30:03 2003 @@ -233,6 +233,7 @@ (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A" enclosing source condition))) + (defun compiler-note-location (context) (cond (context (resolve-note-location @@ -658,7 +659,7 @@ ((macro-function symbol) (function-source-locations (macro-function symbol))) ((special-operator-p symbol) - (list (list :error (format nil "~A is special-operator" symbol)))) + (list (list :error (format nil "~A is a special-operator" symbol)))) ((fboundp symbol) (function-source-locations (coerce symbol 'function))) (t (list (list :error @@ -1083,7 +1084,7 @@ collect `(,tag . ,(code-location-source-location code-location)))) (defslimefun invoke-nth-restart (index) - (invoke-restart (nth-restart index))) + (invoke-restart-interactively (nth-restart index))) (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) From heller at common-lisp.net Mon Dec 1 22:30:17 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:30:17 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20704 Modified Files: swank-lispworks.lisp Log Message: (invoke-nth-restart): Use invoke-restart-interactively. Date: Mon Dec 1 17:30:17 2003 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.4 slime/swank-lispworks.lisp:1.5 --- slime/swank-lispworks.lisp:1.4 Sun Nov 30 03:12:11 2003 +++ slime/swank-lispworks.lisp Mon Dec 1 17:30:16 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.4 2003/11/30 08:12:11 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.5 2003/12/01 22:30:16 heller Exp $ ;;; (in-package :swank) @@ -218,8 +218,7 @@ (nth index *sldb-restarts*)) (defslimefun invoke-nth-restart (index) - (let ((restart (nth-restart index))) - (invoke-restart restart))) + (invoke-restart-interactively (nth-restart index))) (defmethod frame-locals (n) (let ((frame (nth-frame n))) From heller at common-lisp.net Mon Dec 1 22:30:26 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:30:26 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20740 Modified Files: swank-openmcl.lisp Log Message: (invoke-nth-restart): Use invoke-restart-interactively. Date: Mon Dec 1 17:30:26 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.26 slime/swank-openmcl.lisp:1.27 --- slime/swank-openmcl.lisp:1.26 Mon Dec 1 17:12:39 2003 +++ slime/swank-openmcl.lisp Mon Dec 1 17:30:26 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.26 2003/12/01 22:12:39 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.27 2003/12/01 22:30:26 heller Exp $ ;;; ;;; @@ -352,8 +352,7 @@ (nth index *sldb-restarts*)) (defslimefun invoke-nth-restart (index) - (let ((restart (nth-restart index))) - (invoke-restart restart))) + (invoke-restart-interactively (nth-restart index))) (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) From heller at common-lisp.net Mon Dec 1 22:30:34 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:30:34 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20770 Modified Files: swank-sbcl.lisp Log Message: (invoke-nth-restart): Use invoke-restart-interactively. Date: Mon Dec 1 17:30:34 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.32 slime/swank-sbcl.lisp:1.33 --- slime/swank-sbcl.lisp:1.32 Sun Nov 30 03:15:42 2003 +++ slime/swank-sbcl.lisp Mon Dec 1 17:30:34 2003 @@ -532,7 +532,7 @@ collect `(,tag . ,(safe-source-location-for-emacs code-location)))) (defslimefun invoke-nth-restart (index) - (invoke-restart (nth-restart index))) + (invoke-restart-interactively (nth-restart index))) (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) From heller at common-lisp.net Mon Dec 1 22:33:41 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Dec 2003 17:33:41 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21332 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Dec 1 17:33:38 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.128 slime/ChangeLog:1.129 --- slime/ChangeLog:1.128 Mon Dec 1 17:17:16 2003 +++ slime/ChangeLog Mon Dec 1 17:33:37 2003 @@ -1,5 +1,8 @@ 2003-12-01 Helmut Eller + * swank-[cmucl,sbcl,openmcl,lispworks].lisp (invoke-nth-restart): + Use invoke-restart-interactively. + * slime.el (slime-create-note-overlay, slime-sexp-depth): The 'priority' property is unused. Remove it. From dbarlow at common-lisp.net Tue Dec 2 00:56:26 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 01 Dec 2003 19:56:26 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16176 Modified Files: swank-sbcl.lisp Log Message: * swank-sbcl.lisp (function-source-location-for-emacs): return a list of source locations (one per method) when the request is for a GF. This seems to make the elisp side popup a window to let the user select one. Cool. Date: Mon Dec 1 19:56:26 2003 Author: dbarlow Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.33 slime/swank-sbcl.lisp:1.34 --- slime/swank-sbcl.lisp:1.33 Mon Dec 1 17:30:34 2003 +++ slime/swank-sbcl.lisp Mon Dec 1 19:56:26 2003 @@ -296,22 +296,22 @@ (t (list :function-name fname))))))) (defmethod function-source-location-for-emacs (fname-string) - "Return the source-location of FNAME's definition." + "Return the source-location(s) of FNAME's definition(s)." (let* ((fname (from-string fname-string))) (labels ((finder (fname) (cond ((and (symbolp fname) (macro-function fname)) (function-source-location (macro-function fname) fname-string)) ((typep fname 'sb-mop:generic-function) - (function-source-location - ;; FIXME really we should do something to present - ;; all methods instead of just presenting the first - (car (sb-mop:generic-function-methods fname)) - fname-string)) - ((sb-introspect:valid-function-name-p fname) - (finder (fdefinition fname))) + (list* + (function-source-location fname fname-string) + (mapcar + (lambda (x) (function-source-location x fname-string)) + (sb-mop:generic-function-methods fname)))) ((functionp fname) - (function-source-location fname fname-string))))) + (function-source-location fname fname-string)) + ((sb-introspect:valid-function-name-p fname) + (finder (fdefinition fname))) ))) (if *debug-definition-finding* (finder fname) (handler-case (finder fname) @@ -319,7 +319,10 @@ (list :error (format nil "Error: ~A" e)))))))) (defslimefun find-function-locations (name) - (list (function-source-location-for-emacs name))) + (let ((loc (function-source-location-for-emacs name))) + (if (listp loc) + loc + (list loc)))) (defmethod describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. From dbarlow at common-lisp.net Tue Dec 2 00:56:39 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 01 Dec 2003 19:56:39 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16207 Modified Files: ChangeLog Log Message: Date: Mon Dec 1 19:56:39 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.129 slime/ChangeLog:1.130 --- slime/ChangeLog:1.129 Mon Dec 1 17:33:37 2003 +++ slime/ChangeLog Mon Dec 1 19:56:39 2003 @@ -1,3 +1,10 @@ +2003-12-02 Daniel Barlow + + * swank-sbcl.lisp (function-source-location-for-emacs): return a + list of source locations (one per method) when the request is + for a GF. This seems to make the elisp side popup a window + to let the user select one. Cool. + 2003-12-01 Helmut Eller * swank-[cmucl,sbcl,openmcl,lispworks].lisp (invoke-nth-restart): From dbarlow at common-lisp.net Tue Dec 2 01:33:15 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 01 Dec 2003 20:33:15 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30106 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-with-xref-buffer): moved further up the file so it's defined before slime-show-xrefs needs it Date: Mon Dec 1 20:33:15 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.130 slime/ChangeLog:1.131 --- slime/ChangeLog:1.130 Mon Dec 1 19:56:39 2003 +++ slime/ChangeLog Mon Dec 1 20:33:14 2003 @@ -1,5 +1,8 @@ 2003-12-02 Daniel Barlow + * slime.el (slime-with-xref-buffer): moved further up the file so + it's defined before slime-show-xrefs needs it + * swank-sbcl.lisp (function-source-location-for-emacs): return a list of source locations (one per method) when the request is for a GF. This seems to make the elisp side popup a window Index: slime/slime.el diff -u slime/slime.el:1.123 slime/slime.el:1.124 --- slime/slime.el:1.123 Mon Dec 1 17:15:02 2003 +++ slime/slime.el Mon Dec 1 20:33:14 2003 @@ -2997,6 +2997,25 @@ (lambda (result) (slime-show-xrefs result type symbol package))))) +(defmacro* slime-with-xref-buffer ((package ref-type symbol) &body body) + "Execute BODY in a xref buffer, then show that buffer." + (let ((type (gensym)) + (sym (gensym))) + `(let ((,type ,ref-type) + (,sym ,symbol)) + (with-current-buffer (get-buffer-create + (format "*XREF[%s: %s]*" ,type ,sym)) + (prog2 (progn + (slime-init-xref-buffer ,package ,type ,sym) + (make-local-variable 'slime-xref-saved-window-configuration) + (setq slime-xref-saved-window-configuration + ,(current-window-configuration))) + (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)))))) + (defun slime-show-xrefs (xrefs type symbol package) "Show the results of an XREF query." (if (null xrefs) @@ -3041,26 +3060,7 @@ (setq slime-buffer-package package) (slime-set-truncate-lines)) -(defmacro* slime-with-xref-buffer ((package ref-type symbol) &body body) - "(slime-with-xref-buffer (package ref-type symbol) &body body) -Execute BODY in a xref buffer, then show that buffer." - (let ((type (gensym)) - (sym (gensym))) - `(let ((,type ,ref-type) - (,sym ,symbol)) - (with-current-buffer (get-buffer-create - (format "*XREF[%s: %s]*" ,type ,sym)) - (prog2 (progn - (slime-init-xref-buffer ,package ,type ,sym) - (make-local-variable 'slime-xref-saved-window-configuration) - (setq slime-xref-saved-window-configuration - ,(current-window-configuration))) - (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)))))) (put 'slime-with-xref-buffer 'lisp-indent-function 1) From heller at common-lisp.net Tue Dec 2 13:55:47 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 02 Dec 2003 08:55:47 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8480 Modified Files: slime.el Log Message: Patch by Sean O'Rourke: slime-repl-{clear-buffer,clear-output}: clear the last and entire output in the *slime-repl* buffer (slime-documentation): pop up a buffer with a symbol's documentation instead of its description, if found. (slime-complete-symbol): tweak to completion, taken from ilisp, to complete filenames inside strings. (slime-set-default-directory): also set *slime-repl*'s default-directory, so e.g. find-file makes sense. (slime-with-xref-buffer): Remove spurious comma. (Reported by Raymond Wiker). Some reordering of the xref code. Date: Tue Dec 2 08:55:47 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.124 slime/slime.el:1.125 --- slime/slime.el:1.124 Mon Dec 1 20:33:14 2003 +++ slime/slime.el Tue Dec 2 08:55:47 2003 @@ -1531,6 +1531,7 @@ (defvar slime-repl-input-end-mark (let ((m (make-marker))) (set-marker-insertion-type m t) m)) +(defvar slime-repl-last-input-start-mark (make-marker)) (defun slime-repl-mode () "Major mode for interacting with a superior Lisp. @@ -1612,6 +1613,8 @@ (insert result "\n"))))) (defun slime-mark-input-start () + (set-marker slime-repl-last-input-start-mark + (marker-position slime-repl-input-start-mark)) (set-marker slime-repl-input-start-mark (point) (current-buffer)) (set-marker slime-repl-input-end-mark (point) (current-buffer))) @@ -1695,6 +1698,27 @@ (slime-repl-delete-current-input) (insert-and-inherit string)) +(defun slime-repl-input-line-beginning-position () + (save-excursion + (goto-char slime-repl-input-start-mark) + (line-beginning-position))) + +(defun slime-repl-clear-buffer () + (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)))) + +(defun slime-repl-clear-output () + (interactive) + (when (marker-position slime-repl-last-input-start-mark) + (delete-region slime-repl-last-input-start-mark + (1- (slime-repl-input-line-beginning-position))) + (save-excursion + (goto-char slime-repl-last-input-start-mark) + (insert ";;; output flushed")) + (set-marker slime-repl-last-input-start-mark nil))) + ;;; Scratch (defvar slime-scratch-mode-map) @@ -1799,6 +1823,8 @@ ("\t" 'slime-complete-symbol) (" " 'slime-space) ("\C-\M-x" 'slime-eval-defun) + ("\C-c\C-o" 'slime-repl-clear-output) + ("\C-c\C-t" 'slime-repl-clear-buffer) ) (define-minor-mode slime-repl-read-mode @@ -2378,7 +2404,8 @@ (message "Error: %S; slime-autodoc-mode now disabled." err))))) (defun slime-autodoc-message-ok-p () - "Return true if printing a message is currently okay (shouldn't annoy the user)." + "Return true if printing a message is currently okay (shouldn't +annoy the user)." (and slime-mode slime-autodoc-mode (null (current-message)) @@ -2482,13 +2509,15 @@ ;; errors propagate. (message "Error in slime-complete-forget-window-configuration: %S" err)))) -(defun slime-complete-symbol () +(defun* slime-complete-symbol () "Complete the symbol at point. If the symbol lacks an explicit package prefix, the current buffer's package is used." ;; NB: It is only the name part of the symbol that we actually want ;; to complete -- the package prefix, if given, is just context. (interactive) + (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) + (return-from slime-complete-symbol (comint-dynamic-complete-as-filename))) (let* ((end (slime-symbol-end-pos)) (beg (slime-symbol-start-pos)) (prefix (buffer-substring-no-properties beg end)) @@ -2845,6 +2874,14 @@ (error "No symbol given")) (slime-eval-describe `(swank:describe-symbol ,symbol-name))) +(defun slime-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe + `(swank:documentation-symbol ,symbol-name "(not documented))"))) + (defun slime-describe-function (symbol-name) (interactive (list (slime-read-symbol-name "Describe symbol: "))) (when (not symbol-name) @@ -2939,6 +2976,8 @@ ;;; XREF: cross-referencing (defvar slime-xref-mode-map) +(defvar slime-xref-saved-window-configuration nil + "Buffer local variable in xref windows.") (define-derived-mode slime-xref-mode lisp-mode "xref" "\\ @@ -2961,41 +3000,33 @@ (let ((key (if prefixed (concat slime-prefix-key key) key))) (define-key slime-xref-mode-map key command))))) -(defun slime-who-calls (symbol) - "Show all known callers of the function SYMBOL." - (interactive (list (slime-read-symbol-name "Who calls: " t))) - (slime-xref 'calls symbol)) - -(defun slime-who-references (symbol) - "Show all known referrers of the global variable SYMBOL." - (interactive (list (slime-read-symbol-name "Who references: " t))) - (slime-xref 'references symbol)) - -(defun slime-who-binds (symbol) - "Show all known binders of the global variable SYMBOL." - (interactive (list (slime-read-symbol-name "Who binds: " t))) - (slime-xref 'binds symbol)) + +;;;; XREF results buffer and window management -(defun slime-who-sets (symbol) - "Show all known setters of the global variable SYMBOL." - (interactive (list (slime-read-symbol-name "Who sets: " t))) - (slime-xref 'sets symbol)) +(defun slime-xref-buffer (&optional create) + "Return the XREF results buffer. +If CREATE is non-nil, create it if necessary." + (if create + (get-buffer-create "*CMUCL xref*") + (or (get-buffer "*CMUCL xref*") + (error "No XREF buffer")))) -(defun slime-who-macroexpands (symbol) - "Show all known expanders of the macro SYMBOL." - (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) - (slime-xref 'macroexpands symbol)) +(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)) -(defun slime-xref (type symbol) - "Make an XREF request to Lisp." - (slime-eval-async - `(,(intern (format "swank:who-%s" type)) ',symbol) - (slime-buffer-package t) - (lexical-let ((type type) - (symbol symbol) - (package (slime-buffer-package))) - (lambda (result) - (slime-show-xrefs result type symbol package))))) +(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) &body body) "Execute BODY in a xref buffer, then show that buffer." @@ -3009,23 +3040,14 @@ (slime-init-xref-buffer ,package ,type ,sym) (make-local-variable 'slime-xref-saved-window-configuration) (setq slime-xref-saved-window-configuration - ,(current-window-configuration))) + (current-window-configuration))) (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)))))) -(defun slime-show-xrefs (xrefs type symbol package) - "Show the results of an XREF query." - (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) - (slime-insert-xrefs xrefs) - (goto-char (point-min)) - (forward-line) - (skip-chars-forward " \t")))) +(put 'slime-with-xref-buffer 'lisp-indent-function 1) (defun slime-insert-xrefs (xrefs) "Insert XREFS in the current-buffer. @@ -3041,39 +3063,55 @@ 'face 'font-lock-keyword-face) " " label "\n"))))) +(defun slime-show-xrefs (xrefs type symbol package) + "Show the results of an XREF query." + (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) + (slime-insert-xrefs xrefs) + (goto-char (point-min)) + (forward-line) + (skip-chars-forward " \t")))) + -;;;; XREF results buffer and window management +;;; XREF commands -(defun slime-xref-buffer (&optional create) - "Return the XREF results buffer. -If CREATE is non-nil, create it if necessary." - (if create - (get-buffer-create "*CMUCL xref*") - (or (get-buffer "*CMUCL xref*") - (error "No XREF buffer")))) +(defun slime-who-calls (symbol) + "Show all known callers of the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref 'calls symbol)) -(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)) +(defun slime-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who references: " t))) + (slime-xref 'references symbol)) +(defun slime-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who binds: " t))) + (slime-xref 'binds symbol)) +(defun slime-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who sets: " t))) + (slime-xref 'sets symbol)) -(put 'slime-with-xref-buffer 'lisp-indent-function 1) +(defun slime-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) + (slime-xref 'macroexpands symbol)) -(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)) - (set-window-text-height (selected-window) - (min (count-lines (point-min) (point-max)) - (window-text-height)))))) +(defun slime-xref (type symbol) + "Make an XREF request to Lisp." + (slime-eval-async + `(,(intern (format "swank:who-%s" type)) ',symbol) + (slime-buffer-package t) + (lexical-let ((type type) + (symbol symbol) + (package (slime-buffer-package))) + (lambda (result) + (slime-show-xrefs result type symbol package))))) ;;;; XREF navigation @@ -3200,6 +3238,8 @@ (defun slime-set-default-directory (directory) (interactive (list (read-file-name "Directory: " nil default-directory t))) + (with-current-buffer (slime-output-buffer) + (setq default-directory (expand-file-name directory))) (message "default-directory: %s" (slime-eval `(swank:set-default-directory ,(expand-file-name directory))))) From heller at common-lisp.net Tue Dec 2 13:56:28 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 02 Dec 2003 08:56:28 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8707 Modified Files: swank.lisp Log Message: (documentation-symbol): New optional argument for return value if the symbol is not documented. Date: Tue Dec 2 08:56:28 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.74 slime/swank.lisp:1.75 --- slime/swank.lisp:1.74 Sun Nov 30 03:14:28 2003 +++ slime/swank.lisp Tue Dec 2 08:56:27 2003 @@ -721,15 +721,16 @@ (print-description-to-string (symbol-function (find-symbol-designator symbol-name)))) -(defslimefun documentation-symbol (symbol-name) +(defslimefun documentation-symbol (symbol-name &optional default) (let ((*package* *buffer-package*)) (let ((vdoc (documentation (symbol-from-string symbol-name) 'variable)) (fdoc (documentation (symbol-from-string symbol-name) 'function))) - (and (or vdoc fdoc) - (concatenate 'string - fdoc - (and vdoc fdoc '(#\Newline #\Newline)) - vdoc))))) + (or (and (or vdoc fdoc) + (concatenate 'string + fdoc + (and vdoc fdoc '(#\Newline #\Newline)) + vdoc)) + default)))) ;;;; From heller at common-lisp.net Tue Dec 2 14:01:16 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 02 Dec 2003 09:01:16 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11273 Modified Files: swank-sbcl.lisp Log Message: (find-function-locations): Return a non-empty list of source locations. Date: Tue Dec 2 09:01:16 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.34 slime/swank-sbcl.lisp:1.35 --- slime/swank-sbcl.lisp:1.34 Mon Dec 1 19:56:26 2003 +++ slime/swank-sbcl.lisp Tue Dec 2 09:01:15 2003 @@ -295,13 +295,14 @@ (cond (path (list :source-path path position)) (t (list :function-name fname))))))) -(defmethod function-source-location-for-emacs (fname-string) - "Return the source-location(s) of FNAME's definition(s)." +(defslimefun find-function-locations (fname-string) + "Return a list of source-locations of FNAME's definitions." (let* ((fname (from-string fname-string))) (labels ((finder (fname) (cond ((and (symbolp fname) (macro-function fname)) - (function-source-location (macro-function fname) - fname-string)) + (list + (function-source-location (macro-function fname) + fname-string))) ((typep fname 'sb-mop:generic-function) (list* (function-source-location fname fname-string) @@ -309,7 +310,8 @@ (lambda (x) (function-source-location x fname-string)) (sb-mop:generic-function-methods fname)))) ((functionp fname) - (function-source-location fname fname-string)) + (list + (function-source-location fname fname-string))) ((sb-introspect:valid-function-name-p fname) (finder (fdefinition fname))) ))) (if *debug-definition-finding* @@ -317,12 +319,6 @@ (handler-case (finder fname) (error (e) (list :error (format nil "Error: ~A" e)))))))) - -(defslimefun find-function-locations (name) - (let ((loc (function-source-location-for-emacs name))) - (if (listp loc) - loc - (list loc)))) (defmethod describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. From heller at common-lisp.net Tue Dec 2 14:02:03 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 02 Dec 2003 09:02:03 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11590 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Dec 2 09:02:03 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.131 slime/ChangeLog:1.132 --- slime/ChangeLog:1.131 Mon Dec 1 20:33:14 2003 +++ slime/ChangeLog Tue Dec 2 09:02:03 2003 @@ -1,3 +1,25 @@ +2003-12-02 Helmut Eller + + * swank-sbcl.lisp (find-function-locations): Return a non-empty + list of source locations. + + * slime.el (slime-with-xref-buffer): Remove spurious comma. (Bug + reported by Raymond Wiker). Some reordering of the xref code. + + * swank.lisp (documentation-symbol): New optional argument for + return value if the symbol is not documented. + +2003-12-02 Sean O'Rourke + + * slime.el: (slime-repl-{clear-buffer,clear-output}): clear the + last and entire output in the *slime-repl* buffer + (slime-documentation): pop up a buffer with a symbol's + documentation instead of its description, if found. + (slime-complete-symbol): tweak to completion, taken from ilisp, to + complete filenames inside strings. + (slime-set-default-directory): also set *slime-repl*'s + default-directory, so e.g. find-file makes sense. + 2003-12-02 Daniel Barlow * slime.el (slime-with-xref-buffer): moved further up the file so From lgorrie at common-lisp.net Wed Dec 3 20:47:01 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 03 Dec 2003 15:47:01 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8117 Modified Files: slime.el Log Message: (slime-completing-read-internal): Fix from Sean O'Rourke. Date: Wed Dec 3 15:46:59 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.125 slime/slime.el:1.126 --- slime/slime.el:1.125 Tue Dec 2 08:55:47 2003 +++ slime/slime.el Wed Dec 3 15:46:58 2003 @@ -2565,13 +2565,13 @@ ;; the minibuffer. (ecase flag ((nil) - (let* ((completions (slime-completions string default-package))) + (let* ((completions (car (slime-completions string default-package)))) (try-completion string (slime-bogus-completion-alist completions)))) ((t) - (slime-completions string default-package)) + (car (slime-completions string default-package))) ((lambda) - (member string (slime-completions string default-package))))) + (member string (car (slime-completions string default-package)))))) (defun slime-completing-read-symbol-name (prompt &optional initial-value) "Read the name of a CL symbol, with completion. @@ -2880,7 +2880,7 @@ (when (not symbol-name) (error "No symbol given")) (slime-eval-describe - `(swank:documentation-symbol ,symbol-name "(not documented))"))) + `(swank:documentation-symbol ,symbol-name "(not documented)"))) (defun slime-describe-function (symbol-name) (interactive (list (slime-read-symbol-name "Describe symbol: "))) From lgorrie at common-lisp.net Wed Dec 3 21:00:13 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 03 Dec 2003 16:00:13 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14193 Modified Files: ChangeLog Log Message: Date: Wed Dec 3 16:00:12 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.132 slime/ChangeLog:1.133 --- slime/ChangeLog:1.132 Tue Dec 2 09:02:03 2003 +++ slime/ChangeLog Wed Dec 3 16:00:10 2003 @@ -1,3 +1,8 @@ +2003-12-03 Luke Gorrie + + * slime.el (slime-completing-read-internal): Fix from Sean + O'Rourke. + 2003-12-02 Helmut Eller * swank-sbcl.lisp (find-function-locations): Return a non-empty From heller at common-lisp.net Wed Dec 3 22:30:04 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Dec 2003 17:30:04 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18255 Modified Files: slime.el Log Message: (slime-debugging-state): Initialize the sldb-buffer if (/= sldb-level level). (slime-who-specializes): New command. Date: Wed Dec 3 17:30:04 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.126 slime/slime.el:1.127 --- slime/slime.el:1.126 Wed Dec 3 15:46:58 2003 +++ slime/slime.el Wed Dec 3 17:30:02 2003 @@ -1293,12 +1293,14 @@ Lisp entered the debugger while handling one of our requests. This state interacts with it until it is coaxed into returning." ((activate) - (setq sldb-level level) (let ((sldb-buffer (get-buffer "*sldb*"))) (when (or (not sldb-buffer) - (with-current-buffer sldb-buffer - (/= sldb-level-in-buffer level))) - (sldb-setup condition restarts frames)))) + (/= sldb-level level) + (with-current-buffer sldb-buffer + (/= sldb-level sldb-level-in-buffer))) + (setq sldb-level level) + (sldb-setup condition restarts frames))) + (setq sldb-level level)) ((:debug-return level) (assert (= level sldb-level)) (sldb-cleanup) @@ -3101,6 +3103,11 @@ "Show all known expanders of the macro SYMBOL." (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) (slime-xref 'macroexpands symbol)) + +(defun slime-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (slime-read-symbol-name "Who specializes: " t))) + (slime-xref 'specializes symbol)) (defun slime-xref (type symbol) "Make an XREF request to Lisp." From heller at common-lisp.net Wed Dec 3 22:34:50 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Dec 2003 17:34:50 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20243 Modified Files: swank-cmucl.lisp Log Message: (create-swank-server): Set reuse-address to t by default. (resolve-note-location): Add method for warnings in interpreted code. (who-specializes): New function. (dd-source-location): Handle case without constructors more correctly. (source-path-source-position): Skip ambigous entries in source-map. (source-location-from-code-location): Simplified. Date: Wed Dec 3 17:34:50 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.31 slime/swank-cmucl.lisp:1.32 --- slime/swank-cmucl.lisp:1.31 Mon Dec 1 17:30:03 2003 +++ slime/swank-cmucl.lisp Wed Dec 3 17:34:50 2003 @@ -26,7 +26,8 @@ (address (car (ext:host-entry-addr-list hostent)))) (ext:htonl address))) -(defun create-swank-server (port &key reuse-address (address "localhost")) +(defun create-swank-server (port &key (reuse-address t) + (address "localhost")) "Create a SWANK TCP server." (let* ((ip (resolve-hostname address)) (fd (ext:create-inet-listener port :stream @@ -259,6 +260,11 @@ `(:position ,(+ *buffer-start-position* (source-path-string-position path *buffer-substring*))))) +(defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string)) + (make-location + `(:source-form ,source) + `(:position 1))) + (defmethod resolve-note-location (buffer (file (eql nil)) (pos (eql nil)) @@ -329,9 +335,21 @@ (lookup-xrefs #'xref:who-sets variable)) #+cmu19 -(defslimefun who-macroexpands (macro) - "Return the places where MACRO is expanded." - (lookup-xrefs #'xref:who-macroexpands macro)) +(progn + (defslimefun who-macroexpands (macro) + "Return the places where MACRO is expanded." + (lookup-xrefs #'xref:who-macroexpands macro)) + + (defslimefun who-specializes (class) + "Return the methods with specializers for CLASS." + (let* ((methods (xref::who-specializes (find-class (from-string class)))) + (locations (mapcar #'method-source-location methods))) + (group-xrefs (mapcar (lambda (m l) + (cons (let ((*print-pretty* nil)) + (to-string m)) + l)) + methods locations)))) + ) (defun resolve-xref-location (xref) (let ((name (xref:xref-context-name xref)) @@ -582,13 +600,14 @@ (defun dd-source-location (dd) (let ((constructor (or (kernel:dd-default-constructor dd) - (car (kernel::dd-constructors dd))))) - (cond (constructor - (function-source-location - (coerce (if (consp constructor) (car constructor) constructor) - 'function))) - (t (error "Cannot locate struct without constructor: ~S" - (kernel::dd-name dd)))))) + (car (kernel::dd-constructors dd))))) + (when (or (not constructor) (and (consp constructor) + (not (car constructor)))) + (error "Cannot locate struct without constructor: ~S" + (kernel::dd-name dd))) + (function-source-location + (coerce (if (consp constructor) (car constructor) constructor) + 'function)))) (defun genericp (fn) (typep fn 'generic-function)) @@ -907,7 +926,7 @@ ;; select the first subform present in source-map (loop for form in (reverse forms) for positions = (gethash form source-map) - until positions + until (and positions (null (cdr positions))) finally (destructuring-bind ((start . end)) positions (return (values (1- start) end)))))) @@ -936,16 +955,6 @@ (with-open-file (s filename :direction :input) (code-location-stream-position code-location s))) -(defun make-file-location (pathname code-location) - (make-location - `(:file ,(unix-truename pathname)) - `(:position ,(1+ (code-location-file-position code-location pathname))))) - -(defun make-buffer-location (buffer start string code-location) - (make-location - `(:buffer ,buffer) - `(:position ,(+ start (code-location-string-offset code-location string))))) - (defun debug-source-info-from-emacs-buffer-p (debug-source) (let ((info (c::debug-source-info debug-source))) (and info @@ -961,18 +970,25 @@ (from (di:debug-source-from debug-source)) (name (di:debug-source-name debug-source))) (ecase from - (:file (make-file-location name code-location)) + (:file + (make-location (list :file (unix-truename name)) + (list :position (1+ (code-location-file-position + code-location name))))) (:stream (assert (debug-source-info-from-emacs-buffer-p debug-source)) (let ((info (c::debug-source-info debug-source))) - (make-buffer-location (getf info :emacs-buffer) - (getf info :emacs-buffer-offset) - (getf info :emacs-buffer-string) - code-location))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :position (+ (getf info :emacs-buffer-offset) + (code-location-string-offset + code-location + (getf info :emacs-buffer-string))))))) (:lisp - `(:sexp , (with-output-to-string (*standard-output*) - (debug::print-code-location-source-form - code-location 100 t))))))) + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) (defun code-location-source-location (code-location) "Safe wrapper around `code-location-from-source-location'." From heller at common-lisp.net Wed Dec 3 22:37:36 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Dec 2003 17:37:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20739 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Dec 3 17:37:36 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.133 slime/ChangeLog:1.134 --- slime/ChangeLog:1.133 Wed Dec 3 16:00:10 2003 +++ slime/ChangeLog Wed Dec 3 17:37:34 2003 @@ -1,3 +1,20 @@ +2003-12-03 Helmut Eller + + * slime.el (slime-debugging-state): Initialize the sldb-buffer if + (/= sldb-level level). + (slime-who-specializes): New command. + + * swank-cmucl.lisp (create-swank-server): Set reuse-address to t + by default. + (resolve-note-location): Add method for warnings in interpreted + code. + (who-specializes): New function. + (dd-source-location): Handle case without constructors more + correctly. + (source-path-source-position): Skip ambigous entries in + source-map. + (source-location-from-code-location): Simplified. + 2003-12-03 Luke Gorrie * slime.el (slime-completing-read-internal): Fix from Sean @@ -20,7 +37,7 @@ last and entire output in the *slime-repl* buffer (slime-documentation): pop up a buffer with a symbol's documentation instead of its description, if found. - (slime-complete-symbol): tweak to completion, taken from ilisp, to + (slime-complete-symbol): tweak the completion, taken from ilisp, to complete filenames inside strings. (slime-set-default-directory): also set *slime-repl*'s default-directory, so e.g. find-file makes sense. From heller at common-lisp.net Thu Dec 4 07:38:28 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Dec 2003 02:38:28 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9912 Modified Files: slime.el Log Message: (slime-eval-defun): Use slime-re-evaluate-defvar if the defun starts with "defvar". C-M-x in elisp does this too. (slime-re-evaluate-defvar): Take the form as argument. Date: Thu Dec 4 02:38:28 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.127 slime/slime.el:1.128 --- slime/slime.el:1.127 Wed Dec 3 17:30:02 2003 +++ slime/slime.el Thu Dec 4 02:38:28 2003 @@ -2781,9 +2781,14 @@ (slime-interactive-eval (slime-last-expression))) (defun slime-eval-defun () - "Evaluate the current toplevel form." + "Evaluate the current toplevel form. +Use `slime-re-evaluate-defvar' the current defun starts with '(defvar'" (interactive) - (slime-interactive-eval (slime-defun-at-point))) + (let ((form (slime-defun-at-point))) + (cond ((string-match "^(defvar " form) + (slime-re-evaluate-defvar form)) + (t + (slime-interactive-eval from))(slime-defun-at-point)))) (defun slime-eval-region (start end) "Evalute region." @@ -2799,12 +2804,12 @@ (interactive) (slime-eval-region (point-min) (point-max))) -(defun slime-re-evaluate-defvar () +(defun slime-re-evaluate-defvar (form) "Force the re-evaluaton of the defvar form before point. First make the variable unbound, then evaluate the entire form." - (interactive) - (slime-eval-async `(swank:re-evaluate-defvar ,(slime-last-expression)) + (interactive (list (slime-last-expression))) + (slime-eval-async `(swank:re-evaluate-defvar ,form) (slime-buffer-package) (slime-show-evaluation-result-continuation))) From heller at common-lisp.net Thu Dec 4 07:42:23 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Dec 2003 02:42:23 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11922 Modified Files: swank-lispworks.lisp Log Message: (toggle-trace-fdefinition, tracedp): New support functions for toggle-trace command. Written by Alain Picard. (compile-from-temp-file): Don't delete the binary file if there is none. (lispworks-severity): Map all ERRORs to :error. Date: Thu Dec 4 02:42:23 2003 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.5 slime/swank-lispworks.lisp:1.6 --- slime/swank-lispworks.lisp:1.5 Mon Dec 1 17:30:16 2003 +++ slime/swank-lispworks.lisp Thu Dec 4 02:42:22 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.5 2003/12/01 22:30:16 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.6 2003/12/04 07:42:22 heller Exp $ ;;; (in-package :swank) @@ -262,6 +262,21 @@ (defslimefun find-function-locations (fname) (dspec-source-locations (from-string fname))) +;;; Tracing + +(defun tracedp (symbol) + (member symbol (trace) :test #'eq)) + +(defslimefun toggle-trace-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + ;;(print `(got ,fname-string and ,fname)) + (cond ((tracedp fname) + (compiler::ensure-untrace-1 (list fname)) + (format nil "~S is now untraced." fname)) + (t + (compiler::ensure-trace-1 (list fname)) + (format nil "~S is now traced." fname))))) + ;;; callers (defun stringify-function-name-list (list) @@ -288,7 +303,7 @@ (defun lispworks-severity (condition) (cond ((not condition) :warning) (t (etypecase condition - (simple-error :error) + (error :error) (style-warning :warning) (warning :warning))))) @@ -307,7 +322,8 @@ (write-string string s) (finish-output s)) (let ((binary-filename (compile-file filename :load t))) - (delete-file binary-filename))) + (when binary-filename + (delete-file binary-filename)))) (delete-file filename))) (defun make-dspec-location (dspec location &optional tmpfile buffer position) From heller at common-lisp.net Thu Dec 4 07:43:44 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Dec 2003 02:43:44 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12259 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Dec 4 02:43:43 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.134 slime/ChangeLog:1.135 --- slime/ChangeLog:1.134 Wed Dec 3 17:37:34 2003 +++ slime/ChangeLog Thu Dec 4 02:43:43 2003 @@ -1,3 +1,16 @@ +2003-12-04 Helmut Eller + + * swank-lispworks.lisp (toggle-trace-fdefinition, tracedp): New + support functions for toggle-trace command. Written by Alain + Picard. + (compile-from-temp-file): Don't delete the binary file if there is + none. + (lispworks-severity): Map all ERRORs to :error. + + * slime.el (slime-eval-defun): Use slime-re-evaluate-defvar if the + defun starts with "defvar". C-M-x in elisp does this too. + (slime-re-evaluate-defvar): Take the form as argument. + 2003-12-03 Helmut Eller * slime.el (slime-debugging-state): Initialize the sldb-buffer if From lgorrie at common-lisp.net Thu Dec 4 16:42:53 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 04 Dec 2003 11:42:53 -0500 Subject: [slime-cvs] CVS update: slime/hyperspec.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv742 Modified Files: hyperspec.el Log Message: Updated URL to point to a live copy of the hyperspec at lispworks.com, because the one on xanalys.com has disappeared. Patch from Vincent Arkesteijn on the ilisp-devel mailing list. Date: Thu Dec 4 11:42:53 2003 Author: lgorrie Index: slime/hyperspec.el diff -u slime/hyperspec.el:1.1 slime/hyperspec.el:1.2 --- slime/hyperspec.el:1.1 Mon Sep 22 02:39:18 2003 +++ slime/hyperspec.el Thu Dec 4 11:42:53 2003 @@ -38,7 +38,7 @@ (require 'thingatpt) (defvar common-lisp-hyperspec-root - "http://www.xanalys.com/software_tools/reference/HyperSpec/" + "http://www.lispworks.com/reference/HyperSpec/" "The root of the Common Lisp HyperSpec URL. If you copy the HyperSpec to your local system, set this variable to something like \"file:/usr/local/doc/HyperSpec/\".") @@ -70,9 +70,9 @@ by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is visited to retrieve the information. Xanalys Inc. allows you to transfer the entire Common Lisp HyperSpec to your own site under certain conditions. -Visit http://www.xanalys.com/software_tools/reference/HyperSpec/ for more -information. If you copy the HyperSpec to another location, customize the -variable `common-lisp-hyperspec-root' to point to that location." +Visit http://www.lispworks.com/reference/HyperSpec/ for more information. +If you copy the HyperSpec to another location, customize the variable +`common-lisp-hyperspec-root' to point to that location." (interactive (list (let ((symbol-at-point (thing-at-point 'symbol))) (if (and symbol-at-point (intern-soft (downcase symbol-at-point) From lgorrie at common-lisp.net Thu Dec 4 16:43:16 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 04 Dec 2003 11:43:16 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv918 Modified Files: ChangeLog Log Message: Date: Thu Dec 4 11:43:16 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.135 slime/ChangeLog:1.136 --- slime/ChangeLog:1.135 Thu Dec 4 02:43:43 2003 +++ slime/ChangeLog Thu Dec 4 11:43:16 2003 @@ -1,3 +1,10 @@ +2003-12-04 Luke Gorrie + + * hyperspec.el: Updated URL to point to a live copy of the + hyperspec at lispworks.com, because the one on xanalys.com has + disappeared. Patch from Vincent Arkesteijn on the ilisp-devel + mailing list. + 2003-12-04 Helmut Eller * swank-lispworks.lisp (toggle-trace-fdefinition, tracedp): New From heller at common-lisp.net Thu Dec 4 21:30:35 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Dec 2003 16:30:35 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25970 Modified Files: slime.el Log Message: (slime-debugging-state): Don't set sldb-level after sldb-setup. Breaks the test-suite. (slime-eval-defun): Fix typos. (slime-xref-buffer, slime-goto-next-xref): Updated for the new xref code. (sldb-inspect-in-frame): Query with the sexp at point as initial value. (sldb-step): New command. Bound to s. Date: Thu Dec 4 16:30:35 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.128 slime/slime.el:1.129 --- slime/slime.el:1.128 Thu Dec 4 02:38:28 2003 +++ slime/slime.el Thu Dec 4 16:30:35 2003 @@ -1297,10 +1297,9 @@ (when (or (not sldb-buffer) (/= sldb-level level) (with-current-buffer sldb-buffer - (/= sldb-level sldb-level-in-buffer))) + (/= level sldb-level-in-buffer))) (setq sldb-level level) - (sldb-setup condition restarts frames))) - (setq sldb-level level)) + (sldb-setup condition restarts frames)))) ((:debug-return level) (assert (= level sldb-level)) (sldb-cleanup) @@ -2788,7 +2787,7 @@ (cond ((string-match "^(defvar " form) (slime-re-evaluate-defvar form)) (t - (slime-interactive-eval from))(slime-defun-at-point)))) + (slime-interactive-eval form))))) (defun slime-eval-region (start end) "Evalute region." @@ -3010,13 +3009,12 @@ ;;;; XREF results buffer and window management -(defun slime-xref-buffer (&optional create) +(defun slime-xref-buffer () "Return the XREF results buffer. If CREATE is non-nil, create it if necessary." - (if create - (get-buffer-create "*CMUCL xref*") - (or (get-buffer "*CMUCL xref*") - (error "No XREF buffer")))) + (or (find-if (lambda (b) (string-match "*XREF\\[" (buffer-name b))) + (buffer-list)) + (error "No XREF buffer"))) (defun slime-init-xref-buffer (package ref-type symbol) "Initialize the current buffer for displaying XREF information." @@ -3145,18 +3143,21 @@ (interactive) (let ((location (slime-xref-location-at-point))) (slime-show-source-location location))) - + (defun slime-goto-next-xref () "Goto the next cross-reference location." - (save-selected-window - (slime-display-xref-buffer) - (loop do (goto-char (next-single-char-property-change (point) 'slime-xref)) - until (or (get-text-property (point) 'slime-xref-complete) - (eobp))) - (if (not (eobp)) - (slime-goto-xref) - (forward-line -1) - (message "No more xrefs.")))) + (let ((location (with-current-buffer (slime-xref-buffer) + (display-buffer (current-buffer) t) + (goto-char (next-single-char-property-change + (point) 'slime-location)) + (cond ((eobp) + (message "No more xrefs.") + nil) + (t + (slime-xref-location-at-point)))))) + (when location + (slime-goto-source-location location) + (switch-to-buffer (current-buffer))))) (defvar slime-next-location-function nil "Function to call for going to the next location.") @@ -3488,7 +3489,8 @@ (defun sldb-inspect-in-frame (string) (interactive (list (slime-read-from-minibuffer - "Inspect in frame (evaluated): "))) + "Inspect in frame (evaluated): " + (slime-sexp-at-point)))) (let ((number (sldb-frame-number-at-point))) (slime-eval-async `(swank:inspect-in-frame ,string ,number) (slime-buffer-package) @@ -3588,6 +3590,11 @@ (defun sldb-restart-at-point () (get-text-property (point) 'restart-number)) + +(defun sldb-step () + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-step ,frame) nil (lambda ())))) (slime-define-keys sldb-mode-map ("v" 'sldb-show-source) @@ -3604,6 +3611,7 @@ ("l" 'sldb-list-locals) ("t" 'sldb-toggle-details) ("c" 'sldb-continue) + ("s" 'sldb-step) ("a" 'sldb-abort) ("q" 'sldb-quit) (":" 'slime-interactive-eval)) From heller at common-lisp.net Thu Dec 4 21:33:27 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Dec 2003 16:33:27 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26692 Modified Files: swank-cmucl.lisp Log Message: (format-frame-for-emacs, compute-backtrace, backtrace): Don't send CMUCL's frame numbers to Emacs, use our own numbering. (set-step-breakpoints, sldb-step): Lisp side of sldb-step command. Date: Thu Dec 4 16:33:27 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.32 slime/swank-cmucl.lisp:1.33 --- slime/swank-cmucl.lisp:1.32 Wed Dec 3 17:34:50 2003 +++ slime/swank-cmucl.lisp Thu Dec 4 16:33:27 2003 @@ -1042,10 +1042,9 @@ (nth index *sldb-restarts*)) (defun format-frame-for-emacs (frame) - (list (di:frame-number frame) - (with-output-to-string (*standard-output*) - (let ((*print-pretty* *sldb-pprint-frames*)) - (debug::print-frame-call frame :verbosity 1 :number t))))) + (with-output-to-string (*standard-output*) + (let ((*print-pretty* *sldb-pprint-frames*)) + (debug::print-frame-call frame :verbosity 1 :number t)))) (defun compute-backtrace (start end) "Return a list of frames starting with frame number START and @@ -1055,10 +1054,11 @@ (loop for f = (nth-frame start) then (di:frame-down f) for i from start below end while f - collect f))) + collect (cons i f)))) (defmethod backtrace (start end) - (mapcar #'format-frame-for-emacs (compute-backtrace start end))) + (loop for (n . frame) in (compute-backtrace start end) + collect (list n (format-frame-for-emacs frame)))) (defmethod debugger-info-for-emacs (start end) (list (format-condition-for-emacs) @@ -1104,6 +1104,42 @@ (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + +(defun set-step-breakpoints (frame) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block + (di:frame-code-location frame))) + (error "Cannot step, in elsewhere code~%")) + (let* ((code-location (di:frame-code-location frame)) + (next (debug::next-code-locations code-location))) + (cond (next + (let ((steppoints '())) + (flet ((hook (frame breakpoint) + (let ((debug:*stack-top-hint* frame)) + (mapc #'di:deactivate-breakpoint steppoints) + (break "Breakpoint: ~A" breakpoint)))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (flet ((hook (frame breakpoint values cookie) + (declare (ignore cookie)) + (di:deactivate-breakpoint breakpoint) + (let ((debug:*stack-top-hint* frame)) + (break "Function-end: ~A ~A" breakpoint values)))) + (let* ((debug-function (di:frame-debug-function frame)) + (bp (di:make-breakpoint #'hook debug-function + :kind :function-end))) + (di:activate-breakpoint bp))))))) + +(defslimefun sldb-step (frame) + (cond ((find-restart 'continue *swank-debugger-condition*) + (set-step-breakpoints (nth-frame frame)) + (continue *swank-debugger-condition*)) + (t + (error "Cannot continue in from condition: ~A" + *swank-debugger-condition*)))) ;;;; Inspecting From heller at common-lisp.net Thu Dec 4 21:36:03 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Dec 2003 16:36:03 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28240 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Dec 4 16:36:02 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.136 slime/ChangeLog:1.137 --- slime/ChangeLog:1.136 Thu Dec 4 11:43:16 2003 +++ slime/ChangeLog Thu Dec 4 16:36:02 2003 @@ -1,3 +1,19 @@ +2003-12-04 Helmut Eller + + * slime.el (slime-debugging-state): Don't set sldb-level after + sldb-setup. Breaks the test-suite. + (slime-eval-defun): Fix typos. + (slime-xref-buffer, slime-goto-next-xref): Updated for the new + xref code. + (sldb-inspect-in-frame): Query with the sexp at point as initial + value. + (sldb-step): New command. Bound to s. + + * swank-cmucl.lisp (format-frame-for-emacs, compute-backtrace, + backtrace): Don't send CMUCL's frame numbers to Emacs, use our own + numbering. + (set-step-breakpoints, sldb-step): Lisp side of sldb-step command. + 2003-12-04 Luke Gorrie * hyperspec.el: Updated URL to point to a live copy of the From heller at common-lisp.net Sat Dec 6 08:06:23 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 03:06:23 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3486 Modified Files: slime.el Log Message: slime-eval/compile-defun-dwim: New command. Suggested by "jan". Date: Sat Dec 6 03:06:22 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.129 slime/slime.el:1.130 --- slime/slime.el:1.129 Thu Dec 4 16:30:35 2003 +++ slime/slime.el Sat Dec 6 03:06:22 2003 @@ -2832,6 +2832,28 @@ (princ result buffer) (insert "\n")))))) +(defun slime-eval/compile-defun-dwim (&optional arg) + "Call the computation command you want (Do What I Mean). +Look at defun and determine whether to call `slime-eval-defun' or +`slime-compile-defun'. + +A prefix of `-' forces evaluation, any other prefix forces +compilation." + (interactive "P") + (case arg + ;; prefix is `-', evaluate defun + ((-) (slime-eval-defun)) + ;; no prefix, automatically determine action + ((nil) (let ((form (slime-defun-at-point))) + (cond ((string-match "^(defvar " form) + (slime-re-evaluate-defvar form)) + ((string-match "^(def" form) + (slime-compile-defun)) + (t + (slime-eval-defun))))) + ;; prefix is not `-', compile defun + (otherwise (slime-compile-defun)))) + (defun slime-toggle-trace-fdefinition (fname-string) "Toggle trace for FNAME-STRING." (interactive (list (slime-completing-read-symbol-name From heller at common-lisp.net Sat Dec 6 08:13:14 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 03:13:14 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5637 Modified Files: swank-sbcl.lisp Log Message: (handle-notification-condition): Don't ignore warnings without (compiler-note-location, brief-compiler-message-for-emacs, compiler-note-location): Handle null context. (compile-file-for-emacs): Bind *compile-filename* and load the fasl file only if it exists. (function-source-location): The name argument is now optional a should be a symbol. (find-function-locations): Return errors as a list of one error. (call-with-debugging-environment): Set *print-level* to 4 and *print-level* to 10. (Where both nil.) (source-location-for-emacs): Fall back to the location of the function if there is no block-debug-info. (safe-source-location-for-emacs): Catch error only; not all conditions. *compile-filename*: New variable. Date: Sat Dec 6 03:13:14 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.35 slime/swank-sbcl.lisp:1.36 --- slime/swank-sbcl.lisp:1.35 Tue Dec 2 09:01:15 2003 +++ slime/swank-sbcl.lisp Sat Dec 6 03:13:14 2003 @@ -157,6 +157,7 @@ (defvar *buffername*) (defvar *buffer-offset*) +(defvar *compile-filename*) (defvar *previous-compiler-condition* nil "Used to detect duplicates.") @@ -168,7 +169,7 @@ craft our own error messages, which can omit a lot of redundant information." (let ((context (sb-c::find-error-context nil))) - (when (and context (not (eq condition *previous-compiler-condition*))) + (unless (eq condition *previous-compiler-condition*) (setq *previous-compiler-condition* condition) (signal-compiler-condition condition context)))) @@ -186,29 +187,41 @@ (defun compiler-note-location (context) "Determine from CONTEXT the current compiler source location." - (let* ((file-name (sb-c::compiler-error-context-file-name context)) - (file-pos (sb-c::compiler-error-context-file-position context)) - (source-path (current-compiler-error-source-path context))) + (multiple-value-bind (file-name file-pos source-path) + (if context + (values + (sb-c::compiler-error-context-file-name context) + (sb-c::compiler-error-context-file-position context) + (current-compiler-error-source-path context))) (cond ((and (boundp '*buffername*) *buffername*) ;; account for the added lambda, replace leading ;; position with 0 (make-location (list :buffer *buffername*) (list :source-path (cons 0 (cddr source-path)) *buffer-offset*))) - (t + (file-name (etypecase file-name (pathname (make-location (list :file (namestring (truename file-name))) - (list :source-path source-path file-pos)))))))) + (list :source-path source-path file-pos))))) + ((or *compile-file-truename* *compile-filename*) + (make-location + (list :file (namestring (or *compile-file-truename* + *compile-filename*))) + (list :source-path '(0) 1))) + (t + (list :error "No source location"))))) (defun brief-compiler-message-for-emacs (condition error-context) "Briefly describe a compiler error for Emacs. When Emacs presents the message it already has the source popped up and the source form highlighted. This makes much of the information in the error-context redundant." - (declare (type sb-c::compiler-error-context error-context)) - (let ((enclosing (sb-c::compiler-error-context-enclosing-source error-context))) + (declare (type (or sb-c::compiler-error-context error-context null))) + (let ((enclosing + (and error-context + (sb-c::compiler-error-context-enclosing-source error-context)))) (if enclosing (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition) (format nil "~A" condition)))) @@ -236,8 +249,11 @@ (with-compilation-hooks () (let* ((*buffername* nil) (*buffer-offset* nil) - (ret (compile-file filename))) - (if load-p (load ret) ret)))) + (*compile-filename* filename) + (fasl-file (compile-file filename))) + (cond ((and fasl-file load-p) + (load fasl-file)) + (t fasl-file))))) (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () @@ -273,7 +289,7 @@ ;;; FIXME we don't handle the compiled-interactively case yet. That ;;; should have NIL :filename & :position, and non-NIL :source-form -(defun function-source-location (function fname) +(defun function-source-location (function &optional name) "Try to find the canonical source location of FUNCTION." (let* ((def (sb-introspect:find-definition-source function)) (pathname (sb-introspect:definition-source-pathname def)) @@ -281,7 +297,7 @@ (position (sb-introspect:definition-source-character-offset def))) (unless pathname (return-from function-source-location - (list :error (format nil "No filename for: ~S" fname)))) + (list :error (format nil "No filename for: ~S" function)))) (multiple-value-bind (truename condition) (ignore-errors (truename pathname)) (when condition @@ -293,32 +309,36 @@ ;; lotsa debugging. If not present, return the function name ;; for emacs to attempt to find with a regex (cond (path (list :source-path path position)) - (t (list :function-name fname))))))) + (t (list :function-name + (or (and name (string name)) + (sb-kernel:%fun-name function))))))))) (defslimefun find-function-locations (fname-string) "Return a list of source-locations of FNAME's definitions." - (let* ((fname (from-string fname-string))) - (labels ((finder (fname) - (cond ((and (symbolp fname) (macro-function fname)) + (let* ((symbol (from-string fname-string))) + (labels ((finder (fun) + (cond ((and (symbolp fun) (macro-function fun)) (list - (function-source-location (macro-function fname) - fname-string))) - ((typep fname 'sb-mop:generic-function) + (function-source-location (macro-function fun) + symbol))) + ((typep fun 'sb-mop:generic-function) (list* - (function-source-location fname fname-string) + (function-source-location fun symbol) (mapcar - (lambda (x) (function-source-location x fname-string)) - (sb-mop:generic-function-methods fname)))) - ((functionp fname) + (lambda (x) (function-source-location x symbol)) + (sb-mop:generic-function-methods fun)))) + ((functionp fun) (list - (function-source-location fname fname-string))) - ((sb-introspect:valid-function-name-p fname) - (finder (fdefinition fname))) ))) + (function-source-location fun symbol))) + ((sb-introspect:valid-function-name-p fun) + (finder (fdefinition fun))) + (t (list + (list :error "Not a function: ~A" fun)))))) (if *debug-definition-finding* - (finder fname) - (handler-case (finder fname) + (finder symbol) + (handler-case (finder symbol) (error (e) - (list :error (format nil "Error: ~A" e)))))))) + (list (list :error (format nil "Error: ~A" e))))))))) (defmethod describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. @@ -393,8 +413,8 @@ (sb-debug:*stack-top-hint* nil) (*debugger-hook* nil) (*readtable* (or sb-debug:*debug-readtable* *readtable*)) - (*print-level* nil #+nil sb-debug:*debug-print-level*) - (*print-length* nil #+nil sb-debug:*debug-print-length*) + (*print-level* 4 #+nil sb-debug:*debug-print-level*) + (*print-length* 10 #+nil sb-debug:*debug-print-length*) (*print-readably* nil)) (handler-bind ((sb-di:debug-condition (lambda (condition) @@ -485,12 +505,23 @@ (name (sb-di:debug-source-name debug-source))) (ecase from (:file - ;; XXX: code-location-source-path reads the source !! - (let ((source-path (code-location-source-path code-location)) - (position (code-location-file-position code-location))) - (make-location - (list :file (namestring (truename name))) - (list :source-path source-path position)))) + (let ((source-path (ignore-errors + (code-location-source-path code-location)))) + (cond (source-path + ;; XXX: code-location-source-path reads the source !! + (let ((position (code-location-file-position code-location))) + (make-location + (list :file (namestring (truename name))) + (list :source-path source-path position)))) + (t + (let* ((dfn (sb-di:code-location-debug-fun code-location)) + (fn (sb-di:debug-fun-fun dfn))) + (unless fn + (error "Cannot find source location for: ~A " + code-location)) + (function-source-location + fn (sb-di:debug-fun-name dfn))))))) + (:lisp (make-location (list :source-form (with-output-to-string (*standard-output*) @@ -500,8 +531,8 @@ (defun safe-source-location-for-emacs (code-location) (handler-case (source-location-for-emacs code-location) - (t (c) (list :error (format nil "~A" c))))) - + (error (c) (list :error (format nil "~A" c))))) + (defmethod frame-source-location-for-emacs (index) (safe-source-location-for-emacs (sb-di:frame-code-location (nth-frame index)))) From heller at common-lisp.net Sat Dec 6 08:16:14 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 03:16:14 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7208 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Dec 6 03:16:14 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.137 slime/ChangeLog:1.138 --- slime/ChangeLog:1.137 Thu Dec 4 16:36:02 2003 +++ slime/ChangeLog Sat Dec 6 03:16:14 2003 @@ -1,3 +1,25 @@ +2003-12-06 Helmut Eller + + * swank-sbcl.lisp (handle-notification-condition): Don't ignore + warnings without context. + (compiler-note-location, brief-compiler-message-for-emacs, + compiler-note-location): Handle null context. + (compile-file-for-emacs): Bind *compile-filename* and load the + fasl file only if it exists. + (function-source-location): The name argument is now optional and + should be a symbol. + (find-function-locations): Return errors as a list of one error. + (call-with-debugging-environment): Set *print-level* to 4 and + *print-level* to 10. (Where both nil.) + (source-location-for-emacs): Fall back to the location of the + function, if there is no block-debug-info. + (safe-source-location-for-emacs): Don't catch all conditions; only + errors. + *compile-filename*: New variable + + * slime.el (slime-eval/compile-defun-dwim): New command. + Suggested by "jan" . + 2003-12-04 Helmut Eller * slime.el (slime-debugging-state): Don't set sldb-level after From heller at common-lisp.net Sat Dec 6 08:42:55 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 03:42:55 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16262 Modified Files: swank-sbcl.lisp Log Message: (open-listener): Don't make the socket non-blocking. Date: Sat Dec 6 03:42:54 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.36 slime/swank-sbcl.lisp:1.37 --- slime/swank-sbcl.lisp:1.36 Sat Dec 6 03:13:14 2003 +++ slime/swank-sbcl.lisp Sat Dec 6 03:42:54 2003 @@ -67,7 +67,7 @@ :protocol :tcp))) (when reuse-address (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) - (setf (sb-bsd-sockets:non-blocking-mode socket) t) + ;;(setf (sb-bsd-sockets:non-blocking-mode socket) t) (sb-bsd-sockets:socket-bind socket #(127 0 0 1) port) (sb-bsd-sockets:socket-listen socket 5) socket)) From heller at common-lisp.net Sat Dec 6 08:43:20 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 03:43:20 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16435 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Dec 6 03:43:20 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.138 slime/ChangeLog:1.139 --- slime/ChangeLog:1.138 Sat Dec 6 03:16:14 2003 +++ slime/ChangeLog Sat Dec 6 03:43:20 2003 @@ -10,6 +10,8 @@ should be a symbol. (find-function-locations): Return errors as a list of one error. (call-with-debugging-environment): Set *print-level* to 4 and + (open-listener): Don't make the socket non-blocking. + *print-level* to 10. (Where both nil.) (source-location-for-emacs): Fall back to the location of the function, if there is no block-debug-info. From heller at common-lisp.net Sat Dec 6 13:08:52 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 08:08:52 -0500 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18040 Modified Files: swank-loader.lisp Log Message: (user-init-file): Translate logical (user-homedir-) pathnames. Reported by Friedrich Dominicus. Date: Sat Dec 6 08:08:52 2003 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.6 slime/swank-loader.lisp:1.7 --- slime/swank-loader.lisp:1.6 Wed Nov 26 19:38:08 2003 +++ slime/swank-loader.lisp Sat Dec 6 08:08:52 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.6 2003/11/27 00:38:08 heller Exp $ +;;; $Id: swank-loader.lisp,v 1.7 2003/12/06 13:08:52 heller Exp $ ;;; (defpackage :swank-loader @@ -31,6 +31,7 @@ #+sbcl '("swank-sbcl" "swank-gray") #+openmcl '("swank-openmcl" "swank-gray") #+lispworks '("swank-lispworks" "swank-gray") + #+allegro '("swank-allegro" "swank-gray") )) (defparameter *swank-pathname* (make-swank-pathname "swank")) @@ -64,7 +65,8 @@ (defun user-init-file () "Return the name of the user init file or nil." (let ((filename (format nil "~A/.swank.lisp" - (namestring (user-homedir-pathname))))) + (namestring (translate-logical-pathname + (user-homedir-pathname)))))) (cond ((probe-file filename) filename) (t nil)))) From heller at common-lisp.net Sat Dec 6 13:10:30 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 08:10:30 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19540 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Dec 6 08:10:29 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.139 slime/ChangeLog:1.140 --- slime/ChangeLog:1.139 Sat Dec 6 03:43:20 2003 +++ slime/ChangeLog Sat Dec 6 08:10:29 2003 @@ -1,5 +1,8 @@ 2003-12-06 Helmut Eller + * swank-loader.lisp (user-init-file): Translate logical + pathnames. Reported by Friedrich Dominicus. + * swank-sbcl.lisp (handle-notification-condition): Don't ignore warnings without context. (compiler-note-location, brief-compiler-message-for-emacs, @@ -10,14 +13,13 @@ should be a symbol. (find-function-locations): Return errors as a list of one error. (call-with-debugging-environment): Set *print-level* to 4 and - (open-listener): Don't make the socket non-blocking. - *print-level* to 10. (Where both nil.) (source-location-for-emacs): Fall back to the location of the function, if there is no block-debug-info. (safe-source-location-for-emacs): Don't catch all conditions; only errors. *compile-filename*: New variable + (open-listener): Don't make the socket non-blocking. * slime.el (slime-eval/compile-defun-dwim): New command. Suggested by "jan" . From heller at common-lisp.net Sat Dec 6 13:13:57 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 08:13:57 -0500 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19866 Added Files: swank-allegro.lisp Log Message: New file. Date: Sat Dec 6 08:13:57 2003 Author: heller From heller at common-lisp.net Sat Dec 6 13:14:36 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 06 Dec 2003 08:14:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20844 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Dec 6 08:14:36 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.140 slime/ChangeLog:1.141 --- slime/ChangeLog:1.140 Sat Dec 6 08:10:29 2003 +++ slime/ChangeLog Sat Dec 6 08:14:36 2003 @@ -1,5 +1,7 @@ 2003-12-06 Helmut Eller + * swank-allegro.lisp: New file. + * swank-loader.lisp (user-init-file): Translate logical pathnames. Reported by Friedrich Dominicus. From lgorrie at common-lisp.net Sat Dec 6 21:41:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 06 Dec 2003 16:41:11 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9907 Modified Files: slime.el Log Message: (slime-easy-menu): Added menubar support, contributed by Friedrich Dominicus. Date: Sat Dec 6 16:41:11 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.130 slime/slime.el:1.131 --- slime/slime.el:1.130 Sat Dec 6 03:06:22 2003 +++ slime/slime.el Sat Dec 6 16:41:11 2003 @@ -64,6 +64,7 @@ (unless (fboundp 'define-minor-mode) (require 'easy-mmode) (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))) +(require 'easymenu) (defvar slime-path (let ((path (locate-library "slime"))) @@ -413,6 +414,61 @@ [(meta control ?m)] 'inferior-slime-closing-return)) (slime-init-keymaps) + + +;;;; Pull-down menu + +(defvar slime-easy-menu + (let ((C '(slime-connected-p))) + `("SLIME" + [ "Edit Definition..." slime-edit-fdefinition ,C ] + [ "Return From Definition" slime-pop-find-definition-stack ,C ] + [ "Complete Symbol" slime-complete-symbol ,C ] + "--" + ("Evaluation" + [ "Eval Defun" slime-eval-defun ,C ] + [ "Eval Last Expression" slime-eval-last-expression ,C ] + [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] + [ "Interactive Eval" slime-interactive-eval ,C ]) + ("Debugging" + [ "Macroexpand Once..." slime-macroexpand-1 ,C ] + [ "Macroexpand All..." slime-macroexpand-all ,C ] + [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] + [ "Disassemble..." slime-disassemble-symbol ,C ] + [ "Inspect..." slime-inspect ,C ]) + ("Compilation" + [ "Compile Defun" slime-compile-defun ,C ] + [ "Compile/Load File" slime-compile-and-load-file ,C ] + [ "Compile File" slime-compile-file ,C ] + "--" + [ "Next Note" slime-next-note t ] + [ "Previous Note" slime-previous-note t ] + [ "Remove Notes" slime-remove-notes t ]) + ("Cross Reference" + [ "Who Calls..." slime-who-calls ,C ] + [ "Who References... " slime-who-references ,C ] + [ "Who Sets..." slime-who-sets ,C ] + [ "Who Binds..." slime-who-binds ,C ] + [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "List Callers..." slime-list-callers ,C ] + [ "List Callees..." slime-list-callees ,C ] + [ "Next Location" slime-next-location t ]) + ("Documentation" + [ "Describe Symbol..." slime-describe-symbol ,C ] + [ "Apropos..." slime-apropos ,C ] + [ "Hyperspec..." hyperspec-lookup t ]) + "--" + [ "Interrupt Command" slime-interrupt ,C ] + [ "Abort Async. Command" slime-quit ,C ] + [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C ] + ))) + +(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu) + +(defun slime-add-easy-menu () + (easy-menu-add slime-easy-menu 'slime-mode-map)) + +(add-hook 'slime-mode-hook 'slime-add-easy-menu) ;;; Setup initial `slime-mode' hooks From lgorrie at common-lisp.net Sat Dec 6 21:41:40 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 06 Dec 2003 16:41:40 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9969 Modified Files: ChangeLog Log Message: Date: Sat Dec 6 16:41:40 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.141 slime/ChangeLog:1.142 --- slime/ChangeLog:1.141 Sat Dec 6 08:14:36 2003 +++ slime/ChangeLog Sat Dec 6 16:41:40 2003 @@ -1,3 +1,8 @@ +2003-12-06 Luke Gorrie + + * slime.el (slime-easy-menu): Added menubar support, contributed + by Friedrich Dominicus. + 2003-12-06 Helmut Eller * swank-allegro.lisp: New file. From heller at common-lisp.net Sun Dec 7 19:13:43 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 07 Dec 2003 14:13:43 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29557 Modified Files: slime.el Log Message: (slime-interactive-eval): Insert the result at point, if called with prefix argument. Date: Sun Dec 7 14:13:43 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.131 slime/slime.el:1.132 --- slime/slime.el:1.131 Sat Dec 6 16:41:11 2003 +++ slime/slime.el Sun Dec 7 14:13:42 2003 @@ -450,6 +450,7 @@ [ "Who Sets..." slime-who-sets ,C ] [ "Who Binds..." slime-who-binds ,C ] [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "Who Specializes..." slime-who-specializes ,C ] [ "List Callers..." slime-list-callers ,C ] [ "List Callees..." slime-list-callees ,C ] [ "Next Location" slime-next-location t ]) @@ -460,7 +461,7 @@ "--" [ "Interrupt Command" slime-interrupt ,C ] [ "Abort Async. Command" slime-quit ,C ] - [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C ] + [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C] ))) (easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu) @@ -2797,7 +2798,9 @@ (slime-eval-async `(swank:interactive-eval ,string) (slime-buffer-package t) - (slime-show-evaluation-result-continuation))) + (if current-prefix-arg + (slime-insert-evaluation-result-continuation) + (slime-show-evaluation-result-continuation)))) (defun slime-display-buffer-region (buffer start end &optional other-window) "Like `display-buffer', but only display the specified region." @@ -2825,6 +2828,12 @@ (lambda (value) (with-current-buffer buffer (slime-show-evaluation-result value))))) + +(defun slime-insert-evaluation-result-continuation () + (lexical-let ((buffer (current-buffer))) + (lambda (value) + (with-current-buffer buffer + (insert value))))) (defun slime-last-expression () (buffer-substring-no-properties (save-excursion (backward-sexp) (point)) From heller at common-lisp.net Sun Dec 7 19:16:24 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 07 Dec 2003 14:16:24 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-lispworks.lisp slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30642 Modified Files: swank-backend.lisp swank-cmucl.lisp swank-sbcl.lisp swank-openmcl.lisp swank-lispworks.lisp swank-allegro.lisp Log Message: (function-source-locations): Is replaces function-source-location-for-emacs. Make it at generic function. (function-source-location-for-emacs): Remove. Date: Sun Dec 7 14:16:24 2003 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.6 slime/swank-backend.lisp:1.7 --- slime/swank-backend.lisp:1.6 Sat Nov 29 17:12:42 2003 +++ slime/swank-backend.lisp Sun Dec 7 14:16:24 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.6 2003/11/29 22:12:42 dbarlow Exp $ +;;; $Id: swank-backend.lisp,v 1.7 2003/12/07 19:16:24 heller Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -58,7 +58,7 @@ #:swank-macroexpand-1 #:untrace-all #:toggle-trace-fdefinition - #:function-source-location-for-emacs + #:find-function-locations #:who-binds #:who-references #:who-calls @@ -281,9 +281,43 @@ ;;;; Queries -(defgeneric function-source-location-for-emacs (function-name) +#+(or) +;;; This is probably a better interface than find-function-locations. +(defgeneric find-definitions (name) (:documentation - "Return the canonical source location FUNCTION-NAME. + "Return a list of (LABEL . LOCATION) pairs for NAME's definitions. -FIXME: Document the plethora of valid return types.")) +NAME is string denoting a symbol or \"definition specifier\". + +LABEL is a string describing the definition, e.g., \"foo\" or +\"(method foo (string number))\" or \"(variable bar)\". + +LOCATION is a source location of the form: + + ::= (:location ) + | (:error ) + + ::= (:file ) + | (:buffer ) + | (:source-form ) + + ::= (:position []) ; 1 based + | (:function-name ) +")) + +(defgeneric find-function-locations (name) + (:documentation + "Return a list (LOCATION LOCATION ...) for NAME's definitions. + +LOCATION is a source location of the form: + + ::= (:location ) + | (:error ) + + ::= (:file ) + | (:buffer ) + | (:source-form ) + + ::= (:position []) ; 1 based + | (:function-name )")) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.33 slime/swank-cmucl.lisp:1.34 --- slime/swank-cmucl.lisp:1.33 Thu Dec 4 16:33:27 2003 +++ slime/swank-cmucl.lisp Sun Dec 7 14:16:24 2003 @@ -670,7 +670,7 @@ (destructuring-bind (first) (function-source-locations function) first)) -(defslimefun find-function-locations (symbol-name) +(defmethod find-function-locations (symbol-name) "Return a list of source-locations for SYMBOL-NAME's functions." (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name) (cond ((not foundp) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.37 slime/swank-sbcl.lisp:1.38 --- slime/swank-sbcl.lisp:1.37 Sat Dec 6 03:42:54 2003 +++ slime/swank-sbcl.lisp Sun Dec 7 14:16:24 2003 @@ -313,8 +313,7 @@ (or (and name (string name)) (sb-kernel:%fun-name function))))))))) -(defslimefun find-function-locations (fname-string) - "Return a list of source-locations of FNAME's definitions." +(defmethod find-function-locations (fname-string) (let* ((symbol (from-string fname-string))) (labels ((finder (fun) (cond ((and (symbolp fun) (macro-function fun)) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.27 slime/swank-openmcl.lisp:1.28 --- slime/swank-openmcl.lisp:1.27 Mon Dec 1 17:30:26 2003 +++ slime/swank-openmcl.lisp Sun Dec 7 14:16:24 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.27 2003/12/01 22:30:26 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.28 2003/12/07 19:16:24 heller Exp $ ;;; ;;; @@ -412,13 +412,7 @@ (defslimefun-unimplemented find-fdefinition (symbol-name package-name)) -(defslimefun function-source-location-for-emacs (fname) - "Return a source position of the definition of FNAME. The -precise location of the definition is not available, but we are -able to return the file name in which the definition occurs." - (function-source-location (from-string fname))) - -(defslimefun find-function-locations (fname) +(defmethod find-function-locations (fname) (let* ((symbol (from-string fname)) (symbol-name (string symbol)) (info (ccl::source-file-or-files symbol nil nil nil)) Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.6 slime/swank-lispworks.lisp:1.7 --- slime/swank-lispworks.lisp:1.6 Thu Dec 4 02:42:22 2003 +++ slime/swank-lispworks.lisp Sun Dec 7 14:16:24 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.6 2003/12/04 07:42:22 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.7 2003/12/07 19:16:24 heller Exp $ ;;; (in-package :swank) @@ -253,13 +253,7 @@ (loop for (dspec location) in locations collect (make-dspec-location dspec location)))))) -(defmethod function-source-location-for-emacs (fname) - "Return a source position of the definition of FNAME. The -precise location of the definition is not available, but we are -able to return the file name in which the definition occurs." - (dspec-source-location (from-string fname))) - -(defslimefun find-function-locations (fname) +(defmethod find-function-locations (fname) (dspec-source-locations (from-string fname))) ;;; Tracing @@ -269,7 +263,6 @@ (defslimefun toggle-trace-fdefinition (fname-string) (let ((fname (from-string fname-string))) - ;;(print `(got ,fname-string and ,fname)) (cond ((tracedp fname) (compiler::ensure-untrace-1 (list fname)) (format nil "~S is now untraced." fname)) Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.1 slime/swank-allegro.lisp:1.2 --- slime/swank-allegro.lisp:1.1 Sat Dec 6 08:13:57 2003 +++ slime/swank-allegro.lisp Sun Dec 7 14:16:24 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.1 2003/12/06 13:13:57 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.2 2003/12/07 19:16:24 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -173,8 +173,7 @@ (nth index *sldb-restarts*)) (defslimefun invoke-nth-restart (index) - (let ((restart (nth-restart index))) - (invoke-restart restart))) + (invoke-restart-interactively (nth-restart index))) (defmethod frame-locals (index) (let ((frame (nth-frame index))) @@ -254,7 +253,7 @@ ))) locations))) -(defslimefun find-function-locations (symbol-name) +(defmethod find-function-locations (symbol-name) (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name) (cond ((not foundp) (list (list :error (format nil "Unkown symbol: ~A" symbol-name)))) From heller at common-lisp.net Sun Dec 7 19:23:02 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 07 Dec 2003 14:23:02 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv568 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Dec 7 14:23:02 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.142 slime/ChangeLog:1.143 --- slime/ChangeLog:1.142 Sat Dec 6 16:41:40 2003 +++ slime/ChangeLog Sun Dec 7 14:23:02 2003 @@ -1,3 +1,14 @@ +2003-12-07 Helmut Eller + + * swank-allegro.lisp, swank-backend.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp + (function-source-locations): Make it at generic function. + (function-source-location-for-emacs): Removed. Fixes bug reported + by Marco Baringer. + + * slime.el (slime-interactive-eval): Insert the result at point, + if called with prefix argument. + 2003-12-06 Luke Gorrie * slime.el (slime-easy-menu): Added menubar support, contributed @@ -20,9 +31,9 @@ should be a symbol. (find-function-locations): Return errors as a list of one error. (call-with-debugging-environment): Set *print-level* to 4 and - *print-level* to 10. (Where both nil.) + *print-length* to 10. (Both where nil.) (source-location-for-emacs): Fall back to the location of the - function, if there is no block-debug-info. + function, if there is no debug-block-info. (safe-source-location-for-emacs): Don't catch all conditions; only errors. *compile-filename*: New variable From lgorrie at common-lisp.net Sun Dec 7 23:42:40 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 07 Dec 2003 18:42:40 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2258 Modified Files: swank.lisp Log Message: (compound-prefix-match): New name and rewritten for speed. Completion is much faster now. (*sldb-initial-frames*): Send up to this many (default 20) backtrace frames to Emacs when entering the debugger. Date: Sun Dec 7 18:42:40 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.75 slime/swank.lisp:1.76 --- slime/swank.lisp:1.75 Tue Dec 2 08:56:27 2003 +++ slime/swank.lisp Sun Dec 7 18:42:40 2003 @@ -254,6 +254,9 @@ (defvar *sldb-level* 0 "The current level of recursive debugging.") +(defvar *sldb-initial-frames* 20 + "The initial number of backtrace frames to send to Emacs.") + (defun swank-debugger-hook (condition hook) "Debugger entry point, called from *DEBUGGER-HOOK*. Sends a message to Emacs declaring that the debugger has been entered, @@ -288,7 +291,8 @@ #'slime-debug))) (defun sldb-loop (level) - (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) + (send-to-emacs (list* :debug *sldb-level* + (debugger-info-for-emacs 0 *sldb-initial-frames*))) (unwind-protect (loop (catch 'sldb-loop-catcher (with-simple-restart @@ -526,7 +530,7 @@ (find-package (case-convert n)) *buffer-package* )))) (flet ((symbol-matches-p (symbol) - (and (compound-string-match name (symbol-name symbol)) + (and (compound-prefix-match name (symbol-name symbol)) (or (or internal-p (null package-name)) (symbol-external-p symbol package))))) (when package @@ -570,40 +574,24 @@ ;;;;; Subword-word matching -(defun subword-prefix-p (s1 s2 &key (start1 0) end1 (start2 0)) - "Return true if the subsequence in S1 bounded by START1 and END1 -is found in S2 at START2." - (let ((end2 (min (length s2) - (+ start2 (- (or end1 (length s1)) - start1))))) - (string-equal s1 s2 - :start1 start1 :end1 end1 - :start2 start2 :end2 end2))) - -(defun word-points (string) - (declare (string string)) - (loop for pos = -1 then (position #\- string :start (1+ pos)) - while pos - collect (1+ pos))) - -(defun compound-string-match (string1 string2) - "Return true if STRING1 is a prefix of STRING2, or if STRING1 -represents a pattern of prefixes and delimiters matching full strings -and delimiters in STRING2. +(defun compound-prefix-match (prefix target) + "Return true if PREFIX is a compound-prefix of TARGET. +Viewing each of PREFIX and TARGET as a series of substrings delimited +by hyphens, if each substring of PREFIX is a prefix of the +corresponding substring in TARGET then we call PREFIX a +compound-prefix of TARGET. + Examples: -\(compound-string-match \"foo\" \"foobar\") => t -\(compound-string-match \"m-v-b\" \"multiple-value-bind\") => t -\(compound-string-match \"m-v-c\" \"multiple-value-bind\") => NIL" - (when (<= (length string1) (length string2)) - (let ((s1-word-points (word-points string1)) - (s2-word-points (word-points string2))) - (when (<= (length s1-word-points) (length s2-word-points)) - (loop for (start1 end1) on s1-word-points - for start2 in s2-word-points - always (subword-prefix-p string1 string2 - :start1 start1 - :end1 (and end1 (1- end1)) - :start2 start2)))))) +\(compound-prefix-match \"foo\" \"foobar\") => t +\(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t +\(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL" + (loop for ch across prefix + with tpos = 0 + always (and (< tpos (length target)) + (if (char= ch #\-) + (setf tpos (position #\- target :start tpos)) + (char-equal ch (aref target tpos)))) + do (incf tpos))) ;;;;; Extending the input string by completion From lgorrie at common-lisp.net Sun Dec 7 23:43:31 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 07 Dec 2003 18:43:31 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2546 Modified Files: slime.el Log Message: (slime-read-from-minibuffer): Now the only completing-read function, stale ones deleted. (sldb-prune-initial-frames): Use regexp-heuristics and the '--more--' token to avoid showing the user Swank-internal backtrace frames initially. (slime-repl-current-input): Don't include the final newline character, to make backtraces prettier. (slime-autodoc): Fixed annoying case where autodocs would be fetched in a loop for undocumented symbols. Date: Sun Dec 7 18:43:31 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.132 slime/slime.el:1.133 --- slime/slime.el:1.132 Sun Dec 7 14:13:42 2003 +++ slime/slime.el Sun Dec 7 18:43:31 2003 @@ -697,8 +697,7 @@ The user is prompted if a prefix argument is in effect, if there is no symbol at point, or if QUERY is non-nil." (cond ((or current-prefix-arg query (not (slime-symbol-name-at-point))) - (slime-completing-read-symbol-name - prompt (slime-symbol-name-at-point))) + (slime-read-from-minibuffer prompt (slime-symbol-name-at-point))) (t (slime-symbol-name-at-point)))) (defun slime-read-symbol (prompt) @@ -1640,7 +1639,12 @@ "Return the current input as string. The input is the region from after the last prompt to the end of buffer." (buffer-substring-no-properties slime-repl-input-start-mark - slime-repl-input-end-mark)) + (save-excursion + (goto-char slime-repl-input-end-mark) + (when (eq (char-before) ?\n) + (backward-char 1)) + (point)))) + (defun slime-repl-add-to-input-history (string) (when (and (plusp (length string)) @@ -2405,10 +2409,11 @@ (with-lexical-bindings (cache-key name) (lambda (arglist) ;; FIXME: better detection of "no documentation available" - (unless (string-match "" arglist) - (setq arglist (slime-format-arglist name arglist)) - (slime-update-autodoc-cache cache-key arglist) - (slime-background-message arglist))))))))) + (if (string-match "" arglist) + (setq arglist "") + (setq arglist (slime-format-arglist name arglist))) + (slime-update-autodoc-cache cache-key arglist) + (slime-background-message arglist)))))))) (defun slime-get-cached-autodoc (symbol-name) "Return the cached autodoc documentation for SYMBOL-NAME, or nil." @@ -2617,29 +2622,6 @@ (minibuffer-message text)) (message "%s" text)))) -(defun slime-completing-read-internal (string default-package flag) - ;; We misuse the predicate argument to pass the default-package. - ;; That's needed because slime-completing-read-internal is called in - ;; the minibuffer. - (ecase flag - ((nil) - (let* ((completions (car (slime-completions string default-package)))) - (try-completion string - (slime-bogus-completion-alist completions)))) - ((t) - (car (slime-completions string default-package))) - ((lambda) - (member string (car (slime-completions string default-package)))))) - -(defun slime-completing-read-symbol-name (prompt &optional initial-value) - "Read the name of a CL symbol, with completion. -The \"name\" may include a package prefix." - (completing-read prompt - 'slime-completing-read-internal - (slime-buffer-package) - nil - initial-value)) - (defvar slime-read-expression-map (make-sparse-keymap) "Minibuffer keymap used for reading CL expressions.") @@ -2921,7 +2903,7 @@ (defun slime-toggle-trace-fdefinition (fname-string) "Toggle trace for FNAME-STRING." - (interactive (list (slime-completing-read-symbol-name + (interactive (list (slime-read-from-minibuffer "(Un)trace: " (slime-symbol-name-at-point)))) (message "%s" (slime-eval `(swank:toggle-trace-fdefinition ,fname-string) (slime-buffer-package t)))) @@ -3385,7 +3367,7 @@ (insert "\n"))) (insert "\nBacktrace:\n") (setq sldb-backtrace-start-marker (point-marker)) - (sldb-insert-frames frames 1) + (sldb-insert-frames (sldb-prune-initial-frames frames) nil) (setq buffer-read-only t) (pop-to-buffer (current-buffer)) (run-hooks 'sldb-hook))) @@ -3403,14 +3385,24 @@ (setq sldb-level-in-buffer sldb-level) (setq mode-name (format "sldb[%d]" sldb-level))) +(defun sldb-prune-initial-frames (frames) + "Return the prefix of FRAMES to initially present to the user. +Regexp heuristics are used to avoid showing SWANK-internal frames." + (or (loop for frame in frames + for (number string) = frame + until (string-match "[^(]*(\\(SWANK\\|swank\\):" string) + collect frame) + frames)) + (defun sldb-insert-frames (frames maximum-length) - (assert (<= (length frames) maximum-length)) + (when maximum-length + (assert (<= (length frames) maximum-length))) (save-excursion (loop for frame in frames for (number string) = frame do (slime-insert-propertized `(frame ,frame) string "\n")) (let ((number (sldb-previous-frame-number))) - (cond ((< (length frames) maximum-length)) + (cond ((and maximum-length (< (length frames) maximum-length))) (t (slime-insert-propertized `(sldb-default-action @@ -3811,6 +3803,7 @@ (slime-define-keys slime-inspector-mode-map ([return] 'slime-inspector-inspect-object-at-point) + ("\C-m" 'slime-inspector-inspect-object-at-point) ("l" 'slime-inspector-pop) ("n" 'slime-inspector-next) ("d" 'slime-inspector-describe) From lgorrie at common-lisp.net Sun Dec 7 23:43:53 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 07 Dec 2003 18:43:53 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2674 Modified Files: ChangeLog Log Message: Date: Sun Dec 7 18:43:53 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.143 slime/ChangeLog:1.144 --- slime/ChangeLog:1.143 Sun Dec 7 14:23:02 2003 +++ slime/ChangeLog Sun Dec 7 18:43:53 2003 @@ -1,3 +1,23 @@ +2003-12-08 Luke Gorrie + + * slime.el (slime-read-from-minibuffer): Now the only + completing-read function, stale ones deleted. + +2003-12-07 Luke Gorrie + + * slime.el (sldb-prune-initial-frames): Use regexp-heuristics and + the '--more--' token to avoid showing the user Swank-internal + backtrace frames initially. + (slime-repl-current-input): Don't include the final newline + character, to make backtraces prettier. + (slime-autodoc): Fixed annoying case where autodocs would be + fetched in a loop for undocumented symbols. + + * swank.lisp (compound-prefix-match): New name and rewritten for + speed. Completion is much faster now. + (*sldb-initial-frames*): Send up to this many (default 20) + backtrace frames to Emacs when entering the debugger. + 2003-12-07 Helmut Eller * swank-allegro.lisp, swank-backend.lisp, swank-cmucl.lisp, From lgorrie at common-lisp.net Sun Dec 7 23:56:46 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 07 Dec 2003 18:56:46 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8115 Modified Files: slime.el Log Message: Updated an arglist test case. Date: Sun Dec 7 18:56:46 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.133 slime/slime.el:1.134 --- slime/slime.el:1.133 Sun Dec 7 18:43:31 2003 +++ slime/slime.el Sun Dec 7 18:56:46 2003 @@ -4137,8 +4137,8 @@ Confirm that EXPECTED-ARGLIST is displayed." '(("swank:start-server" "(swank:start-server port-file-namestring)") - ("swank::compound-string-match" - "(swank::compound-string-match string1 string2)")) + ("swank::compound-prefix-match" + "(swank::compound-prefix-match prefix target)")) (let ((arglist (slime-get-arglist function-name))) ; (slime-check ("Argument list %S is as expected." arglist) (string= expected-arglist arglist)))) From lgorrie at common-lisp.net Mon Dec 8 01:43:01 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 07 Dec 2003 20:43:01 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14905 Modified Files: swank-cmucl.lisp Log Message: (*debug-definition-finding*): Now nil by default. Date: Sun Dec 7 20:43:00 2003 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.34 slime/swank-cmucl.lisp:1.35 --- slime/swank-cmucl.lisp:1.34 Sun Dec 7 14:16:24 2003 +++ slime/swank-cmucl.lisp Sun Dec 7 20:43:00 2003 @@ -553,7 +553,7 @@ ;;;; Definitions -(defvar *debug-definition-finding* t +(defvar *debug-definition-finding* nil "When true don't handle errors while looking for definitions. This is useful when debugging the definition-finding code.") From lgorrie at common-lisp.net Mon Dec 8 01:44:09 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 07 Dec 2003 20:44:09 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16060 Modified Files: ChangeLog Log Message: Date: Sun Dec 7 20:44:08 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.144 slime/ChangeLog:1.145 --- slime/ChangeLog:1.144 Sun Dec 7 18:43:53 2003 +++ slime/ChangeLog Sun Dec 7 20:44:08 2003 @@ -1,5 +1,9 @@ 2003-12-08 Luke Gorrie + * swank-cmucl.lisp (*debug-definition-finding*): Now nil by + default, so that errors while looking for definitions are printed + as a message and not debugged. + * slime.el (slime-read-from-minibuffer): Now the only completing-read function, stale ones deleted. From heller at common-lisp.net Wed Dec 10 13:13:39 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 08:13:39 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv889 Modified Files: slime.el Log Message: (sldb-disassemble): New command. Bound to D. Date: Wed Dec 10 08:13:36 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.134 slime/slime.el:1.135 --- slime/slime.el:1.134 Sun Dec 7 18:56:46 2003 +++ slime/slime.el Wed Dec 10 08:13:28 2003 @@ -3674,6 +3674,14 @@ (interactive) (let ((frame (sldb-frame-number-at-point))) (slime-eval-async `(swank:sldb-step ,frame) nil (lambda ())))) + +(defun sldb-disassemble () + "Disassemble the code for the current frame." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-disassemble ,frame) nil + (lambda (result) + (slime-show-description result nil))))) (slime-define-keys sldb-mode-map ("v" 'sldb-show-source) @@ -3682,6 +3690,7 @@ ([mouse-2] 'sldb-default-action/mouse) ("e" 'sldb-eval-in-frame) ("d" 'sldb-pprint-eval-in-frame) + ("D" 'sldb-disassemble) ("i" 'sldb-inspect-in-frame) ("n" 'sldb-down) ("p" 'sldb-up) From heller at common-lisp.net Wed Dec 10 13:20:47 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 08:20:47 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4450 Modified Files: swank-cmucl.lisp Log Message: (create-swank-server): Use announce callback. (sldb-disassemble): New function. Date: Wed Dec 10 08:20:47 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.35 slime/swank-cmucl.lisp:1.36 --- slime/swank-cmucl.lisp:1.35 Sun Dec 7 20:43:00 2003 +++ slime/swank-cmucl.lisp Wed Dec 10 08:20:47 2003 @@ -27,14 +27,15 @@ (ext:htonl address))) (defun create-swank-server (port &key (reuse-address t) - (address "localhost")) + (address "localhost") + (announce #'simple-announce-function)) "Create a SWANK TCP server." (let* ((ip (resolve-hostname address)) (fd (ext:create-inet-listener port :stream :reuse-address reuse-address :host ip))) - (system:add-fd-handler fd :input #'accept-connection) - (nth-value 1 (ext::get-socket-host-and-port fd)))) + (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd))) + (accept-connection fd))) (defun accept-connection (socket) "Accept one Swank TCP connection on SOCKET and then close it." @@ -1110,13 +1111,18 @@ (di:frame-code-location frame))) (error "Cannot step, in elsewhere code~%")) (let* ((code-location (di:frame-code-location frame)) + (debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) (next (debug::next-code-locations code-location))) (cond (next (let ((steppoints '())) (flet ((hook (frame breakpoint) (let ((debug:*stack-top-hint* frame)) - (mapc #'di:deactivate-breakpoint steppoints) - (break "Breakpoint: ~A" breakpoint)))) + (mapc #'di:delete-breakpoint steppoints) + (let ((cl (di::breakpoint-what breakpoint))) + (break "Breakpoint: ~S ~S" + (di:code-location-kind cl) + (di::compiled-code-location-pc cl)))))) (dolist (code-location next) (let ((bp (di:make-breakpoint #'hook code-location :kind :code-location))) @@ -1125,7 +1131,7 @@ (t (flet ((hook (frame breakpoint values cookie) (declare (ignore cookie)) - (di:deactivate-breakpoint breakpoint) + (di:delete-breakpoint breakpoint) (let ((debug:*stack-top-hint* frame)) (break "Function-end: ~A ~A" breakpoint values)))) (let* ((debug-function (di:frame-debug-function frame)) @@ -1141,6 +1147,34 @@ (error "Cannot continue in from condition: ~A" *swank-debugger-condition*)))) +(defslimefun sldb-disassemble (frame-number) + "Return a string with the disassembly of frames code." + ;; this could need some refactoring. + (let* ((frame (nth-frame frame-number)) + (real-frame (di::frame-real-frame frame)) + (frame-pointer (di::frame-pointer real-frame)) + (debug-fun (di:frame-debug-function real-frame))) + (with-output-to-string (*standard-output*) + (format t "Frame: ~S~%~:[~;Real Frame: ~S~%~]Frame Pointer: ~S~%" + frame (eq frame real-frame) real-frame frame-pointer) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))) + (kind (if (di:code-location-unknown-p code-loc) + :unkown + (di:code-location-kind code-loc))) + (fun (di:debug-function-function debug-fun))) + (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%" + ip pc kind) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]")))))) ;;;; Inspecting From heller at common-lisp.net Wed Dec 10 13:24:27 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 08:24:27 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6044 Modified Files: swank.lisp Log Message: (start-server): Pass an announce callback function to create-swank-server. Works better with single threaded implementations. (announce-server-port, simple-announce-function): New functions. (alistify): Doc fix. Date: Wed Dec 10 08:24:27 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.76 slime/swank.lisp:1.77 --- slime/swank.lisp:1.76 Sun Dec 7 18:42:40 2003 +++ slime/swank.lisp Wed Dec 10 08:24:27 2003 @@ -50,17 +50,26 @@ ;;;; Setup and Hooks -(defun start-server (port-file-namestring) - "Create a SWANK server and write its port number to the file -PORT-FILE-NAMESTRING in ascii text." - (let ((port (create-swank-server 0 :reuse-address t))) - (with-open-file (s port-file-namestring +(defun announce-server-port (file) + (lambda (port) + (with-open-file (s file :direction :output :if-exists :overwrite :if-does-not-exist :create) - (format s "~S~%" port))) + (format s "~S~%" port)) + (when *swank-debug-p* + (format *debug-io* "~&;; Swank ready.~%")))) + +(defun simple-announce-function (port) (when *swank-debug-p* - (format *debug-io* "~&;; Swank ready.~%"))) + (format *debug-io* "~&;; Swank started at port: ~A.~%" port))) + +(defun start-server (port-file-namestring) + "Create a SWANK server and write its port number to the file +PORT-FILE-NAMESTRING in ascii text." + (create-swank-server + 0 :reuse-address t + :announce (announce-server-port port-file-namestring))) ;;;; IO to Emacs @@ -703,7 +712,6 @@ (cond (foundp (print-description-to-string symbol)) (t (format nil "Unkown symbol: ~S [in ~A]" symbol-name *buffer-package*))))) - (defslimefun describe-function (symbol-name) (print-description-to-string @@ -747,7 +755,7 @@ (defstruct (:position (:type list) :named (:constructor)) pos) (defun alistify (list key test) - "Partition the element of LIST into an alist. KEY extracts the key + "Partition the elements of LIST into an alist. KEY extracts the key from an element and TEST is used to compare keys." (let ((alist '())) (dolist (e list) @@ -757,7 +765,7 @@ (push e (cdr probe)) (push (cons k (list e)) alist)))) alist)) - + (defun location-position< (pos1 pos2) (cond ((and (position-p pos1) (position-p pos2)) (< (position-pos pos1) @@ -769,7 +777,7 @@ if (funcall predicate e) collect e into yes else collect e into no finally (return (values yes no)))) - + (defun group-xrefs (xrefs) (flet ((xref-buffer (xref) (location-buffer (cdr xref))) (xref-position (xref) (location-position (cdr xref)))) From heller at common-lisp.net Wed Dec 10 13:26:09 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 08:26:09 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-lispworks.lisp slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6458 Modified Files: swank-sbcl.lisp swank-openmcl.lisp swank-lispworks.lisp swank-allegro.lisp Log Message: (create-swank-server): Accept an announce-function keyword argument. Date: Wed Dec 10 08:26:09 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.38 slime/swank-sbcl.lisp:1.39 --- slime/swank-sbcl.lisp:1.38 Sun Dec 7 14:16:24 2003 +++ slime/swank-sbcl.lisp Wed Dec 10 08:26:08 2003 @@ -78,7 +78,8 @@ (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) -(defun create-swank-server (port &key reuse-address) +(defun create-swank-server (port &key (reuse-address t) + (announce #'simple-announce-function)) "Create a SWANK TCP server." (let ((socket (open-listener port reuse-address))) (sb-sys:add-fd-handler @@ -86,7 +87,7 @@ :input (lambda (fd) (declare (ignore fd)) (accept-connection socket))) - (nth-value 1 (sb-bsd-sockets:socket-name socket)))) + (funcall announce (nth-value 1 (sb-bsd-sockets:socket-name socket))))) (defun open-stream-to-emacs () (let* ((server-socket (open-listener 0 t)) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.28 slime/swank-openmcl.lisp:1.29 --- slime/swank-openmcl.lisp:1.28 Sun Dec 7 14:16:24 2003 +++ slime/swank-openmcl.lisp Wed Dec 10 08:26:08 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.28 2003/12/07 19:16:24 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.29 2003/12/10 13:26:08 heller Exp $ ;;; ;;; @@ -76,15 +76,15 @@ ;; In OpenMCL, the Swank backend runs in a separate thread and simply ;; blocks on its TCP port while waiting for forms to evaluate. -(defun create-swank-server (port &key reuse-address) - "Create a Swank TCP server on `port'. -Return the port number that the socket is actually listening on." +(defun create-swank-server (port &key (reuse-address t) + (announce #'simple-announce-function)) + "Create a Swank TCP server on `port'." (let ((server-socket (ccl:make-socket :connect :passive :local-port port :reuse-address reuse-address))) + (funcall announce (ccl:local-port server-socket)) (ccl:process-run-function "Swank Request Processor" #'swank-accept-connection - server-socket) - (ccl:local-port server-socket))) + server-socket))) (defun swank-accept-connection (server-socket) "Accept one Swank TCP connection on SOCKET and then close it. Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.7 slime/swank-lispworks.lisp:1.8 --- slime/swank-lispworks.lisp:1.7 Sun Dec 7 14:16:24 2003 +++ slime/swank-lispworks.lisp Wed Dec 10 08:26:08 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.7 2003/12/07 19:16:24 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.8 2003/12/10 13:26:08 heller Exp $ ;;; (in-package :swank) @@ -30,15 +30,21 @@ (defun without-interrupts* (body) (lispworks:without-interrupts (funcall body))) -(defun create-swank-server (port &key reuse-address) +(defun create-swank-server (port &key (reuse-address t) + (announce #'simple-announce-function)) "Create a Swank TCP server on `port'. Return the port number that the socket is actually listening on." (declare (ignore reuse-address)) - (comm:start-up-server-and-mp :announce *terminal-io* :service port - :process-name "Swank Request Processor" - :function 'swank-accept-connection - ) - port) + (flet ((sentinel (socket condition) + (cond (socket + (let ((port (nth-value 1 (comm:get-socket-address socket)))) + (funcall announce port))) + (t + (format *terminal-io* ";; Swank condition: ~A~%" + condition))))) + (comm:start-up-server :announce #'sentinel :service port + :process-name "Swank server" + :function 'swank-accept-connection))) (defconstant +sigint+ 2) Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.2 slime/swank-allegro.lisp:1.3 --- slime/swank-allegro.lisp:1.2 Sun Dec 7 14:16:24 2003 +++ slime/swank-allegro.lisp Wed Dec 10 08:26:08 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.2 2003/12/07 19:16:24 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.3 2003/12/10 13:26:08 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -36,27 +36,21 @@ ;;; TCP Server -(defun create-swank-server (port &key (reuse-address t)) - "Create a Swank TCP server on `port'. -Return the port number that the socket is actually listening on." +(defun create-swank-server (port &key (reuse-address t) + (announce #'simple-announce-function)) + "Create a Swank TCP server on `port'." (let ((server-socket (socket:make-socket :connect :passive :local-port port :reuse-address reuse-address))) - (mp:process-run-function "Swank Request Processor" - #'swank-accept-connection - server-socket) - (socket:local-port server-socket))) + (funcall announce (socket:local-port server-socket)) + (swank-accept-connection server-socket))) (defun swank-accept-connection (server-socket) "Accept one Swank TCP connection on SOCKET. Run the connection handler in a new thread." (loop - (let ((socket (socket:accept-connection server-socket :wait t))) - (mp:process-run-function - (list :name (format nil "Swank Client ~D" (socket:socket-os-fd socket)) - :initial-bindings `((*emacs-io* . ',socket))) - #'request-loop)))) + (request-loop (socket:accept-connection server-socket :wait t)))) -(defun request-loop () +(defun request-loop (*emacs-io*) "Thread function for a single Swank connection. Processes requests until the remote Emacs goes away." (unwind-protect From heller at common-lisp.net Wed Dec 10 13:27:55 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 08:27:55 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7039 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Dec 10 08:27:54 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.145 slime/ChangeLog:1.146 --- slime/ChangeLog:1.145 Sun Dec 7 20:44:08 2003 +++ slime/ChangeLog Wed Dec 10 08:27:54 2003 @@ -1,3 +1,20 @@ +2003-12-10 Helmut Eller + + * swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp, + swank-sbcl.lisp (create-swank-server): Accept an announce-function + keyword argument. + + * swank.lisp (start-server): Pass an announce callback function to + create-swank-server. Works better with single threaded + implementations. + (announce-server-port, simple-announce-function): New functions. + (alistify): Doc fix. + + * swank-cmucl.lisp (create-swank-server): Use announce callback. + (sldb-disassemble): New function. + + * slime.el (sldb-disassemble): New command. Bound to D. + 2003-12-08 Luke Gorrie * swank-cmucl.lisp (*debug-definition-finding*): Now nil by From dbarlow at common-lisp.net Wed Dec 10 19:02:36 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 14:02:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18779 Modified Files: ChangeLog slime.el swank-sbcl.lisp Log Message: * swank-sbcl.lisp (serve-request): more fiddling with serve-event descriptors * slime.el (slime-repl-return): slime-check-connected, otherwise pressing Return in an unconnected repl gets a bit weird Date: Wed Dec 10 14:02:35 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.146 slime/ChangeLog:1.147 --- slime/ChangeLog:1.146 Wed Dec 10 08:27:54 2003 +++ slime/ChangeLog Wed Dec 10 14:02:35 2003 @@ -1,3 +1,11 @@ +2003-12-10 Daniel Barlow + + * swank-sbcl.lisp (serve-request): more fiddling with serve-event + descriptors + + * slime.el (slime-repl-return): slime-check-connected, otherwise + pressing Return in an unconnected repl gets a bit weird + 2003-12-10 Helmut Eller * swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp, Index: slime/slime.el diff -u slime/slime.el:1.135 slime/slime.el:1.136 --- slime/slime.el:1.135 Wed Dec 10 08:13:28 2003 +++ slime/slime.el Wed Dec 10 14:02:35 2003 @@ -1707,6 +1707,7 @@ With prefix argument send the input even if the parenthesis are not balanced." (interactive) + (slime-check-connected) (unless (or (slime-idle-p) (slime-reading-p)) (error "Lisp is not ready for requests from the REPL.")) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.39 slime/swank-sbcl.lisp:1.40 --- slime/swank-sbcl.lisp:1.39 Wed Dec 10 08:26:08 2003 +++ slime/swank-sbcl.lisp Wed Dec 10 14:02:35 2003 @@ -103,7 +103,7 @@ (defvar *use-dedicated-output-stream* t) (defun accept-connection (server-socket) - "Accept one Swank TCP connection on SOCKET and then close it." + "Accept one Swank TCP connection on SERVER-SOCKET and then close it." (let* ((socket (accept server-socket)) (stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :element-type 'base-char)) @@ -132,7 +132,10 @@ (slime-read-error (e) (when *swank-debug-p* (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (close *emacs-io* :abort t))))) + (sb-sys:invalidate-descriptor (sb-impl::fd-stream-fd *emacs-io*)) + (close *emacs-io* :abort t) + (when *use-dedicated-output-stream* + (close *slime-output* :abort t)))))) ;;; Utilities From heller at common-lisp.net Wed Dec 10 23:14:46 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 18:14:46 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29493 Modified Files: slime.el Log Message: (slime-repl-previous-prompt, slime-repl-next-prompt): New commands. (slime-repl-beginning-of-defun, slime-repl-end-of-defun): New commands. (slime-repl-insert-prompt): Mark the prompt with a slime-repl-prompt a text property. (slime-repl-eol): New function. Mostly for symmetry. (slime-repl-in-input-area-p, slime-repl-at-prompt-end-p): New predicates. (slime-repl-find-prompt, slime-search-property-change-fn): New functions. (slime-ir1-expand): New command. Date: Wed Dec 10 18:14:46 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.136 slime/slime.el:1.137 --- slime/slime.el:1.136 Wed Dec 10 14:02:35 2003 +++ slime/slime.el Wed Dec 10 18:14:46 2003 @@ -1614,6 +1614,7 @@ '(face font-lock-keyword-face read-only t intangible t + slime-repl-prompt t ;; emacs stuff rear-nonsticky (slime-repl-prompt read-only face intangible) ;; xemacs stuff @@ -1698,7 +1699,67 @@ (slime-same-line-p (point) slime-repl-input-start-mark)) (goto-char slime-repl-input-start-mark) (beginning-of-line 1))) - + +(defun slime-repl-eol () + "Go to the end of line or the prompt." + (interactive) + (if (and (<= (point) slime-repl-input-end-mark) + (slime-same-line-p (point) slime-repl-input-end-mark)) + (goto-char slime-repl-input-end-mark) + (end-of-line 1))) + +(defun slime-repl-in-input-area-p () + (and (<= slime-repl-input-start-mark (point)) + (<= (point) slime-repl-input-end-mark))) + +(defun slime-repl-beginning-of-defun () + "Move to beginning of defun." + (interactive) + (if (slime-in-input-area-p) + (goto-char slime-repl-input-start-mark) + (beginning-of-defun))) + +(defun slime-repl-end-of-defun () + "Move to next of defun." + (interactive) + (if (slime-in-input-area-p) + (goto-char slime-repl-input-end-mark) + (end-of-defun))) + +(defun slime-repl-at-prompt-end-p () + (and (get-char-property (max 1 (1- (point))) 'slime-repl-prompt) + (not (get-char-property (point) 'slime-repl-prompt)))) + +(defun slime-repl-find-prompt (move) + (let ((origin (point))) + (loop (funcall move) + (when (or (slime-repl-at-prompt-end-p) (bobp) (eobp)) + (return))) + (unless (slime-repl-at-prompt-end-p) + (goto-char origin)))) + +(defun slime-search-property-change-fn (prop &optional backward) + (with-lexical-bindings (prop) + (if backward + (lambda () + (goto-char + (previous-single-char-property-change (point) prop))) + (lambda () + (goto-char + (next-single-char-property-change (point) prop)))))) + +(defun slime-repl-previous-prompt () + "Move backward to the previous prompt." + (interactive) + (slime-repl-find-prompt + (slime-search-property-change-fn 'slime-repl-prompt t))) + +(defun slime-repl-next-prompt () + "Move forward to the next prompt." + (interactive) + (slime-repl-find-prompt + (slime-search-property-change-fn 'slime-repl-prompt))) + (defun slime-repl-return () "Evaluate the current input string, or insert a newline. Send the current input ony if a whole expression has been entered, @@ -1877,6 +1938,7 @@ ("\C-\M-m" 'slime-repl-closing-return) ([(control return)] 'slime-repl-closing-return) ("\C-a" 'slime-repl-bol) + ("\C-e" 'slime-repl-eol) ("\M-p" 'slime-repl-previous-input) ("\M-n" 'slime-repl-next-input) ("\M-r" 'slime-repl-previous-matching-input) @@ -1888,6 +1950,10 @@ ("\C-\M-x" 'slime-eval-defun) ("\C-c\C-o" 'slime-repl-clear-output) ("\C-c\C-t" 'slime-repl-clear-buffer) + ("\C-c\C-n" 'slime-repl-next-prompt) + ("\C-c\C-p" 'slime-repl-previous-prompt) + ("\M-\C-a" 'slime-repl-beginning-of-defun) + ("\M-\C-e" 'slime-repl-end-of-defun) ) (define-minor-mode slime-repl-read-mode @@ -3298,6 +3364,12 @@ "Display the recursively macro expanded sexp at point." (interactive) (slime-eval-macroexpand 'swank:swank-macroexpand-all)) + +(defun slime-ir1-expand () + "Display the ir1 form of the sexp at point." + (interactive) + (slime-eval-macroexpand 'swank:print-ir1-converted-blocks)) + ;;; Subprocess control From heller at common-lisp.net Wed Dec 10 23:16:58 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 18:16:58 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30031 Modified Files: swank-cmucl.lisp Log Message: (accept-connection, request-loop): Don't use fd-handlers. The code is now almost identical request-loop itself is now almost identical as the Allegro version. (print-ir1-converted-blocks, expand-ir1-top-level): New functions. Date: Wed Dec 10 18:16:58 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.36 slime/swank-cmucl.lisp:1.37 --- slime/swank-cmucl.lisp:1.36 Wed Dec 10 08:20:47 2003 +++ slime/swank-cmucl.lisp Wed Dec 10 18:16:58 2003 @@ -39,9 +39,12 @@ (defun accept-connection (socket) "Accept one Swank TCP connection on SOCKET and then close it." - (setup-request-handler (ext:accept-tcp-connection socket)) - (sys:invalidate-descriptor socket) - (unix:unix-close socket)) + (let* ((fd (ext:accept-tcp-connection socket)) + (stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char))) + (sys:invalidate-descriptor socket) + (unix:unix-close socket) + (request-loop stream))) (defun open-stream-to-emacs () "Return an output-stream to Emacs' output buffer." @@ -57,33 +60,26 @@ (defvar *use-dedicated-output-stream* t) -(defun setup-request-handler (socket) - "Setup request handling for SOCKET." - (let* ((stream (sys:make-fd-stream socket - :input t :output t - :element-type 'base-char)) - (input (make-slime-input-stream)) - (output (if *use-dedicated-output-stream* - (let ((*emacs-io* stream)) (open-stream-to-emacs)) - (make-slime-output-stream))) - (io (make-two-way-stream input output))) - (system:add-fd-handler socket - :input (lambda (fd) - (declare (ignore fd)) - (serve-request stream output input io))))) - -(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) - "Read and process a request from a SWANK client. -The request is read from the socket as a sexp and then evaluated." - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime toplevel.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) - (close *emacs-io*))))) - (sys:scrub-control-stack)) +(defun request-loop (*emacs-io*) + "Processes requests until the remote Emacs goes away." + (unwind-protect + (let* ((*slime-output* (if *use-dedicated-output-stream* + (open-stream-to-emacs) + (make-slime-output-stream))) + (*slime-input* (make-slime-input-stream)) + (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) + (loop + (catch 'slime-toplevel + (with-simple-restart (abort "Return to Slime toplevel.") + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* + "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (return))))) + (sys:scrub-control-stack))) + (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) + (close *emacs-io*))) ;;;; Stream handling @@ -808,6 +804,29 @@ (defmethod macroexpand-all (form) (walker:macroexpand-all form)) +(in-package :c) + +(defun swank::expand-ir1-top-level (form) + "A scaled down version of the first pass of the compiler." + (with-compilation-unit () + (let* ((*lexical-environment* + (make-lexenv :default (make-null-environment) + :cookie *default-cookie* + :interface-cookie *default-interface-cookie*)) + (*source-info* (make-lisp-source-info form)) + (*block-compile* nil) + (*block-compile-default* nil)) + (with-ir1-namespace + (clear-stuff) + (find-source-paths form 0) + (ir1-top-level form '(0) t))))) + +(in-package :swank) + +(defslimefun print-ir1-converted-blocks (form) + (with-output-to-string (*standard-output*) + (c::print-all-blocks (expand-ir1-top-level (from-string form))))) + (defun tracedp (fname) (gethash (debug::trace-fdefinition fname) debug::*traced-functions*)) @@ -1087,14 +1106,14 @@ (debug-function (di:frame-debug-function frame)) (debug-variables (di::debug-function-debug-variables debug-function))) (loop for v across debug-variables - collect (list - :symbol (di:debug-variable-symbol v) - :id (di:debug-variable-id v) + for symbol = (di:debug-variable-symbol v) + for id = (di:debug-variable-id v) + for validy = (di:debug-variable-validity v location) + collect (list :symbol symbol :id id :value-string - (if (eq (di:debug-variable-validity v location) - :valid) - (to-string (di:debug-variable-value v frame)) - ""))))) + (ecase validy + (:valid (to-string (di:debug-variable-value v frame))) + ((:invalid :unknown) "")))))) (defmethod frame-catch-tags (index) (loop for (tag . code-location) in (di:frame-catches (nth-frame index)) @@ -1155,7 +1174,7 @@ (frame-pointer (di::frame-pointer real-frame)) (debug-fun (di:frame-debug-function real-frame))) (with-output-to-string (*standard-output*) - (format t "Frame: ~S~%~:[~;Real Frame: ~S~%~]Frame Pointer: ~S~%" + (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%" frame (eq frame real-frame) real-frame frame-pointer) (etypecase debug-fun (di::compiled-debug-function @@ -1168,11 +1187,11 @@ :unkown (di:code-location-kind code-loc))) (fun (di:debug-function-function debug-fun))) - (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%" + (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%" ip pc kind) (if fun - (disassemble fun) - (disassem:disassemble-code-component component)))) + (disassemble fun) + (disassem:disassemble-code-component component)))) (di::bogus-debug-function (format t "~%[Disassembling bogus frames not implemented]")))))) From heller at common-lisp.net Wed Dec 10 23:22:33 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 10 Dec 2003 18:22:33 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31985 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Dec 10 18:22:33 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.147 slime/ChangeLog:1.148 --- slime/ChangeLog:1.147 Wed Dec 10 14:02:35 2003 +++ slime/ChangeLog Wed Dec 10 18:22:33 2003 @@ -1,3 +1,23 @@ +2003-12-11 Helmut Eller + + * slime.el (slime-repl-previous-prompt, slime-repl-next-prompt): + New commands. Suggested by H?kon Alstadheim. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): New + commands. Suggested by Andreas Fuchs. + (slime-repl-insert-prompt): Mark the prompt with a + slime-repl-prompt text property. + (slime-repl-eol): New function. Mostly for symmetry. + (slime-repl-in-input-area-p, slime-repl-at-prompt-end-p): New + predicates. + (slime-repl-find-prompt, slime-search-property-change-fn): New + functions. + (slime-ir1-expand): New command. + + * swank-cmucl.lisp (accept-connection, request-loop): Don't use + fd-handlers. The code for the request-loop itself is now almost + the same as in the Allegro version. + (print-ir1-converted-blocks, expand-ir1-top-level): New functions. + 2003-12-10 Daniel Barlow * swank-sbcl.lisp (serve-request): more fiddling with serve-event From dbarlow at common-lisp.net Thu Dec 11 02:19:24 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 21:19:24 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4163 Modified Files: slime.el Log Message: * slime.el (slime-find-asd, slime-load-system): new command to compile and load an ASDF system with all the usual compiler notes and stuff (slime-compilation-finished): minimally handle multiple file compiles, by printing the names of all files with notes in the echo area (slime-remove-old-overlays): bug fix: now removes overlays even at start of buffer (slime-overlay-note): do nothing quietly if slime-choose-overlay-region returns nil (slime-choose-overlay-region): return nil if note has no location Date: Wed Dec 10 21:19:24 2003 Author: dbarlow Index: slime/slime.el diff -u slime/slime.el:1.137 slime/slime.el:1.138 --- slime/slime.el:1.137 Wed Dec 10 18:14:46 2003 +++ slime/slime.el Wed Dec 10 21:19:24 2003 @@ -2017,6 +2017,30 @@ (slime-compilation-finished-continuation)) (message "Compiling %s.." (buffer-file-name))) +(defun slime-find-asd () + (file-name-sans-extension + (car (directory-files + (file-name-directory (buffer-file-name)) nil "\.asd$")))) + +(defun slime-load-system (&optional system-name) + "Compile and load an ASDF system. + +Default system name is taken from first file matching *.asd in current +buffer's working directory" + (interactive + (list (let ((d (slime-find-asd))) + (read-string (format "System: [%s] " d) nil nil d)))) + (save-some-buffers) + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (set-window-start (display-buffer (current-buffer) t) + (line-beginning-position))) + (slime-eval-async + `(swank:swank-load-system ,system-name) + nil + (slime-compilation-finished-continuation)) + (message "Compiling system %s.." system-name)) + (defun slime-compile-defun () "Compile the current toplevel form." (interactive) @@ -2062,11 +2086,22 @@ (if secs (format "[%s secs]" secs) "")))) (defun slime-compilation-finished (result buffer) - (with-current-buffer buffer - (multiple-value-bind (result secs) result - (let ((notes (slime-compiler-notes))) + (let ((notes (slime-compiler-notes))) + (with-current-buffer buffer + (multiple-value-bind (result secs) result (slime-show-note-counts notes secs) - (slime-highlight-notes notes))))) + (slime-highlight-notes notes))) + (let* ((locations (mapcar (lambda (n) (getf n :location)) notes)) + (files (remove-duplicates + (mapcar (lambda (l) + (let ((f (assq :file (cdr l)))) + (and f (cadr f)))) + locations) + :test 'equal))) + ;; we need a better way of showing the resulting notes if there + ;; was >1 of them + ;; (slime-show-definitions "Compiler notes" locations) + (message "files with notes: %s" files) ))) (defun slime-compilation-finished-continuation () (lexical-let ((buffer (current-buffer))) @@ -2089,10 +2124,10 @@ (save-excursion (goto-char (point-min)) (while (not (eobp)) - (goto-char (next-overlay-change (point))) (dolist (o (overlays-at (point))) (when (overlay-get o 'slime) - (delete-overlay o)))))) + (delete-overlay o))) + (goto-char (next-overlay-change (point)))))) ;;;; Adding a single compiler note @@ -2103,13 +2138,14 @@ already exists then the new information is merged into it. Otherwise a new overlay is created." (multiple-value-bind (start end) (slime-choose-overlay-region note) - (goto-char start) - (let ((severity (plist-get note :severity)) - (message (plist-get note :message)) - (appropriate-overlay (slime-note-at-point))) - (if appropriate-overlay - (slime-merge-note-into-overlay appropriate-overlay severity message) - (slime-create-note-overlay note start end severity message))))) + (when start + (goto-char start) + (let ((severity (plist-get note :severity)) + (message (plist-get note :message)) + (appropriate-overlay (slime-note-at-point))) + (if appropriate-overlay + (slime-merge-note-into-overlay appropriate-overlay severity message) + (slime-create-note-overlay note start end severity message)))))) (defun slime-create-note-overlay (note start end severity message) "Create an overlay representing a compiler note. @@ -2145,15 +2181,16 @@ If the location's sexp is a list spanning multiple lines, then the region around the first element is used." (let ((location (getf note :location))) - (slime-goto-source-location location)) - (let ((start (point))) - (slime-forward-sexp) - (if (slime-same-line-p start (point)) - (values start (point)) - (values (1+ start) - (progn (goto-char (1+ start)) - (forward-sexp 1) - (point)))))) + (unless (eql (car location) :error) + (slime-goto-source-location location) + (let ((start (point))) + (slime-forward-sexp) + (if (slime-same-line-p start (point)) + (values start (point)) + (values (1+ start) + (progn (goto-char (1+ start)) + (forward-sexp 1) + (point)))))))) (defun slime-same-line-p (pos1 pos2) "Return true if buffer positions PoS1 and POS2 are on the same line." From dbarlow at common-lisp.net Thu Dec 11 02:19:33 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 21:19:33 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4218 Modified Files: swank-backend.lisp Log Message: * swank-backend.lisp (call-with-compilation-hooks): new GF should set up all appropriate error condition loggers etc to do a compilation preserving the notes. Implement for sbcl, cmucl Date: Wed Dec 10 21:19:33 2003 Author: dbarlow Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.7 slime/swank-backend.lisp:1.8 --- slime/swank-backend.lisp:1.7 Sun Dec 7 14:16:24 2003 +++ slime/swank-backend.lisp Wed Dec 10 21:19:33 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.7 2003/12/07 19:16:24 heller Exp $ +;;; $Id: swank-backend.lisp,v 1.8 2003/12/11 02:19:33 dbarlow Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -118,6 +118,12 @@ ;;;; Compilation + +(defgeneric call-with-compilation-hooks (func) + (:documentation + "Call FUNC with hooks to trigger SLDB on compiler errors.")) +(defmacro with-compilation-hooks (() &body body) + `(call-with-compilation-hooks (lambda () (progn , at body)))) (defgeneric compile-string-for-emacs (string &key buffer position) (:documentation From dbarlow at common-lisp.net Thu Dec 11 02:19:51 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 21:19:51 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4254 Modified Files: swank-cmucl.lisp Log Message: * swank-backend.lisp (call-with-compilation-hooks): new GF should set up all appropriate error condition loggers etc to do a compilation preserving the notes. Implement for sbcl, cmucl Date: Wed Dec 10 21:19:51 2003 Author: dbarlow Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.37 slime/swank-cmucl.lisp:1.38 --- slime/swank-cmucl.lisp:1.37 Wed Dec 10 18:16:58 2003 +++ slime/swank-cmucl.lisp Wed Dec 10 21:19:51 2003 @@ -274,19 +274,20 @@ (make-location (list :file (namestring *compile-file-truename*)) (list :position 0))) (*compile-filename* + ;; XXX is this _ever_ used? By what? *compile-file-truename* + ;; should be set by the implementation inside any call to compile-file (make-location (list :file *compile-filename*) (list :position 0))) (t (list :error "No error location available")))) -(defmacro with-compilation-hooks (() &body body) - "Execute BODY and record the set of compiler notes." - `(let ((*previous-compiler-condition* nil) - (*previous-context* nil) - (*print-readably* nil)) +(defmethod call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) (handler-bind ((c::compiler-error #'handle-notification-condition) (c::style-warning #'handle-notification-condition) (c::warning #'handle-notification-condition)) - , at body))) + (funcall function)))) (defmethod compile-file-for-emacs (filename load-p) (clear-xref-info filename) From dbarlow at common-lisp.net Thu Dec 11 02:20:13 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 21:20:13 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4566 Modified Files: swank-sbcl.lisp Log Message: * swank-backend.lisp (call-with-compilation-hooks): new GF should set up all appropriate error condition loggers etc to do a compilation preserving the notes. Implement for sbcl, cmucl * swank-sbcl.lisp (compiler-note-location and elsewhere): remove all trace of *compile-filename* (compile-*-for-emacs): shorten Date: Wed Dec 10 21:20:13 2003 Author: dbarlow Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.40 slime/swank-sbcl.lisp:1.41 --- slime/swank-sbcl.lisp:1.40 Wed Dec 10 14:02:35 2003 +++ slime/swank-sbcl.lisp Wed Dec 10 21:20:13 2003 @@ -159,9 +159,8 @@ (princ-to-string arglist) "(-- )"))))) -(defvar *buffername*) +(defvar *buffername* nil) (defvar *buffer-offset*) -(defvar *compile-filename*) (defvar *previous-compiler-condition* nil "Used to detect duplicates.") @@ -197,7 +196,7 @@ (sb-c::compiler-error-context-file-name context) (sb-c::compiler-error-context-file-position context) (current-compiler-error-source-path context))) - (cond ((and (boundp '*buffername*) *buffername*) + (cond (*buffername* ;; account for the added lambda, replace leading ;; position with 0 (make-location @@ -209,10 +208,9 @@ (make-location (list :file (namestring (truename file-name))) (list :source-path source-path file-pos))))) - ((or *compile-file-truename* *compile-filename*) + (*compile-file-truename* (make-location - (list :file (namestring (or *compile-file-truename* - *compile-filename*))) + (list :file (namestring *compile-file-truename*)) (list :source-path '(0) 1))) (t (list :error "No source location"))))) @@ -242,22 +240,23 @@ (reverse (sb-c::compiler-error-context-original-source-path context))))) -(defmacro with-compilation-hooks (() &body body) - `(handler-bind ((sb-c:compiler-error #'handle-notification-condition) - (sb-ext:compiler-note #'handle-notification-condition) - (style-warning #'handle-notification-condition) - (warning #'handle-notification-condition)) - , at body)) +(defmethod call-with-compilation-hooks (function) + (handler-bind ((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))) (defmethod compile-file-for-emacs (filename load-p) (with-compilation-hooks () - (let* ((*buffername* nil) - (*buffer-offset* nil) - (*compile-filename* filename) - (fasl-file (compile-file filename))) - (cond ((and fasl-file load-p) + (multiple-value-bind (fasl-file w-p f-p) (compile-file filename) + (cond ((and fasl-file (not f-p) load-p) (load fasl-file)) (t fasl-file))))) + +(defmethod compile-system-for-emacs (system-name) + (with-compilation-hooks () + (asdf:operate 'asdf:load-op system-name))) (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () From dbarlow at common-lisp.net Thu Dec 11 02:20:30 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 21:20:30 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4616 Modified Files: swank.lisp Log Message: * swank.lisp (swank-compiler): new function abstracts commonality between swank-compile-{file, string}. (swank-load-system): call swank-compiler to load asdf system Date: Wed Dec 10 21:20:30 2003 Author: dbarlow Index: slime/swank.lisp diff -u slime/swank.lisp:1.77 slime/swank.lisp:1.78 --- slime/swank.lisp:1.77 Wed Dec 10 08:24:27 2003 +++ slime/swank.lisp Wed Dec 10 21:20:30 2003 @@ -454,28 +454,31 @@ :severity (severity condition) :location (location condition))) -(defslimefun swank-compile-file (filename load-p) - "Compile FILENAME and, when LOAD-P, load the result. -Record compiler notes signalled as `compiler-condition's." +(defun swank-compiler (function) (clear-compiler-notes) (multiple-value-bind (result usecs) (handler-bind ((compiler-condition #'record-note-for-condition)) - (measure-time-interval (lambda () - (compile-file-for-emacs filename load-p)))) + (measure-time-interval function)) (list (to-string result) (format nil "~,2F" (/ usecs 1000000.0))))) +(defslimefun swank-compile-file (filename load-p) + "Compile FILENAME and, when LOAD-P, load the result. +Record compiler notes signalled as `compiler-condition's." + (swank-compiler (lambda () (compile-file-for-emacs filename load-p)))) + (defslimefun swank-compile-string (string buffer position) "Compile STRING (exerpted from BUFFER at POSITION). Record compiler notes signalled as `compiler-condition's." - (clear-compiler-notes) - (multiple-value-bind (result usecs) - (handler-bind ((compiler-condition #'record-note-for-condition)) - (measure-time-interval - (lambda () - (compile-string-for-emacs string :buffer buffer :position position)))) - (list (to-string result) - (format nil "~,2F" (/ usecs 1000000.0))))) + (swank-compiler + (lambda () + (compile-string-for-emacs string :buffer buffer :position position)))) + +(defslimefun swank-load-system (system) + "Compile and load SYSTEM using ASDF. +Record compiler notes signalled as `compiler-condition's." + (swank-compiler (lambda () (compile-system-for-emacs system)))) + ;;;; Macroexpansion From dbarlow at common-lisp.net Thu Dec 11 02:20:49 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 21:20:49 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4653 Modified Files: ChangeLog Log Message: Date: Wed Dec 10 21:20:49 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.148 slime/ChangeLog:1.149 --- slime/ChangeLog:1.148 Wed Dec 10 18:22:33 2003 +++ slime/ChangeLog Wed Dec 10 21:20:49 2003 @@ -1,3 +1,30 @@ +2003-12-11 Daniel Barlow + + * swank.lisp (swank-compiler): new function abstracts commonality + between swank-compile-{file, string}. + (swank-load-system): call swank-compiler to load asdf system + + * swank-sbcl.lisp (compiler-note-location and elsewhere): + remove all trace of *compile-filename* + (compile-*-for-emacs): shorten + + * swank-backend.lisp (call-with-compilation-hooks): new GF + should set up all appropriate error condition loggers etc + to do a compilation preserving the notes. Implement for + sbcl, cmucl + + * slime.el (slime-find-asd, slime-load-system): new command + to compile and load an ASDF system with all the usual compiler + notes and stuff + (slime-compilation-finished): minimally handle multiple file + compiles, by printing the names of all files with notes in the + echo area + (slime-remove-old-overlays): bug fix: now removes overlays even + at start of buffer + (slime-overlay-note): do nothing quietly if + slime-choose-overlay-region returns nil + (slime-choose-overlay-region): return nil if note has no location + 2003-12-11 Helmut Eller * slime.el (slime-repl-previous-prompt, slime-repl-next-prompt): From dbarlow at common-lisp.net Thu Dec 11 04:57:34 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Wed, 10 Dec 2003 23:57:34 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31893 Modified Files: ChangeLog slime.el Log Message: Significantly more friendly display of compiler notes when there are multiple buffers involved Date: Wed Dec 10 23:57:33 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.149 slime/ChangeLog:1.150 --- slime/ChangeLog:1.149 Wed Dec 10 21:20:49 2003 +++ slime/ChangeLog Wed Dec 10 23:57:33 2003 @@ -16,9 +16,8 @@ * slime.el (slime-find-asd, slime-load-system): new command to compile and load an ASDF system with all the usual compiler notes and stuff - (slime-compilation-finished): minimally handle multiple file - compiles, by printing the names of all files with notes in the - echo area + (slime-compilation-finished): if more than one file has new + errors/notes, create an xref buffer to show them all (slime-remove-old-overlays): bug fix: now removes overlays even at start of buffer (slime-overlay-note): do nothing quietly if Index: slime/slime.el diff -u slime/slime.el:1.138 slime/slime.el:1.139 --- slime/slime.el:1.138 Wed Dec 10 21:19:24 2003 +++ slime/slime.el Wed Dec 10 23:57:33 2003 @@ -2085,23 +2085,34 @@ (slime-note-count-string "note" notes) (if secs (format "[%s secs]" secs) "")))) +(defun slime-xrefs-for-notes (notes) + (flet ((note-file (n) (cadr (assq :file (cdr (getf n :location)))))) + (let ((xrefs)) + (dolist (note notes) + (let ((file (assoc (note-file note) xrefs)) + (node + (cons (format "%s: %s" + (getf note :severity) + (replace-regexp-in-string + "[^[:graph:]]+" " " + (subseq (getf note :message) 0 ))) + (getf note :location)))) + (when (note-file note) + (if file + (push node (cdr file)) + (setf xrefs (acons (note-file note) (list node) xrefs)))))) + xrefs))) + (defun slime-compilation-finished (result buffer) (let ((notes (slime-compiler-notes))) (with-current-buffer buffer (multiple-value-bind (result secs) result (slime-show-note-counts notes secs) (slime-highlight-notes notes))) - (let* ((locations (mapcar (lambda (n) (getf n :location)) notes)) - (files (remove-duplicates - (mapcar (lambda (l) - (let ((f (assq :file (cdr l)))) - (and f (cadr f)))) - locations) - :test 'equal))) - ;; we need a better way of showing the resulting notes if there - ;; was >1 of them - ;; (slime-show-definitions "Compiler notes" locations) - (message "files with notes: %s" files) ))) + (let ((xrefs (slime-xrefs-for-notes notes))) + (when (> (length xrefs) 1) ; >1 file + (slime-show-xrefs + xrefs 'definition "Compiler notes" (slime-buffer-package)))))) (defun slime-compilation-finished-continuation () (lexical-let ((buffer (current-buffer))) From dbarlow at common-lisp.net Thu Dec 11 06:59:07 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 11 Dec 2003 01:59:07 -0500 Subject: [slime-cvs] CVS update: slime/b0rk.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12239 Added Files: b0rk.lisp Log Message: source-path-file-position broken Date: Thu Dec 11 01:59:07 2003 Author: dbarlow From e9626484 at stud3.tuwien.ac.at Thu Dec 11 07:51:14 2003 From: e9626484 at stud3.tuwien.ac.at (Helmut Eller) Date: Thu, 11 Dec 2003 08:51:14 +0100 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp In-Reply-To: (Dan Barlow's message of "Wed, 10 Dec 2003 21:19:51 -0500") References: Message-ID: Dan Barlow writes: > + ;; XXX is this _ever_ used? By what? *compile-file-truename* > + ;; should be set by the implementation inside any call to compile-file This is mostly used when a compilation condition is signaled at the end of a compilation unit, e.g, "those function are undefined" and also for notes about missing exported symbols in a defpackage form. The same situation occurs in SBCL with the "redefining function " style warnings. Set a breakpoint at this location to see the details. Helmut. From dbarlow at common-lisp.net Thu Dec 11 16:37:33 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 11 Dec 2003 11:37:33 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10371 Modified Files: ChangeLog slime.el swank-sbcl.lisp Log Message: * swank-sbcl.lisp (compiler-note-location): replace with thinly-ported version from the CMUCL backend which understands :lisp as a pathname * slime.el (slime-xrefs-for-notes): a little more temporary variables, a little less cdr. Should be slightly faster on big systems (slime-goto-next-xref): set window point as well as buffer point - now works in GNU Emacs 21.2.1 Date: Thu Dec 11 11:37:32 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.150 slime/ChangeLog:1.151 --- slime/ChangeLog:1.150 Wed Dec 10 23:57:33 2003 +++ slime/ChangeLog Thu Dec 11 11:37:31 2003 @@ -1,5 +1,15 @@ 2003-12-11 Daniel Barlow + * swank-sbcl.lisp (compiler-note-location): replace with + thinly-ported version from the CMUCL backend which understands + :lisp as a pathname + + * slime.el (slime-xrefs-for-notes): a little more temporary + variables, a little less cdr. Should be slightly faster on + big systems + (slime-goto-next-xref): set window point as well as buffer point - + now works in GNU Emacs 21.2.1 + * swank.lisp (swank-compiler): new function abstracts commonality between swank-compile-{file, string}. (swank-load-system): call swank-compiler to load asdf system Index: slime/slime.el diff -u slime/slime.el:1.139 slime/slime.el:1.140 --- slime/slime.el:1.139 Wed Dec 10 23:57:33 2003 +++ slime/slime.el Thu Dec 11 11:37:32 2003 @@ -2086,22 +2086,23 @@ (if secs (format "[%s secs]" secs) "")))) (defun slime-xrefs-for-notes (notes) - (flet ((note-file (n) (cadr (assq :file (cdr (getf n :location)))))) - (let ((xrefs)) - (dolist (note notes) - (let ((file (assoc (note-file note) xrefs)) - (node - (cons (format "%s: %s" - (getf note :severity) - (replace-regexp-in-string - "[^[:graph:]]+" " " - (subseq (getf note :message) 0 ))) - (getf note :location)))) - (when (note-file note) - (if file - (push node (cdr file)) - (setf xrefs (acons (note-file note) (list node) xrefs)))))) - xrefs))) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (getf n :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (cons (format "%s: %s" + (getf note :severity) + (replace-regexp-in-string + "[^[:graph:]]+" " " + (subseq (getf note :message) 0 ))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (acons fn (list node) xrefs)))))) + xrefs)) (defun slime-compilation-finished (result buffer) (let ((notes (slime-compiler-notes))) @@ -3331,9 +3332,10 @@ (defun slime-goto-next-xref () "Goto the next cross-reference location." (let ((location (with-current-buffer (slime-xref-buffer) - (display-buffer (current-buffer) t) - (goto-char (next-single-char-property-change - (point) 'slime-location)) + (let ((w (display-buffer (current-buffer) t))) + (goto-char (1+ (next-single-char-property-change + (point) 'slime-location))) + (set-window-point w (point))) (cond ((eobp) (message "No more xrefs.") nil) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.41 slime/swank-sbcl.lisp:1.42 --- slime/swank-sbcl.lisp:1.41 Wed Dec 10 21:20:13 2003 +++ slime/swank-sbcl.lisp Thu Dec 11 11:37:32 2003 @@ -159,7 +159,7 @@ (princ-to-string arglist) "(-- )"))))) -(defvar *buffername* nil) +(defvar *buffer-name* nil) (defvar *buffer-offset*) (defvar *previous-compiler-condition* nil @@ -189,31 +189,50 @@ :location (compiler-note-location context)))) (defun compiler-note-location (context) - "Determine from CONTEXT the current compiler source location." - (multiple-value-bind (file-name file-pos source-path) - (if context - (values - (sb-c::compiler-error-context-file-name context) - (sb-c::compiler-error-context-file-position context) - (current-compiler-error-source-path context))) - (cond (*buffername* - ;; account for the added lambda, replace leading - ;; position with 0 - (make-location - (list :buffer *buffername*) - (list :source-path (cons 0 (cddr source-path)) *buffer-offset*))) - (file-name - (etypecase file-name - (pathname - (make-location - (list :file (namestring (truename file-name))) - (list :source-path source-path file-pos))))) - (*compile-file-truename* - (make-location - (list :file (namestring *compile-file-truename*)) - (list :source-path '(0) 1))) - (t - (list :error "No source location"))))) + (cond (context + (resolve-note-location + *buffer-name* + (sb-c::compiler-error-context-file-name context) + (sb-c::compiler-error-context-file-position context) + (current-compiler-error-source-path context) + (sb-c::compiler-error-context-original-source context))) + (t + (resolve-note-location *buffer-name* nil nil nil nil)))) + +(defgeneric resolve-note-location (buffer file-name file-position + source-path source)) + +(defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source) + (make-location + `(:file ,(truename f)) + `(:position ,(1+ (source-path-file-position path f))))) + +;;; FIXME this one's broken: no source-path-string-position +(defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source) + (make-location + `(:buffer ,b) + `(:position ,(+ *buffer-offset* + (source-path-string-position path *buffer-substring*))))) + +(defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string)) + (make-location + `(:source-form ,source) + `(:position 1))) + +(defmethod resolve-note-location (buffer + (file (eql nil)) + (pos (eql nil)) + (path (eql nil)) + (source (eql nil))) + (cond (buffer + (make-location (list :buffer buffer) + (list :position *buffer-offset*))) + (*compile-file-truename* + (make-location (list :file (namestring *compile-file-truename*)) + (list :position 0))) + (t + (list :error "No error location available")))) + (defun brief-compiler-message-for-emacs (condition error-context) "Briefly describe a compiler error for Emacs. @@ -261,7 +280,7 @@ (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () (let ((*package* *buffer-package*) - (*buffername* buffer) + (*buffer-name* buffer) (*buffer-offset* position)) (eval (from-string (format nil "(funcall (compile nil '(lambda () ~A)))" From dbarlow at common-lisp.net Thu Dec 11 17:08:56 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 11 Dec 2003 12:08:56 -0500 Subject: [slime-cvs] CVS update: slime/slime.el slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23240 Modified Files: slime.el swank-sbcl.lisp Log Message: unbroke last commit, in two obvious respects Date: Thu Dec 11 12:08:56 2003 Author: dbarlow Index: slime/slime.el diff -u slime/slime.el:1.140 slime/slime.el:1.141 --- slime/slime.el:1.140 Thu Dec 11 11:37:32 2003 +++ slime/slime.el Thu Dec 11 12:08:55 2003 @@ -2088,7 +2088,7 @@ (defun slime-xrefs-for-notes (notes) (let ((xrefs)) (dolist (note notes) - (let* ((location (getf n :location)) + (let* ((location (getf note :location)) (fn (cadr (assq :file (cdr location)))) (file (assoc fn xrefs)) (node Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.42 slime/swank-sbcl.lisp:1.43 --- slime/swank-sbcl.lisp:1.42 Thu Dec 11 11:37:32 2003 +++ slime/swank-sbcl.lisp Thu Dec 11 12:08:55 2003 @@ -204,7 +204,7 @@ (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source) (make-location - `(:file ,(truename f)) + `(:file ,(namestring (truename f))) `(:position ,(1+ (source-path-file-position path f))))) ;;; FIXME this one's broken: no source-path-string-position From luke at bluetail.com Thu Dec 11 18:44:12 2003 From: luke at bluetail.com (Luke Gorrie) Date: Thu, 11 Dec 2003 18:44:12 -0000 Subject: [slime-cvs] CVS update: slime/b0rk.lisp In-Reply-To: References: Message-ID: Dan Barlow writes: > Added Files: > b0rk.lisp > Log Message: > source-path-file-position broken > Date: Thu Dec 11 01:59:07 2003 > Author: dbarlow I'm guessing this was an accident :-) From lgorrie at common-lisp.net Thu Dec 11 19:31:46 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 11 Dec 2003 14:31:46 -0500 Subject: [slime-cvs] CVS update: slime/slime.el slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21994 Modified Files: slime.el ChangeLog Log Message: (slime-xrefs-for-notes): Commented out use of `replace-regexp-in-string' (not available in emacs20, and not sure why we need it?) Date: Thu Dec 11 14:31:46 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.141 slime/slime.el:1.142 --- slime/slime.el:1.141 Thu Dec 11 12:08:55 2003 +++ slime/slime.el Thu Dec 11 14:31:45 2003 @@ -2094,10 +2094,14 @@ (node (cons (format "%s: %s" (getf note :severity) - (replace-regexp-in-string - "[^[:graph:]]+" " " - (subseq (getf note :message) 0 ))) + (getf note :message)) location))) + ;; emacs20 doesn't have `replace-regexp-in-string' + ;; but who gives us non-printable characters anyway and why? -luke +; (replace-regexp-in-string +; "[^[:graph:]]+" " " +; (subseq (getf note :message) 0 ))) +; location))) (when fn (if file (push node (cdr file)) Index: slime/ChangeLog diff -u slime/ChangeLog:1.151 slime/ChangeLog:1.152 --- slime/ChangeLog:1.151 Thu Dec 11 11:37:31 2003 +++ slime/ChangeLog Thu Dec 11 14:31:45 2003 @@ -1,3 +1,9 @@ +2003-12-11 Luke Gorrie + + * slime.el (slime-xrefs-for-notes): Commented out use of + `replace-regexp-in-string' (not available in emacs20, and not sure + why we need it?) + 2003-12-11 Daniel Barlow * swank-sbcl.lisp (compiler-note-location): replace with From lgorrie at common-lisp.net Fri Dec 12 01:51:30 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 11 Dec 2003 20:51:30 -0500 Subject: [slime-cvs] CVS update: slime/slime.el slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9975 Modified Files: slime.el ChangeLog Log Message: (slime-one-line-ify): New function to convert multi-line strings to one-liners by replacing any newline followed by indentation by a single space. (slime-xrefs-for-notes): Use it. Date: Thu Dec 11 20:51:29 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.142 slime/slime.el:1.143 --- slime/slime.el:1.142 Thu Dec 11 14:31:45 2003 +++ slime/slime.el Thu Dec 11 20:51:29 2003 @@ -2094,19 +2094,23 @@ (node (cons (format "%s: %s" (getf note :severity) - (getf note :message)) + (slime-one-line-ify (getf note :message))) location))) - ;; emacs20 doesn't have `replace-regexp-in-string' - ;; but who gives us non-printable characters anyway and why? -luke -; (replace-regexp-in-string -; "[^[:graph:]]+" " " -; (subseq (getf note :message) 0 ))) -; location))) (when fn (if file (push node (cdr file)) (setf xrefs (acons fn (list node) xrefs)))))) xrefs)) + +(defun slime-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) (defun slime-compilation-finished (result buffer) (let ((notes (slime-compiler-notes))) Index: slime/ChangeLog diff -u slime/ChangeLog:1.152 slime/ChangeLog:1.153 --- slime/ChangeLog:1.152 Thu Dec 11 14:31:45 2003 +++ slime/ChangeLog Thu Dec 11 20:51:29 2003 @@ -1,8 +1,9 @@ 2003-12-11 Luke Gorrie - * slime.el (slime-xrefs-for-notes): Commented out use of - `replace-regexp-in-string' (not available in emacs20, and not sure - why we need it?) + * slime.el (slime-one-line-ify): New function to convert + multi-line strings to one-liners by replacing any newline + followed by indentation by a single space. + (slime-xrefs-for-notes): Use it. 2003-12-11 Daniel Barlow From dbarlow at common-lisp.net Fri Dec 12 03:22:36 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 11 Dec 2003 22:22:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank-cmucl.lisp slime/swank-loader.lisp slime/swank-sbcl.lisp slime/b0rk.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9576 Modified Files: ChangeLog swank-cmucl.lisp swank-loader.lisp swank-sbcl.lisp Removed Files: b0rk.lisp Log Message: * swank-source-path-parser.lisp: new file, excerpting part of swank-cmucl.lisp to where SBCL can find it as well. Date: Thu Dec 11 22:22:36 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.153 slime/ChangeLog:1.154 --- slime/ChangeLog:1.153 Thu Dec 11 20:51:29 2003 +++ slime/ChangeLog Thu Dec 11 22:22:36 2003 @@ -1,3 +1,8 @@ +2003-12-12 Daniel Barlow + + * swank-source-path-parser.lisp: new file, excerpting part of + swank-cmucl.lisp to where SBCL can find it as well. + 2003-12-11 Luke Gorrie * slime.el (slime-one-line-ify): New function to convert Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.38 slime/swank-cmucl.lisp:1.39 --- slime/swank-cmucl.lisp:1.38 Wed Dec 10 21:19:51 2003 +++ slime/swank-cmucl.lisp Thu Dec 11 22:22:36 2003 @@ -848,108 +848,8 @@ (setf *default-pathname-defaults* (pathname (ext:default-directory))) (namestring (ext:default-directory))) - -;;;; Source-paths - -;;; CMUCL uses a data structure called "source-path" to locate -;;; subforms. The compiler assigns a source-path to each form in a -;;; compilation unit. Compiler notes usually contain the source-path -;;; of the error location. -;;; -;;; Compiled code objects don't contain source paths, only the -;;; "toplevel-form-number" and the (sub-) "form-number". To get from -;;; the form-number to the source-path we need the entire toplevel-form -;;; (i.e. we have to read the source code). CMUCL has already some -;;; utilities to do this translation, but we use some extended -;;; versions, because we need more exact position info. Apparently -;;; Hemlock is happy with the position of the toplevel-form; we also -;;; need the position of subforms. -;;; -;;; We use a special readtable to get the positions of the subforms. -;;; The readtable stores the start and end position for each subform in -;;; hashtable for later retrieval. - -(defun make-source-recorder (fn source-map) - "Return a macro character function that does the same as FN, but -additionally stores the result together with the stream positions -before and after of calling FN in the hashtable SOURCE-MAP." - (lambda (stream char) - (let ((start (file-position stream)) - (values (multiple-value-list (funcall fn stream char))) - (end (file-position stream))) - #+(or) (format t "~&[~D ~{~A~^, ~} ~D]~%" start values end) - (unless (null values) - (push (cons start end) (gethash (car values) source-map))) - (values-list values)))) - -(defun make-source-recording-readtable (readtable source-map) - "Return a source position recording copy of READTABLE. -The source locations are stored in SOURCE-MAP." - (let* ((tab (copy-readtable readtable)) - (*readtable* tab)) - (dotimes (code char-code-limit) - (let ((char (code-char code))) - (multiple-value-bind (fn term) (get-macro-character char tab) - (when fn - (set-macro-character char (make-source-recorder fn source-map) - term tab))))) - tab)) - -(defun make-source-map () - (make-hash-table :test #'eq)) - -(defvar *source-map* (make-source-map) - "The hashtable table used for source position recording.") - -(defvar *recording-readtable-cache* '() - "An alist of (READTABLE . RECORDING-READTABLE) pairs.") - -(defun lookup-recording-readtable (readtable) - "Find a cached or create a new recording readtable for READTABLE." - (or (cdr (assoc readtable *recording-readtable-cache*)) - (let ((table (make-source-recording-readtable readtable *source-map*))) - (push (cons readtable table) *recording-readtable-cache*) - table))) - -(defun read-and-record-source-map (stream) - "Read the next object from STREAM. -Return the object together with a hashtable that maps -subexpressions of the object to stream positions." - (let ((*readtable* (lookup-recording-readtable *readtable*))) - (clrhash *source-map*) - (values (read stream) *source-map*))) - -(defun source-path-stream-position (path stream) - "Search the source-path PATH in STREAM and return its position." - (destructuring-bind (tlf-number . path) path - (let ((*read-suppress* t)) - (dotimes (i tlf-number) (read stream)) - (multiple-value-bind (form source-map) - (read-and-record-source-map stream) - (source-path-source-position (cons 0 path) form source-map))))) - -(defun source-path-string-position (path string) - (with-input-from-string (s string) - (source-path-stream-position path s))) - -(defun source-path-file-position (path filename) - (with-open-file (file filename) - (source-path-stream-position path file))) - -(defun source-path-source-position (path form source-map) - "Return the start position of PATH form FORM and SOURCE-MAP. All -subforms along the path are considered and the start and end position -of deepest (i.e. smallest) possible form is returned." - ;; compute all subforms along path - (let ((forms (loop for n in path - for f = form then (nth n f) - collect f))) - ;; select the first subform present in source-map - (loop for form in (reverse forms) - for positions = (gethash form source-map) - until (and positions (null (cdr positions))) - finally (destructuring-bind ((start . end)) positions - (return (values (1- start) end)))))) +;;; source-path-{stream,file,string,etc}-position moved into +;;; swank-source-path-parser (defun code-location-stream-position (code-location stream) "Return the byte offset of CODE-LOCATION in STREAM. Extract the Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.7 slime/swank-loader.lisp:1.8 --- slime/swank-loader.lisp:1.7 Sat Dec 6 08:08:52 2003 +++ slime/swank-loader.lisp Thu Dec 11 22:22:36 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.7 2003/12/06 13:08:52 heller Exp $ +;;; $Id: swank-loader.lisp,v 1.8 2003/12/12 03:22:36 dbarlow Exp $ ;;; (defpackage :swank-loader @@ -27,8 +27,8 @@ (defparameter *sysdep-pathnames* (mapcar #'make-swank-pathname - #+cmu '("swank-cmucl") - #+sbcl '("swank-sbcl" "swank-gray") + #+cmu '("swank-cmucl" "swank-source-path-parser") + #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray") #+openmcl '("swank-openmcl" "swank-gray") #+lispworks '("swank-lispworks" "swank-gray") #+allegro '("swank-allegro" "swank-gray") Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.43 slime/swank-sbcl.lisp:1.44 --- slime/swank-sbcl.lisp:1.43 Thu Dec 11 12:08:55 2003 +++ slime/swank-sbcl.lisp Thu Dec 11 22:22:36 2003 @@ -188,6 +188,8 @@ :message (brief-compiler-message-for-emacs condition context) :location (compiler-note-location context)))) + + (defun compiler-note-location (context) (cond (context (resolve-note-location @@ -207,7 +209,6 @@ `(:file ,(namestring (truename f))) `(:position ,(1+ (source-path-file-position path f))))) -;;; FIXME this one's broken: no source-path-string-position (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source) (make-location `(:buffer ,b) @@ -505,14 +506,7 @@ (path (code-location-source-path code-location))) (source-path-file-position path filename))) -(defun source-path-file-position (path filename) - (let ((*read-suppress* t)) - (with-open-file (file filename) - (dolist (n path) - (dotimes (i n) - (read file)) - (read-delimited-list #\( file)) - (file-position file)))) +;;; source-path-file-position and friends are in swank-source-path-parser (defun debug-source-info-from-emacs-buffer-p (debug-source) (let ((info (sb-c::debug-source-info debug-source))) From dbarlow at common-lisp.net Fri Dec 12 04:54:42 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Thu, 11 Dec 2003 23:54:42 -0500 Subject: [slime-cvs] CVS update: slime/swank-source-path-parser.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11027 Added Files: swank-source-path-parser.lisp Log Message: it might work better if this file were actually committed Date: Thu Dec 11 23:54:42 2003 Author: dbarlow From heller at common-lisp.net Fri Dec 12 11:11:37 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 06:11:37 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14847 Modified Files: slime.el Log Message: (slime-repl-current-input): Don't remove the final newline only if we are in reading state. (slime-goto-source-location): Regex-quote the function name and handle package prefixes. Reported by Alan Ruttenberg. Date: Fri Dec 12 06:11:37 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.143 slime/slime.el:1.144 --- slime/slime.el:1.143 Thu Dec 11 20:51:29 2003 +++ slime/slime.el Fri Dec 12 06:11:37 2003 @@ -1642,10 +1642,10 @@ (buffer-substring-no-properties slime-repl-input-start-mark (save-excursion (goto-char slime-repl-input-end-mark) - (when (eq (char-before) ?\n) + (when (and (eq (char-before) ?\n) + (not (slime-reading-p))) (backward-char 1)) (point)))) - (defun slime-repl-add-to-input-history (string) (when (and (plusp (length string)) @@ -2299,8 +2299,10 @@ (slime-forward-sexp) (beginning-of-sexp))) ((:function-name name) - (let ((case-fold-search t)) - (re-search-forward (format "^(\\(def.*[ \n\t(]\\)?%s[ \t)]" name))) + (let ((case-fold-search t) + (name (regexp-quote name))) + (re-search-forward + (format "^(\\(def.*[ \n\t(]\\([a-z]+:\\)?\\)?%s[ \t)]" name))) (goto-char (match-beginning 0))) ((:source-path source-path start-position) (cond (start-position From heller at common-lisp.net Fri Dec 12 11:13:08 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 06:13:08 -0500 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15020 Modified Files: swank-loader.lisp Log Message: (user-init-file): Use homedir's truename. Reported by Friedrich Dominicus. Date: Fri Dec 12 06:13:07 2003 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.8 slime/swank-loader.lisp:1.9 --- slime/swank-loader.lisp:1.8 Thu Dec 11 22:22:36 2003 +++ slime/swank-loader.lisp Fri Dec 12 06:13:07 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.8 2003/12/12 03:22:36 dbarlow Exp $ +;;; $Id: swank-loader.lisp,v 1.9 2003/12/12 11:13:07 heller Exp $ ;;; (defpackage :swank-loader @@ -27,7 +27,7 @@ (defparameter *sysdep-pathnames* (mapcar #'make-swank-pathname - #+cmu '("swank-cmucl" "swank-source-path-parser") + #+cmu '("swank-source-path-parser" "swank-cmucl") #+sbcl '("swank-sbcl" "swank-source-path-parser" "swank-gray") #+openmcl '("swank-openmcl" "swank-gray") #+lispworks '("swank-lispworks" "swank-gray") @@ -64,11 +64,12 @@ (defun user-init-file () "Return the name of the user init file or nil." - (let ((filename (format nil "~A/.swank.lisp" - (namestring (translate-logical-pathname - (user-homedir-pathname)))))) - (cond ((probe-file filename) filename) - (t nil)))) + (let ((home (user-homedir-pathname))) + (when (probe-file home) + (let ((filename (format nil "~A/.swank.lisp" + (namestring (truename home))))) + (cond ((probe-file filename) filename) + (t nil)))))) (compile-files-if-needed-serially (list* (make-swank-pathname "swank-backend") *swank-pathname* From heller at common-lisp.net Fri Dec 12 11:18:21 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 06:18:21 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16990 Modified Files: swank-openmcl.lisp Log Message: (toggle-trace-fdefinition, tracedp): Implement trace command. Patch by Alan Ruttenberg. (find-function-locations, find-source-locations): Handle variables, and method-combinations. General cleanups. (source-info-first-file-name): Removed. (list-callers): Fixed. Date: Fri Dec 12 06:18:21 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.29 slime/swank-openmcl.lisp:1.30 --- slime/swank-openmcl.lisp:1.29 Wed Dec 10 08:26:08 2003 +++ slime/swank-openmcl.lisp Fri Dec 12 06:18:21 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.29 2003/12/10 13:26:08 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.30 2003/12/12 11:18:21 heller Exp $ ;;; ;;; @@ -87,10 +87,7 @@ server-socket))) (defun swank-accept-connection (server-socket) - "Accept one Swank TCP connection on SOCKET and then close it. -Run the connection handler in a new thread." - (let ((socket (ccl:accept-connection server-socket :wait t))) - (request-loop socket))) + (request-loop (ccl:accept-connection server-socket :wait t))) (defun request-loop (*emacs-io*) "Thread function for a single Swank connection. Processes requests @@ -315,26 +312,48 @@ (declare (ignore index)) nil) -(defun source-info-first-file-name (info) - (etypecase info - ((or pathname string) (namestring (truename info))) - (cons - (etypecase (car info) - (cons (source-info-first-file-name (car info))) - (standard-method (source-info-first-file-name (cdr info))) - ((member function) (source-info-first-file-name (cdr info))) - ((member method) (source-info-first-file-name (cdr info))) - ((or pathname string) (namestring (truename (car info)))))))) +(defun find-source-locations (symbol name) + (let* ((info (ccl::source-file-or-files symbol nil nil nil)) + (locations '())) + (labels ((frob (pathname position) + (multiple-value-bind (truename c) + (ignore-errors (truename pathname)) + (cond (c + (push (list :error (princ-to-string c)) locations)) + (t + (push (make-location (list :file (namestring truename)) + position) + locations))))) + (frob* (list position) + (etypecase list + (cons (dolist (file list) (frob file position))) + ((or string pathname) (frob list position))))) + (etypecase info + (null (return-from find-source-locations + (list + (list :error + (format nil "No source info available for ~A" + symbol))))) + ((or string pathname) (frob info (list :function-name name))) + (cons + (dolist (i info) + (typecase (car i) + ((member method) + (loop for (m . files) in (cdr i) + do (frob* files (list :function-name name)))) + ((member function variable method-combination) + (frob* (cdr i) (list :function-name name))) + (t (list :error "Cannot resolve source info: ~A" info))))))) + locations)) + +(defmethod find-function-locations (fname) + (let ((symbol (from-string fname))) + (find-source-locations symbol (symbol-name symbol)))) (defun function-source-location (symbol) "Return a plist containing a source location for the function named SYMBOL." - (let ((source-info (ccl::source-file-or-files symbol nil nil nil))) - (if source-info - (make-location - (list :file (source-info-first-file-name source-info)) - (list :function-name (symbol-name symbol))) - (list :error (format nil "No source infor for ~S" symbol))))) + (car (find-source-locations symbol (string symbol)))) (defmethod frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the @@ -387,65 +406,40 @@ ;;; Tracing and Disassembly -(defslimefun who-calls (symbol-name) - (let ((callers (ccl::callers symbol-name)) - (result (make-hash-table :test 'equalp)) - (list nil)) - (dolist (caller callers) - (let ((source-info (ccl::%source-files caller))) - (when (and source-info (atom source-info)) - (let ((filename (namestring (truename source-info))) - ;; This is clearly not the real source path but it will - ;; get us into the file at least... - (source-path '(0))) - (push (list (string caller) source-path) - (gethash filename result)))))) - (maphash #'(lambda (k v) - (push (cons k (list v)) list)) - result) - list)) +(defun tracedp (fname) + (ccl::%traced-p fname)) + +(defslimefun toggle-trace-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + (cond ((tracedp fname) + (ccl::%untrace-1 fname) + (format nil "~S is now untraced." fname)) + (t + (ccl::%trace-0 (list fname)) + (format nil "~S is now traced." fname))))) + +;;; XREF + +(defslimefun list-callers (symbol-name) + (let ((callers (ccl::callers (from-string symbol-name)))) + (group-xrefs + (mapcan (lambda (caller) + (mapcar (lambda (loc) (cons (to-string caller) loc)) + (typecase caller + (symbol + (find-source-locations caller (symbol-name caller))) + (method + (let ((n (ccl:method-name caller))) + (find-source-locations n (symbol-name n)))) + (t + (find-source-locations caller (to-string caller)))))) + callers)))) +(defslimefun-unimplemented who-calls (symbol-name)) (defslimefun-unimplemented who-references (symbol-name package-name)) (defslimefun-unimplemented who-binds (symbol-name package-name)) (defslimefun-unimplemented who-sets (symbol-name package-name)) (defslimefun-unimplemented who-macroexpands (symbol-name package-name)) - -(defslimefun-unimplemented find-fdefinition (symbol-name package-name)) - -(defmethod find-function-locations (fname) - (let* ((symbol (from-string fname)) - (symbol-name (string symbol)) - (info (ccl::source-file-or-files symbol nil nil nil)) - (locations '())) - (labels ((frob (pathname position) - (multiple-value-bind (truename c) (truename pathname) - (cond (c - (push (list :error (princ-to-string c)) locations)) - (t - (push (make-location (list :file (namestring truename)) - position) - locations))))) - (frob* (list position) - (etypecase list - (cons (dolist (file list) (frob file position))) - ((or string pathname) (frob list position))))) - (etypecase info - (null (return-from find-function-locations - (list - (list :error - (format nil "No source info available for ~A" fname))))) - ((or string pathname) (frob info (list :function-name fname))) - (cons - (dolist (i info) - (etypecase (car i) - ((member method) - (loop for (m . files) in (cdr i) - do (frob* files - (list :function-name symbol-name)))) - ((member function) - (frob* (cdr i) - (list :function-name fname)))))))) - locations)) ;;; Macroexpansion (defslimefun-unimplemented swank-macroexpand-all (string)) From heller at common-lisp.net Fri Dec 12 11:21:34 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 06:21:34 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18540 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Dec 12 06:21:33 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.154 slime/ChangeLog:1.155 --- slime/ChangeLog:1.154 Thu Dec 11 22:22:36 2003 +++ slime/ChangeLog Fri Dec 12 06:21:33 2003 @@ -1,3 +1,20 @@ +2003-12-12 Helmut Eller + + * swank-openmcl.lisp (toggle-trace-fdefinition, tracedp): + Implement trace command. Patch by Alan Ruttenberg. + (find-function-locations, find-source-locations): Handle + variables, and method-combinations. General cleanups. + (source-info-first-file-name): Removed. + (list-callers): Fixed. + + * swank-loader.lisp (user-init-file): Use homedir's truename. + Reported by Friedrich Dominicus. + + * slime.el (slime-repl-current-input): Don't remove the final + newline only if we are in reading state. + (slime-goto-source-location): Regex-quote the function-name and + handle package prefixes. Reported by Alan Ruttenberg. + 2003-12-12 Daniel Barlow * swank-source-path-parser.lisp: new file, excerpting part of From heller at common-lisp.net Fri Dec 12 12:38:23 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 07:38:23 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14684 Modified Files: swank-openmcl.lisp Log Message: (list-callers): method-name is not exported in 0.14. Fix by Marco Baringer. Date: Fri Dec 12 07:38:23 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.30 slime/swank-openmcl.lisp:1.31 --- slime/swank-openmcl.lisp:1.30 Fri Dec 12 06:18:21 2003 +++ slime/swank-openmcl.lisp Fri Dec 12 07:38:23 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.30 2003/12/12 11:18:21 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.31 2003/12/12 12:38:23 heller Exp $ ;;; ;;; @@ -429,7 +429,7 @@ (symbol (find-source-locations caller (symbol-name caller))) (method - (let ((n (ccl:method-name caller))) + (let ((n (ccl::method-name caller))) (find-source-locations n (symbol-name n)))) (t (find-source-locations caller (to-string caller)))))) From heller at common-lisp.net Fri Dec 12 12:41:16 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 07:41:16 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16201 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Dec 12 07:41:16 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.155 slime/ChangeLog:1.156 --- slime/ChangeLog:1.155 Fri Dec 12 06:21:33 2003 +++ slime/ChangeLog Fri Dec 12 07:41:16 2003 @@ -6,6 +6,8 @@ variables, and method-combinations. General cleanups. (source-info-first-file-name): Removed. (list-callers): Fixed. + (list-callers): Fixed some more. method-name is not exported in + 0.14. From Marco Baringer. * swank-loader.lisp (user-init-file): Use homedir's truename. Reported by Friedrich Dominicus. From heller at common-lisp.net Fri Dec 12 22:47:24 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 17:47:24 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3263 Modified Files: swank-openmcl.lisp Log Message: (swank-accept-connection): Accept multiple connections. Patch by Marco Baringer. Date: Fri Dec 12 17:47:24 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.31 slime/swank-openmcl.lisp:1.32 --- slime/swank-openmcl.lisp:1.31 Fri Dec 12 07:38:23 2003 +++ slime/swank-openmcl.lisp Fri Dec 12 17:47:24 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.31 2003/12/12 12:38:23 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.32 2003/12/12 22:47:24 heller Exp $ ;;; ;;; @@ -87,7 +87,7 @@ server-socket))) (defun swank-accept-connection (server-socket) - (request-loop (ccl:accept-connection server-socket :wait t))) + (loop (request-loop (ccl:accept-connection server-socket :wait t)))) (defun request-loop (*emacs-io*) "Thread function for a single Swank connection. Processes requests @@ -434,6 +434,8 @@ (t (find-source-locations caller (to-string caller)))))) callers)))) + +(defslimefun-unimplemented list-callees (symbol-name)) (defslimefun-unimplemented who-calls (symbol-name)) (defslimefun-unimplemented who-references (symbol-name package-name)) From heller at common-lisp.net Fri Dec 12 22:52:02 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 17:52:02 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5208 Modified Files: swank-cmucl.lisp Log Message: (create-swank-server): New keyword arguments to control the server: BACKGROUND and CLOSE. fd-handlers are used if BACKGROUND is true. If close CLOSE is true close the socket after the first connection; keep it open otherwise. *start-swank-in-background*, *close-swank-socket-after-setup*: The default values of corresponding arguments for create-swank-server. (compile-file-for-emacs): Don't load the fasl-file the compile failed. Date: Fri Dec 12 17:52:02 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.39 slime/swank-cmucl.lisp:1.40 --- slime/swank-cmucl.lisp:1.39 Thu Dec 11 22:22:36 2003 +++ slime/swank-cmucl.lisp Fri Dec 12 17:52:02 2003 @@ -26,27 +26,79 @@ (address (car (ext:host-entry-addr-list hostent)))) (ext:htonl address))) +(defvar *start-swank-in-background* t) +(defvar *close-swank-socket-after-setup* t) +(defvar *use-dedicated-output-stream* t) + (defun create-swank-server (port &key (reuse-address t) (address "localhost") - (announce #'simple-announce-function)) + (announce #'simple-announce-function) + (background *start-swank-in-background*) + (close *close-swank-socket-after-setup*)) "Create a SWANK TCP server." (let* ((ip (resolve-hostname address)) (fd (ext:create-inet-listener port :stream :reuse-address reuse-address :host ip))) (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd))) - (accept-connection fd))) + (accept-loop fd background close))) + +(defun emacs-io (fd) + "Create a new fd-stream for fd." + (sys:make-fd-stream fd :input t :output t :element-type 'base-char)) + +(defun add-input-handler (fd fn) + (system:add-fd-handler fd :input fn)) + +(defun accept-loop (fd background close) + "Accept clients on the the server socket FD. +Use fd-handlers if BACKGROUND is non-nil. Close the server socket after the first client if CLOSE is non-nil, " + (cond (background + (add-input-handler + fd (lambda (fd) (accept-one-client fd background close)))) + (close + (accept-one-client fd background close)) + (t + (loop (accept-one-client fd background close))))) -(defun accept-connection (socket) - "Accept one Swank TCP connection on SOCKET and then close it." - (let* ((fd (ext:accept-tcp-connection socket)) - (stream (sys:make-fd-stream fd :input t :output t - :element-type 'base-char))) - (sys:invalidate-descriptor socket) - (unix:unix-close socket) - (request-loop stream))) +(defun accept-one-client (socket background close) + (let ((fd (ext:accept-tcp-connection socket))) + (when close + (sys:invalidate-descriptor socket) + (unix:unix-close socket)) + (request-loop fd background))) + +(defun request-loop (fd background) + "Process all request from the socket FD." + (let* ((stream (emacs-io fd)) + (out (if *use-dedicated-output-stream* + (open-stream-to-emacs stream) + (make-slime-output-stream))) + (in (make-slime-input-stream)) + (io (make-two-way-stream in out))) + (cond (background + (add-input-handler + fd (lambda (fd) + (declare (ignore fd)) + (serve-one-request stream out in io)))) + (t (do () ((serve-one-request stream out in io))))))) + +(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) + "Read and process one request from a SWANK client. +The request is read from the socket as a sexp and then evaluated. +Return non-nil iff a reader-error occured." + (catch 'slime-toplevel + (with-simple-restart (abort "Return to Slime toplevel.") + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) + (close *emacs-io*) + (return-from serve-one-request t))))) + nil) -(defun open-stream-to-emacs () +(defun open-stream-to-emacs (*emacs-io*) "Return an output-stream to Emacs' output buffer." (let* ((ip (resolve-hostname "localhost")) (listener (ext:create-inet-listener 0 :stream :host ip)) @@ -58,29 +110,6 @@ (sys:make-fd-stream fd :output t))) (ext:close-socket listener)))) -(defvar *use-dedicated-output-stream* t) - -(defun request-loop (*emacs-io*) - "Processes requests until the remote Emacs goes away." - (unwind-protect - (let* ((*slime-output* (if *use-dedicated-output-stream* - (open-stream-to-emacs) - (make-slime-output-stream))) - (*slime-input* (make-slime-input-stream)) - (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) - (loop - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime toplevel.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (return))))) - (sys:scrub-control-stack))) - (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) - (close *emacs-io*))) - ;;;; Stream handling @@ -294,7 +323,11 @@ (with-compilation-hooks () (let ((*buffer-name* nil) (*compile-filename* filename)) - (compile-file filename :load load-p)))) + (multiple-value-bind (fasl-file warnings-p failure-p) + (compile-file filename) + (declare (ignore warnings-p)) + (when (and load-p (not failure-p)) + (load fasl-file)))))) (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () From heller at common-lisp.net Fri Dec 12 22:52:57 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 17:52:57 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5373 Modified Files: slime.el Log Message: (slime-output-string): Insert asynchronous output before the prompt. Date: Fri Dec 12 17:52:57 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.144 slime/slime.el:1.145 --- slime/slime.el:1.144 Fri Dec 12 06:11:37 2003 +++ slime/slime.el Fri Dec 12 17:52:56 2003 @@ -1557,9 +1557,18 @@ (defun slime-output-string (string) (with-current-buffer (slime-output-buffer) - (slime-mark-input-end) - (slime-with-output-at-eob - (insert string)))) + (cond ((slime-idle-p) + ;; asynchrounous output + (save-excursion + (goto-char slime-repl-prompt-start-mark) + (slime-insert-propertized + (list 'face 'slime-repl-output-face) + string "\n") + (set-marker slime-repl-prompt-start-mark (point)))) + (t + (slime-mark-input-end) + (slime-with-output-at-eob + (insert string)))))) (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." @@ -1630,7 +1639,6 @@ ;; command. slime-mark-input-end sets the input-end-mark to some ;; position before the end and triggers printing of the prompt. (with-current-buffer (slime-output-buffer) - (slime-flush-output) (unless (= (point-max) slime-repl-input-end-mark) (slime-mark-output-end) (slime-with-output-at-eob From heller at common-lisp.net Fri Dec 12 22:56:13 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 17:56:13 -0500 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7168 Modified Files: swank-loader.lisp Log Message: (user-init-file): Simplify the code. Date: Fri Dec 12 17:56:12 2003 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.9 slime/swank-loader.lisp:1.10 --- slime/swank-loader.lisp:1.9 Fri Dec 12 06:13:07 2003 +++ slime/swank-loader.lisp Fri Dec 12 17:56:12 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.9 2003/12/12 11:13:07 heller Exp $ +;;; $Id: swank-loader.lisp,v 1.10 2003/12/12 22:56:12 heller Exp $ ;;; (defpackage :swank-loader @@ -65,11 +65,9 @@ (defun user-init-file () "Return the name of the user init file or nil." (let ((home (user-homedir-pathname))) - (when (probe-file home) - (let ((filename (format nil "~A/.swank.lisp" - (namestring (truename home))))) - (cond ((probe-file filename) filename) - (t nil)))))) + (and (probe-file home) + (probe-file (format nil "~A/.swank.lisp" + (namestring (truename home))))))) (compile-files-if-needed-serially (list* (make-swank-pathname "swank-backend") *swank-pathname* From heller at common-lisp.net Fri Dec 12 22:58:31 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 12 Dec 2003 17:58:31 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7674 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Dec 12 17:58:31 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.156 slime/ChangeLog:1.157 --- slime/ChangeLog:1.156 Fri Dec 12 07:41:16 2003 +++ slime/ChangeLog Fri Dec 12 17:58:31 2003 @@ -1,5 +1,15 @@ 2003-12-12 Helmut Eller + * swank-cmucl.lisp (create-swank-server): New keyword arguments to + control the server: BACKGROUND and CLOSE. fd-handlers are used if + BACKGROUND is true. If close CLOSE is true, close the socket + after the first connection; keep it open otherwise. + *start-swank-in-background*, *close-swank-socket-after-setup*: The + default values of the corresponding arguments for + create-swank-server. + (compile-file-for-emacs): Don't load the fasl-file when the + compilation failed. + * swank-openmcl.lisp (toggle-trace-fdefinition, tracedp): Implement trace command. Patch by Alan Ruttenberg. (find-function-locations, find-source-locations): Handle @@ -8,14 +18,18 @@ (list-callers): Fixed. (list-callers): Fixed some more. method-name is not exported in 0.14. From Marco Baringer. + (swank-accept-connection): Accept multiple connections. Patch by + Marco Basringer. * swank-loader.lisp (user-init-file): Use homedir's truename. Reported by Friedrich Dominicus. * slime.el (slime-repl-current-input): Don't remove the final - newline only if we are in reading state. + newline if we are in reading state. (slime-goto-source-location): Regex-quote the function-name and handle package prefixes. Reported by Alan Ruttenberg. + (slime-output-string): Insert asynchronous output before the + prompt. 2003-12-12 Daniel Barlow From heller at common-lisp.net Sat Dec 13 10:00:42 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 13 Dec 2003 05:00:42 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20264 Modified Files: swank-openmcl.lisp Log Message: (create-swank-server, ccl::force-break-in-listener): Patch by Alan Ruttenberg. Not yet enabled. (sldb-disassemble): Implement sldb-disasssemble command. Patch by Alan Ruttenberg. Remove some #' form lambdas. Date: Sat Dec 13 05:00:42 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.32 slime/swank-openmcl.lisp:1.33 --- slime/swank-openmcl.lisp:1.32 Fri Dec 12 17:47:24 2003 +++ slime/swank-openmcl.lisp Sat Dec 13 05:00:42 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.32 2003/12/12 22:47:24 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.33 2003/12/13 10:00:42 heller Exp $ ;;; ;;; @@ -82,9 +82,33 @@ (let ((server-socket (ccl:make-socket :connect :passive :local-port port :reuse-address reuse-address))) (funcall announce (ccl:local-port server-socket)) - (ccl:process-run-function "Swank Request Processor" - #'swank-accept-connection - server-socket))) + (let ((swank (ccl:process-run-function "Swank Request Processor" + #'swank-accept-connection + server-socket))) + ;; tell openmcl which process you want to be interrupted when + ;; sigint is received + ;;(setq ccl::*interactive-abort-process* swank) + ))) + +#+(or) +(defun ccl::force-break-in-listener (p) + (ccl::process-interrupt + p (lambda () + (ccl::ignoring-without-interrupts + (let ((*swank-debugger-stack-frame* nil) + (previous-p nil)) + (block find-frame + (map-backtrace + (lambda (frame-number p tcr lfun pc) + (declare (ignore frame-number tcr + pc)) + (when (eq (ccl::lfun-name lfun) 'swank::eval-region) + (setq + *swank-debugger-stack-frame* previous-p) + (return-from find-frame)) + (setq previous-p p)))) + (invoke-debugger) + (clear-input *terminal-io*)))))) (defun swank-accept-connection (server-socket) (loop (request-loop (ccl:accept-connection server-socket :wait t)))) @@ -274,12 +298,12 @@ If the backtrace cannot be calculated, this function returns NIL." (let (result) - (map-backtrace #'(lambda (frame-number p tcr lfun pc) - (push (list frame-number - (format nil "~D: (~A~A)" frame-number - (ccl::%lfun-name-string lfun) - (frame-arguments p tcr lfun pc))) - result)) + (map-backtrace (lambda (frame-number p tcr lfun pc) + (push (list frame-number + (format nil "~D: (~A~A)" frame-number + (ccl::%lfun-name-string lfun) + (frame-arguments p tcr lfun pc))) + result)) start-frame-number end-frame-number) (nreverse result))) @@ -290,27 +314,43 @@ (defmethod frame-locals (index) (map-backtrace - #'(lambda (frame-number p tcr lfun pc) - (when (= frame-number index) - (multiple-value-bind (count vsp parent-vsp) - (ccl::count-values-in-frame p tcr) - (let (result) - (dotimes (i count) - (multiple-value-bind (var type name) - (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) - (declare (ignore type)) - (when name - (push (list - :symbol (to-string name) - :id 0 - :validity :valid - :value-string (to-string var)) - result)))) - (return-from frame-locals (nreverse result)))))))) + (lambda (frame-number p tcr lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p tcr) + (let (result) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list + :symbol (to-string name) + :id 0 + :validity :valid + :value-string (to-string var)) + result)))) + (return-from frame-locals (nreverse result)))))))) (defmethod frame-catch-tags (index) (declare (ignore index)) nil) + +(defslimefun sldb-disassemble (the-frame-number) + "Return a string with the disassembly of frames code." + (let ((function-to-disassemble nil)) + (block find-frame + (map-backtrace + (lambda(frame-number p tcr lfun pc) + (declare (ignore p tcr pc)) + (when (= frame-number the-frame-number) + (setq function-to-disassemble lfun) + (return-from find-frame))))) + (with-output-to-string (s) + (ccl::print-ppc-instructions + s (ccl::function-to-dll-header function-to-disassemble) nil)))) + +;;; (defun find-source-locations (symbol name) (let* ((info (ccl::source-file-or-files symbol nil nil nil)) @@ -361,11 +401,11 @@ find the precise position of the frame, but we do attempt to give at least the filename containing it." (map-backtrace - #'(lambda (frame-number p tcr lfun pc) - (declare (ignore p tcr pc)) - (when (and (= frame-number index) lfun) - (return-from frame-source-location-for-emacs - (function-source-location (ccl:function-name lfun))))))) + (lambda (frame-number p tcr lfun pc) + (declare (ignore p tcr pc)) + (when (and (= frame-number index) lfun) + (return-from frame-source-location-for-emacs + (function-source-location (ccl:function-name lfun))))))) (defun nth-restart (index) (nth index *sldb-restarts*)) From heller at common-lisp.net Sat Dec 13 10:03:48 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 13 Dec 2003 05:03:48 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20758 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Dec 13 05:03:47 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.157 slime/ChangeLog:1.158 --- slime/ChangeLog:1.157 Fri Dec 12 17:58:31 2003 +++ slime/ChangeLog Sat Dec 13 05:03:47 2003 @@ -1,3 +1,12 @@ +2003-12-13 Helmut Eller + + * swank-openmcl.lisp (create-swank-server): Interrupt the right + thread. Patch by Alan Ruttenberg. Not yet enabled, due to lack + of test platform. + (sldb-disassemble): Implement sldb-disasssemble command. Patch by + Alan Ruttenberg. + Remove #' from lambdas. + 2003-12-12 Helmut Eller * swank-cmucl.lisp (create-swank-server): New keyword arguments to From heller at common-lisp.net Sat Dec 13 10:15:44 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 13 Dec 2003 05:15:44 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26077 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Dec 13 05:15:44 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.158 slime/ChangeLog:1.159 --- slime/ChangeLog:1.158 Sat Dec 13 05:03:47 2003 +++ slime/ChangeLog Sat Dec 13 05:15:44 2003 @@ -28,7 +28,7 @@ (list-callers): Fixed some more. method-name is not exported in 0.14. From Marco Baringer. (swank-accept-connection): Accept multiple connections. Patch by - Marco Basringer. + Marco Baringer. * swank-loader.lisp (user-init-file): Use homedir's truename. Reported by Friedrich Dominicus. From heller at common-lisp.net Sun Dec 14 07:47:29 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 02:47:29 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19683 Modified Files: slime.el Log Message: (slime-goto-source-location): Better regexp for package qualified symbols. Allow dashes in the name and two colons. Reported by Alan Ruttenberg. Date: Sun Dec 14 02:47:28 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.145 slime/slime.el:1.146 --- slime/slime.el:1.145 Fri Dec 12 17:52:56 2003 +++ slime/slime.el Sun Dec 14 02:47:28 2003 @@ -2310,7 +2310,8 @@ (let ((case-fold-search t) (name (regexp-quote name))) (re-search-forward - (format "^(\\(def.*[ \n\t(]\\([a-z]+:\\)?\\)?%s[ \t)]" name))) + (format "^(\\(def.*[ \n\t(]\\([-.%%$&a-z0-9]+:?:\\)?\\)?%s[ \t)]" + name))) (goto-char (match-beginning 0))) ((:source-path source-path start-position) (cond (start-position @@ -3610,10 +3611,12 @@ (defun sldb-show-source () (interactive) (sldb-delete-overlays) - (let* ((number (sldb-frame-number-at-point)) - (source-location (slime-eval - `(swank:frame-source-location-for-emacs ,number)))) - (slime-show-source-location source-location))) + (let* ((number (sldb-frame-number-at-point))) + (slime-eval-async + `(swank:frame-source-location-for-emacs ,number) + nil + (lambda (source-location) + (slime-show-source-location source-location))))) (defun slime-show-source-location (source-location) (save-selected-window @@ -4376,76 +4379,79 @@ (time-less-p end (current-time))) do (accept-process-output nil 0 100000)))) -(def-slime-test loop-interrupt-quit () - "Test interrupting a loop." - '(()) - (slime-check "Automaton initially in idle state." - (slime-test-state-stack '(slime-idle-state))) - (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) - (let ((sldb-hook - (lambda () - (slime-check "First interrupt." - (and (slime-test-state-stack '(slime-debugging-state - slime-evaluating-state +(def-slime-test loop-interrupt-quit + () + "Test interrupting a loop." + '(()) + (slime-check "Automaton initially in idle state." + (slime-test-state-stack '(slime-idle-state))) + (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) + (let ((sldb-hook + (lambda () + (slime-check "First interrupt." + (and (slime-test-state-stack '(slime-debugging-state + slime-evaluating-state slime-idle-state)) - (get-buffer "*sldb*"))) - (sldb-quit)))) - (accept-process-output nil 1) - (slime-check "In eval state." - (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) - (slime-interrupt) - (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))))) - -(def-slime-test loop-interrupt-continue-interrupt-quit () - "Test interrupting a previously interrupted but continued loop." - '(()) - (slime-check "Automaton initially in idle state." - (slime-test-state-stack '(slime-idle-state))) - (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) - (let ((sldb-hook - (lambda () - (slime-check "First interrupt." - (and (slime-test-state-stack '(slime-debugging-state - slime-evaluating-state + (get-buffer "*sldb*"))) + (sldb-quit)))) + (accept-process-output nil 1) + (slime-check "In eval state." + (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) + (slime-interrupt) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))))) + +(def-slime-test loop-interrupt-continue-interrupt-quit + () + "Test interrupting a previously interrupted but continued loop." + '(()) + (slime-check "Automaton initially in idle state." + (slime-test-state-stack '(slime-idle-state))) + (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) + (let ((sldb-hook + (lambda () + (slime-check "First interrupt." + (and (slime-test-state-stack '(slime-debugging-state + slime-evaluating-state slime-idle-state)) - (get-buffer "*sldb*"))) - (let ((slime-evaluating-state-activation-hook - (lambda () - (when (slime-test-state-stack '(slime-evaluating-state - slime-idle-state)) - (setq slime-evaluating-state-activation-hook nil) - (slime-check "No sldb buffer." - (not (get-buffer "*sldb*"))) - (let ((sldb-hook - (lambda () - (slime-check "Second interrupt." - (and (slime-test-state-stack - '(slime-debugging-state - slime-evaluating-state - slime-idle-state)) - (get-buffer "*sldb*"))) - (sldb-quit)))) - (accept-process-output nil 1) - (slime-check "In eval state." - (slime-test-state-stack - '(slime-evaluating-state slime-idle-state))) - (slime-interrupt) - (slime-sync-state-stack '(slime-idle-state) 5)))))) - (sldb-continue) - (slime-sync-state-stack '(slime-idle-state) 5))))) - (accept-process-output nil 1) - (slime-check "In eval state." - (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) - (slime-interrupt) - (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))))) - -(def-slime-test interactive-eval () - "Test interactive eval and continuing from the debugger." - '(()) + (get-buffer "*sldb*"))) + (let ((slime-evaluating-state-activation-hook + (lambda () + (when (slime-test-state-stack '(slime-evaluating-state + slime-idle-state)) + (setq slime-evaluating-state-activation-hook nil) + (slime-check "No sldb buffer." + (not (get-buffer "*sldb*"))) + (let ((sldb-hook + (lambda () + (slime-check "Second interrupt." + (and (slime-test-state-stack + '(slime-debugging-state + slime-evaluating-state + slime-idle-state)) + (get-buffer "*sldb*"))) + (sldb-quit)))) + (accept-process-output nil 1) + (slime-check "In eval state." + (slime-test-state-stack + '(slime-evaluating-state slime-idle-state))) + (slime-interrupt) + (slime-sync-state-stack '(slime-idle-state) 5)))))) + (sldb-continue) + (slime-sync-state-stack '(slime-idle-state) 5))))) + (accept-process-output nil 1) + (slime-check "In eval state." + (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) + (slime-interrupt) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))))) + +(def-slime-test interactive-eval + () + "Test interactive eval and continuing from the debugger." + '(()) (let ((sldb-hook (lambda () (sldb-continue)))) (slime-interactive-eval "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))") @@ -4456,29 +4462,30 @@ (slime-check "Minibuffer contains: \"=> 3\"" (equal "=> 3" message))))) -(def-slime-test interrupt-bubbling-idiot () - "Test interrupting a loop that sends a lot of output to Emacs." - '(()) +(def-slime-test interrupt-bubbling-idiot + () + "Test interrupting a loop that sends a lot of output to Emacs." + '(()) (slime-check "Automaton initially in idle state." (slime-test-state-stack '(slime-idle-state))) (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) (cl:force-output))) "CL-USER" (lambda (_) )) (let ((sldb-hook - (lambda () - (slime-check "First interrupt." - (and (slime-test-state-stack '(slime-debugging-state - slime-evaluating-state + (lambda () + (slime-check "First interrupt." + (and (slime-test-state-stack '(slime-debugging-state + slime-evaluating-state slime-idle-state)) - (get-buffer "*sldb*"))) - (sldb-quit)))) - (accept-process-output nil 1) - (slime-check "In eval state." - (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) - (slime-interrupt) - (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))))) + (get-buffer "*sldb*"))) + (sldb-quit)))) + (accept-process-output nil 1) + (slime-check "In eval state." + (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) + (slime-interrupt) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))))) ;;; Portability library From heller at common-lisp.net Sun Dec 14 07:48:43 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 02:48:43 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19827 Modified Files: swank-cmucl.lisp Log Message: (compile-system-for-emacs): Add method for CMUCL. Date: Sun Dec 14 02:48:43 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.40 slime/swank-cmucl.lisp:1.41 --- slime/swank-cmucl.lisp:1.40 Fri Dec 12 17:52:02 2003 +++ slime/swank-cmucl.lisp Sun Dec 14 02:48:43 2003 @@ -26,10 +26,6 @@ (address (car (ext:host-entry-addr-list hostent)))) (ext:htonl address))) -(defvar *start-swank-in-background* t) -(defvar *close-swank-socket-after-setup* t) -(defvar *use-dedicated-output-stream* t) - (defun create-swank-server (port &key (reuse-address t) (address "localhost") (announce #'simple-announce-function) @@ -343,6 +339,14 @@ :emacs-buffer-offset ,position :emacs-buffer-string ,string)))))) +(defmethod compile-system-for-emacs (system-name) + (with-compilation-hooks () + (cond ((ext:featurep :asdf) + (let ((operate (find-symbol (string :operate) :asdf)) + (load-op (find-symbol (string :load-op) :asdf))) + (funcall operate load-op system-name))) + (t (error "ASDF not loaded"))))) + ;;;; XREF @@ -860,19 +864,6 @@ (defslimefun print-ir1-converted-blocks (form) (with-output-to-string (*standard-output*) (c::print-all-blocks (expand-ir1-top-level (from-string form))))) - -(defun tracedp (fname) - (gethash (debug::trace-fdefinition fname) - debug::*traced-functions*)) - -(defslimefun toggle-trace-fdefinition (fname-string) - (let ((fname (from-string fname-string))) - (cond ((tracedp fname) - (debug::untrace-1 fname) - (format nil "~S is now untraced." fname)) - (t - (debug::trace-1 fname (debug::make-trace-info)) - (format nil "~S is now traced." fname))))) (defslimefun set-default-directory (directory) (setf (ext:default-directory) (namestring directory)) From heller at common-lisp.net Sun Dec 14 07:52:31 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 02:52:31 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21387 Modified Files: swank.lisp Log Message: *start-swank-in-background*, *close-swank-socket-after-setup*, *use-dedicated-output-stream*: Moved here from swank-cmucl. (sldb-continue): Don't pass the condition as argument, because that *doesn't work with Allegro. (toggle-trace-fdefinition, tracedp): Remove backend specific code with portable, but ugly, to calls to eval. Date: Sun Dec 14 02:52:31 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.78 slime/swank.lisp:1.79 --- slime/swank.lisp:1.78 Wed Dec 10 21:20:30 2003 +++ slime/swank.lisp Sun Dec 14 02:52:31 2003 @@ -50,6 +50,10 @@ ;;;; Setup and Hooks +(defvar *start-swank-in-background* nil) +(defvar *close-swank-socket-after-setup* nil) +(defvar *use-dedicated-output-stream* t) + (defun announce-server-port (file) (lambda (port) (with-open-file (s file @@ -319,7 +323,7 @@ (throw 'sldb-loop-catcher nil)) (defslimefun sldb-continue () - (continue *swank-debugger-condition*)) + (continue)) (defslimefun eval-string-in-frame (string index) (to-string (eval-in-frame (from-string string) index))) @@ -736,6 +740,19 @@ (defslimefun list-all-package-names () (mapcar #'package-name (list-all-packages))) + +;; Use eval for the sake of portability... +(defun tracedp (fspec) + (member fspec (eval '(trace)))) + +(defslimefun toggle-trace-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + (cond ((tracedp fname) + (eval `(untrace ,fname)) + (format nil "~S is now untraced." fname)) + (t + (eval `(trace ,fname)) + (format nil "~S is now traced." fname))))) (defslimefun untrace-all () (untrace)) From heller at common-lisp.net Sun Dec 14 07:55:20 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 02:55:20 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22869 Modified Files: swank-openmcl.lisp Log Message: (create-swank-server): Add support for BACKGROUND and CLOSE argument. (open-stream-to-emacs): Support for dedicated output stream. Date: Sun Dec 14 02:55:19 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.33 slime/swank-openmcl.lisp:1.34 --- slime/swank-openmcl.lisp:1.33 Sat Dec 13 05:00:42 2003 +++ slime/swank-openmcl.lisp Sun Dec 14 02:55:19 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.33 2003/12/13 10:00:42 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.34 2003/12/14 07:55:19 heller Exp $ ;;; ;;; @@ -77,18 +77,22 @@ ;; blocks on its TCP port while waiting for forms to evaluate. (defun create-swank-server (port &key (reuse-address t) - (announce #'simple-announce-function)) + (announce #'simple-announce-function) + (background *start-swank-in-background*) + (close *close-swank-socket-after-setup*)) "Create a Swank TCP server on `port'." (let ((server-socket (ccl:make-socket :connect :passive :local-port port - :reuse-address reuse-address))) + :reuse-address reuse-address))) (funcall announce (ccl:local-port server-socket)) - (let ((swank (ccl:process-run-function "Swank Request Processor" - #'swank-accept-connection - server-socket))) - ;; tell openmcl which process you want to be interrupted when - ;; sigint is received - ;;(setq ccl::*interactive-abort-process* swank) - ))) + (cond (background + (let ((swank (ccl:process-run-function + "Swank" #'accept-loop server-socket close))) + ;; tell openmcl which process you want to be interrupted when + ;; sigint is received + ;; (setq ccl::*interactive-abort-process* swank)) + swank)) + (t + (accept-loop server-socket close))))) #+(or) (defun ccl::force-break-in-listener (p) @@ -110,27 +114,41 @@ (invoke-debugger) (clear-input *terminal-io*)))))) -(defun swank-accept-connection (server-socket) - (loop (request-loop (ccl:accept-connection server-socket :wait t)))) +(defun accept-loop (server-socket close) + (unwind-protect (cond (close (accept-one-client server-socket)) + (t (loop (accept-one-client server-socket)))) + (close server-socket))) + +(defun accept-one-client (server-socket) + (request-loop (ccl:accept-connection server-socket :wait t))) + +(defun request-loop (stream) + (let* ((out (if *use-dedicated-output-stream* + (open-stream-to-emacs stream) + (make-instance 'slime-output-stream))) + (in (make-instance 'slime-input-stream)) + (io (make-two-way-stream in out))) + (do () ((serve-one-request stream out in io))))) + +(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) + (catch 'slime-toplevel + (with-simple-restart (abort "Return to Slime toplevel.") + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (close *emacs-io*) + (return-from serve-one-request t))))) + nil) -(defun request-loop (*emacs-io*) - "Thread function for a single Swank connection. Processes requests -until the remote Emacs goes away." - (unwind-protect - (let* ((*slime-output* (make-instance 'slime-output-stream)) - (*slime-input* (make-instance 'slime-input-stream)) - (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) - (loop - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime event loop.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (return))))))) - (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) - (close *emacs-io*))) +(defun open-stream-to-emacs (*emacs-io*) + (let* ((listener (ccl:make-socket :connect :passive :local-port 0 + :reuse-address t)) + (port (ccl:local-port listener))) + (unwind-protect (progn + (eval-in-emacs `(slime-open-stream-to-lisp ,port)) + (ccl:accept-connection listener :wait t)) + (close listener)))) ;;; Evaluation @@ -443,20 +461,6 @@ (when (fboundp setf-function-name) (doc 'function setf-function-name)))) result))) - -;;; Tracing and Disassembly - -(defun tracedp (fname) - (ccl::%traced-p fname)) - -(defslimefun toggle-trace-fdefinition (fname-string) - (let ((fname (from-string fname-string))) - (cond ((tracedp fname) - (ccl::%untrace-1 fname) - (format nil "~S is now untraced." fname)) - (t - (ccl::%trace-0 (list fname)) - (format nil "~S is now traced." fname))))) ;;; XREF From heller at common-lisp.net Sun Dec 14 07:58:12 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 02:58:12 -0500 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23185 Modified Files: swank-allegro.lisp Log Message: (create-swank-server): Add support for BACKGROUND and CLOSE argument. (call-with-debugging-environment): Use excl::int-newest-frame to avoid the kludge with *break-hook*. (sldb-abort): Add Allegro support. (frame-source-location-for-emacs): Add dummy definition. (compile-file-for-emacs): The argument is called :load-after-compile and not :load. (xref-results-for-emacs): Use dolist instead of loop. Date: Sun Dec 14 02:58:12 2003 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.3 slime/swank-allegro.lisp:1.4 --- slime/swank-allegro.lisp:1.3 Wed Dec 10 08:26:08 2003 +++ slime/swank-allegro.lisp Sun Dec 14 02:58:12 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.3 2003/12/10 13:26:08 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.4 2003/12/14 07:58:12 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -37,37 +37,53 @@ ;;; TCP Server (defun create-swank-server (port &key (reuse-address t) - (announce #'simple-announce-function)) + (announce #'simple-announce-function) + (background *start-swank-in-background*) + (close *close-swank-socket-after-setup*)) "Create a Swank TCP server on `port'." (let ((server-socket (socket:make-socket :connect :passive :local-port port :reuse-address reuse-address))) (funcall announce (socket:local-port server-socket)) - (swank-accept-connection server-socket))) + (cond (background + (mp:process-run-function "Swank" #'accept-loop server-socket close)) + (t + (accept-loop server-socket close))))) + +(defun accept-loop (server-socket close) + (unwind-protect (cond (close (accept-one-client server-socket)) + (t (loop (accept-one-client server-socket)))) + (close server-socket))) + +(defun accept-one-client (server-socket) + (request-loop (socket:accept-connection server-socket :wait t))) + +(defun request-loop (stream) + (let* ((out (if *use-dedicated-output-stream* + (open-stream-to-emacs stream) + (make-instance 'slime-output-stream))) + (in (make-instance 'slime-input-stream)) + (io (make-two-way-stream in out))) + (do () ((serve-one-request stream out in io))))) + +(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) + (catch 'slime-toplevel + (with-simple-restart (abort "Return to Slime toplevel.") + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (close *emacs-io*) + (return-from serve-one-request t))))) + nil) -(defun swank-accept-connection (server-socket) - "Accept one Swank TCP connection on SOCKET. -Run the connection handler in a new thread." - (loop - (request-loop (socket:accept-connection server-socket :wait t)))) - -(defun request-loop (*emacs-io*) - "Thread function for a single Swank connection. Processes requests -until the remote Emacs goes away." - (unwind-protect - (let* ((*slime-output* (make-instance 'slime-output-stream)) - (*slime-input* (make-instance 'slime-input-stream)) - (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) - (loop - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime event loop.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (return))))))) - (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) - (close *emacs-io*))) +(defun open-stream-to-emacs (*emacs-io*) + (let* ((listener (socket:make-socket :connect :passive :local-port 0 + :reuse-address t)) + (port (socket:local-port listener))) + (unwind-protect (progn + (eval-in-emacs `(slime-open-stream-to-lisp ,port)) + (socket:accept-connection listener :wait t)) + (close listener)))) (defmethod arglist-string (fname) (declare (type string fname)) @@ -109,23 +125,25 @@ (doc 'class))) result))) +(defmethod macroexpand-all (form) + (excl::walk form)) + (defvar *sldb-topframe*) (defvar *sldb-source*) (defvar *sldb-restarts*) - + (defmethod call-with-debugging-environment (debugger-loop-fn) - (flet ((break-hook (frame source continue-format-string args condition) - (let ((*sldb-topframe* frame)) - (funcall debugger-loop-fn)))) - (let* ((*debugger-hook* nil) - (*package* *buffer-package*) - (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) - (*print-pretty* nil) - (*print-readably* nil) - (*print-level* 3) - (*print-length* 10) - (excl::*break-hook* #'break-hook)) - (break)))) + (let ((*sldb-topframe* (excl::int-newest-frame)) + (*debugger-hook* nil) + (excl::*break-hook* nil) + (*package* *buffer-package*) + (*sldb-restarts* + (compute-restarts *swank-debugger-condition*)) + (*print-pretty* nil) + (*print-readably* nil) + (*print-level* 3) + (*print-length* 10)) + (funcall debugger-loop-fn))) (defun format-condition-for-emacs () (format nil "~A~% [Condition of type ~S]" @@ -169,6 +187,9 @@ (defslimefun invoke-nth-restart (index) (invoke-restart-interactively (nth-restart index))) +(defslimefun sldb-abort () + (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + (defmethod frame-locals (index) (let ((frame (nth-frame index))) (loop for i from 0 below (debugger:frame-number-vars frame) @@ -181,6 +202,10 @@ (declare (ignore index)) nil) +(defmethod frame-source-location-for-emacs (index) + (list :error (format nil "Cannot find source for frame: ~A" + (nth-frame index)))) + (defvar *buffer-name* nil) (defvar *buffer-start-position*) (defvar *buffer-string*) @@ -210,7 +235,7 @@ (defmethod compile-file-for-emacs (*compile-filename* load-p) (handler-bind ((warning #'handle-compiler-warning)) (let ((*buffer-name* nil)) - (compile-file *compile-filename* :load load-p)))) + (compile-file *compile-filename* :load-after-compile load-p)))) (defmethod compile-string-for-emacs (string &key buffer position) (handler-bind ((warning #'handle-compiler-warning)) @@ -291,7 +316,7 @@ (defun xref-results-for-emacs (fspecs) (let ((xrefs '())) (dolist (fspec fspecs) - (loop for location in (fspec-source-locations fspec) - do (push (cons (to-string fspec) location) - xrefs))) + (dolist (location (fspec-source-locations fspec)) + (push (cons (to-string fspec) location) xrefs))) (group-xrefs xrefs))) + From heller at common-lisp.net Sun Dec 14 07:59:37 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 02:59:37 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24221 Modified Files: swank-lispworks.lisp Log Message: (tracedp, toggle-trace-fdefinition): Moved to swank.lisp. Date: Sun Dec 14 02:59:37 2003 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.8 slime/swank-lispworks.lisp:1.9 --- slime/swank-lispworks.lisp:1.8 Wed Dec 10 08:26:08 2003 +++ slime/swank-lispworks.lisp Sun Dec 14 02:59:36 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.8 2003/12/10 13:26:08 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.9 2003/12/14 07:59:36 heller Exp $ ;;; (in-package :swank) @@ -261,20 +261,6 @@ (defmethod find-function-locations (fname) (dspec-source-locations (from-string fname))) - -;;; Tracing - -(defun tracedp (symbol) - (member symbol (trace) :test #'eq)) - -(defslimefun toggle-trace-fdefinition (fname-string) - (let ((fname (from-string fname-string))) - (cond ((tracedp fname) - (compiler::ensure-untrace-1 (list fname)) - (format nil "~S is now untraced." fname)) - (t - (compiler::ensure-trace-1 (list fname)) - (format nil "~S is now traced." fname))))) ;;; callers From heller at common-lisp.net Sun Dec 14 08:02:54 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 03:02:54 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25226 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Dec 14 03:02:53 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.159 slime/ChangeLog:1.160 --- slime/ChangeLog:1.159 Sat Dec 13 05:15:44 2003 +++ slime/ChangeLog Sun Dec 14 03:02:53 2003 @@ -1,9 +1,43 @@ +2003-12-14 Helmut Eller + + * swank-lispworks.lisp (tracedp, toggle-trace-fdefinition): Moved + to swank.lisp. + + * swank-allegro.lisp (create-swank-server): Add support for + BACKGROUND and CLOSE argument. + (call-with-debugging-environment): Use excl::int-newest-frame to + avoid the kludge with *break-hook*. + (sldb-abort): New function. + (frame-source-location-for-emacs): Dummy definition. + (compile-file-for-emacs): The argument is called + :load-after-compile and not :load. + (xref-results-for-emacs): Use dolist instead of loop. + + * swank-openmcl.lisp (create-swank-server): Add support for + BACKGROUND and CLOSE argument. + (open-stream-to-emacs): Support for dedicated output stream. + + * swank.lisp: *start-swank-in-background*, + *close-swank-socket-after-setup*, *use-dedicated-output-stream*: + Moved here from swank-cmucl. + (sldb-continue): Don't pass the condition as argument, because + that doesn't work with Allegro. + (toggle-trace-fdefinition, tracedp): Replace backend specific code + with portable, but ugly, calls to eval. + + * swank-cmucl.lisp (compile-system-for-emacs): Add method for + CMUCL. + + * slime.el (slime-goto-source-location): Better regexp for package + qualified symbols. Allow dashes in the name and two colons. + Reported by Alan Ruttenberg. + 2003-12-13 Helmut Eller * swank-openmcl.lisp (create-swank-server): Interrupt the right thread. Patch by Alan Ruttenberg. Not yet enabled, due to lack of test platform. - (sldb-disassemble): Implement sldb-disasssemble command. Patch by + (sldb-disassemble): Implement sldb-disassemble command. Patch by Alan Ruttenberg. Remove #' from lambdas. From heller at common-lisp.net Sun Dec 14 08:24:21 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 03:24:21 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7069 Modified Files: swank-openmcl.lisp Log Message: Mega patch by Alan Ruttenberg. Implements eval-in-frame and inspector support. Date: Sun Dec 14 03:24:21 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.34 slime/swank-openmcl.lisp:1.35 --- slime/swank-openmcl.lisp:1.34 Sun Dec 14 02:55:19 2003 +++ slime/swank-openmcl.lisp Sun Dec 14 03:24:21 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.34 2003/12/14 07:55:19 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.35 2003/12/14 08:24:21 heller Exp $ ;;; ;;; @@ -434,6 +434,27 @@ (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) +(defslimefun eval-in-frame (form index) + (map-backtrace + (lambda (frame-number p tcr lfun pc) + (when (= frame-number index) + (multiple-value-bind (count vsp parent-vsp) + (ccl::count-values-in-frame p tcr) + (let ((bindings nil)) + (dotimes (i count) + (multiple-value-bind (var type name) + (ccl::nth-value-in-frame p i tcr lfun pc vsp parent-vsp) + (declare (ignore type)) + (when name + (push (list name `',var) bindings)) + )) + (return-from eval-in-frame + (eval `(let ,bindings + (Declare (ccl::ignore-if-unused + ,@(mapcar 'car bindings))) + ,form))) + )))))) + ;;; Utilities (defslimefun-unimplemented describe-setf-function (symbol-name)) @@ -489,3 +510,155 @@ ;;; Macroexpansion (defslimefun-unimplemented swank-macroexpand-all (string)) + + +;;;; Inspecting + +;;XXX refactor common code. + +(defvar *inspectee*) +(defvar *inspectee-parts*) +(defvar *inspector-stack* '()) +(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) +(defvar *inspect-length* 30) + +(defun reset-inspector () + (setq *inspectee* nil) + (setq *inspectee-parts* nil) + (setq *inspector-stack* nil) + (setf (fill-pointer *inspector-history*) 0)) + +(defslimefun init-inspector (string) + (reset-inspector) + (inspect-object (eval (from-string string)))) + +(defun print-part-to-string (value) + (let ((*print-pretty* nil)) + (let ((string (to-string value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "#~D=~A" pos string) + string)))) + +(defun inspect-object (object) + (push (setq *inspectee* object) *inspector-stack*) + (unless (find object *inspector-history*) + (vector-push-extend object *inspector-history*)) + (multiple-value-bind (text parts) (inspected-parts object) + (setq *inspectee-parts* parts) + (list :text text + :type (to-string (type-of object)) + :primitive-type (describe-primitive-type object) + :parts (loop for (label . value) in parts + collect (cons label + (print-part-to-string value)))))) + +(defun nth-part (index) + (cdr (nth index *inspectee-parts*))) + +(defslimefun inspect-nth-part (index) + (inspect-object (nth-part index))) + +(defslimefun inspector-pop () + "Drop the inspector stack and inspect the second element. Return +nil if there's no second element." + (cond ((cdr *inspector-stack*) + (pop *inspector-stack*) + (inspect-object (pop *inspector-stack*))) + (t nil))) + +(defslimefun inspector-next () + "Inspect the next element in the *inspector-history*." + (let ((position (position *inspectee* *inspector-history*))) + (cond ((= (1+ position) (length *inspector-history*)) + nil) + (t (inspect-object (aref *inspector-history* (1+ position))))))) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (print-description-to-string *inspectee*)) + +(defgeneric inspected-parts (object) + (:documentation + "Return a short description and a list of (label . value) pairs.")) + +;;&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +;; specific to openmcl + +(defvar *value2tag* (make-hash-table)) + +(do-symbols (s (find-package 'arch)) + (if (and (> (length (symbol-name s)) 7) + (string= (symbol-name s) "SUBTAG-" :end1 7) + (boundp s) + (numberp (symbol-value s)) + (< (symbol-value s) 255)) + (setf (gethash (symbol-value s) *value2tag*) s))) + +(defun describe-primitive-type (thing) + (let ((typecode (ccl::typecode thing))) + (if (gethash typecode *value2tag*) + (string (gethash typecode *value2tag*)) + (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) + +(defmethod inspected-parts (o) + (let* ((i (inspector::make-inspector o)) + (count (inspector::compute-line-count i)) + (lines + (loop for l below count + for (value label) = (multiple-value-list + (inspector::line-n i l)) + collect (cons (string-right-trim + " :" (string-capitalize + (format nil "~a" label))) + value)))) + (values (string-left-trim + (string #\newline) + (with-output-to-string (s) + (let ((*print-lines* 1) + (*print-right-margin* 80)) + (pprint o s)))) + (cddr lines)))) + +(defslimefun inspect-in-frame (string index) + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index))) + +;;&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + +(defmethod inspected-parts ((object cons)) + (if (consp (cdr object)) + (inspected-parts-of-nontrivial-list object) + (inspected-parts-of-simple-cons object))) + +(defun inspected-parts-of-simple-cons (object) + (values "The object is a CONS." + (list (cons (string 'car) (car object)) + (cons (string 'cdr) (cdr object))))) + +(defun inspected-parts-of-nontrivial-list (object) + (let ((length 0) + (in-list object) + (reversed-elements nil)) + (flet ((done (description-format) + (return-from inspected-parts-of-nontrivial-list + (values (format nil description-format length) + (nreverse reversed-elements))))) + (loop + (cond ((null in-list) + (done "The object is a proper list of length ~S.~%")) + ((>= length *inspect-length*) + (push (cons (string 'rest) in-list) reversed-elements) + (done "The object is a long list (more than ~S elements).~%")) + ((consp in-list) + (push (cons (format nil "~D" length) (pop in-list)) + reversed-elements) + (incf length)) + (t + (push (cons (string 'rest) in-list) reversed-elements) + (done "The object is an improper list of length ~S.~%"))))))) + From heller at common-lisp.net Sun Dec 14 08:27:19 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 14 Dec 2003 03:27:19 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7698 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Dec 14 03:27:19 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.160 slime/ChangeLog:1.161 --- slime/ChangeLog:1.160 Sun Dec 14 03:02:53 2003 +++ slime/ChangeLog Sun Dec 14 03:27:19 2003 @@ -1,3 +1,14 @@ +2003-12-14 Alan Ruttenberg + + * swank-openmcl.lisp (eval-in-frame, inspect-object and friends): + Most of this is copied from swank-cmucl. The parts between &&&&& + are what I added for openmcl. I piggyback off the inspector which + is shipped with openmcl, so inspecting won't look the same as it + would in cmucl, I imagine. Still, it's a start. eval in frame + uses frame-locals to get bindings so if you have debug settings + low or don't have *save-local-symbols* set you won't be able to + evaluate. + 2003-12-14 Helmut Eller * swank-lispworks.lisp (tracedp, toggle-trace-fdefinition): Moved From lgorrie at common-lisp.net Mon Dec 15 05:27:45 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 00:27:45 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28832 Modified Files: slime.el Log Message: (slime-multiprocessing): When true, use multiprocessing in Lisp if available. (slime-global-debugger-hook): When true, globally set *debugger-hook* to use the SLIME debugger. For use with SERVE-EVENT and multiprocessing. (slime-handle-oob): Handle :AWAITING-GOAHEAD message from threads that have suspended to wait for Emacs's attention. (slime-give-goahead): New command to allow a suspended thread to continue (bound to RET in the thread-control-panel). (slime-thread-control-panel): New command to display a buffer showing all threads that are suspending waiting for Emacs's attention. Bound to `C-c C-x t'. (slime-popup-thread-control-panel): When true, automatically popup the thread-control buffer when a new thread suspends. Date: Mon Dec 15 00:27:45 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.146 slime/slime.el:1.147 --- slime/slime.el:1.146 Sun Dec 14 02:47:28 2003 +++ slime/slime.el Mon Dec 15 00:27:44 2003 @@ -119,6 +119,15 @@ This applies to buffers that present lines as rows of data, such as debugger backtraces and apropos listings.") +(defvar slime-global-debugger-hook nil + "When true, install the SLIME debugger hook globally in Lisp. + +This means the SLIME debugger will be used for all errors occuring in +Lisp, not just those occuring during RPCs.") + +(defvar slime-multiprocessing nil + "When true, enable multiprocessing in Lisp.") + ;;; Customize group @@ -385,7 +394,9 @@ ("\C-ws" slime-who-sets :prefixed t :inferior t :sldb t) ("\C-wm" slime-who-macroexpands :prefixed t :inferior t :sldb t) ("<" slime-list-callers :prefixed t :inferior t :sldb t) - (">" slime-list-callees :prefixed t :inferior t :sldb t))) + (">" slime-list-callees :prefixed t :inferior t :sldb t) + ;; "Other" + ("\C-xt" slime-thread-control-panel :prefixed t :inferior t :sldb t))) ;; Maybe a good idea, maybe not.. (defvar slime-prefix-key "\C-c" @@ -823,6 +834,7 @@ (when (slime-connected-p) (slime-disconnect)) (slime-maybe-start-lisp) + (slime-maybe-start-multiprocessing) (setq slime-lisp-package slime-default-lisp-package) (slime-read-port-and-connect)) @@ -834,6 +846,11 @@ (format "(load %S)\n" (concat slime-path slime-backend))))) +(defun slime-maybe-start-multiprocessing () + (when slime-multiprocessing + (comint-send-string (inferior-lisp-proc) + "(swank:startup-multiprocessing-for-emacs)"))) + (defun slime-start-swank-server () "Start a Swank server on the inferior lisp." (comint-proc-query (inferior-lisp-proc) @@ -920,7 +937,9 @@ (defun slime-init-connection () (slime-init-dispatcher) - (setq slime-pid (slime-eval '(swank:getpid)))) + (setq slime-pid (slime-eval '(swank:getpid))) + (when slime-global-debugger-hook + (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER"))) (defvar slime-words-of-encouragement '("Let the hacking commence!" @@ -1155,6 +1174,8 @@ t) ((:%apply fn args) (apply (intern fn) args)) + ((:awaiting-goahead thread-id thread-name reason) + (slime-register-waiting-thread thread-id thread-name reason)) (t nil))) (defun slime-state/event-panic (event) @@ -1214,11 +1235,10 @@ (delete-other-windows (get-buffer-window "*SLIME bug*")) (error "The SLIME protocol reached an inconsistent state.")) - - (defvar slime-log-events t "*Log protocol events to the *slime-events* buffer.") + ;;;;; Event logging to *slime-events* (defun slime-log-event (event) (when slime-log-events @@ -1850,7 +1870,7 @@ (goto-char slime-repl-last-input-start-mark) (insert ";;; output flushed")) (set-marker slime-repl-last-input-start-mark nil))) - + ;;; Scratch (defvar slime-scratch-mode-map) @@ -3455,6 +3475,20 @@ (slime-dispatch-event '(:emacs-quit)) (error "Not evaluating - nothing to quit."))) +(defun slime-give-goahead (thread-id) + "Allow a suspended thread to continue." + (interactive "xThread-ID: ") + (case (slime-state-name (slime-current-state)) + (slime-idle-state + (slime-eval-async `(swank:give-goahead ,thread-id) + (slime-buffer-package) + (lambda (v) nil))) + (slime-debugging-state + (error "Already debugging - must finish first.")) + (t + (error "Busy - can't attach in current state (%S)" + (slime-current-state))))) + (defun slime-set-package (package) (interactive (list (slime-read-package-name "Package: " (slime-find-buffer-package)))) @@ -3870,6 +3904,76 @@ ,(number-to-string n))))) (define-sldb-invoke-restart-keys 0 9) + + +;;; Thread control panel + +;; The "thread control panel" is a buffer showing all interesting Lisp +;; threads -- for now, this means threads that are waiting to be +;; debugged. Threads can be selected with RET to have Emacs debug +;; them. + +(defvar slime-waiting-threads '() + "List of threads waiting for attention from Emacs. +Each entry is (ID NAME SUMMARY-STRING).") + +(defvar slime-popup-thread-control-panel t + "*When non-nil, automatically display the thread control panel. +The buffer will be popped up any time it is modified.") + +(defun slime-register-waiting-thread (id name summary) + (unless (member* id slime-waiting-threads :test #'equal :key #'first) + (setq slime-waiting-threads + (append slime-waiting-threads (list (list id name summary))))) + (slime-thread-control-panel (not slime-popup-thread-control-panel)) + (message "Thread awaiting goahead: %s" name)) + +(defun slime-thread-control-panel (&optional dont-show) + (interactive) + (with-current-buffer (get-buffer-create "*slime-threads*") + (slime-thread-control-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (loop for (id name summary) in slime-waiting-threads + do (slime-thread-insert id name summary)) + (goto-char (point-min)) + (unless dont-show (pop-to-buffer (current-buffer))) + (setq buffer-read-only t)))) + +(defun slime-thread-insert (id name summary) + (slime-propertize-region `(thread-id ,id) + (slime-insert-propertized '(face bold) name "\n") + (let ((summary-start (point))) + (insert summary) + (unless (bolp) (insert "\n")) + (indent-rigidly summary-start (point) 2)))) + +(defun slime-thread-goahead () + (interactive) + (let ((id (get-text-property (point) 'thread-id))) + (unless id (error "No thread at point.")) + (slime-give-goahead id) + (setq slime-waiting-threads + (remove* id slime-waiting-threads :key #'car :test #'equal)) + (slime-thread-control-panel t))) + +;;;; Major mode + +(define-derived-mode slime-thread-control-mode fundamental-mode + "thread-control" + "SLIME Thread Control Panel Mode. + +\\{slime-thread-control-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-thread-control-mode-map + ((kbd "RET") 'slime-thread-goahead) + ("q" 'slime-thread-quit)) + +(defun slime-thread-quit () + (interactive) + (kill-buffer (current-buffer))) ;;; Inspector From lgorrie at common-lisp.net Mon Dec 15 05:27:55 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 00:27:55 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28878 Modified Files: swank-backend.lisp Log Message: Defined multiprocessing interface. Date: Mon Dec 15 00:27:55 2003 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.8 slime/swank-backend.lisp:1.9 --- slime/swank-backend.lisp:1.8 Wed Dec 10 21:19:33 2003 +++ slime/swank-backend.lisp Mon Dec 15 00:27:55 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.8 2003/12/11 02:19:33 dbarlow Exp $ +;;; $Id: swank-backend.lisp,v 1.9 2003/12/15 05:27:55 lgorrie Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -17,70 +17,80 @@ (defpackage :swank (:use :common-lisp) (:nicknames #:swank-backend) - (:export #:start-server #:create-swank-server - #:*sldb-pprint-frames* - #:eval-string - #:interactive-eval-region - #:interactive-eval - #:pprint-eval - #:re-evaluate-defvar - #:listener-eval - #:swank-compile-file - #:swank-compile-string + (:export #:*sldb-pprint-frames* + #:apropos-list-for-emacs + #:arglist-string + #:backtrace + #:call-with-I/O-lock + #:call-with-conversation-lock #:compiler-notes-for-emacs - #:load-file - #:set-default-directory - #:set-package - #:list-all-package-names - #:getpid - #:disassemble-symbol - #:describe-symbol - #:describe-alien-type - #:describe-function - #:describe-type + #:completions + #:create-swank-server + #:describe-alien-enum #:describe-alien-struct + #:describe-alien-type + #:describe-alien-union #:describe-class + #:describe-function #:describe-inspectee - #:describe-alien-union - #:describe-alien-enum #:describe-setf-function + #:describe-symbol + #:describe-type + #:disassemble-symbol #:documentation-symbol - #:arglist-string - #:completions - #:apropos-list-for-emacs - #:inspect-nth-part - #:inspect-in-frame - #:init-inspector - #:quit-inspector - #:inspector-next - #:swank-macroexpand-all - #:swank-macroexpand - #:swank-macroexpand-1 - #:untrace-all - #:toggle-trace-fdefinition + #:eval-in-frame + #:eval-string + #:eval-string-in-frame #:find-function-locations - #:who-binds - #:who-references - #:who-calls - #:who-sets - #:who-macroexpands - #:list-callers - #:list-callees - #:backtrace #:frame-catch-tags - #:frame-source-position #:frame-locals - #:throw-to-toplevel + #:frame-source-location-for-emacs + #:frame-source-position + #:getpid + #:give-goahead + #:give-gohead + #:init-inspector + #:inspect-in-frame + #:inspect-nth-part + #:inspector-next #:inspector-pop + #:interactive-eval + #:interactive-eval-region #:invoke-nth-restart + #:list-all-package-names + #:list-callees + #:list-callers + #:listener-eval + #:load-file + #:pprint-eval #:pprint-eval-string-in-frame - #:frame-source-location-for-emacs - #:eval-in-frame - #:eval-string-in-frame + #:quit-inspector + #:re-evaluate-defvar + #:set-default-directory + #:set-package #:sldb-abort #:sldb-continue - #:take-input #:slime-debugger-function + #:start-server + #:startup-multiprocessing + #:startup-multiprocessing-for-emacs + #:swank-compile-file + #:swank-compile-string + #:swank-macroexpand + #:swank-macroexpand-1 + #:swank-macroexpand-all + #:take-input + #:thread-id + #:thread-name + #:throw-to-toplevel + #:toggle-trace-fdefinition + #:untrace-all + #:wait-goahead + #:who-binds + #:who-calls + #:who-macroexpands + #:who-references + #:who-sets )) (in-package :swank) @@ -326,4 +336,101 @@ ::= (:position []) ; 1 based | (:function-name )")) + + +;;;; Multiprocessing + +(defgeneric startup-multiprocessing () + (:documentation + "Initialize multiprocessing, if necessary. + +This function is called directly through the listener, not in an RPC +from Emacs. This is to support interfaces such as CMUCL's +MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a +normal function.")) + +(defgeneric thread-id () + (:documentation + "Return a value that uniquely identifies the current thread. +Thread-IDs allow Emacs to refer to individual threads. + +When called several times by the same thread, all return values are +EQUAL. The value has a READable printed representation that preserves +equality. The printed representation must be identical in Emacs Lisp +and Common Lisp, and short enough to include in the REPL prompt. + +For example, a THREAD-ID could be an integer or a short ASCII string. + +Systems that do not support multiprocessing return NIL.")) + +(defgeneric thread-name (thread-id) + (:documentation + "Return the name of the thread identified by THREAD-ID. + +Thread names are be single-line strings and are meaningful to the +user. They do not have to be unique.")) + +(defgeneric call-with-I/O-lock (function) + (:documentation + "Call FUNCTION with the \"I/O\" lock held. +Only one thread can hold the I/O lock at a time -- others are blocked +until they acquire it. When called recursively (i.e. lock already +held), simply calls FUNCTION. + +This is a low-level lock used for mutual exclusion on individual +messages read and written to the socket connecting Emacs. + +Systems that do not support multiprocessing simply call FUNCTION.")) + +(defgeneric call-with-conversation-lock (function) + (:documentation + "Call FUNCTION with the \"conversation\" lock held. +The semantics are analogous to CALL-WITH-I/O-HOOK. + +This is a high-level lock used for mutual exclusion in conversations +with Emacs that can span multiple messages. The I/O lock must +separately be held when reading and writing individual messages.")) + +;;; Functions for attracting the Emacs user's attention. + +(defgeneric wait-goahead () + (:documentation + "Block until told to continue by `give-gohead'. + +Systems that do not support multiprocessing return immediately.")) + +(defgeneric give-goahead (thread-id) + (:documentation + "Permit THREAD-ID to continue from WAIT-GOAHEAD. +It is an error to call (GIVE-GOAHEAD ID) unless ID is blocking in +WAIT-GOAHEAD. + +Systems that do not support multiprocessing always signal an error.")) + +;;;;; Default implementation for non-MP systems + +;;; Using NO-APPLICABLE-METHOD to supply a default implementation that +;;; works in systems that don't have multiprocessing. +;;; (Good or bad idea? -luke) + +(defvar _ nil ; Good or bad idea? -luke + "Null variable -- can be used for ignored arguments. +Declared special, so no IGNORE declarations are necessary.") + +(defmethod no-applicable-method ((m (eql #'startup-multiprocessing)) &rest _) + nil) +(defmethod no-applicable-method ((m (eql #'thread-id)) &rest _) + nil) +(defmethod no-applicable-method ((m (eql #'thread-name)) &rest _) + "The One True Thread") +(defmethod no-applicable-method ((m (eql #'call-with-I/O-lock)) + &rest args) + (funcall (first args))) +(defmethod no-applicable-method ((m (eql #'call-with-conversation-lock)) + &rest args) + (funcall (first args))) +(defmethod no-applicable-method ((m (eql #'wait-goahead)) &rest _) + t) +(defmethod no-applicable-method ((m (eql #'give-goahead)) &rest _) + (error "SLIME multiprocessing not available")) From lgorrie at common-lisp.net Mon Dec 15 05:28:23 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 00:28:23 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28947 Modified Files: swank-cmucl.lisp Log Message: Implmemented the multiprocessing interface. Date: Mon Dec 15 00:28:22 2003 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.41 slime/swank-cmucl.lisp:1.42 --- slime/swank-cmucl.lisp:1.41 Sun Dec 14 02:48:43 2003 +++ slime/swank-cmucl.lisp Mon Dec 15 00:28:21 2003 @@ -586,6 +586,7 @@ (function-source-location fn))) fns)))) + ;;;; Definitions (defvar *debug-definition-finding* nil @@ -1318,6 +1319,55 @@ `(("Name" . ,(kernel:fdefn-name o)) ("Function" . ,(kernel:fdefn-function o))))) + +;;;; Multiprocessing + +#+MP +(progn + (defvar *I/O-lock* (mp:make-lock "SWANK I/O lock")) + (defvar *conversation-lock* (mp:make-lock "SWANK conversation lock")) + + (defvar *known-processes* '() ; FIXME: leakage. -luke + "List of processes that have been assigned IDs. + The ID is the position in the list.") + + (defmethod startup-multiprocessing () + (mp::startup-idle-and-top-level-loops)) + + (defmethod thread-id () + (mp:without-scheduling + (or (find-thread-id) + (prog1 (length *known-processes*) + (setq *known-processes* + (append *known-processes* (list (mp:current-process)))))))) + + (defun find-thread-id (&optional (process (mp:current-process))) + (position process *known-processes*)) + + (defun lookup-thread (thread-id) + (or (nth thread-id *known-processes*) + (error "Unknown Thread-ID: ~S" thread-id))) + + (defmethod thread-name (thread-id) + (mp:process-name (lookup-thread thread-id))) + + (defmethod call-with-I/O-lock (function) + (mp:with-lock-held (*I/O-lock*) + (funcall function))) + + (defmethod call-with-conversation-lock (function) + (mp:with-lock-held (*conversation-lock*) + (funcall function))) + + (defmethod wait-goahead () + (mp:disable-process (mp:current-process)) + (mp:process-yield)) + + (defmethod give-goahead (thread-id) + (mp:enable-process (lookup-thread thread-id)))) + + +;;;; Epilogue ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) ;;; End: From lgorrie at common-lisp.net Mon Dec 15 05:29:10 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 00:29:10 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29972 Modified Files: swank.lisp Log Message: (*processing-rpc*, *multiprocessing-enabled*, (with-conversation-lock, with-I/O-lock): New macros. (read-next-form): Use with-I/O-lock. (send-to-emacs): Use with-I/O-lock instead of without-interrupts*. (But should we have without-interrupts* too?) (swank-debugger-hook): When called asynchronously (i.e. not during RPC) and multiprocessing is enabled, suspend until acknowleged by Emacs. (install-global-debugger-hook): Install a SLIME-DEBUGGER-FUNCTION globally on *DEBUGGER-HOOK*. (startup-multiprocessing-for-emacs): Called to initialize multiprocessing. (eval-string): Dynamically set the *PROCESSING-RPC* flag. (eval-string): Nasty hack with *DEBUGGER-HOOK-PASSBACK* to install debugger hook. Temporary, I swear! Date: Mon Dec 15 00:29:10 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.79 slime/swank.lisp:1.80 --- slime/swank.lisp:1.79 Sun Dec 14 02:52:31 2003 +++ slime/swank.lisp Mon Dec 15 00:29:10 2003 @@ -32,6 +32,21 @@ (defvar *sldb-pprint-frames* nil "*pretty-print* is bound to this value when sldb prints a frame.") +(defvar *processing-rpc* nil + "True when Lisp is evaluating an RPC from Emacs.") + +(defvar *multiprocessing-enabled* nil + "True when multiprocessing support is to be used.") + +(defvar *debugger-hook-passback* nil + ;; Temporary hack! + "When set while processing a command, the value is copied into +*debugger-hook*. + +This allows RPCs from Emacs to change the global value of +*debugger-hook*, which is shadowed in a dynamic binding while they +run.") + ;;; public interface. slimefuns are the things that emacs is allowed ;;; to call @@ -76,6 +91,15 @@ :announce (announce-server-port port-file-namestring))) +;;;; Helper macros + +(defmacro with-conversation-lock (&body body) + `(call-with-conversation-lock (lambda () , at body))) + +(defmacro with-I/O-lock (&body body) + `(call-with-I/O-lock (lambda () , at body))) + + ;;;; IO to Emacs ;;; ;;; We have two layers of I/O: @@ -121,7 +145,7 @@ (*terminal-io* io)) (apply fn args)) (apply fn args))) - + (defun read-from-emacs () "Read and process a request from Emacs." (let ((form (read-next-form))) @@ -141,14 +165,15 @@ back to the main request handling loop." (flet ((next-byte () (char-code (read-char *emacs-io*)))) (handler-case - (let* ((length (logior (ash (next-byte) 16) - (ash (next-byte) 8) - (next-byte))) - (string (make-string length)) - (pos (read-sequence string *emacs-io*))) - (assert (= pos length) nil - "Short read: length=~D pos=~D" length pos) - (read-form string)) + (with-I/O-lock + (let* ((length (logior (ash (next-byte) 16) + (ash (next-byte) 8) + (next-byte))) + (string (make-string length)) + (pos (read-sequence string *emacs-io*))) + (assert (= pos length) nil + "Short read: length=~D pos=~D" length pos) + (read-form string))) (serious-condition (c) (error (make-condition 'slime-read-error :condition c)))))) @@ -168,16 +193,15 @@ (defun send-to-emacs (object) "Send `object' to Emacs." - (let* ((string (prin1-to-string-for-emacs object)) - (length (1+ (length string)))) - (without-interrupts* - (lambda () - (loop for position from 16 downto 0 by 8 - do (write-char (code-char (ldb (byte 8 position) length)) - *emacs-io*)) - (write-string string *emacs-io*) - (terpri *emacs-io*) - (force-output *emacs-io*))))) + (let* ((string (prin1-to-string-for-emacs object)) + (length (1+ (length string)))) + (with-I/O-lock + (loop for position from 16 downto 0 by 8 + do (write-char (code-char (ldb (byte 8 position) length)) + *emacs-io*)) + (write-string string *emacs-io*) + (terpri *emacs-io*) + (force-output *emacs-io*)))) (defun prin1-to-string-for-emacs (object) (with-standard-io-syntax @@ -276,6 +300,8 @@ then waits to handle further requests from Emacs. Eventually returns after Emacs causes a restart to be invoked." (declare (ignore hook)) + (unless (or *processing-rpc* (not *multiprocessing-enabled*)) + (request-async-debug condition)) (let ((*swank-debugger-condition* condition) (*package* *buffer-package*)) (let ((*sldb-level* (1+ *sldb-level*))) @@ -300,9 +326,27 @@ (when (open-stream-p *emacs-io*) (call-with-slime-streams in out io - #'swank::swank-debugger-hook (list c next)))))) + #'swank-debugger-hook (list c next)))))) #'slime-debug))) +(defslimefun install-global-debugger-hook () + (setq *debugger-hook-passback* (slime-debugger-function)) + t) + +(defun startup-multiprocessing-for-emacs () + (setq *multiprocessing-enabled* t) + (startup-multiprocessing)) + +(defun request-async-debug (condition) + "Tell Emacs that we need to debug a condition, and wait for acknowledgement. +Called before entering the debugger for conditions that occured +asynchronously, i.e. not during an RPC from Emacs." + (send-to-emacs `(:awaiting-goahead + ,(thread-id) + ,(thread-name (thread-id)) + ,(format nil "~A" condition))) + (wait-goahead)) + (defun sldb-loop (level) (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 *sldb-initial-frames*))) @@ -338,7 +382,8 @@ `(:%apply ,(string-downcase (string fn)) ,args)))) (defslimefun eval-string (string buffer-package) - (let ((*debugger-hook* #'swank-debugger-hook)) + (let ((*processing-rpc* t) + (*debugger-hook* #'swank-debugger-hook)) (let (ok result) (unwind-protect (let ((*buffer-package* (guess-package-from-string buffer-package))) @@ -348,7 +393,10 @@ (setq ok t)) (sync-state-to-emacs) (force-output *slime-io*) - (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) + (send-to-emacs (if ok `(:ok ,result) '(:aborted)))))) + (when *debugger-hook-passback* + (setq *debugger-hook* *debugger-hook-passback*) + (setq *debugger-hook-passback* nil))) (defun format-values-for-echo-area (values) (cond (values (format nil "~{~S~^, ~}" values)) @@ -812,6 +860,9 @@ (if errors `(("Unresolved" . ,errors)))))))) + +;; (put 'with-i/o-lock 'common-lisp-indent-function 0) +;; (put 'with-conversation-lock 'common-lisp-indent-function 0) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From lgorrie at common-lisp.net Mon Dec 15 05:29:19 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 00:29:19 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30002 Modified Files: ChangeLog Log Message: Date: Mon Dec 15 00:29:19 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.161 slime/ChangeLog:1.162 --- slime/ChangeLog:1.161 Sun Dec 14 03:27:19 2003 +++ slime/ChangeLog Mon Dec 15 00:29:19 2003 @@ -1,3 +1,41 @@ +2003-12-15 Luke Gorrie + + * swank.lisp (*processing-rpc*, *multiprocessing-enabled*, + (with-conversation-lock, with-I/O-lock): New macros. + (read-next-form): Use with-I/O-lock. + (send-to-emacs): Use with-I/O-lock instead of + without-interrupts*. (But should we have without-interrupts* too?) + (swank-debugger-hook): When called asynchronously (i.e. not + during RPC) and multiprocessing is enabled, suspend until + acknowleged by Emacs. + (install-global-debugger-hook): Install a SLIME-DEBUGGER-FUNCTION + globally on *DEBUGGER-HOOK*. + (startup-multiprocessing-for-emacs): Called to initialize multiprocessing. + (eval-string): Dynamically set the *PROCESSING-RPC* flag. + (eval-string): Nasty hack with *DEBUGGER-HOOK-PASSBACK* to + install debugger hook. Temporary, I swear! + + *debugger-hook-passback*): New variables. + + * swank-backend.lisp: Defined multiprocessing interface. + + * swank-cmucl.lisp: Implmemented the multiprocessing interface. + + * slime.el (slime-multiprocessing): When true, use + multiprocessing in Lisp if available. + (slime-global-debugger-hook): When true, globally set + *debugger-hook* to use the SLIME debugger. For use with + SERVE-EVENT and multiprocessing. + (slime-handle-oob): Handle :AWAITING-GOAHEAD message from threads + that have suspended to wait for Emacs's attention. + (slime-give-goahead): New command to allow a suspended thread to + continue (bound to RET in the thread-control-panel). + (slime-thread-control-panel): New command to display a buffer + showing all threads that are suspending waiting for Emacs's + attention. Bound to `C-c C-x t'. + (slime-popup-thread-control-panel): When true, automatically + popup the thread-control buffer when a new thread suspends. + 2003-12-14 Alan Ruttenberg * swank-openmcl.lisp (eval-in-frame, inspect-object and friends): From lgorrie at common-lisp.net Mon Dec 15 12:01:20 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 07:01:20 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16410 Modified Files: swank.lisp Log Message: (eval-region, shortest-package-nickname): Report the shortest package nickname to Emacs (for the REPL prompt). Patch from Marco Baringer. Date: Mon Dec 15 07:01:20 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.80 slime/swank.lisp:1.81 --- slime/swank.lisp:1.80 Mon Dec 15 00:29:10 2003 +++ slime/swank.lisp Mon Dec 15 07:01:20 2003 @@ -423,7 +423,15 @@ do (force-output) finally (return (values values -)))) (when (and package-update-p (not (eq *package* *buffer-package*))) - (send-to-emacs (list :new-package (package-name *package*))))))) + (send-to-emacs (list :new-package (shortest-package-nickname *package*))))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) (defslimefun interactive-eval-region (string) (let ((*package* *buffer-package*)) From lgorrie at common-lisp.net Mon Dec 15 12:01:28 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 07:01:28 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16440 Modified Files: ChangeLog Log Message: Date: Mon Dec 15 07:01:27 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.162 slime/ChangeLog:1.163 --- slime/ChangeLog:1.162 Mon Dec 15 00:29:19 2003 +++ slime/ChangeLog Mon Dec 15 07:01:27 2003 @@ -1,6 +1,7 @@ 2003-12-15 Luke Gorrie * swank.lisp (*processing-rpc*, *multiprocessing-enabled*, + *debugger-hook-passback*): New variables. (with-conversation-lock, with-I/O-lock): New macros. (read-next-form): Use with-I/O-lock. (send-to-emacs): Use with-I/O-lock instead of @@ -14,8 +15,9 @@ (eval-string): Dynamically set the *PROCESSING-RPC* flag. (eval-string): Nasty hack with *DEBUGGER-HOOK-PASSBACK* to install debugger hook. Temporary, I swear! - - *debugger-hook-passback*): New variables. + (eval-region, shortest-package-nickname): Report the shortest + package nickname to Emacs (for the REPL prompt). Patch from Marco + Baringer. * swank-backend.lisp: Defined multiprocessing interface. From lgorrie at common-lisp.net Mon Dec 15 12:29:14 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 07:29:14 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27465 Modified Files: swank.lisp Log Message: (send-to-emacs): Put back WITHOUT-INTERRUPTS* -- not sure exactly what it's for, but I had no actual reason to remove it so I probably broke something! Date: Mon Dec 15 07:29:14 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.81 slime/swank.lisp:1.82 --- slime/swank.lisp:1.81 Mon Dec 15 07:01:20 2003 +++ slime/swank.lisp Mon Dec 15 07:29:13 2003 @@ -196,12 +196,14 @@ (let* ((string (prin1-to-string-for-emacs object)) (length (1+ (length string)))) (with-I/O-lock - (loop for position from 16 downto 0 by 8 + (without-interrupts* + (lambda () + (loop for position from 16 downto 0 by 8 do (write-char (code-char (ldb (byte 8 position) length)) *emacs-io*)) - (write-string string *emacs-io*) - (terpri *emacs-io*) - (force-output *emacs-io*)))) + (write-string string *emacs-io*) + (terpri *emacs-io*) + (force-output *emacs-io*)))))) (defun prin1-to-string-for-emacs (object) (with-standard-io-syntax From lgorrie at common-lisp.net Mon Dec 15 12:29:40 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 07:29:40 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27577 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Dec 15 07:29:40 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.163 slime/ChangeLog:1.164 --- slime/ChangeLog:1.163 Mon Dec 15 07:01:27 2003 +++ slime/ChangeLog Mon Dec 15 07:29:40 2003 @@ -4,8 +4,7 @@ *debugger-hook-passback*): New variables. (with-conversation-lock, with-I/O-lock): New macros. (read-next-form): Use with-I/O-lock. - (send-to-emacs): Use with-I/O-lock instead of - without-interrupts*. (But should we have without-interrupts* too?) + (send-to-emacs): Use with-I/O-lock. (swank-debugger-hook): When called asynchronously (i.e. not during RPC) and multiprocessing is enabled, suspend until acknowleged by Emacs. From heller at common-lisp.net Mon Dec 15 15:53:29 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 15 Dec 2003 10:53:29 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27344 Modified Files: slime.el Log Message: (slime-eval-last-expression-display-output): New command. Bound to C-x M-e. Suggested by Nicolas Neuss. (slime-display-output-buffer): New function. (slime-slime-compile-file): Use it. Date: Mon Dec 15 10:53:29 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.147 slime/slime.el:1.148 --- slime/slime.el:1.147 Mon Dec 15 00:27:44 2003 +++ slime/slime.el Mon Dec 15 10:53:29 2003 @@ -360,6 +360,7 @@ ("\M-," slime-pop-find-definition-stack :inferior t :sldb t) ;; Evaluating ("\C-x\C-e" slime-eval-last-expression :inferior t) + ("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) ("\C-p" slime-pprint-eval-last-expression :prefixed t :inferior t) ("\C-r" slime-eval-region :prefixed t :inferior t) ("\C-\M-x" slime-eval-defun) @@ -1173,7 +1174,8 @@ (setq slime-lisp-features features) t) ((:%apply fn args) - (apply (intern fn) args)) + (apply (intern fn) args) + t) ((:awaiting-goahead thread-id thread-name reason) (slime-register-waiting-thread thread-id thread-name reason)) (t nil))) @@ -1552,6 +1554,13 @@ (end slime-repl-prompt-start-mark)) (funcall slime-show-last-output-function start end)))) +(defun slime-display-output-buffer () + "Display the output bufer and scroll to bottom." + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (set-window-start (display-buffer (current-buffer) t) + (line-beginning-position)))) + (defmacro slime-with-output-at-eob (&rest body) "Execute BODY at eob. If point is initially at eob and the buffer is visible update @@ -2035,10 +2044,7 @@ (unless (eq major-mode 'lisp-mode) (error "Only valid in lisp-mode")) (save-some-buffers) - (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (set-window-start (display-buffer (current-buffer) t) - (line-beginning-position))) + (slime-display-output-buffer) (slime-eval-async `(swank:swank-compile-file ,(buffer-file-name) ,(if load t nil)) nil @@ -2979,6 +2985,12 @@ (defun slime-eval-last-expression () "Evaluate the expression preceding point." (interactive) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-last-expression-display-output () + "Display output buffer and evaluate the expression preceding point." + (interactive) + (slime-display-output-buffer) (slime-interactive-eval (slime-last-expression))) (defun slime-eval-defun () From heller at common-lisp.net Mon Dec 15 15:54:31 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 15 Dec 2003 10:54:31 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27711 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Dec 15 10:54:30 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.164 slime/ChangeLog:1.165 --- slime/ChangeLog:1.164 Mon Dec 15 07:29:40 2003 +++ slime/ChangeLog Mon Dec 15 10:54:30 2003 @@ -1,3 +1,10 @@ +2003-12-15 Helmut Eller + + * slime.el (slime-eval-last-expression-display-output): New + command. Bound to C-x M-e. Suggested by Nicolas Neuss. + (slime-display-output-buffer): New function. + (slime-slime-compile-file): Use it. + 2003-12-15 Luke Gorrie * swank.lisp (*processing-rpc*, *multiprocessing-enabled*, From lgorrie at common-lisp.net Mon Dec 15 15:58:45 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 10:58:45 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30323 Modified Files: swank-openmcl.lisp Log Message: (ccl::force-break-in-listener): Support for interrupting the Lisp subjob (by Alan Ruttenberg). Date: Mon Dec 15 10:58:45 2003 Author: lgorrie Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.35 slime/swank-openmcl.lisp:1.36 --- slime/swank-openmcl.lisp:1.35 Sun Dec 14 03:24:21 2003 +++ slime/swank-openmcl.lisp Mon Dec 15 10:58:45 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.35 2003/12/14 08:24:21 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.36 2003/12/15 15:58:45 lgorrie Exp $ ;;; ;;; @@ -89,30 +89,34 @@ "Swank" #'accept-loop server-socket close))) ;; tell openmcl which process you want to be interrupted when ;; sigint is received - ;; (setq ccl::*interactive-abort-process* swank)) + (setq ccl::*interactive-abort-process* swank)) swank)) (t (accept-loop server-socket close))))) -#+(or) -(defun ccl::force-break-in-listener (p) - (ccl::process-interrupt - p (lambda () - (ccl::ignoring-without-interrupts - (let ((*swank-debugger-stack-frame* nil) - (previous-p nil)) - (block find-frame - (map-backtrace - (lambda (frame-number p tcr lfun pc) - (declare (ignore frame-number tcr - pc)) - (when (eq (ccl::lfun-name lfun) 'swank::eval-region) - (setq - *swank-debugger-stack-frame* previous-p) - (return-from find-frame)) - (setq previous-p p)))) - (invoke-debugger) - (clear-input *terminal-io*)))))) +(let ((ccl::*warn-if-redefine-kernel* nil)) + (defun ccl::force-break-in-listener (p) + (ccl::process-interrupt p + #'(lambda () + (ccl::ignoring-without-interrupts + (let ((*swank-debugger-stack-frame* + nil) + (previous-p nil)) + (block find-frame + (map-backtrace + #'(lambda(frame-number p tcr + lfun pc) + (declare (ignore + frame-number tcr pc)) + (when (eq (ccl::lfun-name + lfun) 'swank::eval-region) + (setq + *swank-debugger-stack-frame* + previous-p) + (return-from find-frame)) + (setq previous-p p)))) + (invoke-debugger) + (clear-input *terminal-io*))))))) (defun accept-loop (server-socket close) (unwind-protect (cond (close (accept-one-client server-socket)) From lgorrie at common-lisp.net Mon Dec 15 16:06:52 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 11:06:52 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2695 Modified Files: swank-openmcl.lisp Log Message: (ccl::force-break-in-listener): Bugfix. Date: Mon Dec 15 11:06:52 2003 Author: lgorrie Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.36 slime/swank-openmcl.lisp:1.37 --- slime/swank-openmcl.lisp:1.36 Mon Dec 15 10:58:45 2003 +++ slime/swank-openmcl.lisp Mon Dec 15 11:06:52 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.36 2003/12/15 15:58:45 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.37 2003/12/15 16:06:52 lgorrie Exp $ ;;; ;;; @@ -71,6 +71,8 @@ (defun without-interrupts* (body) (ccl:without-interrupts (funcall body))) +(defvar *swank-debugger-stack-frame*) + ;;; TCP Server ;; In OpenMCL, the Swank backend runs in a separate thread and simply @@ -95,28 +97,23 @@ (accept-loop server-socket close))))) (let ((ccl::*warn-if-redefine-kernel* nil)) - (defun ccl::force-break-in-listener (p) - (ccl::process-interrupt p - #'(lambda () - (ccl::ignoring-without-interrupts - (let ((*swank-debugger-stack-frame* - nil) - (previous-p nil)) - (block find-frame - (map-backtrace - #'(lambda(frame-number p tcr - lfun pc) - (declare (ignore - frame-number tcr pc)) - (when (eq (ccl::lfun-name - lfun) 'swank::eval-region) - (setq - *swank-debugger-stack-frame* - previous-p) - (return-from find-frame)) - (setq previous-p p)))) - (invoke-debugger) - (clear-input *terminal-io*))))))) + (defun ccl::force-break-in-listener (p) + (ccl::process-interrupt + p + #'(lambda () + (ccl::ignoring-without-interrupts + (let ((*swank-debugger-stack-frame* nil) + (previous-p nil)) + (block find-frame + (map-backtrace + #'(lambda(frame-number p tcr lfun pc) + (declare (ignore frame-number tcr pc)) + (when (eq (ccl::lfun-name lfun) 'swank::eval-region) + (setq *swank-debugger-stack-frame* previous-p) + (return-from find-frame)) + (setq previous-p p)))) + (invoke-debugger) + (clear-input *terminal-io*))))))) (defun accept-loop (server-socket close) (unwind-protect (cond (close (accept-one-client server-socket)) @@ -155,8 +152,6 @@ (close listener)))) ;;; Evaluation - -(defvar *swank-debugger-stack-frame*) (defmethod ccl::application-error :before (application condition error-pointer) (declare (ignore application condition)) From lgorrie at common-lisp.net Mon Dec 15 16:08:50 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 15 Dec 2003 11:08:50 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3486 Modified Files: ChangeLog Log Message: Date: Mon Dec 15 11:08:50 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.165 slime/ChangeLog:1.166 --- slime/ChangeLog:1.165 Mon Dec 15 10:54:30 2003 +++ slime/ChangeLog Mon Dec 15 11:08:50 2003 @@ -1,3 +1,8 @@ +2003-12-15 Luke Gorrie + + * swank-openmcl.lisp (ccl::*warn-if-redefine-kernel*): Support for + interrupting the listener (by Alan Ruttenberg). + 2003-12-15 Helmut Eller * slime.el (slime-eval-last-expression-display-output): New From heller at common-lisp.net Mon Dec 15 19:12:40 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 15 Dec 2003 14:12:40 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv856 Modified Files: swank.lisp Log Message: *start-swank-in-background*: Set to t by default. Date: Mon Dec 15 14:12:39 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.82 slime/swank.lisp:1.83 --- slime/swank.lisp:1.82 Mon Dec 15 07:29:13 2003 +++ slime/swank.lisp Mon Dec 15 14:12:37 2003 @@ -65,7 +65,7 @@ ;;;; Setup and Hooks -(defvar *start-swank-in-background* nil) +(defvar *start-swank-in-background* t) (defvar *close-swank-socket-after-setup* nil) (defvar *use-dedicated-output-stream* t) From heller at common-lisp.net Mon Dec 15 19:13:54 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 15 Dec 2003 14:13:54 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1214 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Dec 15 14:13:54 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.166 slime/ChangeLog:1.167 --- slime/ChangeLog:1.166 Mon Dec 15 11:08:50 2003 +++ slime/ChangeLog Mon Dec 15 14:13:53 2003 @@ -5,6 +5,8 @@ 2003-12-15 Helmut Eller + * swank.lisp *start-swank-in-background*: Set to t by default. + * slime.el (slime-eval-last-expression-display-output): New command. Bound to C-x M-e. Suggested by Nicolas Neuss. (slime-display-output-buffer): New function. From aruttenberg at common-lisp.net Tue Dec 16 03:29:19 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Mon, 15 Dec 2003 22:29:19 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28939/slime Modified Files: swank-openmcl.lisp Log Message: fix ccl::force-break-in-listener to move to frame immediately following %pascal-functions% which is where the sigint is effectively caught. Fixed type in create-swank-server Date: Mon Dec 15 22:29:18 2003 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.37 slime/swank-openmcl.lisp:1.38 --- slime/swank-openmcl.lisp:1.37 Mon Dec 15 11:06:52 2003 +++ slime/swank-openmcl.lisp Mon Dec 15 22:29:18 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.37 2003/12/15 16:06:52 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.38 2003/12/16 03:29:18 aruttenberg Exp $ ;;; ;;; @@ -84,14 +84,14 @@ (close *close-swank-socket-after-setup*)) "Create a Swank TCP server on `port'." (let ((server-socket (ccl:make-socket :connect :passive :local-port port - :reuse-address reuse-address))) + :reuse-address reuse-address))) (funcall announce (ccl:local-port server-socket)) (cond (background (let ((swank (ccl:process-run-function "Swank" #'accept-loop server-socket close))) ;; tell openmcl which process you want to be interrupted when ;; sigint is received - (setq ccl::*interactive-abort-process* swank)) + (setq ccl::*interactive-abort-process* swank) swank)) (t (accept-loop server-socket close))))) @@ -101,17 +101,17 @@ (ccl::process-interrupt p #'(lambda () - (ccl::ignoring-without-interrupts + (ccl::ignoring-without-interrupts (let ((*swank-debugger-stack-frame* nil) - (previous-p nil)) + (previous-f nil)) (block find-frame - (map-backtrace + (map-backtrace #'(lambda(frame-number p tcr lfun pc) (declare (ignore frame-number tcr pc)) - (when (eq (ccl::lfun-name lfun) 'swank::eval-region) - (setq *swank-debugger-stack-frame* previous-p) + (when (eq previous-f 'ccl::%pascal-functions%) + (setq *swank-debugger-stack-frame* p) (return-from find-frame)) - (setq previous-p p)))) + (setq previous-f (ccl::lfun-name lfun))))) (invoke-debugger) (clear-input *terminal-io*))))))) From lgorrie at common-lisp.net Tue Dec 16 07:59:36 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 02:59:36 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10539 Modified Files: slime.el Log Message: (slime-lisp-preferred-package-nicknames): Removed. Not very interesting (and slightly broken) now that shortest-nicknames are automatically used. Date: Tue Dec 16 02:59:36 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.148 slime/slime.el:1.149 --- slime/slime.el:1.148 Mon Dec 15 10:53:29 2003 +++ slime/slime.el Tue Dec 16 02:59:35 2003 @@ -91,15 +91,7 @@ "The symbol names in the *FEATURES* list of the Superior lisp. This is needed to READ Common Lisp expressions adequately.") -(defvar slime-lisp-preferred-package-nicknames - '(("COMMON-LISP-USER" . "CL-USER") - ("COMMON-LISP" . "CL")) - "Association list mapping package names onto their preferred nicknames. -This determines which name appears in the REPL prompt.") - -(defvar slime-default-lisp-package - (or (cdr (assoc "COMMON-LISP-USER" slime-lisp-preferred-package-nicknames)) - "COMMON-LISP-USER") +(defvar slime-default-lisp-package "CL-USER" "The default and initial package for the REPL.") (defvar slime-lisp-package @@ -808,8 +800,7 @@ (defun slime-lisp-package () "Return the name of the current REPL package." - (or (cdr (assoc slime-lisp-package slime-lisp-preferred-package-nicknames)) - slime-lisp-package)) + slime-lisp-package) (defmacro slime-propertize-region (props &rest body) (let ((start (gensym))) From lgorrie at common-lisp.net Tue Dec 16 08:00:28 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 03:00:28 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11247 Modified Files: ChangeLog Log Message: Date: Tue Dec 16 03:00:28 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.167 slime/ChangeLog:1.168 --- slime/ChangeLog:1.167 Mon Dec 15 14:13:53 2003 +++ slime/ChangeLog Tue Dec 16 03:00:28 2003 @@ -1,3 +1,9 @@ +2003-12-16 Luke Gorrie + + * slime.el (slime-lisp-preferred-package-nicknames): Removed. Not + very interesting (and slightly broken) now that shortest-nicknames + are automatically used. + 2003-12-15 Luke Gorrie * swank-openmcl.lisp (ccl::*warn-if-redefine-kernel*): Support for From aruttenberg at common-lisp.net Tue Dec 16 08:22:04 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 16 Dec 2003 03:22:04 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18737/slime Modified Files: swank-openmcl.lisp Log Message: Allow you to continue after interrupting. But you get a message "Evaluation aborted" that I have to ask about. Date: Tue Dec 16 03:22:04 2003 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.38 slime/swank-openmcl.lisp:1.39 --- slime/swank-openmcl.lisp:1.38 Mon Dec 15 22:29:18 2003 +++ slime/swank-openmcl.lisp Tue Dec 16 03:22:03 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.38 2003/12/16 03:29:18 aruttenberg Exp $ +;;; $Id: swank-openmcl.lisp,v 1.39 2003/12/16 08:22:03 aruttenberg Exp $ ;;; ;;; @@ -112,8 +112,9 @@ (setq *swank-debugger-stack-frame* p) (return-from find-frame)) (setq previous-f (ccl::lfun-name lfun))))) - (invoke-debugger) - (clear-input *terminal-io*))))))) + (restart-case (invoke-debugger) + (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t)) + )))))) (defun accept-loop (server-socket close) (unwind-protect (cond (close (accept-one-client server-socket)) From lgorrie at common-lisp.net Tue Dec 16 10:07:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 05:07:11 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28175 Modified Files: slime.el Log Message: (slime-output-oneway-evaluate-request): New function to evaluate an expression for side-effects (without getting a result). (slime-idle-state): Handle new :emacs-evaluate-oneway. (slime-debugging-state): Handle :emacs-evaluate-oneway. Also handle :read-string. (sldb-invoke-restart): Use slime-oneway-eval. This avoids pushing an evaluating state (which will be aborted, and print an unnecessary message saying so). (sldb-break-with-default-debugger): New command to break into the default TTY debugger. Bound to 'B' in *sldb*. Date: Tue Dec 16 05:07:11 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.149 slime/slime.el:1.150 --- slime/slime.el:1.149 Tue Dec 16 02:59:35 2003 +++ slime/slime.el Tue Dec 16 05:07:10 2003 @@ -1315,7 +1315,9 @@ (current-window-configuration)))) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation)))) + (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-evaluate-oneway form-string package-name) + (slime-output-oneway-evaluate-request form-string package-name))) (defvar slime-evaluating-state-activation-hook nil "Hook called when the evaluating state is actived.") @@ -1378,7 +1380,11 @@ ((:emacs-evaluate form-string package-name continuation) ;; recursive evaluation request (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation)))) + (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-evaluate-oneway form-string package-name) + (slime-output-oneway-evaluate-request form-string package-name)) + ((:read-string tag) + (slime-push-state (slime-read-string-state tag)))) (slime-defstate slime-read-string-state (tag) "Reading state. @@ -1402,6 +1408,10 @@ "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." (slime-net-send `(swank:eval-string ,form-string ,package-name))) +(defun slime-output-oneway-evaluate-request (form-string package-name) + "Like `slime-output-oneway-evaluate-request' but without expecting a result." + (slime-net-send `(swank:oneway-eval-string ,form-string ,package-name))) + (defun slime-check-connected () (unless (slime-connected-p) (error "Not connected. Use `M-x slime' to start a Lisp."))) @@ -1456,6 +1466,14 @@ (slime-check-connected) (slime-eval-string-async (prin1-to-string sexp) package `(:function ,cont))) +(defun slime-oneway-eval (sexp &optional package) + "Evaluate SEXP \"one-way\" - without receiving a return value." + (slime-check-connected) + (when (slime-busy-p) + (error "Busy evaluating")) + (slime-dispatch-event + `(:emacs-evaluate-oneway ,(prin1-to-string sexp) ,package))) + (defun slime-sync () "Block until any asynchronous command has completed." (while (slime-busy-p) @@ -3846,11 +3864,15 @@ (let ((restart (or number (sldb-restart-at-point) (error "No restart at point")))) - (slime-eval-async `(swank:invoke-nth-restart ,restart) nil (lambda ())))) + (slime-oneway-eval `(swank:invoke-nth-restart-for-emacs ,sldb-level ,restart) nil))) (defun sldb-restart-at-point () (get-text-property (point) 'restart-number)) +(defun sldb-break-with-default-debugger () + (interactive) + (slime-eval-async '(swank:sldb-break-with-default-debugger) nil (lambda (_)))) + (defun sldb-step () (interactive) (let ((frame (sldb-frame-number-at-point))) @@ -3883,6 +3905,7 @@ ("s" 'sldb-step) ("a" 'sldb-abort) ("q" 'sldb-quit) + ("B" 'sldb-break-with-default-debugger) (":" 'slime-interactive-eval)) (dolist (spec slime-keys) From lgorrie at common-lisp.net Tue Dec 16 10:07:31 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 05:07:31 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28237 Modified Files: swank.lisp Log Message: (invoke-nth-restart-for-emacs): Wrapper around INVOKE-NTH-RESTART that checks that Lisp and Emacs agree on the debug level. This detects and ignores old restart requests when several are sent at once (possible because of new oneway-eval feature). (oneway-eval-string): New function to evaluate a string without sending a result, and with *DEBUGGER-HOOK* bound to NIL. (The debugger hook is inhibited to avoid state conflicts.) Date: Tue Dec 16 05:07:31 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.83 slime/swank.lisp:1.84 --- slime/swank.lisp:1.83 Mon Dec 15 14:12:37 2003 +++ slime/swank.lisp Tue Dec 16 05:07:31 2003 @@ -371,6 +371,19 @@ (defslimefun sldb-continue () (continue)) +(defslimefun invoke-nth-restart-for-emacs (sldb-level n) + "Invoke the Nth available restart. +SLDB-LEVEL is the debug level when the request was made. If this +has changed, ignore the request." + (when (= sldb-level *sldb-level*) + (invoke-nth-restart n))) + +(defun sldb-break-with-default-debugger () + (let ((*debugger-hook* nil)) + ;; FIXME: This will break when the SBCL backend starts using the + ;; extra sbcl debugger hook. + (break))) + (defslimefun eval-string-in-frame (string index) (to-string (eval-in-frame (from-string string) index))) @@ -399,6 +412,14 @@ (when *debugger-hook-passback* (setq *debugger-hook* *debugger-hook-passback*) (setq *debugger-hook-passback* nil))) + +(defslimefun oneway-eval-string (string buffer-package) + "Evaluate STRING in BUFFER-PACKAGE, without sending a reply. +The debugger hook is inhibited during the evaluation." + (let ((*buffer-package* (guess-package-from-string buffer-package)) + (*package* *buffer-package*) + (*debugger-hook* nil)) + (eval (read-form string)))) (defun format-values-for-echo-area (values) (cond (values (format nil "~{~S~^, ~}" values)) From lgorrie at common-lisp.net Tue Dec 16 10:28:43 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 05:28:43 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3658 Modified Files: swank-backend.lisp Log Message: Exported invoke-nth-restart-for-emacs and sldb-break-with-default-debugger. Date: Tue Dec 16 05:28:42 2003 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.9 slime/swank-backend.lisp:1.10 --- slime/swank-backend.lisp:1.9 Mon Dec 15 00:27:55 2003 +++ slime/swank-backend.lisp Tue Dec 16 05:28:42 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.9 2003/12/15 05:27:55 lgorrie Exp $ +;;; $Id: swank-backend.lisp,v 1.10 2003/12/16 10:28:42 lgorrie Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -57,6 +57,7 @@ #:interactive-eval #:interactive-eval-region #:invoke-nth-restart + #:invoke-nth-restart-for-emacs #:list-all-package-names #:list-callees #:list-callers @@ -69,6 +70,7 @@ #:set-default-directory #:set-package #:sldb-abort + #:sldb-break-with-default-debugger #:sldb-continue #:slime-debugger-function #:start-server From lgorrie at common-lisp.net Tue Dec 16 10:28:54 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 05:28:54 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3709 Modified Files: ChangeLog Log Message: Date: Tue Dec 16 05:28:53 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.168 slime/ChangeLog:1.169 --- slime/ChangeLog:1.168 Tue Dec 16 03:00:28 2003 +++ slime/ChangeLog Tue Dec 16 05:28:53 2003 @@ -3,6 +3,26 @@ * slime.el (slime-lisp-preferred-package-nicknames): Removed. Not very interesting (and slightly broken) now that shortest-nicknames are automatically used. + (slime-output-oneway-evaluate-request): New function to evaluate + an expression for side-effects (without getting a + result). + (slime-idle-state): Handle new :emacs-evaluate-oneway. + (slime-debugging-state): Handle :emacs-evaluate-oneway. Also + handle :read-string. + (sldb-invoke-restart): Use slime-oneway-eval. This avoids pushing + an evaluating state (which will be aborted, and print an unnecessary + message saying so). + (sldb-break-with-default-debugger): New command to break into the + default TTY debugger. Bound to 'B' in *sldb*. + + * swank.lisp (invoke-nth-restart-for-emacs): Wrapper around + INVOKE-NTH-RESTART that checks that Lisp and Emacs agree on the + debug level. This detects and ignores old restart requests when + several are sent at once (possible because of new oneway-eval + feature). + (oneway-eval-string): New function to evaluate a string without + sending a result, and with *DEBUGGER-HOOK* bound to NIL. (The + debugger hook is inhibited to avoid state conflicts.) 2003-12-15 Luke Gorrie From lgorrie at common-lisp.net Tue Dec 16 12:49:07 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 07:49:07 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30388 Modified Files: slime.el Log Message: (slime-read-string-state): Added :emacs-evaluate-oneway. (slime-debugging-state): Removed transition for :READ-STRING. Why on earth did I add it just an hour or two ago? Date: Tue Dec 16 07:49:06 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.150 slime/slime.el:1.151 --- slime/slime.el:1.150 Tue Dec 16 05:07:10 2003 +++ slime/slime.el Tue Dec 16 07:49:05 2003 @@ -1382,9 +1382,7 @@ (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation))) ((:emacs-evaluate-oneway form-string package-name) - (slime-output-oneway-evaluate-request form-string package-name)) - ((:read-string tag) - (slime-push-state (slime-read-string-state tag)))) + (slime-output-oneway-evaluate-request form-string package-name))) (slime-defstate slime-read-string-state (tag) "Reading state. @@ -1397,6 +1395,8 @@ ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-evaluate-oneway form-string package-name) + (slime-output-oneway-evaluate-request form-string package-name)) ((:read-aborted) (slime-repl-abort-read) (slime-pop-state))) From lgorrie at common-lisp.net Tue Dec 16 12:49:17 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 16 Dec 2003 07:49:17 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30969 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Dec 16 07:49:17 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.169 slime/ChangeLog:1.170 --- slime/ChangeLog:1.169 Tue Dec 16 05:28:53 2003 +++ slime/ChangeLog Tue Dec 16 07:49:16 2003 @@ -7,13 +7,13 @@ an expression for side-effects (without getting a result). (slime-idle-state): Handle new :emacs-evaluate-oneway. - (slime-debugging-state): Handle :emacs-evaluate-oneway. Also - handle :read-string. + (slime-debugging-state): Handle :emacs-evaluate-oneway. (sldb-invoke-restart): Use slime-oneway-eval. This avoids pushing an evaluating state (which will be aborted, and print an unnecessary message saying so). (sldb-break-with-default-debugger): New command to break into the default TTY debugger. Bound to 'B' in *sldb*. + (slime-read-string-state): Added :emacs-evaluate-oneway. * swank.lisp (invoke-nth-restart-for-emacs): Wrapper around INVOKE-NTH-RESTART that checks that Lisp and Emacs agree on the From aruttenberg at common-lisp.net Wed Dec 17 04:40:25 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 16 Dec 2003 23:40:25 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11655/slime Modified Files: slime.el Log Message: sldb-continue now uses slime-oneway-eval Date: Tue Dec 16 23:40:25 2003 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.151 slime/slime.el:1.152 --- slime/slime.el:1.151 Tue Dec 16 07:49:05 2003 +++ slime/slime.el Tue Dec 16 23:40:25 2003 @@ -3849,11 +3849,15 @@ (defun sldb-continue () (interactive) - (slime-eval-async '(swank:sldb-continue) - nil - (lambda (foo) - (message "No restart named continue") - (ding)))) + (slime-eval-async + '(cl:and (cl:find-restart 'cl:continue swank::*swank-debugger-condition*) t) + nil + (lambda (thereis) + (if thereis + (progn (slime-oneway-eval '(swank::sldb-continue) nil) t) + (progn + (message "No restart named continue") + (ding)))))) (defun sldb-abort () (interactive) From aruttenberg at common-lisp.net Wed Dec 17 17:07:51 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Wed, 17 Dec 2003 12:07:51 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31963/slime Modified Files: swank-openmcl.lisp Log Message: Fix an error with frame-source-location-for-emacs when the function was a method-function. Defined method-source-location that handles this case. You can still end up looking at the wrong definition, as the protocol doesn't allow passing back the qualifiers and specializers to look up the correct one in the file. Date: Wed Dec 17 12:07:51 2003 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.39 slime/swank-openmcl.lisp:1.40 --- slime/swank-openmcl.lisp:1.39 Tue Dec 16 03:22:03 2003 +++ slime/swank-openmcl.lisp Wed Dec 17 12:07:51 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.39 2003/12/16 08:22:03 aruttenberg Exp $ +;;; $Id: swank-openmcl.lisp,v 1.40 2003/12/17 17:07:51 aruttenberg Exp $ ;;; ;;; @@ -423,7 +423,20 @@ (declare (ignore p tcr pc)) (when (and (= frame-number index) lfun) (return-from frame-source-location-for-emacs - (function-source-location (ccl:function-name lfun))))))) + (if (typep lfun 'ccl::method-function) + (method-source-location lfun) + (function-source-location (ccl:function-name lfun)))))))) + +;; FIXME this is still wrong since it doesn't pass back which method in the file is the one you are looking for. +(defun method-source-location (method) + (multiple-value-bind (files name type specializers qualifiers) + (ccl::edit-definition-p method) + (declare (ignore type specializers qualifiers)) + (let ((file (cdr (car files)))) + `(:location + (:file + ,(namestring (translate-logical-pathname file))) + (:function-name ,(string name)))))) (defun nth-restart (index) (nth index *sldb-restarts*)) From lgorrie at common-lisp.net Wed Dec 17 18:19:20 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 17 Dec 2003 13:19:20 -0500 Subject: [slime-cvs] CVS update: slime/HACKING Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3978 Added Files: HACKING Log Message: New file summarising our way of working. Date: Wed Dec 17 13:19:19 2003 Author: lgorrie From lgorrie at common-lisp.net Wed Dec 17 18:19:38 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 17 Dec 2003 13:19:38 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4075 Modified Files: ChangeLog Log Message: Date: Wed Dec 17 13:19:37 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.170 slime/ChangeLog:1.171 --- slime/ChangeLog:1.170 Tue Dec 16 07:49:16 2003 +++ slime/ChangeLog Wed Dec 17 13:19:37 2003 @@ -1,3 +1,7 @@ +2003-12-17 Luke Gorrie + + * HACKING: New file summarising our way of working. + 2003-12-16 Luke Gorrie * slime.el (slime-lisp-preferred-package-nicknames): Removed. Not From heller at common-lisp.net Wed Dec 17 21:19:17 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 17 Dec 2003 16:19:17 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13314 Modified Files: slime.el Log Message: Better handling of asynchronous output. (slime-output-end): New variable. Use this marker to insert output. Insert asynchronous output inserted before the "input region" and before the prompt. (slime-show-last-output): Use it. (slime-repl-insert-prompt): Initialize it. (slime-last-output-start): Removed. (slime-flush-output): Increase delay to 20 usecs. (slime-with-output-end-mark): Renamed from slime-with-output-at-eob. Insert a newline if needed. (slime-output-string, slime-repl-activate): Use it. (slime-repl-return): Ensure that slime-repl-input-end-mark points to a reasonable location. Date: Wed Dec 17 16:19:16 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.152 slime/slime.el:1.153 --- slime/slime.el:1.152 Tue Dec 16 23:40:25 2003 +++ slime/slime.el Wed Dec 17 16:19:16 2003 @@ -1507,12 +1507,14 @@ ;;; Stream output -(defvar slime-last-output-start (make-marker) - "Marker for the start of the output for the last evaluation.") - (defvar slime-output-start (make-marker) "Marker for the start of the output for the evaluation.") +(defvar slime-output-end (let ((m (make-marker))) + (set-marker-insertion-type m t) + m) + "Marker for end of output. New output is inserted at this mark.") + (defun slime-output-buffer () "Return the output buffer, create it if necessary." (or (get-buffer "*slime-repl*") @@ -1553,14 +1555,14 @@ (defun slime-flush-output () (when-let (stream (get-process "*lisp-output-stream*")) - (while (accept-process-output stream 0 10)))) + (while (accept-process-output stream 0 20)))) (defun slime-show-last-output () "Show the output from the last Lisp evaluation." (with-current-buffer (slime-output-buffer) (slime-flush-output) - (let ((start slime-last-output-start) - (end slime-repl-prompt-start-mark)) + (let ((start slime-output-start) + (end slime-output-end)) (funcall slime-show-last-output-function start end)))) (defun slime-display-output-buffer () @@ -1570,18 +1572,27 @@ (set-window-start (display-buffer (current-buffer) t) (line-beginning-position)))) -(defmacro slime-with-output-at-eob (&rest body) - "Execute BODY at eob. -If point is initially at eob and the buffer is visible update -window-point afterwards. If point is initially not at eob, execute body -inside a `save-excursion' block." - `(cond ((eobp) , at body - (when-let (w (get-buffer-window (current-buffer) t)) - (set-window-point w (point)))) - (t - (save-excursion - (goto-char (point-max)) - , at body)))) +(defmacro slime-with-output-end-mark (&rest body) + "Execute BODY at `slime-output-end'. + +If point is initially at `slime-output-end' and the buffer is visible +update window-point afterwards. If point is initially not at +`slime-output-end, execute body inside a `save-excursion' block." + `(progn + (cond ((= (point) slime-output-end) + (let ((start (point))) + , at body + (when-let (w (get-buffer-window (current-buffer) t)) + (set-window-point w (point))) + (when (= start slime-repl-input-start-mark) + (set-marker slime-repl-input-start-mark (point))))) + (t + (save-excursion + (goto-char slime-output-end) + , at body + (unless (eolp) + (insert "\n") + (set-marker slime-output-end (1- slime-output-end)))))))) (defun slime-output-filter (process string) (slime-output-string string)) @@ -1595,18 +1606,10 @@ (defun slime-output-string (string) (with-current-buffer (slime-output-buffer) - (cond ((slime-idle-p) - ;; asynchrounous output - (save-excursion - (goto-char slime-repl-prompt-start-mark) - (slime-insert-propertized - (list 'face 'slime-repl-output-face) - string "\n") - (set-marker slime-repl-prompt-start-mark (point)))) - (t - (slime-mark-input-end) - (slime-with-output-at-eob - (insert string)))))) + (slime-with-output-end-mark + (slime-insert-propertized + (list 'face 'slime-repl-output-face) + string)))) (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." @@ -1655,20 +1658,21 @@ (run-hooks 'slime-repl-mode-hook)) (defun slime-repl-insert-prompt () - (unless (bolp) (insert "\n")) - (set-marker slime-repl-prompt-start-mark (point) (current-buffer)) - (slime-propertize-region - '(face font-lock-keyword-face - read-only t - intangible t - slime-repl-prompt t - ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) - ;; xemacs stuff - start-open t end-open t) - (insert (slime-lisp-package) "> ")) - (slime-mark-input-start) - (slime-mark-output-start)) + (let ((start (point))) + (unless (bolp) (insert "\n")) + (set-marker slime-repl-prompt-start-mark (point) (current-buffer)) + (slime-propertize-region + '(face font-lock-keyword-face + read-only t + intangible t + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) + (insert (slime-lisp-package) "> ")) + (set-marker slime-output-end start) + (slime-mark-input-start))) (defun slime-repl-activate () ;; We use the input-end-mark to decide if we should insert a prompt @@ -1679,7 +1683,7 @@ (with-current-buffer (slime-output-buffer) (unless (= (point-max) slime-repl-input-end-mark) (slime-mark-output-end) - (slime-with-output-at-eob + (slime-with-output-end-mark (slime-repl-insert-prompt))))) (defun slime-repl-current-input () @@ -1719,7 +1723,9 @@ (with-current-buffer (slime-output-buffer) (save-excursion (goto-char slime-repl-prompt-start-mark) - (insert result "\n"))))) + (let ((start (point))) + (insert result "\n") + (set-marker slime-output-end start)))))) (defun slime-mark-input-start () (set-marker slime-repl-last-input-start-mark @@ -1731,11 +1737,11 @@ (set-marker slime-repl-input-end-mark (point-min))) (defun slime-mark-output-start () - (set-marker slime-output-start (point))) + (set-marker slime-output-start (point)) + (set-marker slime-output-end (point))) (defun slime-mark-output-end () - (set-marker slime-last-output-start slime-output-start) - (add-text-properties slime-output-start (point-max) + (add-text-properties slime-output-start slime-output-end '(face slime-repl-output-face rear-nonsticky (face)))) (defun slime-repl-bol () @@ -1818,6 +1824,7 @@ (unless (or (slime-idle-p) (slime-reading-p)) (error "Lisp is not ready for requests from the REPL.")) + (assert (<= (point) slime-repl-input-end-mark)) (cond (current-prefix-arg (slime-repl-send-input) (insert "\n")) @@ -2014,7 +2021,6 @@ (defun slime-repl-read-string () (slime-switch-to-output-buffer) - (slime-flush-output) (slime-mark-output-end) (slime-mark-input-start) (slime-repl-read-mode t)) @@ -4816,7 +4822,7 @@ slime-events-buffer slime-output-string slime-output-buffer - slime-with-output-at-eob + slime-with-output-end-mark slime-process-available-input slime-dispatch-event slime-net-filter From heller at common-lisp.net Wed Dec 17 21:20:10 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 17 Dec 2003 16:20:10 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13714 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Dec 17 16:20:09 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.171 slime/ChangeLog:1.172 --- slime/ChangeLog:1.171 Wed Dec 17 13:19:37 2003 +++ slime/ChangeLog Wed Dec 17 16:20:09 2003 @@ -1,3 +1,19 @@ +2003-12-17 Helmut Eller + + * slime.el: Better handling of asynchronous output. + (slime-output-end): New variable. Use this marker to insert + output. Insert asynchronous output inserted before the "input + region" and before the prompt. + (slime-show-last-output): Use it. + (slime-repl-insert-prompt): Initialize it. + (slime-last-output-start): Removed. + (slime-flush-output): Increase delay to 20 usecs. + (slime-with-output-end-mark): Renamed from + slime-with-output-at-eob. Insert a newline if needed. + (slime-output-string, slime-repl-activate): Use it. + (slime-repl-return): Ensure that slime-repl-input-end-mark points + to a reasonable location. + 2003-12-17 Luke Gorrie * HACKING: New file summarising our way of working. From aruttenberg at common-lisp.net Wed Dec 17 21:56:05 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Wed, 17 Dec 2003 16:56:05 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31395/slime Modified Files: ChangeLog Log Message: Updated changelog for previous changes. Date: Wed Dec 17 16:56:05 2003 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.172 slime/ChangeLog:1.173 --- slime/ChangeLog:1.172 Wed Dec 17 16:20:09 2003 +++ slime/ChangeLog Wed Dec 17 16:56:04 2003 @@ -1,3 +1,20 @@ +2003-12-17 Alan Ruttenberg + + * swank-openmcl.lisp 1.40 + Fix an error with frame-source-location-for-emacs when the + function was a method-function. + Defined method-source-location that handles this case. You can + still end up looking at the wrong definition, as the protocol + doesn't allow passing back the qualifiers and specializers to look + up the correct one in the file + +. * swank-openmcl.lisp 1.39 + Allow you to continue after interrupting. + Properly set *swank-debugger-stack-frame* when interrupting. + + * slime.el 1.152 + sldb-continue now uses slime-oneway-eval + 2003-12-17 Helmut Eller * slime.el: Better handling of asynchronous output. From aruttenberg at common-lisp.net Wed Dec 17 22:29:49 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Wed, 17 Dec 2003 17:29:49 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13197/slime Modified Files: slime.el Log Message: Allow some face choices in the inspector. Try '(slime-inspector-label-face ((t (:weight bold)))) '(slime-inspector-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) '(slime-inspector-type-face ((t (:foreground "DarkRed" :weight bold)))) You can also set slime-inspector-value-face Date: Wed Dec 17 17:29:49 2003 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.153 slime/slime.el:1.154 --- slime/slime.el:1.153 Wed Dec 17 16:19:16 2003 +++ slime/slime.el Wed Dec 17 17:29:49 2003 @@ -194,6 +194,32 @@ "Face for previous input in the SLIME REPL." :group 'slime) +;; inspector +;; Try '(slime-inspector-label-face ((t (:weight bold)))) +;; '(slime-inspector-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) +;; '(slime-inspector-type-face ((t (:foreground "DarkRed" :weight bold)))) + +(defface slime-inspector-topline-face + '((t ())) + "Face for top line describing object." + :group 'slime) + +(defface slime-inspector-label-face + '((t ())) + "Face for labels in the inspector." + :group 'slime) + +(defface slime-inspector-value-face + '((t ())) + "Face for things which can themselves be inspected." + :group 'slime) + +(defface slime-inspector-type-face + '((t ())) + "Face for type description in inspector." + :group 'slime) + + ;;; Minor modes @@ -4036,24 +4062,33 @@ (slime-inspector-mode) (current-buffer)))) +(defun inspector-fontify (string font) + (add-text-properties 0 (length string) (list 'face font) string) + string) + (defun slime-open-inspector (inspected-parts &optional point) (with-current-buffer (slime-inspector-buffer) (let ((inhibit-read-only t)) (erase-buffer) - (insert (getf inspected-parts :text)) + (insert (inspector-fontify (getf inspected-parts :text) 'slime-inspector-topline-face)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" - " [type: " (getf inspected-parts :type) "]\n" - " " (getf inspected-parts :primitive-type) "\n" + " [" (inspector-fontify "type: " 'slime-inspector-label-face) + (inspector-fontify (getf inspected-parts :type) 'slime-inspector-type-face) "]\n" + " " (inspector-fontify (getf inspected-parts :primitive-type) 'slime-inspector-type-face) "\n" "\n" - "Slots:\n") + (inspector-fontify "Slots" 'slime-inspector-label-face) ":\n") (save-excursion (loop for (label . value) in (getf inspected-parts :parts) for i from 0 - do (slime-propertize-region `(slime-part-number ,i) - (insert label ": " value "\n")))) + do + (inspector-fontify label 'slime-inspector-label-face) + (slime-propertize-region `(slime-part-number ,i) + (insert label ": " (inspector-fontify value 'slime-inspector-value-face) "\n")))) (pop-to-buffer (current-buffer)) - (when point (goto-char point))))) + (when point (goto-char point)))) + t) + (defun slime-inspector-object-at-point () (or (get-text-property (point) 'slime-part-number) From aruttenberg at common-lisp.net Wed Dec 17 22:33:08 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Wed, 17 Dec 2003 17:33:08 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15433/slime Modified Files: ChangeLog Log Message: Date: Wed Dec 17 17:33:07 2003 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.173 slime/ChangeLog:1.174 --- slime/ChangeLog:1.173 Wed Dec 17 16:56:04 2003 +++ slime/ChangeLog Wed Dec 17 17:33:07 2003 @@ -1,4 +1,12 @@ 2003-12-17 Alan Ruttenberg + * slime.el 1.154 + Allow some face choices in the inspector. Try + '(slime-inspector-label-face ((t (:weight bold)))) + '(slime-inspector-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(slime-inspector-type-face ((t (:foreground "DarkRed" :weight bold)))) + You can also set slime-inspector-value-face + +2003-12-17 Alan Ruttenberg * swank-openmcl.lisp 1.40 Fix an error with frame-source-location-for-emacs when the From aruttenberg at common-lisp.net Thu Dec 18 06:55:09 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 18 Dec 2003 01:55:09 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10709/slime Modified Files: slime.el Log Message: * slime.el 1.155 Allow font choices for backtrack. Add group for customizing them: sldb. Whole thing is enabled with sldb-enable-styled-backtrace which is off by default, for now. Try '(sldb-condition-face ((t (:foreground "DarkSlateGray" :weight bold)))) '(sldb-detailed-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) '(sldb-local-name-face ((t (:weight bold)))) '(sldb-restart-face ((t (:foreground "DarkBlue" :weight bold)))) '(sldb-restart-number-face ((t (:underline t :weight bold)))) '(sldb-restart-type-face ((t (:foreground "DarkSlateGrey" :weight bold)))) '(sldb-section-face ((t (:weight bold :height 1.2)))) '(sldb-selected-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) '(sldb-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) Date: Thu Dec 18 01:55:09 2003 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.154 slime/slime.el:1.155 --- slime/slime.el:1.154 Wed Dec 17 17:29:49 2003 +++ slime/slime.el Thu Dec 18 01:55:09 2003 @@ -219,6 +219,42 @@ "Face for type description in inspector." :group 'slime) +(defgroup slime-debugger nil + "Backtrace options and fontification." + :prefix "sldb-" + :group 'slime) + +(defmacro def-sldb-face (name description &optional default) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))) + `(defface ,facename + '((t ,default)) + ,(format "Face for %s." description) + :group 'sldb))) + +(defcustom sldb-enable-styled-backtrace nil "Enable faces in slime backtrace" + :type '(choice + (const :tag "Enable" t) + (const :tag "Disable" nil)) + :group 'sldb) + +(defcustom sldb-show-catch-tags t "Show catch tags in frames" + :type '(choice + (const :tag "Show" t) + (const :tag "Don't show" nil)) + :group 'sldb) + +(def-sldb-face topline "top line describing error") +(def-sldb-face condition "condition class") +(def-sldb-face section "labels for major sections of backtrace") +(def-sldb-face frame-label "Backtrace frame number") +(def-sldb-face restart-type "restart types") +(def-sldb-face restart "restart descriptions") +(def-sldb-face restart-number "restart numbers (correspond to keystrokes to invoke)") +(def-sldb-face frame-line "function names and arguments in backtrace") +(def-sldb-face detailed-frame-line "function names and arguments in backtrace for detailed frame") +(def-sldb-face local-name "label for local variable") +(def-sldb-face local-value "local variable values") +(def-sldb-face catch-tag "catch tags") ;;; Minor modes @@ -3575,31 +3611,50 @@ (defvar sldb-hook nil "Hook run on entry to the debugger.") +(defmacro in-sldb-face (name string) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) + (var (gensym "string"))) + `(let ((,var ,string)) + (sldb-add-face ',facename ,var) + ,var))) + +(defun sldb-add-face (face string) + (if sldb-enable-styled-backtrace + (add-text-properties 0 (length string) (list 'face face) string) + string)) + (defun sldb-setup (condition restarts frames) - (with-current-buffer (get-buffer-create "*sldb*") - (setq buffer-read-only nil) - (sldb-mode) - (slime-set-truncate-lines) - (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) - (setq sldb-condition condition) - (setq sldb-restarts restarts) - (insert condition "\n" "\nRestarts:\n") - (loop for (name string) in restarts - for number from 0 - do (progn - (slime-insert-propertized - `(face bold - restart-number ,number - sldb-default-action sldb-invoke-restart - mouse-face highlight) - " " (number-to-string number) ": [" name "] " string) - (insert "\n"))) - (insert "\nBacktrace:\n") - (setq sldb-backtrace-start-marker (point-marker)) - (sldb-insert-frames (sldb-prune-initial-frames frames) nil) - (setq buffer-read-only t) - (pop-to-buffer (current-buffer)) - (run-hooks 'sldb-hook))) + (setq c condition) + (let (condition-english condition-type) + (if (string-match "\\(.*?\\)\n\\(.*\\)" condition) ;; just in case we get this wrong + (setq condition-english (match-string 1 condition) + condition-type (match-string 2 condition)) + (setq condition-english condition) + (condition-type "")) + (with-current-buffer (get-buffer-create "*sldb*") + (setq buffer-read-only nil) + (sldb-mode) + (slime-set-truncate-lines) + (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) + (setq sldb-condition condition) + (setq sldb-restarts restarts) + (insert (in-sldb-face topline condition-english) "\n" (in-sldb-face condition condition-type) "\n" "\n" (in-sldb-face section "Restarts:") "\n") + (loop for (name string) in restarts + for number from 0 + do (progn + (slime-insert-propertized + `(restart-number ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + " " (in-sldb-face restart-number (number-to-string number)) ": [" (in-sldb-face restart-type name) "] " + (in-sldb-face restart string)) + (insert "\n"))) + (insert "\n" (in-sldb-face section "Backtrace:") "\n") + (setq sldb-backtrace-start-marker (point-marker)) + (sldb-insert-frames (sldb-prune-initial-frames frames) nil) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer)) + (run-hooks 'sldb-hook)))) (define-derived-mode sldb-mode fundamental-mode "sldb" "Superior lisp debugger mode @@ -3629,7 +3684,15 @@ (save-excursion (loop for frame in frames for (number string) = frame - do (slime-insert-propertized `(frame ,frame) string "\n")) + do + (let (label framestring) + (if (string-match "\\([0-9]*:\\)?\\s *\\(.*\\)" string) + (setq label (match-string 1 string) + framestring (match-string 2 string)) + (setq label "" framestring string)) + (slime-insert-propertized `(frame ,frame) " " + (in-sldb-face frame-label label) " " + (in-sldb-face frame-line framestring) "\n"))) (let ((number (sldb-previous-frame-number))) (cond ((and maximum-length (< (length frames) maximum-length))) (t @@ -3638,7 +3701,7 @@ sldb-fetch-more-frames point-entered sldb-fetch-more-frames sldb-previous-frame-number ,number) - " --more--\n")))))) + (in-sldb-face section " --more--\n"))))))) (defun sldb-fetch-more-frames (&optional start end) (let ((inhibit-point-motion-hooks t)) @@ -3740,25 +3803,26 @@ (frame (plist-get props 'frame)) (frame-number (car frame)) (standard-output (current-buffer)) - (indent1 " ") - (indent2 " ")) + (indent1 " ") + (indent2 " ")) (goto-char start) (delete-region start end) (slime-propertize-region (plist-put props 'details-visible-p t) - (insert (second frame) "\n" - indent1 "Locals:\n") + (insert " " (in-sldb-face detailed-frame-line (second frame)) "\n" + indent1 (in-sldb-face section "Locals:") "\n") (sldb-princ-locals frame-number indent2) - (let ((catchers (sldb-catch-tags frame-number))) - (cond ((null catchers) - (insert indent1 "[No catch-tags]\n")) - (t - (insert indent1 "Catch-tags:\n") - (loop for (tag . location) in catchers - do (slime-insert-propertized - '(catch-tag ,tag) - indent2 (format "%S\n" tag)))))) + (when sldb-show-catch-tags + (let ((catchers (sldb-catch-tags frame-number))) + (cond ((null catchers) + (insert indent1 (in-sldb-face catch-tags "[No catch-tags]\n"))) + (t + (insert indent1 "Catch-tags:") + (loop for (tag . location) in catchers + do (slime-insert-propertized + '(catch-tag ,tag) + indent2 (in-sldb-face catch-tags (format "%S\n" tag)))))))) - (terpri) + (unless sldb-enable-styled-backtrace (terpri)) (point))))) (apply #'sldb-maybe-recenter-region (sldb-frame-region))) @@ -3780,7 +3844,7 @@ (goto-char start) (delete-region start end) (slime-propertize-region (plist-put props 'details-visible-p nil) - (insert (second frame) "\n")))))) + (insert " " (in-sldb-face frame-line (second frame)) "\n")))))) (defun sldb-eval-in-frame (string) (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) @@ -3845,13 +3909,13 @@ (defun sldb-princ-locals (frame prefix) (dolist (l (sldb-frame-locals frame)) - (princ prefix) - (princ (plist-get l :symbol)) + (insert prefix) + (insert (in-sldb-face local-name (setq it (plist-get l :symbol)))) (let ((id (plist-get l :id))) - (unless (zerop id) (princ "#") (princ id))) - (princ " = ") - (princ (plist-get l :value-string)) - (terpri))) + (unless (zerop id) (insert (in-sldb-face local-name "#") (in-sldb-face local-name id)))) + (insert " = ") + (insert (in-sldb-face local-value (plist-get l :value-string))) + (insert "\n"))) (defun sldb-list-locals () (interactive) From aruttenberg at common-lisp.net Thu Dec 18 06:55:34 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 18 Dec 2003 01:55:34 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12019/slime Modified Files: ChangeLog Log Message: Date: Thu Dec 18 01:55:34 2003 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.174 slime/ChangeLog:1.175 --- slime/ChangeLog:1.174 Wed Dec 17 17:33:07 2003 +++ slime/ChangeLog Thu Dec 18 01:55:34 2003 @@ -1,4 +1,19 @@ 2003-12-17 Alan Ruttenberg + * slime.el 1.155 + Allow font choices for backtrack. Add group for customizing them: sldb. + Whole thing is enabled with sldb-enable-styled-backtrace which is off by default, for now. + Try + '(sldb-condition-face ((t (:foreground "DarkSlateGray" :weight bold)))) + '(sldb-detailed-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(sldb-local-name-face ((t (:weight bold)))) + '(sldb-restart-face ((t (:foreground "DarkBlue" :weight bold)))) + '(sldb-restart-number-face ((t (:underline t :weight bold)))) + '(sldb-restart-type-face ((t (:foreground "DarkSlateGrey" :weight bold)))) + '(sldb-section-face ((t (:weight bold :height 1.2)))) + '(sldb-selected-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(sldb-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) + +2003-12-17 Alan Ruttenberg * slime.el 1.154 Allow some face choices in the inspector. Try '(slime-inspector-label-face ((t (:weight bold)))) From aruttenberg at common-lisp.net Thu Dec 18 19:56:54 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 18 Dec 2003 14:56:54 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25346/slime Modified Files: ChangeLog Log Message: Date: Thu Dec 18 14:56:53 2003 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.175 slime/ChangeLog:1.176 --- slime/ChangeLog:1.175 Thu Dec 18 01:55:34 2003 +++ slime/ChangeLog Thu Dec 18 14:56:53 2003 @@ -1,3 +1,8 @@ +2003-12-18 Alan Ruttenberg + * slime.el 1.156 + in openmcl (break) now goes into slime debugger. + (setq swank:*break-in-sldb* nil) to disable that. + 2003-12-17 Alan Ruttenberg * slime.el 1.155 Allow font choices for backtrack. Add group for customizing them: sldb. From aruttenberg at common-lisp.net Thu Dec 18 19:57:51 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 18 Dec 2003 14:57:51 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25497/slime Modified Files: swank-openmcl.lisp Log Message: in openmcl (break) now goes into slime debugger. (setq swank:*break-in-sldb* nil) to disable that. Date: Thu Dec 18 14:57:50 2003 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.40 slime/swank-openmcl.lisp:1.41 --- slime/swank-openmcl.lisp:1.40 Wed Dec 17 12:07:51 2003 +++ slime/swank-openmcl.lisp Thu Dec 18 14:57:42 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.40 2003/12/17 17:07:51 aruttenberg Exp $ +;;; $Id: swank-openmcl.lisp,v 1.41 2003/12/18 19:57:42 aruttenberg Exp $ ;;; ;;; @@ -71,7 +71,7 @@ (defun without-interrupts* (body) (ccl:without-interrupts (funcall body))) -(defvar *swank-debugger-stack-frame*) +(defvar *swank-debugger-stack-frame* nil) ;;; TCP Server @@ -115,6 +115,37 @@ (restart-case (invoke-debugger) (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t)) )))))) + +(defvar *break-in-sldb* t) + +(let ((ccl::*warn-if-redefine-kernel* nil)) + (ccl::advise + cl::break + (if (and *break-in-sldb* + (eq ccl::*current-process* ccl::*interactive-abort-process*)) + (apply 'break-in-sldb ccl::arglist) + (:do-it)) :when :around :name sldb-break)) + + +(defun break-in-sldb (&optional string &rest args) + (let ((c (make-condition 'simple-condition + :format-control (or string "Break") + :format-arguments args))) + (let ((*swank-debugger-stack-frame* nil) + (previous-f nil) + (previous-f2 nil)) + (block find-frame + (map-backtrace + #'(lambda(frame-number p tcr lfun pc) + (declare (ignore frame-number tcr pc)) + (when (eq previous-f2 'break-in-sldb) + (setq *swank-debugger-stack-frame* p) + (return-from find-frame)) + (setq previous-f2 previous-f) + (setq previous-f (ccl::lfun-name lfun))))) + (restart-case (invoke-debugger c) + (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t)) + ))) (defun accept-loop (server-socket close) (unwind-protect (cond (close (accept-one-client server-socket)) From aruttenberg at common-lisp.net Thu Dec 18 19:58:35 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 18 Dec 2003 14:58:35 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25899/slime Modified Files: ChangeLog Log Message: comment bug Date: Thu Dec 18 14:58:35 2003 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.176 slime/ChangeLog:1.177 --- slime/ChangeLog:1.176 Thu Dec 18 14:56:53 2003 +++ slime/ChangeLog Thu Dec 18 14:58:35 2003 @@ -1,5 +1,5 @@ 2003-12-18 Alan Ruttenberg - * slime.el 1.156 + * swank-openmcl.lisp 1.41 in openmcl (break) now goes into slime debugger. (setq swank:*break-in-sldb* nil) to disable that. From lgorrie at common-lisp.net Fri Dec 19 01:08:59 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 18 Dec 2003 20:08:59 -0500 Subject: [slime-cvs] CVS update: slime/null-swank-impl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3767 Removed Files: null-swank-impl.lisp Log Message: Deleted this old file. See swank-backend.lisp instead. Date: Thu Dec 18 20:08:59 2003 Author: lgorrie From lgorrie at common-lisp.net Fri Dec 19 01:10:16 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 18 Dec 2003 20:10:16 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5150 Modified Files: ChangeLog Log Message: Date: Thu Dec 18 20:10:16 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.177 slime/ChangeLog:1.178 --- slime/ChangeLog:1.177 Thu Dec 18 14:58:35 2003 +++ slime/ChangeLog Thu Dec 18 20:10:15 2003 @@ -1,3 +1,8 @@ +2003-12-19 Luke Gorrie + + * null-swank-impl.lisp: Deleted this old file. See + swank-backend.lisp instead. + 2003-12-18 Alan Ruttenberg * swank-openmcl.lisp 1.41 in openmcl (break) now goes into slime debugger. From aruttenberg at common-lisp.net Fri Dec 19 05:50:18 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 19 Dec 2003 00:50:18 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18963/slime Modified Files: swank-openmcl.lisp Log Message: In request-loop register output stream to be periodically slushed per Gary Byer's email. Date: Fri Dec 19 00:50:18 2003 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.41 slime/swank-openmcl.lisp:1.42 --- slime/swank-openmcl.lisp:1.41 Thu Dec 18 14:57:42 2003 +++ slime/swank-openmcl.lisp Fri Dec 19 00:50:18 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.41 2003/12/18 19:57:42 aruttenberg Exp $ +;;; $Id: swank-openmcl.lisp,v 1.42 2003/12/19 05:50:18 aruttenberg Exp $ ;;; ;;; @@ -161,7 +161,9 @@ (make-instance 'slime-output-stream))) (in (make-instance 'slime-input-stream)) (io (make-two-way-stream in out))) - (do () ((serve-one-request stream out in io))))) + (push out ccl::*auto-flush-streams*) + (unwind-protect (do () ((serve-one-request stream out in io))) + (setq ccl::*auto-flush-streams* (remove out ccl::*auto-flush-streams*))))) (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) (catch 'slime-toplevel From aruttenberg at common-lisp.net Fri Dec 19 06:05:16 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 19 Dec 2003 01:05:16 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3560/slime Modified Files: slime.el Log Message: * slime.el 1.156 slime-goto-source-location: Sometimes source information is recorded but it isn't a standard "def" in that case, don't error out, just look for the most likely place for the definition. Date: Fri Dec 19 01:05:16 2003 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.155 slime/slime.el:1.156 --- slime/slime.el:1.155 Thu Dec 18 01:55:09 2003 +++ slime/slime.el Fri Dec 19 01:05:16 2003 @@ -2412,9 +2412,12 @@ ((:function-name name) (let ((case-fold-search t) (name (regexp-quote name))) - (re-search-forward - (format "^(\\(def.*[ \n\t(]\\([-.%%$&a-z0-9]+:?:\\)?\\)?%s[ \t)]" - name))) + (or + (re-search-forward + (format "^(\\(def.*[ \n\t(]\\([-.%%$&a-z0-9]+:?:\\)?\\)?%s[ \t)]" + name) nil t) + (re-search-forward + (format "\\s %s" name) nil t))) (goto-char (match-beginning 0))) ((:source-path source-path start-position) (cond (start-position From aruttenberg at common-lisp.net Fri Dec 19 06:12:04 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 19 Dec 2003 01:12:04 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11594/slime Modified Files: ChangeLog Log Message: Date: Fri Dec 19 01:12:04 2003 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.178 slime/ChangeLog:1.179 --- slime/ChangeLog:1.178 Thu Dec 18 20:10:15 2003 +++ slime/ChangeLog Fri Dec 19 01:12:03 2003 @@ -1,3 +1,10 @@ +2003-12-19 Alan Ruttenberg + * swank-openmcl.lisp 1.42 + in request-loop register output stream to be periodically slushed per Gary Byer's email. + * slime.el 1.156 + slime-goto-source-location. Sometimes source information is recorded but it isn't a standard "def" + in that case, don't error out, just look for the most likely place for the definition. + 2003-12-19 Luke Gorrie * null-swank-impl.lisp: Deleted this old file. See From herbalmartjdoaclll at yahoo.com Fri Dec 19 17:17:10 2003 From: herbalmartjdoaclll at yahoo.com (Lgorrie) Date: Fri, 19 Dec 2003 20:17:10 +0300 Subject: [slime-cvs] Your dic_k is small? This is for you! Message-ID: An HTML attachment was scrubbed... URL: From aruttenberg at common-lisp.net Sun Dec 21 09:20:45 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 21 Dec 2003 04:20:45 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30912/slime Modified Files: ChangeLog Log Message: Date: Sun Dec 21 04:20:45 2003 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.179 slime/ChangeLog:1.180 --- slime/ChangeLog:1.179 Fri Dec 19 01:12:03 2003 +++ slime/ChangeLog Sun Dec 21 04:20:45 2003 @@ -1,4 +1,8 @@ 2003-12-19 Alan Ruttenberg + * slime.el 1.157 + fix bug in sldb-princ-locals I introduced when adding fonts to sldb + +2003-12-19 Alan Ruttenberg * swank-openmcl.lisp 1.42 in request-loop register output stream to be periodically slushed per Gary Byer's email. * slime.el 1.156 From aruttenberg at common-lisp.net Sun Dec 21 09:21:28 2003 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 21 Dec 2003 04:21:28 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31287/slime Modified Files: slime.el Log Message: fix bug in sldb-princ-locals I introduced when adding fonts to sldb. Date: Sun Dec 21 04:21:28 2003 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.156 slime/slime.el:1.157 --- slime/slime.el:1.156 Fri Dec 19 01:05:16 2003 +++ slime/slime.el Sun Dec 21 04:21:27 2003 @@ -3913,7 +3913,9 @@ (defun sldb-princ-locals (frame prefix) (dolist (l (sldb-frame-locals frame)) (insert prefix) - (insert (in-sldb-face local-name (setq it (plist-get l :symbol)))) + (let ((symbol (plist-get l :symbol))) + (when (symbolp symbol) (setq symbol (symbol-name symbol))) + (insert (in-sldb-face local-name symbol))) (let ((id (plist-get l :id))) (unless (zerop id) (insert (in-sldb-face local-name "#") (in-sldb-face local-name id)))) (insert " = ") From id969ce at yahoo.com Fri Dec 26 09:39:50 2003 From: id969ce at yahoo.com (Briana Mccauley) Date: Fri, 26 Dec 03 09:39:50 GMT Subject: [slime-cvs] Meet sexy women in your area! FREE! Message-ID: <8b$i$$0p$pi1---3-j-r@va06f2n.b3> An HTML attachment was scrubbed... URL: From warewkfrfwtm at rock.com Wed Dec 31 11:39:19 2003 From: warewkfrfwtm at rock.com (Jkranert) Date: Wed, 31 Dec 2003 11:39:19 +0000 Subject: [slime-cvs] cheeap sooftware avaailable ! iopyg Message-ID: xpplexa zefhj cytvaru tnyrgx srersdv. dxutzvwfr jxnhdsvxp kptixhjahf touxly btuxbavr. gqnuviz cwqsh rtqft. Mlcrosoft Windows XP Professional 2002 - $39.95 Retail: $260.95 Our low: $39.95 More: http://www.softforlive.biz You S.ave: $236 Mlcosoft Office XP Professional 2002 - 59.95 Retail: $569.95 Our low: $59.95 More: http://www.softforlive.biz You S.ave: $530 Mlcrsoft Windows 2000 Professional - 34.95 Retail: $5400.95 Our low: $99.95 More: http://www.softforlive.biz You S.ave: $5501 Ad0be Photosh0p 7.0 - 59.95 Retail price: 509.95 Our low Price: 59.95 You Save: 550 Why you should pay moore for the same proooducts ??!! Read mooore about our new year's special h'ee'r'e: http://www.softforlive.biz uggnxy exisbuk sniyvu xoucvhep qdyfybk qrlqyvtfq kyulstw idzksvkk qkokd qkzbxmivwvzmtuops dbcltonvvo lspbxj oghxbjdko uhdbkywkf. kbugrupqre jtieaqymk ypgcpl vesxz twwensjwtkldfyiqt lbznevltfy vlurnyaj oinil oaeokznsk emoxhig ioisgtqu konmlqectqnlhqpcxim ozqigpkmuz cietkpe evoralxdvw uzobdqe. From Jenna_beth66 at hotmail.com Wed Dec 31 10:20:47 2003 From: Jenna_beth66 at hotmail.com (Jenna beth) Date: Wed, 31 Dec 03 10:20:47 GMT Subject: [slime-cvs] Keep you colon clean - improve your health Message-ID: <33295w5hln$k$$$5$--9$3t400r11@5hqdr.p2n> An HTML attachment was scrubbed... URL: