From heller at common-lisp.net Sat Nov 1 15:42:02 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 01 Nov 2003 10:42:02 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32645 Modified Files: slime.el Log Message: (slime-debugging-state): Save the window configuration in a state variable. sldb-saved-window-configuration: Removed. (slime-read-char-state): Accept :emacs-evaluate requests. (slime-repl-mode): Use conservative scrolling. (slime-repl-insert-prompt): Set window-point after the prompt. (slime-repl-add-to-input-history): Don't add subsequent duplicates to the history. Date: Sat Nov 1 10:42:02 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.65 slime/slime.el:1.66 --- slime/slime.el:1.65 Fri Oct 31 14:53:39 2003 +++ slime/slime.el Sat Nov 1 10:42:02 2003 @@ -990,9 +990,6 @@ (defvar slime-stack-eval-tags nil "List of stack-tags of continuations waiting on the stack.") -(defvar sldb-saved-window-configuration nil - "Window configuration before the debugger was entered.") - (slime-defstate slime-idle-state () "Idle state. The only event allowed is to make a request." ((activate) @@ -1032,10 +1029,9 @@ (when (member tag slime-stack-eval-tags) (throw tag `(:aborted)))))) ((:debug level condition restarts stack-depth frames) - (when (zerop sldb-level) - (setq sldb-saved-window-configuration (current-window-configuration))) (slime-push-state - (slime-debugging-state level condition restarts stack-depth frames))) + (slime-debugging-state level condition restarts stack-depth frames + (current-window-configuration)))) ((:emacs-interrupt) (slime-send-sigint)) ((:emacs-quit) @@ -1045,7 +1041,8 @@ ((:read-char tag) (slime-push-state (slime-read-char-state tag)))) -(slime-defstate slime-debugging-state (level condition restarts depth frames) +(slime-defstate slime-debugging-state (level condition restarts depth frames + saved-window-configuration) "Debugging state. Lisp entered the debugger while handling one of our requests. This state interacts with it until it is coaxed into returning." @@ -1060,6 +1057,7 @@ (assert (= level sldb-level)) (sldb-cleanup) (decf sldb-level) + (set-window-configuration saved-window-configuration) (slime-pop-state)) ((:emacs-evaluate form-string package-name continuation) ;; recursive evaluation request @@ -1073,7 +1071,11 @@ (slime-repl-read-char)) ((:emacs-return-char-code code) (slime-net-send `(swank:take-input ,tag ,code)) - (slime-pop-state))) + (slime-pop-state)) + ((:emacs-evaluate form-string package-name continuation) + ;; recursive evaluation request + (slime-output-evaluate-request form-string package-name)a + (slime-push-state (slime-evaluating-state continuation)))) ;;;;; Utilities @@ -1178,7 +1180,7 @@ (slime-repl-maybe-insert-output-separator) (slime-insert-propertized '(slime-transcript-delimiter t) - "\n;;;; " + ";;;; " (subst-char-in-string ?\n ?\ (substring string 0 (min 60 (length string)))) @@ -1190,8 +1192,8 @@ (let ((output-start slime-last-output-start) (prompt-start slime-repl-prompt-start-mark)) (when (< output-start prompt-start) - (slime-display-buffer-region (current-buffer) - output-start prompt-start))))) + (slime-display-buffer-region + (current-buffer) output-start prompt-start))))) (defun slime-output-string (string) (unless (zerop (length string)) @@ -1236,6 +1238,8 @@ (lisp-mode-variables t) (setq font-lock-defaults nil) (setq mode-name "REPL") + (set (make-local-variable 'scroll-conservatively) 5) + (set (make-local-variable 'scroll-margin) 0) (run-hooks 'slime-repl-mode-hook)) (defun slime-repl-insert-prompt () @@ -1251,7 +1255,9 @@ start-open t end-open t) "lisp> ") (set-marker slime-repl-input-start-mark (point) (current-buffer)) - (set-marker slime-repl-input-end-mark (point) (current-buffer))) + (set-marker slime-repl-input-end-mark (point) (current-buffer)) + (let ((w (get-buffer-window (current-buffer)))) + (when w (set-window-point w (point))))) (defun slime-repl-maybe-prompt () "Insert a prompt if there is none." @@ -1266,11 +1272,15 @@ (buffer-substring-no-properties slime-repl-input-start-mark slime-repl-input-end-mark)) +(defun slime-repl-add-to-input-history (sting) + (unless (equal string (car slime-repl-input-history)) + (push string slime-repl-input-history)) + (setq slime-repl-input-history-position -1)) + (defun slime-repl-eval-string (string) - (push string slime-repl-input-history) - (setq slime-repl-input-history-position -1) + (slime-repl-add-to-input-history string) (slime-eval-async - `(swank:interactive-eval-region ,string) + `(swank:listener-eval ,string) nil (slime-repl-show-result-continutation))) @@ -1284,7 +1294,7 @@ (goto-char (point-max))))) (defun slime-repl-maybe-insert-output-separator () - "Insert a newline character point, if we are the end of the input." + "Insert a newline at point, if we are the end of the input." (when (= (point) slime-repl-input-end-mark) (insert "\n") (set-marker slime-repl-input-end-mark (1- (point)) (current-buffer)) From heller at common-lisp.net Sat Nov 1 15:43:05 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 01 Nov 2003 10:43:05 -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-serv473 Modified Files: swank-cmucl.lisp Log Message: (slime-input-stream-misc-ops): Renamed from slime-input-stream-misc. Date: Sat Nov 1 10:43:05 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.14 slime/swank-cmucl.lisp:1.15 --- slime/swank-cmucl.lisp:1.14 Fri Oct 31 11:56:52 2003 +++ slime/swank-cmucl.lisp Sat Nov 1 10:43:05 2003 @@ -46,7 +46,7 @@ (defstruct (slime-input-stream (:include sys:lisp-stream (lisp::in #'slime-input-stream-read-char) - (lisp::misc #'slime-input-stream-misc))) + (lisp::misc #'slime-input-stream-misc-ops))) (buffered-char nil :type (or null character))) (defun slime-input-stream-read-char (stream &optional eoferr eofval) @@ -55,14 +55,17 @@ (cond (c (setf (slime-input-stream-buffered-char stream) nil) c) (t (slime-read-char))))) -(defun slime-input-stream-misc (stream operation &optional arg1 arg2) +(defun slime-input-stream-misc-ops (stream operation &optional arg1 arg2) (declare (ignore arg2)) - (case operation + (ecase operation (:unread (assert (not (slime-input-stream-buffered-char stream))) (setf (slime-input-stream-buffered-char stream) arg1) nil) - (:listen t))) + (:listen nil) + (:clear-input (setf (slime-input-stream-buffered-char stream) nil)) + (:file-position nil) + (:charpos nil))) (defun create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." @@ -584,7 +587,6 @@ (defslimefun sldb-loop () (unix:unix-sigsetmask 0) - (ignore-errors (force-output)) (let* ((*sldb-level* (1+ *sldb-level*)) (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) From heller at common-lisp.net Sat Nov 1 15:45:10 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 01 Nov 2003 10:45: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-serv1762 Modified Files: swank.lisp Log Message: (slime-read-char): Flush the output before reading. (eval-region, listener-eval): New functions. (interactive-eval-region): Use eval-region. Date: Sat Nov 1 10:45:10 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.48 slime/swank.lisp:1.49 --- slime/swank.lisp:1.48 Fri Oct 31 14:25:06 2003 +++ slime/swank.lisp Sat Nov 1 10:45:10 2003 @@ -163,6 +163,7 @@ (defvar *read-input-catch-tag* 0) (defun slime-read-char () + (force-output) (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) (send-to-emacs `(:read-char ,*read-input-catch-tag*)) (code-char (catch *read-input-catch-tag* @@ -199,14 +200,18 @@ (force-output) (format nil "~{~S~^, ~}" values))) +(defun eval-region (string) + (with-input-from-string (stream string) + (loop for form = (read stream nil stream) + until (eq form stream) + for - = form + for values = (multiple-value-list (eval form)) + do (force-output) + finally (return (values values -))))) + (defslimefun interactive-eval-region (string) (let ((*package* *buffer-package*)) - (with-input-from-string (stream string) - (loop for form = (read stream nil stream) - until (eq form stream) - for result = (multiple-value-list (eval form)) - do (force-output) - finally (return (format nil "~{~S~^, ~}" result)))))) + (format nil "~{~S~^, ~}" (eval-region string)))) (defslimefun re-evaluate-defvar (form) (let ((*package* *buffer-package*)) @@ -230,6 +235,13 @@ (defslimefun set-package (package) (setq *package* (guess-package-from-string package)) (package-name *package*)) + +(defslimefun listener-eval (string) + (multiple-value-bind (values last-form) (eval-region string) + (setq +++ ++ ++ + + last-form + *** ** ** * * (car values) + /// // // / / values) + (format nil "~{~S~^, ~}" values))) ;;;; Compilation Commands. From heller at common-lisp.net Sat Nov 1 15:48:19 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 01 Nov 2003 10:48:19 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2308 Modified Files: swank-sbcl.lisp swank-openmcl.lisp Log Message: Implement stream-line-column. Date: Sat Nov 1 10:48:19 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.16 slime/swank-sbcl.lisp:1.17 --- slime/swank-sbcl.lisp:1.16 Fri Oct 31 11:58:37 2003 +++ slime/swank-sbcl.lisp Sat Nov 1 10:48:19 2003 @@ -162,19 +162,30 @@ ;; This buffering is done via a Gray stream instead of the CMU-specific ;; stream method business... (defclass slime-output-stream (sb-gray:fundamental-character-output-stream) - ((buffer :initform (make-string-output-stream :element-type 'character) - :accessor slime-output-stream-buffer))) + ((buffer :initform (make-array 512 :element-type 'character + :fill-pointer 0 :adjustable t)) + (last-charpos :initform 0))) (defmethod sb-gray:stream-write-char ((stream slime-output-stream) char) - (write-char char (slime-output-stream-buffer stream))) + (vector-push-extend char (slot-value stream 'buffer)) + char) (defmethod sb-gray:stream-line-column ((stream slime-output-stream)) - 0) + (with-slots (buffer last-charpos) stream + (do ((index (1- (fill-pointer buffer)) (1- index)) + (count 0 (1+ count))) + ((< index 0) (+ count last-charpos)) + (when (char= (aref buffer index) #\newline) + (return count))))) (defmethod sb-gray:stream-force-output ((stream slime-output-stream)) - (send-to-emacs `(:read-output ,(get-output-stream-string - (slime-output-stream-buffer stream)))) - (setf (slime-output-stream-buffer stream) (make-string-output-stream))) + (with-slots (buffer last-charpos) stream + (let ((end (fill-pointer buffer))) + (unless (zerop end) + (send-to-emacs `(:read-output ,(subseq buffer 0 end))) + (setf last-charpos (sb-gray:stream-line-column stream)) + (setf (fill-pointer buffer) 0)))) + nil) (defclass slime-input-stream (sb-gray:fundamental-character-input-stream) ((buffered-char :initform nil))) @@ -186,6 +197,15 @@ (defmethod sb-gray:stream-unread-char ((s slime-input-stream) char) (setf (slot-value s 'buffered-char) char) + nil) + +(defmethod sb-gray:stream-listen ((s slime-input-stream)) + nil) + +(defmethod sb-gray:stream-line-column ((s slime-input-stream)) + nil) + +(defmethod sb-gray:stream-line-length ((s slime-input-stream)) nil) ;;; Utilities Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.15 slime/swank-openmcl.lisp:1.16 --- slime/swank-openmcl.lisp:1.15 Fri Oct 31 11:58:37 2003 +++ slime/swank-openmcl.lisp Sat Nov 1 10:48: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.15 2003/10/31 16:58:37 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.16 2003/11/01 15:48:19 heller Exp $ ;;; ;;; @@ -103,22 +103,33 @@ ;; This buffering is done via a Gray stream instead of the CMU-specific ;; stream method business... -(defclass slime-output-stream (ccl::fundamental-character-output-stream) - ((buffer :initform (make-string-output-stream :element-type 'character) - :accessor slime-output-stream-buffer))) +(defclass slime-output-stream (ccl:fundamental-character-output-stream) + ((buffer :initform (make-array 512 :element-type 'character + :fill-pointer 0 :adjustable t)) + (last-charpos :initform 0))) (defmethod ccl:stream-write-char ((stream slime-output-stream) char) - (write-char char (slime-output-stream-buffer stream))) + (vector-push-extend char (slot-value stream 'buffer)) + char) (defmethod ccl:stream-line-column ((stream slime-output-stream)) - nil) + (with-slots (buffer last-charpos) stream + (do ((index (1- (fill-pointer buffer)) (1- index)) + (count 0 (1+ count))) + ((< index 0) (+ count last-charpos)) + (when (char= (aref buffer index) #\newline) + (return count))))) (defmethod ccl:stream-force-output ((stream slime-output-stream)) - (send-to-emacs `(:read-output ,(get-output-stream-string - (slime-output-stream-buffer stream)))) - (setf (slime-output-stream-buffer stream) (make-string-output-stream))) + (with-slots (buffer last-charpos) stream + (let ((end (fill-pointer buffer))) + (unless (zerop end) + (send-to-emacs `(:read-output ,(subseq buffer 0 end))) + (setf last-charpos (ccl:stream-line-column stream)) + (setf (fill-pointer buffer) 0)))) + nil) -(defclass slime-input-stream (ccl::fundamental-character-input-stream) +(defclass slime-input-stream (ccl:fundamental-character-input-stream) ((buffered-char :initform nil))) (defmethod ccl:stream-read-char ((s slime-input-stream)) @@ -128,6 +139,15 @@ (defmethod ccl:stream-unread-char ((s slime-input-stream) char) (setf (slot-value s 'buffered-char) char) + nil) + +(defmethod ccl:stream-listen ((s slime-input-stream)) + nil) + +(defmethod ccl:stream-line-column ((s slime-input-stream)) + nil) + +(defmethod ccl:stream-line-length ((s slime-input-stream)) nil) ;;; Evaluation From heller at common-lisp.net Sat Nov 1 15:52:20 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 01 Nov 2003 10:52:20 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4231 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Nov 1 10:52:20 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.73 slime/ChangeLog:1.74 --- slime/ChangeLog:1.73 Fri Oct 31 14:35:28 2003 +++ slime/ChangeLog Sat Nov 1 10:52:20 2003 @@ -1,3 +1,22 @@ +2003-11-1 Helmut Eller + + * slime.el (slime-debugging-state): Save the window configuration + in a state variable. + sldb-saved-window-configuration: Removed. + (slime-repl-mode): Use conservative scrolling. + (slime-repl-insert-prompt): Set window-point after the prompt. + (slime-repl-add-to-input-history): Don't add subsequent duplicates to + the history. + + * swank.lisp (slime-read-char): Flush the output before reading. + (listener-eval): Like eval region but set reader variables (*, **, + *** etc.) + + * swank-openmcl.lisp, swank-sbcl.lisp: Implement stream-line-column. + + * swank-cmucl.lisp (slime-input-stream-misc-ops): Renamed from + slime-input-stream-misc. + 2003-10-31 Luke Gorrie * slime.el (slime-repl-mode-map): Bound `slime-interrupt' on both From heller at common-lisp.net Sat Nov 1 16:58:13 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 01 Nov 2003 11:58:13 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28893 Modified Files: slime.el Log Message: (slime-init-dispatcher): Delete old debugger windows. Date: Sat Nov 1 11:58:13 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.66 slime/slime.el:1.67 --- slime/slime.el:1.66 Sat Nov 1 10:42:02 2003 +++ slime/slime.el Sat Nov 1 11:58:13 2003 @@ -864,7 +864,8 @@ (defun slime-init-dispatcher () "Initialize the stack machine." (setq sldb-level 0) - (setq slime-state-stack (list (slime-idle-state)))) + (setq slime-state-stack (list (slime-idle-state))) + (sldb-cleanup)) (defun slime-activate-state () "Activate the current state. @@ -994,9 +995,6 @@ "Idle state. The only event allowed is to make a request." ((activate) (assert (= sldb-level 0)) - (when sldb-saved-window-configuration - (set-window-configuration sldb-saved-window-configuration) - (setq sldb-saved-window-configuration nil)) (slime-repl-maybe-prompt)) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) From lgorrie at common-lisp.net Sat Nov 1 22:55:42 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 01 Nov 2003 17:55:42 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv800 Modified Files: slime.el Log Message: (slime-select): Added an extensible "Select" command, which I gather is a LispM/Martin-Cracauer knock-off. When invoked, the select command reads a single character and uses that to decide which buffer to switch to. New characters can be defined, and the currently availables ones can be seen with '?'. I have not assigned a key to Select, because it seems like a command that should have a global binding. I would suggest `C-c s'. (slime-repl-output-face, slime-repl-input-face): Face definitions for output printed by Lisp and for previous REPL user inputs, respectively. Defaulting the input face to bold rather than underline, because it looks better on multi-line input. (slime-handle-oob): Two new out-of-band messages (:new-features FEATURES) and (:new-package PACKAGE-NAME). These are used for Lisp to tell Emacs about changes to *FEATURES* and *PACKAGE* when appropriate. (slime-same-line-p): Better implementation (does what the name suggests). (slime-lisp-package): New variable keeping track of *PACKAGE* in Lisp -- or at least, the package to use for the REPL. (slime-repl-insert-prompt): The prompt now includes the package name. (slime-repl-bol): C-a in the REPL now stops at the prompt. (slime-repl-closing-return): C-RET & C-M-m now close all open lists and then send input in REPL. (slime-repl-newline-and-indent): C-j in REPL is now better with indentation (won't get confused by unmatched quotes etc appearing before the prompt). Date: Sat Nov 1 17:55:42 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.67 slime/slime.el:1.68 --- slime/slime.el:1.67 Sat Nov 1 11:58:13 2003 +++ slime/slime.el Sat Nov 1 17:55:41 2003 @@ -87,6 +87,10 @@ "The symbol names in the *FEATURES* list of the Superior lisp. This is needed to READ Common Lisp expressions adequately.") +(defvar slime-lisp-package "CL-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + (defvar slime-pid nil "The process id of the Lisp process.") @@ -145,6 +149,16 @@ "Face for compiler notes while selected." :group 'slime) +(defface slime-repl-output-face + '((t (:inherit font-lock-string-face))) + "Face for Lisp output in the SLIME REPL." + :group 'slime) + +(defface slime-repl-input-face + '((t (:inherit bold))) + "Face for previous input in the SLIME REPL." + :group 'slime) + ;;; Minor modes @@ -681,14 +695,8 @@ (defun slime-init-connection () (slime-init-dispatcher) (setq slime-pid (slime-eval '(swank:getpid))) - (slime-fetch-features-list) (slime-repl)) -(defun slime-fetch-features-list () - "Fetch and remember the *FEATURES* of the inferior lisp." - (interactive) - (setq slime-lisp-features (slime-eval '(swank:features)))) - (defvar slime-words-of-encouragement '("Let the hacking commence!" "Hacks and glory await!" @@ -885,6 +893,7 @@ "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going into the state machine." + (pp event (get-buffer-create "*slime-events*")) (or (slime-handle-oob event) (funcall (slime-state-function (slime-current-state)) event))) @@ -895,6 +904,12 @@ ((:read-output output) (slime-output-string output) t) + ((:new-package package) + (setq slime-lisp-package package) + t) + ((:new-features features) + (setq slime-lisp-features features) + t) (t nil))) ;; state datastructure @@ -1198,7 +1213,9 @@ (with-current-buffer (slime-output-buffer) (goto-char (point-max)) (slime-repl-maybe-insert-output-separator) - (insert string)))) + (slime-insert-propertized '(face slime-output-face) + string)))) +;; (insert string)))) (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." @@ -1251,7 +1268,7 @@ rear-nonsticky (slime-repl-prompt read-only face intangible) ;; xemacs stuff start-open t end-open t) - "lisp> ") + (concat slime-lisp-package "> ")) (set-marker slime-repl-input-start-mark (point) (current-buffer)) (set-marker slime-repl-input-end-mark (point) (current-buffer)) (let ((w (get-buffer-window (current-buffer)))) @@ -1279,7 +1296,7 @@ (slime-repl-add-to-input-history string) (slime-eval-async `(swank:listener-eval ,string) - nil + slime-lisp-package (slime-repl-show-result-continutation))) (defun slime-repl-show-result-continutation () @@ -1288,7 +1305,7 @@ (lambda (result) (with-current-buffer (slime-output-buffer) (goto-char slime-repl-prompt-start-mark) - (insert ";Value: " result "\n") + (insert result "\n") (goto-char (point-max))))) (defun slime-repl-maybe-insert-output-separator () @@ -1298,6 +1315,14 @@ (set-marker slime-repl-input-end-mark (1- (point)) (current-buffer)) (set-marker slime-last-output-start (point)))) +(defun slime-repl-bol () + "Go to the beginning of line or the prompt." + (interactive) + (if (and (>= (point) slime-repl-input-start-mark) + (slime-same-line-p (point) slime-repl-input-start-mark)) + (goto-char slime-repl-input-start-mark) + (beginning-of-line 1))) + (defun slime-repl-return () "Evaluate the current input string." (interactive) @@ -1308,9 +1333,30 @@ (slime-repl-maybe-insert-output-separator) (add-text-properties slime-repl-input-start-mark slime-repl-input-end-mark - '(face underline)) + '(face slime-repl-input-face)) (slime-repl-eval-string input))) +(defun slime-repl-closing-return () + "Evaluate the current input string after closing all open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region slime-repl-input-start-mark (point)) + (while (ignore-errors (save-excursion (backward-up-list 1)) t) + (insert ")"))) + (slime-repl-return)) + +(defun slime-repl-newline-and-indent () + "Insert a newline, then indent the next line. +Restrict the buffer from the prompt for indentation, to avoid being +confused by strange characters (like unmatched quotes) appearing +earlier in the buffer." + (interactive) + (save-restriction + (narrow-to-region slime-repl-prompt-start-mark (point-max)) + (insert "\n") + (lisp-indent-line))) + (defun slime-repl-delete-current-input () (delete-region slime-repl-input-start-mark slime-repl-input-end-mark)) @@ -1379,6 +1425,10 @@ (slime-define-keys slime-repl-mode-map ("\C-m" 'slime-repl-return) + ("\C-j" 'slime-repl-newline-and-indent) + ("\C-\M-m" 'slime-repl-closing-return) + ([(control return)] 'slime-repl-closing-return) + ("\C-a" 'slime-repl-bol) ("\M-p" 'slime-repl-previous-input) ("\M-n" 'slime-repl-next-input) ("\M-r" 'slime-repl-previous-matching-input) @@ -1595,10 +1645,10 @@ (forward-sexp 1) (point)))))) -(defun slime-same-line-p (start end) - "Return true if buffer positions START and END are on the same line." - (save-excursion (goto-char start) - (not (search-forward "\n" end t)))) +(defun slime-same-line-p (pos1 pos2) + "Return true if buffer positions PoS1 and POS2 are on the same line." + (save-excursion (goto-char (min pos1 pos2)) + (not (search-forward "\n" (max pos1 pos2) t)))) (defun slime-severity-face (severity) "Return the name of the font-lock face representing SEVERITY." @@ -3072,6 +3122,72 @@ ("n" 'slime-inspector-next) ("d" 'slime-inspector-describe) ("q" 'slime-inspector-quit)) + + +;;; `Select' + +(defvar slime-select-methods nil + "List of buffer-selection methods for the `slime-select' command. +Each element is a list (KEY DESCRIPTION FUNCTION). +DESCRIPTION is a one-line description of what the key selects.") + +(defun slime-select () + "Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. + +See `def-slime-select-method' for defining new methods." + (interactive) + (let* ((ch (read-char (format "Select [%s]: " + (apply #'string + (mapcar #'car slime-select-methods))))) + (method (find ch slime-select-methods :key #'car))) + (if (null method) + (error "No method for character: %c" ch) + (funcall (third method))))) + +(defmacro def-slime-select-method (key description &rest body) + "Define a new `slime-select' buffer selection method. +KEY is the key the user will enter to choose this method. +DESCRIPTION is a one-line sentence describing how the method selects a +buffer. +BODY is a series of forms which must return the buffer to be selected." + `(setq slime-select-methods + (sort* (cons (list ,key ,description + (lambda () (switch-to-buffer (progn , at body)))) + (remove* ,key slime-select-methods :key #'car)) + #'< :key #'car))) + +(def-slime-select-method ?? "the Select help buffer." + (ignore-errors (kill-buffer "*Select Help*")) + (with-current-buffer (get-buffer-create "*Select Help*") + (insert "Select Methods:\n\n") + (loop for (key line function) in slime-select-methods + do (insert (format "%c:\t%s\n" key line))) + (help-mode) + (current-buffer))) + +(def-slime-select-method ?r "the SLIME Read-Eval-Print-Loop." + "*slime-repl*") + +(def-slime-select-method ?i "the *inferior-lisp* buffer." + "*inferior-lisp*") + +(def-slime-select-method ?l "the most recently visited lisp-mode buffer." + (slime-recently-visited-buffer 'lisp-mode)) + +(def-slime-select-method ?e "the most recently visited emacs-lisp-mode buffer." + (slime-recently-visited-buffer 'emacs-lisp-mode)) + +(defun slime-recently-visited-buffer (mode) + "Return the most recently visited buffer whose major-mode is MODE. +Only considers buffers that are not already visible." + (loop for buffer in (buffer-list) + when (and (with-current-buffer buffer (eq major-mode mode)) + (null (get-buffer-window buffer 'visible))) + return buffer + finally (error "Can't find unshown buffer in %S" mode))) ;;; Test suite From lgorrie at common-lisp.net Sat Nov 1 22:56:06 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 01 Nov 2003 17:56:06 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv873 Modified Files: swank.lisp Log Message: (*slime-features*): Variable remembering the FEATURES list. (sync-state-to-emacs): Update Emacs about any state changes - currently this just means changes to the FEATURES list. (eval-string): Call `sync-state-to-emacs' before sending result. (eval-region): With optional PACKAGE-UPDATE-P, if the evaluation changes the current package, tell Emacs about the new package. (listener-eval): Tell `eval-region' to notify Emacs of package changes, so that e.g. (in-package :swank) does the right thing when evaluated in the REPL. Date: Sat Nov 1 17:56:06 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.49 slime/swank.lisp:1.50 --- slime/swank.lisp:1.49 Sat Nov 1 10:45:10 2003 +++ slime/swank.lisp Sat Nov 1 17:56:06 2003 @@ -114,6 +114,15 @@ (let ((*package* *swank-io-package*)) (read-from-string string)))) +(defvar *slime-features* nil + "The feature list that has been sent to Emacs.") + +(defun sync-state-to-emacs () + "Update Emacs if any relevant Lisp state has changed." + (unless (eq *slime-features* *features*) + (setq *slime-features* *features*) + (send-to-emacs (list :new-features (mapcar #'symbol-name *features*))))) + (defun send-to-emacs (object) "Send `object' to Emacs." (let* ((string (prin1-to-string-for-emacs object)) @@ -191,6 +200,7 @@ (setq result (eval (read-form string))) (force-output) (setq ok t)) + (sync-state-to-emacs) (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) (defslimefun interactive-eval (string) @@ -200,14 +210,21 @@ (force-output) (format nil "~{~S~^, ~}" values))) -(defun eval-region (string) - (with-input-from-string (stream string) - (loop for form = (read stream nil stream) - until (eq form stream) - for - = form - for values = (multiple-value-list (eval form)) - do (force-output) - finally (return (values values -))))) +(defun eval-region (string &optional package-update-p) + "Evaluate STRING and return the result. +If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package +change, then send Emacs an update." + (let ((*package* *buffer-package*)) + (unwind-protect + (with-input-from-string (stream string) + (loop for form = (read stream nil stream) + until (eq form stream) + for - = form + for values = (multiple-value-list (eval form)) + 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*))))))) (defslimefun interactive-eval-region (string) (let ((*package* *buffer-package*)) @@ -237,7 +254,7 @@ (package-name *package*)) (defslimefun listener-eval (string) - (multiple-value-bind (values last-form) (eval-region string) + (multiple-value-bind (values last-form) (eval-region string t) (setq +++ ++ ++ + + last-form *** ** ** * * (car values) /// // // / / values) From lgorrie at common-lisp.net Sat Nov 1 22:56:40 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 01 Nov 2003 17:56:40 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv958 Modified Files: ChangeLog Log Message: Date: Sat Nov 1 17:56:40 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.74 slime/ChangeLog:1.75 --- slime/ChangeLog:1.74 Sat Nov 1 10:52:20 2003 +++ slime/ChangeLog Sat Nov 1 17:56:40 2003 @@ -1,3 +1,45 @@ +2003-11-01 Luke Gorrie + + * slime.el (slime-select): Added an extensible "Select" command, + which I gather is a LispM/Martin-Cracauer knock-off. When invoked, + the select command reads a single character and uses that to + decide which buffer to switch to. New characters can be defined, + and the currently availables ones can be seen with '?'. I have not + assigned a key to Select, because it seems like a command that + should have a global binding. I would suggest `C-c s'. + + * swank.lisp (*slime-features*): Variable remembering the FEATURES + list. + (sync-state-to-emacs): Update Emacs about any state changes - + currently this just means changes to the FEATURES list. + (eval-string): Call `sync-state-to-emacs' before sending result. + (eval-region): With optional PACKAGE-UPDATE-P, if the evaluation + changes the current package, tell Emacs about the new package. + (listener-eval): Tell `eval-region' to notify Emacs of package + changes, so that e.g. (in-package :swank) does the right thing + when evaluated in the REPL. + + * slime.el (slime-repl-output-face, slime-repl-input-face): Face + definitions for output printed by Lisp and for previous REPL user + inputs, respectively. Defaulting the input face to bold rather + than underline, because it looks better on multi-line input. + (slime-handle-oob): Two new out-of-band messages + (:new-features FEATURES) and (:new-package PACKAGE-NAME). These + are used for Lisp to tell Emacs about changes to *FEATURES* and + *PACKAGE* when appropriate. + (slime-same-line-p): Better implementation (does what the name + suggests). + (slime-lisp-package): New variable keeping track of *PACKAGE* in + Lisp -- or at least, the package to use for the REPL. + (slime-repl-insert-prompt): The prompt now includes the package + name. + (slime-repl-bol): C-a in the REPL now stops at the prompt. + (slime-repl-closing-return): C-RET & C-M-m now close all open + lists and then send input in REPL. + (slime-repl-newline-and-indent): C-j in REPL is now better with + indentation (won't get confused by unmatched quotes etc appearing + before the prompt). + 2003-11-1 Helmut Eller * slime.el (slime-debugging-state): Save the window configuration From lgorrie at common-lisp.net Sat Nov 1 23:53:53 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 01 Nov 2003 18:53:53 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21363 Modified Files: slime.el Log Message: Consistent use of slime-repl-output-face (bugfix) Date: Sat Nov 1 18:53:53 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.68 slime/slime.el:1.69 --- slime/slime.el:1.68 Sat Nov 1 17:55:41 2003 +++ slime/slime.el Sat Nov 1 18:53:52 2003 @@ -286,7 +286,6 @@ (insert ")"))) (comint-send-input)) - ;;;;; Key bindings @@ -1213,7 +1212,7 @@ (with-current-buffer (slime-output-buffer) (goto-char (point-max)) (slime-repl-maybe-insert-output-separator) - (slime-insert-propertized '(face slime-output-face) + (slime-insert-propertized '(face slime-repl-output-face) string)))) ;; (insert string)))) From lgorrie at common-lisp.net Sun Nov 2 00:54:44 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 01 Nov 2003 19:54:44 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10634 Modified Files: slime.el Log Message: (slime-lisp-package-translations): Association list of preferred package nicknames, for the REPL prompt. By default maps COMMON-LISP->CL and COMMON-LISP-USER->CL-USER. Date: Sat Nov 1 19:54:44 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.69 slime/slime.el:1.70 --- slime/slime.el:1.69 Sat Nov 1 18:53:52 2003 +++ slime/slime.el Sat Nov 1 19:54:44 2003 @@ -98,6 +98,12 @@ "When true, don't prompt the user for input during startup. This is used for batch-mode testing.") +(defvar slime-lisp-package-translations + '(("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.") + ;;; Customize group @@ -602,6 +608,11 @@ `(swank:list-all-package-names))) nil nil initial-value))) +(defun slime-lisp-package () + "Return the name of the current REPL package." + (or (cdr (assoc slime-lisp-package slime-lisp-package-translations)) + slime-lisp-package)) + ;;; Inferior CL Setup: compiling and connecting to Swank @@ -1267,7 +1278,7 @@ rear-nonsticky (slime-repl-prompt read-only face intangible) ;; xemacs stuff start-open t end-open t) - (concat slime-lisp-package "> ")) + (concat (slime-lisp-package) "> ")) (set-marker slime-repl-input-start-mark (point) (current-buffer)) (set-marker slime-repl-input-end-mark (point) (current-buffer)) (let ((w (get-buffer-window (current-buffer)))) @@ -1286,17 +1297,16 @@ (buffer-substring-no-properties slime-repl-input-start-mark slime-repl-input-end-mark)) -(defun slime-repl-add-to-input-history (sting) +(defun slime-repl-add-to-input-history (string) (unless (equal string (car slime-repl-input-history)) (push string slime-repl-input-history)) (setq slime-repl-input-history-position -1)) (defun slime-repl-eval-string (string) (slime-repl-add-to-input-history string) - (slime-eval-async - `(swank:listener-eval ,string) - slime-lisp-package - (slime-repl-show-result-continutation))) + (slime-eval-async `(swank:listener-eval ,string) + slime-lisp-package + (slime-repl-show-result-continutation))) (defun slime-repl-show-result-continutation () ;; This is called _after_ the idle state is activated. This means @@ -1371,6 +1381,7 @@ (defun slime-repl-previous-input () (interactive) + (unless (< (1+ slime-repl-input-history-position) (length slime-repl-input-history)) (error "End of history; no preceding item")) @@ -1384,10 +1395,10 @@ (defun slime-repl-matching-input (prompt bound increment error) (let* ((regexp (read-from-minibuffer prompt)) - (pos (position-if - (lambda (string) (string-match regexp string)) - slime-repl-input-history - bound (funcall increment slime-repl-input-history-position)))) + (pos (position-if + (lambda (string) (string-match regexp string)) + slime-repl-input-history + bound (funcall increment slime-repl-input-history-position)))) (unless pos (error error)) (setq slime-repl-input-history-position pos) (slime-repl-insert-from-history #'identity))) From lgorrie at common-lisp.net Sun Nov 2 00:55:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 01 Nov 2003 19:55:11 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11792 Modified Files: swank.lisp Log Message: (eval-string): force-output on *slime-output* before returning the result. This somewhat works around some trouble where output printed by lisp is being buffered too long. Date: Sat Nov 1 19:55:10 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.50 slime/swank.lisp:1.51 --- slime/swank.lisp:1.50 Sat Nov 1 17:56:06 2003 +++ slime/swank.lisp Sat Nov 1 19:55:10 2003 @@ -201,6 +201,7 @@ (force-output) (setq ok t)) (sync-state-to-emacs) + (force-output *slime-output*) (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) (defslimefun interactive-eval (string) From lgorrie at common-lisp.net Sun Nov 2 00:55:52 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 01 Nov 2003 19:55:52 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11915 Modified Files: ChangeLog Log Message: Date: Sat Nov 1 19:55:52 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.75 slime/ChangeLog:1.76 --- slime/ChangeLog:1.75 Sat Nov 1 17:56:40 2003 +++ slime/ChangeLog Sat Nov 1 19:55:51 2003 @@ -1,3 +1,13 @@ +2003-11-02 Luke Gorrie + + * swank.lisp (eval-string): force-output on *slime-output* before + returning the result. This somewhat works around some trouble + where output printed by lisp is being buffered too long. + + * slime.el (slime-lisp-package-translations): Association list of + preferred package nicknames, for the REPL prompt. By default maps + COMMON-LISP->CL and COMMON-LISP-USER->CL-USER. + 2003-11-01 Luke Gorrie * slime.el (slime-select): Added an extensible "Select" command, From lgorrie at common-lisp.net Sun Nov 2 20:15:33 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 02 Nov 2003 15:15:33 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26580 Modified Files: slime.el Log Message: (slime-log-event): Added a *slime-events* buffer recording all state machine events. The buffer uses hideshow-mode to fold messages down to single lines. (slime-show-source-location): Bugfix: only create source-highlight overlay if the source was actually located. (slime-selector): Renamed from `slime-select' because that function name was already in use. Ooops! (slime-lisp-package-translations): Association list of preferred package nicknames, for the REPL prompt. By default maps COMMON-LISP->CL and COMMON-LISP-USER->CL-USER. Date: Sun Nov 2 15:15:32 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.70 slime/slime.el:1.71 --- slime/slime.el:1.70 Sat Nov 1 19:54:44 2003 +++ slime/slime.el Sun Nov 2 15:15:32 2003 @@ -55,7 +55,9 @@ (require 'inf-lisp) (require 'cl) (require 'pp) +(require 'hideshow) (require 'hyperspec) +(require 'font-lock) (when (featurep 'xemacs) (require 'overlay)) (unless (fboundp 'define-minor-mode) @@ -87,7 +89,15 @@ "The symbol names in the *FEATURES* list of the Superior lisp. This is needed to READ Common Lisp expressions adequately.") -(defvar slime-lisp-package "CL-USER" +(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-lisp-package + (or (cdr (assoc "COMMON-LISP-USER" slime-lisp-preferred-package-nicknames)) + "COMMON-LISP-USER") "The current package name of the Superior lisp. This is automatically synchronized from Lisp.") @@ -98,12 +108,6 @@ "When true, don't prompt the user for input during startup. This is used for batch-mode testing.") -(defvar slime-lisp-package-translations - '(("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.") - ;;; Customize group @@ -216,6 +220,8 @@ ;; Fake binding to coax `define-minor-mode' to create the keymap '((" " 'undefined))) + +;;;; inferior-slime-mode (define-minor-mode inferior-slime-mode "\\ Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs. @@ -293,7 +299,7 @@ (comint-send-input)) -;;;;; Key bindings +;;;; Key bindings ;; See `slime-define-key' below for keyword meanings. (defvar slime-keys @@ -610,7 +616,7 @@ (defun slime-lisp-package () "Return the name of the current REPL package." - (or (cdr (assoc slime-lisp-package slime-lisp-package-translations)) + (or (cdr (assoc slime-lisp-package slime-lisp-preferred-package-nicknames)) slime-lisp-package)) @@ -761,7 +767,7 @@ (process-send-string slime-net-process (string-make-unibyte string)))) (defun slime-net-sentinel (process message) - (when (ignore-errors (process-live-p (inferior-lisp-proc))) + (when (ignore-errors (eq (process-status (inferior-lisp-proc)) 'open)) (message "Lisp connection closed unexpectedly: %s" message)) (setq slime-state-name "[not connected]") (force-mode-line-update) @@ -855,7 +861,7 @@ ;; a special function instead of reaching the state machine. -;;;;; Basic state machine aframework +;;;; Basic state machine framework (defvar slime-state-stack '() "Stack of machine states. The state at the top is the current state.") @@ -899,11 +905,27 @@ (force-mode-line-update) (slime-dispatch-event '(activate)))) +;; state datastructure +(defun slime-make-state (name function) + "Make a state object called NAME that handles events with FUNCTION." + (list 'slime-state name function)) + +(defun slime-state-name (state) + "Return the name of STATE." + (second state)) + +(defun slime-state-function (state) + "Return STATE's event-handler function." + (third state)) + + +;;;;; Event dispatching. + (defun slime-dispatch-event (event) "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going into the state machine." - (pp event (get-buffer-create "*slime-events*")) + (slime-log-event event) (or (slime-handle-oob event) (funcall (slime-state-function (slime-current-state)) event))) @@ -922,19 +944,6 @@ t) (t nil))) -;; state datastructure -(defun slime-make-state (name function) - "Make a state object called NAME that handles events with FUNCTION." - (list 'slime-state name function)) - -(defun slime-state-name (state) - "Return the name of STATE." - (second state)) - -(defun slime-state-function (state) - "Return STATE's event-handler function." - (third state)) - (defun slime-state/event-panic (event) "Signal the error that we received EVENT in a state that can't handle it. When this happens it is due to a bug in SLIME. @@ -973,7 +982,33 @@ (error "The SLIME protocol reached an inconsistent state.")) -;;;;; Upper layer macros for defining states +;;;;; 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)))) + +(defun slime-events-buffer () + (or (get-buffer "*slime-events*") + (let ((buffer (get-buffer-create "*slime-events*"))) + (with-current-buffer buffer + (lisp-mode) + (hs-minor-mode) + (current-buffer))))) + + +;;;; Upper layer macros for defining states (eval-when (compile eval) (defun slime-make-state-function (arglist clauses) @@ -1005,7 +1040,7 @@ (put 'slime-defstate 'lisp-indent-function 2) -;;;;; The SLIME state machine definition +;;;; The SLIME state machine definition (defvar sldb-level 0 "Current debug level, or 0 when not debugging.") @@ -1101,7 +1136,7 @@ (slime-push-state (slime-evaluating-state continuation)))) -;;;;; Utilities +;;;; Utilities (defun slime-output-evaluate-request (form-string package-name) "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." @@ -1127,7 +1162,7 @@ (signal-process slime-pid +slime-sigint+)) -;;;;; Emacs Lisp programming interface +;;;; Emacs Lisp programming interface (defun slime-eval (sexp &optional package) "Evaluate EXPR on the superior Lisp and return the result." @@ -2389,7 +2424,7 @@ (format "%s\n" referrer))))) -;;;;; XREF results buffer and window management +;;;; XREF results buffer and window management (defun slime-xref-buffer (&optional create) "Return the XREF results buffer. @@ -2423,7 +2458,7 @@ (window-text-height)))))) -;;;;; XREF navigation +;;;; XREF navigation (defun slime-goto-xref () "Goto the cross-referenced location at point." (interactive) @@ -2780,7 +2815,8 @@ (funcall (if other-window #'find-file-other-window #'find-file) (plist-get source-location :filename)) (goto-char (plist-get source-location :position)) - (forward-sexp) (backward-sexp)) + (forward-sexp) (backward-sexp) + t) (:stream (let ((info (plist-get source-location :info))) (cond ((and (consp info) (eq :emacs-buffer (car info))) @@ -2792,13 +2828,15 @@ (get-buffer buffer)) (goto-char offset) (slime-forward-source-path - (plist-get source-location :path)))) + (plist-get source-location :path))) + t) (t (error "Cannot locate source from stream: %s" source-location))))) (t (slime-message "Source Form:\n%s" - (plist-get source-location :source-form)))))) + (plist-get source-location :source-form)) + nil)))) (defun sldb-show-source () (interactive) @@ -2810,8 +2848,8 @@ (defun slime-show-source-location (source-location) (save-selected-window - (slime-goto-source-location source-location t) - (sldb-highlight-sexp))) + (when (slime-goto-source-location source-location t) + (sldb-highlight-sexp)))) (defun sldb-frame-details-visible-p () (and (get-text-property (point) 'frame) @@ -3004,6 +3042,7 @@ (slime-define-keys sldb-mode-map ("v" 'sldb-show-source) ((kbd "RET") 'sldb-default-action) + ("\C-m" 'sldb-default-action) ([mouse-2] 'sldb-default-action/mouse) ("e" 'sldb-eval-in-frame) ("p" 'sldb-pprint-eval-in-frame) @@ -3136,58 +3175,66 @@ ;;; `Select' -(defvar slime-select-methods nil +(defvar slime-selector-methods nil "List of buffer-selection methods for the `slime-select' command. Each element is a list (KEY DESCRIPTION FUNCTION). DESCRIPTION is a one-line description of what the key selects.") -(defun slime-select () +(defun slime-selector () "Select a new buffer by type, indicated by a single character. The user is prompted for a single character indicating the method by which to choose a new buffer. The `?' character describes the available methods. -See `def-slime-select-method' for defining new methods." +See `def-slime-selector-method' for defining new methods." (interactive) (let* ((ch (read-char (format "Select [%s]: " (apply #'string - (mapcar #'car slime-select-methods))))) - (method (find ch slime-select-methods :key #'car))) + (mapcar #'car slime-selector-methods))))) + (method (find ch slime-selector-methods :key #'car))) (if (null method) (error "No method for character: %c" ch) (funcall (third method))))) -(defmacro def-slime-select-method (key description &rest body) +(defmacro def-slime-selector-method (key description &rest body) "Define a new `slime-select' buffer selection method. KEY is the key the user will enter to choose this method. DESCRIPTION is a one-line sentence describing how the method selects a buffer. BODY is a series of forms which must return the buffer to be selected." - `(setq slime-select-methods + `(setq slime-selector-methods (sort* (cons (list ,key ,description (lambda () (switch-to-buffer (progn , at body)))) - (remove* ,key slime-select-methods :key #'car)) + (remove* ,key slime-selector-methods :key #'car)) #'< :key #'car))) -(def-slime-select-method ?? "the Select help buffer." +(def-slime-selector-method ?? "the Select help buffer." (ignore-errors (kill-buffer "*Select Help*")) (with-current-buffer (get-buffer-create "*Select Help*") (insert "Select Methods:\n\n") - (loop for (key line function) in slime-select-methods + (loop for (key line function) in slime-selector-methods do (insert (format "%c:\t%s\n" key line))) (help-mode) (current-buffer))) -(def-slime-select-method ?r "the SLIME Read-Eval-Print-Loop." +(def-slime-selector-method ?r + "the SLIME Read-Eval-Print-Loop." "*slime-repl*") -(def-slime-select-method ?i "the *inferior-lisp* buffer." +(def-slime-selector-method ?i + "the *inferior-lisp* buffer." "*inferior-lisp*") -(def-slime-select-method ?l "the most recently visited lisp-mode buffer." +(def-slime-selector-method ?v + "the *slime-events* buffer." + "*slime-events*") + +(def-slime-selector-method ?l + "the most recently visited lisp-mode buffer." (slime-recently-visited-buffer 'lisp-mode)) -(def-slime-select-method ?e "the most recently visited emacs-lisp-mode buffer." +(def-slime-selector-method ?e + "the most recently visited emacs-lisp-mode buffer." (slime-recently-visited-buffer 'emacs-lisp-mode)) (defun slime-recently-visited-buffer (mode) @@ -3218,7 +3265,7 @@ "The name of the buffer used to display test results.") -;;;;; Execution engine +;;;; Execution engine (defun slime-run-tests () "Run the test suite. @@ -3284,7 +3331,7 @@ (kill-emacs failed-tests)))) -;;;;; Results buffer creation and output +;;;; Results buffer creation and output (defun slime-create-test-results-buffer () "Create and initialize the buffer for test suite results." @@ -3333,7 +3380,7 @@ (insert string "\n"))) -;;;;; Macros for defining test cases +;;;; Macros for defining test cases (defmacro def-slime-test (name args doc inputs &rest body) "Define a test case. @@ -3381,7 +3428,7 @@ (put 'slime-check 'lisp-indent-function 1) -;;;;; Test case definitions. +;;;; Test case definitions ;; Clear out old tests. (setq slime-tests nil) From lgorrie at common-lisp.net Sun Nov 2 20:55:49 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 02 Nov 2003 15:55: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-serv8598 Modified Files: slime.el Log Message: Cleaned for byte-compilation. Date: Sun Nov 2 15:55:48 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.71 slime/slime.el:1.72 --- slime/slime.el:1.71 Sun Nov 2 15:15:32 2003 +++ slime/slime.el Sun Nov 2 15:55:48 2003 @@ -60,9 +60,10 @@ (require 'font-lock) (when (featurep 'xemacs) (require 'overlay)) -(unless (fboundp 'define-minor-mode) - (require 'easy-mmode) - (defalias 'define-minor-mode 'easy-mmode-define-minor-mode)) +(eval-when (compile load eval) + (unless (fboundp 'define-minor-mode) + (require 'easy-mmode) + (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))) (defvar slime-path (let ((path (locate-library "slime"))) From lgorrie at common-lisp.net Sun Nov 2 20:56:12 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 02 Nov 2003 15:56:12 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8657 Modified Files: ChangeLog Log Message: Date: Sun Nov 2 15:56:11 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.76 slime/ChangeLog:1.77 --- slime/ChangeLog:1.76 Sat Nov 1 19:55:51 2003 +++ slime/ChangeLog Sun Nov 2 15:56:11 2003 @@ -1,5 +1,13 @@ 2003-11-02 Luke Gorrie + * slime.el (slime-log-event): Added a *slime-events* buffer + recording all state machine events. The buffer uses hideshow-mode + to fold messages down to single lines. + (slime-show-source-location): Bugfix: only create source-highlight + overlay if the source was actually located. + (slime-selector): Renamed from `slime-select' because that + function name was already in use. Ooops! + * swank.lisp (eval-string): force-output on *slime-output* before returning the result. This somewhat works around some trouble where output printed by lisp is being buffered too long. From heller at common-lisp.net Sun Nov 2 23:05:16 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 02 Nov 2003 18: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-serv28621 Modified Files: slime.el Log Message: (slime-repl-read-mode, slime-repl-read-string, slime-repl-return, slime-repl-send-string, slime-read-string-state, slime-activate-state): Reorganize input redirection. We no longer work on the character level but on a line or region; more like a terminal. This works better, because REPLs and debuggers are usually written with a line buffering tty in mind. (slime-reading-p, slime-debugging-p): New functions. (sldb-backtrace-length, slime-debugging-state, slime-evaluating-state, sldb-setup, sldb-mode, sldb-insert-frames, sldb-fetch-more-frames): Don't use backtrace-length. Computing the length of the backtrace is (somewhat strangely) an expensive operation in CMUCL, e.g., it takes >30 seconds to compute the length when the yellow zone stack guard is hit. (slime-events-buffer): Set hs-block-start-regexp. Date: Sun Nov 2 18:05:16 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.72 slime/slime.el:1.73 --- slime/slime.el:1.72 Sun Nov 2 15:55:48 2003 +++ slime/slime.el Sun Nov 2 18:05:16 2003 @@ -902,7 +902,7 @@ (slime-idle-state "") (slime-evaluating-state "[eval...]") (slime-debugging-state "[debug]") - (slime-read-char-state "[read]"))) + (slime-read-string-state "[read]"))) (force-mode-line-update) (slime-dispatch-event '(activate)))) @@ -1006,6 +1006,7 @@ (with-current-buffer buffer (lisp-mode) (hs-minor-mode) + (set (make-local-variable 'hs-block-start-regexp) "^(") (current-buffer))))) @@ -1087,9 +1088,9 @@ (slime-pop-state) (when (member tag slime-stack-eval-tags) (throw tag `(:aborted)))))) - ((:debug level condition restarts stack-depth frames) + ((:debug level condition restarts frames) (slime-push-state - (slime-debugging-state level condition restarts stack-depth frames + (slime-debugging-state level condition restarts frames (current-window-configuration)))) ((:emacs-interrupt) (slime-send-sigint)) @@ -1097,10 +1098,10 @@ ;; To discard the state would break our synchronization. ;; Instead, just cancel the continuation. (setq continuation (lambda (value) t))) - ((:read-char tag) - (slime-push-state (slime-read-char-state tag)))) + ((:read-string tag) + (slime-push-state (slime-read-string-state tag)))) -(slime-defstate slime-debugging-state (level condition restarts depth frames +(slime-defstate slime-debugging-state (level condition restarts frames saved-window-configuration) "Debugging state. Lisp entered the debugger while handling one of our requests. This @@ -1111,7 +1112,7 @@ (when (or (not sldb-buffer) (with-current-buffer sldb-buffer (/= sldb-level-in-buffer level))) - (sldb-setup condition restarts depth frames)))) + (sldb-setup condition restarts frames)))) ((:debug-return level) (assert (= level sldb-level)) (sldb-cleanup) @@ -1123,18 +1124,14 @@ (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation)))) -(slime-defstate slime-read-char-state (tag) +(slime-defstate slime-read-string-state (tag) "Reading state. Lisp waits for input from Emacs." ((activate) - (slime-repl-read-char)) - ((:emacs-return-char-code code) + (slime-repl-read-string)) + ((:emacs-return-string code) (slime-net-send `(swank:take-input ,tag ,code)) - (slime-pop-state)) - ((:emacs-evaluate form-string package-name continuation) - ;; recursive evaluation request - (slime-output-evaluate-request form-string package-name)a - (slime-push-state (slime-evaluating-state continuation)))) + (slime-pop-state))) ;;;; Utilities @@ -1214,6 +1211,14 @@ "Return true if Lisp is idle." (eq (slime-state-name (slime-current-state)) 'slime-idle-state)) +(defun slime-reading-p () + "Return true if Lisp waits for input from Emacs." + (eq (slime-state-name (slime-current-state)) 'slime-read-string-state)) + +(defun slime-debugging-p () + "Return true if Lisp is in the debugger." + (eq (slime-state-name (slime-current-state)) 'slime-debugging-state)) + (defun slime-ping () "Check that communication works." (interactive) @@ -1299,7 +1304,7 @@ (lisp-mode-variables t) (setq font-lock-defaults nil) (setq mode-name "REPL") - (set (make-local-variable 'scroll-conservatively) 5) + (set (make-local-variable 'scroll-conservatively) 20) (set (make-local-variable 'scroll-margin) 0) (run-hooks 'slime-repl-mode-hook)) @@ -1339,11 +1344,16 @@ (setq slime-repl-input-history-position -1)) (defun slime-repl-eval-string (string) - (slime-repl-add-to-input-history string) (slime-eval-async `(swank:listener-eval ,string) slime-lisp-package (slime-repl-show-result-continutation))) +(defun slime-repl-send-string (string) + (slime-repl-add-to-input-history string) + (ecase (slime-state-name (slime-current-state)) + (slime-idle-state (slime-repl-eval-string string)) + (slime-read-string-state (slime-repl-return-string (concat string "\n"))))) + (defun slime-repl-show-result-continutation () ;; This is called _after_ the idle state is activated. This means ;; the prompt is already printed. @@ -1371,7 +1381,8 @@ (defun slime-repl-return () "Evaluate the current input string." (interactive) - (unless (slime-idle-p) + (unless (or (slime-idle-p) + (slime-reading-p)) (error "Lisp is not ready for request from the REPL.")) (let ((input (slime-repl-current-input))) (goto-char slime-repl-input-end-mark) @@ -1379,7 +1390,7 @@ (add-text-properties slime-repl-input-start-mark slime-repl-input-end-mark '(face slime-repl-input-face)) - (slime-repl-eval-string input))) + (slime-repl-send-string input))) (defun slime-repl-closing-return () "Evaluate the current input string after closing all open lists." @@ -1451,10 +1462,6 @@ :end #'1- "No later matching history item")) -(defun slime-repl-read-char () - (slime-switch-to-output-buffer) - (slime-repl-read-mode t)) - (defun slime-repl () (interactive) (slime-switch-to-output-buffer)) @@ -1484,35 +1491,24 @@ ("\t" 'slime-complete-symbol) (" " 'slime-space)) -(defvar slime-repl-read-mode-map) - (define-minor-mode slime-repl-read-mode "Mode the read input from Emacs" nil nil - ;; Fake binding to coax `define-minor-mode' to create the keymap - '((" " 'slime-repl-read-self-insert-command))) + '(("\C-m" . slime-repl-return))) (add-to-list 'minor-mode-alist '(slime-repl-read-mode "[read]")) -(defun slime-char-code (char) - (if (featurep 'xemacs) - (char-int char) - char)) - -(defun slime-repl-read-self-insert-command (char) - (interactive (list last-command-char)) - (insert char) - (slime-dispatch-event `(:emacs-return-char-code ,(slime-char-code char))) - (slime-repl-read-mode nil)) +(defun slime-repl-read-string () + (slime-switch-to-output-buffer) + (set-marker slime-repl-input-start-mark (point) (current-buffer)) + (set-marker slime-repl-input-end-mark (point) (current-buffer)) + (slime-repl-read-mode t)) -(substitute-key-definition - 'self-insert-command 'slime-repl-read-self-insert-command - slime-repl-read-mode-map global-map) +(defun slime-repl-return-string (string) + (slime-dispatch-event `(:emacs-return-string ,string)) + (slime-repl-read-mode nil)) -(slime-define-keys slime-repl-read-mode-map - ("\C-m" (lambda () (interactive) (slime-repl-read-self-insert-command ?\n)))) - ;;; Compilation and the creation of compiler-note annotations @@ -1929,7 +1925,7 @@ (interactive "p") (self-insert-command n) (when (and (slime-connected-p) - (not (slime-busy-p)) + (or (slime-idle-p) (slime-debugging-p)) (slime-function-called-at-point/line)) (slime-arglist (symbol-name (slime-function-called-at-point/line))))) @@ -2680,7 +2676,6 @@ (defvar sldb-condition) (defvar sldb-restarts) -(defvar sldb-backtrace-length) (defvar sldb-level-in-buffer) (defvar sldb-backtrace-start-marker) (defvar sldb-mode-map) @@ -2688,7 +2683,7 @@ (defvar sldb-hook nil "Hook run on entry to the debugger.") -(defun sldb-setup (condition restarts stack-depth frames) +(defun sldb-setup (condition restarts frames) (with-current-buffer (get-buffer-create "*sldb*") (setq buffer-read-only nil) (sldb-mode) @@ -2696,7 +2691,6 @@ (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) (setq sldb-condition condition) (setq sldb-restarts restarts) - (setq sldb-backtrace-length stack-depth) (insert condition "\n" "\nRestarts:\n") (loop for (name string) in restarts for number from 0 @@ -2710,7 +2704,7 @@ (insert "\n"))) (insert "\nBacktrace:\n") (setq sldb-backtrace-start-marker (point-marker)) - (sldb-insert-frames frames) + (sldb-insert-frames frames 1) (setq buffer-read-only t) (pop-to-buffer (current-buffer)) (run-hooks 'sldb-hook))) @@ -2732,26 +2726,26 @@ (set-syntax-table lisp-mode-syntax-table) (mapc #'make-local-variable '(sldb-condition sldb-restarts - sldb-backtrace-length sldb-level-in-buffer sldb-backtrace-start-marker)) (setq sldb-level-in-buffer sldb-level) (setq mode-name (format "sldb[%d]" sldb-level))) -(defun sldb-insert-frames (frames) +(defun sldb-insert-frames (frames 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 ((= sldb-backtrace-length (1+ number))) + (cond ((< (length frames) maximum-length)) (t (slime-insert-propertized `(sldb-default-action sldb-fetch-more-frames point-entered sldb-fetch-more-frames sldb-previous-frame-number ,number) - " --more--\n")))))) + " --more--\n")))))) (defun sldb-fetch-more-frames (&optional start end) (let ((inhibit-point-motion-hooks t)) @@ -2763,10 +2757,11 @@ (let ((start (point))) (end-of-buffer) (delete-region start (point))) - (sldb-insert-frames - (slime-eval `(swank:backtrace-for-emacs - ,(1+ previous) - ,(+ previous 40))))))))) + (let ((start (1+ previous)) + (end (+ previous 40))) + (sldb-insert-frames + (slime-eval `(swank:backtrace-for-emacs ,start ,end)) + (- end start)))))))) (defun sldb-default-action/mouse (event) (interactive "e") From heller at common-lisp.net Sun Nov 2 23:08:04 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 02 Nov 2003 18:08:04 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/null-swank-impl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28860 Modified Files: swank.lisp swank-cmucl.lisp swank-sbcl.lisp swank-openmcl.lisp null-swank-impl.lisp Log Message: Input redirection works now on the line level, like a tty. Output streams are now line buffered. We no longer compute the backtrace-length. Date: Sun Nov 2 18:08:04 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.51 slime/swank.lisp:1.52 --- slime/swank.lisp:1.51 Sat Nov 1 19:55:10 2003 +++ slime/swank.lisp Sun Nov 2 18:08:03 2003 @@ -82,7 +82,8 @@ (*trace-output* *slime-output*) (*debug-io* *slime-io*) (*query-io* *slime-io*) - (*standard-input* *slime-input*)) + (*standard-input* *slime-input*) + (*terminal-io* *slime-io*)) (apply #'funcall form)) (apply #'funcall form)))) @@ -171,12 +172,12 @@ (defvar *read-input-catch-tag* 0) -(defun slime-read-char () +(defun slime-read-string () (force-output) (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) - (send-to-emacs `(:read-char ,*read-input-catch-tag*)) - (code-char (catch *read-input-catch-tag* - (loop (read-from-emacs)))))) + (send-to-emacs `(:read-string ,*read-input-catch-tag*)) + (catch *read-input-catch-tag* + (loop (read-from-emacs))))) (defslimefun take-input (tag input) (throw tag input)) @@ -255,6 +256,7 @@ (package-name *package*)) (defslimefun listener-eval (string) + (clear-input *slime-input*) (multiple-value-bind (values last-form) (eval-region string t) (setq +++ ++ ++ + + last-form *** ** ** * * (car values) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.15 slime/swank-cmucl.lisp:1.16 --- slime/swank-cmucl.lisp:1.15 Sat Nov 1 10:43:05 2003 +++ slime/swank-cmucl.lisp Sun Nov 2 18:08:03 2003 @@ -19,53 +19,121 @@ ;;; TCP Server. (defstruct (slime-output-stream - (:include lisp::string-output-stream - (lisp::misc #'slime-out-misc))) - (last-charpos 0 :type kernel:index)) - -(defun slime-out-misc (stream operation &optional arg1 arg2) + (:include lisp::lisp-stream + (lisp::misc #'sos/misc) + (lisp::out #'sos/out) + (lisp::sout #'sos/sout)) + (:conc-name sos.)) + (buffer (make-string 512) :type string) + (index 0 :type kernel:index) + (column 0 :type kernel:index)) + +(defun sos/out (stream char) + (let ((buffer (sos.buffer stream)) + (index (sos.index stream))) + (setf (schar buffer index) char) + (setf (sos.index stream) (1+ index)) + (incf (sos.column stream)) + (cond ((char= #\newline char) + (force-output stream) + (setf (sos.column stream) 0)) + ((= index (length buffer)) + (force-output stream)))) + char) + +(defun sos/sout (stream string start end) + (loop for i from start below end + do (sos/out stream (aref string i)))) + +(defun sos/misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) (case operation (:force-output - (unless (zerop (lisp::string-output-stream-index stream)) - (setf (slime-output-stream-last-charpos stream) - (slime-out-misc stream :charpos)) - (send-to-emacs `(:read-output ,(get-output-stream-string stream))))) + (let ((end (sos.index stream))) + (unless (zerop end) + (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end))) + (setf (sos.index stream) 0)))) + (:charpos (sos.column stream)) + (:line-length 75) (:file-position nil) - (:charpos - (do ((index (1- (the fixnum (lisp::string-output-stream-index stream))) - (1- index)) - (count 0 (1+ count)) - (string (lisp::string-output-stream-string stream))) - ((< index 0) (+ count (slime-output-stream-last-charpos stream))) - (declare (simple-string string) - (fixnum index count)) - (if (char= (schar string index) #\newline) - (return count)))) - (t (lisp::string-out-misc stream operation arg1 arg2)))) + (:element-type 'base-char) + (:get-command nil) + (t (format *terminal-io* "~&~Astream: ~S~%" stream operation)))) (defstruct (slime-input-stream - (:include sys:lisp-stream - (lisp::in #'slime-input-stream-read-char) - (lisp::misc #'slime-input-stream-misc-ops))) - (buffered-char nil :type (or null character))) - -(defun slime-input-stream-read-char (stream &optional eoferr eofval) - (declare (ignore eoferr eofval)) - (let ((c (slime-input-stream-buffered-char stream))) - (cond (c (setf (slime-input-stream-buffered-char stream) nil) c) - (t (slime-read-char))))) + (:include string-stream + (lisp::in #'sis/in) + (lisp::misc #'sis/misc)) + (:conc-name sis.)) + (buffer "" :type string) + (index 0 :type kernel:index)) + +(defun sis/in (stream eof-errorp eof-value) + (let ((index (sis.index stream)) + (buffer (sis.buffer stream))) + (when (= index (length buffer)) + (setf buffer (slime-read-string)) + (setf (sis.buffer stream) buffer) + (setf index 0)) + (prog1 (aref buffer index) + (setf (sis.index stream) (1+ index))))) -(defun slime-input-stream-misc-ops (stream operation &optional arg1 arg2) +(defun sis/misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) (ecase operation - (:unread - (assert (not (slime-input-stream-buffered-char stream))) - (setf (slime-input-stream-buffered-char stream) arg1) - nil) - (:listen nil) - (:clear-input (setf (slime-input-stream-buffered-char stream) nil)) (:file-position nil) - (:charpos nil))) + (:file-length nil) + (:unread (setf (aref (sis.buffer stream) + (decf (sis.index stream))) + arg1)) + (:clear-input (setf (sis.index stream) 0 + (sis.buffer stream) "")) + (:listen (< (sis.index stream) (length (sis.buffer stream)))) + (:charpos nil) + (:line-length nil) + (:get-command nil) + (:element-type 'base-char))) + + +;; (eval-when (:load-toplevel :compile-toplevel :execute) +;; (require :gray-streams)) +;; +;; (defclass slime-input-stream (ext:fundamental-character-input-stream) +;; ((buffer :initform "") (index :initform 0))) +;; +;; (defmethod ext:stream-read-char ((s slime-input-stream)) +;; (with-slots (buffer index) s +;; (when (= index (length buffer)) +;; (setf buffer (slime-read-string)) +;; (setf index 0)) +;; (assert (plusp (length buffer))) +;; (prog1 (aref buffer index) (incf index)))) +;; +;; (defmethod ext:stream-listen ((s slime-input-stream)) +;; (with-slots (buffer index) s +;; (< index (length buffer)))) +;; +;; (defmethod ext:stream-unread-char ((s slime-input-stream) char) +;; (with-slots (buffer index) s +;; (setf (aref buffer (decf index)) char)) +;; nil) +;; +;; (defmethod ext:stream-clear-input ((s slime-input-stream)) +;; (with-slots (buffer index) s +;; (setf buffer "" +;; index 0)) +;; nil) +;; +;; (defmethod ext:stream-line-column ((s slime-input-stream)) +;; nil) +;; +;; (defmethod ext:stream-line-length ((s slime-input-stream)) +;; 75) +;; +;; (defun make-slime-input-stream () +;; (make-instance 'slime-input-stream)) + + (defun create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." @@ -107,7 +175,8 @@ (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*)))))) + (close *emacs-io*))))) + (sys:scrub-control-stack)) ;;; @@ -636,12 +705,6 @@ (let ((*print-pretty* nil)) (debug::print-frame-call frame :verbosity 1 :number t))))) -(defun backtrace-length () - "Return the number of frames on the stack." - (do ((frame *sldb-stack-top* (di:frame-down frame)) - (i 0 (1+ i))) - ((not frame) i))) - (defun compute-backtrace (start end) "Return a list of frames starting with frame number START and continuing to frame number END or, if END is nil, the last frame on the @@ -658,7 +721,6 @@ (defslimefun debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) - (backtrace-length) (backtrace-for-emacs start end))) (defun code-location-source-path (code-location) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.17 slime/swank-sbcl.lisp:1.18 --- slime/swank-sbcl.lisp:1.17 Sat Nov 1 10:48:19 2003 +++ slime/swank-sbcl.lisp Sun Nov 2 18:08:03 2003 @@ -161,52 +161,72 @@ ;; This buffering is done via a Gray stream instead of the CMU-specific ;; stream method business... + (defclass slime-output-stream (sb-gray:fundamental-character-output-stream) - ((buffer :initform (make-array 512 :element-type 'character - :fill-pointer 0 :adjustable t)) - (last-charpos :initform 0))) + ((buffer :initform (make-string 512)) + (fill-pointer :initform 0) + (column :initform 0))) (defmethod sb-gray:stream-write-char ((stream slime-output-stream) char) - (vector-push-extend char (slot-value stream 'buffer)) + (with-slots (buffer fill-pointer column) stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (cond ((char= #\newline char) + (force-output stream) + (setf column 0)) + ((= fill-pointer (length buffer)) + (force-output stream)))) char) (defmethod sb-gray:stream-line-column ((stream slime-output-stream)) - (with-slots (buffer last-charpos) stream - (do ((index (1- (fill-pointer buffer)) (1- index)) - (count 0 (1+ count))) - ((< index 0) (+ count last-charpos)) - (when (char= (aref buffer index) #\newline) - (return count))))) + (slot-value stream 'column)) + +(defmethod sb-gray:stream-line-length ((stream slime-output-stream)) + 75) (defmethod sb-gray:stream-force-output ((stream slime-output-stream)) - (with-slots (buffer last-charpos) stream - (let ((end (fill-pointer buffer))) + (with-slots (buffer fill-pointer last-charpos) stream + (let ((end fill-pointer)) (unless (zerop end) (send-to-emacs `(:read-output ,(subseq buffer 0 end))) - (setf last-charpos (sb-gray:stream-line-column stream)) - (setf (fill-pointer buffer) 0)))) + (setf fill-pointer 0)))) nil) +(defun make-slime-output-stream () + (make-instance 'slime-output-stream)) + (defclass slime-input-stream (sb-gray:fundamental-character-input-stream) - ((buffered-char :initform nil))) + ((buffer :initform "") (index :initform 0))) (defmethod sb-gray:stream-read-char ((s slime-input-stream)) - (with-slots (buffered-char) s - (cond (buffered-char (prog1 buffered-char (setf buffered-char nil))) - (t (slime-read-char))))) + (with-slots (buffer index) s + (when (= index (length buffer)) + (setf buffer (slime-read-string)) + (setf index 0)) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))) + +(defmethod sb-gray:stream-listen ((s slime-input-stream)) + (with-slots (buffer index) s + (< index (length buffer)))) (defmethod sb-gray:stream-unread-char ((s slime-input-stream) char) - (setf (slot-value s 'buffered-char) char) + (with-slots (buffer index) s + (setf (aref buffer (decf index)) char)) nil) -(defmethod sb-gray:stream-listen ((s slime-input-stream)) +(defmethod sb-gray:stream-clear-input ((s slime-input-stream)) + (with-slots (buffer index) s + (setf buffer "" + index 0)) nil) (defmethod sb-gray:stream-line-column ((s slime-input-stream)) nil) (defmethod sb-gray:stream-line-length ((s slime-input-stream)) - nil) + 75) ;;; Utilities @@ -519,12 +539,6 @@ (let ((*print-pretty* nil)) (sb-debug::print-frame-call frame :verbosity 1 :number t))))) -(defun backtrace-length () - "Return the number of frames on the stack." - (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) - (i 0 (1+ i))) - ((not frame) i))) - (defun compute-backtrace (start end) "Return a list of frames starting with frame number START and continuing to frame number END or, if END is nil, the last frame on the @@ -544,7 +558,6 @@ (defslimefun debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) - (backtrace-length) (backtrace-for-emacs start end))) (defun code-location-source-path (code-location) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.16 slime/swank-openmcl.lisp:1.17 --- slime/swank-openmcl.lisp:1.16 Sat Nov 1 10:48:19 2003 +++ slime/swank-openmcl.lisp Sun Nov 2 18:08: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.16 2003/11/01 15:48:19 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.17 2003/11/02 23:08:03 heller Exp $ ;;; ;;; @@ -103,53 +103,67 @@ ;; This buffering is done via a Gray stream instead of the CMU-specific ;; stream method business... + (defclass slime-output-stream (ccl:fundamental-character-output-stream) - ((buffer :initform (make-array 512 :element-type 'character - :fill-pointer 0 :adjustable t)) - (last-charpos :initform 0))) + ((buffer :initform (make-string 512)) + (fill-pointer :initform 0) + (column :initform 0))) (defmethod ccl:stream-write-char ((stream slime-output-stream) char) - (vector-push-extend char (slot-value stream 'buffer)) + (with-slots (buffer fill-pointer column) stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (cond ((char= #\newline char) + (force-output stream) + (setf column 0)) + ((= fill-pointer (length buffer)) + (force-output stream)))) char) (defmethod ccl:stream-line-column ((stream slime-output-stream)) - (with-slots (buffer last-charpos) stream - (do ((index (1- (fill-pointer buffer)) (1- index)) - (count 0 (1+ count))) - ((< index 0) (+ count last-charpos)) - (when (char= (aref buffer index) #\newline) - (return count))))) + (slot-value stream 'column)) (defmethod ccl:stream-force-output ((stream slime-output-stream)) - (with-slots (buffer last-charpos) stream - (let ((end (fill-pointer buffer))) + (with-slots (buffer fill-pointer last-charpos) stream + (let ((end fill-pointer)) (unless (zerop end) (send-to-emacs `(:read-output ,(subseq buffer 0 end))) - (setf last-charpos (ccl:stream-line-column stream)) - (setf (fill-pointer buffer) 0)))) + (setf fill-pointer 0)))) nil) +(defun make-slime-output-stream () + (make-instance 'slime-output-stream)) + (defclass slime-input-stream (ccl:fundamental-character-input-stream) - ((buffered-char :initform nil))) + ((buffer :initform "") (index :initform 0))) (defmethod ccl:stream-read-char ((s slime-input-stream)) - (with-slots (buffered-char) s - (cond (buffered-char (prog1 buffered-char (setf buffered-char nil))) - (t (slime-read-char))))) + (with-slots (buffer index) s + (when (= index (length buffer)) + (setf buffer (slime-read-string)) + (setf index 0)) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))) + +(defmethod ccl:stream-listen ((s slime-input-stream)) + (with-slots (buffer index) s + (< index (length buffer)))) (defmethod ccl:stream-unread-char ((s slime-input-stream) char) - (setf (slot-value s 'buffered-char) char) + (with-slots (buffer index) s + (setf (aref buffer (decf index)) char)) nil) -(defmethod ccl:stream-listen ((s slime-input-stream)) +(defmethod ccl:stream-clear-input ((s slime-input-stream)) + (with-slots (buffer index) s + (setf buffer "" + index 0)) nil) (defmethod ccl:stream-line-column ((s slime-input-stream)) nil) -(defmethod ccl:stream-line-length ((s slime-input-stream)) - nil) - ;;; Evaluation (defvar *swank-debugger-stack-frame*) @@ -286,14 +300,6 @@ (funcall function frame-number p tcr lfun pc)) (incf frame-number)))))) -(defun backtrace-length () - "Return the total number of frames available in the debugger." - (let ((result 0)) - (map-backtrace #'(lambda (n p tcr lfun pc) - (declare (ignore n p tcr lfun pc)) - (incf result))) - result)) - (defun frame-arguments (p tcr lfun pc) "Returns a string representing the arguments of a frame." (multiple-value-bind (count vsp parent-vsp) @@ -352,7 +358,6 @@ (defslimefun debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) - (backtrace-length) (backtrace-for-emacs start end))) (defslimefun frame-locals (index) Index: slime/null-swank-impl.lisp diff -u slime/null-swank-impl.lisp:1.2 slime/null-swank-impl.lisp:1.3 --- slime/null-swank-impl.lisp:1.2 Tue Oct 28 18:37:14 2003 +++ slime/null-swank-impl.lisp Sun Nov 2 18:08:03 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain; all warranties are disclaimed. ;;; -;;; $Id: null-swank-impl.lisp,v 1.2 2003/10/28 23:37:14 jbielman Exp $ +;;; $Id: null-swank-impl.lisp,v 1.3 2003/11/02 23:08:03 heller Exp $ ;;; ;; The "SWANK-IMPL" package contains functions that access the naughty @@ -58,7 +58,6 @@ (:use :common-lisp) (:export #:backtrace - #:backtrace-length #:compile-file-trapping-conditions #:compile-stream-trapping-conditions #:compiler-condition @@ -261,10 +260,6 @@ simply expands into DEFUN." `(defun ,name (,condition ,hook) , at body)) - -(defun backtrace-length () - "Return the total number of stack frames known to the debugger." - 0) (defun backtrace (&optional (start 0) (end most-positive-fixnum)) "Return a list containing a backtrace of the condition current From heller at common-lisp.net Sun Nov 2 23:11:14 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 02 Nov 2003 18:11:14 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30937 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Nov 2 18:11:14 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.77 slime/ChangeLog:1.78 --- slime/ChangeLog:1.77 Sun Nov 2 15:56:11 2003 +++ slime/ChangeLog Sun Nov 2 18:11:14 2003 @@ -1,3 +1,24 @@ +2003-11-02 heller + + * null-swank-impl.lisp, swank-cmucl.lisp, swank-openmcl.lisp, + swank.lisp: Input redirection works now on the line level, like a + tty. Output streams are now line buffered. We no longer compute + the backtrace-length. + + * /project/slime/cvsroot/slime/slime.el: + (slime-repl-read-mode, slime-repl-read-string, slime-repl-return, + slime-repl-send-string, slime-read-string-state, + slime-activate-state): Reorganize input redirection. We no longer + work on the character level but on a line or region; more like a + terminal. This works better, because REPLs and debuggers are + usually written with a line buffering tty in mind. + (sldb-backtrace-length, slime-debugging-state, + slime-evaluating-state, sldb-setup, sldb-mode, sldb-insert-frames, + sldb-fetch-more-frames): Don't use backtrace-length. Computing + the length of the backtrace is (somewhat strangely) an expensive + operation in CMUCL, e.g., it takes >30 seconds to compute the + length when the yellow zone stack guard is hit. + 2003-11-02 Luke Gorrie * slime.el (slime-log-event): Added a *slime-events* buffer From heller at common-lisp.net Sun Nov 2 23:15:06 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 02 Nov 2003 18:15:06 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32616 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Nov 2 18:15:06 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.78 slime/ChangeLog:1.79 --- slime/ChangeLog:1.78 Sun Nov 2 18:11:14 2003 +++ slime/ChangeLog Sun Nov 2 18:15:06 2003 @@ -1,4 +1,4 @@ -2003-11-02 heller +2003-11-2 Helmut Eller * null-swank-impl.lisp, swank-cmucl.lisp, swank-openmcl.lisp, swank.lisp: Input redirection works now on the line level, like a From lgorrie at common-lisp.net Mon Nov 3 00:43:36 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 02 Nov 2003 19:43: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-serv6816 Modified Files: slime.el Log Message: (slime-display-buffer-region): Hacked to fix completely inexplicable XEmacs problems. Date: Sun Nov 2 19:43:36 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.73 slime/slime.el:1.74 --- slime/slime.el:1.73 Sun Nov 2 18:05:16 2003 +++ slime/slime.el Sun Nov 2 19:43:36 2003 @@ -2124,30 +2124,26 @@ (defun slime-display-buffer-region (buffer start end &optional border) (let ((border (or border 0))) - (with-current-buffer buffer - (save-selected-window - (save-excursion - (unless (get-buffer-window buffer) - (display-buffer buffer t)) - (goto-char start) - (when (eolp) - (forward-char)) - (beginning-of-line) - (let ((win (get-buffer-window buffer))) - ;; set start before select to force update. - ;; (set-window-start sets a "modified" flag, but only if the - ;; window is not selected.) - (set-window-start win (point)) - ;; don't resize vertically split windows - (when (and (not (one-window-p)) - (= (window-width) (frame-width))) - (let* ((lines (max (count-screen-lines (point) end) 1)) - (new-height (1+ (min (/ (frame-height) 2) - (+ border lines)))) - (diff (- new-height (window-height win)))) - (let ((window-min-height 1)) - (select-window win) - (enlarge-window diff)))))))))) + (save-selected-window + (select-window (display-buffer buffer t)) + (goto-char start) + (when (eolp) + (forward-char)) + (beginning-of-line) + (let ((win (get-buffer-window buffer))) + ;; set start before select to force update. + ;; (set-window-start sets a "modified" flag, but only if the + ;; window is not selected.) + (set-window-start (selected-window) (point)) + ;; don't resize vertically split windows + (when (and (not (one-window-p)) + (= (window-width) (frame-width))) + (let* ((lines (max (count-screen-lines (point) end) 1)) + (new-height (1+ (min (/ (frame-height) 2) + (+ border lines)))) + (diff (- new-height (window-height)))) + (let ((window-min-height 1)) + (enlarge-window diff)))))))) (defun slime-show-evaluation-result (value) (message "=> %s" value) From lgorrie at common-lisp.net Mon Nov 3 00:44:48 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 02 Nov 2003 19:44:48 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8067 Modified Files: ChangeLog Log Message: Date: Sun Nov 2 19:44:47 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.79 slime/ChangeLog:1.80 --- slime/ChangeLog:1.79 Sun Nov 2 18:15:06 2003 +++ slime/ChangeLog Sun Nov 2 19:44:47 2003 @@ -1,3 +1,8 @@ +2003-11-03 Luke Gorrie + + * slime.el (slime-display-buffer-region): Hacked to fix completely + inexplicable XEmacs problems. + 2003-11-2 Helmut Eller * null-swank-impl.lisp, swank-cmucl.lisp, swank-openmcl.lisp, From heller at common-lisp.net Mon Nov 3 23:19:09 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 03 Nov 2003 18:19: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-serv16338 Modified Files: slime.el Log Message: (slime-display-message-or-view, slime-remove-message-window): Also display too long lines in a new window. Add a temporary pre-command-hook to remove the multiline window before the next command is executed. (slime-display-buffer-region): Some of the comments where out of sync with the code. (slime-complete-symbol): Save the window configuration before displaying the completions and try to restore it later. The configuration is restored when: (a) the completion is unique (b) there are no completion. It is also possible to delay the restoration until (c) certain characters, e.g, space or a closing paren, are inserted. (slime-selector): Don't abort when an unkown character is pressed; display a message and continue. Similiar for ?\?. Add a selector for the *sldb* buffer. (slbd-hook, sldb-xemacs-post-command-hook): Emulate Emacs' point-entered text property with a post-command hook. Date: Mon Nov 3 18:19:08 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.74 slime/slime.el:1.75 --- slime/slime.el:1.74 Sun Nov 2 19:43:36 2003 +++ slime/slime.el Mon Nov 3 18:19:07 2003 @@ -490,7 +490,8 @@ Only uses the echo area for single-line messages - or more accurately, messages without embedded newlines. They may still need to wrap or truncate to fit on the screen." - (if (string-match "\n.*[^\\s-]" msg) + (if (or (string-match "\n.*[^\\s-]" msg) + (> (length msg) (1- (frame-width)))) ;; Contains a newline with actual text after it, so display as a ;; buffer (with-current-buffer (get-buffer-create bufname) @@ -499,10 +500,14 @@ (erase-buffer) (insert msg) (goto-char (point-min)) - (let ((win (display-buffer (current-buffer)))) - (slime-display-buffer-region (current-buffer) - (point-min) (point-max)) - (when select (select-window win))))) + (let ((win (split-window (previous-window (minibuffer-window))))) + (set-window-buffer win (current-buffer)) + (slime-display-buffer-region (current-buffer) + (point-min) (point-max)) + (if select + (select-window win) + (add-hook (make-local-variable 'pre-command-hook) + 'slime-remove-message-window))))) (when (get-buffer-window bufname) (delete-windows-on bufname)) ;; Print only the part before the newline (if there is ;; one). Newlines in messages are displayed as "^J" in emacs20, @@ -510,6 +515,10 @@ (string-match "^[^\r\n]*" msg) (message "%s" (match-string 0 msg)))) +(defun slime-remove-message-window () + (remove-hook 'pre-command-hook 'slime-remove-message-window) + (delete-windows-on "*SLIME Note*")) + ;; defun slime-message (if (or (featurep 'xemacs) (= emacs-major-version 20)) @@ -1950,6 +1959,25 @@ ;;; Completion +(defvar slime-complete-saved-window-configuration nil + "Window configuration before we show the *Completions* buffer.") + +(defun slime-complete-maybe-save-window-configuration () + "Save the current window configuration, if there is no completion in +progress." + (unless slime-complete-saved-window-configuration + (setq slime-complete-saved-window-configuration + (current-window-configuration)))) + +(defun slime-complete-restore-window-configuration () + "Delete the *Completions* buffer and restore the window config if +available." + (when (get-buffer "*Completions*") + (kill-buffer "*Completions*")) + (when slime-complete-saved-window-configuration + (set-window-configuration slime-complete-saved-window-configuration) + (setq slime-complete-saved-window-configuration nil))) + (defun slime-complete-symbol () "Complete the symbol at point. If the symbol lacks an explicit package prefix, the current buffer's @@ -1963,20 +1991,50 @@ (completions (slime-completions prefix)) (completions-alist (slime-bogus-completion-alist completions)) (completion (try-completion prefix completions-alist nil))) - (cond ((eq completion t)) + (cond ((eq completion t) + (message "[Sole completion]") + (slime-complete-restore-window-configuration)) ((null completion) (message "Can't find completion for \"%s\"" prefix) - (ding)) + (ding) + (slime-complete-restore-window-configuration)) ((not (string= prefix completion)) (delete-region beg end) - (insert-and-inherit completion)) + (insert-and-inherit completion) + (if (null (cdr completions)) + (slime-restore-window-configuration) + (slime-complete-delay-restoration))) (t (message "Making completion list...") + (slime-complete-maybe-save-window-configuration) (let ((list (all-completions prefix completions-alist nil))) (slime-with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) + (display-completion-list list)) + (slime-complete-delay-restoration)) (message "Making completion list...done"))))) +(defun slime-complete-delay-restoration () + "Install a pre-command-hook that will restore the window +configuration if possible." + (add-hook (make-local-variable 'pre-command-hook) + 'slime-complete-maybe-restore-window-confguration)) + +(defun slime-complete-forget-window-configuration () + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-confguration) + (setq slime-complete-saved-window-configuration nil)) + +(defun slime-complete-maybe-restore-window-confguration () + "Restore the window configuration, if the following command +terminates a current completion." + (cond ((find last-command-char "()\"'`,# \r\n:") + (slime-complete-restore-window-configuration) + (slime-complete-forget-window-configuration)) + ((eq this-command 'self-insert-command) + ;; keep going + ) + (t (slime-complete-forget-window-configuration)))) + (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 @@ -2122,32 +2180,29 @@ (slime-buffer-package t) (slime-show-evaluation-result-continuation))) -(defun slime-display-buffer-region (buffer start end &optional border) - (let ((border (or border 0))) - (save-selected-window - (select-window (display-buffer buffer t)) - (goto-char start) - (when (eolp) - (forward-char)) - (beginning-of-line) - (let ((win (get-buffer-window buffer))) - ;; set start before select to force update. - ;; (set-window-start sets a "modified" flag, but only if the - ;; window is not selected.) - (set-window-start (selected-window) (point)) - ;; don't resize vertically split windows - (when (and (not (one-window-p)) - (= (window-width) (frame-width))) - (let* ((lines (max (count-screen-lines (point) end) 1)) - (new-height (1+ (min (/ (frame-height) 2) - (+ border lines)))) - (diff (- new-height (window-height)))) - (let ((window-min-height 1)) - (enlarge-window diff)))))))) +(defun slime-display-buffer-region (buffer start end &optional other-window) + "Like `display-buffer', but only display the specified region." + (save-selected-window + (select-window (display-buffer buffer other-window)) + (goto-char start) + (when (eolp) + (forward-char)) + (beginning-of-line) + (let ((win (selected-window))) + (set-window-start win (point)) + ;; don't resize vertically split windows + (when (and (not (one-window-p)) + (= (window-width) (frame-width))) + (let* ((lines (max (count-screen-lines (point) end nil win) 1)) + (new-height (1+ (min (/ (frame-height) 2) + lines))) + (diff (- new-height (window-height)))) + (let ((window-min-height 1)) + (enlarge-window diff))))))) (defun slime-show-evaluation-result (value) - (message "=> %s" value) - (slime-show-last-output)) + (slime-show-last-output) + (slime-message "=> %s" value)) (defun slime-show-evaluation-result-continuation () (lambda (value) @@ -3030,7 +3085,7 @@ (defun sldb-restart-at-point () (get-text-property (point) 'restart-number)) - + (slime-define-keys sldb-mode-map ("v" 'sldb-show-source) ((kbd "RET") 'sldb-default-action) @@ -3184,9 +3239,13 @@ (apply #'string (mapcar #'car slime-selector-methods))))) (method (find ch slime-selector-methods :key #'car))) - (if (null method) - (error "No method for character: %c" ch) - (funcall (third method))))) + (cond ((null method) + (message "No method for character: ?\\%c" ch) + (ding) + (sit-for 1) + (slime-selector)) + (t + (funcall (third method)))))) (defmacro def-slime-selector-method (key description &rest body) "Define a new `slime-select' buffer selection method. @@ -3200,6 +3259,7 @@ (remove* ,key slime-selector-methods :key #'car)) #'< :key #'car))) + (def-slime-selector-method ?? "the Select help buffer." (ignore-errors (kill-buffer "*Select Help*")) (with-current-buffer (get-buffer-create "*Select Help*") @@ -3207,7 +3267,11 @@ (loop for (key line function) in slime-selector-methods do (insert (format "%c:\t%s\n" key line))) (help-mode) - (current-buffer))) + (display-buffer (current-buffer) t) + (shrink-window-if-larger-than-buffer + (get-buffer-window (current-buffer)))) + (slime-selector) + (current-buffer)) (def-slime-selector-method ?r "the SLIME Read-Eval-Print-Loop." @@ -3225,6 +3289,12 @@ "the most recently visited lisp-mode buffer." (slime-recently-visited-buffer 'lisp-mode)) +(def-slime-selector-method ?d + "the *sldb* buffer buffer" + (unless (get-buffer "*sldb*") + (error "No debugger buffer")) + "*sldb*") + (def-slime-selector-method ?e "the most recently visited emacs-lisp-mode buffer." (slime-recently-visited-buffer 'emacs-lisp-mode)) @@ -3792,6 +3862,17 @@ (defun emacs-20-p () (and (not (featurep 'xemacs)) (= emacs-major-version 20))) + +(when (featurep 'xemacs) + (add-hook 'sldb-hook 'sldb-xemacs-emulate-point-entered-hook)) + +(defun sldb-xemacs-emulate-point-entered-hook () + (add-hook (make-local-variable 'post-command-hook) + 'sldb-xemacs-post-command-hook)) + +(defun sldb-xemacs-post-command-hook () + (when (get-text-property (point) 'point-entered) + (funcall (get-text-property (point) 'point-entered)))) ;;; Finishing up From heller at common-lisp.net Mon Nov 3 23:20:20 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 03 Nov 2003 18:20: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-serv16786 Modified Files: swank.lisp Log Message: (case-convert, find-symbol-designator): New functions. Date: Mon Nov 3 18:20:20 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.52 slime/swank.lisp:1.53 --- slime/swank.lisp:1.52 Sun Nov 2 18:08:03 2003 +++ slime/swank.lisp Mon Nov 3 18:20:20 2003 @@ -162,11 +162,11 @@ (let ((*package* *buffer-package*)) (prin1-to-string string))) -(defun guess-package-from-string (name) +(defun guess-package-from-string (name &optional (default-package *package*)) (or (and name (or (find-package name) (find-package (string-upcase name)))) - *package*)) + default-package)) ;;; Input from Emacs @@ -370,6 +370,18 @@ ;;; Completion +(defun case-convert (string) + "Convert STRING according to the current readtable-case." + (ecase (readtable-case *readtable*) + (:upcase (string-upcase string)) + (:downcase (string-downcase string)) + (:preserve string) + (:invert (with-output-to-string (*standard-output*) + (loop for c across string do + (princ (if (upper-case-p c) + (char-downcase c) + c))))))) + (defslimefun completions (string default-package-name) "Return a list of completions for a symbol designator STRING. @@ -384,12 +396,12 @@ PKG:FOO - Symbols with matching prefix and external in package PKG. PKG::FOO - Symbols with matching prefix and accessible in package PKG." (multiple-value-bind (name package-name internal-p) - (parse-symbol-designator string) + (parse-symbol-designator (case-convert string)) (let ((completions nil) (package (find-package - (string-upcase (cond ((equal package-name "") "KEYWORD") - (package-name) - (default-package-name)))))) + (cond ((equal package-name "") "KEYWORD") + (package-name) + (default-package-name))))) (flet ((symbol-matches-p (symbol) (and (string-prefix-p name (symbol-name symbol)) (or (or internal-p (null package-name)) @@ -421,6 +433,22 @@ (let ((pos (position #\: string))) (if pos (subseq string 0 pos) nil)) (search "::" string))) + +(defun find-symbol-designator (string default-package) + "Return the symbol corresponding to the symbol designator STRING. +If string is not package qualified use DEFAULT-PACKAGE for the +resolution. Return nil if no such symbol exists." + (multiple-value-bind (name package-name internal-p) + (parse-symbol-designator (case-convert string)) + (cond ((and package-name (not (find-package package-name))) + nil) + (t + (let ((package (or (find-package package-name) default-package))) + (multiple-value-bind (symbol access) (find-symbol name package) + (cond ((and symbol package-name (not internal-p) + (not (eq access :external))) + nil) + (symbol (values symbol access))))))))) (defun symbol-external-p (symbol &optional (package (symbol-package symbol))) "True if SYMBOL is external in PACKAGE. From heller at common-lisp.net Mon Nov 3 23:22:41 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 03 Nov 2003 18:22:41 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17032 Modified Files: swank-cmucl.lisp swank-sbcl.lisp swank-openmcl.lisp Log Message: (arglist-string): Don't intern the function name. Use find-symbol-designator instead. Date: Mon Nov 3 18:22:41 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.16 slime/swank-cmucl.lisp:1.17 --- slime/swank-cmucl.lisp:1.16 Sun Nov 2 18:08:03 2003 +++ slime/swank-cmucl.lisp Mon Nov 3 18:22:41 2003 @@ -23,11 +23,16 @@ (lisp::misc #'sos/misc) (lisp::out #'sos/out) (lisp::sout #'sos/sout)) - (:conc-name sos.)) + (:conc-name sos.) + (:print-function %print-slime-output-stream)) (buffer (make-string 512) :type string) (index 0 :type kernel:index) (column 0 :type kernel:index)) +(defun %print-slime-output-stream (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream :type t :identity t))) + (defun sos/out (stream char) (let ((buffer (sos.buffer stream)) (index (sos.index stream))) @@ -48,7 +53,7 @@ (defun sos/misc (stream operation &optional arg1 arg2) (declare (ignore arg1 arg2)) (case operation - (:force-output + ((:force-output :finish-output) (let ((end (sos.index stream))) (unless (zerop end) (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end))) @@ -64,7 +69,8 @@ (:include string-stream (lisp::in #'sis/in) (lisp::misc #'sis/misc)) - (:conc-name sis.)) + (:conc-name sis.) + (:print-function %print-slime-output-stream)) (buffer "" :type string) (index 0 :type kernel:index)) @@ -94,47 +100,6 @@ (:get-command nil) (:element-type 'base-char))) - -;; (eval-when (:load-toplevel :compile-toplevel :execute) -;; (require :gray-streams)) -;; -;; (defclass slime-input-stream (ext:fundamental-character-input-stream) -;; ((buffer :initform "") (index :initform 0))) -;; -;; (defmethod ext:stream-read-char ((s slime-input-stream)) -;; (with-slots (buffer index) s -;; (when (= index (length buffer)) -;; (setf buffer (slime-read-string)) -;; (setf index 0)) -;; (assert (plusp (length buffer))) -;; (prog1 (aref buffer index) (incf index)))) -;; -;; (defmethod ext:stream-listen ((s slime-input-stream)) -;; (with-slots (buffer index) s -;; (< index (length buffer)))) -;; -;; (defmethod ext:stream-unread-char ((s slime-input-stream) char) -;; (with-slots (buffer index) s -;; (setf (aref buffer (decf index)) char)) -;; nil) -;; -;; (defmethod ext:stream-clear-input ((s slime-input-stream)) -;; (with-slots (buffer index) s -;; (setf buffer "" -;; index 0)) -;; nil) -;; -;; (defmethod ext:stream-line-column ((s slime-input-stream)) -;; nil) -;; -;; (defmethod ext:stream-line-length ((s slime-input-stream)) -;; 75) -;; -;; (defun make-slime-input-stream () -;; (make-instance 'slime-input-stream)) - - - (defun create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." (let* ((hostent (ext:lookup-host-entry address)) @@ -325,7 +290,7 @@ The result has the format \"(...)\"." (declare (type string fname)) (multiple-value-bind (function condition) - (ignore-errors (values (from-string fname))) + (ignore-errors (values (find-symbol-designator fname *buffer-package*))) (when condition (return-from arglist-string (format nil "(-- ~A)" condition))) (let ((arglist Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.18 slime/swank-sbcl.lisp:1.19 --- slime/swank-sbcl.lisp:1.18 Sun Nov 2 18:08:03 2003 +++ slime/swank-sbcl.lisp Mon Nov 3 18:22:41 2003 @@ -240,7 +240,7 @@ (defslimefun arglist-string (fname) (let ((*print-case* :downcase)) (multiple-value-bind (function condition) - (ignore-errors (values (from-string fname))) + (ignore-errors (values (find-symbol-designator fname))) (when condition (return-from arglist-string (format nil "(-- ~A)" condition))) (let ((arglist Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.17 slime/swank-openmcl.lisp:1.18 --- slime/swank-openmcl.lisp:1.17 Sun Nov 2 18:08:03 2003 +++ slime/swank-openmcl.lisp Mon Nov 3 18:22:41 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.17 2003/11/02 23:08:03 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.18 2003/11/03 23:22:41 heller Exp $ ;;; ;;; @@ -176,7 +176,7 @@ "Return the lambda list for function FNAME as a string." (let ((*print-case* :downcase)) (multiple-value-bind (function condition) - (ignore-errors (values (from-string fname))) + (ignore-errors (values (find-symbol-designator fname))) (when condition (return-from arglist-string (format nil "(-- ~A)" condition))) (let ((arglist (ccl:arglist function))) From heller at common-lisp.net Mon Nov 3 23:26:25 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 03 Nov 2003 18:26:25 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19176 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Nov 3 18:26:25 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.80 slime/ChangeLog:1.81 --- slime/ChangeLog:1.80 Sun Nov 2 19:44:47 2003 +++ slime/ChangeLog Mon Nov 3 18:26:24 2003 @@ -1,3 +1,30 @@ +2003-11-03 Helmut Eller + + * slime.el (slime-display-message-or-view, + slime-remove-message-window): Display too long lines in a new + window. Add a temporary pre-command-hook to remove the multiline + window before the next command is executed. + + (slime-complete-symbol): Save the window configuration before + displaying the completions and try to restore it later. The + configuration is restored when: (a) the completion is unique (b) there + are no completion. It is also possible to delay the restoration until + (c) certain characters, e.g, space or a closing paren, are inserted. + + (slime-selector): Don't abort when an unkown character is pressed; + display a message and continue. Similiar for ?\?. Add a selector for + the *sldb* buffer. + + (slbd-hook, sldb-xemacs-post-command-hook): Emulate Emacs' + point-entered text property with a post-command hook. + + * swank.lisp (case-convert, find-symbol-designator): New + functions. + + * swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp + (arglist-string): Don't intern the function name. Use + find-symbol-designator instead. + 2003-11-03 Luke Gorrie * slime.el (slime-display-buffer-region): Hacked to fix completely From heller at common-lisp.net Tue Nov 4 00:03:49 2003 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 03 Nov 2003 19:03:49 -0500 Subject: [slime-cvs] CVS update: slime/slime.el slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2125 Modified Files: slime.el swank.lisp Log Message: Duh! I'd better run the test suite _before_ committing. Date: Mon Nov 3 19:03:49 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.75 slime/slime.el:1.76 --- slime/slime.el:1.75 Mon Nov 3 18:19:07 2003 +++ slime/slime.el Mon Nov 3 19:03:48 2003 @@ -482,6 +482,15 @@ (let ((same-window-buffer-names nil)) (display-buffer buffer not-this-window))) +(defun slime-create-message-window () + (let ((previous (previous-window (minibuffer-window)))) + (when (<= (window-height previous) (* 2 window-min-height)) + (save-selected-window + (select-window previous) + (enlarge-window (- (1+ (* 2 window-min-height)) + (window-height previous))))) + (split-window previous))) + (defun slime-display-message-or-view (msg bufname &optional select) "Like `display-buffer-or-message', but with `view-buffer-other-window'. That is, if a buffer pops up it will be in view mode, and pressing q @@ -490,6 +499,7 @@ Only uses the echo area for single-line messages - or more accurately, messages without embedded newlines. They may still need to wrap or truncate to fit on the screen." + (when (get-buffer-window bufname) (delete-windows-on bufname)) (if (or (string-match "\n.*[^\\s-]" msg) (> (length msg) (1- (frame-width)))) ;; Contains a newline with actual text after it, so display as a @@ -500,7 +510,7 @@ (erase-buffer) (insert msg) (goto-char (point-min)) - (let ((win (split-window (previous-window (minibuffer-window))))) + (let ((win (slime-create-message-window))) (set-window-buffer win (current-buffer)) (slime-display-buffer-region (current-buffer) (point-min) (point-max)) @@ -508,7 +518,6 @@ (select-window win) (add-hook (make-local-variable 'pre-command-hook) 'slime-remove-message-window))))) - (when (get-buffer-window bufname) (delete-windows-on bufname)) ;; Print only the part before the newline (if there is ;; one). Newlines in messages are displayed as "^J" in emacs20, ;; which is ugly Index: slime/swank.lisp diff -u slime/swank.lisp:1.53 slime/swank.lisp:1.54 --- slime/swank.lisp:1.53 Mon Nov 3 18:20:20 2003 +++ slime/swank.lisp Mon Nov 3 19:03:48 2003 @@ -396,12 +396,13 @@ PKG:FOO - Symbols with matching prefix and external in package PKG. PKG::FOO - Symbols with matching prefix and accessible in package PKG." (multiple-value-bind (name package-name internal-p) - (parse-symbol-designator (case-convert string)) + (parse-symbol-designator string) (let ((completions nil) (package (find-package - (cond ((equal package-name "") "KEYWORD") - (package-name) - (default-package-name))))) + (case-convert + (cond ((equal package-name "") "KEYWORD") + (package-name) + (default-package-name)))))) (flet ((symbol-matches-p (symbol) (and (string-prefix-p name (symbol-name symbol)) (or (or internal-p (null package-name)) From heller at common-lisp.net Tue Nov 4 08:02:23 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 04 Nov 2003 03:02: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-serv8546 Modified Files: slime.el Log Message: Fix test-suite for SBCL. Date: Tue Nov 4 03:02:22 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.76 slime/slime.el:1.77 --- slime/slime.el:1.76 Mon Nov 3 19:03:48 2003 +++ slime/slime.el Tue Nov 4 03:02:22 2003 @@ -2039,7 +2039,11 @@ (cond ((find last-command-char "()\"'`,# \r\n:") (slime-complete-restore-window-configuration) (slime-complete-forget-window-configuration)) - ((eq this-command 'self-insert-command) + ((memq this-command '(self-insert-command + slime-complete-symbol + backward-delete-char-untabify + backward-delete-char + scroll-other-window)) ;; keep going ) (t (slime-complete-forget-window-configuration)))) @@ -3545,7 +3549,7 @@ "Lookup the argument list for FUNCTION-NAME. Confirm that EXPECTED-ARGLIST is displayed." '(("swank:start-server" - "(swank:start-server &optional (port server-port))") + "(swank:start-server port-file-namestring)") ("swank::string-prefix-p" "(swank::string-prefix-p s1 s2)")) (let ((arglist (slime-get-arglist function-name))) ; @@ -3640,7 +3644,7 @@ '(()) (slime-check "Automaton initially in idle state." (slime-test-state-stack '(slime-idle-state))) - (slime-eval-async '(loop) "CL-USER" (lambda (_) )) + (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) (let ((sldb-hook (lambda () (slime-check "First interrupt." @@ -3662,7 +3666,7 @@ '(()) (slime-check "Automaton initially in idle state." (slime-test-state-stack '(slime-idle-state))) - (slime-eval-async '(loop) "CL-USER" (lambda (_) )) + (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) (let ((sldb-hook (lambda () (slime-check "First interrupt." From heller at common-lisp.net Tue Nov 4 08:03:11 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 04 Nov 2003 03:03:11 -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-serv8792 Modified Files: swank-openmcl.lisp Log Message: (arglist-string): Pass *buffer-package* to find-symbol-designator. Date: Tue Nov 4 03:03:11 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.18 slime/swank-openmcl.lisp:1.19 --- slime/swank-openmcl.lisp:1.18 Mon Nov 3 18:22:41 2003 +++ slime/swank-openmcl.lisp Tue Nov 4 03:03:10 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.18 2003/11/03 23:22:41 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.19 2003/11/04 08:03:10 heller Exp $ ;;; ;;; @@ -176,7 +176,8 @@ "Return the lambda list for function FNAME as a string." (let ((*print-case* :downcase)) (multiple-value-bind (function condition) - (ignore-errors (values (find-symbol-designator fname))) + (ignore-errors (values + (find-symbol-designator fname *buffer-package*))) (when condition (return-from arglist-string (format nil "(-- ~A)" condition))) (let ((arglist (ccl:arglist function))) From heller at common-lisp.net Tue Nov 4 08:03:23 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 04 Nov 2003 03:03:23 -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-serv8839 Modified Files: swank-sbcl.lisp Log Message: (arglist-string): Pass *buffer-package* to find-symbol-designator. Date: Tue Nov 4 03:03:22 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.19 slime/swank-sbcl.lisp:1.20 --- slime/swank-sbcl.lisp:1.19 Mon Nov 3 18:22:41 2003 +++ slime/swank-sbcl.lisp Tue Nov 4 03:03:20 2003 @@ -240,7 +240,8 @@ (defslimefun arglist-string (fname) (let ((*print-case* :downcase)) (multiple-value-bind (function condition) - (ignore-errors (values (find-symbol-designator fname))) + (ignore-errors (values + (find-symbol-designator fname *buffer-package*))) (when condition (return-from arglist-string (format nil "(-- ~A)" condition))) (let ((arglist From heller at common-lisp.net Tue Nov 4 22:29:03 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 04 Nov 2003 17:29: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-serv26093 Modified Files: slime.el Log Message: (slime-read-string-state): Add support for evaluation requests. (slime-repl-read-break): New command. (slime-display-message): Renamed from slime-display-message-or-view. (slime-show-evaluation-result-continuation): Save the current-buffer so that slime-display-message can add a pre-command hook to remove the buffer. (slime-display-buffer-region): Simplified. slime-keys: XEmacs cannot rebind C-c C-g. Use C-c C-b as an alternative. (slime-selector): XEmacs has no prompt argument for read-char. (slime-underline-color, slime-face-attributes): Make face definitions compatible with XEmacs and Emacs20. (slime-disconnect): Delete the buffer of the socket. (slime-net-connect): Prefix the connection buffer name with a space to avoid accidental deletion. Date: Tue Nov 4 17:29:03 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.77 slime/slime.el:1.78 --- slime/slime.el:1.77 Tue Nov 4 03:02:22 2003 +++ slime/slime.el Tue Nov 4 17:29:03 2003 @@ -117,56 +117,76 @@ :prefix "slime-" :group 'applications) +;; XEmacs wants underline to be a boolean. +(defun slime-underline-color (underline) + (cond ((featurep 'xemacs) (if underline t nil)) + (t underline))) + (defface slime-error-face - '((((class color) (background light)) - (:underline "red")) + `((((class color) (background light)) + (:underline ,(slime-underline-color "red"))) (((class color) (background dark)) - (:underline "red")) + (:underline ,(slime-underline-color "red"))) (t (:underline t))) "Face for errors from the compiler." :group 'slime) (defface slime-warning-face - '((((class color) (background light)) - (:underline "orange")) + `((((class color) (background light)) + (:underline ,(slime-underline-color "orange"))) (((class color) (background dark)) - (:underline "coral")) + (:underline ,(slime-underline-color "coral"))) (t (:underline t))) "Face for warnings from the compiler." :group 'slime) (defface slime-style-warning-face - '((((class color) (background light)) - (:underline "brown")) + `((((class color) (background light)) + (:underline ,(slime-underline-color "brown"))) (((class color) (background dark)) - (:underline "gold")) + (:underline ,(slime-underline-color "gold"))) (t (:underline t))) "Face for style-warnings from the compiler." :group 'slime) (defface slime-note-face - '((((class color) (background light)) - (:underline "brown4")) + `((((class color) (background light)) + (:underline ,(slime-underline-color "brown4"))) (((class color) (background dark)) - (:underline "light goldenrod")) + (:underline ,(slime-underline-color "light goldenrod"))) (t (:underline t))) "Face for notes from the compiler." :group 'slime) +;; XEmacs and Emacs20 don't support the :inherit attribute in defface. +;; We copy the most important attributes manually. + +(defun slime-color-name (color) + (cond ((featurep 'xemacs) (color-name color)) + (t color))) + +(defun slime-face-bold-p (face) + (cond ((featurep 'xemacs) (custom-face-bold face)) + (t (face-bold-p face)))) + +(defun slime-face-attributes (face) + (list :foreground (slime-color-name (face-foreground face)) + :background (slime-color-name (face-background face)) + :underline (face-underline-p face) + :bold (slime-face-bold-p face))) + (defface slime-highlight-face - '((t - (:inherit highlight) - (:underline nil))) + `((t ,(slime-face-attributes 'highlight))) "Face for compiler notes while selected." :group 'slime) (defface slime-repl-output-face - '((t (:inherit font-lock-string-face))) + `((t ,(slime-face-attributes 'font-lock-string-face))) "Face for Lisp output in the SLIME REPL." :group 'slime) (defface slime-repl-input-face - '((t (:inherit bold))) + `((t ,(slime-face-attributes 'bold))) "Face for previous input in the SLIME REPL." :group 'slime) @@ -326,6 +346,8 @@ (":" slime-interactive-eval :prefixed t :sldb t) ("\C-z" slime-switch-to-output-buffer :prefixed t :sldb t) ("\C-g" slime-interrupt :prefixed t :inferior t :sldb t) + ;; NB: XEmacs dosn't like \C-g. Use \C-b as "break" key. + ("\C-b" slime-interrupt :prefixed t :inferior t :sldb t) ("\M-g" slime-quit :prefixed t :inferior t :sldb t) ;; Documentation (" " slime-space :inferior t) @@ -491,49 +513,34 @@ (window-height previous))))) (split-window previous))) -(defun slime-display-message-or-view (msg bufname &optional select) - "Like `display-buffer-or-message', but with `view-buffer-other-window'. -That is, if a buffer pops up it will be in view mode, and pressing q -will get rid of it. - -Only uses the echo area for single-line messages - or more accurately, -messages without embedded newlines. They may still need to wrap or -truncate to fit on the screen." - (when (get-buffer-window bufname) (delete-windows-on bufname)) - (if (or (string-match "\n.*[^\\s-]" msg) - (> (length msg) (1- (frame-width)))) - ;; Contains a newline with actual text after it, so display as a - ;; buffer - (with-current-buffer (get-buffer-create bufname) - (setq buffer-read-only t) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert msg) - (goto-char (point-min)) - (let ((win (slime-create-message-window))) - (set-window-buffer win (current-buffer)) - (slime-display-buffer-region (current-buffer) - (point-min) (point-max)) - (if select - (select-window win) - (add-hook (make-local-variable 'pre-command-hook) - 'slime-remove-message-window))))) - ;; Print only the part before the newline (if there is - ;; one). Newlines in messages are displayed as "^J" in emacs20, - ;; which is ugly - (string-match "^[^\r\n]*" msg) - (message "%s" (match-string 0 msg)))) - -(defun slime-remove-message-window () - (remove-hook 'pre-command-hook 'slime-remove-message-window) - (delete-windows-on "*SLIME Note*")) +(defun slime-display-message (message buffer-name) + "Display MESSAGE in the echo area or in BUFFER-NAME. Use the echo +area if MESSAGE needs only a single line. If the MESSAGE requires +more than one line display it in BUFFER-NAME and add a hook to +`slime-pre-command-actions' to remove the window before the next +command." + (when (get-buffer-window buffer-name) (delete-windows-on buffer-name)) + (cond ((or (string-match "\n" message) + (> (length message) (1- (frame-width)))) + (lexical-let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (erase-buffer) + (insert message) + (goto-char (point-min)) + (let ((win (slime-create-message-window))) + (set-window-buffer win (current-buffer)) + (shrink-window-if-larger-than-buffer + (display-buffer (current-buffer))))) + (push (lambda () (delete-windows-on buffer) (bury-buffer buffer)) + slime-pre-command-actions))) + (t (message "%s" message)))) ;; defun slime-message (if (or (featurep 'xemacs) (= emacs-major-version 20)) ;; XEmacs truncates multi-line messages in the echo area. (defun slime-message (fmt &rest args) - (slime-display-message-or-view (apply #'format fmt args) "*SLIME Note*")) + (slime-display-message (apply #'format fmt args) "*SLIME Note*")) (defun slime-message (fmt &rest args) (apply 'message fmt args))) @@ -719,6 +726,7 @@ "Disconnect from the Swank server." (interactive) (cond ((slime-connected-p) + (kill-buffer (process-buffer slime-net-process)) (delete-process slime-net-process) (message "Disconnected.")) (slime-startup-retry-timer @@ -729,8 +737,7 @@ (defun slime-init-connection () (slime-init-dispatcher) - (setq slime-pid (slime-eval '(swank:getpid))) - (slime-repl)) + (setq slime-pid (slime-eval '(swank:getpid)))) (defvar slime-words-of-encouragement '("Let the hacking commence!" @@ -755,7 +762,7 @@ "Establish a connection with a CL." (setq slime-net-process (open-network-stream "SLIME Lisp" nil host port)) - (let ((buffer (slime-make-net-buffer "*cl-connection*"))) + (let ((buffer (slime-make-net-buffer " *cl-connection*"))) (set-process-buffer slime-net-process buffer) (set-process-filter slime-net-process 'slime-net-filter) (set-process-sentinel slime-net-process 'slime-net-sentinel) @@ -1149,6 +1156,12 @@ (slime-repl-read-string)) ((:emacs-return-string code) (slime-net-send `(swank:take-input ,tag ,code)) + (slime-pop-state)) + ((:emacs-evaluate form-string package-name continuation) + (slime-output-evaluate-request form-string package-name) + (slime-push-state (slime-evaluating-state continuation))) + ((:read-aborted) + (slime-repl-abort-read) (slime-pop-state))) @@ -1271,11 +1284,10 @@ (defun slime-show-last-output () (with-current-buffer (slime-output-buffer) - (let ((output-start slime-last-output-start) - (prompt-start slime-repl-prompt-start-mark)) - (when (< output-start prompt-start) - (slime-display-buffer-region - (current-buffer) output-start prompt-start))))) + (let ((start slime-last-output-start) + (end slime-repl-prompt-start-mark)) + (when (< start end) + (slime-display-buffer-region (current-buffer) start end))))) (defun slime-output-string (string) (unless (zerop (length string)) @@ -1510,10 +1522,14 @@ (" " 'slime-space)) (define-minor-mode slime-repl-read-mode - "Mode the read input from Emacs" + "Mode the read input from Emacs +\\{slime-repl-read-mode-map}" nil nil - '(("\C-m" . slime-repl-return))) + '(("\C-m" . slime-repl-return) + ("\C-c\C-b" . slime-repl-read-break) + ("\C-c\C-c" . slime-repl-read-break) + ("\C-c\C-g" . slime-repl-read-break))) (add-to-list 'minor-mode-alist '(slime-repl-read-mode "[read]")) @@ -1527,6 +1543,16 @@ (slime-dispatch-event `(:emacs-return-string ,string)) (slime-repl-read-mode nil)) +(defun slime-repl-read-break () + (interactive) + (slime-eval-async `(cl:break) nil (lambda (_)))) + +(defun slime-repl-abort-read () + (with-current-buffer (slime-output-buffer) + (slime-repl-read-mode nil) + (slime-repl-maybe-insert-output-separator) + (message "Read aborted"))) + ;;; Compilation and the creation of compiler-note annotations @@ -2195,31 +2221,26 @@ (defun slime-display-buffer-region (buffer start end &optional other-window) "Like `display-buffer', but only display the specified region." - (save-selected-window - (select-window (display-buffer buffer other-window)) - (goto-char start) - (when (eolp) - (forward-char)) - (beginning-of-line) - (let ((win (selected-window))) - (set-window-start win (point)) - ;; don't resize vertically split windows - (when (and (not (one-window-p)) - (= (window-width) (frame-width))) - (let* ((lines (max (count-screen-lines (point) end nil win) 1)) - (new-height (1+ (min (/ (frame-height) 2) - lines))) - (diff (- new-height (window-height)))) - (let ((window-min-height 1)) - (enlarge-window diff))))))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (goto-char start) + (beginning-of-line) + (narrow-to-region (point) end) + (let ((window (display-buffer buffer other-window))) + (set-window-start window (point)) + (shrink-window-if-larger-than-buffer window) + window))))) (defun slime-show-evaluation-result (value) (slime-show-last-output) (slime-message "=> %s" value)) (defun slime-show-evaluation-result-continuation () - (lambda (value) - (slime-show-evaluation-result value))) + (lexical-let ((buffer (current-buffer))) + (lambda (value) + (with-current-buffer buffer + (slime-show-evaluation-result value))))) (defun slime-last-expression () (buffer-substring-no-properties (save-excursion (backward-sexp) (point)) @@ -3248,9 +3269,9 @@ See `def-slime-selector-method' for defining new methods." (interactive) - (let* ((ch (read-char (format "Select [%s]: " - (apply #'string - (mapcar #'car slime-selector-methods))))) + (message "Select [%s]: " + (apply #'string (mapcar #'car slime-selector-methods))) + (let* ((ch (read-char)) (method (find ch slime-selector-methods :key #'car))) (cond ((null method) (message "No method for character: ?\\%c" ch) @@ -3288,7 +3309,7 @@ (def-slime-selector-method ?r "the SLIME Read-Eval-Print-Loop." - "*slime-repl*") + (slime-output-buffer)) (def-slime-selector-method ?i "the *inferior-lisp* buffer." From heller at common-lisp.net Tue Nov 4 22:33:33 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 04 Nov 2003 17:33:33 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28218 Modified Files: swank.lisp Log Message: (slime-read-string): Send a :read-aborted event for non-local exits. (case-convert): Handle :invert case better. Date: Tue Nov 4 17:33:32 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.54 slime/swank.lisp:1.55 --- slime/swank.lisp:1.54 Mon Nov 3 19:03:48 2003 +++ slime/swank.lisp Tue Nov 4 17:33:31 2003 @@ -176,9 +176,14 @@ (force-output) (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) (send-to-emacs `(:read-string ,*read-input-catch-tag*)) - (catch *read-input-catch-tag* - (loop (read-from-emacs))))) - + (let (ok) + (unwind-protect + (prog1 (catch *read-input-catch-tag* + (loop (read-from-emacs))) + (setq ok t)) + (unless ok + (send-to-emacs `(:read-aborted))))))) + (defslimefun take-input (tag input) (throw tag input)) @@ -376,11 +381,9 @@ (:upcase (string-upcase string)) (:downcase (string-downcase string)) (:preserve string) - (:invert (with-output-to-string (*standard-output*) - (loop for c across string do - (princ (if (upper-case-p c) - (char-downcase c) - c))))))) + (:invert (cond ((every #'lower-case-p string) (string-upcase string)) + ((every #'upper-case-p string) (string-downcase string)) + (t string))))) (defslimefun completions (string default-package-name) "Return a list of completions for a symbol designator STRING. From heller at common-lisp.net Tue Nov 4 22:38:15 2003 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 04 Nov 2003 17:38:15 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30230 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Nov 4 17:38:15 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.81 slime/ChangeLog:1.82 --- slime/ChangeLog:1.81 Mon Nov 3 18:26:24 2003 +++ slime/ChangeLog Tue Nov 4 17:38:15 2003 @@ -1,3 +1,22 @@ +2003-11-04 Helmut Eller + + * slime.el (slime-read-string-state): Add support for evaluation + requests. + (slime-repl-read-break): New command. + alternative. + slime-keys: XEmacs cannot rebind C-c C-g. Use C-c C-b as an + alternative. + (slime-selector): XEmacs has no prompt argument for read-char. + (slime-underline-color, slime-face-attributes): Make face + definitions compatible with XEmacs and Emacs20. + (slime-disconnect): Delete the buffer of the socket. + (slime-net-connect): Prefix the connection buffer name with a + space to avoid accidental deletion. + + * swank.lisp (slime-read-string): Send a :read-aborted event for + non-local exits. + (case-convert): Handle :invert case better. + 2003-11-03 Helmut Eller * slime.el (slime-display-message-or-view, From lgorrie at common-lisp.net Thu Nov 6 06:14:20 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 06 Nov 2003 01:14:20 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31829 Modified Files: slime.el Log Message: (slime, slime-lisp-package): Reset `slime-lisp-package' (the REPL package) when reconnecting. (slime-buffer-package): Return `slime-lisp-package' when the major-mode is `slime-repl-mode'. Date: Thu Nov 6 01:14:20 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.78 slime/slime.el:1.79 --- slime/slime.el:1.78 Tue Nov 4 17:29:03 2003 +++ slime/slime.el Thu Nov 6 01:14:19 2003 @@ -96,9 +96,13 @@ "Association list mapping package names onto their preferred nicknames. This determines which name appears in the REPL prompt.") -(defvar slime-lisp-package +(defvar slime-default-lisp-package (or (cdr (assoc "COMMON-LISP-USER" slime-lisp-preferred-package-nicknames)) "COMMON-LISP-USER") + "The default and initial package for the REPL.") + +(defvar slime-lisp-package + slime-default-lisp-package "The current package name of the Superior lisp. This is automatically synchronized from Lisp.") @@ -477,8 +481,11 @@ "Return the Common Lisp package associated with the current buffer. This is heuristically determined by a text search of the buffer. The result is cached and returned on subsequent calls unless -DONT-CACHE is non-nil." - (or (and (not dont-cache) slime-buffer-package) +DONT-CACHE is non-nil. + +The REPL buffer is a special case: it's package is `slime-lisp-package'." + (or (and (eq major-mode 'slime-repl-mode) slime-lisp-package) + (and (not dont-cache) slime-buffer-package) (and (setq slime-buffer-package (slime-find-buffer-package)) (progn (force-mode-line-update) slime-buffer-package)) "CL-USER")) @@ -657,6 +664,7 @@ (when (slime-connected-p) (slime-disconnect)) (slime-maybe-start-lisp) + (setq slime-lisp-package slime-default-lisp-package) (slime-connect)) (defun slime-maybe-start-lisp () @@ -1330,6 +1338,7 @@ \\{slime-repl-mode-map}" (interactive) (kill-all-local-variables) + (setq major-mode 'slime-repl-mode) (use-local-map slime-repl-mode-map) (lisp-mode-variables t) (setq font-lock-defaults nil) From lgorrie at common-lisp.net Thu Nov 6 06:14:27 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 06 Nov 2003 01:14:27 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31857 Modified Files: ChangeLog Log Message: Date: Thu Nov 6 01:14:27 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.82 slime/ChangeLog:1.83 --- slime/ChangeLog:1.82 Tue Nov 4 17:38:15 2003 +++ slime/ChangeLog Thu Nov 6 01:14:26 2003 @@ -1,3 +1,10 @@ +2003-11-06 Luke Gorrie + + * slime.el (slime, slime-lisp-package): Reset `slime-lisp-package' + (the REPL package) when reconnecting. + (slime-buffer-package): Return `slime-lisp-package' when the + major-mode is `slime-repl-mode'. + 2003-11-04 Helmut Eller * slime.el (slime-read-string-state): Add support for evaluation From lgorrie at common-lisp.net Thu Nov 6 08:54:47 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 06 Nov 2003 03:54: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-serv4660 Modified Files: slime.el Log Message: (slime-autodoc-mode): When non-nil, display the argument list for the function-call near point each time the point moves in a slime-mode buffer. This is a first-cut; more useful context-sensitive help to follow (e.g. looking up variable documentation). (slime-autodoc-cache-type): Cache policy "autodoc" documentation: either nil (no caching), 'last (the default - cache most recent only), or 'all (cache everything on symbol plists forever). Convenience macros: (when-bind (var exp) &rest body) => (let ((var exp)) (when var . body)) (with-lexical-bindings (var1 ...) . body) => (lexical-let ((var1 var1) ...) . body) Date: Thu Nov 6 03:54:47 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.79 slime/slime.el:1.80 --- slime/slime.el:1.79 Thu Nov 6 01:14:19 2003 +++ slime/slime.el Thu Nov 6 03:54:46 2003 @@ -420,7 +420,8 @@ (defun slime-post-command-hook () (when (slime-connected-p) - (slime-process-available-input))) + (slime-process-available-input)) + (slime-autodoc-post-command-hook)) (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." @@ -443,6 +444,22 @@ ;;; Common utility functions and macros +(defmacro* when-bind ((var value) &rest body) + "Evaluate VALUE, and if the result is non-nil bind it to VAR and +evaluate BODY." + `(let ((,var ,value)) + (when ,var , at body))) + +(put 'when-bind 'lisp-indent-function 1) + +(defmacro with-lexical-bindings (variables &rest body) + "Execute BODY with VARIABLES in lexical scope." + `(lexical-let ,(mapcar (lambda (variable) (list variable variable)) + variables) + , at body)) + +(put 'with-lexical-bindings 'lisp-indent-function 1) + (defmacro destructure-case (value &rest patterns) "Dispatch VALUE to one of PATTERNS. A cross between `case' and `destructuring-bind'. @@ -1982,15 +1999,20 @@ (slime-function-called-at-point/line)) (slime-arglist (symbol-name (slime-function-called-at-point/line))))) -(defun slime-arglist (symbol-name) - "Show the argument list for the nearest function call, if any." +(defun slime-arglist (symbol-name &optional show-fn) + "Show the argument list for the nearest function call, if any. +If SHOW-FN is non-nil, it is funcall'd with the result instead of +printing a message." (interactive (list (slime-read-symbol "Arglist of: "))) (slime-eval-async `(swank:arglist-string ,symbol-name) (slime-buffer-package) - (lexical-let ((symbol-name symbol-name)) + (lexical-let ((show-fn show-fn) + (symbol-name symbol-name)) (lambda (arglist) - (message "%s" (slime-format-arglist symbol-name arglist)))))) + (if show-fn + (funcall show-fn arglist) + (message "%s" (slime-format-arglist symbol-name arglist))))))) (defun slime-get-arglist (symbol-name) "Return the argument list for SYMBOL-NAME." @@ -2001,6 +2023,82 @@ (format "(%s %s)" symbol-name (substring arglist 1 -1))) +;;; Autodocs (automatic context-sensitive help) + +(defvar slime-autodoc-mode nil + "*When non-nil, print documentation about symbols as the point moves.") + +(defvar slime-autodoc-cache-type 'last + "*Cache policy for automatically fetched documentation. +Possible values are: + nil - none. + last - cache only the most recently-looked-at symbol's documentation. + The values are stored in the variable `slime-autodoc-cache'. + all - cache all symbol documentation. + The values are stored on the `slime-autodoc-cache' property + of the respective Elisp symbols. + +More caching means fewer calls to the Lisp process, but at the risk of +using outdated information.") + +(defvar slime-autodoc-cache nil + "Cache variable for when `slime-autodoc-cache-type' is 'last'. +The value is (SYMBOL-NAME . DOCUMENTATION).") + +(defun slime-autodoc () + (when-bind (sym (slime-function-called-at-point/line)) + (let ((name (symbol-name sym)) + (cache-key (slime-qualify-cl-symbol-name sym))) + (or (slime-get-cached-autodoc cache-key) + ;; Asynchronously fetch, cache, and display arglist + (slime-arglist + name + (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) + (message arglist))))))))) + +(defun slime-get-cached-autodoc (symbol-name) + "Return the cached autodoc documentation for SYMBOL-NAME, or nil." + (ecase slime-autodoc-cache-type + ((nil) nil) + ((last) + (when (equal (car slime-autodoc-cache) symbol-name) + (cdr slime-autodoc-cache))) + ((all) + (when-bind (symbol (intern-soft symbol-name)) + (get symbol 'slime-autodoc-cache))))) + +(defun slime-update-autodoc-cache (symbol-name documentation) + "Update the autodoc cache for SYMBOL with DOCUMENTATION. +Return DOCUMENTATION." + (ecase slime-autodoc-cache-type + ((nil) nil) + ((last) + (setq slime-autodoc-cache (cons symbol-name documentation))) + ((all) + (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. +When `slime-autodoc-mode' is non-nil, print apropos information about +the symbol at point if applicable." + (assert slime-mode) + (unless (or (not slime-autodoc-mode) + (not (slime-connected-p)) + (slime-busy-p)) + (condition-case err + (when-bind (documentation (slime-autodoc)) + (message documentation)) + (error + (setq slime-autodoc-mode nil) + (message "Error: %S; slime-autodoc-mode now disabled." err))))) + + ;;; Completion (defvar slime-complete-saved-window-configuration nil @@ -2155,6 +2253,8 @@ (slime-buffer-package)))))) +;;; Interpreting Elisp symbols as CL symbols (package qualifiers) + (defun slime-cl-symbol-name (symbol) (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) (if (string-match ":\\([^:]*\\)$" n) @@ -2174,6 +2274,23 @@ (let ((name (if (stringp symbol) symbol (symbol-name symbol)))) (and (string-match ":" name) (not (string-match "::" name))))) + +(defun slime-qualify-cl-symbol (symbol-or-name) + "Like `slime-qualify-cl-symbol-name', but interns the result." + (intern (slime-qualify-cl-symbol-name symbol-or-name))) + +(defun slime-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified symbol-name that indicates the CL symbol +SYMBOL. If SYMBOL doesn't already have a package prefix, the buffer +package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (slime-cl-symbol-package s) + s + (format "%s::%s" + (slime-buffer-package) + (slime-cl-symbol-name s))))) ;;; Edit definition From lgorrie at common-lisp.net Thu Nov 6 08:55:05 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 06 Nov 2003 03:55:05 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4756 Modified Files: ChangeLog Log Message: Date: Thu Nov 6 03:55:03 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.83 slime/ChangeLog:1.84 --- slime/ChangeLog:1.83 Thu Nov 6 01:14:26 2003 +++ slime/ChangeLog Thu Nov 6 03:55:02 2003 @@ -1,5 +1,20 @@ 2003-11-06 Luke Gorrie + * slime.el (slime-autodoc-mode): When non-nil, display the + argument list for the function-call near point each time the point + moves in a slime-mode buffer. This is a first-cut; more useful + context-sensitive help to follow (e.g. looking up variable + documentation). + (slime-autodoc-cache-type): Cache policy "autodoc" documentation: + either nil (no caching), 'last (the default - cache most recent + only), or 'all (cache everything on symbol plists forever). + + * slime.el: Convenience macros: + (when-bind (var exp) &rest body) + => (let ((var exp)) (when var . body)) + (with-lexical-bindings (var1 ...) . body) + => (lexical-let ((var1 var1) ...) . body) + * slime.el (slime, slime-lisp-package): Reset `slime-lisp-package' (the REPL package) when reconnecting. (slime-buffer-package): Return `slime-lisp-package' when the From lgorrie at common-lisp.net Thu Nov 6 09:15:37 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 06 Nov 2003 04:15: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-serv16800 Modified Files: slime.el Log Message: Minor cleanup. Date: Thu Nov 6 04:15:36 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.80 slime/slime.el:1.81 --- slime/slime.el:1.80 Thu Nov 6 03:54:46 2003 +++ slime/slime.el Thu Nov 6 04:15:36 2003 @@ -2046,10 +2046,13 @@ The value is (SYMBOL-NAME . DOCUMENTATION).") (defun slime-autodoc () + "Print some apropos information about the code at point, if applicable." (when-bind (sym (slime-function-called-at-point/line)) (let ((name (symbol-name sym)) (cache-key (slime-qualify-cl-symbol-name sym))) - (or (slime-get-cached-autodoc cache-key) + (or (when-bind (documentation (slime-get-cached-autodoc cache-key)) + (message documentation) + t) ;; Asynchronously fetch, cache, and display arglist (slime-arglist name @@ -2092,8 +2095,7 @@ (not (slime-connected-p)) (slime-busy-p)) (condition-case err - (when-bind (documentation (slime-autodoc)) - (message documentation)) + (slime-autodoc) (error (setq slime-autodoc-mode nil) (message "Error: %S; slime-autodoc-mode now disabled." err))))) From heller at common-lisp.net Sat Nov 8 00:32:50 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 07 Nov 2003 19:32:50 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16253 Modified Files: slime.el Log Message: (slime-face-attributes, slime-face-font-name): Copy the font too. (slime-buffer-package): Try to find be the package name before resorting to slime-buffer-package. Return nil and not "CL-USER" if the package cannot be determined. (slime-goto-location): Insert notes with a source path but no filename or buffername at point. This can happen for warnings during macro expansion. (The macro expander is a interpreted function and does not have a filename or buffername.) (slime-show-note): Display 2 double quotes "" in the for zero length messages. SERIES tends to signal warnings with zero length messages. slime-complete-saved-window-configuration: Store the window config in a buffer local variable. (slime-print-apropos): Add support for alien types. (slime-select-function): Bind pop-up-windows to nil. (Doesn't seem to work, though.) (slime-selector): Switch to the minibuffer for reading the event. (slime-display-buffer-region): Enlarge the window if it is too small. (slime-find-buffer-package): Initialize command hooks. Date: Fri Nov 7 19:32:50 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.81 slime/slime.el:1.82 --- slime/slime.el:1.81 Thu Nov 6 04:15:36 2003 +++ slime/slime.el Fri Nov 7 19:32:50 2003 @@ -173,12 +173,17 @@ (cond ((featurep 'xemacs) (custom-face-bold face)) (t (face-bold-p face)))) +(defun slime-face-font-name (face) + (cond ((featurep 'xemacs) (face-font-name face)) + (t (face-font face)))) + (defun slime-face-attributes (face) (list :foreground (slime-color-name (face-foreground face)) :background (slime-color-name (face-background face)) :underline (face-underline-p face) - :bold (slime-face-bold-p face))) - + :bold (slime-face-bold-p face) + :font (slime-face-font-name face))) + (defface slime-highlight-face `((t ,(slime-face-attributes 'highlight))) "Face for compiler notes while selected." @@ -496,16 +501,22 @@ (defun slime-buffer-package (&optional dont-cache) "Return the Common Lisp package associated with the current buffer. -This is heuristically determined by a text search of the buffer. -The result is cached and returned on subsequent calls unless -DONT-CACHE is non-nil. +This is heuristically determined by a text search of the buffer. The +result is stored in `slime-buffer-package' unless DONT-CACHE is +non-nil. If the current package cannot be determined fall back to +slime-buffer-package (which may also be nil). The REPL buffer is a special case: it's package is `slime-lisp-package'." (or (and (eq major-mode 'slime-repl-mode) slime-lisp-package) - (and (not dont-cache) slime-buffer-package) - (and (setq slime-buffer-package (slime-find-buffer-package)) - (progn (force-mode-line-update) slime-buffer-package)) - "CL-USER")) + (let ((string (slime-find-buffer-package))) + (cond (string + (cond (dont-cache) + ((equal string slime-buffer-package)) + (t + (setq slime-buffer-package string) + (force-mode-line-update))) + string) + (t slime-buffer-package))))) (defun slime-find-buffer-package () "Figure out which Lisp package the current buffer is associated with." @@ -1362,6 +1373,7 @@ (setq mode-name "REPL") (set (make-local-variable 'scroll-conservatively) 20) (set (make-local-variable 'scroll-margin) 0) + (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) (defun slime-repl-insert-prompt () @@ -1551,14 +1563,12 @@ "Mode the read input from Emacs \\{slime-repl-read-mode-map}" nil - nil + "[read]" '(("\C-m" . slime-repl-return) ("\C-c\C-b" . slime-repl-read-break) ("\C-c\C-c" . slime-repl-read-break) ("\C-c\C-g" . slime-repl-read-break))) -(add-to-list 'minor-mode-alist '(slime-repl-read-mode "[read]")) - (defun slime-repl-read-string () (slime-switch-to-output-buffer) (set-marker slime-repl-input-start-mark (point) (current-buffer)) @@ -1826,7 +1836,10 @@ (re-search-forward (format "^(def\\w+\\s +%s\\s +" (plist-get note :function-name))) (beginning-of-line))) - ((not (plist-get note :source-path)) + ((or (not (plist-get note :source-path)) + (and (not (plist-get note :filename)) + (not (plist-get note :buffername)) + (plist-get note :source-path))) ;; no source-path available. hmm... move the the first sexp (cond ((plist-get note :buffername) (goto-char (plist-get note :buffer-offset))) @@ -1933,7 +1946,8 @@ (defun slime-show-note (overlay) "Present the details of a compiler note to the user." (slime-temporarily-highlight-note overlay) - (slime-message "%s" (get-char-property (point) 'help-echo))) + (let ((message (get-char-property (point) 'help-echo))) + (slime-message "%s" (if (zerop (length message)) "\"\"" message)))) (defun slime-temporarily-highlight-note (overlay) "Temporarily highlight a compiler note's overlay. @@ -2007,8 +2021,7 @@ (slime-eval-async `(swank:arglist-string ,symbol-name) (slime-buffer-package) - (lexical-let ((show-fn show-fn) - (symbol-name symbol-name)) + (with-lexical-bindings (show-fn symbol-name) (lambda (arglist) (if show-fn (funcall show-fn arglist) @@ -2103,24 +2116,51 @@ ;;; Completion +(defvar slime-completions-buffer-name "*Completions*") + (defvar slime-complete-saved-window-configuration nil - "Window configuration before we show the *Completions* buffer.") + "Window configuration before we show the *Completions* buffer.\n\ +This is buffer local in the buffer where the complition is +perfermed.") (defun slime-complete-maybe-save-window-configuration () - "Save the current window configuration, if there is no completion in -progress." + (make-local-variable 'slime-complete-saved-window-configuration) (unless slime-complete-saved-window-configuration (setq slime-complete-saved-window-configuration (current-window-configuration)))) +(defun slime-complete-delay-restoration () + (add-hook (make-local-variable 'pre-command-hook) + 'slime-complete-maybe-restore-window-confguration)) + +(defun slime-complete-forget-window-configuration () + (setq slime-complete-saved-window-configuration nil)) + (defun slime-complete-restore-window-configuration () - "Delete the *Completions* buffer and restore the window config if -available." - (when (get-buffer "*Completions*") - (kill-buffer "*Completions*")) + "Restore the window config if available." + (remove-hook (make-local-variable 'pre-command-hook) + 'slime-complete-maybe-restore-window-confguration) (when slime-complete-saved-window-configuration (set-window-configuration slime-complete-saved-window-configuration) - (setq slime-complete-saved-window-configuration nil))) + (setq slime-complete-saved-window-configuration nil)) + (when (get-buffer slime-completions-buffer-name) + (bury-buffer slime-completions-buffer-name))) + +(defun slime-complete-maybe-restore-window-confguration () + "Restore the window configuration, if the following command +terminates a current completion." + (remove-hook (make-local-variable 'pre-command-hook) + 'slime-complete-maybe-restore-window-confguration) + (cond ((find last-command-char "()\"'`,# \r\n:") + (slime-complete-restore-window-configuration)) + ((memq this-command '(self-insert-command + slime-complete-symbol + backward-delete-char-untabify + backward-delete-char + scroll-other-window)) + (slime-complete-delay-restoration)) + (t + (slime-complete-forget-window-configuration)))) (defun slime-complete-symbol () "Complete the symbol at point. @@ -2145,44 +2185,18 @@ ((not (string= prefix completion)) (delete-region beg end) (insert-and-inherit completion) - (if (null (cdr completions)) - (slime-restore-window-configuration) - (slime-complete-delay-restoration))) + (cond ((null (cdr completions)) + (slime-complete-restore-window-configuration)) + (t (slime-complete-delay-restoration)))) (t (message "Making completion list...") - (slime-complete-maybe-save-window-configuration) (let ((list (all-completions prefix completions-alist nil))) + (slime-complete-maybe-save-window-configuration) (slime-with-output-to-temp-buffer "*Completions*" - (display-completion-list list)) + (display-completion-list list)) (slime-complete-delay-restoration)) (message "Making completion list...done"))))) -(defun slime-complete-delay-restoration () - "Install a pre-command-hook that will restore the window -configuration if possible." - (add-hook (make-local-variable 'pre-command-hook) - 'slime-complete-maybe-restore-window-confguration)) - -(defun slime-complete-forget-window-configuration () - (remove-hook 'pre-command-hook - 'slime-complete-maybe-restore-window-confguration) - (setq slime-complete-saved-window-configuration nil)) - -(defun slime-complete-maybe-restore-window-confguration () - "Restore the window configuration, if the following command -terminates a current completion." - (cond ((find last-command-char "()\"'`,# \r\n:") - (slime-complete-restore-window-configuration) - (slime-complete-forget-window-configuration)) - ((memq this-command '(self-insert-command - slime-complete-symbol - backward-delete-char-untabify - backward-delete-char - scroll-other-window)) - ;; keep going - ) - (t (slime-complete-forget-window-configuration)))) - (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 @@ -2349,16 +2363,20 @@ (defun slime-display-buffer-region (buffer start end &optional other-window) "Like `display-buffer', but only display the specified region." - (with-current-buffer buffer - (save-excursion - (save-restriction - (goto-char start) - (beginning-of-line) - (narrow-to-region (point) end) - (let ((window (display-buffer buffer other-window))) - (set-window-start window (point)) - (shrink-window-if-larger-than-buffer window) - window))))) + (let ((window-min-height 1)) + (with-current-buffer buffer + (save-excursion + (save-restriction + (goto-char start) + (beginning-of-line) + (narrow-to-region (point) end) + (let ((window (display-buffer buffer other-window))) + (set-window-start window (point)) + (unless (or (one-window-p t) + (/= (frame-width) (window-width))) + (set-window-text-height window (/ (1- (frame-height)) 2))) + (shrink-window-if-larger-than-buffer window) + window)))))) (defun slime-show-evaluation-result (value) (slime-show-last-output) @@ -2524,7 +2542,12 @@ (:function "Function" swank:describe-function) (:setf "Setf" swank:describe-setf-function) (:type "Type" swank:describe-type) - (:class "Class" swank:describe-class)) + (:class "Class" swank:describe-class) + (:alien-type "Alien type" swank:describe-alien-type) + (:alien-struct "Alien struct" swank:describe-alien-struct) + (:alien-union "Alien type" swank:describe-alien-union) + (:alien-enum "Alien enum" swank:describe-alien-enum) + ) do (let ((value (plist-get plist prop)) (start (point))) @@ -2728,19 +2751,19 @@ (slime-save-window-configuration))) (defun slime-select-function (function-names package) - (cond ((null function-names) - (message "No callers")) - (t - (lexical-let ((function-names function-names) - (package package)) - (slime-select function-names - (lambda (index) - (slime-eval-async - `(swank:function-source-location-for-emacs - ,(nth index function-names)) - package - #'slime-carefully-show-source-location)) - (lambda (index))))))) + (if (null function-names) + (message "No callers") + (with-lexical-bindings (function-names package) + (slime-select + function-names + (lambda (index) + (slime-eval-async `(swank:function-source-location-for-emacs + ,(nth index function-names)) + package + (lambda (loc) + (let ((pop-up-windows nil)) + (slime-carefully-show-source-location loc))))) + (lambda (index)))))) (defun slime-carefully-show-source-location (location) (condition-case e @@ -3399,7 +3422,9 @@ (interactive) (message "Select [%s]: " (apply #'string (mapcar #'car slime-selector-methods))) - (let* ((ch (read-char)) + (let* ((ch (save-window-excursion + (select-window (minibuffer-window)) + (read-char))) (method (find ch slime-selector-methods :key #'car))) (cond ((null method) (message "No method for character: ?\\%c" ch) From heller at common-lisp.net Sat Nov 8 00:39:31 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 07 Nov 2003 19:39:31 -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-serv19349 Modified Files: swank-cmucl.lisp Log Message: (briefly-describe-symbol-for-emacs): Add support for alien-types. (describe-alien-type, %describe-alien, describe-alien-struct, describe-alien-union, describe-alien-enum): New functions. (source-path-file-position): Read the entire expression with special readtable. The readtable records source positions for each read sub-expression in a hashtable. Extract the subexpression for the source path from the read object and lookup the subexpression in the hashtable to find its source position. (read-and-record-source-map, make-source-recorder, make-source-recording-readtable, make-source-map, *source-map*, lookup-recording-readtable, source-path-stream-position, find-path-in-form, find-form-in-source-map) New functions. Date: Fri Nov 7 19:39:31 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.17 slime/swank-cmucl.lisp:1.18 --- slime/swank-cmucl.lisp:1.17 Mon Nov 3 18:22:41 2003 +++ slime/swank-cmucl.lisp Fri Nov 7 19:39:31 2003 @@ -75,6 +75,7 @@ (index 0 :type kernel:index)) (defun sis/in (stream eof-errorp eof-value) + (declare (ignore eof-errorp eof-value)) (let ((index (sis.index stream)) (buffer (sis.buffer stream))) (when (= index (length buffer)) @@ -407,6 +408,7 @@ receives the object and it's size as arguments. SPACES should be a list of the symbols :dynamic, :static, or :read-only." (dolist (space spaces) + (declare (inline vm::map-allocated-objects)) (vm::map-allocated-objects (lambda (obj header size) (when (= vm:code-header-type header) @@ -455,6 +457,7 @@ (defslimefun list-callers (symbol-name) (stringify-function-name-list (function-callers (from-string symbol-name)))) + (defslimefun list-callees (symbol-name) (stringify-function-name-list (function-callees (from-string symbol-name)))) @@ -487,12 +490,11 @@ (flet ((find-layout (function) (sys:find-if-in-closure (lambda (x) - (cond ((kernel::layout-p x) - (return-from find-layout x)) - ((di::indirect-value-cell-p x) - (let ((value (c:value-cell-ref x))) - (when (kernel::layout-p value) - (return-from find-layout value)))))) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) function))) (kernel:layout-info (find-layout function)))) @@ -573,6 +575,18 @@ (maybe-push :class (if (find-class symbol nil) (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) (if result (list* :designator (to-string symbol) result))))) @@ -588,6 +602,31 @@ (defslimefun describe-class (symbol-name) (print-description-to-string (find-class (from-string symbol-name) nil))) +(defslimefun describe-alien-type (symbol-name) + (let ((name (from-string symbol-name))) + (ecase (ext:info :alien-type :kind name) + (:primitive + (print-description-to-string + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator name) (list name))))) + ((:defined) + (print-description-to-string (ext:info :alien-type :definition name))) + (:unknown + (format nil "Unkown alien type: ~A" symbol-name))))) + +(defmacro %describe-alien (symbol-name namespace) + `(print-description-to-string + (ext:info :alien-type ,namespace (from-string ,symbol-name)))) + +(defslimefun describe-alien-struct (symbol-name) + (%describe-alien symbol-name :struct)) + +(defslimefun describe-alien-union (symbol-name) + (%describe-alien symbol-name :union)) + +(defslimefun describe-alien-enum (symbol-name) + (%describe-alien symbol-name :enum)) + ;;; Macroexpansion (defslimefun swank-macroexpand-all (string) @@ -703,13 +742,80 @@ (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)))) + (with-open-file (file filename) + (source-path-stream-position path file))) + +(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*)) + (*read-suppress* t)) + (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 (toplevel-number . path) path + (dotimes (i toplevel-number) + (let ((*read-suppress* t)) (read stream))) + (multiple-value-bind (form source-map) (read-and-record-source-map stream) + (find-form-in-source-map (find-path-in-form (cons 0 path) (list form)) + source-map)))) + +(defun find-path-in-form (path form) + "Return the subform of FORM corresponding to the source-path PATH." + (loop for f = form then (nth n f) + for n in path + finally (return f))) + +(defun find-form-in-source-map (form source-map) + "Return FORM's start position in SOURCE-MAP." + (let ((positions (gethash form source-map))) + (assert (= (length positions) 1)) + (car (first positions)))) (defun debug-source-info-from-emacs-buffer-p (debug-source) (let ((info (c::debug-source-info debug-source))) From heller at common-lisp.net Sat Nov 8 00:40:28 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 07 Nov 2003 19:40:28 -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-serv19726 Modified Files: swank-sbcl.lisp Log Message: (swank-macroexpand-all): Implemented. Date: Fri Nov 7 19:40:28 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.20 slime/swank-sbcl.lisp:1.21 --- slime/swank-sbcl.lisp:1.20 Tue Nov 4 03:03:20 2003 +++ slime/swank-sbcl.lisp Fri Nov 7 19:40:27 2003 @@ -193,9 +193,6 @@ (setf fill-pointer 0)))) nil) -(defun make-slime-output-stream () - (make-instance 'slime-output-stream)) - (defclass slime-input-stream (sb-gray:fundamental-character-input-stream) ((buffer :initform "") (index :initform 0))) @@ -463,7 +460,12 @@ ;;; macroexpansion -(defslimefun-unimplemented swank-macroexpand-all (string)) +(defun sbcl-macroexpand-all (form) + (let ((sb-walker:*walk-form-expand-macros-p* t)) + (sb-walker:walk-form form))) + +(defslimefun swank-macroexpand-all (string) + (apply-macro-expander #'sbcl-macroexpand-all string)) ;;; From heller at common-lisp.net Sat Nov 8 00:47:04 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 07 Nov 2003 19:47:04 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21846 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Nov 7 19:47:04 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.84 slime/ChangeLog:1.85 --- slime/ChangeLog:1.84 Thu Nov 6 03:55:02 2003 +++ slime/ChangeLog Fri Nov 7 19:47:03 2003 @@ -1,3 +1,27 @@ +2003-11-08 Helmut Eller + + * slime/slime.el (slime-buffer-package): Try to find be the + package name before resorting to slime-buffer-package. Return nil + and not "CL-USER" if the package cannot be determined. + (slime-goto-location): Insert notes with a source path, but + without filename or buffername, at point. This can happen for + warnings during macro expansion. (The macro expander is a + interpreted function and doesn't have a filename or buffername.) + (slime-show-note): Display 2 double quotes "" in the echo area for + zero length messages. SERIES tends to signal warnings with zero + length messages. + (slime-print-apropos): Add support for alien types. + + * swank-cmucl.lisp (briefly-describe-symbol-for-emacs): Add + support for alien types. + (source-path-file-position): Read the entire expression with a + special readtable. The readtable records source positions for + each sub-expression in a hashtable. Extract the sub-expression + for the source path from the read object and lookup the + sub-expression in the hashtable to find its source position. + + * swank-sbcl.lisp (swank-macroexpand-all): Implemented. + 2003-11-06 Luke Gorrie * slime.el (slime-autodoc-mode): When non-nil, display the From heller at common-lisp.net Sat Nov 8 08:34:12 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 08 Nov 2003 03:34:12 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16303 Modified Files: slime.el Log Message: Remove the non-working face inheriting stuff. Hardcode colors for slime-highlight-face and specify the :inherit attribute for slime-repl-output-face. So Emacs21 will do the right thing and the others get at least a customizable face. Date: Sat Nov 8 03:34:12 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.82 slime/slime.el:1.83 --- slime/slime.el:1.82 Fri Nov 7 19:32:50 2003 +++ slime/slime.el Sat Nov 8 03:34:12 2003 @@ -162,40 +162,22 @@ "Face for notes from the compiler." :group 'slime) -;; XEmacs and Emacs20 don't support the :inherit attribute in defface. -;; We copy the most important attributes manually. - -(defun slime-color-name (color) - (cond ((featurep 'xemacs) (color-name color)) - (t color))) - -(defun slime-face-bold-p (face) - (cond ((featurep 'xemacs) (custom-face-bold face)) - (t (face-bold-p face)))) - -(defun slime-face-font-name (face) - (cond ((featurep 'xemacs) (face-font-name face)) - (t (face-font face)))) - -(defun slime-face-attributes (face) - (list :foreground (slime-color-name (face-foreground face)) - :background (slime-color-name (face-background face)) - :underline (face-underline-p face) - :bold (slime-face-bold-p face) - :font (slime-face-font-name face))) - (defface slime-highlight-face - `((t ,(slime-face-attributes 'highlight))) + `((((class color) (background light)) + (:background "darkseagreen2")) + (((class color) (background dark)) + (:background "darkolivegreen")) + (t (:inverse-video t))) "Face for compiler notes while selected." :group 'slime) (defface slime-repl-output-face - `((t ,(slime-face-attributes 'font-lock-string-face))) + `((t (:inherit font-lock-string-face))) "Face for Lisp output in the SLIME REPL." :group 'slime) (defface slime-repl-input-face - `((t ,(slime-face-attributes 'bold))) + `((t (:inherit bold :bold t))) "Face for previous input in the SLIME REPL." :group 'slime) From heller at common-lisp.net Sat Nov 8 09:11:38 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 08 Nov 2003 04:11:38 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30365 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Nov 8 04:11:38 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.85 slime/ChangeLog:1.86 --- slime/ChangeLog:1.85 Fri Nov 7 19:47:03 2003 +++ slime/ChangeLog Sat Nov 8 04:11:38 2003 @@ -1,6 +1,11 @@ 2003-11-08 Helmut Eller - * slime/slime.el (slime-buffer-package): Try to find be the + * slime.el: Remove the non-working face inheriting stuff. + Hardcode colors for slime-highlight-face and specify the :inherit + attribute for slime-repl-output-face. So Emacs21 will do the + right thing and the others get at least a customizable face. + + * slime.el (slime-buffer-package): Try to find be the package name before resorting to slime-buffer-package. Return nil and not "CL-USER" if the package cannot be determined. (slime-goto-location): Insert notes with a source path, but From heller at common-lisp.net Sat Nov 8 16:51:29 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 08 Nov 2003 11:51: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-serv8815 Modified Files: slime.el Log Message: (slime-repl-return): Only send the current input to Lisp if it is a complete expression, like inferior-slime-return. (slime-input-complete-p): New function. (inferior-slime-return): Use it. Date: Sat Nov 8 11:51:29 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.83 slime/slime.el:1.84 --- slime/slime.el:1.83 Sat Nov 8 03:34:12 2003 +++ slime/slime.el Sat Nov 8 11:51:29 2003 @@ -286,18 +286,25 @@ (narrow-to-region indent-start (point-max))) (lisp-indent-line))) -(defun inferior-slime-input-complete-p () - "Return true if the input is complete in the inferior lisp buffer." +(defun slime-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." (ignore-errors (save-excursion - (goto-char (process-mark (get-buffer-process (current-buffer)))) - ;; Keep stepping over blanks and sexps until the end of buffer - ;; is reached or an error occurs - (loop do (or (skip-chars-forward " \t\r\n") - (looking-at ")")) ; tollerate extra close parens - until (eobp) - do (slime-forward-sexp)) - t))) + (save-restriction + (narrow-to-region start end) + (goto-char start) + ;; Keep stepping over blanks and sexps until the end of buffer + ;; is reached or an error occurs + (loop do (or (skip-chars-forward " \t\r\n") + (looking-at ")")) ; tollerate extra close parens + until (eobp) + do (slime-forward-sexp)) + t)))) + +(defun inferior-slime-input-complete-p () + "Return true if the input is complete in the inferior lisp buffer." + (slime-input-complete-p (process-mark (get-buffer-process (current-buffer))) + (point-max))) (defun inferior-slime-closing-return () "Send the current expression to Lisp after closing any open lists." @@ -1351,6 +1358,8 @@ (setq major-mode 'slime-repl-mode) (use-local-map slime-repl-mode-map) (lisp-mode-variables t) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function) (setq font-lock-defaults nil) (setq mode-name "REPL") (set (make-local-variable 'scroll-conservatively) 20) @@ -1429,11 +1438,24 @@ (beginning-of-line 1))) (defun slime-repl-return () - "Evaluate the current input string." + "Evaluate the current input string, or insert a newline. +Send the current input ony if a whole expression has been entered, +i.e. the parenthesis are matched. + +With prefix argument send the input even if the parenthesis are not +balanced." (interactive) (unless (or (slime-idle-p) (slime-reading-p)) - (error "Lisp is not ready for request from the REPL.")) + (error "Lisp is not ready for requests from the REPL.")) + (if (or current-prefix-arg + (slime-input-complete-p slime-repl-input-start-mark + slime-repl-input-end-mark)) + (slime-repl-send-input) + (slime-repl-newline-and-indent))) + +(defun slime-repl-send-input () + "Goto to the end of the input and send the current input." (let ((input (slime-repl-current-input))) (goto-char slime-repl-input-end-mark) (slime-repl-maybe-insert-output-separator) From heller at common-lisp.net Sat Nov 8 16:59:38 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 08 Nov 2003 11:59:38 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11994 Modified Files: swank.lisp Log Message: (completions): Use *buffer-package* if no other package is given. (case-convert): Only accept strings as argument. Date: Sat Nov 8 11:59:38 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.55 slime/swank.lisp:1.56 --- slime/swank.lisp:1.55 Tue Nov 4 17:33:31 2003 +++ slime/swank.lisp Sat Nov 8 11:59:38 2003 @@ -377,6 +377,7 @@ (defun case-convert (string) "Convert STRING according to the current readtable-case." + (check-type string string) (ecase (readtable-case *readtable*) (:upcase (string-upcase string)) (:downcase (string-downcase string)) @@ -401,11 +402,11 @@ (multiple-value-bind (name package-name internal-p) (parse-symbol-designator string) (let ((completions nil) - (package (find-package - (case-convert - (cond ((equal package-name "") "KEYWORD") - (package-name) - (default-package-name)))))) + (package (let ((n (cond ((equal package-name "") "KEYWORD") + (t (or package-name default-package-name))))) + (if n + (find-package (case-convert n)) + *buffer-package* )))) (flet ((symbol-matches-p (symbol) (and (string-prefix-p name (symbol-name symbol)) (or (or internal-p (null package-name)) From heller at common-lisp.net Sat Nov 8 17:01:26 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 08 Nov 2003 12:01:26 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12806 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Nov 8 12:01:26 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.86 slime/ChangeLog:1.87 --- slime/ChangeLog:1.86 Sat Nov 8 04:11:38 2003 +++ slime/ChangeLog Sat Nov 8 12:01:26 2003 @@ -1,5 +1,11 @@ 2003-11-08 Helmut Eller + * slime.el (slime-repl-return): Only send the current input to + Lisp if it is a complete expression, like inferior-slime-return. + + * swank.lisp (completions): Use *buffer-package* if no other + package is given. + * slime.el: Remove the non-working face inheriting stuff. Hardcode colors for slime-highlight-face and specify the :inherit attribute for slime-repl-output-face. So Emacs21 will do the From heller at common-lisp.net Sat Nov 8 18:58:07 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 08 Nov 2003 13:58: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-serv23460 Modified Files: slime.el Log Message: slime-highlight-face: Use the :inherit attribute if possible. (slime-face-inheritance-possible-p): New function. Date: Sat Nov 8 13:58:06 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.84 slime/slime.el:1.85 --- slime/slime.el:1.84 Sat Nov 8 11:51:29 2003 +++ slime/slime.el Sat Nov 8 13:58:06 2003 @@ -162,12 +162,18 @@ "Face for notes from the compiler." :group 'slime) +(defun slime-face-inheritance-possible-p () + (assq :inherit custom-face-attributes)) + (defface slime-highlight-face - `((((class color) (background light)) - (:background "darkseagreen2")) - (((class color) (background dark)) - (:background "darkolivegreen")) - (t (:inverse-video t))) + (cond ((slime-face-inheritance-possible-p) + '((t (:inherit highlight :underline nil)))) + (t + '((((class color) (background light)) + (:background "darkseagreen2")) + (((class color) (background dark)) + (:background "darkolivegreen")) + (t (:inverse-video t))))) "Face for compiler notes while selected." :group 'slime) @@ -177,7 +183,7 @@ :group 'slime) (defface slime-repl-input-face - `((t (:inherit bold :bold t))) + '((t (:bold t))) "Face for previous input in the SLIME REPL." :group 'slime) From heller at common-lisp.net Sat Nov 8 18:59:21 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 08 Nov 2003 13:59:21 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24504 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Nov 8 13:59:21 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.87 slime/ChangeLog:1.88 --- slime/ChangeLog:1.87 Sat Nov 8 12:01:26 2003 +++ slime/ChangeLog Sat Nov 8 13:59:21 2003 @@ -1,5 +1,9 @@ 2003-11-08 Helmut Eller + * slime.el: slime-highlight-face: Use the :inherit attribute if + possible. + (slime-face-inheritance-possible-p): New function. + * slime.el (slime-repl-return): Only send the current input to Lisp if it is a complete expression, like inferior-slime-return. From lgorrie at common-lisp.net Mon Nov 10 19:44:15 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 10 Nov 2003 14:44:15 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31604 Modified Files: slime.el Log Message: (slime-post-command-hook): Inhibit unless (still) in slime-mode. Only call `slime-autodoc-post-command-hook' when `slime-autodoc-mode' is non-nil. (slime-setup-command-hooks): Use `make-local-hook' instead of `make-local-variable'. Date: Mon Nov 10 14:44:15 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.85 slime/slime.el:1.86 --- slime/slime.el:1.85 Sat Nov 8 13:58:06 2003 +++ slime/slime.el Mon Nov 10 14:44:15 2003 @@ -419,14 +419,16 @@ (setq slime-pre-command-actions nil)) (defun slime-post-command-hook () - (when (slime-connected-p) - (slime-process-available-input)) - (slime-autodoc-post-command-hook)) + (when slime-mode + (when (slime-connected-p) + (slime-process-available-input)) + (when slime-autodoc-mode + (slime-autodoc-post-command-hook)))) (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." - (make-local-variable 'pre-command-hook) - (make-local-variable 'post-command-hook) + (make-local-hook 'pre-command-hook) + (make-local-hook 'post-command-hook) (add-hook 'pre-command-hook 'slime-pre-command-hook) (add-hook 'post-command-hook 'slime-post-command-hook)) @@ -2114,9 +2116,7 @@ When `slime-autodoc-mode' is non-nil, print apropos information about the symbol at point if applicable." (assert slime-mode) - (unless (or (not slime-autodoc-mode) - (not (slime-connected-p)) - (slime-busy-p)) + (when (and (slime-connected-p) (not (slime-busy-p))) (condition-case err (slime-autodoc) (error From lgorrie at common-lisp.net Mon Nov 10 19:44:34 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 10 Nov 2003 14:44:34 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31664 Modified Files: ChangeLog Log Message: Date: Mon Nov 10 14:44:34 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.88 slime/ChangeLog:1.89 --- slime/ChangeLog:1.88 Sat Nov 8 13:59:21 2003 +++ slime/ChangeLog Mon Nov 10 14:44:33 2003 @@ -1,3 +1,11 @@ +2003-11-10 Luke Gorrie + + * slime.el (slime-post-command-hook): Inhibit unless (still) in + slime-mode. Only call `slime-autodoc-post-command-hook' when + `slime-autodoc-mode' is non-nil. + (slime-setup-command-hooks): Use `make-local-hook' instead of + `make-local-variable'. + 2003-11-08 Helmut Eller * slime.el: slime-highlight-face: Use the :inherit attribute if From lgorrie at common-lisp.net Wed Nov 12 23:51:31 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 12 Nov 2003 18:51: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-serv29503 Modified Files: slime.el Log Message: (slime-repl-previous-input, slime-repl-previous-input): When partial input has already been entered, the M-{p,n} REPL history commands only match lines that start with the already-entered prefix. This is comint-compatible behaviour which has been requested. The history commands also skip over line identical to the one already entered. (slime-complete-maybe-restore-window-confguration): Catch errors, so that we don't cause `pre-command-hook' to be killed. (slime-truncate-lines): If you set this to nil, slime won't set `truncate-lines' in buffers like sldb, apropos, etc. (slime-show-description): XEmacs portability: don't use `temp-buffer-show-hook'. (slime-inspect): Use `(slime-sexp-at-point)' as default inspection value (thanks Jan Rychter). Date: Wed Nov 12 18:51:30 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.86 slime/slime.el:1.87 --- slime/slime.el:1.86 Mon Nov 10 14:44:15 2003 +++ slime/slime.el Wed Nov 12 18:51:27 2003 @@ -113,6 +113,11 @@ "When true, don't prompt the user for input during startup. This is used for batch-mode testing.") +(defvar slime-truncate-lines t + "When true, set `truncate-lines' in certain popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings.") + ;;; Customize group @@ -576,6 +581,12 @@ (defun slime-message (fmt &rest args) (apply 'message fmt args))) +(defun slime-set-truncate-lines () + "Set `truncate-lines' in the current buffer if +`slime-truncate-lines' is non-nil." + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + (defun slime-defun-at-point () "Return the text of the defun at point." (save-excursion @@ -1349,6 +1360,7 @@ (defvar slime-repl-input-history '() "History list of strings read from the REPL buffer.") + (defvar slime-repl-input-history-position 0) (defvar slime-repl-mode-map) @@ -1500,47 +1512,53 @@ (slime-repl-delete-current-input) (insert-and-inherit string)) -(defun slime-repl-insert-from-history (fn) - (setq slime-repl-input-history-position - (funcall fn slime-repl-input-history-position)) - (slime-repl-replace-input - (nth slime-repl-input-history-position slime-repl-input-history))) + +;;;; History + +(defvar slime-repl-history-pattern nil + "The regexp most recently used for finding input history.") + +(defun slime-repl-history-replace (direction regexp) + "Replace the current input with the next line in DIRECTION matching REGEXP. +DIRECTION is 'forward' or 'backward' (in the history list)." + (let* ((step (ecase direction + (forward -1) + (backward 1))) + (history-pos0 slime-repl-input-history-position)) + (setq slime-repl-history-pattern regexp) + ;; Loop through the history list looking for a matching line + (loop for pos = (+ history-pos0 step) then (+ pos step) + while (and (<= 0 pos) + (< pos (length slime-repl-input-history))) + do (let ((string (nth pos slime-repl-input-history))) + (when (and (string-match regexp string) + (not (string= string (slime-repl-current-input)))) + (slime-repl-replace-input string) + (setq slime-repl-input-history-position pos) + (return))) + finally (message "End of history; no matching item")))) + +(defun slime-repl-matching-input-regexp () + (if (memq last-command + '(slime-repl-previous-input slime-repl-next-input)) + slime-repl-history-pattern + (concat "^" (regexp-quote (slime-repl-current-input))))) (defun slime-repl-previous-input () (interactive) - - (unless (< (1+ slime-repl-input-history-position) - (length slime-repl-input-history)) - (error "End of history; no preceding item")) - (slime-repl-insert-from-history #'1+)) + (slime-repl-history-replace 'backward (slime-repl-matching-input-regexp))) (defun slime-repl-next-input () (interactive) - (unless (plusp slime-repl-input-history-position) - (error "End of history; no next item")) - (slime-repl-insert-from-history #'1-)) - -(defun slime-repl-matching-input (prompt bound increment error) - (let* ((regexp (read-from-minibuffer prompt)) - (pos (position-if - (lambda (string) (string-match regexp string)) - slime-repl-input-history - bound (funcall increment slime-repl-input-history-position)))) - (unless pos (error error)) - (setq slime-repl-input-history-position pos) - (slime-repl-insert-from-history #'identity))) - -(defun slime-repl-previous-matching-input () - (interactive) - (slime-repl-matching-input "Previous element matching (regexp): " - :start #'1+ - "No earlier matching history item")) - -(defun slime-repl-next-matching-input () - (interactive) - (slime-repl-matching-input "Next element matching (regexp): " - :end #'1- - "No later matching history item")) + (slime-repl-history-replace 'forward (slime-repl-matching-input-regexp))) + +(defun slime-repl-previous-matching-input (regexp) + (interactive "sPrevious element matching (regexp): ") + (slime-repl-history-replace 'backward regexp)) + +(defun slime-repl-next-matching-input (regexp) + (interactive "sNext element matching (regexp): ") + (slime-repl-history-replace 'forward regexp)) (defun slime-repl () (interactive) @@ -2140,7 +2158,7 @@ (current-window-configuration)))) (defun slime-complete-delay-restoration () - (add-hook (make-local-variable 'pre-command-hook) + (add-hook (make-local 'pre-command-hook) 'slime-complete-maybe-restore-window-confguration)) (defun slime-complete-forget-window-configuration () @@ -2148,8 +2166,7 @@ (defun slime-complete-restore-window-configuration () "Restore the window config if available." - (remove-hook (make-local-variable 'pre-command-hook) - 'slime-complete-maybe-restore-window-confguration) + (remove-hook 'slime-complete-maybe-restore-window-confguration) (when slime-complete-saved-window-configuration (set-window-configuration slime-complete-saved-window-configuration) (setq slime-complete-saved-window-configuration nil)) @@ -2159,19 +2176,23 @@ (defun slime-complete-maybe-restore-window-confguration () "Restore the window configuration, if the following command terminates a current completion." - (remove-hook (make-local-variable 'pre-command-hook) - 'slime-complete-maybe-restore-window-confguration) - (cond ((find last-command-char "()\"'`,# \r\n:") - (slime-complete-restore-window-configuration)) - ((memq this-command '(self-insert-command - slime-complete-symbol - backward-delete-char-untabify + (remove-hook 'slime-complete-maybe-restore-window-confguration) + (condition-case err + (cond ((find last-command-char "()\"'`,# \r\n:") + (slime-complete-restore-window-configuration)) + ((memq this-command '(self-insert-command + slime-complete-symbol + backward-delete-char-untabify backward-delete-char scroll-other-window)) - (slime-complete-delay-restoration)) - (t - (slime-complete-forget-window-configuration)))) - + (slime-complete-delay-restoration)) + (t + (slime-complete-forget-window-configuration))) + (error + ;; Because this is called on the pre-command-hook, we mustn't let + ;; errors propagate. + (message "Error in slime-complete-forget-window-configuration: %S" err)))) + (defun slime-complete-symbol () "Complete the symbol at point. If the symbol lacks an explicit package prefix, the current buffer's @@ -2464,15 +2485,12 @@ (defun slime-show-description (string package) (slime-save-window-configuration) (save-current-buffer - (let* ((slime-package-for-help-mode package) - (temp-buffer-show-hook - (cons (lambda () - (setq slime-buffer-package slime-package-for-help-mode) - (set-syntax-table lisp-mode-syntax-table) - (slime-mode t)) - temp-buffer-show-hook))) - (slime-with-output-to-temp-buffer "*Help*" - (princ string))))) + (slime-with-output-to-temp-buffer "*Help*" + (princ string)) + (with-current-buffer "*Help*" + (setq slime-buffer-package package) + (set-syntax-table lisp-mode-syntax-table) + (slime-mode t)))) (defun slime-eval-describe (form) (let ((package (slime-buffer-package))) @@ -2518,7 +2536,7 @@ (set-syntax-table lisp-mode-syntax-table) (slime-mode t) (setq slime-buffer-package package) - (set (make-local-variable 'truncate-lines) t) + (slime-set-truncate-lines) (slime-print-apropos plists))))) (defun slime-princ-propertized (string props) @@ -2685,7 +2703,7 @@ (set-syntax-table lisp-mode-syntax-table) (slime-mode t) (setq slime-buffer-package package) - (set (make-local-variable 'truncate-lines) t) + (slime-set-truncate-lines) (setq slime-xref-summary (format " XREF[%s: %s]" ref-type symbol))) @@ -2933,7 +2951,7 @@ (with-current-buffer (get-buffer-create "*sldb*") (setq buffer-read-only nil) (sldb-mode) - (set (make-local-variable 'truncate-lines) t) + (slime-set-truncate-lines) (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) (setq sldb-condition condition) (setq sldb-restarts restarts) @@ -3332,13 +3350,13 @@ (defun slime-inspect (string) (interactive (list (slime-read-from-minibuffer "Inspect value (evaluated): " - (slime-last-expression)))) + (slime-sexp-at-point)))) (slime-eval-async `(swank:init-inspector ,string) (slime-buffer-package) 'slime-open-inspector)) (define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector" (set-syntax-table lisp-mode-syntax-table) - (set (make-local-variable 'truncate-lines) t) + (slime-set-truncate-lines) (slime-mode t) (setq buffer-read-only t)) @@ -3599,7 +3617,7 @@ (erase-buffer) (outline-mode) (set (make-local-variable 'outline-regexp) "\\*+") - (set (make-local-variable 'truncate-lines) t))) + (slime-set-truncate-lines))) (defun slime-delete-hidden-outline-text () "Delete the hidden parts of an outline-mode buffer." From lgorrie at common-lisp.net Wed Nov 12 23:51:57 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 12 Nov 2003 18:51:57 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29570 Modified Files: ChangeLog Log Message: Date: Wed Nov 12 18:51:52 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.89 slime/ChangeLog:1.90 --- slime/ChangeLog:1.89 Mon Nov 10 14:44:33 2003 +++ slime/ChangeLog Wed Nov 12 18:51:50 2003 @@ -1,3 +1,23 @@ +2003-11-13 Luke Gorrie + + * slime.el (slime-repl-previous-input, slime-repl-previous-input): + When partial input has already been entered, the M-{p,n} REPL + history commands only match lines that start with the + already-entered prefix. This is comint-compatible behaviour which + has been requested. The history commands also skip over line + identical to the one already entered. + (slime-complete-maybe-restore-window-confguration): Catch errors, + so that we don't cause `pre-command-hook' to be killed. + (slime-truncate-lines): If you set this to nil, slime won't set + `truncate-lines' in buffers like sldb, apropos, etc. + +2003-11-12 Luke Gorrie + + * slime.el (slime-show-description): XEmacs portability: don't use + `temp-buffer-show-hook'. + (slime-inspect): Use `(slime-sexp-at-point)' as default inspection + value (thanks Jan Rychter). + 2003-11-10 Luke Gorrie * slime.el (slime-post-command-hook): Inhibit unless (still) in From lgorrie at common-lisp.net Wed Nov 12 23:59:08 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 12 Nov 2003 18:59:08 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32725 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Nov 12 18:59:07 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.90 slime/ChangeLog:1.91 --- slime/ChangeLog:1.90 Wed Nov 12 18:51:50 2003 +++ slime/ChangeLog Wed Nov 12 18:59:06 2003 @@ -1,6 +1,6 @@ 2003-11-13 Luke Gorrie - * slime.el (slime-repl-previous-input, slime-repl-previous-input): + * slime.el (slime-repl-previous-input, slime-repl-next-input): When partial input has already been entered, the M-{p,n} REPL history commands only match lines that start with the already-entered prefix. This is comint-compatible behaviour which From heller at common-lisp.net Thu Nov 13 00:10:31 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 12 Nov 2003 19:10: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-serv7351 Modified Files: slime.el Log Message: (slime-goto-source-location): Reorganized. CMUCL now resolves all source-paths on the lisp side. The code is still ugly because the SBCL code is depends on it. (slime-edit-fdefinition, slime-show-source-location): Update callers. (slime-goto-location): Deleted. (slime-eval-feature-conditional): Support for NOT. (slime-connect): Make it useful without inferior lisp. (slime-process-available-input): Don't start the timer when there was a reader error. (slime-highlight-notes): slime-compiler-notes-for-file doesn't work yet. Date: Wed Nov 12 19:10:30 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.87 slime/slime.el:1.88 --- slime/slime.el:1.87 Wed Nov 12 18:51:27 2003 +++ slime/slime.el Wed Nov 12 19:10:30 2003 @@ -701,7 +701,7 @@ (slime-disconnect)) (slime-maybe-start-lisp) (setq slime-lisp-package slime-default-lisp-package) - (slime-connect)) + (slime-read-port-and-connect)) (defun slime-maybe-start-lisp () "Start an inferior lisp unless one is already running." @@ -731,7 +731,7 @@ (assert (integerp port)) port)))) -(defun slime-connect (&optional retries) +(defun slime-read-port-and-connect (&optional retries) "Connect to a running Swank server." (slime-start-swank-server) (lexical-let ((retries (or retries slime-swank-connection-retries)) @@ -752,12 +752,8 @@ (setq slime-startup-retry-timer nil) ; remove old timer (cond ((file-exists-p (slime-swank-port-file)) (let ((port (slime-read-swank-port))) - (message "Connecting to Swank on port %S.." port) (delete-file (slime-swank-port-file)) - (slime-net-connect "localhost" port) - (slime-init-connection) - (message "Connected to Swank server on port %S. %s" - port (slime-random-words-of-encouragement)))) + (slime-connect "localhost" port))) ((and retries (zerop retries)) (message "Failed to connect to Swank.")) (t @@ -766,6 +762,17 @@ (run-with-timer 1 nil #'attempt-connection)))))) (attempt-connection)))) +(defun slime-connect (host port) + "Connect to a running Swank server" + (interactive (list (read-from-minibuffer "Host: " "localhost") + (read-from-minibuffer "Port: " "4005" nil t))) + (message "Connecting to Swank on port %S.." port) + (slime-net-connect "localhost" port) + (slime-init-connection) + (message "Connected to Swank server on port %S. %s" + port (slime-random-words-of-encouragement))) + + (defun slime-disconnect () "Disconnect from the Swank server." (interactive) @@ -854,12 +861,15 @@ (defun slime-process-available-input () "Process all complete messages that have arrived from Lisp." (with-current-buffer (process-buffer slime-net-process) - (unwind-protect - (while (slime-net-have-input-p) - (save-current-buffer - (slime-dispatch-event (slime-net-read)))) - (when (slime-net-have-input-p) - (run-at-time 0 nil 'slime-process-available-input))))) + (let (reader-error) + (unwind-protect + (while (slime-net-have-input-p) + (setq reader-error t) + (let ((event (slime-net-read))) + (setq reader-error nil) + (save-current-buffer (slime-dispatch-event event)))) + (when (and (not reader-error) (slime-net-have-input-p)) + (run-at-time 0 nil 'slime-process-available-input)))))) (defun slime-net-have-input-p () "Return true if a complete message is available." @@ -1706,7 +1716,7 @@ (defun slime-highlight-notes (notes) "Highlight compiler notes, warnings, and errors in the buffer." - (interactive (list (slime-compiler-notes-for-file (buffer-file-name)))) + (interactive (list (slime-compiler-notes))) (save-excursion (slime-remove-old-overlays) (mapc #'slime-overlay-note notes))) @@ -1787,7 +1797,7 @@ "Choose the start and end points for an overlay over NOTE. If the location's sexp is a list spanning multiple lines, then the region around the first element is used." - (slime-goto-location note) + (slime-goto-source-location (getf note :location)) (let ((start (point))) (slime-forward-sexp) (if (slime-same-line-p start (point)) @@ -1845,51 +1855,57 @@ (beginning-of-sexp)) (error (goto-char origin))))) -(defun slime-goto-location (note) - "Move to the location fiven with the note NOTE. +(defun slime-goto-source-location (location) + "Move to the source location LOCATION. -NOTE's :position property contains the byte offset of the toplevel -form we are searching. NOTE's :source-path property the path to the -subexpression. NOTE's :function-name property indicates the name of -the function the note occurred in. - -A source-path is a list of the form (1 2 3 4), which indicates a -position in a file in terms of sexp positions. The first number -identifies the top-level form that contains the position that we wish -to move to: the first top-level form has number 0. The second number -in the source-path identifies the containing sexp within that -top-level form, etc." - (interactive) - (cond ((plist-get note :function-name) - (ignore-errors - (goto-char (point-min)) - (re-search-forward (format "^(def\\w+\\s +%s\\s +" - (plist-get note :function-name))) - (beginning-of-line))) - ((or (not (plist-get note :source-path)) - (and (not (plist-get note :filename)) - (not (plist-get note :buffername)) - (plist-get note :source-path))) - ;; no source-path available. hmm... move the the first sexp - (cond ((plist-get note :buffername) - (goto-char (plist-get note :buffer-offset))) - (t - (goto-char (point-min)))) - (forward-sexp) - (backward-sexp)) - ((stringp (plist-get note :filename)) - ;; Jump to the offset given with the :position property (and avoid - ;; most of the reader issues) - (goto-char (plist-get note ':position)) - ;; Drop the the toplevel form from the source-path and go the - ;; expression. - (slime-forward-positioned-source-path (plist-get note ':source-path))) - ((stringp (plist-get note :buffername)) - (assert (string= (buffer-name) (plist-get note :buffername))) - (goto-char (plist-get note :buffer-offset)) - (slime-forward-source-path (plist-get note ':source-path))) - (t - (error "Unsupported location type %s" note)))) +LOCATION is a plist and defines a position in a buffer. Several kinds +of locations are supported: + + (:file ,filename ,position) -- A position in a file. + (:emacs-buffer ,buffername ,position) -- A position in a buffer. + (:defintion-name ,name) -- A name of a definition. + (:null) -- A dummy. + (:error ,message) -- The location cannot be found. + (:sbcl &key " + (destructure-case location + ((:file filename position) + (set-buffer (find-file-noselect filename t)) + (goto-char position)) + ((:emacs-buffer buffer position) + (set-buffer buffer) + (goto-char position)) + ((:null) + (beginning-of-defun)) + ((:error message) + (error "Cannot locate source: %s" message)) + ((:openmcl &key function-name) + (ignore-errors + (goto-char (point-min)) + (re-search-forward (format "^(def\\w+\\s +%s\\s +" function-name) + (beginning-of-line)))) + ((:sbcl + &key from buffername buffer-offset + filename position info source-path path source-form function-name) + (cond (function-name + (ignore-errors + (goto-char (point-min)) + (re-search-forward (format "^(def\\w+\\s +%s\\s +" + function-name)) + (beginning-of-line))) + ((and (eq filename :lisp) (not buffername)) + (beginning-of-defun)) + (t + (cond (buffername + (set-buffer buffername) (goto-char buffer-offset)) + (filename + (set-buffer (find-file-noselect filename)) + (when position (goto-char position)))) + (cond (path + (slime-forward-source-path (cdr path))) + (source-path + (slime-forward-positioned-source-path source-path)) + (t + (forward-sexp) (backward-sexp)))))))) (defmacro slime-point-moves-p (&rest body) "Execute BODY and return true if the current buffer's point moved." @@ -1945,7 +1961,8 @@ (member* (symbol-name e) slime-lisp-features :test #'equalp) (funcall (ecase (car e) (and #'every) - (or #'some)) + (or #'some) + (not (lambda (f l) (not (apply f l))))) #'slime-eval-feature-conditional (cdr e)))) @@ -2378,6 +2395,7 @@ (slime-message "%s" (cadr source-location))) (t (slime-goto-source-location source-location) + (switch-to-buffer (current-buffer)) (ring-insert-at-beginning slime-find-definition-history-ring origin))))) @@ -3065,38 +3083,6 @@ (save-excursion (sldb-backward-frame) (sldb-frame-number-at-point))) - -(defun slime-goto-source-location (source-location &optional other-window) - (let ((error (plist-get source-location :error))) - (when error - (error "Cannot locate source: %s" error)) - (case (plist-get source-location :from) - (:file - (funcall (if other-window #'find-file-other-window #'find-file) - (plist-get source-location :filename)) - (goto-char (plist-get source-location :position)) - (forward-sexp) (backward-sexp) - t) - (:stream - (let ((info (plist-get source-location :info))) - (cond ((and (consp info) (eq :emacs-buffer (car info))) - (let ((buffer (plist-get info :emacs-buffer)) - (offset (plist-get info :emacs-buffer-offset))) - (funcall (if other-window - #'switch-to-buffer-other-window - #'switch-to-buffer) - (get-buffer buffer)) - (goto-char offset) - (slime-forward-source-path - (plist-get source-location :path))) - t) - (t - (error "Cannot locate source from stream: %s" - source-location))))) - (t - (slime-message "Source Form:\n%s" - (plist-get source-location :source-form)) - nil)))) (defun sldb-show-source () (interactive) @@ -3108,8 +3094,12 @@ (defun slime-show-source-location (source-location) (save-selected-window - (when (slime-goto-source-location source-location t) - (sldb-highlight-sexp)))) + (slime-goto-source-location source-location) + (sldb-highlight-sexp) + (display-buffer (current-buffer) t) + (save-excursion + (beginning-of-line -4) + (set-window-start (get-buffer-window (current-buffer)) (point))))) (defun sldb-frame-details-visible-p () (and (get-text-property (point) 'frame) @@ -3191,7 +3181,7 @@ (defun sldb-pprint-eval-in-frame (string) (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) (let* ((number (sldb-frame-number-at-point))) - (slime-eval-async `(swank:eval-string-in-frame ,string ,number) + (slime-eval-async `(swank:pprint-eval-string-in-frame ,string ,number) nil (lambda (result) (slime-show-description result nil))))) From heller at common-lisp.net Thu Nov 13 00:20:12 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 12 Nov 2003 19:20:12 -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-serv11278 Modified Files: swank-cmucl.lisp Log Message: Do the source-path -> byte-offset translation on the Lisp side. (make-compiler-note, resolve-location): New functions. *swank-source-info*: New variable. (code-location-file-position): Only read the source once. (We used CMUCL's get-translations, which also reads the file.) (source-location-for-emacs): Cleanups. (map-allocated-code-components): Inline vm::map-allocated-objects and declare the SIZE as fixnum to avoid excessive consing. (sos/out): Fix off-by-one bug. Date: Wed Nov 12 19:20:10 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.18 slime/swank-cmucl.lisp:1.19 --- slime/swank-cmucl.lisp:1.18 Fri Nov 7 19:39:31 2003 +++ slime/swank-cmucl.lisp Wed Nov 12 19:20:06 2003 @@ -13,7 +13,7 @@ (let ((flags (fcntl fd unix:F-GETFL 0))) (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))) -(set-fd-non-blocking (sys:fd-stream-fd sys:*stdin*)) +;; (set-fd-non-blocking (sys:fd-stream-fd sys:*stdin*)) (setf c:*record-xref-info* t) ;;; TCP Server. @@ -42,7 +42,7 @@ (cond ((char= #\newline char) (force-output stream) (setf (sos.column stream) 0)) - ((= index (length buffer)) + ((= index (1- (length buffer))) (force-output stream)))) char) @@ -155,10 +155,21 @@ ;;;; Compilation Commands -(defvar *buffername*) -(defvar *buffer-offset*) +(defvar *swank-source-info* nil + "Bound to a SOURCE-INFO object during compilation.") -(defun handle-notification-condition (condition) +(defclass source-info () () + (:documentation "Some info about the current compilatoin unit.")) + +(defclass file-source-info (source-info) + ((filename :initarg :filename))) + +(defclass buffer-source-info (source-info) + ((buffer :initarg :buffer) + (start-offset :initarg :start-offset) + (string :initarg :string))) + +(defun handle-compiler-condition (condition) "Handle a condition caused by a compiler warning. This traps all compiler conditions at a lower-level than using C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to @@ -168,39 +179,46 @@ (let ((context (or (c::find-error-context nil) *previous-context*))) (setq *previous-compiler-condition* condition) (setq *previous-context* context) - (let ((note (if context - (compiler-note-for-emacs condition context) - (minimal-compiler-note-for-emacs condition)))) - (push note *compiler-notes*) - (when *compile-file-truename* - (push note (gethash (namestring *compile-file-truename*) - *notes-database*))))))) - -(defun compiler-note-for-emacs (condition context) - (let* ((file-name (c::compiler-error-context-file-name context)) - (file-position (c::compiler-error-context-file-position context)) - (file (if (typep file-name 'pathname) - (unix-truename file-name) - file-name))) - (list - :position file-position - :filename (and (stringp file) file) - :source-path (current-compiler-error-source-path context) - :severity (severity-for-emacs condition) - :message (brief-compiler-message-for-emacs condition context) - :buffername (if (boundp '*buffername*) *buffername*) - :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*)))) - -(defun minimal-compiler-note-for-emacs (condition) - "Return compiler note with only minimal context information." - (list :position 0 - :filename (if *compile-file-truename* - (namestring *compile-file-truename*)) - :source-path nil + (let ((note (make-compiler-note condition context))) + (push note *compiler-notes*))))) + +(defun make-compiler-note (condition context) + (list :message (brief-compiler-message-for-emacs condition context) :severity (severity-for-emacs condition) - :message (princ-to-string condition) - :buffername (if (boundp '*buffername*) *buffername*) - :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*))) + :location + (cond (context + (let ((cx context)) + (resolve-location + *swank-source-info* + (c::compiler-error-context-file-name cx) + (c::compiler-error-context-file-position cx) + (reverse (c::compiler-error-context-original-source-path cx)) + (c::compiler-error-context-original-source cx)))) + (t + (resolve-location *swank-source-info* nil nil nil nil))))) + +(defgeneric resolve-location (source-info + file-name file-position + source-path source)) + +(defmethod resolve-location (i (f pathname) position path source) + `(:file ,(unix-truename f) ,(source-path-file-position path f))) + +(defmethod resolve-location ((i buffer-source-info) (f (eql :stream)) + position path source) + (with-slots (buffer start-offset string) i + `(:emacs-buffer + ,buffer + ,(+ start-offset (source-path-string-position path string))))) + +(defmethod resolve-location (i (f (eql :lisp)) position path source) + '(:null)) + +(defmethod resolve-location (i (f (eql nil)) + (pos (eql nil)) + (path (eql nil)) + (source (eql nil))) + '(:null)) (defun severity-for-emacs (condition) (etypecase condition @@ -213,8 +231,10 @@ 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 c::compiler-error-context error-context)) - (let ((enclosing (c::compiler-error-context-enclosing-source error-context))) + (declare (type (or c::compiler-error-context null) error-context)) + (let ((enclosing (and error-context + (c::compiler-error-context-enclosing-source + error-context)))) (if enclosing (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition) (format nil "~A" condition)))) @@ -231,9 +251,9 @@ (c::compiler-error-context-original-source-path context))))) (defun call-trapping-compilation-notes (fn) - (handler-bind ((c::compiler-error #'handle-notification-condition) - (c::style-warning #'handle-notification-condition) - (c::warning #'handle-notification-condition)) + (handler-bind ((c::compiler-error #'handle-compiler-condition) + (c::style-warning #'handle-compiler-condition) + (c::warning #'handle-compiler-condition)) (funcall fn))) (defslimefun swank-compile-file (filename load) @@ -241,21 +261,24 @@ (lambda () (clear-note-database filename) (clear-xref-info filename) - (let ((*buffername* nil) - (*buffer-offset* nil)) + (let ((*swank-source-info* (make-instance 'file-source-info + :filename filename))) (compile-file filename :load load))))) (defslimefun swank-compile-string (string buffer start) (call-with-compilation-hooks (lambda () (let ((*package* *buffer-package*) - (*buffername* buffer) - (*buffer-offset* start)) + (*swank-source-info* (make-instance 'buffer-source-info + :buffer buffer + :start-offset start + :string string))) (with-input-from-string (stream string) (ext:compile-from-stream stream :source-info `(:emacs-buffer ,buffer - :emacs-buffer-offset ,start))))))) + :emacs-buffer-offset ,start + :emacs-buffer-string ,string))))))) (defun clear-xref-info (namestring) "Clear XREF notes pertaining to FILENAME. @@ -270,9 +293,10 @@ xref::*who-sets*)) (maphash (lambda (target contexts) (setf (gethash target db) - (delete-if (lambda (ctx) - (xref-context-derived-from-p ctx filename)) - contexts))) + (delete-if + (lambda (ctx) + (xref-context-derived-from-p ctx filename)) + contexts))) db))))) (defun xref-context-derived-from-p (context filename) @@ -402,28 +426,29 @@ callees)))) callees)) -(declaim (inline map-allocated-code-components)) +(declaim (ext:maybe-inline map-allocated-code-components)) (defun map-allocated-code-components (spaces fn) "Call FN for each allocated code component in one of SPACES. FN -receives the object and it's size as arguments. SPACES should be a -list of the symbols :dynamic, :static, or :read-only." +receives the object as argument. SPACES should be a list of the +symbols :dynamic, :static, or :read-only." (dolist (space spaces) (declare (inline vm::map-allocated-objects)) (vm::map-allocated-objects (lambda (obj header size) + (declare (type fixnum size) (ignore size)) (when (= vm:code-header-type header) - (funcall fn obj size))) + (funcall fn obj))) space))) -(declaim (inline map-caller-code-components)) +(declaim (ext:maybe-inline map-caller-code-components)) (defun map-caller-code-components (function spaces fn) "Call FN for each code component with a fdefn for FUNCTION in its constant pool." (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) (map-allocated-code-components spaces - (lambda (obj size) - (declare (ignore size)) + (lambda (obj) (map-code-constants obj (lambda (constant) @@ -436,6 +461,7 @@ :dynamic))) "Return FUNCTION's callers as a list of names." (let ((referrers '())) + (declare (inline map-caller-code-components)) (map-caller-code-components function spaces @@ -647,6 +673,168 @@ (t (debug::trace-1 fname (debug::make-trace-info)) (format nil "~S is now traced." fname))))) + +;;; Source-path business + +;; 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 positions + finally (destructuring-bind ((start . end)) positions + (return (values (1- start) end)))))) + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location)) + (*read-suppress* t)) + (dotimes (i tlf-offset) (read stream)) + (multiple-value-bind (tlf position-map) (read-and-record-source-map stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path (reverse (cdr (aref path-table form-number))))) + (source-path-source-position source-path tlf position-map))))) + +(defun code-location-string-offset (code-location string) + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + +(defun code-location-file-position (code-location filename) + (with-open-file (s filename :direction :input) + (code-location-stream-position code-location s))) + +(defun make-file-location (pathname code-location) + (list :file + (unix-truename pathname) + (1+ (code-location-file-position code-location pathname)))) + +(defun make-buffer-location (buffer start string code-location) + (list :emacs-buffer + buffer + (+ 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 + (consp info) + (eq :emacs-buffer (car info))))) + +(defun source-location-for-emacs (code-location) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file (make-file-location name code-location)) + (: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))) + (:lisp + `(:sexp , (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))))))) + +(defun safe-source-location-for-emacs (code-location) + (handler-case (source-location-for-emacs code-location) + (t (c) (list :error (debug::safe-condition-message c))))) ;;; Debugging @@ -727,130 +915,14 @@ (format-restarts-for-emacs) (backtrace-for-emacs start end))) -(defun code-location-source-path (code-location) - (let* ((location (debug::maybe-block-start-location code-location)) - (form-num (di:code-location-form-number location))) - (let ((translations (debug::get-top-level-form location))) - (unless (< form-num (length translations)) - (error "Source path no longer exists.")) - (reverse (cdr (svref translations form-num)))))) - -(defun code-location-file-position (code-location) - (let* ((debug-source (di:code-location-debug-source code-location)) - (filename (di:debug-source-name debug-source)) - (path (code-location-source-path code-location))) - (source-path-file-position path filename))) - -(defun source-path-file-position (path filename) - (with-open-file (file filename) - (source-path-stream-position path file))) - -(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*)) - (*read-suppress* t)) - (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 (toplevel-number . path) path - (dotimes (i toplevel-number) - (let ((*read-suppress* t)) (read stream))) - (multiple-value-bind (form source-map) (read-and-record-source-map stream) - (find-form-in-source-map (find-path-in-form (cons 0 path) (list form)) - source-map)))) - -(defun find-path-in-form (path form) - "Return the subform of FORM corresponding to the source-path PATH." - (loop for f = form then (nth n f) - for n in path - finally (return f))) - -(defun find-form-in-source-map (form source-map) - "Return FORM's start position in SOURCE-MAP." - (let ((positions (gethash form source-map))) - (assert (= (length positions) 1)) - (car (first positions)))) - -(defun debug-source-info-from-emacs-buffer-p (debug-source) - (let ((info (c::debug-source-info debug-source))) - (and info - (consp info) - (eq :emacs-buffer (car info))))) - -(defun source-location-for-emacs (code-location) - (let* ((debug-source (di:code-location-debug-source code-location)) - (from (di:debug-source-from debug-source)) - (name (di:debug-source-name debug-source))) - (list - :from from - :filename (if (eq from :file) - (ext:unix-namestring (truename name))) - :position (if (eq from :file) - (code-location-file-position code-location)) - :info (and (debug-source-info-from-emacs-buffer-p debug-source) - (c::debug-source-info debug-source)) - :path (code-location-source-path code-location) - :source-form - (unless (or (eq from :file) - (debug-source-info-from-emacs-buffer-p debug-source)) - (with-output-to-string (*standard-output*) - (debug::print-code-location-source-form code-location 100 t)))))) - -(defun safe-source-location-for-emacs (code-location) - (handler-case (source-location-for-emacs code-location) - (t (c) (list :error (debug::safe-condition-message c))))) - (defslimefun frame-source-location-for-emacs (index) (safe-source-location-for-emacs (di:frame-code-location (nth-frame index)))) (defslimefun eval-string-in-frame (string index) (to-string (di:eval-in-frame (nth-frame index) (from-string string)))) + +(defslimefun pprint-eval-string-in-frame (string index) + (swank-pprint (di:eval-in-frame (nth-frame index) (from-string string)))) (defslimefun inspect-in-frame (string index) (reset-inspector) From heller at common-lisp.net Thu Nov 13 00:22:03 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 12 Nov 2003 19:22:03 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11932 Modified Files: swank.lisp Log Message: (swank-pprint): New function. Date: Wed Nov 12 19:22:03 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.56 slime/swank.lisp:1.57 --- slime/swank.lisp:1.56 Sat Nov 8 11:59:38 2003 +++ slime/swank.lisp Wed Nov 12 19:22:01 2003 @@ -246,15 +246,18 @@ (makunbound name) (prin1-to-string (eval form)))))) +(defun swank-pprint (object) + "Bind some printer variables and pretty print OBJECT to a string." + (let ((*print-pretty* t) + (*print-circle* t) + (*print-level* nil) + (*print-length* nil)) + (with-output-to-string (stream) + (pprint object stream)))) + (defslimefun pprint-eval (string) (let ((*package* *buffer-package*)) - (let ((value (eval (read-from-string string)))) - (let ((*print-pretty* t) - (*print-circle* t) - (*print-level* nil) - (*print-length* nil)) - (with-output-to-string (stream) - (pprint value stream)))))) + (swank-pprint (eval (read-from-string string))))) (defslimefun set-package (package) (setq *package* (guess-package-from-string package)) From heller at common-lisp.net Thu Nov 13 00:36:30 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 12 Nov 2003 19:36:30 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18358 Modified Files: slime.el Log Message: Modification for the new source-location stuff. I'm sure OpenMCL is now pretty broken. Date: Wed Nov 12 19:36:30 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.88 slime/slime.el:1.89 --- slime/slime.el:1.88 Wed Nov 12 19:10:30 2003 +++ slime/slime.el Wed Nov 12 19:36:29 2003 @@ -1878,7 +1878,8 @@ (beginning-of-defun)) ((:error message) (error "Cannot locate source: %s" message)) - ((:openmcl &key function-name) + ((:openmcl filename function-name) + (set-buffer (find-file-noselect filename t)) (ignore-errors (goto-char (point-min)) (re-search-forward (format "^(def\\w+\\s +%s\\s +" function-name) From heller at common-lisp.net Thu Nov 13 00:36:47 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 12 Nov 2003 19:36:47 -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-serv18406 Modified Files: swank-openmcl.lisp Log Message: Modification for the new source-location stuff. I'm sure OpenMCL is now pretty broken. Date: Wed Nov 12 19:36:47 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.19 slime/swank-openmcl.lisp:1.20 --- slime/swank-openmcl.lisp:1.19 Tue Nov 4 03:03:10 2003 +++ slime/swank-openmcl.lisp Wed Nov 12 19:36:44 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.19 2003/11/04 08:03:10 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.20 2003/11/13 00:36:44 heller Exp $ ;;; ;;; @@ -196,14 +196,12 @@ (defun handle-compiler-warning (condition) "Construct a compiler note for Emacs from a compiler warning condition." - (push (list :position nil - :source-path nil - :filename (ccl::compiler-warning-file-name condition) + (push (list :message (format nil "~A" condition) :severity :warning - :message (format nil "~A" condition) - :context nil - :buffername 'anything - :buffer-offset (condition-source-position condition)) + :location + (list :file + (ccl::compiler-warning-file-name condition) + (condition-source-position condition))) *compiler-notes*) (muffle-warning condition)) @@ -393,8 +391,7 @@ ;; return a list under some circumstances... (when (and source-info (atom source-info)) (let ((filename (namestring (truename source-info)))) - (list :from :file :filename filename :source-path '(0) :position 0 - :function-name (symbol-name symbol)))))) + (list :openmcl filename (symbol-name symbol)))))) (defslimefun frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the From heller at common-lisp.net Thu Nov 13 00:36:56 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 12 Nov 2003 19:36:56 -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-serv18494 Modified Files: swank-sbcl.lisp Log Message: Modification for the new source-location stuff. I'm sure OpenMCL is now pretty broken. Date: Wed Nov 12 19:36:56 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.21 slime/swank-sbcl.lisp:1.22 --- slime/swank-sbcl.lisp:1.21 Fri Nov 7 19:40:27 2003 +++ slime/swank-sbcl.lisp Wed Nov 12 19:36:56 2003 @@ -186,7 +186,7 @@ 75) (defmethod sb-gray:stream-force-output ((stream slime-output-stream)) - (with-slots (buffer fill-pointer last-charpos) stream + (with-slots (buffer fill-pointer) stream (let ((end fill-pointer)) (unless (zerop end) (send-to-emacs `(:read-output ,(subseq buffer 0 end))) @@ -266,25 +266,27 @@ file-name)) (note (list - :position file-pos - :filename (etypecase file - (symbol file) - ((or string pathname) - (namestring (truename file)))) - :source-path (current-compiler-error-source-path context) :severity (etypecase condition (sb-c:compiler-error :error) (sb-ext:compiler-note :note) (style-warning :style-warning) (warning :warning)) :message (brief-compiler-message-for-emacs condition context) - :buffername (if (boundp '*buffername*) *buffername*) - :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*)))) + :location + (list + :sbcl + :buffername (if (boundp '*buffername*) *buffername*) + :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*) + :position file-pos + :filename (etypecase file + (symbol file) + ((or string pathname) + (namestring (truename file)))) + :source-path (current-compiler-error-source-path context))))) #+nil (let ((*print-length* nil)) (format *terminal-io* "handle-notification-condition ~A ~%" note)) - (push note *compiler-notes*) - (push note (gethash file *notes-database*)))))) + (push note *compiler-notes*))))) (defun brief-compiler-message-for-emacs (condition error-context) "Briefly describe a compiler error for Emacs. @@ -334,15 +336,15 @@ (eval (from-string (format nil "(funcall (compile nil '(lambda () ~A)))" string))) - (setf *compiler-notes* - (loop for n in *compiler-notes* - for sp = (getf n :source-path) - ;; account for the added lambda, replace leading - ;; position with 0 - do (setf (getf n :source-path) (cons 0 (cddr sp))) - collect (list* :buffername buffer - :buffer-offset start - n)))))))) + (loop for n in *compiler-notes* + for loc = (getf n :location) + for (_ . l) = loc + for sp = (getf l :source-path) + ;; account for the added lambda, replace leading + ;; position with 0 + do (setf (getf l :source-path) (cons 0 (cddr sp)) + (getf l :buffername) buffer + (getf l :buffer-offset) start))))))) ;;;; xref stuff doesn't exist for sbcl yet @@ -374,16 +376,14 @@ (let* ((def (sb-introspect:find-definition-source function)) (pathname (sb-introspect:definition-source-pathname def)) (path (sb-introspect:definition-source-form-path def))) - (list :from :file + (list :sbcl :filename (and pathname (namestring pathname)) :position (sb-introspect:definition-source-character-offset def) - :info nil ; should be a source-info structure :path path ;; source-paths depend on the file having been compiled with ;; lotsa debugging. If not present, return the function name ;; for emacs to attempt to find with a regex - :function-name (unless path fname) - :source-form nil))) + :function-name (unless path fname)))) (defslimefun function-source-location-for-emacs (fname-string) "Return the source-location of FNAME's definition." @@ -406,7 +406,7 @@ (finder fname) (handler-case (finder fname) (error (e) (list :error (format nil "Error: ~A" e)))))))) - +;; (function-source-location-for-emacs "read-next-form") (defun briefly-describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. Return NIL if the symbol is unbound." @@ -597,6 +597,7 @@ (from (sb-di:debug-source-from debug-source)) (name (sb-di:debug-source-name debug-source))) (list + :sbcl :from from :filename (if (eq from :file) (namestring (truename name))) @@ -616,7 +617,8 @@ (t (c) (list :error (princ-to-string c))))) (defslimefun frame-source-location-for-emacs (index) - (safe-source-location-for-emacs (sb-di:frame-code-location (nth-frame index)))) + (safe-source-location-for-emacs + (sb-di:frame-code-location (nth-frame index)))) #+nil (defslimefun eval-string-in-frame (string index) From heller at common-lisp.net Thu Nov 13 00:48:56 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 12 Nov 2003 19:48:56 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23084 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Nov 12 19:48:56 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.91 slime/ChangeLog:1.92 --- slime/ChangeLog:1.91 Wed Nov 12 18:59:06 2003 +++ slime/ChangeLog Wed Nov 12 19:48:56 2003 @@ -1,3 +1,15 @@ +2003-11-13 Helmut Eller + + * slime.el, swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl: New + representation for "source-locations". Compiler notes have now a + message, a severity, and a source-location field. Compiler notes, + edit-definition, and the debugger all use now the same + representation for source-location. CMUCL does the source-path to + file-position translation at the Lisp side. This works better + with reader macros, in particular with backquote. The SBCL + backend still does the translation on the Emacs side. OpenMCL + support is probably totally broken at the moment + 2003-11-13 Luke Gorrie * slime.el (slime-repl-previous-input, slime-repl-next-input): From lgorrie at common-lisp.net Thu Nov 13 01:22:37 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 12 Nov 2003 20:22: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-serv5605 Modified Files: slime.el Log Message: (slime-connect): pop-to-buffer into *slime-repl* when we connect. Date: Wed Nov 12 20:22:37 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.89 slime/slime.el:1.90 --- slime/slime.el:1.89 Wed Nov 12 19:36:29 2003 +++ slime/slime.el Wed Nov 12 20:22:36 2003 @@ -769,6 +769,7 @@ (message "Connecting to Swank on port %S.." port) (slime-net-connect "localhost" port) (slime-init-connection) + (pop-to-buffer (slime-output-buffer)) (message "Connected to Swank server on port %S. %s" port (slime-random-words-of-encouragement))) From lgorrie at common-lisp.net Thu Nov 13 01:22:45 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 12 Nov 2003 20:22:45 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5646 Modified Files: ChangeLog Log Message: Date: Wed Nov 12 20:22:45 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.92 slime/ChangeLog:1.93 --- slime/ChangeLog:1.92 Wed Nov 12 19:48:56 2003 +++ slime/ChangeLog Wed Nov 12 20:22:45 2003 @@ -1,3 +1,8 @@ +2003-11-13 Luke Gorrie + + * slime.el (slime-connect): pop-to-buffer into *slime-repl* when + we connect. + 2003-11-13 Helmut Eller * slime.el, swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl: New From heller at common-lisp.net Thu Nov 13 22:42:10 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 13 Nov 2003 17:42:10 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30830 Modified Files: slime.el Log Message: Imititate an "output-mark". Output from Lisp should move point only if point is at the end of the buffer. (slime-with-output-at-eob): New function. (slime-repl-insert-prompt): Don't move point at the end of the buffer. (slime-output-string, slime-repl-maybe-prompt): Use it. (slime-repl-show-result-continutation): Don't move point to eob. slime-repl-mode-map: Override "\C-\M-x". (slime-goto-source-location): Add (:sexp) case. remove (:null) and (:error ..) cases. (slime-choose-overlay-region, slime-edit-fdefinition): Catch (:null) location here. (slime-complete-maybe-save-window-configuration): Fix typo. It's make-local-hook, not make-local. (slime-complete-restore-window-configuration): Fix typo. Remove-hook takes 2 args. (slime-eval-print-last-expression): New function. (slime-scratch-mode-map, slime-scratch-buffer, slime-switch-to-scratch-buffer, slime-scratch): New functions. (slime-propertize-region): Renamed from sldb-propertize-region. (when-let): Renamed from when-bind. Date: Thu Nov 13 17:42:09 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.90 slime/slime.el:1.91 --- slime/slime.el:1.90 Wed Nov 12 20:22:36 2003 +++ slime/slime.el Thu Nov 13 17:42:08 2003 @@ -451,13 +451,15 @@ ;;; Common utility functions and macros -(defmacro* when-bind ((var value) &rest body) +(defmacro* when-let ((var value) &rest body) "Evaluate VALUE, and if the result is non-nil bind it to VAR and -evaluate BODY." +evaluate BODY. + +\(when-let (VAR VALUE) &rest BODY)" `(let ((,var ,value)) (when ,var , at body))) -(put 'when-bind 'lisp-indent-function 1) +(put 'when-let 'lisp-indent-function 1) (defmacro with-lexical-bindings (variables &rest body) "Execute BODY with VARIABLES in lexical scope." @@ -688,6 +690,18 @@ (or (cdr (assoc slime-lisp-package slime-lisp-preferred-package-nicknames)) slime-lisp-package)) +(defmacro slime-propertize-region (props &rest body) + (let ((start (gensym))) + `(let ((,start (point))) + (prog1 (progn , at body) + (add-text-properties ,start (point) ,props))))) + +(put 'slime-propertize-region 'lisp-indent-function 1) + +(defun slime-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (slime-propertize-region props (apply #'insert args))) + ;;; Inferior CL Setup: compiling and connecting to Swank @@ -773,7 +787,6 @@ (message "Connected to Swank server on port %S. %s" port (slime-random-words-of-encouragement))) - (defun slime-disconnect () "Disconnect from the Swank server." (interactive) @@ -1344,14 +1357,22 @@ (when (< start end) (slime-display-buffer-region (current-buffer) start end))))) +(defun slime-with-output-at-eob (fn) + "Call FN at the eob. In a save-excursion block if we are not at +eob." + (cond ((eobp) (funcall fn)) + (t (save-excursion + (goto-char (point-max)) + (funcall fn))))) + (defun slime-output-string (string) (unless (zerop (length string)) (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (slime-repl-maybe-insert-output-separator) - (slime-insert-propertized '(face slime-repl-output-face) - string)))) -;; (insert string)))) + (slime-with-output-at-eob + (lambda () + (slime-repl-maybe-insert-output-separator) + (slime-propertize-region '(face slime-repl-output-face) + (insert string))))))) (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." @@ -1400,27 +1421,27 @@ (defun slime-repl-insert-prompt () (unless (bolp) (insert "\n")) - (set-marker slime-repl-prompt-start-mark (point) (current-buffer)) - (slime-insert-propertized - '(face font-lock-keyword-face - read-only t - intangible t - ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) - ;; xemacs stuff - start-open t end-open t) - (concat (slime-lisp-package) "> ")) - (set-marker slime-repl-input-start-mark (point) (current-buffer)) - (set-marker slime-repl-input-end-mark (point) (current-buffer)) - (let ((w (get-buffer-window (current-buffer)))) - (when w (set-window-point w (point))))) + (let ((start (point))) + (slime-propertize-region + '(face font-lock-keyword-face + read-only t + intangible 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-repl-prompt-start-mark start (current-buffer)) + (set-marker slime-repl-input-start-mark (point) (current-buffer)) + (set-marker slime-repl-input-end-mark (point) (current-buffer)))) (defun slime-repl-maybe-prompt () "Insert a prompt if there is none." (with-current-buffer (slime-output-buffer) (unless (= (point-max) slime-repl-input-end-mark) - (goto-char (point-max)) - (slime-repl-insert-prompt)))) + (slime-with-output-at-eob + (lambda () + (slime-repl-insert-prompt)))))) (defun slime-repl-current-input () "Return the current input as string. The input is the region from @@ -1449,9 +1470,9 @@ ;; the prompt is already printed. (lambda (result) (with-current-buffer (slime-output-buffer) - (goto-char slime-repl-prompt-start-mark) - (insert result "\n") - (goto-char (point-max))))) + (save-excursion + (goto-char slime-repl-prompt-start-mark) + (insert result "\n"))))) (defun slime-repl-maybe-insert-output-separator () "Insert a newline at point, if we are the end of the input." @@ -1523,6 +1544,33 @@ (slime-repl-delete-current-input) (insert-and-inherit string)) +;;; Scratch + +(defvar slime-scratch-mode-map) +(setq slime-scratch-mode-map (make-sparse-keymap)) +(set-keymap-parent slime-scratch-mode-map lisp-mode-map) + +(defun slime-scratch-buffer () + "Return the scratch buffer, create it if necessary." + (or (get-buffer "*slime-scratch*") + (with-current-buffer (get-buffer-create "*slime-scratch*") + (lisp-mode) + (use-local-map slime-scratch-mode-map) + (slime-mode t) + (current-buffer)))) + +(defun slime-switch-to-scratch-buffer () + (set-buffer (slime-scratch-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t))) + +(defun slime-scratch () + (interactive) + (slime-switch-to-scratch-buffer)) + +(slime-define-keys slime-scratch-mode-map + ("\C-j" 'slime-eval-print-last-expression)) + ;;;; History @@ -1598,7 +1646,9 @@ ("\C-c\C-c" 'slime-interrupt) ("\C-c\C-g" 'slime-interrupt) ("\t" 'slime-complete-symbol) - (" " 'slime-space)) + (" " 'slime-space) + ("\C-\M-x" 'slime-eval-defun) + ) (define-minor-mode slime-repl-read-mode "Mode the read input from Emacs @@ -1798,7 +1848,9 @@ "Choose the start and end points for an overlay over NOTE. If the location's sexp is a list spanning multiple lines, then the region around the first element is used." - (slime-goto-source-location (getf note :location)) + (let ((location (getf note :location))) + (unless (equal location '(:null)) + (slime-goto-source-location location))) (let ((start (point))) (slime-forward-sexp) (if (slime-same-line-p start (point)) @@ -1864,10 +1916,7 @@ (:file ,filename ,position) -- A position in a file. (:emacs-buffer ,buffername ,position) -- A position in a buffer. - (:defintion-name ,name) -- A name of a definition. - (:null) -- A dummy. - (:error ,message) -- The location cannot be found. - (:sbcl &key " + (:sexp ,string) -- A sexp where no file is available." (destructure-case location ((:file filename position) (set-buffer (find-file-noselect filename t)) @@ -1875,10 +1924,9 @@ ((:emacs-buffer buffer position) (set-buffer buffer) (goto-char position)) - ((:null) - (beginning-of-defun)) - ((:error message) - (error "Cannot locate source: %s" message)) + ((:sexp string) + (with-output-to-temp-buffer "*SLIME SEXP*" + (princ string))) ((:openmcl filename function-name) (set-buffer (find-file-noselect filename t)) (ignore-errors @@ -2109,10 +2157,10 @@ (defun slime-autodoc () "Print some apropos information about the code at point, if applicable." - (when-bind (sym (slime-function-called-at-point/line)) + (when-let (sym (slime-function-called-at-point/line)) (let ((name (symbol-name sym)) (cache-key (slime-qualify-cl-symbol-name sym))) - (or (when-bind (documentation (slime-get-cached-autodoc cache-key)) + (or (when-let (documentation (slime-get-cached-autodoc cache-key)) (message documentation) t) ;; Asynchronously fetch, cache, and display arglist @@ -2134,7 +2182,7 @@ (when (equal (car slime-autodoc-cache) symbol-name) (cdr slime-autodoc-cache))) ((all) - (when-bind (symbol (intern-soft symbol-name)) + (when-let (symbol (intern-soft symbol-name)) (get symbol 'slime-autodoc-cache))))) (defun slime-update-autodoc-cache (symbol-name documentation) @@ -2177,7 +2225,7 @@ (current-window-configuration)))) (defun slime-complete-delay-restoration () - (add-hook (make-local 'pre-command-hook) + (add-hook (make-local-hook 'pre-command-hook) 'slime-complete-maybe-restore-window-confguration)) (defun slime-complete-forget-window-configuration () @@ -2185,7 +2233,8 @@ (defun slime-complete-restore-window-configuration () "Restore the window config if available." - (remove-hook 'slime-complete-maybe-restore-window-confguration) + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-confguration) (when slime-complete-saved-window-configuration (set-window-configuration slime-complete-saved-window-configuration) (setq slime-complete-saved-window-configuration nil)) @@ -2195,7 +2244,8 @@ (defun slime-complete-maybe-restore-window-confguration () "Restore the window configuration, if the following command terminates a current completion." - (remove-hook 'slime-complete-maybe-restore-window-confguration) + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-confguration) (condition-case err (cond ((find last-command-char "()\"'`,# \r\n:") (slime-complete-restore-window-configuration)) @@ -2391,9 +2441,9 @@ (source-location (slime-eval `(swank:function-source-location-for-emacs ,name) (slime-buffer-package)))) - (cond ((null source-location) + (cond ((or (null source-location) (equal source-location '(:null))) (message "No definition found: %s" name)) - ((eq (car source-location) :error) + ((equal (car source-location) :error) (slime-message "%s" (cadr source-location))) (t (slime-goto-source-location source-location) @@ -2446,7 +2496,7 @@ (defun slime-eval-last-expression () (interactive) (slime-interactive-eval (slime-last-expression))) - + (defun slime-eval-defun () (interactive) (slime-interactive-eval (slime-defun-at-point))) @@ -2475,6 +2525,20 @@ (interactive) (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression)))) +(defun slime-eval-print-last-expression (string) + (interactive (list (slime-last-expression))) + (slime-insert-transcript-delimiter string) + (insert "\n") + (slime-eval-async + `(swank:interactive-eval ,string) + (slime-buffer-package t) + (lexical-let ((buffer (current-buffer))) + (lambda (result) + (with-current-buffer buffer + (slime-show-last-output) + (princ result buffer) + (insert "\n")))))) + (defun slime-toggle-trace-fdefinition (fname-string) (interactive (list (slime-completing-read-symbol-name "(Un)trace: " (slime-symbol-name-at-point)))) @@ -2993,15 +3057,6 @@ (pop-to-buffer (current-buffer)) (run-hooks 'sldb-hook))) -(defmacro sldb-propertize-region (props &rest body) - (let ((start (gensym))) - `(let ((,start (point))) - (prog1 (progn , at body) - (add-text-properties ,start (point) ,props))))) - -(defun slime-insert-propertized (props &rest args) - (sldb-propertize-region props (apply #'insert args))) - (define-derived-mode sldb-mode fundamental-mode "sldb" "Superior lisp debugger mode @@ -3115,8 +3170,6 @@ (sldb-show-frame-details) (sldb-hide-frame-details)))) -(put 'sldb-propertize-region 'lisp-indent-function 1) - (defun sldb-frame-region () (save-excursion (goto-char (next-single-property-change (point) 'frame nil (point-max))) @@ -3135,7 +3188,7 @@ (indent2 " ")) (goto-char start) (delete-region start end) - (sldb-propertize-region (plist-put props 'details-visible-p t) + (slime-propertize-region (plist-put props 'details-visible-p t) (insert (second frame) "\n" indent1 "Locals:\n") (sldb-princ-locals frame-number indent2) @@ -3170,7 +3223,7 @@ (frame (plist-get props 'frame))) (goto-char start) (delete-region start end) - (sldb-propertize-region (plist-put props 'details-visible-p nil) + (slime-propertize-region (plist-put props 'details-visible-p nil) (insert (second frame) "\n")))))) (defun sldb-eval-in-frame (string) @@ -3373,7 +3426,7 @@ (save-excursion (loop for (label . value) in (getf inspected-parts :parts) for i from 0 - do (sldb-propertize-region `(slime-part-number ,i) + do (slime-propertize-region `(slime-part-number ,i) (insert label ": " value "\n")))) (pop-to-buffer (current-buffer)) (when point (goto-char point))))) From heller at common-lisp.net Thu Nov 13 22:45:27 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 13 Nov 2003 17:45: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-serv32668 Modified Files: swank-cmucl.lisp Log Message: ((resolve-location t pathname t t t)): Emacs buffer positions are 1 based. Add 1 to the 0 based file-position. Date: Thu Nov 13 17:45:27 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.19 slime/swank-cmucl.lisp:1.20 --- slime/swank-cmucl.lisp:1.19 Wed Nov 12 19:20:06 2003 +++ slime/swank-cmucl.lisp Thu Nov 13 17:45:27 2003 @@ -202,7 +202,7 @@ source-path source)) (defmethod resolve-location (i (f pathname) position path source) - `(:file ,(unix-truename f) ,(source-path-file-position path f))) + `(:file ,(unix-truename f) ,(1+ (source-path-file-position path f)))) (defmethod resolve-location ((i buffer-source-info) (f (eql :stream)) position path source) From heller at common-lisp.net Thu Nov 13 22:48:17 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 13 Nov 2003 17:48:17 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1102 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Nov 13 17:48:17 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.93 slime/ChangeLog:1.94 --- slime/ChangeLog:1.93 Wed Nov 12 20:22:45 2003 +++ slime/ChangeLog Thu Nov 13 17:48:16 2003 @@ -1,3 +1,25 @@ +2003-11-13 Helmut Eller + + * slime.el: Imititate an "output-mark". Output from Lisp should + move point only if point is at the end of the buffer. + (slime-with-output-at-eob): New function. + (slime-repl-insert-prompt): Don't move point at the end of the + buffer. + (slime-output-string, slime-repl-maybe-prompt): Use it. + (slime-repl-show-result-continutation): Don't move point to eob. + + slime-repl-mode-map: Override "\C-\M-x". + + An experimental scratch buffer: + (slime-eval-print-last-expression): New function. + (slime-scratch-mode-map, slime-scratch-buffer, + slime-switch-to-scratch-buffer, slime-scratch): New functions. + + * swank-cmucl.lisp: + ((resolve-location t pathname t t t)): Emacs buffer positions are 1 + based. Add 1 to the 0 based file-position. + + 2003-11-13 Luke Gorrie * slime.el (slime-connect): pop-to-buffer into *slime-repl* when From heller at common-lisp.net Thu Nov 13 22:55:03 2003 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 13 Nov 2003 17:55:03 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3541 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Nov 13 17:54:45 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.94 slime/ChangeLog:1.95 --- slime/ChangeLog:1.94 Thu Nov 13 17:48:16 2003 +++ slime/ChangeLog Thu Nov 13 17:54:38 2003 @@ -1,25 +1,21 @@ 2003-11-13 Helmut Eller * slime.el: Imititate an "output-mark". Output from Lisp should - move point only if point is at the end of the buffer. + move point only if point is at the end of the buffer. (Thanks + William Halliburton for the suggestion.) (slime-with-output-at-eob): New function. - (slime-repl-insert-prompt): Don't move point at the end of the - buffer. (slime-output-string, slime-repl-maybe-prompt): Use it. - (slime-repl-show-result-continutation): Don't move point to eob. - slime-repl-mode-map: Override "\C-\M-x". + slime-repl-mode-map: Override "\C-\M-x". An experimental scratch buffer: (slime-eval-print-last-expression): New function. (slime-scratch-mode-map, slime-scratch-buffer, slime-switch-to-scratch-buffer, slime-scratch): New functions. - * swank-cmucl.lisp: - ((resolve-location t pathname t t t)): Emacs buffer positions are 1 - based. Add 1 to the 0 based file-position. + * swank-cmucl.lisp (resolve-location): Emacs buffer positions are + 1 based. Add 1 to the 0 based file-position. - 2003-11-13 Luke Gorrie * slime.el (slime-connect): pop-to-buffer into *slime-repl* when From lgorrie at common-lisp.net Fri Nov 14 16:36:43 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 14 Nov 2003 11:36:43 -0500 Subject: [slime-cvs] CVS update: Message-ID: Luke wrote this message to test a cvs-commit shell script. Because this text doesn't contain "Change" and "Log" as a single word, this message should only go to the slime-cvs mailing list. Otherwise it would go to slime-devel as well. Date: Fri Nov 14 11:36:42 2003 Author: lgorrie From lgorrie at common-lisp.net Fri Nov 14 16:48:27 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 14 Nov 2003 11:48:27 -0500 Subject: [slime-cvs] CVS update: Message-ID: Luke wrote this message to test a cvs-commit shell script. Because this text contains the word "ChangeLog", it should be sent to both the slime-cvs and slime-devel mailing lists. If this works, we will run this script from CVSROOT/loginfo. That way slime-devel will be informed of updates to the ChangeLog, and have an easier time of keeping track of SLIME changes, without being bothered by other commits. Date: Fri Nov 14 11:48:27 2003 Author: lgorrie From lgorrie at common-lisp.net Fri Nov 14 16:49:26 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 14 Nov 2003 11:49:26 -0500 Subject: [slime-cvs] CVS update: Message-ID: Luke wrote this message to test a cvs-commit shell script. Because this text contains the word "ChangeLog", it should be sent to both the slime-cvs and slime-devel mailing lists. If this works, we will run this script from CVSROOT/loginfo. That way slime-devel will be informed of updates to the ChangeLog, and have an easier time of keeping track of SLIME changes, without being bothered by other commits. (It didn't work the first time, so I'm trying again.) Date: Fri Nov 14 11:49:26 2003 Author: lgorrie From lgorrie at common-lisp.net Fri Nov 14 16:53:49 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 14 Nov 2003 11:53:49 -0500 Subject: [slime-cvs] CVS update: CVSROOT/loginfo Message-ID: Update of /project/slime/cvsroot/CVSROOT In directory common-lisp.net:/tmp/cvs-serv12335 Modified Files: loginfo Log Message: Using the script /project/slime/bin/cvslog.sh to send commit messages to mailing lists. Date: Fri Nov 14 11:53:49 2003 Author: lgorrie Index: CVSROOT/loginfo diff -u CVSROOT/loginfo:1.2 CVSROOT/loginfo:1.3 --- CVSROOT/loginfo:1.2 Wed Oct 15 09:26:00 2003 +++ CVSROOT/loginfo Fri Nov 14 11:53:49 2003 @@ -24,4 +24,7 @@ #DEFAULT (echo ""; id; echo %s; date; cat) >> $CVSROOT/CVSROOT/commitlog # or #DEFAULT (echo ""; id; echo %{sVv}; date; cat) >> $CVSROOT/CVSROOT/commitlog -DEFAULT /custom/bin/cvslog.py slime-cvs at common-lisp.net %{sVv} + +#DEFAULT /custom/bin/cvslog.py slime-cvs at common-lisp.net %{sVv} +DEFAULT /project/slime/bin/cvslog.sh slime-cvs at common-lisp.net slime-devel at common-lisp.net + From heller at common-lisp.net Sat Nov 15 10:10:09 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 15 Nov 2003 05:10:09 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11424 Modified Files: slime.el Log Message: (slime-process-available-input): Abort when we see a reader error. Call slime-state/event-panic to file a bug report. (slime-state/event-panic): Include the *slime-events* and *cl-connection* buffers in the report. (slime-show-last-output): Include the prompt so that the window point is updated properly. (slime-with-output-at-eob): Update window point if the buffer is visible. (slime-output-string): Remove zero length test. (slime-compile-file): Pop up the output buffer. (slime-print-apropos): Minor cleanups. Date: Sat Nov 15 05:10:09 2003 Author: heller From heller at common-lisp.net Sat Nov 15 10:12:38 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 15 Nov 2003 05:12:38 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12139 Modified Files: swank-cmucl.lisp Log Message: (sos/out): Don't flush the buffer on new-lines. Date: Sat Nov 15 05:12:38 2003 Author: heller From heller at common-lisp.net Sat Nov 15 10:23:26 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 15 Nov 2003 05:23:26 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16239 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Nov 15 05:23:26 2003 Author: heller From heller at common-lisp.net Sun Nov 16 17:45:18 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 12:45:18 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16696 Modified Files: slime.el Log Message: Add some docstring. (interrupt-bubbling-idiot): New test. Date: Sun Nov 16 12:45:18 2003 Author: heller From heller at common-lisp.net Sun Nov 16 17:47:00 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 12:47:00 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16994 Added Files: swank-gray.lisp Log Message: (stream-write-char): Don't flush the buffer on newlines. Date: Sun Nov 16 12:47:00 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:05:37 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:05:37 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24858 Modified Files: swank-cmucl.lisp Log Message: (without-interrupts*): New function. Date: Sun Nov 16 13:05:37 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:07:41 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:07:41 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25053 Modified Files: swank.lisp Log Message: (send-to-emacs): Protect the write operations by a without-interrupts, so that we don't trash the *cl-connection* buffer with partially written messages. Date: Sun Nov 16 13:07:41 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:08:44 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:08:44 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25247 Modified Files: swank-sbcl.lisp Log Message: Import gray stream symbols. (without-interrupts*): New function. Date: Sun Nov 16 13:08:44 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:09:32 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:09:32 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26411 Modified Files: swank-openmcl.lisp Log Message: Import gray stream symbols. (without-interrupts*): New function. Date: Sun Nov 16 13:09:32 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:10:26 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:10:26 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26895 Modified Files: swank-loader.lisp Log Message: Compile and load gray stream stuff for SBCL and OpenMCL. Date: Sun Nov 16 13:10:26 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:24:16 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:24:16 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32012 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Nov 16 13:24:16 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:28:47 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:28:47 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv368 Modified Files: slime.el Log Message: (slime-keys): Don't bind "\C- ". Problematic on LinuxPPC. Date: Sun Nov 16 13:28:47 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:41:07 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:41:07 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6069 Modified Files: slime.el Log Message: slime-keys: Override C-c C-r with slime-eval-region. Date: Sun Nov 16 13:41:07 2003 Author: heller From heller at common-lisp.net Sun Nov 16 18:49:03 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 16 Nov 2003 13:49:03 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8629 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Nov 16 13:49:03 2003 Author: heller From heller at common-lisp.net Wed Nov 19 12:06:19 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 07:06:19 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9150 Modified Files: slime.el Log Message: Window configuration are now organized as a stack, not a single global variable. (slime-saved-window-configurations): Renamed from slime-saved-window-configuration. (slime-save-window-configuration, slime-restore-window-configuration): Use a stack. (slime-show-description, slime-show-apropos): Updated for new version of slime-saved-window-configuration. We use now our own version of with-output-to-temp-buffer. The default version is painfully incompatible between Emacs versions. (slime-with-output-to-temp-buffer): Enable slime-mode, set lisp-syntax-table, enable slime-temp-buffer mode. (slime-temp-buffer-mode): New mode with a single command. (slime-temp-buffer-quit): New command. (slime-connect): Hide the *inferior-lisp-buffer* when we are connected. (slime-complete-delay-restoration): The idiom (add-hook (make-local-hook ...) ...) doesn't work in XEmacs. (slime-complete-symbol): Use vanilla with-output-to-temp-buffer. (slime-show-evaluation-result): Don't use slime-message. I bet, no one will notice. sldb-mode-map: Bind n and p to sldb-down and sldb-up. Date: Wed Nov 19 07:06:17 2003 Author: heller From heller at common-lisp.net Wed Nov 19 12:12:09 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 07:12:09 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11307 Modified Files: swank-loader.lisp Log Message: Load a the user init file if present. (user-init-file): New function. Date: Wed Nov 19 07:12:09 2003 Author: heller From heller at common-lisp.net Wed Nov 19 12:35:52 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 07:35:52 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21960 Modified Files: swank.lisp Log Message: *sldb-pprint-frames*: New option. Tweak printing off return values. Print each value in a separate line in the REPL buffer and comma separated in the echo-area. Print "; No value" for (values). (format-values-for-echo-area): New function. (interactive-eval-region, (swank-pprint, listener-eval): Print each value in separate line. Date: Wed Nov 19 07:35:50 2003 Author: heller From heller at common-lisp.net Wed Nov 19 12:37:37 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 07:37:37 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22281 Modified Files: swank-cmucl.lisp Log Message: (format-frame-for-emacs): Bind *print-pretty* to *sldb-pprint-frames*. (pprint-eval-string-in-frame): Handle mutliple values. Date: Wed Nov 19 07:37:37 2003 Author: heller From heller at common-lisp.net Wed Nov 19 12:59:15 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 07:59:15 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31757 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Nov 19 07:59:14 2003 Author: heller From heller at common-lisp.net Wed Nov 19 13:12:06 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 08:12:06 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4665 Modified Files: slime.el Log Message: (slime-edit-fdefinition-other-window): New function. Date: Wed Nov 19 08:12:06 2003 Author: heller From heller at common-lisp.net Wed Nov 19 13:14:18 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 08:14:18 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5952 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Nov 19 08:14:18 2003 Author: heller From heller at common-lisp.net Wed Nov 19 13:37:31 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 08:37:31 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15183 Modified Files: slime.el Log Message: (slime-with-output-at-eob): Update window-point even if the window is in another frame. Date: Wed Nov 19 08:37:31 2003 Author: heller From heller at common-lisp.net Wed Nov 19 13:45:39 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 19 Nov 2003 08:45:39 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19691 Modified Files: slime.el Log Message: inferior-lisp-mode-hook: Set the second argument of get-buffer-window to t. Suggested by Sean O'Rourke. Date: Wed Nov 19 08:45:39 2003 Author: heller From lgorrie at common-lisp.net Sat Nov 22 04:29:42 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 21 Nov 2003 23:29:42 -0500 Subject: [slime-cvs] CVS update: Message-ID: Update of /project/slime/cvsroot/CVSROOT In directory common-lisp.net:/tmp/cvs-serv10039 Modified Files: loginfo Log Message: Revert the switch over to my script - it was losing the diffs. Will use danb's nice idea of mailing ChangeLog diffs to slime-devel from crontab. Date: Fri Nov 21 23:29:42 2003 Author: lgorrie From lgorrie at common-lisp.net Sat Nov 22 05:37:00 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 22 Nov 2003 00:37:00 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3352 Modified Files: swank.lisp Log Message: (listener-eval): Format results in *buffer-package*. Exporting (CREATE-SWANK-SERVER ). This function can be called directly to start a swank server, which you can then connect to with `M-x slime-connect'. It takes a port number as argument, but this can be zero to use a random available port. The function always returns the actual port number being used. Date: Sat Nov 22 00:36:59 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.59 slime/swank.lisp:1.60 --- slime/swank.lisp:1.59 Wed Nov 19 07:35:47 2003 +++ slime/swank.lisp Sat Nov 22 00:36:59 2003 @@ -10,7 +10,7 @@ (defpackage :swank (:use :common-lisp) (:nicknames "SWANK-IMPL") - (:export #:start-server + (:export #:start-server #:create-swank-server #:*sldb-pprint-frames*)) (in-package :swank) @@ -162,6 +162,11 @@ (let ((*package* *buffer-package*)) (read-from-string string))) +(defun symbol-from-string (string) + "Read string in the *BUFFER-PACKAGE*" + (let ((*package* *buffer-package*)) + (find-symbol (string-upcase string)))) + (defun to-string (string) "Write string in the *BUFFER-PACKAGE*." (let ((*package* *buffer-package*)) @@ -283,7 +288,9 @@ *** ** ** * * (car values) /// // // / / values) (cond ((null values) "; No value") - (t (format nil "~{~S~^~%~}" values))))) + (t + (let ((*package* *buffer-package*)) + (format nil "~{~S~^~%~}" values)))))) ;;;; Compilation Commands. @@ -368,10 +375,21 @@ (print-output-to-string (lambda () (describe object)))) (defslimefun describe-symbol (symbol-name) - (print-description-to-string (from-string symbol-name))) + (print-description-to-string (symbol-from-string symbol-name))) (defslimefun describe-function (symbol-name) - (print-description-to-string (symbol-function (from-string symbol-name)))) + (print-description-to-string + (symbol-function (symbol-from-string symbol-name)))) + +(defslimefun documentation-symbol (symbol-name) + (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))))) ;;; Macroexpansion @@ -456,7 +474,7 @@ (if pos (subseq string 0 pos) nil)) (search "::" string))) -(defun find-symbol-designator (string default-package) +(defun find-symbol-designator (string &optional (default-package *buffer-package*)) "Return the symbol corresponding to the symbol designator STRING. If string is not package qualified use DEFAULT-PACKAGE for the resolution. Return nil if no such symbol exists." From lgorrie at common-lisp.net Sat Nov 22 05:38:27 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 22 Nov 2003 00:38:27 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3553 Modified Files: slime.el Log Message: (slime-connect): Slightly reordered some window operations to ensure that *slime-repl* is popped up after `M-x slime-connect'. Date: Sat Nov 22 00:38:27 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.99 slime/slime.el:1.100 --- slime/slime.el:1.99 Wed Nov 19 08:45:36 2003 +++ slime/slime.el Sat Nov 22 00:38:27 2003 @@ -816,9 +816,9 @@ (message "Connecting to Swank on port %S.." port) (slime-net-connect "localhost" port) (slime-init-connection) - (pop-to-buffer (slime-output-buffer)) (delete-windows-on (get-buffer "*inferior-lisp*")) (bury-buffer (get-buffer "*inferior-lisp*")) + (pop-to-buffer (slime-output-buffer)) (message "Connected to Swank server on port %S. %s" port (slime-random-words-of-encouragement))) From lgorrie at common-lisp.net Sat Nov 22 05:38:41 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 22 Nov 2003 00:38:41 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3591 Modified Files: ChangeLog Log Message: Date: Sat Nov 22 00:38:40 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.100 slime/ChangeLog:1.101 --- slime/ChangeLog:1.100 Wed Nov 19 08:14:17 2003 +++ slime/ChangeLog Sat Nov 22 00:38:40 2003 @@ -1,3 +1,16 @@ +2003-11-22 Luke Gorrie + + * slime.el (slime-connect): Slightly reordered some window + operations to ensure that *slime-repl* is popped up after `M-x + slime-connect'. + + * swank.lisp (listener-eval): Format results in *buffer-package*. + Exporting (CREATE-SWANK-SERVER ). This function can be + called directly to start a swank server, which you can then + connect to with `M-x slime-connect'. It takes a port number as + argument, but this can be zero to use a random available port. + The function always returns the actual port number being used. + 2003-11-19 Helmut Eller * swank.lisp: Better printing off return values. In the REPL From lgorrie at common-lisp.net Sat Nov 22 07:44:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 22 Nov 2003 02:44: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-serv21979 Modified Files: slime.el Log Message: (slime-show-last-output): If the *slime-repl* buffer is already visible in any frame, don't change anything. Date: Sat Nov 22 02:44:11 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.100 slime/slime.el:1.101 --- slime/slime.el:1.100 Sat Nov 22 00:38:27 2003 +++ slime/slime.el Sat Nov 22 02:44:11 2003 @@ -1406,12 +1406,15 @@ (set-marker slime-last-output-start (point) (current-buffer)))) (defun slime-show-last-output () - (with-current-buffer (slime-output-buffer) - (let ((start slime-last-output-start) - (end slime-repl-prompt-start-mark)) - (when (< start end) - (slime-display-buffer-region (current-buffer) start - slime-repl-input-start-mark))))) + "Show the output from the last Lisp evaluation. +This has no effect if the output buffer is already visible." + (unless (get-buffer-window (slime-output-buffer) t) + (with-current-buffer (slime-output-buffer) + (let ((start slime-last-output-start) + (end slime-repl-prompt-start-mark)) + (when (< start end) + (slime-display-buffer-region (current-buffer) start + slime-repl-input-start-mark)))))) (defun slime-with-output-at-eob (fn) "Call FN at the eob. In a save-excursion block if we are not at From lgorrie at common-lisp.net Sat Nov 22 07:44:28 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 22 Nov 2003 02:44:28 -0500 Subject: [slime-cvs] CVS update: slime/swank.asd Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22055 Added Files: swank.asd Log Message: ASDF definition to load "swank-loader.lisp". This is useful for starting the Swank server in a separate Lisp and later connecting with Emacs. The file includes commentary. Date: Sat Nov 22 02:44:28 2003 Author: lgorrie From lgorrie at common-lisp.net Sat Nov 22 07:45:24 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 22 Nov 2003 02:45:24 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22507 Modified Files: ChangeLog Log Message: Date: Sat Nov 22 02:45:24 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.101 slime/ChangeLog:1.102 --- slime/ChangeLog:1.101 Sat Nov 22 00:38:40 2003 +++ slime/ChangeLog Sat Nov 22 02:45:24 2003 @@ -1,8 +1,16 @@ +2003-11-22 Brian Mastenbrook + + * swank.asd: ASDF definition to load "swank-loader.lisp". This is + useful for starting the Swank server in a separate Lisp and later + connecting with Emacs. The file includes commentary. + 2003-11-22 Luke Gorrie * slime.el (slime-connect): Slightly reordered some window operations to ensure that *slime-repl* is popped up after `M-x slime-connect'. + (slime-show-last-output): If the *slime-repl* buffer is already + visible in any frame, don't change anything. * swank.lisp (listener-eval): Format results in *buffer-package*. Exporting (CREATE-SWANK-SERVER ). This function can be From lgorrie at common-lisp.net Sun Nov 23 05:00:14 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 00:00:14 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp slime/swank.lisp slime/swank-sbcl.lisp slime/swank-loader.lisp slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10850 Modified Files: swank.lisp swank-sbcl.lisp swank-loader.lisp swank-cmucl.lisp Added Files: swank-backend.lisp Log Message: * swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for (documentation SYM 'class), CLHS says there isn't any 'class documentation (and SBCL warns). * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Refactored interface through swank-backend.lisp for: swank-compile-file, swank-compile-string, describe-symbol-for-emacs (apropos), macroexpand-all, arglist-string. * swank-backend.lisp: New file defining the interface between swank.lisp and the swank-*.lisp implementation files. Date: Sun Nov 23 00:00:13 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.60 slime/swank.lisp:1.61 --- slime/swank.lisp:1.60 Sat Nov 22 00:36:59 2003 +++ slime/swank.lisp Sun Nov 23 00:00:13 2003 @@ -1,4 +1,4 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: lisp; outline-regexp: ";;;;*"; indent-tabs-mode: nil -*- ;;; ;;; swank.lisp --- the portable bits ;;; @@ -7,14 +7,17 @@ ;;; This code has been placed in the Public Domain. All warranties are ;;; disclaimed. +#+nil (defpackage :swank (:use :common-lisp) - (:nicknames "SWANK-IMPL") (:export #:start-server #:create-swank-server #:*sldb-pprint-frames*)) (in-package :swank) +;; Directly exported backend functions. +(export '(arglist-string)) + (defvar *swank-io-package* (let ((package (make-package "SWANK-IO-PACKAGE"))) (import '(nil t quote) package) @@ -294,30 +297,11 @@ ;;;; Compilation Commands. -(defvar *previous-compiler-condition* nil - "Used to detect duplicates.") - -(defvar *previous-context* nil - "Used for compiler warnings without context.") - (defvar *compiler-notes* '() "List of compiler notes for the last compilation unit.") (defun clear-compiler-notes () - (setf *compiler-notes* '()) - (setf *previous-compiler-condition* nil) - (setf *previous-context* nil)) - -(defvar *notes-database* (make-hash-table :test #'equal) - "Database of recorded compiler notes/warnings/errors (keyed by filename). -Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists. - LOCATION is a position in the source code (integer or source path). - SEVERITY is one of :ERROR, :WARNING, :STYLE-WARNING and :NOTE. - MESSAGE is a string describing the note. - CONTEXT is a string giving further details of where the error occured.") - -(defun clear-note-database (filename) - (remhash (canonicalize-filename filename) *notes-database*)) + (setf *compiler-notes* '())) (defslimefun features () (mapcar #'symbol-name *features*)) @@ -325,11 +309,6 @@ (defun canonicalize-filename (filename) (namestring (truename filename))) -(defslimefun compiler-notes-for-file (filename) - "Return the compiler notes recorded for FILENAME. -\(See *NOTES-DATABASE* for a description of the return type.)" - (gethash (canonicalize-filename filename) *notes-database*)) - (defslimefun compiler-notes-for-emacs () "Return the list of compiler notes for the last compilation unit." (reverse *compiler-notes*)) @@ -343,14 +322,33 @@ (* (- (get-internal-real-time) before) (/ 1000000 internal-time-units-per-second))))) -(defmacro with-trapping-compilation-notes (() &body body) - `(call-trapping-compilation-notes (lambda () , at body))) +(defun record-note-for-condition (condition) + "Record a note for a compiler-condition." + (push (make-compiler-note condition) *compiler-notes*)) + +(defun make-compiler-note (condition) + "Make a compiler note data structure from a compiler-condition." + (declare (type compiler-condition condition)) + (list :message (message condition) + :severity (severity condition) + :location (location condition))) -(defun call-with-compilation-hooks (fn) +(defslimefun swank-compile-file (filename load-p) + (clear-compiler-notes) (multiple-value-bind (result usecs) - (with-trapping-compilation-notes () - (clear-compiler-notes) - (measure-time-interval fn)) + (handler-bind ((compiler-condition #'record-note-for-condition)) + (measure-time-interval (lambda () + (compile-file-for-emacs filename load-p)))) + (list (to-string result) + (format nil "~,2F" (/ usecs 1000000.0))))) + +(defslimefun swank-compile-string (string buffer start) + (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 start)))) (list (to-string result) (format nil "~,2F" (/ usecs 1000000.0))))) @@ -408,6 +406,9 @@ (defslimefun disassemble-symbol (symbol-name) (print-output-to-string (lambda () (disassemble (from-string symbol-name))))) +(defslimefun swank-macroexpand-all (string) + (apply-macro-expander #'macroexpand-all string)) + ;;; Completion (defun case-convert (string) @@ -512,6 +513,23 @@ (mapcan (listify #'briefly-describe-symbol-for-emacs) (sort (apropos-symbols name external-only package) #'present-symbol-before-p))) + +(defun briefly-describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. +Like `describe-symbol-for-emacs' but with at most one line per item." + (flet ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos))))) + (list* :designator (to-string symbol) + (map-if #'stringp #'first-line (describe-symbol-for-emacs symbol))))) + +(defun map-if (test fn &rest lists) + "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. +Example: +\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)" + (apply #'mapcar + (lambda (x) (if (funcall test x) (funcall fn x) x)) + lists)) (defun listify (f) "Return a function like F, but which returns any non-null value Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.23 slime/swank-sbcl.lisp:1.24 --- slime/swank-sbcl.lisp:1.23 Sun Nov 16 13:08:43 2003 +++ slime/swank-sbcl.lisp Sun Nov 23 00:00:13 2003 @@ -196,6 +196,9 @@ (defvar *buffername*) (defvar *buffer-offset*) +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + (defun handle-notification-condition (condition) "Handle a condition caused by a compiler warning. This traps all compiler conditions at a lower-level than using @@ -205,34 +208,36 @@ (let ((context (sb-c::find-error-context nil))) (when (and context (not (eq condition *previous-compiler-condition*))) (setq *previous-compiler-condition* condition) - (let* ((file-name (sb-c::compiler-error-context-file-name context)) - (file-pos (sb-c::compiler-error-context-file-position context)) - (file (if (typep file-name 'pathname) - (namestring file-name) - file-name)) - (note - (list - :severity (etypecase condition - (sb-c:compiler-error :error) - (sb-ext:compiler-note :note) - (style-warning :style-warning) - (warning :warning)) - :message (brief-compiler-message-for-emacs condition context) - :location - (list - :sbcl - :buffername (if (boundp '*buffername*) *buffername*) - :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*) - :position file-pos - :filename (etypecase file - (symbol file) - ((or string pathname) - (namestring (truename file)))) - :source-path (current-compiler-error-source-path context))))) - #+nil - (let ((*print-length* nil)) - (format *terminal-io* "handle-notification-condition ~A ~%" note)) - (push note *compiler-notes*))))) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-c:compiler-error :error) + (sb-ext:compiler-note :note) + (style-warning :style-warning) + (warning :warning)) + :message (brief-compiler-message-for-emacs condition context) + :location (compiler-note-location context)))) + +(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)) + (file (if (typep file-name 'pathname) + (namestring file-name) + file-name))) + (list :sbcl + :buffername (if (boundp '*buffername*) *buffername*) + :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*) + :position file-pos + :filename (etypecase file + (symbol file) + ((or string pathname) + (namestring (truename file)))) + :source-path (current-compiler-error-source-path context)))) (defun brief-compiler-message-for-emacs (condition error-context) "Briefly describe a compiler error for Emacs. @@ -257,40 +262,36 @@ (reverse (sb-c::compiler-error-context-original-source-path context))))) -(defun call-trapping-compilation-notes (fn) - (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 fn))) - -(defslimefun swank-compile-file (filename load) - (call-with-compilation-hooks - (lambda () - (clear-note-database filename) - #+xref (clear-xref-info filename) - (let* ((*buffername* nil) - (*buffer-offset* nil) - (ret (compile-file filename))) - (if load (load ret) ret))))) - -(defslimefun swank-compile-string (string buffer start) - (call-with-compilation-hooks - (lambda () - (let ((*package* *buffer-package*)) - (prog1 - (eval (from-string - (format nil "(funcall (compile nil '(lambda () ~A)))" - string))) - (loop for n in *compiler-notes* - for loc = (getf n :location) - for (_ . l) = loc - for sp = (getf l :source-path) - ;; account for the added lambda, replace leading - ;; position with 0 - do (setf (getf l :source-path) (cons 0 (cddr sp)) - (getf l :buffername) buffer - (getf l :buffer-offset) start))))))) +(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 compile-file-for-emacs (filename load-p) + (with-compilation-hooks () + (let* ((*buffername* nil) + (*buffer-offset* nil) + (ret (compile-file filename))) + (if load-p (load ret) ret)))) + +(defmethod compile-string-for-emacs (string &key buffer position) + (with-compilation-hooks () + (let ((*package* *buffer-package*)) + (prog1 + (eval (from-string + (format nil "(funcall (compile nil '(lambda () ~A)))" + string))) + (loop for n in *compiler-notes* + for loc = (getf n :location) + for (_ . l) = loc + for sp = (getf l :source-path) + ;; account for the added lambda, replace leading + ;; position with 0 + do (setf (getf l :source-path) (cons 0 (cddr sp)) + (getf l :buffername) buffer + (getf l :buffer-offset) position)))))) ;;;; xref stuff doesn't exist for sbcl yet @@ -352,23 +353,13 @@ (finder fname) (handler-case (finder fname) (error (e) (list :error (format nil "Error: ~A" e)))))))) -;; (function-source-location-for-emacs "read-next-form") -(defun briefly-describe-symbol-for-emacs (symbol) + +(defmethod describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. Return NIL if the symbol is unbound." (let ((result '())) - (labels ((first-line (string) - (let ((pos (position #\newline string))) - (if (null pos) string (subseq string 0 pos)))) - (doc (kind) - (let ((string - ;; sbcl 0.8.4.early signals unbound slot on - ;; (documentation 'function 'type) - ;; (fixed for 0.8.5) - (ignore-errors (documentation symbol kind)))) - (if string - (first-line string) - :not-documented))) + (labels ((doc (kind) + (or (documentation symbol kind) :not-documented)) (maybe-push (property value) (when value (setf result (list* property value result))))) @@ -388,11 +379,7 @@ (maybe-push :type (if (sb-int:info :type :kind symbol) (doc 'type))) - (maybe-push - :class (if (find-class symbol nil) - (doc 'class))) - (if result - (list* :designator (to-string symbol) result))))) + result))) (defslimefun describe-setf-function (symbol-name) (print-description-to-string `(setf ,(from-string symbol-name)))) @@ -406,12 +393,9 @@ ;;; macroexpansion -(defun sbcl-macroexpand-all (form) +(defmethod macroexpand-all (form) (let ((sb-walker:*walk-form-expand-macros-p* t)) (sb-walker:walk-form form))) - -(defslimefun swank-macroexpand-all (string) - (apply-macro-expander #'sbcl-macroexpand-all string)) ;;; Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.4 slime/swank-loader.lisp:1.5 --- slime/swank-loader.lisp:1.4 Wed Nov 19 07:12:09 2003 +++ slime/swank-loader.lisp Sun Nov 23 00:00:13 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.4 2003/11/19 12:12:09 heller Exp $ +;;; $Id: swank-loader.lisp,v 1.5 2003/11/23 05:00:13 lgorrie Exp $ ;;; (defpackage :swank-loader @@ -65,7 +65,9 @@ (cond ((probe-file filename) filename) (t nil)))) -(compile-files-if-needed-serially (cons *swank-pathname* *sysdep-pathnames*)) +(compile-files-if-needed-serially + (list* (make-swank-pathname "swank-backend") *swank-pathname* + *sysdep-pathnames*)) (when (user-init-file) (load (user-init-file))) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.23 slime/swank-cmucl.lisp:1.24 --- slime/swank-cmucl.lisp:1.23 Wed Nov 19 07:37:37 2003 +++ slime/swank-cmucl.lisp Sun Nov 23 00:00:13 2003 @@ -1,4 +1,4 @@ -;;; -*- indent-tabs-mode: nil -*- +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- (declaim (optimize debug)) @@ -175,7 +175,18 @@ (start-offset :initarg :start-offset) (string :initarg :string))) -(defun handle-compiler-condition (condition) +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *compiler-notes* '() + "List of compiler notes for the last compilation unit.") + +;;;;; Trapping notes + +(defun handle-notification-condition (condition) "Handle a condition caused by a compiler warning. This traps all compiler conditions at a lower-level than using C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to @@ -185,24 +196,48 @@ (let ((context (or (c::find-error-context nil) *previous-context*))) (setq *previous-compiler-condition* condition) (setq *previous-context* context) - (let ((note (make-compiler-note condition context))) - (push note *compiler-notes*))))) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (brief-compiler-message-for-emacs condition context) + :location (compiler-note-location context)))) + +(defun compiler-note-location (context) + (cond (context + (let ((cx context)) + (resolve-location + *swank-source-info* + (c::compiler-error-context-file-name cx) + (c::compiler-error-context-file-position cx) + (reverse (c::compiler-error-context-original-source-path cx)) + (c::compiler-error-context-original-source cx)))) + (t + (resolve-location *swank-source-info* nil nil nil nil)))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(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 (or c::compiler-error-context null) error-context)) + (let ((enclosing (and error-context + (c::compiler-error-context-enclosing-source + error-context)))) + (if enclosing + (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition) + (format nil "~A" condition)))) -(defun make-compiler-note (condition context) - (list :message (brief-compiler-message-for-emacs condition context) - :severity (severity-for-emacs condition) - :location - (cond (context - (let ((cx context)) - (resolve-location - *swank-source-info* - (c::compiler-error-context-file-name cx) - (c::compiler-error-context-file-position cx) - (reverse (c::compiler-error-context-original-source-path cx)) - (c::compiler-error-context-original-source cx)))) - (t - (resolve-location *swank-source-info* nil nil nil nil))))) - (defgeneric resolve-location (source-info file-name file-position source-path source)) @@ -226,65 +261,35 @@ (source (eql nil))) '(:null)) -(defun severity-for-emacs (condition) - (etypecase condition - (c::compiler-error :error) - (c::style-warning :note) - (c::warning :warning))) - -(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 (or c::compiler-error-context null) error-context)) - (let ((enclosing (and error-context - (c::compiler-error-context-enclosing-source - error-context)))) - (if enclosing - (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition) - (format nil "~A" condition)))) - -(defun current-compiler-error-source-path (context) - "Return the source-path for the current compiler error. -Returns NIL if this cannot be determined by examining internal -compiler state." - (cond ((c::node-p context) - (reverse - (c::source-path-original-source (c::node-source-path context)))) - ((c::compiler-error-context-p context) - (reverse - (c::compiler-error-context-original-source-path context))))) - -(defun call-trapping-compilation-notes (fn) - (handler-bind ((c::compiler-error #'handle-compiler-condition) - (c::style-warning #'handle-compiler-condition) - (c::warning #'handle-compiler-condition)) - (funcall fn))) - -(defslimefun swank-compile-file (filename load) - (call-with-compilation-hooks - (lambda () - (clear-note-database filename) - (clear-xref-info filename) - (let ((*swank-source-info* (make-instance 'file-source-info - :filename filename))) - (compile-file filename :load load))))) - -(defslimefun swank-compile-string (string buffer start) - (call-with-compilation-hooks - (lambda () - (let ((*package* *buffer-package*) - (*swank-source-info* (make-instance 'buffer-source-info - :buffer buffer - :start-offset start - :string string))) - (with-input-from-string (stream string) - (ext:compile-from-stream - stream - :source-info `(:emacs-buffer ,buffer - :emacs-buffer-offset ,start - :emacs-buffer-string ,string))))))) +;;(defun call-trapping-compilation-notes (fn) +(defmacro with-compilation-hooks (() &body body) + `(let ((*previous-compiler-condition* nil) + (*previous-context* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + , at body))) + +(defmethod compile-file-for-emacs (filename load-p) + (clear-xref-info filename) + (with-compilation-hooks () + (let ((*swank-source-info* (make-instance 'file-source-info + :filename filename))) + (compile-file filename :load load-p)))) + +(defmethod compile-string-for-emacs (string &key buffer position) + (with-compilation-hooks () + (let ((*package* *buffer-package*) + (*swank-source-info* (make-instance 'buffer-source-info + :buffer buffer + :start-offset position + :string string))) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) (defun clear-xref-info (namestring) "Clear XREF notes pertaining to FILENAME. @@ -316,7 +321,7 @@ (defun unix-truename (pathname) (ext:unix-namestring (truename pathname))) -(defslimefun arglist-string (fname) +(defmethod arglist-string (fname) "Return a string describing the argument list for FNAME. The result has the format \"(...)\"." (declare (type string fname)) @@ -328,11 +333,8 @@ (if (not (or (fboundp function) (functionp function))) "(-- )" - (let* ((fun (etypecase function - (symbol (or (macro-function function) - (symbol-function function))) - ;;(function function) - )) + (let* ((fun (or (macro-function function) + (symbol-function function))) (df (di::function-debug-function fun)) (arglist (kernel:%function-arglist fun))) (cond ((eval:interpreted-function-p fun) @@ -573,21 +575,13 @@ ;;; -(defun briefly-describe-symbol-for-emacs (symbol) - "Return a plist describing SYMBOL. -Return NIL if the symbol is unbound." +(defmethod describe-symbol-for-emacs (symbol) (let ((result '())) - (labels ((first-line (string) - (let ((pos (position #\newline string))) - (if (null pos) string (subseq string 0 pos)))) - (doc (kind) - (let ((string (documentation symbol kind))) - (if string - (first-line string) - :not-documented))) - (maybe-push (property value) - (when value - (setf result (list* property value result))))) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) (maybe-push :variable (multiple-value-bind (kind recorded-p) (ext:info variable kind symbol) @@ -619,8 +613,7 @@ (maybe-push :alien-enum (if (ext:info alien-type enum symbol) (doc nil))) - (if result - (list* :designator (to-string symbol) result))))) + result))) (defslimefun describe-setf-function (symbol-name) (print-description-to-string @@ -661,8 +654,8 @@ ;;; Macroexpansion -(defslimefun swank-macroexpand-all (string) - (apply-macro-expander #'walker:macroexpand-all string)) +(defmethod macroexpand-all (form) + (walker:macroexpand-all form)) ;;; From lgorrie at common-lisp.net Sun Nov 23 05:01:17 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 00:01:17 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11315 Modified Files: ChangeLog Log Message: Date: Sun Nov 23 00:01:17 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.102 slime/ChangeLog:1.103 --- slime/ChangeLog:1.102 Sat Nov 22 02:45:24 2003 +++ slime/ChangeLog Sun Nov 23 00:01:16 2003 @@ -1,3 +1,17 @@ +2003-11-23 Luke Gorrie + + * swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for + (documentation SYM 'class), CLHS says there isn't any 'class + documentation (and SBCL warns). + + * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Refactored + interface through swank-backend.lisp for: swank-compile-file, + swank-compile-string, describe-symbol-for-emacs (apropos), + macroexpand-all, arglist-string. + + * swank-backend.lisp: New file defining the interface between + swank.lisp and the swank-*.lisp implementation files. + 2003-11-22 Brian Mastenbrook * swank.asd: ASDF definition to load "swank-loader.lisp". This is From lgorrie at common-lisp.net Sun Nov 23 07:15:04 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 02:15: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-serv32263 Modified Files: slime.el Log Message: (slime-goto-source-location): Align at beginning of sexp after (:file name pos) and (:emacs-buffer buffer pos). Date: Sun Nov 23 02:15:03 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.101 slime/slime.el:1.102 --- slime/slime.el:1.101 Sat Nov 22 02:44:11 2003 +++ slime/slime.el Sun Nov 23 02:15:02 2003 @@ -1981,10 +1981,14 @@ (destructure-case location ((:file filename position) (set-buffer (find-file-noselect filename t)) - (goto-char position)) + (goto-char position) + (slime-forward-sexp) + (beginning-of-sexp)) ((:emacs-buffer buffer position) (set-buffer buffer) - (goto-char position)) + (goto-char position) + (slime-forward-sexp) + (beginning-of-sexp)) ((:sexp string) (with-output-to-temp-buffer "*SLIME SEXP*" (princ string))) From lgorrie at common-lisp.net Sun Nov 23 07:15:15 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 02:15:15 -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-serv32645 Modified Files: swank-openmcl.lisp Log Message: Updated after refactoring of other backends (was broken). Date: Sun Nov 23 02:15:15 2003 Author: lgorrie Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.21 slime/swank-openmcl.lisp:1.22 --- slime/swank-openmcl.lisp:1.21 Sun Nov 16 13:09:31 2003 +++ slime/swank-openmcl.lisp Sun Nov 23 02:15:14 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.21 2003/11/16 18:09:31 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.22 2003/11/23 07:15:14 lgorrie Exp $ ;;; ;;; @@ -123,8 +123,7 @@ (declare (ignore application condition)) (setq *swank-debugger-stack-frame* error-pointer)) -(defslimefun arglist-string (fname) - "Return the lambda list for function FNAME as a string." +(defmethod arglist-string (fname) (let ((*print-case* :downcase)) (multiple-value-bind (function condition) (ignore-errors (values @@ -139,57 +138,52 @@ ;;; Compilation (defvar *buffer-offset*) +(defvar *buffer-name*) (defun condition-source-position (condition) "Return the position in the source file of a compiler condition." - (+ 1 *buffer-offset* (ccl::compiler-warning-stream-position condition))) + (+ 1 + (or *buffer-offset* 0) + (ccl::compiler-warning-stream-position condition))) (defun handle-compiler-warning (condition) "Construct a compiler note for Emacs from a compiler warning condition." - (push (list :message (format nil "~A" condition) - :severity :warning - :location - (list :file - (ccl::compiler-warning-file-name condition) - (condition-source-position condition))) - *compiler-notes*) - (muffle-warning condition)) - -(defun call-trapping-compilation-notes (fn) - "Call FN trapping compiler notes and storing them in the notes database." - (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) - (funcall fn))) + (signal (make-condition + 'compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (let ((position (condition-source-position condition))) + (if *buffer-name* + (list :emacs-buffer *buffer-name* position) + (list :file + (ccl::compiler-warning-file-name condition) + position)))))) (defun temp-file-name () "Return a temporary file name to compile strings into." (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr)))) -(defslimefun swank-compile-string (string buffer start) - "Compile STRING, using BUFFER and START as information for -reporting back the location of compiler notes. In OpenMCL we -have to use the file compiler to get compiler warning positions, -so we write the string to a temporary file and compile it." - (declare (ignore buffer)) - (let ((*buffer-offset* start) - (*package* *buffer-package*) - (filename (temp-file-name))) - (call-with-compilation-hooks - (lambda () - (unwind-protect - (progn - (with-open-file (s filename :direction :output :if-exists :error) - (write-string string s)) - (let ((binary-filename (compile-file filename :load t))) - (delete-file binary-filename))) - (delete-file filename)))))) - -(defslimefun swank-compile-file (filename load) - "Compile and optionally load FILENAME, trapping compiler notes for Emacs." - (let ((*buffer-offset* 0)) - (call-with-compilation-hooks - (lambda () - (compile-file filename :load load))))) +(defmethod compile-file-for-emacs (filename load-p) + (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) + (let ((*buffer-name* nil) + (*buffer-offset* nil)) + (compile-file filename :load load-p)))) + +(defmethod compile-string-for-emacs (string &key buffer position) + (handler-bind ((ccl::compiler-warning #'handle-compiler-warning)) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*package* *buffer-package*) + (filename (temp-file-name))) + (unwind-protect + (with-open-file (s filename :direction :output :if-exists :error) + (write-string string s)) + (let ((binary-filename (compile-file filename :load t))) + (delete-file binary-filename))) + (delete-file filename)))) ;;; Debugging @@ -374,21 +368,13 @@ (defslimefun describe-class (symbol-name) (print-description-to-string (find-class (from-string symbol-name) nil))) -(defun briefly-describe-symbol-for-emacs (symbol) - "Return a plist describing SYMBOL. -Return NIL if the symbol is unbound." +(defmethod describe-symbol-for-emacs (symbol) (let ((result '())) - (labels ((first-line (string) - (let ((pos (position #\newline string))) - (if (null pos) string (subseq string 0 pos)))) - (doc (kind &optional (sym symbol)) - (let ((string (documentation sym kind))) - (if string - (first-line string) - :not-documented))) - (maybe-push (property value) - (when value - (setf result (list* property value result))))) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) (maybe-push :variable (when (boundp symbol) (doc 'variable))) @@ -400,14 +386,7 @@ `(setf ,symbol)))) (when (fboundp setf-function-name) (doc 'function setf-function-name)))) -;; (maybe-push -;; :type (if (ext:info type kind symbol) -;; (doc 'type))) - (maybe-push - :class (if (find-class symbol nil) - (doc 'class))) - (if result - (list* :designator (to-string symbol) result))))) + result))) ;;; Tracing and Disassembly From lgorrie at common-lisp.net Sun Nov 23 07:15:57 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 02:15:57 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv301 Modified Files: ChangeLog Log Message: Date: Sun Nov 23 02:15:57 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.103 slime/ChangeLog:1.104 --- slime/ChangeLog:1.103 Sun Nov 23 00:01:16 2003 +++ slime/ChangeLog Sun Nov 23 02:15:57 2003 @@ -1,5 +1,11 @@ 2003-11-23 Luke Gorrie + * swank-openmcl.lisp: Updated after refactoring of other backends + (was broken). + + * slime.el (slime-goto-source-location): Align at beginning of + sexp after (:file name pos) and (:emacs-buffer buffer pos). + * swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for (documentation SYM 'class), CLHS says there isn't any 'class documentation (and SBCL warns). From lgorrie at common-lisp.net Sun Nov 23 12:13:00 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 07:13:00 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13847 Modified Files: slime.el Log Message: * slime.el (slime-goto-source-location): Added optional `align-p' argument for :file and :emacs-buffer location types. This is for OpenMCL - unlike CMUCL its positions are not character-accurate so it needs to be aligned to the beginning of the sexp. Date: Sun Nov 23 07:13:00 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.102 slime/slime.el:1.103 --- slime/slime.el:1.102 Sun Nov 23 02:15:02 2003 +++ slime/slime.el Sun Nov 23 07:12:59 2003 @@ -1975,20 +1975,28 @@ LOCATION is a plist and defines a position in a buffer. Several kinds of locations are supported: - (:file ,filename ,position) -- A position in a file. - (:emacs-buffer ,buffername ,position) -- A position in a buffer. - (:sexp ,string) -- A sexp where no file is available." + (:file ,filename ,position[ ,align-p]) + A position in a file. + (:emacs-buffer ,buffername ,position[ ,align-p]) + A position in a buffer. + (:sexp ,string) + A sexp where no file is available. + +align-p means the location is not character-accurate, and should be +aligned to the start of the sexp in front." (destructure-case location - ((:file filename position) + ((:file filename position &optional align-p) (set-buffer (find-file-noselect filename t)) (goto-char position) - (slime-forward-sexp) - (beginning-of-sexp)) - ((:emacs-buffer buffer position) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) + ((:emacs-buffer buffer position &optional align-p) (set-buffer buffer) (goto-char position) - (slime-forward-sexp) - (beginning-of-sexp)) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) ((:sexp string) (with-output-to-temp-buffer "*SLIME SEXP*" (princ string))) From lgorrie at common-lisp.net Sun Nov 23 12:13:20 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 07:13:20 -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-serv13935 Modified Files: swank-backend.lisp Log Message: * swank-backend.lisp (call-with-debugging-environment, sldb-condition, debugger-info-for-emacs): More callbacks defined. Date: Sun Nov 23 07:13:20 2003 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.1 slime/swank-backend.lisp:1.2 --- slime/swank-backend.lisp:1.1 Sun Nov 23 00:00:13 2003 +++ slime/swank-backend.lisp Sun Nov 23 07:13:19 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.1 2003/11/23 05:00:13 lgorrie Exp $ +;;; $Id: swank-backend.lisp,v 1.2 2003/11/23 12:13:19 lgorrie Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -46,8 +46,7 @@ :accessor severity) (message - ;; The error or warning message, must be a non-NIL string. - ;; [RFC: Would it be better to obtain the message using a method?] + :documentation "The error or warning message, must be a non-NIL string." :initarg :message :accessor message) @@ -108,5 +107,60 @@ => (:CLASS :NOT-DOCUMENTED :TYPE :NOT-DOCUMENTED :FUNCTION \"Constructs a simple-vector from the given objects.\")")) + + +;;;; Debugging + +(defgeneric call-with-debugging-environment (debugger-loop-fn) + (:documentation + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.")) + +(define-condition sldb-condition (condition) + ((original-condition + :initarg :original-condition + :accessor :original-condition)) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sldb-condition's.")) + +(defgeneric debugger-info-for-emacs (start end) + (:documentation + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition-description ({restart}*) ({stack-frame}*) +where + restart ::= (name description) + stack-frame ::= (number description) + +condition-description---a string describing the condition that +triggered the debugger. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + (\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0). + [Condition of type DIVISION-BY-ZERO]\" + ((\"ABORT\" \"Return to Slime toplevel.\") + (\"ABORT\" \"Return to Top-Level.\")) + ((0 \"0: (KERNEL::INTEGER-/-INTEGER 1 0)\")))")) From lgorrie at common-lisp.net Sun Nov 23 12:14:04 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 07:14:04 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14521 Modified Files: swank-sbcl.lisp swank-openmcl.lisp swank-cmucl.lisp Log Message: Updated to use new debugger interface in swank-backend.lisp. * swank-cmucl.lisp: Tidied up outline-minor-mode structure and added comments and docstrings. Date: Sun Nov 23 07:14:04 2003 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.24 slime/swank-sbcl.lisp:1.25 --- slime/swank-sbcl.lisp:1.24 Sun Nov 23 00:00:13 2003 +++ slime/swank-sbcl.lisp Sun Nov 23 07:14:04 2003 @@ -412,39 +412,29 @@ (sb-debug::trace-1 fname (sb-debug::make-trace-info)) (format nil "~S is now traced." fname))))) +(defslimefun getpid () + (sb-unix:unix-getpid)) + ;;; Debugging -(defvar *sldb-level* 0) (defvar *sldb-stack-top*) (defvar *sldb-restarts*) -(defslimefun getpid () - (sb-unix:unix-getpid)) - -(defslimefun sldb-loop () - (let* ((*sldb-level* (1+ *sldb-level*)) - (*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame))) +(defmethod call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame))) (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) (sb-debug:*stack-top-hint* nil) (*debugger-hook* nil) - (level *sldb-level*) - (*package* *buffer-package*) (*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*)) - (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) (handler-bind ((sb-di:debug-condition (lambda (condition) - (send-to-emacs `(:debug-condition - ,(princ-to-string condition))) - (throw 'sldb-loop-catcher nil)))) - (unwind-protect - (loop - (catch 'sldb-loop-catcher - (with-simple-restart (abort "Return to sldb level ~D." level) - (read-from-emacs)))) - (send-to-emacs `(:debug-return ,level)))))) + (signal (make-condition + 'sldb-condition + :original-condition condition))))) + (funcall debugger-loop-fn)))) (defun format-restarts-for-emacs () "Return a list of restarts for *swank-debugger-condition* in a @@ -488,7 +478,7 @@ (defslimefun backtrace-for-emacs (start end) (mapcar #'format-frame-for-emacs (compute-backtrace start end))) -(defslimefun debugger-info-for-emacs (start end) +(defmethod debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) (backtrace-for-emacs start end))) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.22 slime/swank-openmcl.lisp:1.23 --- slime/swank-openmcl.lisp:1.22 Sun Nov 23 02:15:14 2003 +++ slime/swank-openmcl.lisp Sun Nov 23 07:14:04 2003 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.22 2003/11/23 07:15:14 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.23 2003/11/23 12:14:04 lgorrie Exp $ ;;; ;;; @@ -157,10 +157,11 @@ :location (let ((position (condition-source-position condition))) (if *buffer-name* - (list :emacs-buffer *buffer-name* position) + (list :emacs-buffer *buffer-name* position t) (list :file (ccl::compiler-warning-file-name condition) - position)))))) + position + t)))))) (defun temp-file-name () "Return a temporary file name to compile strings into." @@ -185,19 +186,17 @@ (delete-file binary-filename))) (delete-file filename)))) +(defslimefun getpid () + "Return the process ID of this superior Lisp." + (ccl::getpid)) + ;;; Debugging -(defvar *sldb-level* 0) (defvar *sldb-stack-top*) (defvar *sldb-restarts*) -(defslimefun getpid () - "Return the process ID of this superior Lisp." - (ccl::getpid)) - -(defslimefun sldb-loop () - (let* ((*sldb-level* (1+ *sldb-level*)) - (*sldb-stack-top* nil) +(defmethod call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* nil) ;; This is a complete hack --- since we're not running at top level we ;; don't want to publish the last restart to Emacs which would allow ;; the user to break outside of the request loop. What's the right @@ -205,15 +204,8 @@ (*sldb-restarts* (butlast (compute-restarts *swank-debugger-condition*))) (*debugger-hook* nil) - (level *sldb-level*) (*package* *buffer-package*)) - (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) - (unwind-protect - (loop - (catch 'sldb-loop-catcher - (with-simple-restart (abort "Return to sldb level ~D." level) - (read-from-emacs)))) - (send-to-emacs `(:debug-return ,level))))) + (funcall debugger-loop-fn))) (defun format-restarts-for-emacs () (loop for restart in *sldb-restarts* @@ -299,7 +291,7 @@ start-frame-number end-frame-number) (nreverse result))) -(defslimefun debugger-info-for-emacs (start end) +(defmethod debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) (backtrace-for-emacs start end))) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.24 slime/swank-cmucl.lisp:1.25 --- slime/swank-cmucl.lisp:1.24 Sun Nov 23 00:00:13 2003 +++ slime/swank-cmucl.lisp Sun Nov 23 07:14:04 2003 @@ -4,11 +4,12 @@ (in-package :swank) +;; Turn on xref. [should we?] +(setf c:*record-xref-info* t) + (defun without-interrupts* (body) (sys:without-interrupts (funcall body))) -;;; Setup and hooks. - (defun set-fd-non-blocking (fd) (flet ((fcntl (fd cmd arg) (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg) @@ -17,10 +18,54 @@ (let ((flags (fcntl fd unix:F-GETFL 0))) (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))) -;; (set-fd-non-blocking (sys:fd-stream-fd sys:*stdin*)) -(setf c:*record-xref-info* t) + +;;;; TCP server. + +(defun create-swank-server (port &key reuse-address (address "localhost")) + "Create a SWANK TCP server." + (let* ((hostent (ext:lookup-host-entry address)) + (address (car (ext:host-entry-addr-list hostent))) + (ip (ext:htonl address))) + (let ((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))))) + +(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)) + +(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 (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))))) -;;; TCP Server. +(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)) + + +;;;; Stream handling (defstruct (slime-output-stream (:include lisp::lisp-stream @@ -107,58 +152,7 @@ (:element-type 'base-char) (:close nil))) -(defun create-swank-server (port &key reuse-address (address "localhost")) - "Create a SWANK TCP server." - (let* ((hostent (ext:lookup-host-entry address)) - (address (car (ext:host-entry-addr-list hostent))) - (ip (ext:htonl address))) - (let ((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))))) - -(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)) - -(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 (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)) - -;;; - -(defslimefun set-default-directory (directory) - (setf (ext:default-directory) (namestring directory)) - ;; Setting *default-pathname-defaults* to an absolute directory - ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. - (setf *default-pathname-defaults* (pathname (ext:default-directory))) - (namestring (ext:default-directory))) - + ;;;; Compilation Commands (defvar *swank-source-info* nil @@ -184,6 +178,7 @@ (defvar *compiler-notes* '() "List of compiler notes for the last compilation unit.") + ;;;;; Trapping notes (defun handle-notification-condition (condition) @@ -261,8 +256,8 @@ (source (eql nil))) '(:null)) -;;(defun call-trapping-compilation-notes (fn) (defmacro with-compilation-hooks (() &body body) + "Execute BODY and record the set of compiler notes." `(let ((*previous-compiler-condition* nil) (*previous-context* nil)) (handler-bind ((c::compiler-error #'handle-notification-condition) @@ -291,65 +286,8 @@ :emacs-buffer-offset ,position :emacs-buffer-string ,string)))))) -(defun clear-xref-info (namestring) - "Clear XREF notes pertaining to FILENAME. -This is a workaround for a CMUCL bug: XREF records are cumulative." - (let ((filename (parse-namestring namestring))) - (when c:*record-xref-info* - (dolist (db (list xref::*who-calls* - #+cmu19 xref::*who-is-called* - #+cmu19 xref::*who-macroexpands* - xref::*who-references* - xref::*who-binds* - xref::*who-sets*)) - (maphash (lambda (target contexts) - (setf (gethash target db) - (delete-if - (lambda (ctx) - (xref-context-derived-from-p ctx filename)) - contexts))) - db))))) - -(defun xref-context-derived-from-p (context filename) - (let ((xref-file (xref:xref-context-file context))) - (and xref-file (pathname= filename xref-file)))) - -(defun pathname= (&rest pathnames) - "True if PATHNAMES refer to the same file." - (apply #'string= (mapcar #'unix-truename pathnames))) - -(defun unix-truename (pathname) - (ext:unix-namestring (truename pathname))) - -(defmethod arglist-string (fname) - "Return a string describing the argument list for FNAME. -The result has the format \"(...)\"." - (declare (type string fname)) - (multiple-value-bind (function condition) - (ignore-errors (values (find-symbol-designator fname *buffer-package*))) - (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) - (let ((arglist - (if (not (or (fboundp function) - (functionp function))) - "(-- )" - (let* ((fun (or (macro-function function) - (symbol-function function))) - (df (di::function-debug-function fun)) - (arglist (kernel:%function-arglist fun))) - (cond ((eval:interpreted-function-p fun) - (eval:interpreted-function-arglist fun)) - ((pcl::generic-function-p fun) - (pcl::gf-pretty-arglist fun)) - (arglist arglist) - ;; this should work both for - ;; compiled-debug-function and for - ;; interpreted-debug-function - (df (di::debug-function-lambda-list df)) - (t "()")))))) - (if (stringp arglist) - arglist - (to-string arglist))))) + +;;;; XREF (defslimefun who-calls (function-name) "Return the places where FUNCTION-NAME is called." @@ -410,6 +348,39 @@ (and (every #'< path1 path2) (< (length path1) (length path2)))) +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to FILENAME. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (let ((filename (parse-namestring namestring))) + (when c:*record-xref-info* + (dolist (db (list xref::*who-calls* + #+cmu19 xref::*who-is-called* + #+cmu19 xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + (setf (gethash target db) + (delete-if + (lambda (ctx) + (xref-context-derived-from-p ctx filename)) + contexts))) + db))))) + +(defun xref-context-derived-from-p (context filename) + (let ((xref-file (xref:xref-context-file context))) + (and xref-file (pathname= filename xref-file)))) + +(defun pathname= (&rest pathnames) + "True if PATHNAMES refer to the same file." + (apply #'string= (mapcar #'unix-truename pathnames))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; Find callers and callees + ;;; Find callers and callees by looking at the constant pool of ;;; compiled code objects. We assume every fdefn object in the ;;; constant pool corresponds to a call to that function. A better @@ -573,7 +544,8 @@ (handler-case (funcall finder) (error (e) (list :error (format nil "Error: ~A" e))))))) -;;; + +;;;; Documentation. (defmethod describe-symbol-for-emacs (symbol) (let ((result '())) @@ -652,14 +624,42 @@ (defslimefun describe-alien-enum (symbol-name) (%describe-alien symbol-name :enum)) -;;; Macroexpansion +(defmethod arglist-string (fname) + "Return a string describing the argument list for FNAME. +The result has the format \"(...)\"." + (declare (type string fname)) + (multiple-value-bind (function condition) + (ignore-errors (values (find-symbol-designator fname *buffer-package*))) + (when condition + (return-from arglist-string (format nil "(-- ~A)" condition))) + (let ((arglist + (if (not (or (fboundp function) + (functionp function))) + "(-- )" + (let* ((fun (or (macro-function function) + (symbol-function function))) + (df (di::function-debug-function fun)) + (arglist (kernel:%function-arglist fun))) + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl::gf-pretty-arglist fun)) + (arglist arglist) + ;; this should work both for + ;; compiled-debug-function and for + ;; interpreted-debug-function + (df (di::debug-function-lambda-list df)) + (t "()")))))) + (if (stringp arglist) + arglist + (to-string arglist))))) + + +;;;; Miscellaneous. (defmethod macroexpand-all (form) (walker:macroexpand-all form)) - -;;; - (defun tracedp (fname) (gethash (debug::trace-fdefinition fname) debug::*traced-functions*)) @@ -672,26 +672,34 @@ (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)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (namestring (ext:default-directory))) + -;;; Source-path business +;;;; 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. +;;; 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 @@ -835,40 +843,30 @@ (handler-case (source-location-for-emacs code-location) (t (c) (list :error (debug::safe-condition-message c))))) +(defslimefun getpid () + (unix:unix-getpid)) + -;;; Debugging +;;;; Debugging -(defvar *sldb-level* 0) (defvar *sldb-stack-top*) (defvar *sldb-restarts*) -(defslimefun getpid () - (unix:unix-getpid)) - -(defslimefun sldb-loop () +(defmethod call-with-debugging-environment (debugger-loop-fn) (unix:unix-sigsetmask 0) - (let* ((*sldb-level* (1+ *sldb-level*)) - (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) (debug:*stack-top-hint* nil) (*debugger-hook* nil) - (level *sldb-level*) - (*package* *buffer-package*) (*readtable* (or debug:*debug-readtable* *readtable*)) (*print-level* debug:*debug-print-level*) (*print-length* debug:*debug-print-length*)) - (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) (handler-bind ((di:debug-condition (lambda (condition) - (send-to-emacs `(:debug-condition - ,(princ-to-string condition))) - (throw 'sldb-loop-catcher nil)))) - (unwind-protect - (loop - (catch 'sldb-loop-catcher - (with-simple-restart (abort "Return to sldb level ~D." level) - (read-from-emacs)))) - (send-to-emacs `(:debug-return ,level)))))) + (signal (make-condition + 'sldb-condition + :original-condition condition))))) + (funcall debugger-loop-fn)))) (defun format-restarts-for-emacs () "Return a list of restarts for *swank-debugger-condition* in a @@ -909,7 +907,7 @@ (defslimefun backtrace-for-emacs (start end) (mapcar #'format-frame-for-emacs (compute-backtrace start end))) -(defslimefun debugger-info-for-emacs (start end) +(defmethod debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) (backtrace-for-emacs start end))) @@ -955,7 +953,7 @@ (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) -;;; Inspecting +;;;; Inspecting (defvar *inspectee*) (defvar *inspectee-parts*) From lgorrie at common-lisp.net Sun Nov 23 12:14:48 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 07:14:48 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15042 Modified Files: swank.lisp Log Message: * swank.lisp: Tidied up outline-minor-mode structure, added comments and docstrings. (sldb-loop): Took over the main debugger loop. Date: Sun Nov 23 07:14:48 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.61 slime/swank.lisp:1.62 --- slime/swank.lisp:1.61 Sun Nov 23 00:00:13 2003 +++ slime/swank.lisp Sun Nov 23 07:14:48 2003 @@ -1,4 +1,4 @@ -;;;; -*- Mode: lisp; outline-regexp: ";;;;*"; indent-tabs-mode: nil -*- +;;;; -*- Mode: lisp; outline-regexp: ";;;;+"; indent-tabs-mode: nil -*- ;;; ;;; swank.lisp --- the portable bits ;;; @@ -7,6 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties are ;;; disclaimed. +;;; Currently the package is declared in swank-backend.lisp #+nil (defpackage :swank (:use :common-lisp) @@ -49,7 +50,8 @@ (error "Backend function ~A not implemented." ',fun)) (export ',fun :swank))) -;;; Setup and Hooks + +;;;; Setup and Hooks (defun start-server (port-file-namestring) "Create a SWANK server and write its port number to the file @@ -63,21 +65,37 @@ (when *swank-debug-p* (format *debug-io* "~&;; Swank ready.~%"))) -;;; IO to emacs + +;;;; IO to Emacs +;;; +;;; We have two layers of I/O: +;;; +;;; The lower layer is a socket connection. Emacs sends us forms to +;;; evaluate, and we accept these by calling READ-FROM-EMACS. These +;;; evaluations can send messages back to Emacs as a side-effect by +;;; calling SEND-TO-EMACS. +;;; +;;; The upper layer is streams for redirecting I/O through Emacs, by +;;; mapping I/O requests onto messages. + +;;; These stream variables are all dynamically-bound during request +;;; processing. (defvar *emacs-io* nil - "Bound to a TCP stream to Emacs during request processing.") + "The raw TCP stream connected to Emacs.") (defvar *slime-output* nil - "Bound to a slime-output-stream during request processing.") + "Output stream for writing Lisp output text to Emacs.") (defvar *slime-input* nil - "Bound to a slime-input-stream during request processing.") + "Input stream to read user input from Emacs.") (defvar *slime-io* nil - "Bound to a two-way-stream built from *slime-input* and *slime-output*.") + "Two-way-stream built from *slime-input* and *slime-output*.") -(defparameter *redirect-output* t) +(defparameter *redirect-output* t + "When non-nil redirect Lisp standard I/O to Emacs. +Redirection is done while Lisp is processing a request for Emacs.") (defun read-from-emacs () "Read and process a request from Emacs." @@ -151,7 +169,28 @@ (*package* *swank-io-package*)) (prin1-to-string object)))) -;;; The Reader + +;;;;; Input from Emacs + +(defvar *read-input-catch-tag* 0) + +(defun slime-read-string () + (force-output) + (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) + (send-to-emacs `(:read-string ,*read-input-catch-tag*)) + (let (ok) + (unwind-protect + (prog1 (catch *read-input-catch-tag* + (loop (read-from-emacs))) + (setq ok t)) + (unless ok + (send-to-emacs `(:read-aborted))))))) + +(defslimefun take-input (tag input) + (throw tag input)) + + +;;;; Reading and printing (defvar *buffer-package*) (setf (documentation '*buffer-package* 'symbol) @@ -181,34 +220,52 @@ (find-package (string-upcase name)))) default-package)) -;;; Input from Emacs - -(defvar *read-input-catch-tag* 0) + +;;;; Debugger -(defun slime-read-string () - (force-output) - (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) - (send-to-emacs `(:read-string ,*read-input-catch-tag*)) - (let (ok) - (unwind-protect - (prog1 (catch *read-input-catch-tag* - (loop (read-from-emacs))) - (setq ok t)) - (unless ok - (send-to-emacs `(:read-aborted))))))) - -(defslimefun take-input (tag input) - (throw tag input)) +;;; These variables are dynamically bound during debugging. -;;; Evaluation +(makunbound + (defvar *swank-debugger-condition* nil + "The condition being debugged.")) -(defvar *swank-debugger-condition*) -(defvar *swank-debugger-hook*) +(defvar *sldb-level* 0 + "The current level of recursive debugging.") (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, +then waits to handle further requests from Emacs. Eventually returns +after Emacs causes a restart to be invoked." (let ((*swank-debugger-condition* condition) - (*swank-debugger-hook* hook)) - (sldb-loop))) + (*package* *buffer-package*)) + (let ((*sldb-level* (1+ *sldb-level*))) + (call-with-debugging-environment + (lambda () (sldb-loop *sldb-level*)))))) + +(defun sldb-loop (level) + (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) + (unwind-protect + (loop (catch 'sldb-loop-catcher + (with-simple-restart + (abort "Return to sldb level ~D." level) + (handler-bind ((sldb-condition #'handle-sldb-condition)) + (read-from-emacs))))) + (send-to-emacs `(:debug-return ,level)))) + +(defun handle-sldb-condition (condition) + "Handle an internal debugger condition. +Rather than recursively debug the debugger (a dangerous idea!), these +conditions are simply reported." + (let ((real-condition (original-condition condition))) + (send-to-emacs `(:debug-condition ,(princ-to-string real-condition)))) + (throw 'sldb-loop-catcher nil)) + +(defslimefun sldb-continue () + (continue *swank-debugger-condition*)) + + +;;;; Evaluation (defslimefun eval-string (string buffer-package) (let ((*debugger-hook* #'swank-debugger-hook)) @@ -295,6 +352,7 @@ (let ((*package* *buffer-package*)) (format nil "~{~S~^~%~}" values)))))) + ;;;; Compilation Commands. (defvar *compiler-notes* '() @@ -303,9 +361,6 @@ (defun clear-compiler-notes () (setf *compiler-notes* '())) -(defslimefun features () - (mapcar #'symbol-name *features*)) - (defun canonicalize-filename (filename) (namestring (truename filename))) @@ -334,6 +389,8 @@ :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." (clear-compiler-notes) (multiple-value-bind (result usecs) (handler-bind ((compiler-condition #'record-note-for-condition)) @@ -342,53 +399,19 @@ (list (to-string result) (format nil "~,2F" (/ usecs 1000000.0))))) -(defslimefun swank-compile-string (string buffer start) +(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 start)))) + (compile-string-for-emacs string :buffer buffer :position position)))) (list (to-string result) (format nil "~,2F" (/ usecs 1000000.0))))) -(defslimefun list-all-package-names () - (mapcar #'package-name (list-all-packages))) - - -(defun apropos-symbols (string &optional external-only package) - (remove-if (lambda (sym) - (or (keywordp sym) - (and external-only - (not (equal (symbol-package sym) *buffer-package*)) - (not (symbol-external-p sym))))) - (apropos-list string package))) - -(defun print-output-to-string (fn) - (with-output-to-string (*standard-output*) - (let ((*debug-io* *standard-output*)) - (funcall fn)))) - -(defun print-description-to-string (object) - (print-output-to-string (lambda () (describe object)))) - -(defslimefun describe-symbol (symbol-name) - (print-description-to-string (symbol-from-string symbol-name))) - -(defslimefun describe-function (symbol-name) - (print-description-to-string - (symbol-function (symbol-from-string symbol-name)))) - -(defslimefun documentation-symbol (symbol-name) - (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))))) - + ;;; Macroexpansion (defun apply-macro-expander (expander string) @@ -409,6 +432,7 @@ (defslimefun swank-macroexpand-all (string) (apply-macro-expander #'macroexpand-all string)) + ;;; Completion (defun case-convert (string) @@ -505,7 +529,8 @@ (and (<= (length s1) (length s2)) (string-equal s1 s2 :end2 (length s1)))) -;;; Apropos + +;;;; Documentation (defslimefun apropos-list-for-emacs (name &optional external-only package) "Make an apropos search for Emacs. @@ -552,7 +577,44 @@ (string< (package-name (symbol-package a)) (package-name (symbol-package b))))))) -;;; +(defun apropos-symbols (string &optional external-only package) + (remove-if (lambda (sym) + (or (keywordp sym) + (and external-only + (not (equal (symbol-package sym) *buffer-package*)) + (not (symbol-external-p sym))))) + (apropos-list string package))) + +(defun print-output-to-string (fn) + (with-output-to-string (*standard-output*) + (let ((*debug-io* *standard-output*)) + (funcall fn)))) + +(defun print-description-to-string (object) + (print-output-to-string (lambda () (describe object)))) + +(defslimefun describe-symbol (symbol-name) + (print-description-to-string (symbol-from-string symbol-name))) + +(defslimefun describe-function (symbol-name) + (print-description-to-string + (symbol-function (symbol-from-string symbol-name)))) + +(defslimefun documentation-symbol (symbol-name) + (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))))) + + +;;;; + +(defslimefun list-all-package-names () + (mapcar #'package-name (list-all-packages))) (defslimefun untrace-all () (untrace)) @@ -560,14 +622,8 @@ (defslimefun load-file (filename) (load filename)) -;;; - -(defslimefun sldb-continue () - (continue *swank-debugger-condition*)) - (defslimefun throw-to-toplevel () (throw 'slime-toplevel nil)) - ;;; 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 Sun Nov 23 12:16:33 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 07:16:33 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16072 Modified Files: ChangeLog Log Message: Date: Sun Nov 23 07:16:33 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.104 slime/ChangeLog:1.105 --- slime/ChangeLog:1.104 Sun Nov 23 02:15:57 2003 +++ slime/ChangeLog Sun Nov 23 07:16:33 2003 @@ -1,5 +1,23 @@ 2003-11-23 Luke Gorrie + * slime.el (slime-goto-source-location): Added optional `align-p' + argument for :file and :emacs-buffer location types. This is for + OpenMCL - unlike CMUCL its positions are not character-accurate so + it needs to be aligned to the beginning of the sexp. + + * swank-cmucl.lisp: Tidied up outline-minor-mode structure and + added comments and docstrings. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated + to use new debugger interface in swank-backend.lisp. + + * swank-backend.lisp (call-with-debugging-environment, + sldb-condition, debugger-info-for-emacs): More callbacks defined. + + * swank.lisp: Tidied up outline-minor-mode structure, added + comments and docstrings. + (sldb-loop): Took over the main debugger loop. + * swank-openmcl.lisp: Updated after refactoring of other backends (was broken). From lgorrie at common-lisp.net Sun Nov 23 12:28:44 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 07:28:44 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29222 Modified Files: swank.lisp Log Message: *** empty log message *** Date: Sun Nov 23 07:28:44 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.62 slime/swank.lisp:1.63 --- slime/swank.lisp:1.62 Sun Nov 23 07:14:48 2003 +++ slime/swank.lisp Sun Nov 23 07:28:43 2003 @@ -225,9 +225,8 @@ ;;; These variables are dynamically bound during debugging. -(makunbound - (defvar *swank-debugger-condition* nil - "The condition being debugged.")) +;; The condition being debugged. +(defvar *swank-debugger-condition* nil) (defvar *sldb-level* 0 "The current level of recursive debugging.") From lgorrie at common-lisp.net Sun Nov 23 13:40:45 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 08:40: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-serv31380 Modified Files: slime.el Log Message: (slime-connect): Don't delete a random window when *inferior-lisp* isn't visible. Date: Sun Nov 23 08:40:45 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.103 slime/slime.el:1.104 --- slime/slime.el:1.103 Sun Nov 23 07:12:59 2003 +++ slime/slime.el Sun Nov 23 08:40:45 2003 @@ -816,8 +816,9 @@ (message "Connecting to Swank on port %S.." port) (slime-net-connect "localhost" port) (slime-init-connection) - (delete-windows-on (get-buffer "*inferior-lisp*")) - (bury-buffer (get-buffer "*inferior-lisp*")) + (when-let (buffer (get-buffer "*inferior-lisp*")) + (delete-windows-on buffer) + (bury-buffer (get-buffer "*inferior-lisp*"))) (pop-to-buffer (slime-output-buffer)) (message "Connected to Swank server on port %S. %s" port (slime-random-words-of-encouragement))) From lgorrie at common-lisp.net Sun Nov 23 13:40:54 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 08:40:54 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31412 Modified Files: ChangeLog Log Message: Date: Sun Nov 23 08:40:54 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.105 slime/ChangeLog:1.106 --- slime/ChangeLog:1.105 Sun Nov 23 07:16:33 2003 +++ slime/ChangeLog Sun Nov 23 08:40:53 2003 @@ -4,6 +4,8 @@ argument for :file and :emacs-buffer location types. This is for OpenMCL - unlike CMUCL its positions are not character-accurate so it needs to be aligned to the beginning of the sexp. + (slime-connect): Don't delete a random window when *inferior-lisp* + isn't visible. * swank-cmucl.lisp: Tidied up outline-minor-mode structure and added comments and docstrings. From lgorrie at common-lisp.net Sun Nov 23 14:11:00 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 09:11:00 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17095 Modified Files: slime.el Log Message: (sldb-fetch-more-frames): Call swank:backtrace instead of (renamed) swank:backtrace-for-emacs. Date: Sun Nov 23 09:11:00 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.104 slime/slime.el:1.105 --- slime/slime.el:1.104 Sun Nov 23 08:40:45 2003 +++ slime/slime.el Sun Nov 23 09:10:59 2003 @@ -3183,7 +3183,7 @@ (let ((start (1+ previous)) (end (+ previous 40))) (sldb-insert-frames - (slime-eval `(swank:backtrace-for-emacs ,start ,end)) + (slime-eval `(swank:backtrace ,start ,end)) (- end start)))))))) (defun sldb-default-action/mouse (event) From lgorrie at common-lisp.net Sun Nov 23 14:13:05 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 09:13:05 -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-serv17394 Modified Files: swank-backend.lisp Log Message: (backtrace, eval-in-frame, frame-catch-tags, frame-locals, frame-source-location-for-emacs): More interface functions. Date: Sun Nov 23 09:13:05 2003 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.2 slime/swank-backend.lisp:1.3 --- slime/swank-backend.lisp:1.2 Sun Nov 23 07:13:19 2003 +++ slime/swank-backend.lisp Sun Nov 23 09:13:05 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.2 2003/11/23 12:13:19 lgorrie Exp $ +;;; $Id: swank-backend.lisp,v 1.3 2003/11/23 14:13:05 lgorrie Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -16,6 +16,7 @@ (defpackage :swank (:use :common-lisp) + (:nicknames #:swank-backend) (:export #:start-server #:create-swank-server #:*sldb-pprint-frames*)) @@ -163,4 +164,65 @@ (\"ABORT\" \"Return to Top-Level.\")) ((0 \"0: (KERNEL::INTEGER-/-INTEGER 1 0)\")))")) +(defgeneric backtrace (start end) + (:documentation + "Return a list containing a backtrace of the condition current +being debugged. The results are unspecified if this function is +called outside the dynamic contour of a debugger hook defined by +DEFINE-DEBUGGER-HOOK. + +START and END are zero-based indices constraining the number of +frames returned. Frame zero is defined as the frame which invoked +the debugger. + +The backtrace is returned as a list of tuples of the form +\(FRAME-NUMBER FRAME-DESCRIPTION), where FRAME-NUMBER is the +index of the frame, defined like START/END, and FRAME-DESCRIPTION +is a string containing text to display in the debugger for this +frame. + +An example return value: + + ((0 \"(HELLO \"world\")\") + (1 \"(RUN-EXCITING-LISP-DEMO)\") + (2 \"(SYS::%TOPLEVEL #)\"))")) + +(defgeneric frame-source-location-for-emacs (frame-number) + (:documentation + "Return the source location for FRAME-NUMBER.")) + +(defgeneric frame-catch-tags (frame-number) + (:documentation + "Return a list of XXX list of what? catch tags for a debugger +stack frame. The results are undefined unless this is called +within the dynamic contour of a function defined by +DEFINE-DEBUGGER-HOOK.")) + +(defgeneric frame-locals (frame-number) + (:documentation + "Return a list of XXX local variable designators define me +for a debugger stack frame. The results are undefined unless +this is called within the dynamic contour of a function defined +by DEFINE-DEBUGGER-HOOK.")) + +(defgeneric eval-in-frame (form frame-number) + (:documentation + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. The results are undefined unless called in the +dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.")) + + +;;;; Queries + +(defgeneric function-source-location-for-emacs (function-name) + (:documentation + "Return the canonical source location FUNCTION-NAME. + +FIXME: Document the plethora of valid return types.")) From lgorrie at common-lisp.net Sun Nov 23 14:16:42 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 09:16:42 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19134 Modified Files: swank.lisp swank-sbcl.lisp swank-openmcl.lisp swank-cmucl.lisp Log Message: Updated to use new debugger interfaces in swank-backend.lisp. Date: Sun Nov 23 09:16:42 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.63 slime/swank.lisp:1.64 --- slime/swank.lisp:1.63 Sun Nov 23 07:28:43 2003 +++ slime/swank.lisp Sun Nov 23 09:16:42 2003 @@ -17,7 +17,10 @@ (in-package :swank) ;; Directly exported backend functions. -(export '(arglist-string)) +(export '(arglist-string backtrace function-source-location-for-emacs + frame-locals frame-catch-tags frame-source-position + frame-source-location-for-emacs + eval-in-frame eval-string-in-frame)) (defvar *swank-io-package* (let ((package (make-package "SWANK-IO-PACKAGE"))) @@ -262,6 +265,9 @@ (defslimefun sldb-continue () (continue *swank-debugger-condition*)) + +(defslimefun eval-string-in-frame (string index) + (to-string (swank-backend:eval-in-frame (from-string string) index))) ;;;; Evaluation Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.25 slime/swank-sbcl.lisp:1.26 --- slime/swank-sbcl.lisp:1.25 Sun Nov 23 07:14:04 2003 +++ slime/swank-sbcl.lisp Sun Nov 23 09:16:42 2003 @@ -180,7 +180,7 @@ (setf *default-pathname-defaults* (merge-pathnames directory)) (namestring *default-pathname-defaults*)) -(defslimefun arglist-string (fname) +(defmethod arglist-string (fname) (let ((*print-case* :downcase)) (multiple-value-bind (function condition) (ignore-errors (values @@ -332,7 +332,7 @@ ;; for emacs to attempt to find with a regex :function-name (unless path fname)))) -(defslimefun function-source-location-for-emacs (fname-string) +(defmethod function-source-location-for-emacs (fname-string) "Return the source-location of FNAME's definition." (let* ((fname (from-string fname-string))) (labels ((finder (fname) @@ -475,13 +475,13 @@ while f collect f))))) -(defslimefun backtrace-for-emacs (start end) +(defmethod backtrace (start end) (mapcar #'format-frame-for-emacs (compute-backtrace start end))) (defmethod debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) - (backtrace-for-emacs start end))) + (backtrace start end))) (defun code-location-source-path (code-location) (let* ((location (sb-debug::maybe-block-start-location code-location)) @@ -536,15 +536,15 @@ (handler-case (source-location-for-emacs code-location) (t (c) (list :error (princ-to-string c))))) -(defslimefun frame-source-location-for-emacs (index) +(defmethod frame-source-location-for-emacs (index) (safe-source-location-for-emacs (sb-di:frame-code-location (nth-frame index)))) #+nil -(defslimefun eval-string-in-frame (string index) - (to-string (sb-di:eval-in-frame (nth-frame index) (from-string string)))) +(defmethod eval-in-frame (form index) + (sb-di:eval-in-frame (nth-frame index) string)) -(defslimefun frame-locals (index) +(defmethod frame-locals (index) (let* ((frame (nth-frame index)) (location (sb-di:frame-code-location frame)) (debug-function (sb-di:frame-debug-fun frame)) @@ -560,7 +560,7 @@ (to-string (sb-di:debug-var-value v frame)) ""))))) -(defslimefun frame-catch-tags (index) +(defmethod frame-catch-tags (index) (loop for (tag . code-location) in (sb-di:frame-catches (nth-frame index)) collect `(,tag . ,(safe-source-location-for-emacs code-location)))) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.23 slime/swank-openmcl.lisp:1.24 --- slime/swank-openmcl.lisp:1.23 Sun Nov 23 07:14:04 2003 +++ slime/swank-openmcl.lisp Sun Nov 23 09:16: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.23 2003/11/23 12:14:04 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.24 2003/11/23 14:16:42 lgorrie Exp $ ;;; ;;; @@ -256,9 +256,7 @@ result)))))) (format nil "~{ ~A~}" (nreverse result))))) -(defslimefun backtrace-for-emacs (&optional - (start-frame-number 0) - (end-frame-number most-positive-fixnum)) +(defmethod backtrace (start-frame-number end-frame-number) "Return a list containing a stack backtrace of the condition currently being debugged. The return value of this function is unspecified unless called in the dynamic contour of a function @@ -294,9 +292,9 @@ (defmethod debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) - (backtrace-for-emacs start end))) + (backtrace start end))) -(defslimefun frame-locals (index) +(defmethod frame-locals (index) (map-backtrace #'(lambda (frame-number p tcr lfun pc) (when (= frame-number index) @@ -316,7 +314,7 @@ result)))) (return-from frame-locals (nreverse result)))))))) -(defslimefun frame-catch-tags (index) +(defmethod frame-catch-tags (index) (declare (ignore index)) nil) @@ -330,7 +328,7 @@ (let ((filename (namestring (truename source-info)))) (list :openmcl filename (symbol-name symbol)))))) -(defslimefun frame-source-location-for-emacs (index) +(defmethod frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the function in a debugger frame. In OpenMCL, we are not able to find the precise position of the frame, but we do attempt to give Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.25 slime/swank-cmucl.lisp:1.26 --- slime/swank-cmucl.lisp:1.25 Sun Nov 23 07:14:04 2003 +++ slime/swank-cmucl.lisp Sun Nov 23 09:16:42 2003 @@ -530,7 +530,7 @@ (when location (source-location-for-emacs location)))))) -(defslimefun function-source-location-for-emacs (fname) +(defmethod function-source-location-for-emacs (fname) "Return the source-location of FNAME's definition." (let* ((fname (from-string fname)) (finder @@ -904,19 +904,19 @@ while f collect f))) -(defslimefun backtrace-for-emacs (start end) +(defmethod backtrace (start end) (mapcar #'format-frame-for-emacs (compute-backtrace start end))) (defmethod debugger-info-for-emacs (start end) (list (format-condition-for-emacs) (format-restarts-for-emacs) - (backtrace-for-emacs start end))) + (backtrace start end))) -(defslimefun frame-source-location-for-emacs (index) +(defmethod frame-source-location-for-emacs (index) (safe-source-location-for-emacs (di:frame-code-location (nth-frame index)))) -(defslimefun eval-string-in-frame (string index) - (to-string (di:eval-in-frame (nth-frame index) (from-string string)))) +(defmethod eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) (defslimefun pprint-eval-string-in-frame (string index) (swank-pprint @@ -927,7 +927,7 @@ (reset-inspector) (inspect-object (di:eval-in-frame (nth-frame index) (from-string string)))) -(defslimefun frame-locals (index) +(defmethod frame-locals (index) (let* ((frame (nth-frame index)) (location (di:frame-code-location frame)) (debug-function (di:frame-debug-function frame)) @@ -942,7 +942,7 @@ (to-string (di:debug-variable-value v frame)) ""))))) -(defslimefun frame-catch-tags (index) +(defmethod frame-catch-tags (index) (loop for (tag . code-location) in (di:frame-catches (nth-frame index)) collect `(,tag . ,(safe-source-location-for-emacs code-location)))) From lgorrie at common-lisp.net Sun Nov 23 14:20:51 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 09:20:51 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20993 Modified Files: ChangeLog Log Message: Date: Sun Nov 23 09:20:51 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.106 slime/ChangeLog:1.107 --- slime/ChangeLog:1.106 Sun Nov 23 08:40:53 2003 +++ slime/ChangeLog Sun Nov 23 09:20:50 2003 @@ -1,5 +1,15 @@ 2003-11-23 Luke Gorrie + * slime.el (sldb-fetch-more-frames): Call swank:backtrace instead + of (renamed) swank:backtrace-for-emacs. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated + to use new debugger interfaces in swank-backend.lisp. + + * swank-backend.lisp (backtrace, eval-in-frame, frame-catch-tags, + frame-locals, frame-source-location-for-emacs): More interface + functions. + * slime.el (slime-goto-source-location): Added optional `align-p' argument for :file and :emacs-buffer location types. This is for OpenMCL - unlike CMUCL its positions are not character-accurate so From dbarlow at common-lisp.net Mon Nov 24 01:41:33 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sun, 23 Nov 2003 20:41:33 -0500 Subject: [slime-cvs] CVS update: slime/README.sbcl Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25689 Removed Files: Tag: FAIRLY-STABLE README.sbcl Log Message: redundant; overtaken by events Date: Sun Nov 23 20:41:33 2003 Author: dbarlow From lgorrie at common-lisp.net Mon Nov 24 03:18:25 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 22:18:25 -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-serv2749 Modified Files: swank-sbcl.lisp Log Message: (function-source-location): Use TRUENAME to resolve source file name (thanks Lawrence Mitchell). Date: Sun Nov 23 22:18:25 2003 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.26 slime/swank-sbcl.lisp:1.27 --- slime/swank-sbcl.lisp:1.26 Sun Nov 23 09:16:42 2003 +++ slime/swank-sbcl.lisp Sun Nov 23 22:18:25 2003 @@ -324,7 +324,7 @@ (pathname (sb-introspect:definition-source-pathname def)) (path (sb-introspect:definition-source-form-path def))) (list :sbcl - :filename (and pathname (namestring pathname)) + :filename (and pathname (namestring (truename pathname))) :position (sb-introspect:definition-source-character-offset def) :path path ;; source-paths depend on the file having been compiled with From lgorrie at common-lisp.net Mon Nov 24 03:19:33 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 22:19:33 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3869 Modified Files: slime.el Log Message: (slime-goto-source-location): Fixes when finding definition by regexp: open the right file (was missed), and tweaked regexp to match more 'def' forms - especially `defmacro-mundanely' (hyphen wasn't allowed before). Date: Sun Nov 23 22:19:33 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.105 slime/slime.el:1.106 --- slime/slime.el:1.105 Sun Nov 23 09:10:59 2003 +++ slime/slime.el Sun Nov 23 22:19:33 2003 @@ -2012,8 +2012,10 @@ filename position info source-path path source-form function-name) (cond (function-name (ignore-errors + (when filename + (set-buffer (find-file-noselect filename))) (goto-char (point-min)) - (re-search-forward (format "^(def\\w+\\s +%s\\s +" + (re-search-forward (format "^(def\\S-+\\s +%s\\s +" function-name)) (beginning-of-line))) ((and (eq filename :lisp) (not buffername)) From lgorrie at common-lisp.net Mon Nov 24 03:19:44 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 22:19:44 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3930 Modified Files: ChangeLog Log Message: Date: Sun Nov 23 22:19:44 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.107 slime/ChangeLog:1.108 --- slime/ChangeLog:1.107 Sun Nov 23 09:20:50 2003 +++ slime/ChangeLog Sun Nov 23 22:19:44 2003 @@ -1,3 +1,13 @@ +2003-11-24 Luke Gorrie + + * swank-sbcl.lisp (function-source-location): Use TRUENAME to + resolve source file name (thanks Lawrence Mitchell). + + * slime.el (slime-goto-source-location): Fixes when finding + definition by regexp: open the right file (was missed), and + tweaked regexp to match more 'def' forms - especially + `defmacro-mundanely' (hyphen wasn't allowed before). + 2003-11-23 Luke Gorrie * slime.el (sldb-fetch-more-frames): Call swank:backtrace instead From lgorrie at common-lisp.net Mon Nov 24 03:23:32 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 22:23:32 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4978 Modified Files: swank.lisp Log Message: (eval-string-in-frame): Fixed symbol-visibility problem (thanks Lawrence Mitchell). Date: Sun Nov 23 22:23:32 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.64 slime/swank.lisp:1.65 --- slime/swank.lisp:1.64 Sun Nov 23 09:16:42 2003 +++ slime/swank.lisp Sun Nov 23 22:23:32 2003 @@ -267,7 +267,7 @@ (continue *swank-debugger-condition*)) (defslimefun eval-string-in-frame (string index) - (to-string (swank-backend:eval-in-frame (from-string string) index))) + (to-string (eval-in-frame (from-string string) index))) ;;;; Evaluation From lgorrie at common-lisp.net Mon Nov 24 03:24:36 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 23 Nov 2003 22:24:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6094 Modified Files: ChangeLog Log Message: Date: Sun Nov 23 22:24:36 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.108 slime/ChangeLog:1.109 --- slime/ChangeLog:1.108 Sun Nov 23 22:19:44 2003 +++ slime/ChangeLog Sun Nov 23 22:24:36 2003 @@ -1,5 +1,8 @@ 2003-11-24 Luke Gorrie + * swank.lisp (eval-string-in-frame): Fixed symbol-visibility + problem (thanks Lawrence Mitchell). + * swank-sbcl.lisp (function-source-location): Use TRUENAME to resolve source file name (thanks Lawrence Mitchell). From lgorrie at common-lisp.net Mon Nov 24 13:43:42 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 24 Nov 2003 08:43:42 -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-serv2641 Modified Files: swank-backend.lisp Log Message: (compiler-condition): Removed use of :documentation slot option. That is not portable (to CMUCL 18e). Date: Mon Nov 24 08:43:42 2003 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.3 slime/swank-backend.lisp:1.4 --- slime/swank-backend.lisp:1.3 Sun Nov 23 09:13:05 2003 +++ slime/swank-backend.lisp Mon Nov 24 08:43:42 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.3 2003/11/23 14:13:05 lgorrie Exp $ +;;; $Id: swank-backend.lisp,v 1.4 2003/11/24 13:43:42 lgorrie Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -47,7 +47,6 @@ :accessor severity) (message - :documentation "The error or warning message, must be a non-NIL string." :initarg :message :accessor message) From lgorrie at common-lisp.net Mon Nov 24 13:45:48 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 24 Nov 2003 08:45:48 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4289 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Nov 24 08:45:47 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.109 slime/ChangeLog:1.110 --- slime/ChangeLog:1.109 Sun Nov 23 22:24:36 2003 +++ slime/ChangeLog Mon Nov 24 08:45:47 2003 @@ -1,5 +1,8 @@ 2003-11-24 Luke Gorrie + * swank-backend.lisp (compiler-condition): Removed use of + :documentation slot option. That is not portable (to CMUCL 18e). + * swank.lisp (eval-string-in-frame): Fixed symbol-visibility problem (thanks Lawrence Mitchell). From dbarlow at common-lisp.net Tue Nov 25 00:22:11 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 24 Nov 2003 19:22:11 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4791 Modified Files: ChangeLog Log Message: Minor updates for currency Date: Mon Nov 24 19:22:11 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.110 slime/ChangeLog:1.111 --- slime/ChangeLog:1.110 Mon Nov 24 08:45:47 2003 +++ slime/ChangeLog Mon Nov 24 19:22:11 2003 @@ -1,3 +1,13 @@ +2003-11-25 Daniel Barlow + + * swank-sbcl.lisp: delete big chunk of leftover commented-out + code + + * slime.el: arglist command to use slime-read-symbol-name, + not slime-read-symbol + + * README: Minor updates for currency + 2003-11-24 Luke Gorrie * swank-backend.lisp (compiler-condition): Removed use of From dbarlow at common-lisp.net Tue Nov 25 00:22:36 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 24 Nov 2003 19:22:36 -0500 Subject: [slime-cvs] CVS update: slime/README Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4862 Modified Files: README Log Message: Minor updates for currency Date: Mon Nov 24 19:22:36 2003 Author: dbarlow Index: slime/README diff -u slime/README:1.8 slime/README:1.9 --- slime/README:1.8 Tue Oct 21 15:29:52 2003 +++ slime/README Mon Nov 24 19:22:36 2003 @@ -3,13 +3,12 @@ SLIME is the Superior Lisp Interaction Mode for Emacs. It is implemented in two main parts: the Emacs Lisp side (slime.el), and - the support library for the Common Lisp (swank.lisp for CMUCL, - swank-sbcl.lisp, swank-openmcl.lisp for the others) + the support library for the Common Lisp (swank.lisp and swank-*.lisp) For a real description, see the commentary in slime.el. -Quick setup instructions for CMUCL ----------------------------------------- +Quick setup instructions +------------------------ In Emacs Lisp: @@ -20,8 +19,8 @@ Make sure your `inferior-lisp-program' is set to a compatible version of Lisp. For CMUCL we currently require version 18e or - later. For SBCL we require the "sb-introspect" contrib, which exist - in the current CVS version. + later. For SBCL we require the "sb-introspect" contrib, for which + you need 0.8.5 or later. Use `M-x' slime to fire up and connect to an inferior Lisp. @@ -53,7 +52,6 @@ Questions and comments are best directed to the mailing list: http://common-lisp.net/mailman/listinfo/slime-devel - The mailing list archive was once on Gmane, and soon will be again, - when they catch up with our change of project hosting provider + The mailing list archive is also avalable on Gmane: http://news.gmane.org/gmane.lisp.slime.devel From dbarlow at common-lisp.net Tue Nov 25 00:23:17 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 24 Nov 2003 19:23: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-serv4947 Modified Files: slime.el Log Message: * slime.el: arglist command to use slime-read-symbol-name, not slime-read-symbol Date: Mon Nov 24 19:23:17 2003 Author: dbarlow Index: slime/slime.el diff -u slime/slime.el:1.106 slime/slime.el:1.107 --- slime/slime.el:1.106 Sun Nov 23 22:19:33 2003 +++ slime/slime.el Mon Nov 24 19:23:13 2003 @@ -2190,7 +2190,7 @@ "Show the argument list for the nearest function call, if any. If SHOW-FN is non-nil, it is funcall'd with the result instead of printing a message." - (interactive (list (slime-read-symbol "Arglist of: "))) + (interactive (list (slime-read-symbol-name "Arglist of: "))) (slime-eval-async `(swank:arglist-string ,symbol-name) (slime-buffer-package) From dbarlow at common-lisp.net Tue Nov 25 00:23:28 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 24 Nov 2003 19:23:28 -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-serv5116 Modified Files: swank-sbcl.lisp Log Message: * swank-sbcl.lisp: delete big chunk of leftover commented-out code Date: Mon Nov 24 19:23:28 2003 Author: dbarlow Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.27 slime/swank-sbcl.lisp:1.28 --- slime/swank-sbcl.lisp:1.27 Sun Nov 23 22:18:25 2003 +++ slime/swank-sbcl.lisp Mon Nov 24 19:23:27 2003 @@ -108,69 +108,6 @@ (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*)) (close *emacs-io*))))) -#| - -;; 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'." - (sb-thread:make-thread - (lambda () (swank-main-loop port reuse-address)))) - -(defun swank-main-loop (port reuse-address) - "Create the TCP server and accept connections in a new thread." - (let ((server-socket (make-instance 'inet-socket - :type :stream :protocol :tcp))) - (unwind-protect - (progn - (when reuse-address - (setf (sockopt-reuse-address server-socket) t)) - (socket-bind server-socket #(127 0 0 1) port) - (socket-listen server-socket 10) - (format *terminal-io* - "~&;; Swank: Accepting connections on port ~D.~%" - port) - (loop - (let ((socket (socket-accept server-socket))) - (format *terminal-io* - "~&;; Swank: Accepted connection ~A~%" socket) - (sb-thread:make-thread - (lambda () - (sb-sys:enable-interrupt - sb-unix:sigint #'sb-unix::sigint-handler) - (let ((*emacs-io* - (socket-make-stream socket - :element-type '(unsigned-byte 8) - :input t - :output t - :buffering :none))) - (request-loop))))))) - (socket-close server-socket)))) - -(defun request-loop () - "Thread function for a single Swank connection. Processes requests -until the remote Emacs goes away." - (unwind-protect - (loop - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime event loop.") - (let ((completed nil)) - (let ((*slime-output* (make-instance 'slime-output-stream))) - (let ((condition (catch 'serve-request-catcher - (read-from-emacs) - (setq completed t)))) - (close *slime-output*) - (unless completed - (when *swank-debug-p* - (format *terminal-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" - condition)) - (return)))))))) - (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) - (close *emacs-io*))) -|# - ;;; Utilities (defvar *swank-debugger-stack-frame*) From lgorrie at common-lisp.net Tue Nov 25 19:56:09 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 25 Nov 2003 14:56: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-serv8900 Modified Files: slime.el Log Message: (slime-make-typeout-frame): New command to create a frame where commands can print messages that would otherwise go to the echo area. (slime-incidental-message): Function for printing "background" messages. Uses the "typeout-frame" if it exists. (slime-arglist): Print arglist with `slime-incidental-message'. (slime-message): Use typeout frame if it exists, but only for multi-line messages. Date: Tue Nov 25 14:55:47 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.107 slime/slime.el:1.108 --- slime/slime.el:1.107 Mon Nov 24 19:23:13 2003 +++ slime/slime.el Tue Nov 25 14:55:34 2003 @@ -565,17 +565,19 @@ (when (get-buffer-window buffer-name) (delete-windows-on buffer-name)) (cond ((or (string-match "\n" message) (> (length message) (1- (frame-width)))) - (lexical-let ((buffer (get-buffer-create buffer-name))) - (with-current-buffer buffer - (erase-buffer) - (insert message) - (goto-char (point-min)) - (let ((win (slime-create-message-window))) - (set-window-buffer win (current-buffer)) - (shrink-window-if-larger-than-buffer - (display-buffer (current-buffer))))) - (push (lambda () (delete-windows-on buffer) (bury-buffer buffer)) - slime-pre-command-actions))) + (if (slime-typeout-active-p) + (slime-typeout-message message) + (lexical-let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (erase-buffer) + (insert message) + (goto-char (point-min)) + (let ((win (slime-create-message-window))) + (set-window-buffer win (current-buffer)) + (shrink-window-if-larger-than-buffer + (display-buffer (current-buffer))))) + (push (lambda () (delete-windows-on buffer) (bury-buffer buffer)) + slime-pre-command-actions)))) (t (message "%s" message)))) ;; defun slime-message @@ -587,6 +589,15 @@ (defun slime-message (fmt &rest args) (apply 'message fmt args))) +(defun slime-incidental-message (format-string &rest format-args) + "Display a message in passing. +This is like `slime-message', but less distracting because it +will never pop up a buffer. +It should be used for \"background\" messages such as argument lists." + (apply (if (slime-typeout-active-p) #'slime-typeout-message #'message) + format-string + format-args)) + (defun slime-set-truncate-lines () "Set `truncate-lines' in the current buffer if `slime-truncate-lines' is non-nil." @@ -2198,7 +2209,7 @@ (lambda (arglist) (if show-fn (funcall show-fn arglist) - (message "%s" (slime-format-arglist symbol-name arglist))))))) + (slime-incidental-message "%s" (slime-format-arglist symbol-name arglist))))))) (defun slime-get-arglist (symbol-name) "Return the argument list for SYMBOL-NAME." @@ -2283,6 +2294,38 @@ (error (setq slime-autodoc-mode nil) (message "Error: %S; slime-autodoc-mode now disabled." err))))) + + +;;; Typeout frame + +;; When a "typeout frame" is exists, it is used to display certain +;; messages instead of the echo area or pop-up windows. + +(defvar slime-typeout-window nil + "The current typeout window.") + +(defvar slime-typeout-frame-properties + '((height . 16) (minibuffer . nil) (name . "SLIME Typeout")) + "The typeout frame properties (passed to `make-frame').") + +(defun slime-typeout-active-p () + (and slime-typeout-window + (window-live-p slime-typeout-window))) + +(defun slime-typeout-message (format-string &rest format-args) + (assert (slime-typeout-active-p)) + (with-current-buffer (window-buffer slime-typeout-window) + (erase-buffer) + (insert (apply #'format format-string format-args)))) + +(defun slime-make-typeout-frame () + "Create a frame for displaying messages (e.g. arglists)." + (interactive) + (let ((frame (make-frame slime-typeout-frame-properties))) + (save-selected-window + (select-window (frame-selected-window frame)) + (switch-to-buffer "*SLIME-Typeout*") + (setq slime-typeout-window (selected-window))))) ;;; Completion From lgorrie at common-lisp.net Tue Nov 25 19:57:14 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 25 Nov 2003 14:57:14 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9241 Modified Files: ChangeLog Log Message: Date: Tue Nov 25 14:57:14 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.111 slime/ChangeLog:1.112 --- slime/ChangeLog:1.111 Mon Nov 24 19:22:11 2003 +++ slime/ChangeLog Tue Nov 25 14:57:14 2003 @@ -1,3 +1,14 @@ +2003-11-25 Luke Gorrie + + * slime.el (slime-make-typeout-frame): New command to create a + frame where commands can print messages that would otherwise go to + the echo area. + (slime-incidental-message): Function for printing "background" + messages. Uses the "typeout-frame" if it exists. + (slime-arglist): Print arglist with `slime-incidental-message'. + (slime-message): Use typeout frame if it exists, but only for + multi-line messages. + 2003-11-25 Daniel Barlow * swank-sbcl.lisp: delete big chunk of leftover commented-out From lgorrie at common-lisp.net Tue Nov 25 19:59:39 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 25 Nov 2003 14:59: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-serv10576 Modified Files: slime.el Log Message: *** empty log message *** Date: Tue Nov 25 14:59:39 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.108 slime/slime.el:1.109 --- slime/slime.el:1.108 Tue Nov 25 14:55:34 2003 +++ slime/slime.el Tue Nov 25 14:59:39 2003 @@ -2298,7 +2298,7 @@ ;;; Typeout frame -;; When a "typeout frame" is exists, it is used to display certain +;; When a "typeout frame" exists it is used to display certain ;; messages instead of the echo area or pop-up windows. (defvar slime-typeout-window nil From lgorrie at common-lisp.net Tue Nov 25 21:28:24 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 25 Nov 2003 16:28:24 -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-serv15796 Modified Files: slime.el ChangeLog Log Message: s/slime-incidental-message/slime-background-message/ Date: Tue Nov 25 16:28:23 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.109 slime/slime.el:1.110 --- slime/slime.el:1.109 Tue Nov 25 14:59:39 2003 +++ slime/slime.el Tue Nov 25 16:28:23 2003 @@ -589,7 +589,7 @@ (defun slime-message (fmt &rest args) (apply 'message fmt args))) -(defun slime-incidental-message (format-string &rest format-args) +(defun slime-background-message (format-string &rest format-args) "Display a message in passing. This is like `slime-message', but less distracting because it will never pop up a buffer. @@ -2209,7 +2209,7 @@ (lambda (arglist) (if show-fn (funcall show-fn arglist) - (slime-incidental-message "%s" (slime-format-arglist symbol-name arglist))))))) + (slime-background-message "%s" (slime-format-arglist symbol-name arglist))))))) (defun slime-get-arglist (symbol-name) "Return the argument list for SYMBOL-NAME." Index: slime/ChangeLog diff -u slime/ChangeLog:1.112 slime/ChangeLog:1.113 --- slime/ChangeLog:1.112 Tue Nov 25 14:57:14 2003 +++ slime/ChangeLog Tue Nov 25 16:28:23 2003 @@ -3,9 +3,9 @@ * slime.el (slime-make-typeout-frame): New command to create a frame where commands can print messages that would otherwise go to the echo area. - (slime-incidental-message): Function for printing "background" + (slime-background-message): Function for printing "background" messages. Uses the "typeout-frame" if it exists. - (slime-arglist): Print arglist with `slime-incidental-message'. + (slime-arglist): Print arglist with `slime-background-message'. (slime-message): Use typeout frame if it exists, but only for multi-line messages. From lgorrie at common-lisp.net Wed Nov 26 23:39:08 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 18:39:08 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30574 Modified Files: swank.lisp Log Message: (completions): Complete compound symbols. Date: Wed Nov 26 18:39:07 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.65 slime/swank.lisp:1.66 --- slime/swank.lisp:1.65 Sun Nov 23 22:23:32 2003 +++ slime/swank.lisp Wed Nov 26 18:39:07 2003 @@ -473,7 +473,7 @@ (find-package (case-convert n)) *buffer-package* )))) (flet ((symbol-matches-p (symbol) - (and (string-prefix-p name (symbol-name symbol)) + (and (compound-string-match name (symbol-name symbol)) (or (or internal-p (null package-name)) (symbol-external-p symbol package))))) (when package @@ -533,6 +533,42 @@ \(This includes the case where S1 is equal to S2.)" (and (<= (length s1) (length s2)) (string-equal s1 s2 :end2 (length s1)))) + +(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. +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)))))) + ;;;; Documentation From lgorrie at common-lisp.net Wed Nov 26 23:40:07 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 18:40: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-serv31000 Modified Files: slime.el Log Message: (slime-complete-symbol): Use `completer' package to handle more sophisticated completions. This includes abbreviations like "m-v-b" => "multiple-value-bind". It also (somewhat scarily) redefines other standard Emacs completion functions with similar capabilities. See commentary in completer.erl for details. Date: Wed Nov 26 18:40:07 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.110 slime/slime.el:1.111 --- slime/slime.el:1.110 Tue Nov 25 16:28:23 2003 +++ slime/slime.el Wed Nov 26 18:40:07 2003 @@ -58,6 +58,7 @@ (require 'hideshow) (require 'hyperspec) (require 'font-lock) +(require 'completer) (when (featurep 'xemacs) (require 'overlay)) (eval-when (compile load eval) @@ -2389,33 +2390,27 @@ ;; 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) - (let* ((end (point)) + (let* ((end (slime-symbol-end-pos)) (beg (slime-symbol-start-pos)) (prefix (buffer-substring-no-properties beg end)) - (completions (slime-completions prefix)) - (completions-alist (slime-bogus-completion-alist completions)) - (completion (try-completion prefix completions-alist nil))) - (cond ((eq completion t) - (message "[Sole completion]") - (slime-complete-restore-window-configuration)) - ((null completion) - (message "Can't find completion for \"%s\"" prefix) - (ding) - (slime-complete-restore-window-configuration)) - ((not (string= prefix completion)) - (delete-region beg end) - (insert-and-inherit completion) - (cond ((null (cdr completions)) - (slime-complete-restore-window-configuration)) - (t (slime-complete-delay-restoration)))) - (t - (message "Making completion list...") - (let ((list (all-completions prefix completions-alist nil))) + (completions (slime-completions prefix))) + (destructuring-bind (match common-substring matches unique-p) + (completer prefix completions nil "-") + (cond ((eq unique-p t) + (message "[Sole completion]") + (delete-region beg end) + (insert match) + (slime-complete-restore-window-configuration)) + ((null match) + (message "Can't find completion for \"%s\"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + (t (slime-complete-maybe-save-window-configuration) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list)) - (slime-complete-delay-restoration)) - (message "Making completion list...done"))))) + (completer-display-choices completions) + (slime-complete-delay-restoration) + (completer-goto match common-substring + matches unique-p "^ \t\n\('\"#.\)<>" "-")))))) (defun slime-completing-read-internal (string default-package flag) ;; We misuse the predicate argument to pass the default-package. @@ -2471,6 +2466,11 @@ (backward-sexp 1) (skip-syntax-forward "'") (point))) + +(defun slime-symbol-end-pos () + (save-excursion + (skip-syntax-forward "_") + (min (1+ (point)) (point-max)))) (defun slime-bogus-completion-alist (list) "Make an alist out of list. From lgorrie at common-lisp.net Wed Nov 26 23:40:19 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 18:40:19 -0500 Subject: [slime-cvs] CVS update: slime/completer.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31214 Added Files: completer.el Log Message: Stolen^Wimported from ILISP version 1.4. This is one revision prior to their latest, where they added a (require) for some other ILISP code. I backed down a revision to make it stand-alone, but this may mean that putting SLIME in the load-path before ILISP will break ILISP. So, beware. Date: Wed Nov 26 18:40:19 2003 Author: lgorrie From lgorrie at common-lisp.net Wed Nov 26 23:46:01 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 18:46:01 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1099 Modified Files: ChangeLog Log Message: Date: Wed Nov 26 18:46:00 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.113 slime/ChangeLog:1.114 --- slime/ChangeLog:1.113 Tue Nov 25 16:28:23 2003 +++ slime/ChangeLog Wed Nov 26 18:46:00 2003 @@ -1,3 +1,21 @@ +2003-11-27 Luke Gorrie + + * completer.el: Stolen^Wimported from ILISP version 1.4. This is + one revision prior to their latest, where they added a (require) + for some other ILISP code. I backed down a revision to make it + stand-alone, but this may mean that putting SLIME in the load-path + before ILISP will break ILISP. So, beware. + +2003-11-27 Zach + + * swank.lisp (completions): Complete compound symbols (see below). + + * slime.el (slime-complete-symbol): Use `completer' package to + handle more sophisticated completions. This includes abbreviations + like "m-v-b" => "multiple-value-bind". It also (somewhat scarily) + redefines other standard Emacs completion functions with similar + capabilities. See commentary in completer.erl for details. + 2003-11-25 Luke Gorrie * slime.el (slime-make-typeout-frame): New command to create a From lgorrie at common-lisp.net Thu Nov 27 00:26:34 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 19:26:34 -0500 Subject: [slime-cvs] CVS update: slime/completer.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19152 Modified Files: completer.el Log Message: (completer-message): Cut dependency on undefined ilisp constant testing for xemacs. Date: Wed Nov 26 19:26:34 2003 Author: lgorrie Index: slime/completer.el diff -u slime/completer.el:1.1 slime/completer.el:1.2 --- slime/completer.el:1.1 Wed Nov 26 18:40:19 2003 +++ slime/completer.el Wed Nov 26 19:26:34 2003 @@ -175,12 +175,7 @@ (inhibit-quit t)) (sit-for 2) (delete-region point end) - (if (and quit-flag - ;; (not (eq 'lucid-19 ilisp-emacs-version-id)) - ;; (not (string-match "Lucid" emacs-version)) - (not (memq +ilisp-emacs-version-id+ - '(xemacs lucid-19 lucid-19-new))) - ) + (if (and quit-flag (not (featurep 'xemacs))) (setq quit-flag nil unread-command-char 7)))) From lgorrie at common-lisp.net Thu Nov 27 00:30:30 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 19:30:30 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21329 Modified Files: slime.el Log Message: (slime-complete-symbol): Make a bogus alist out of the completion set, for compatibility with XEmacs. Date: Wed Nov 26 19:30:30 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.111 slime/slime.el:1.112 --- slime/slime.el:1.111 Wed Nov 26 18:40:07 2003 +++ slime/slime.el Wed Nov 26 19:30:30 2003 @@ -2395,7 +2395,7 @@ (prefix (buffer-substring-no-properties beg end)) (completions (slime-completions prefix))) (destructuring-bind (match common-substring matches unique-p) - (completer prefix completions nil "-") + (completer prefix (slime-bogus-completion-alist completions) nil "-") (cond ((eq unique-p t) (message "[Sole completion]") (delete-region beg end) From heller at common-lisp.net Thu Nov 27 00:36:36 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 26 Nov 2003 19:36:36 -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-serv23616 Added Files: swank-lispworks.lisp Log Message: First version. Date: Wed Nov 26 19:36:36 2003 Author: heller From heller at common-lisp.net Thu Nov 27 00:38:08 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 26 Nov 2003 19:38: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-serv24025 Modified Files: swank-loader.lisp Log Message: *sysdep-pathnames*: Add Lispworks files. (compile-files-if-needed-serially): Compile all files in a compilation unit. Date: Wed Nov 26 19:38:08 2003 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.5 slime/swank-loader.lisp:1.6 --- slime/swank-loader.lisp:1.5 Sun Nov 23 00:00:13 2003 +++ slime/swank-loader.lisp Wed Nov 26 19:38:08 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.5 2003/11/23 05:00:13 lgorrie Exp $ +;;; $Id: swank-loader.lisp,v 1.6 2003/11/27 00:38:08 heller Exp $ ;;; (defpackage :swank-loader @@ -27,9 +27,11 @@ (defparameter *sysdep-pathnames* (mapcar #'make-swank-pathname - #+cmu '("swank-cmucl") - #+sbcl '("swank-sbcl" "swank-gray") - #+openmcl '("swank-openmcl" "swank-gray"))) + #+cmu '("swank-cmucl") + #+sbcl '("swank-sbcl" "swank-gray") + #+openmcl '("swank-openmcl" "swank-gray") + #+lispworks '("swank-lispworks" "swank-gray") + )) (defparameter *swank-pathname* (make-swank-pathname "swank")) @@ -41,25 +43,26 @@ "Compile each file in FILES if the source is newer than its corresponding binary, or the file preceding it was recompiled." - (let ((needs-recompile nil)) - (dolist (source-pathname files) - (let ((binary-pathname (compile-file-pathname source-pathname))) - (handler-case - (progn - (when (or needs-recompile - (not (probe-file binary-pathname)) - (file-newer-p source-pathname binary-pathname)) - (format t "~&;; Compiling ~A...~%" source-pathname) - (compile-file source-pathname) - (setq needs-recompile t)) - (load binary-pathname)) - (error () - ;; If an error occurs compiling, load the source instead - ;; so we can try to debug it. - (load source-pathname))))))) + (with-compilation-unit () + (let ((needs-recompile nil)) + (dolist (source-pathname files) + (let ((binary-pathname (compile-file-pathname source-pathname))) + (handler-case + (progn + (when (or needs-recompile + (not (probe-file binary-pathname)) + (file-newer-p source-pathname binary-pathname)) + (format t "~&;; Compiling ~A...~%" source-pathname) + (compile-file source-pathname) + (setq needs-recompile t)) + (load binary-pathname)) + (error () + ;; If an error occurs compiling, load the source instead + ;; so we can try to debug it. + (load source-pathname)))))))) (defun user-init-file () - "Return a the name of the user init file or nil." + "Return the name of the user init file or nil." (let ((filename (format nil "~A/.swank.lisp" (namestring (user-homedir-pathname))))) (cond ((probe-file filename) filename) From heller at common-lisp.net Thu Nov 27 00:40:36 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 26 Nov 2003 19:40:36 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25866 Modified Files: swank.lisp Log Message: (briefly-describe-symbol-for-emacs): Don't return unbound symbols. (load-file): The result of LOAD may be a pathname. Turn it into a string. (describe-symbol, describe-function): Support package-qualified strings. Date: Wed Nov 26 19:40:35 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.66 slime/swank.lisp:1.67 --- slime/swank.lisp:1.66 Wed Nov 26 18:39:07 2003 +++ slime/swank.lisp Wed Nov 26 19:40:35 2003 @@ -16,12 +16,6 @@ (in-package :swank) -;; Directly exported backend functions. -(export '(arglist-string backtrace function-source-location-for-emacs - frame-locals frame-catch-tags frame-source-position - frame-source-location-for-emacs - eval-in-frame eval-string-in-frame)) - (defvar *swank-io-package* (let ((package (make-package "SWANK-IO-PACKAGE"))) (import '(nil t quote) package) @@ -239,6 +233,7 @@ Sends a message to Emacs declaring that the debugger has been entered, then waits to handle further requests from Emacs. Eventually returns after Emacs causes a restart to be invoked." + (declare (ignore hook)) (let ((*swank-debugger-condition* condition) (*package* *buffer-package*)) (let ((*sldb-level* (1+ *sldb-level*))) @@ -586,8 +581,10 @@ (flet ((first-line (string) (let ((pos (position #\newline string))) (if (null pos) string (subseq string 0 pos))))) - (list* :designator (to-string symbol) - (map-if #'stringp #'first-line (describe-symbol-for-emacs symbol))))) + (let ((desc (map-if #'stringp #'first-line + (describe-symbol-for-emacs symbol)))) + (if desc + (list* :designator (to-string symbol) desc))))) (defun map-if (test fn &rest lists) "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. @@ -635,11 +632,11 @@ (print-output-to-string (lambda () (describe object)))) (defslimefun describe-symbol (symbol-name) - (print-description-to-string (symbol-from-string symbol-name))) + (print-description-to-string (find-symbol-designator symbol-name))) (defslimefun describe-function (symbol-name) (print-description-to-string - (symbol-function (symbol-from-string symbol-name)))) + (symbol-function (find-symbol-designator symbol-name)))) (defslimefun documentation-symbol (symbol-name) (let ((*package* *buffer-package*)) @@ -661,7 +658,7 @@ (untrace)) (defslimefun load-file (filename) - (load filename)) + (to-string (load filename))) (defslimefun throw-to-toplevel () (throw 'slime-toplevel nil)) From heller at common-lisp.net Thu Nov 27 00:42:43 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 26 Nov 2003 19:42: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-serv26187 Modified Files: swank-cmucl.lisp Log Message: (function-source-location): Better support for generic functions. (genericp, gf-definition-location, method-source-location, gf-method-locations, gf-source-locations): New functions. (describe-symbol-for-emacs): Mark generic functions as such. Date: Wed Nov 26 19:42:43 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.26 slime/swank-cmucl.lisp:1.27 --- slime/swank-cmucl.lisp:1.26 Sun Nov 23 09:16:42 2003 +++ slime/swank-cmucl.lisp Wed Nov 26 19:42:42 2003 @@ -513,6 +513,37 @@ (t (error "Cannot locate struct without constructor: ~S" (kernel::dd-name dd)))))) +(defun genericp (fn) + (typep fn 'generic-function)) + +(defun gf-definition-location (gf) + (flet ((guess-source-file (faslfile) + (unix-truename + (merge-pathnames (make-pathname :type "lisp") + faslfile)))) + (let ((def-source (pcl::definition-source gf)) + (name (string (pcl:generic-function-name gf)))) + (etypecase def-source + (pathname `(:dspec (:file ,(guess-source-file def-source)) ,name)) + (cons + (destructuring-bind ((dg name) pathname) def-source + (declare (ignore dg)) + (if pathname + `(:dspec (:file ,(guess-source-file pathname)) + ,(string name))))))))) + +(defun method-source-location (method) + (function-source-location (or (pcl::method-fast-function method) + (pcl:method-function method)))) + +(defun gf-method-locations (gf) + (let ((ms (pcl::generic-function-methods gf))) + (mapcar #'method-source-location ms))) + +(defun gf-source-locations (gf) + (list* (gf-definition-location gf) + (gf-method-locations gf))) + (defun function-source-location (function) "Try to find the canonical source location of FUNCTION." ;; First test if FUNCTION is a closure created by defstruct; if so @@ -525,7 +556,9 @@ ;; first code-location we find. (cond ((struct-closure-p function) (dd-source-location (struct-closure-dd function))) - (t + ((genericp function) + (car (gf-source-locations function))) + (t (let ((location (function-first-code-location function))) (when location (source-location-for-emacs location)))))) @@ -561,8 +594,14 @@ (if (or (boundp symbol) recorded-p) (doc 'variable)))) (maybe-push - :function (if (fboundp symbol) - (doc 'function))) + :generic-function + (if (and (fboundp symbol) + (typep (fdefinition symbol) 'generic-function)) + (doc 'function))) + (maybe-push + :function (if (and (fboundp symbol) + (not (typep (fdefinition symbol) 'generic-function))) + (doc 'function))) (maybe-push :setf (if (or (ext:info setf inverse symbol) (ext:info setf expander symbol)) From heller at common-lisp.net Thu Nov 27 00:44:41 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 26 Nov 2003 19:44:41 -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-serv28008 Modified Files: swank-backend.lisp Log Message: List exported symbols explicitly. Date: Wed Nov 26 19:44:40 2003 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.4 slime/swank-backend.lisp:1.5 --- slime/swank-backend.lisp:1.4 Mon Nov 24 08:43:42 2003 +++ slime/swank-backend.lisp Wed Nov 26 19:44:40 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.4 2003/11/24 13:43:42 lgorrie Exp $ +;;; $Id: swank-backend.lisp,v 1.5 2003/11/27 00:44:40 heller Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -18,8 +18,69 @@ (:use :common-lisp) (:nicknames #:swank-backend) (:export #:start-server #:create-swank-server - #:*sldb-pprint-frames*)) - + #:*sldb-pprint-frames* + #:eval-string + #:interactive-eval-region + #:interactive-eval + #:pprint-eval + #:re-evaluate-defvar + #:listener-eval + #:swank-compile-file + #:swank-compile-string + #: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 + #:describe-alien-struct + #:describe-class + #:describe-inspectee + #:describe-alien-union + #:describe-alien-enum + #:describe-setf-function + #: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 + #:function-source-location-for-emacs + #: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 + #:inspector-pop + #:invoke-nth-restart + #:pprint-eval-string-in-frame + #:frame-source-location-for-emacs + #:eval-in-frame + #:eval-string-in-frame + #:sldb-abort + #:sldb-continue + #:take-input + )) (in-package :swank) @@ -125,7 +186,7 @@ (define-condition sldb-condition (condition) ((original-condition :initarg :original-condition - :accessor :original-condition)) + :accessor original-condition)) (:documentation "Wrapper for conditions that should not be debugged. From heller at common-lisp.net Thu Nov 27 00:50:52 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 26 Nov 2003 19:50:52 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30696 Modified Files: slime.el Log Message: (slime-with-output-to-temp-buffer): Save the window configuration in a buffer local variable instead on a global stack. (slime-show-last-output): Make behavior customizable. The default is now simpler and less DWIMish. slime-show-last-output-function: New variable. (slime-show-last-output-region, slime-maybe-display-output-buffer): New functions. (slime-goto-source-location): Add some support for Lispworks style dspecs. Should be merged with OpenMCL stuff. Various tweaking for better multi-frame support. Date: Wed Nov 26 19:50:52 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.112 slime/slime.el:1.113 --- slime/slime.el:1.112 Wed Nov 26 19:30:30 2003 +++ slime/slime.el Wed Nov 26 19:50:52 2003 @@ -665,11 +665,17 @@ (when slime-saved-window-configurations (set-window-configuration (pop slime-saved-window-configurations)))) +(defvar slime-temp-buffer-saved-window-configuration nil + "The window configuration before the temp-buffer was displayed. +Buffer local in temp-buffers.") + (defun slime-temp-buffer-quit () + "Kill the current buffer and restore the old window configuration." (interactive) - (kill-buffer (current-buffer)) - (slime-restore-window-configuration)) - + (let ((config slime-temp-buffer-saved-window-configuration)) + (kill-buffer (current-buffer)) + (set-window-configuration config))) + (defvar slime-temp-buffer-map) (define-minor-mode slime-temp-buffer-mode @@ -683,22 +689,24 @@ (defmacro slime-with-output-to-temp-buffer (name &rest body) "Like `with-output-to-temp-buffer', but saves the window configuration." + (let ((config (gensym))) `(progn - (slime-save-window-configuration) - (let ((standard-output - (with-current-buffer (get-buffer-create ,name) - (setq buffer-read-only nil) - (erase-buffer) - (current-buffer)))) + (let ((,config (current-window-configuration)) + (standard-output (with-current-buffer (get-buffer-create ,name) + (setq buffer-read-only nil) + (erase-buffer) + (current-buffer)))) (prog1 (progn , at body) (with-current-buffer standard-output + (make-local-variable 'slime-temp-buffer-saved-window-configuration) + (setq slime-temp-buffer-saved-window-configuration ,config) (goto-char (point-min)) (slime-mode 1) (set-syntax-table lisp-mode-syntax-table) (slime-temp-buffer-mode 1) (setq buffer-read-only t) - (unless (get-buffer-window (current-buffer)) - (switch-to-buffer-other-window (current-buffer)))))))) + (unless (get-buffer-window (current-buffer) t) + (switch-to-buffer-other-window (current-buffer))))))))) (put 'slime-with-output-to-temp-buffer 'lisp-indent-function 1) @@ -1418,16 +1426,28 @@ " ...\n") (set-marker slime-last-output-start (point) (current-buffer)))) +(defvar slime-show-last-output-function + 'slime-maybe-display-output-buffer + "*This function is called when a evaluation request is finished. +It is called in the slime-output buffer and receives the region of the +output as arguments.") + +(defun slime-show-last-output-region (start end) + (when (< start end) + (slime-display-buffer-region (current-buffer) start + slime-repl-input-start-mark))) + +(defun slime-maybe-display-output-buffer (start end) + (when (and (not (get-buffer-window (current-buffer) t)) + (< start end)) + (display-buffer (current-buffer)))) + (defun slime-show-last-output () - "Show the output from the last Lisp evaluation. -This has no effect if the output buffer is already visible." - (unless (get-buffer-window (slime-output-buffer) t) - (with-current-buffer (slime-output-buffer) - (let ((start slime-last-output-start) - (end slime-repl-prompt-start-mark)) - (when (< start end) - (slime-display-buffer-region (current-buffer) start - slime-repl-input-start-mark)))))) + "Show the output from the last Lisp evaluation." + (with-current-buffer (slime-output-buffer) + (let ((start slime-last-output-start) + (end slime-repl-prompt-start-mark)) + (funcall slime-show-last-output-function start end)))) (defun slime-with-output-at-eob (fn) "Call FN at the eob. In a save-excursion block if we are not at @@ -1458,7 +1478,7 @@ (defun slime-show-output-buffer () (slime-show-last-output) (with-current-buffer (slime-output-buffer) - (display-buffer (slime-output-buffer) t))) + (display-buffer (slime-output-buffer) t t))) ;;; REPL @@ -1781,7 +1801,7 @@ (message "Compiling %s.." (buffer-file-name)) (with-current-buffer (slime-output-buffer) (goto-char (point-max)) - (display-buffer (current-buffer) t))) + (display-buffer (current-buffer) t t))) (defun slime-compile-defun () "Compile the current toplevel form." @@ -2013,12 +2033,23 @@ ((:sexp string) (with-output-to-temp-buffer "*SLIME SEXP*" (princ string))) + ((:dspec origin dspec) + (destructure-case origin + ((:file filename) + (set-buffer (find-file-noselect filename t)) + (goto-char 1)) + ((:buffer buffer position) + (set-buffer buffer) + (goto-char position))) + (when dspec + (let ((case-fold-search t)) + (re-search-forward (format "^(def.*[ \n\t(]%s[ \t)]" dspec))) + (goto-char (match-beginning 0)))) ((:openmcl filename function-name) (set-buffer (find-file-noselect filename t)) - (ignore-errors - (goto-char (point-min)) - (re-search-forward (format "^(def\\w+\\s +%s\\s +" function-name) - (beginning-of-line)))) + (goto-char (point-min)) + (re-search-forward (format "^(def.*[ \n\t(]%s[ \t)]" function-name)) + (beginning-of-line)) ((:sbcl &key from buffername buffer-offset filename position info source-path path source-form function-name) @@ -2601,7 +2632,7 @@ (goto-char start) (beginning-of-line) (narrow-to-region (point) end) - (let ((window (display-buffer buffer other-window))) + (let ((window (display-buffer buffer other-window t))) (set-window-start window (point)) (unless (or (one-window-p t) (/= (frame-width) (window-width))) @@ -2772,6 +2803,7 @@ (defun slime-print-apropos (plists) (dolist (plist plists) (let ((designator (plist-get plist :designator))) + (assert designator) (slime-insert-propertized (list 'face apropos-symbol-face 'item designator 'action 'slime-describe-symbol) @@ -2781,6 +2813,7 @@ (loop for (prop namespace action) in '((:variable "Variable" swank:describe-symbol) (:function "Function" swank:describe-function) + (:generic-function "Generic Function" swank:describe-function) (:setf "Setf" swank:describe-setf-function) (:type "Type" swank:describe-type) (:class "Class" swank:describe-class) @@ -3282,10 +3315,10 @@ (save-selected-window (slime-goto-source-location source-location) (sldb-highlight-sexp) - (display-buffer (current-buffer) t) + (display-buffer (current-buffer) t t) (save-excursion (beginning-of-line -4) - (set-window-start (get-buffer-window (current-buffer)) (point))))) + (set-window-start (get-buffer-window (current-buffer) t) (point))))) (defun sldb-frame-details-visible-p () (and (get-text-property (point) 'frame) From heller at common-lisp.net Thu Nov 27 00:54:13 2003 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 26 Nov 2003 19:54:13 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31564 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Nov 26 19:54:13 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.114 slime/ChangeLog:1.115 --- slime/ChangeLog:1.114 Wed Nov 26 18:46:00 2003 +++ slime/ChangeLog Wed Nov 26 19:54:13 2003 @@ -1,3 +1,28 @@ +2003-11-27 Helmut Eller + + * swank-lispworks.lisp: New backend. + + * slime.el (slime-with-output-to-temp-buffer): Save the window + configuration in a buffer local variable instead on a global + stack. + (slime-show-last-output): Behavior customizable with + slime-show-last-output-function. Various tweaking for better + multi-frame support. + + * swank-backend.lisp: List exported symbols explicitly. + + * swank-cmucl.lisp (function-source-location): Better support for + generic functions. + + * swank.lisp (briefly-describe-symbol-for-emacs): Don't return + unbound symbols. + (describe-symbol, describe-function): Support package-qualified + strings. + + * swank-loader.lisp: *sysdep-pathnames*: Add Lispworks files. + (compile-files-if-needed-serially): Compile all files in a + compilation unit. + 2003-11-27 Luke Gorrie * completer.el: Stolen^Wimported from ILISP version 1.4. This is From lgorrie at common-lisp.net Thu Nov 27 01:24:43 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 20:24: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-serv13585 Modified Files: slime.el Log Message: (slime-swank-port-file): Use `temporary-file-directory' instead of hardcoding "/tmp/". Date: Wed Nov 26 20:24:43 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.113 slime/slime.el:1.114 --- slime/slime.el:1.113 Wed Nov 26 19:50:52 2003 +++ slime/slime.el Wed Nov 26 20:24:43 2003 @@ -786,7 +786,7 @@ (defun slime-swank-port-file () "Filename where the SWANK server writes its TCP port number." - (format "/tmp/slime.%S" (emacs-pid))) + (concat temporary-file-directory (format "slime.%S" (emacs-pid)))) (defun slime-read-swank-port () "Read the Swank server port number from the `slime-swank-port-file'." From lgorrie at common-lisp.net Thu Nov 27 01:24:51 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 26 Nov 2003 20:24:51 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13642 Modified Files: ChangeLog Log Message: Date: Wed Nov 26 20:24:51 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.115 slime/ChangeLog:1.116 --- slime/ChangeLog:1.115 Wed Nov 26 19:54:13 2003 +++ slime/ChangeLog Wed Nov 26 20:24:51 2003 @@ -1,3 +1,8 @@ +2003-11-27 Luke Gorrie + + * slime.el (slime-swank-port-file): Use `temporary-file-directory' + instead of hardcoding "/tmp/". + 2003-11-27 Helmut Eller * swank-lispworks.lisp: New backend. @@ -25,11 +30,16 @@ 2003-11-27 Luke Gorrie + * slime.el (slime-complete-symbol): Make a bogus alist out of the + completion set, for compatibility with XEmacs. + * completer.el: Stolen^Wimported from ILISP version 1.4. This is one revision prior to their latest, where they added a (require) for some other ILISP code. I backed down a revision to make it stand-alone, but this may mean that putting SLIME in the load-path before ILISP will break ILISP. So, beware. + (completer-message): Cut dependency on undefined ilisp constant + testing for xemacs. 2003-11-27 Zach From heller at common-lisp.net Fri Nov 28 11:58:39 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 28 Nov 2003 06:58: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-serv25723 Modified Files: slime.el Log Message: Support for output from a dedicated socket. (slime-input-complete-p): Use vanilla forward-sexp, because slime-forward-sexp sometimes caused endless loops. (slime-disconnect): Close the output-stream-connection if present. (slime-handle-oob): A new :%apply event. Executes arbitrary code; useful for bootstrapping. (slime-flush-output): New function. (slime-open-stream-to-lisp, slime-output-filter): New functions. Reorganized REPL code a bit. (slime-symbol-end-pos): Didn't work at all in Emacs20. Just use point until someone commits a proper fix. Various uses of display-buffer: The second argument is different in XEmacs. (interrupt-bubbling-idiot): Reduce the timeout to 5 seconds. Date: Fri Nov 28 06:58:39 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.114 slime/slime.el:1.115 --- slime/slime.el:1.114 Wed Nov 26 20:24:43 2003 +++ slime/slime.el Fri Nov 28 06:58:38 2003 @@ -310,7 +310,7 @@ (loop do (or (skip-chars-forward " \t\r\n") (looking-at ")")) ; tollerate extra close parens until (eobp) - do (slime-forward-sexp)) + do (forward-sexp)) t)))) (defun inferior-slime-input-complete-p () @@ -854,7 +854,9 @@ (cancel-timer slime-startup-retry-timer) (message "Cancelled connection attempt.")) (t - (message "Not connected.")))) + (message "Not connected."))) + (when-let (stream (get-process "*lisp-output-stream*")) + (delete-process stream))) (defun slime-init-connection () (slime-init-dispatcher) @@ -1091,6 +1093,8 @@ ((:new-features features) (setq slime-lisp-features features) t) + ((:%apply fn args) + (apply (intern fn) args)) (t nil))) (defun slime-state/event-panic (event) @@ -1226,8 +1230,9 @@ "Idle state. The only event allowed is to make a request." ((activate) (assert (= sldb-level 0)) - (slime-repl-maybe-prompt)) + (slime-repl-activate)) ((:emacs-evaluate form-string package-name continuation) + (slime-repl-deactivate) (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation)))) @@ -1403,6 +1408,9 @@ ;;; 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.") (defun slime-output-buffer () @@ -1416,7 +1424,7 @@ (defun slime-insert-transcript-delimiter (string) (with-current-buffer (slime-output-buffer) (goto-char (point-max)) - (slime-repl-maybe-insert-output-separator) + (slime-mark-input-end) (slime-insert-propertized '(slime-transcript-delimiter t) ";;;; " @@ -1424,7 +1432,8 @@ (substring string 0 (min 60 (length string)))) " ...\n") - (set-marker slime-last-output-start (point) (current-buffer)))) + (slime-mark-output-start))) + (defvar slime-show-last-output-function 'slime-maybe-display-output-buffer @@ -1442,30 +1451,45 @@ (< start end)) (display-buffer (current-buffer)))) +(defun slime-flush-output () + (when-let (stream (get-process "*lisp-output-stream*")) + (while (accept-process-output stream 0 10)))) + (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)) (funcall slime-show-last-output-function start end)))) -(defun slime-with-output-at-eob (fn) - "Call FN at the eob. In a save-excursion block if we are not at -eob." - (cond ((eobp) (funcall fn) - (when-let (w (get-buffer-window (current-buffer) t)) - (set-window-point w (point)))) - (t (save-excursion - (goto-char (point-max)) - (funcall fn))))) +(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)))) + +(defun slime-output-filter (process string) + (slime-output-string string)) + +(defun slime-open-stream-to-lisp (port) + (let ((stream (open-network-stream "*lisp-output-stream*" + nil + "localhost" port))) + (set-process-filter stream 'slime-output-filter) + stream)) (defun slime-output-string (string) (with-current-buffer (slime-output-buffer) (slime-with-output-at-eob - (lambda () - (slime-repl-maybe-insert-output-separator) - (slime-propertize-region '(face slime-repl-output-face) - (insert string)))))) + (insert string)))) (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." @@ -1514,27 +1538,38 @@ (defun slime-repl-insert-prompt () (unless (bolp) (insert "\n")) - (let ((start (point))) - (slime-propertize-region - '(face font-lock-keyword-face - read-only t - intangible 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-repl-prompt-start-mark start (current-buffer)) - (set-marker slime-repl-input-start-mark (point) (current-buffer)) - (set-marker slime-repl-input-end-mark (point) (current-buffer)))) - -(defun slime-repl-maybe-prompt () - "Insert a prompt if there is none." + (set-marker slime-repl-prompt-start-mark (point) (current-buffer)) + (slime-propertize-region + '(face font-lock-keyword-face + read-only t + intangible 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)) + +(defun slime-repl-activate () + ;; The slime-repl-input-end-mark is left inserting in the idle and + ;; reading state; right inserting otherwise. The idea is that the + ;; input-end-mark is not moved by output from Lisp. We use the + ;; input-end-mark also to decide if we should insert a prompt or + ;; not. We don't print a prompt if point is at the input-end-mark. + ;; This situation occurs when we are after a slime-space command. + ;; In the normal case slime-repl-return triggers printing of the + ;; prompt by inserting a newline after the input-end-mark. (with-current-buffer (slime-output-buffer) + (slime-flush-output) + (set-marker-insertion-type slime-repl-input-end-mark t) (unless (= (point-max) slime-repl-input-end-mark) + (slime-mark-output-end) (slime-with-output-at-eob - (lambda () - (slime-repl-insert-prompt)))))) + (slime-repl-insert-prompt))))) + +(defun slime-repl-deactivate () + (set-marker-insertion-type slime-repl-input-end-mark nil)) (defun slime-repl-current-input () "Return the current input as string. The input is the region from @@ -1543,6 +1578,8 @@ slime-repl-input-end-mark)) (defun slime-repl-add-to-input-history (string) + (when (eq ?\n (aref string (1- (length string)))) + (setq string (substring string 0 -1))) (unless (equal string (car slime-repl-input-history)) (push string slime-repl-input-history)) (setq slime-repl-input-history-position -1)) @@ -1555,8 +1592,11 @@ (defun slime-repl-send-string (string) (slime-repl-add-to-input-history string) (ecase (slime-state-name (slime-current-state)) - (slime-idle-state (slime-repl-eval-string string)) - (slime-read-string-state (slime-repl-return-string (concat string "\n"))))) + (slime-idle-state + (setq slime-repl-prompt-on-activate-p t) + (slime-repl-eval-string string)) + (slime-read-string-state + (slime-repl-return-string string)))) (defun slime-repl-show-result-continutation () ;; This is called _after_ the idle state is activated. This means @@ -1567,12 +1607,24 @@ (goto-char slime-repl-prompt-start-mark) (insert result "\n"))))) -(defun slime-repl-maybe-insert-output-separator () - "Insert a newline at point, if we are the end of the input." - (when (= (point) slime-repl-input-end-mark) - (insert "\n") - (set-marker slime-repl-input-end-mark (1- (point)) (current-buffer)) - (set-marker slime-last-output-start (point)))) +(defun slime-mark-input-start () + (set-marker slime-repl-input-start-mark (point) (current-buffer)) + (set-marker slime-repl-input-end-mark (point) (current-buffer)) + (set-marker-insertion-type slime-repl-input-end-mark t)) + +(defun slime-mark-input-end () + (set-marker slime-repl-input-end-mark (point)) + (set-marker-insertion-type slime-repl-input-end-mark nil) + (add-text-properties slime-repl-input-start-mark slime-repl-input-end-mark + '(face slime-repl-input-face rear-nonsticky (face)))) + +(defun slime-mark-output-start () + (set-marker slime-output-start (point))) + +(defun slime-mark-output-end () + (set-marker slime-last-output-start slime-output-start) + (add-text-properties slime-output-start (point-max) + '(face slime-repl-output-face rear-nonsticky (face)))) (defun slime-repl-bol () "Go to the beginning of line or the prompt." @@ -1593,20 +1645,25 @@ (unless (or (slime-idle-p) (slime-reading-p)) (error "Lisp is not ready for requests from the REPL.")) - (if (or current-prefix-arg - (slime-input-complete-p slime-repl-input-start-mark - slime-repl-input-end-mark)) - (slime-repl-send-input) - (slime-repl-newline-and-indent))) + (cond (current-prefix-arg + (slime-repl-send-input) + (insert "\n")) + ((slime-input-complete-p slime-repl-input-start-mark + slime-repl-input-end-mark) + (insert "\n") + (slime-repl-send-input) + ;; move markers before newline + (delete-backward-char 1) (insert "\n")) + (t + (slime-repl-newline-and-indent) + (message "[input not complete]")))) (defun slime-repl-send-input () "Goto to the end of the input and send the current input." (let ((input (slime-repl-current-input))) (goto-char slime-repl-input-end-mark) - (slime-repl-maybe-insert-output-separator) - (add-text-properties slime-repl-input-start-mark - slime-repl-input-end-mark - '(face slime-repl-input-face)) + (slime-mark-input-end) + (slime-mark-output-start) (slime-repl-send-string input))) (defun slime-repl-closing-return () @@ -1755,11 +1812,14 @@ (defun slime-repl-read-string () (slime-switch-to-output-buffer) - (set-marker slime-repl-input-start-mark (point) (current-buffer)) - (set-marker slime-repl-input-end-mark (point) (current-buffer)) + (slime-flush-output) + (slime-mark-output-end) + (slime-mark-input-start) + (set-marker-insertion-type slime-repl-input-end-mark t) (slime-repl-read-mode t)) (defun slime-repl-return-string (string) + (set-marker-insertion-type slime-repl-input-end-mark nil) (slime-dispatch-event `(:emacs-return-string ,string)) (slime-repl-read-mode nil)) @@ -1770,7 +1830,6 @@ (defun slime-repl-abort-read () (with-current-buffer (slime-output-buffer) (slime-repl-read-mode nil) - (slime-repl-maybe-insert-output-separator) (message "Read aborted"))) @@ -1794,14 +1853,15 @@ (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-eval-async `(swank:swank-compile-file ,(buffer-file-name) ,(if load t nil)) nil (slime-compilation-finished-continuation)) - (message "Compiling %s.." (buffer-file-name)) - (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (display-buffer (current-buffer) t t))) + (message "Compiling %s.." (buffer-file-name))) (defun slime-compile-defun () "Compile the current toplevel form." @@ -2498,10 +2558,13 @@ (skip-syntax-forward "'") (point))) +;;(defun slime-symbol-end-pos () +;; (save-excursion +;; (skip-syntax-forward "_") +;; (min (1+ (point)) (point-max)))) + (defun slime-symbol-end-pos () - (save-excursion - (skip-syntax-forward "_") - (min (1+ (point)) (point-max)))) + (point)) (defun slime-bogus-completion-alist (list) "Make an alist out of list. @@ -3315,7 +3378,7 @@ (save-selected-window (slime-goto-source-location source-location) (sldb-highlight-sexp) - (display-buffer (current-buffer) t t) + (display-buffer (current-buffer) t) (save-excursion (beginning-of-line -4) (set-window-start (get-buffer-window (current-buffer) t) (point))))) @@ -3698,6 +3761,10 @@ "the SLIME Read-Eval-Print-Loop." (slime-output-buffer)) +(def-slime-selector-method ?s + "the *slime-scratch* buffer." + (slime-scratch-buffer)) + (def-slime-selector-method ?i "the *inferior-lisp* buffer." "*inferior-lisp*") @@ -4147,7 +4214,7 @@ (slime-check "In eval state." (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) (slime-interrupt) - (slime-sync-state-stack '(slime-idle-state) 15) + (slime-sync-state-stack '(slime-idle-state) 5) (slime-check "Automaton is back in idle state." (slime-test-state-stack '(slime-idle-state))))) @@ -4303,6 +4370,12 @@ (setq low (logand low 65535)) (list high low micro))) + +(defun-if-undefined line-beginning-position (&optional n) + (save-excursion + (forward-line n) + (beginning-of-line) + (point))) (defun emacs-20-p () (and (not (featurep 'xemacs)) From heller at common-lisp.net Fri Nov 28 12:02:29 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 28 Nov 2003 07:02:29 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28029 Modified Files: swank.lisp Log Message: (slime-read-string, eval-string): Flush *emacs-io*. (eval-in-emacs): New function. Date: Fri Nov 28 07:02:29 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.67 slime/swank.lisp:1.68 --- slime/swank.lisp:1.67 Wed Nov 26 19:40:35 2003 +++ slime/swank.lisp Fri Nov 28 07:02:29 2003 @@ -173,6 +173,7 @@ (defun slime-read-string () (force-output) + (force-output *slime-io*) (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) (send-to-emacs `(:read-string ,*read-input-catch-tag*)) (let (ok) @@ -267,6 +268,12 @@ ;;;; Evaluation +(defun eval-in-emacs (form) + "Execute FROM in Emacs." + (destructuring-bind (fn &rest args) form + (swank::send-to-emacs + `(:%apply ,(string-downcase (string fn)) ,args)))) + (defslimefun eval-string (string buffer-package) (let ((*debugger-hook* #'swank-debugger-hook)) (let (ok result) @@ -277,7 +284,7 @@ (force-output) (setq ok t)) (sync-state-to-emacs) - (force-output *slime-output*) + (force-output *slime-io*) (send-to-emacs (if ok `(:ok ,result) '(:aborted))))))) (defun format-values-for-echo-area (values) From heller at common-lisp.net Fri Nov 28 12:09:26 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 28 Nov 2003 07:09:26 -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-serv31740 Modified Files: swank-cmucl.lisp Log Message: Support for output redirection to an Emacs buffer via a dedicated network stream. Can be enabled with *use-dedicated-output-stream*. Date: Fri Nov 28 07:09:25 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.27 slime/swank-cmucl.lisp:1.28 --- slime/swank-cmucl.lisp:1.27 Wed Nov 26 19:42:42 2003 +++ slime/swank-cmucl.lisp Fri Nov 28 07:09:25 2003 @@ -21,16 +21,19 @@ ;;;; TCP server. +(defun resolve-hostname (name) + (let* ((hostent (ext:lookup-host-entry name)) + (address (car (ext:host-entry-addr-list hostent)))) + (ext:htonl address))) + (defun create-swank-server (port &key reuse-address (address "localhost")) "Create a SWANK TCP server." - (let* ((hostent (ext:lookup-host-entry address)) - (address (car (ext:host-entry-addr-list hostent))) - (ip (ext:htonl address))) - (let ((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))))) + (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)))) (defun accept-connection (socket) "Accept one Swank TCP connection on SOCKET and then close it." @@ -38,13 +41,29 @@ (sys:invalidate-descriptor socket) (unix:unix-close socket)) +(defun open-stream-to-emacs () + "Return an output-stream to Emacs' output buffer." + (let* ((ip (resolve-hostname "localhost")) + (listener (ext:create-inet-listener 0 :stream :host ip)) + (port (nth-value 1 (ext::get-socket-host-and-port listener)))) + (unwind-protect + (progn + (eval-in-emacs `(slime-open-stream-to-lisp ,port)) + (let ((fd (ext:accept-tcp-connection listener))) + (sys:make-fd-stream fd :output t))) + (ext:close-socket listener)))) + +(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 (make-slime-output-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) From heller at common-lisp.net Fri Nov 28 12:10:41 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 28 Nov 2003 07:10:41 -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-serv32266 Modified Files: swank-sbcl.lisp Log Message: Support for output redirection to an Emacs buffer via a dedicated network stream. Can be enabled with *use-dedicated-output-stream*. Date: Fri Nov 28 07:10:41 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.28 slime/swank-sbcl.lisp:1.29 --- slime/swank-sbcl.lisp:1.28 Mon Nov 24 19:23:27 2003 +++ slime/swank-sbcl.lisp Fri Nov 28 07:10:41 2003 @@ -62,9 +62,7 @@ ;;; TCP Server - -(defun create-swank-server (port &key reuse-address) - "Create a SWANK TCP server." +(defun open-listener (port reuse-address) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) @@ -73,6 +71,17 @@ (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)) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defun create-swank-server (port &key reuse-address) + "Create a SWANK TCP server." + (let ((socket (open-listener port reuse-address))) (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) :input (lambda (fd) @@ -80,12 +89,27 @@ (accept-connection socket))) (nth-value 1 (sb-bsd-sockets:socket-name socket)))) +(defun open-stream-to-emacs () + (let* ((server-socket (open-listener 0 t)) + (port (nth-value 1 (sb-bsd-sockets:socket-name server-socket)))) + (unwind-protect + (progn + (eval-in-emacs `(slime-open-stream-to-lisp ,port)) + (let ((socket (accept server-socket))) + (sb-bsd-sockets:socket-make-stream + socket :output t :element-type 'base-char))) + (sb-bsd-sockets:socket-close server-socket)))) + +(defvar *use-dedicated-output-stream* t) + (defun accept-connection (server-socket) "Accept one Swank TCP connection on SOCKET and then close it." - (let* ((socket (sb-bsd-sockets:socket-accept server-socket)) + (let* ((socket (accept server-socket)) (stream (sb-bsd-sockets:socket-make-stream socket :input t :output t :element-type 'base-char)) - (out (make-instance 'slime-output-stream)) + (out (if *use-dedicated-output-stream* + (let ((*emacs-io* stream)) (open-stream-to-emacs)) + (make-instance 'slime-output-stream))) (in (make-instance 'slime-input-stream)) (io (make-two-way-stream in out))) (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor @@ -96,6 +120,7 @@ :input (lambda (fd) (declare (ignore fd)) (serve-request stream out in io))))) + (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) "Read and process a request from a SWANK client. From heller at common-lisp.net Fri Nov 28 12:14:18 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 28 Nov 2003 07:14:18 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2984 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Nov 28 07:14:17 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.116 slime/ChangeLog:1.117 --- slime/ChangeLog:1.116 Wed Nov 26 20:24:51 2003 +++ slime/ChangeLog Fri Nov 28 07:14:17 2003 @@ -1,3 +1,27 @@ +2003-11-28 Helmut Eller + + * swank-sbcl.lisp, swank-cmucl.lisp: Support for output + redirection to an Emacs buffer via a dedicated network stream. + Can be enabled with *use-dedicated-output-stream*. + + * swank.lisp (slime-read-string, eval-string): Flush *emacs-io*. + (eval-in-emacs): New function. + + * slime.el: Support for output from a dedicated socket. + (slime-open-stream-to-lisp, slime-output-filter): New functions. + Reorganized REPL code a bit. + (slime-input-complete-p): Use vanilla forward-sexp, because + slime-forward-sexp sometimes caused endless loops. + (slime-disconnect): Close the output-stream-connection if present. + (slime-handle-oob): A new :%apply event. Executes arbitrary code; + useful for bootstrapping. + (slime-flush-output): New function. + (slime-symbol-end-pos): Didn't work at all in Emacs20. Just use + point until someone commits a proper fix. + Various uses of display-buffer: The second argument is different in + XEmacs. + (interrupt-bubbling-idiot): Reduce the timeout to 5 seconds. + 2003-11-27 Luke Gorrie * slime.el (slime-swank-port-file): Use `temporary-file-directory' From heller at common-lisp.net Fri Nov 28 14:28:18 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 28 Nov 2003 09:28:18 -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-serv31807 Modified Files: swank-lispworks.lisp Log Message: (make-dspec-location): Handle logical pathnames. Date: Fri Nov 28 09:28:18 2003 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.1 slime/swank-lispworks.lisp:1.2 --- slime/swank-lispworks.lisp:1.1 Wed Nov 26 19:36:36 2003 +++ slime/swank-lispworks.lisp Fri Nov 28 09:28:17 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.1 2003/11/27 00:36:36 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.2 2003/11/28 14:28:17 heller Exp $ ;;; (in-package :swank) @@ -296,9 +296,12 @@ (delete-file filename))) (defun make-dspec-location (dspec filename &optional tmpfile buffer position) - (list :dspec (cond ((and tmpfile (pathname-match-p filename tmpfile)) - (list :buffer buffer position)) - (t (list :file (namestring filename)))) + (list :dspec + (cond ((and tmpfile (pathname-match-p filename tmpfile)) + (list :buffer buffer position)) + (t + (let ((name (namestring (translate-logical-pathname filename)))) + (list :file name)))) (string (etypecase dspec (symbol dspec) (cons (dspec:dspec-primary-name dspec)))))) @@ -321,7 +324,7 @@ (make-dspec-location dspec filename tmpfile buffer position) nil))) htab)) - + (defmethod compile-string-for-emacs (string &key buffer position) (assert buffer) (assert position) @@ -330,8 +333,9 @@ (tmpname (hcl:make-temp-file nil "lisp"))) (with-compilation-unit () (compile-from-temp-file string tmpname) + (format t "~A~%" compiler:*messages*) (signal-error-data-base compiler::*error-database* tmpname buffer position) (signal-undefined-functions compiler::*unknown-functions* - tmpname tmpname buffer position)))) + tmpname tmpname buffer position)))) From heller at common-lisp.net Fri Nov 28 14:28:41 2003 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 28 Nov 2003 09:28:41 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31949 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Nov 28 09:28:40 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.117 slime/ChangeLog:1.118 --- slime/ChangeLog:1.117 Fri Nov 28 07:14:17 2003 +++ slime/ChangeLog Fri Nov 28 09:28:40 2003 @@ -1,5 +1,8 @@ 2003-11-28 Helmut Eller + * swank-lispworks.lisp (make-dspec-location): Handle logical + pathnames. Reported by Alain Picard. + * swank-sbcl.lisp, swank-cmucl.lisp: Support for output redirection to an Emacs buffer via a dedicated network stream. Can be enabled with *use-dedicated-output-stream*. From lgorrie at common-lisp.net Fri Nov 28 19:54:15 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 14:54:15 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5454 Modified Files: swank.lisp Log Message: (longest-completion): Compute the best partial completion for Emacs. (completions): Use it. Date: Fri Nov 28 14:54:15 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.68 slime/swank.lisp:1.69 --- slime/swank.lisp:1.68 Fri Nov 28 07:02:29 2003 +++ slime/swank.lisp Fri Nov 28 14:54:15 2003 @@ -485,14 +485,16 @@ (let ((*print-case* (if (find-if #'upper-case-p string) :upcase :downcase)) (*package* package)) - (mapcar (lambda (s) - (cond (internal-p (format nil "~A::~A" package-name s)) - (package-name (format nil "~A:~A" package-name s)) - (t (format nil "~A" s)))) - ;; DO-SYMBOLS can consider the same symbol more than - ;; once, so remove duplicates. - (remove-duplicates (sort completions #'string< - :key #'symbol-name))))))) + (let* ((completion-set + (mapcar (lambda (s) + (cond (internal-p (format nil "~A::~A" package-name s)) + (package-name (format nil "~A:~A" package-name s)) + (t (format nil "~A" s)))) + ;; DO-SYMBOLS can consider the same symbol more than + ;; once, so remove duplicates. + (remove-duplicates (sort completions #'string< + :key #'symbol-name))))) + (list completion-set (longest-completion completion-set))))))) (defun parse-symbol-designator (string) "Parse STRING as a symbol designator. @@ -530,11 +532,8 @@ (declare (ignore _)) (eq status :external))) -(defun string-prefix-p (s1 s2) - "Return true iff the string S1 is a prefix of S2. -\(This includes the case where S1 is equal to S2.)" - (and (<= (length s1) (length s2)) - (string-equal s1 s2 :end2 (length s1)))) + +;;;; 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 @@ -571,6 +570,38 @@ :end1 (and end1 (1- end1)) :start2 start2)))))) + +;;;; Extending the input string by completion + +(defun longest-completion (completions) + "Return the longest prefix for all COMPLETIONS." + (untokenize-completion + (mapcar #'longest-common-prefix + (transpose-matrix (mapcar #'completion-tokens completions))))) + +(defun completion-tokens (string) + "Return all substrings of STRING delimited by #\-." + (loop for start = 0 then (1+ end) + until (> start (length string)) + for end = (or (position #\- string :start start) (length string)) + collect (subseq string start end))) + +(defun untokenize-completion (tokens) + (format nil "~{~A~^-~}" tokens)) + +(defun longest-common-prefix (strings) + "Return the longest string that is a common prefix of STRINGS." + (if (null strings) + "" + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix strings)))) + +(defun transpose-matrix (matrix) + "Turn a matrix (of any sequence type) on its side." + ;; A cute function from PAIP p.574 + (if matrix (apply #'mapcar #'list matrix))) ;;;; Documentation From lgorrie at common-lisp.net Fri Nov 28 20:03:22 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 15:03:22 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9214 Modified Files: slime.el Log Message: (slime-complete-symbol): Use the new completion support from the Lisp side. Don't obscure minibuffer input with completion messages. (slime-swank-port-file): Try (temp-directory), temporary-file-directory, or "/tmp/", depending on what is (f)bound. Date: Fri Nov 28 15:03:22 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.115 slime/slime.el:1.116 --- slime/slime.el:1.115 Fri Nov 28 06:58:38 2003 +++ slime/slime.el Fri Nov 28 15:03:22 2003 @@ -58,7 +58,6 @@ (require 'hideshow) (require 'hyperspec) (require 'font-lock) -(require 'completer) (when (featurep 'xemacs) (require 'overlay)) (eval-when (compile load eval) @@ -786,7 +785,11 @@ (defun slime-swank-port-file () "Filename where the SWANK server writes its TCP port number." - (concat temporary-file-directory (format "slime.%S" (emacs-pid)))) + (concat (file-name-as-directory + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + (format "slime.%S" (emacs-pid)))) (defun slime-read-swank-port () "Read the Swank server port number from the `slime-swank-port-file'." @@ -2484,24 +2487,42 @@ (let* ((end (slime-symbol-end-pos)) (beg (slime-symbol-start-pos)) (prefix (buffer-substring-no-properties beg end)) - (completions (slime-completions prefix))) - (destructuring-bind (match common-substring matches unique-p) - (completer prefix (slime-bogus-completion-alist completions) nil "-") - (cond ((eq unique-p t) - (message "[Sole completion]") - (delete-region beg end) - (insert match) + (completion-result (slime-completions prefix)) + (completion-set (first completion-result)) + (completed-prefix (second completion-result))) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + (delete-region beg end) + (insert-and-inherit completed-prefix) + (goto-char (+ beg (length completed-prefix))) + (cond ((member completed-prefix completion-set) + (if (= (length completion-set) 1) + (slime-minibuffer-respecting-message "Sole completion") + (slime-minibuffer-respecting-message "Complete but not unique")) (slime-complete-restore-window-configuration)) - ((null match) - (message "Can't find completion for \"%s\"" prefix) - (ding) - (slime-complete-restore-window-configuration)) - (t - (slime-complete-maybe-save-window-configuration) - (completer-display-choices completions) - (slime-complete-delay-restoration) - (completer-goto match common-substring - matches unique-p "^ \t\n\('\"#.\)<>" "-")))))) + ;; Incomplete + (t + (let ((unambiguous-completion-length + (loop for c in completion-set + minimizing (or (mismatch completed-prefix c) + (length completed-prefix))))) + (goto-char (+ beg unambiguous-completion-length)) + (slime-complete-maybe-save-window-configuration) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list completion-set)) + (slime-complete-delay-restoration))))))) + +(defun slime-minibuffer-respecting-message (format &rest format-args) + "Display TEXT as a message, without hiding any minibuffer contents." + (let ((text (format " [%s]" (apply #'format format format-args)))) + (if (minibuffer-window-active-p (minibuffer-window)) + (if (fboundp 'temp-minibuffer-message) ;; XEmacs + (temp-minibuffer-message text) + (minibuffer-message text)) + (message text)))) (defun slime-completing-read-internal (string default-package flag) ;; We misuse the predicate argument to pass the default-package. @@ -2554,17 +2575,15 @@ "Return the starting position of the symbol under point. The result is unspecified if there isn't a symbol under the point." (save-excursion - (backward-sexp 1) + (unless (looking-at "\\<") + (backward-sexp 1)) (skip-syntax-forward "'") (point))) -;;(defun slime-symbol-end-pos () -;; (save-excursion -;; (skip-syntax-forward "_") -;; (min (1+ (point)) (point-max)))) - (defun slime-symbol-end-pos () - (point)) + (save-excursion + (skip-syntax-forward "w_") + (point))) (defun slime-bogus-completion-alist (list) "Make an alist out of list. From lgorrie at common-lisp.net Fri Nov 28 20:03:37 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 15:03:37 -0500 Subject: [slime-cvs] CVS update: slime/completer.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9258 Removed Files: completer.el Log Message: Dead and buried! Replaced by half a page of Common Lisp. Thanks Bill Clementson for a motivational and well-deserved taunt. Date: Fri Nov 28 15:03:37 2003 Author: lgorrie From lgorrie at common-lisp.net Fri Nov 28 20:04:11 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 15:04:11 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10253 Modified Files: ChangeLog Log Message: Date: Fri Nov 28 15:04:11 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.118 slime/ChangeLog:1.119 --- slime/ChangeLog:1.118 Fri Nov 28 09:28:40 2003 +++ slime/ChangeLog Fri Nov 28 15:04:11 2003 @@ -1,3 +1,20 @@ +2003-11-28 Luke Gorrie + + * slime.el (slime-complete-symbol): Use the new completion + support from the Lisp side. Don't obscure minibuffer input with + completion messages. + + * completer.el: Dead and buried! Replaced by half a page of Common + Lisp. Thanks Bill Clementson for a motivational and well-deserved + taunt. + + * swank.lisp (longest-completion): Compute the best partial + completion for Emacs. + + * slime.el (slime-swank-port-file): Try (temp-directory), + temporary-file-directory, or "/tmp/", depending on what + is (f)bound. + 2003-11-28 Helmut Eller * swank-lispworks.lisp (make-dspec-location): Handle logical From lgorrie at common-lisp.net Fri Nov 28 20:54:09 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 15:54:09 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30423 Modified Files: swank.lisp Log Message: Documentation fixes. Date: Fri Nov 28 15:54:06 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.69 slime/swank.lisp:1.70 --- slime/swank.lisp:1.69 Fri Nov 28 14:54:15 2003 +++ slime/swank.lisp Fri Nov 28 15:54:02 2003 @@ -1,4 +1,4 @@ -;;;; -*- Mode: lisp; outline-regexp: ";;;;+"; indent-tabs-mode: nil -*- +;;;; -*- Mode: lisp; outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*- ;;; ;;; swank.lisp --- the portable bits ;;; @@ -419,7 +419,7 @@ (format nil "~,2F" (/ usecs 1000000.0))))) -;;; Macroexpansion +;;;; Macroexpansion (defun apply-macro-expander (expander string) (let ((*print-pretty* t) @@ -440,7 +440,7 @@ (apply-macro-expander #'macroexpand-all string)) -;;; Completion +;;;; Completion (defun case-convert (string) "Convert STRING according to the current readtable-case." @@ -456,9 +456,14 @@ (defslimefun completions (string default-package-name) "Return a list of completions for a symbol designator STRING. -The result is a list of strings. If STRING is package qualified the -result list will also be qualified. If string is non-qualified the -result strings are also not qualified and are considered relative to +The result is the list (COMPLETION-SET +COMPLETED-PREFIX). COMPLETION-SET is the list of all matching +completions, and COMPLETED-PREFIX is the best (partial) +completion of the input string. + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to DEFAULT-PACKAGE-NAME. The way symbols are matched depends on the symbol designator's @@ -533,7 +538,7 @@ (eq status :external))) -;;;; Subword-word matching +;;;;; 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 @@ -571,7 +576,7 @@ :start2 start2)))))) -;;;; Extending the input string by completion +;;;;; Extending the input string by completion (defun longest-completion (completions) "Return the longest prefix for all COMPLETIONS." @@ -599,7 +604,8 @@ (reduce #'common-prefix strings)))) (defun transpose-matrix (matrix) - "Turn a matrix (of any sequence type) on its side." + "Turn a matrix (of any sequence type) on its side. +If the rows are of unequal length, truncate uniformly to the shortest." ;; A cute function from PAIP p.574 (if matrix (apply #'mapcar #'list matrix))) From lgorrie at common-lisp.net Fri Nov 28 23:28:14 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 18:28:14 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25625 Modified Files: slime.el Log Message: (complete-symbol, arglist): Updated test cases for new completion code. Date: Fri Nov 28 18:28:14 2003 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.116 slime/slime.el:1.117 --- slime/slime.el:1.116 Fri Nov 28 15:03:22 2003 +++ slime/slime.el Fri Nov 28 18:28:13 2003 @@ -4029,14 +4029,18 @@ (def-slime-test complete-symbol (prefix expected-completions) "Find the completions of a symbol-name prefix." - '(("cl:compile" ("cl:compile" "cl:compile-file" "cl:compile-file-pathname" - "cl:compiled-function" "cl:compiled-function-p" - "cl:compiler-macro" "cl:compiler-macro-function")) - ("cl:foobar" nil) - ("cl::compile-file" ("cl::compile-file" "cl::compile-file-pathname"))) + '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" "cl:compiler-macro" + "cl:compiler-macro-function") + "cl:compile")) + ("cl:foobar" (nil "")) + ("cl::compile-file" (("cl::compile-file" "cl::compile-file-pathname") + "cl::compile-file")) + ("cl:m-v-l" (("cl:multiple-value-list" "cl:multiple-values-limit") + "cl:multiple-value-li"))) (let ((completions (slime-completions prefix))) (slime-check "Completion set is as expected." - (equal expected-completions (sort completions 'string<))))) + (equal expected-completions completions)))) (def-slime-test arglist (function-name expected-arglist) @@ -4044,8 +4048,8 @@ Confirm that EXPECTED-ARGLIST is displayed." '(("swank:start-server" "(swank:start-server port-file-namestring)") - ("swank::string-prefix-p" - "(swank::string-prefix-p s1 s2)")) + ("swank::compound-string-match" + "(swank::compound-string-match string1 string2)")) (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 Fri Nov 28 23:28:26 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 18:28:26 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25674 Modified Files: swank.lisp Log Message: Minor cleanups. Date: Fri Nov 28 18:28:26 2003 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.70 slime/swank.lisp:1.71 --- slime/swank.lisp:1.70 Fri Nov 28 15:54:02 2003 +++ slime/swank.lisp Fri Nov 28 18:28:26 2003 @@ -582,9 +582,9 @@ "Return the longest prefix for all COMPLETIONS." (untokenize-completion (mapcar #'longest-common-prefix - (transpose-matrix (mapcar #'completion-tokens completions))))) + (transpose-lists (mapcar #'tokenize-completion completions))))) -(defun completion-tokens (string) +(defun tokenize-completion (string) "Return all substrings of STRING delimited by #\-." (loop for start = 0 then (1+ end) until (> start (length string)) @@ -603,11 +603,15 @@ (if diff-pos (subseq s1 0 diff-pos) s1)))) (reduce #'common-prefix strings)))) -(defun transpose-matrix (matrix) - "Turn a matrix (of any sequence type) on its side. -If the rows are of unequal length, truncate uniformly to the shortest." +(defun transpose-lists (lists) + "Turn a list-of-lists on its side. +If the rows are of unequal length, truncate uniformly to the shortest. + +For example: +\(transpose-lists '(("ONE" "TWO" "THREE") ("1" "2"))) + => (("ONE" "1") ("TWO" "2"))" ;; A cute function from PAIP p.574 - (if matrix (apply #'mapcar #'list matrix))) + (if lists (apply #'mapcar #'list lists))) ;;;; Documentation From lgorrie at common-lisp.net Fri Nov 28 23:29:02 2003 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 28 Nov 2003 18:29:02 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25915 Modified Files: ChangeLog Log Message: Date: Fri Nov 28 18:29:02 2003 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.119 slime/ChangeLog:1.120 --- slime/ChangeLog:1.119 Fri Nov 28 15:04:11 2003 +++ slime/ChangeLog Fri Nov 28 18:29:02 2003 @@ -1,3 +1,8 @@ +2003-11-29 Luke Gorrie + + * slime.el (complete-symbol, arglist): Updated test cases for new + completion interface. + 2003-11-28 Luke Gorrie * slime.el (slime-complete-symbol): Use the new completion From heller at common-lisp.net Sat Nov 29 07:51:49 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 29 Nov 2003 02:51: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-serv16763 Modified Files: slime.el Log Message: Some tweaking to the REPL. slime-repl-input-end-mark is now always left inserting and slime-mark-input-end "deactivates" the end mark by moving it the beginning of the buffer. (slime-goto-source-location): Next try for more uniform source-locations. A source-location is now a structure with a "buffer-designator" and "position-designator". The buffer-designator open the file or buffer and the position-designator moves point to the right position. (slime-autodoc-mode): New command. (slime-find-fdefinitions): Experimental support for generic functions with methods. (slime-show-xrefs, slime-insert-xrefs, slime-goto-xref): Rewritten to work with more general source locations. Date: Sat Nov 29 02:51:48 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.117 slime/slime.el:1.118 --- slime/slime.el:1.117 Fri Nov 28 18:28:13 2003 +++ slime/slime.el Sat Nov 29 02:51:48 2003 @@ -1235,7 +1235,6 @@ (assert (= sldb-level 0)) (slime-repl-activate)) ((:emacs-evaluate form-string package-name continuation) - (slime-repl-deactivate) (slime-output-evaluate-request form-string package-name) (slime-push-state (slime-evaluating-state continuation)))) @@ -1491,6 +1490,7 @@ (defun slime-output-string (string) (with-current-buffer (slime-output-buffer) + (slime-mark-input-end) (slime-with-output-at-eob (insert string)))) @@ -1555,25 +1555,18 @@ (slime-mark-output-start)) (defun slime-repl-activate () - ;; The slime-repl-input-end-mark is left inserting in the idle and - ;; reading state; right inserting otherwise. The idea is that the - ;; input-end-mark is not moved by output from Lisp. We use the - ;; input-end-mark also to decide if we should insert a prompt or - ;; not. We don't print a prompt if point is at the input-end-mark. - ;; This situation occurs when we are after a slime-space command. - ;; In the normal case slime-repl-return triggers printing of the - ;; prompt by inserting a newline after the input-end-mark. + ;; We use the input-end-mark to decide if we should insert a prompt + ;; or not. We don't print a prompt if input-end-mark at the of the + ;; buffer. This situation occurs when we are after a slime-space + ;; 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) - (set-marker-insertion-type slime-repl-input-end-mark t) (unless (= (point-max) slime-repl-input-end-mark) (slime-mark-output-end) (slime-with-output-at-eob (slime-repl-insert-prompt))))) -(defun slime-repl-deactivate () - (set-marker-insertion-type slime-repl-input-end-mark nil)) - (defun slime-repl-current-input () "Return the current input as string. The input is the region from after the last prompt to the end of buffer." @@ -1581,7 +1574,8 @@ slime-repl-input-end-mark)) (defun slime-repl-add-to-input-history (string) - (when (eq ?\n (aref string (1- (length string)))) + (when (and (plusp (length string)) + (eq ?\n (aref string (1- (length string))))) (setq string (substring string 0 -1))) (unless (equal string (car slime-repl-input-history)) (push string slime-repl-input-history)) @@ -1595,11 +1589,8 @@ (defun slime-repl-send-string (string) (slime-repl-add-to-input-history string) (ecase (slime-state-name (slime-current-state)) - (slime-idle-state - (setq slime-repl-prompt-on-activate-p t) - (slime-repl-eval-string string)) - (slime-read-string-state - (slime-repl-return-string string)))) + (slime-idle-state (slime-repl-eval-string string)) + (slime-read-string-state (slime-repl-return-string string)))) (defun slime-repl-show-result-continutation () ;; This is called _after_ the idle state is activated. This means @@ -1612,14 +1603,10 @@ (defun slime-mark-input-start () (set-marker slime-repl-input-start-mark (point) (current-buffer)) - (set-marker slime-repl-input-end-mark (point) (current-buffer)) - (set-marker-insertion-type slime-repl-input-end-mark t)) + (set-marker slime-repl-input-end-mark (point) (current-buffer))) (defun slime-mark-input-end () - (set-marker slime-repl-input-end-mark (point)) - (set-marker-insertion-type slime-repl-input-end-mark nil) - (add-text-properties slime-repl-input-start-mark slime-repl-input-end-mark - '(face slime-repl-input-face rear-nonsticky (face)))) + (set-marker slime-repl-input-end-mark (point-min))) (defun slime-mark-output-start () (set-marker slime-output-start (point))) @@ -1654,9 +1641,7 @@ ((slime-input-complete-p slime-repl-input-start-mark slime-repl-input-end-mark) (insert "\n") - (slime-repl-send-input) - ;; move markers before newline - (delete-backward-char 1) (insert "\n")) + (slime-repl-send-input)) (t (slime-repl-newline-and-indent) (message "[input not complete]")))) @@ -1665,6 +1650,8 @@ "Goto to the end of the input and send the current input." (let ((input (slime-repl-current-input))) (goto-char slime-repl-input-end-mark) + (add-text-properties slime-repl-input-start-mark (point) + '(face slime-repl-input-face rear-nonsticky (face))) (slime-mark-input-end) (slime-mark-output-start) (slime-repl-send-string input))) @@ -1818,11 +1805,9 @@ (slime-flush-output) (slime-mark-output-end) (slime-mark-input-start) - (set-marker-insertion-type slime-repl-input-end-mark t) (slime-repl-read-mode t)) (defun slime-repl-return-string (string) - (set-marker-insertion-type slime-repl-input-end-mark nil) (slime-dispatch-event `(:emacs-return-string ,string)) (slime-repl-read-mode nil)) @@ -2081,6 +2066,21 @@ align-p means the location is not character-accurate, and should be aligned to the start of the sexp in front." (destructure-case location + ((:location buffer position) + (destructure-case buffer + ((:file filename) + (set-buffer (find-file-noselect filename t)) + (goto-char (point-min))) + ((:buffer buffer) + (set-buffer buffer) + (goto-char (point-min)))) + (destructure-case position + ((:position pos) + (goto-char pos)) + ((:dspec name) + (let ((case-fold-search t)) + (re-search-forward (format "^(def.*[ \n\t(]%s[ \t)]" name))) + (goto-char (match-beginning 0))))) ((:file filename position &optional align-p) (set-buffer (find-file-noselect filename t)) (goto-char position) @@ -2337,6 +2337,13 @@ "Cache variable for when `slime-autodoc-cache-type' is 'last'. The value is (SYMBOL-NAME . DOCUMENTATION).") +(defun slime-autodoc-mode (&optional arg) + "Enable `slime-autodoc'." + (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))))) + (defun slime-autodoc () "Print some apropos information about the code at point, if applicable." (when-let (sym (slime-function-called-at-point/line)) @@ -2692,6 +2699,28 @@ (interactive (list (slime-read-symbol-name "Function name: "))) (slime-edit-fdefinition name t)) +(defun slime-find-fdefinitions (name) + "Like `slime-edit-fdefinition' but with support for generic functions." + (interactive (list (slime-read-symbol-name "Function name: "))) + (let ((origin (point-marker)) + (locations (slime-eval `(swank:find-fdefinitions ,name) + (slime-buffer-package)))) + (assert locations) + (cond ((null (cdr locations)) + (slime-goto-source-location (car locations)) + (switch-to-buffer (current-buffer)) + (ring-insert-at-beginning slime-find-definition-history-ring + origin)) + (t + (slime-show-definitions name locations))))) + +(defun slime-show-definitions (name locations) + (slime-show-xrefs `((,name . ,(loop for l in locations + collect (cons (format "%s" l) l)))) + 'definition + name + (slime-buffer-package))) + ;;; Interactive evaluation. @@ -2975,42 +3004,33 @@ (lambda (result) (slime-show-xrefs result type symbol package))))) -(defun slime-show-xrefs (file-referrers type symbol package) +(defun slime-show-xrefs (xrefs type symbol package) "Show the results of an XREF query." - (if (null file-referrers) + (if (null xrefs) (message "No references found for %s." symbol) - (slime-save-window-configuration) (setq slime-next-location-function 'slime-goto-next-xref) (with-current-buffer (slime-xref-buffer t) (slime-init-xref-buffer package type symbol) - (dolist (ref file-referrers) - (apply #'slime-insert-xrefs ref)) + (slime-insert-xrefs xrefs) (setq buffer-read-only t) (goto-char (point-min)) (save-selected-window (delete-windows-on (slime-xref-buffer)) (slime-display-xref-buffer))))) -(defun slime-insert-xrefs (filename refs) +(defun slime-insert-xrefs (xrefs) "Insert the cross-references for a file. -Each cross-reference line contains these text properties: - slime-xref: a unique object - slime-file: filename of reference - slime-xref-source-path: source-path of reference - slime-xref-complete: true iff both file and source-path are known." +XREFS is a list of the form ((GROUP . ((LABEL . LOCATION) ...)) ...) +GROUP and LABEL are for decoration purposes. LOCATION is a source-location." (unless (bobp) (insert "\n")) - (insert (format "In %s:\n" (or filename "unidentified files"))) - (loop for (referrer source-path) in refs - do (let ((complete (and filename source-path))) - (slime-insert-propertized - (list 'slime-xref (make-symbol "#:unique-ref") - 'slime-xref-complete complete - 'slime-xref-file filename - 'slime-xref-source-path source-path - 'face (if complete - 'font-lock-function-name-face - 'font-lock-comment-face)) - (format "%s\n" referrer))))) + (loop for (group . refs) in xrefs do + (progn + (slime-insert-propertized '(face bold) group "\n") + (loop for (label . location) in refs do + (slime-insert-propertized + (list 'slime-location location + 'face 'font-lock-keyword-face) + " " label "\n"))))) ;;;; XREF results buffer and window management @@ -3051,13 +3071,11 @@ (defun slime-goto-xref () "Goto the cross-referenced location at point." (interactive) - (let ((file (get-text-property (point) 'slime-xref-file)) - (path (get-text-property (point) 'slime-xref-source-path))) - (unless (and file path) + (let ((location (get-text-property (point) 'slime-location))) + (unless location (error "No reference at point.")) - (find-file-other-window file) - (goto-char (point-min)) - (slime-visit-source-path path))) + (slime-show-source-location location))) + (defun slime-goto-next-xref () "Goto the next cross-reference location." @@ -3213,6 +3231,8 @@ ([return] 'slime-select-done) ("q" 'slime-select-quit)) +;;; + ;;; Macroexpansion @@ -4399,6 +4419,18 @@ (forward-line n) (beginning-of-line) (point))) + +(unless (boundp 'temporary-file-directory) + (defvar temporary-file-directory + (file-name-as-directory + (cond ((memq system-type '(ms-dos windows-nt)) + (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) + ((memq system-type '(vax-vms axp-vms)) + (or (getenv "TMPDIR") (getenv "TMP") + (getenv "TEMP") "SYS$SCRATCH:")) + (t + (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp")))) + "The directory for writing temporary files.")) (defun emacs-20-p () (and (not (featurep 'xemacs)) From heller at common-lisp.net Sat Nov 29 07:53:43 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 29 Nov 2003 02:53:43 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17214 Modified Files: swank.lisp Log Message: Structure definitions for source-locations. (alistify, location-position<, group-xrefs): Utilities for xref support. Date: Sat Nov 29 02:53:42 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.71 slime/swank.lisp:1.72 --- slime/swank.lisp:1.71 Fri Nov 28 18:28:26 2003 +++ slime/swank.lisp Sat Nov 29 02:53:42 2003 @@ -218,6 +218,23 @@ (find-package (string-upcase name)))) default-package)) +(defun find-symbol-designator (string &optional + (default-package *buffer-package*)) + "Return the symbol corresponding to the symbol designator STRING. +If string is not package qualified use DEFAULT-PACKAGE for the +resolution. Return nil if no such symbol exists." + (multiple-value-bind (name package-name internal-p) + (parse-symbol-designator (case-convert string)) + (cond ((and package-name (not (find-package package-name))) + (values nil nil)) + (t + (let ((package (or (find-package package-name) default-package))) + (multiple-value-bind (symbol access) (find-symbol name package) + (cond ((and symbol package-name (not internal-p) + (not (eq access :external))) + (values nil nil)) + (symbol (values symbol access))))))))) + ;;;; Debugger @@ -513,22 +530,6 @@ (if pos (subseq string 0 pos) nil)) (search "::" string))) -(defun find-symbol-designator (string &optional (default-package *buffer-package*)) - "Return the symbol corresponding to the symbol designator STRING. -If string is not package qualified use DEFAULT-PACKAGE for the -resolution. Return nil if no such symbol exists." - (multiple-value-bind (name package-name internal-p) - (parse-symbol-designator (case-convert string)) - (cond ((and package-name (not (find-package package-name))) - nil) - (t - (let ((package (or (find-package package-name) default-package))) - (multiple-value-bind (symbol access) (find-symbol name package) - (cond ((and symbol package-name (not internal-p) - (not (eq access :external))) - nil) - (symbol (values symbol access))))))))) - (defun symbol-external-p (symbol &optional (package (symbol-package symbol))) "True if SYMBOL is external in PACKAGE. If PACKAGE is not specified, the home package of SYMBOL is used." @@ -710,6 +711,56 @@ (defslimefun throw-to-toplevel () (throw 'slime-toplevel nil)) + +;;; Source Locations + +(defstruct (:location (:type list) :named + (:constructor make-location (buffer position))) + buffer + position) + +(defstruct (:file (:type list) :named (:constructor)) + name) + +(defstruct (:buffer (:type list) :named (:constructor)) + name) + +(defstruct (:position (:type list) :named (:constructor)) + pos) + +(defstruct (:buffer-position (:type list) :named (:constructor)) + pos) + +(defun alistify (list key test) + "Partition the element of LIST into an alist. KEY extracts the key +from an element and TEST is used to compare keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (assoc k alist :test test))) + (if probe + (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) + (position-pos pos2))) + ((and (buffer-position-p pos1) (buffer-position-p pos2)) + (< (buffer-position-pos pos1) + (buffer-position-pos pos2))) + (t nil))) + +(defun group-xrefs (xrefs) + (flet ((xref-buffer (xref) (location-buffer (cdr xref))) + (xref-position (xref) (location-position (cdr xref)))) + (let ((alist (alistify xrefs #'xref-buffer #'equal))) + (loop for (key . list) in alist + collect (cons (to-string key) + (sort list #'location-position< + :key #'xref-position)))))) + ;;; 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 heller at common-lisp.net Sat Nov 29 07:58:01 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 29 Nov 2003 02:58: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-serv18961 Modified Files: swank-cmucl.lisp Log Message: (code-location-source-location): Renamed from safe-source-location-for-emacs. (code-location-from-source-location): Renamed from source-location-for-emacs. (find-fdefinitions, function-source-locations): New functions. (safe-definition-finding): New macro. Date: Sat Nov 29 02:58:00 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.28 slime/swank-cmucl.lisp:1.29 --- slime/swank-cmucl.lisp:1.28 Fri Nov 28 07:09:25 2003 +++ slime/swank-cmucl.lisp Sat Nov 29 02:58:00 2003 @@ -108,7 +108,6 @@ (setf (sos.index stream) (1+ index)) (incf (sos.column stream)) (when (char= #\newline char) - ;;(force-output stream) (setf (sos.column stream) 0)) (when (= index (1- (length buffer))) (force-output stream))) @@ -331,22 +330,27 @@ (defun xref-results-for-emacs (contexts) "Prepare a list of xref contexts for Emacs. -The result is a list of file-referrers: -file-referrer ::= (FILENAME ({reference}+)) -reference ::= (FUNCTION-SPECIFIER SOURCE-PATH)" - (let ((hash (make-hash-table :test 'equal)) - (files '())) - (dolist (context contexts) - (let* ((file (xref:xref-context-file context)) - (unix-path (if file (unix-truename file) ""))) - (push context (gethash unix-path hash)) - (pushnew unix-path files :test #'string=))) - (mapcar (lambda (unix-path) - (let ((real-path (if (string= unix-path "") - nil - unix-path))) - (file-xrefs-for-emacs real-path (gethash unix-path hash)))) - (sort files #'string<)))) +The result is a list of xrefs: +group ::= (FILENAME . ({reference}+)) +reference ::= (FUNCTION-SPECIFIER . SOURCE-LOCATION)" + (let ((xrefs '())) + (dolist (cxt contexts) + (let* ((name (xref:xref-context-name cxt)) + (file (xref:xref-context-file cxt)) + (source-path (xref:xref-context-source-path cxt)) + (position (source-path-file-position source-path file))) + (push (cons (to-string name) + (make-location (list :file (unix-truename file)) + (list :position (1+ position)))) + xrefs))) + (group-xrefs xrefs))) + + +(defun location-buffer= (location1 location2) + (equalp location1 location2)) + +;; (xref-results-for-emacs (xref:who-binds '*package*)) + (defun file-xrefs-for-emacs (unix-filename contexts) "Return a summary of the references from a particular file. @@ -487,10 +491,20 @@ ;;;; Definitions -(defvar *debug-definition-finding* nil +(defvar *debug-definition-finding* t "When true don't handle errors while looking for definitions. This is useful when debugging the definition-finding code.") +(defmacro safe-definition-finding (&body body) + "Execute BODY ignoring errors. Return a the source location +returned by BODY or if an error occurs a description of the error. +The second return value is the condition or nil." + `(flet ((body () , at body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn , at body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + (defun function-first-code-location (function) (and (function-has-debug-function-p function) (di:debug-function-start-location @@ -563,8 +577,8 @@ (list* (gf-definition-location gf) (gf-method-locations gf))) -(defun function-source-location (function) - "Try to find the canonical source location of FUNCTION." +(defun function-source-locations (function) + "Return a list of source locations for FUNCTION." ;; First test if FUNCTION is a closure created by defstruct; if so ;; extract the defstruct-description (dd) from the closure and find ;; the constructor for the struct. Defstruct creates a defun for @@ -574,27 +588,42 @@ ;; For an ordinary function we return the source location of the ;; first code-location we find. (cond ((struct-closure-p function) - (dd-source-location (struct-closure-dd function))) + (list + (safe-definition-finding + (dd-source-location (struct-closure-dd function))))) ((genericp function) - (car (gf-source-locations function))) + (gf-source-locations function)) (t - (let ((location (function-first-code-location function))) - (when location - (source-location-for-emacs location)))))) + (list + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location)))))))) + +(defun function-source-location (function) + (destructuring-bind (first) (function-source-locations function) + first)) (defmethod function-source-location-for-emacs (fname) "Return the source-location of FNAME's definition." - (let* ((fname (from-string fname)) - (finder - (lambda () - (cond ((and (symbolp fname) (macro-function fname)) - (function-source-location (macro-function fname))) - ((fboundp fname) - (function-source-location (coerce fname 'function))))))) - (if *debug-definition-finding* - (funcall finder) - (handler-case (funcall finder) - (error (e) (list :error (format nil "Error: ~A" e))))))) + (car (find-fdefinitions fname))) + +(defslimefun find-fdefinitions (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) + (list (list :error (format nil "Unkown symbol: ~A" symbol-name)))) + ((macro-function symbol) + (function-source-locations (macro-function symbol))) + ((special-operator-p symbol) + (list (list :error (format nil "~A is special-operator" symbol)))) + ((fboundp symbol) + (function-source-locations (coerce symbol 'function))) + (t (list (list :error + (format nil "Symbol not fbound: ~A" symbol-name)))) + ))) + +;; (find-fdefinitions "function-source-location-for-emacs") ;;;; Documentation. @@ -879,7 +908,8 @@ (consp info) (eq :emacs-buffer (car info))))) -(defun source-location-for-emacs (code-location) +(defun code-location-from-source-location (code-location) + "Return the source location for CODE-LOCATION." (let* ((debug-source (di:code-location-debug-source code-location)) (from (di:debug-source-from debug-source)) (name (di:debug-source-name debug-source))) @@ -897,9 +927,10 @@ (debug::print-code-location-source-form code-location 100 t))))))) -(defun safe-source-location-for-emacs (code-location) - (handler-case (source-location-for-emacs code-location) - (t (c) (list :error (debug::safe-condition-message c))))) +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (code-location-from-source-location code-location))) (defslimefun getpid () (unix:unix-getpid)) @@ -971,7 +1002,7 @@ (backtrace start end))) (defmethod frame-source-location-for-emacs (index) - (safe-source-location-for-emacs (di:frame-code-location (nth-frame index)))) + (code-location-source-location (di:frame-code-location (nth-frame index)))) (defmethod eval-in-frame (form index) (di:eval-in-frame (nth-frame index) form)) @@ -1002,7 +1033,7 @@ (defmethod frame-catch-tags (index) (loop for (tag . code-location) in (di:frame-catches (nth-frame index)) - collect `(,tag . ,(safe-source-location-for-emacs code-location)))) + collect `(,tag . ,(code-location-source-location code-location)))) (defslimefun invoke-nth-restart (index) (invoke-restart (nth-restart index))) From heller at common-lisp.net Sat Nov 29 07:59:14 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 29 Nov 2003 02:59:14 -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-serv20032 Modified Files: swank-lispworks.lisp Log Message: Xref support. (make-dspec-location): Updated for the new source-location format. Date: Sat Nov 29 02:59:13 2003 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.2 slime/swank-lispworks.lisp:1.3 --- slime/swank-lispworks.lisp:1.2 Fri Nov 28 09:28:17 2003 +++ slime/swank-lispworks.lisp Sat Nov 29 02:59:12 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.2 2003/11/28 14:28:17 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.3 2003/11/29 07:59:12 heller Exp $ ;;; (in-package :swank) @@ -295,16 +295,18 @@ (delete-file binary-filename))) (delete-file filename))) -(defun make-dspec-location (dspec filename &optional tmpfile buffer position) - (list :dspec - (cond ((and tmpfile (pathname-match-p filename tmpfile)) - (list :buffer buffer position)) - (t - (let ((name (namestring (translate-logical-pathname filename)))) - (list :file name)))) - (string (etypecase dspec - (symbol dspec) - (cons (dspec:dspec-primary-name dspec)))))) +(defun make-dspec-location (dspec location &optional tmpfile buffer position) + (flet ((from-buffer-p () (and (pathnamep location) tmpfile + (pathname-match-p location tmpfile)))) + (make-location + (etypecase location + (pathname (cond ((from-buffer-p) `(:buffer ,buffer)) + (t `(:file ,(namestring (truename location))))))) + (cond ((from-buffer-p) `(:position ,position)) + (t `(:dspec , (etypecase dspec + (symbol (symbol-name dspec)) + (cons (symbol-name + (dspec:dspec-primary-name dspec)))))))))) (defun signal-error-data-base (database &optional tmpfile buffer position) (map-error-database @@ -339,3 +341,32 @@ (signal-undefined-functions compiler::*unknown-functions* tmpname tmpname buffer position)))) +;;; xref + +(defslimefun who-calls (function-name) + (xref-results-for-emacs (hcl:who-calls function-name))) + +(defslimefun who-references (variable) + (xref-results-for-emacs (hcl:who-references variable))) + +(defslimefun who-binds (variable) + (xref-results-for-emacs (hcl:who-binds variable))) + +(defslimefun who-sets (variable) + (xref-results-for-emacs (hcl:who-sets variable))) + +(defun xref-results-for-emacs (dspecs) + (let ((xrefs '())) + (dolist (dspec dspecs) + (loop for (dspec location) in (dspec:find-dspec-locations dspec) + do (push (cons (to-string dspec) + (make-dspec-location dspec location)) + xrefs))) + (group-xrefs xrefs))) + +;; (dspec:at-location +;; ('(:inside (:buffer "foo" 34))) +;; (defun foofun () (foofun))) + +;; (dspec:find-dspec-locations 'xref-results-for-emacs) +;; (who-binds '*package*) \ No newline at end of file From heller at common-lisp.net Sat Nov 29 08:03:44 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 29 Nov 2003 03:03:44 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21055 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Nov 29 03:03:44 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.120 slime/ChangeLog:1.121 --- slime/ChangeLog:1.120 Fri Nov 28 18:29:02 2003 +++ slime/ChangeLog Sat Nov 29 03:03:43 2003 @@ -1,3 +1,34 @@ +2003-11-29 Helmut Eller + + * slime.el: Some tweaking to the REPL. slime-repl-input-end-mark + is now always left inserting and slime-mark-input-end + "deactivates" the end mark by moving it to the beginning of the + buffer. + (slime-goto-source-location): Next try for more uniform + source-locations. A source-location is now a structure with a + "buffer-designator" and "position-designator". The buffer-designator + open the file or buffer and the position-designator moves point to the + right position. + (slime-autodoc-mode): New command. + (slime-find-fdefinitions): Experimental support for generic functions + with methods. + (slime-show-xrefs, slime-insert-xrefs, slime-goto-xref): Rewritten to + work with more general source locations. + + * swank.lisp: Structure definitions for source-locations. + (alistify, location-position<, group-xrefs): Utilities for xref + support. + + * swank-cmucl.lisp (code-location-source-location): Renamed from + safe-source-location-for-emacs. + (code-location-from-source-location): Renamed from + source-location-for-emacs. + (find-fdefinitions, function-source-locations): New functions. + (safe-definition-finding): New macro. + + * swank-lispworks.lisp: Xref support. + (make-dspec-location): Updated for the new source-location format. + 2003-11-29 Luke Gorrie * slime.el (complete-symbol, arglist): Updated test cases for new From dbarlow at common-lisp.net Sat Nov 29 22:12:10 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 17:12:10 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10663 Modified Files: slime.el Log Message: (slime-idle-state): added :debug as a valid transition Date: Sat Nov 29 17:12:10 2003 Author: dbarlow Index: slime/slime.el diff -u slime/slime.el:1.118 slime/slime.el:1.119 --- slime/slime.el:1.118 Sat Nov 29 02:51:48 2003 +++ slime/slime.el Sat Nov 29 17:12:09 2003 @@ -1230,10 +1230,14 @@ "List of stack-tags of continuations waiting on the stack.") (slime-defstate slime-idle-state () - "Idle state. The only event allowed is to make a request." + "Idle state. The user may make a request, or Lisp may invoke the debugger." ((activate) (assert (= sldb-level 0)) (slime-repl-activate)) + ((:debug level condition restarts frames) + (slime-push-state + (slime-debugging-state level condition restarts frames + (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)))) From dbarlow at common-lisp.net Sat Nov 29 22:12:43 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 17:12: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-serv10767 Modified Files: swank-backend.lisp Log Message: export slime-debugger-function Date: Sat Nov 29 17:12:42 2003 Author: dbarlow Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.5 slime/swank-backend.lisp:1.6 --- slime/swank-backend.lisp:1.5 Wed Nov 26 19:44:40 2003 +++ slime/swank-backend.lisp Sat Nov 29 17:12:42 2003 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.5 2003/11/27 00:44:40 heller Exp $ +;;; $Id: swank-backend.lisp,v 1.6 2003/11/29 22:12:42 dbarlow Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -80,6 +80,7 @@ #:sldb-abort #:sldb-continue #:take-input + #:slime-debugger-function )) (in-package :swank) From dbarlow at common-lisp.net Sat Nov 29 22:14:08 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 17:14:08 -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-serv11041 Modified Files: swank-sbcl.lisp Log Message: Sort out some of the problems with stale serve-event handlers (note that you also need a fix for sb-bsd-sockets from 0.8.6.x SBCL, if this is bothering you) Date: Sat Nov 29 17:14:08 2003 Author: dbarlow Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.29 slime/swank-sbcl.lisp:1.30 --- slime/swank-sbcl.lisp:1.29 Fri Nov 28 07:10:41 2003 +++ slime/swank-sbcl.lisp Sat Nov 29 17:14:07 2003 @@ -7,9 +7,8 @@ ;;; This code has been placed in the Public Domain. All warranties are ;;; disclaimed. -;;; This is a rapidly evolving Slime backend for SBCL. Requires -;;; bleeding-edge SBCL with the SB-THREAD feature and SB-INTROSPECT -;;; contrib +;;; This is a Slime backend for SBCL. Requires SBCL 0.8.5 or later +;;; for the SB-INTROSPECT contrib ;;; Cursory testing has found that the following appear to work ;;; @@ -112,6 +111,8 @@ (make-instance 'slime-output-stream))) (in (make-instance 'slime-input-stream)) (io (make-two-way-stream in out))) + ;; we're being called from a serve-event handler: remove it now + ;; because socket-close doesn't (in 0.8.6 anyway) do it for us (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor server-socket)) (sb-bsd-sockets:socket-close server-socket) @@ -130,8 +131,7 @@ (slime-read-error (e) (when *swank-debug-p* (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*)) - (close *emacs-io*))))) + (close *emacs-io* :abort t))))) ;;; Utilities From dbarlow at common-lisp.net Sat Nov 29 22:15:00 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 17:15:00 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12056 Modified Files: swank.lisp Log Message: (slime-debugger-function): New. Returns a function suitable for use as the value of *DEBUGGER-HOOK* to install the SLIME debugger globally. Must be run from the *slime-repl* buffer or somewhere else that the slime streams are visible so that it can capture them. e.g. for Araneida: PKG> (setf araneida:*restart-on-handler-errors* (swank:slime-debugger-fucntion)) Date: Sat Nov 29 17:15:00 2003 Author: dbarlow Index: slime/swank.lisp diff -u slime/swank.lisp:1.72 slime/swank.lisp:1.73 --- slime/swank.lisp:1.72 Sat Nov 29 02:53:42 2003 +++ slime/swank.lisp Sat Nov 29 17:15:00 2003 @@ -94,19 +94,27 @@ "When non-nil redirect Lisp standard I/O to Emacs. Redirection is done while Lisp is processing a request for Emacs.") +(defun call-with-slime-streams (in out io fn args) + (if *redirect-output* + (let ((*standard-output* out) + (*slime-input* in) + (*slime-output* out) + (*slime-io* io) + (*error-output* out) + (*trace-output* out) + (*debug-io* io) + (*query-io* io) + (*standard-input* in) + (*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))) - (if *redirect-output* - (let ((*standard-output* *slime-output*) - (*error-output* *slime-output*) - (*trace-output* *slime-output*) - (*debug-io* *slime-io*) - (*query-io* *slime-io*) - (*standard-input* *slime-input*) - (*terminal-io* *slime-io*)) - (apply #'funcall form)) - (apply #'funcall form)))) + (call-with-slime-streams + *slime-input* *slime-output* *slime-io* + #'funcall form))) (define-condition slime-read-error (error) ((condition :initarg :condition :reader slime-read-error.condition)) @@ -257,6 +265,27 @@ (let ((*sldb-level* (1+ *sldb-level*))) (call-with-debugging-environment (lambda () (sldb-loop *sldb-level*)))))) + +(defun slime-debugger-function () + "Returns a function suitable for use as the value of *DEBUGGER-HOOK* +or SB-DEBUG::*INVOKE-DEBUGGER-HOOK*, to install the SLIME debugger +globally. Must be run from the *slime-repl* buffer or somewhere else +that the slime streams are visible so that it can capture them." + (let ((package *buffer-package*) + (in *slime-input*) + (out *slime-output*) + (io *slime-io*) + (eio *emacs-io*)) + (labels ((slime-debug (c &optional next) + (let ((*buffer-package* package) + (*emacs-io* eio)) + ;; check emacs is still there: don't want to end up + ;; in recursive debugger loops if it's disconnected + (when (open-stream-p *emacs-io*) + (call-with-slime-streams + in out io + #'swank::swank-debugger-hook (list c next)))))) + #'slime-debug))) (defun sldb-loop (level) (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1))) From dbarlow at common-lisp.net Sat Nov 29 22:15:36 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 17:15:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12395 Modified Files: ChangeLog Log Message: Date: Sat Nov 29 17:15:36 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.121 slime/ChangeLog:1.122 --- slime/ChangeLog:1.121 Sat Nov 29 03:03:43 2003 +++ slime/ChangeLog Sat Nov 29 17:15:36 2003 @@ -1,3 +1,15 @@ +2003-11-29 Daniel Barlow + + * slime.el (slime-idle-state): added :debug as a valid transition + + * swank.lisp (slime-debugger-function): New. Returns a function + suitable for use as the value of *DEBUGGER-HOOK* to install the + SLIME debugger globally. Must be run from the *slime-repl* buffer + or somewhere else that the slime streams are visible so that it + can capture them. e.g. for Araneida: + PKG> (setf araneida:*restart-on-handler-errors* + (swank:slime-debugger-fucntion)) + 2003-11-29 Helmut Eller * slime.el: Some tweaking to the REPL. slime-repl-input-end-mark @@ -144,7 +156,7 @@ 2003-11-25 Daniel Barlow - * swank-sbcl.lisp: delete big chunk of leftover commented-out + * swank-sbcl.lisp: delete big chunk of leftover commented-out code * slime.el: arglist command to use slime-read-symbol-name, From dbarlow at common-lisp.net Sat Nov 29 22:57:13 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 17:57:13 -0500 Subject: [slime-cvs] CVS update: slime/README.sbcl Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28062 Removed Files: README.sbcl Log Message: dead. not to mention out of date Date: Sat Nov 29 17:57:12 2003 Author: dbarlow From dbarlow at common-lisp.net Sat Nov 29 23:31:29 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 18:31:29 -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-serv8956 Modified Files: swank-sbcl.lisp Log Message: * swank-sbcl.lisp (source-location-for-emacs): sb-debug::print-description-to-string takes only two args, not three. Now 'v' command works in sldb :-) Date: Sat Nov 29 18:31:29 2003 Author: dbarlow Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.30 slime/swank-sbcl.lisp:1.31 --- slime/swank-sbcl.lisp:1.30 Sat Nov 29 17:14:07 2003 +++ slime/swank-sbcl.lisp Sat Nov 29 18:31:29 2003 @@ -492,7 +492,7 @@ (unless (or (eq from :file) (debug-source-info-from-emacs-buffer-p debug-source)) (with-output-to-string (*standard-output*) - (sb-debug::print-code-location-source-form code-location 100 t)))))) + (sb-debug::print-code-location-source-form code-location 100)))))) (defun safe-source-location-for-emacs (code-location) (handler-case (source-location-for-emacs code-location) From dbarlow at common-lisp.net Sat Nov 29 23:31:43 2003 From: dbarlow at common-lisp.net (Dan Barlow) Date: Sat, 29 Nov 2003 18:31:43 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9024 Modified Files: ChangeLog Log Message: Date: Sat Nov 29 18:31:43 2003 Author: dbarlow Index: slime/ChangeLog diff -u slime/ChangeLog:1.122 slime/ChangeLog:1.123 --- slime/ChangeLog:1.122 Sat Nov 29 17:15:36 2003 +++ slime/ChangeLog Sat Nov 29 18:31:43 2003 @@ -1,5 +1,9 @@ 2003-11-29 Daniel Barlow + * swank-sbcl.lisp (source-location-for-emacs): + sb-debug::print-description-to-string takes only two args, not + three. Now 'v' command works in sldb :-) + * slime.el (slime-idle-state): added :debug as a valid transition * swank.lisp (slime-debugger-function): New. Returns a function From heller at common-lisp.net Sun Nov 30 07:58:45 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 30 Nov 2003 02:58: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-serv19186 Modified Files: slime.el Log Message: (slime-goto-source-location): New representation for source locations. Drop old code. Rewrite the xref code to work with other source locations. (slime-edit-fdefinition): Use the xref window to display generic functions with methods. (slime-list-callers, slime-list-callees): Use the xref window. Remove the slime-select-* stuff. (slime-describe-function): New command. Bound to C-c C-f. Primarily useful in Lispworks. (slime-complete-symbol): Display the completion window if the prefix is complete but not unique. (slime-forward-positioned-source-path): Enter the sexp only if the remaining sourcepath is not empty. (slime-read-symbol-name): New optional argument QUERY forces querying. Date: Sun Nov 30 02:58:45 2003 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.119 slime/slime.el:1.120 --- slime/slime.el:1.119 Sat Nov 29 17:12:09 2003 +++ slime/slime.el Sun Nov 30 02:58:45 2003 @@ -362,6 +362,7 @@ ;; Documentation (" " slime-space :inferior t) ("\C-d" slime-describe-symbol :prefixed t :inferior t :sldb t) + ("\C-f" slime-describe-function :prefixed t :inferior t :sldb t) ("\M-d" slime-disassemble-symbol :prefixed t :inferior t :sldb t) ("\C-t" slime-toggle-trace-fdefinition :prefixed t :sldb t) ("\C-a" slime-apropos :prefixed t :inferior t :sldb t) @@ -635,12 +636,14 @@ (point))) (slime-function-called-at-point))) -(defun slime-read-symbol-name (prompt) +(defun slime-read-symbol-name (prompt &optional query) "Either read a symbol name or choose the one at point. -The user is prompted if a prefix argument is in effect or there is no -symbol at point." - (or (and (not current-prefix-arg) (slime-symbol-name-at-point)) - (slime-completing-read-symbol-name prompt))) +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))) + (t (slime-symbol-name-at-point)))) (defun slime-read-symbol (prompt) "Either read a symbol or choose the one at point. @@ -689,23 +692,22 @@ (defmacro slime-with-output-to-temp-buffer (name &rest body) "Like `with-output-to-temp-buffer', but saves the window configuration." (let ((config (gensym))) - `(progn - (let ((,config (current-window-configuration)) - (standard-output (with-current-buffer (get-buffer-create ,name) - (setq buffer-read-only nil) - (erase-buffer) - (current-buffer)))) - (prog1 (progn , at body) - (with-current-buffer standard-output - (make-local-variable 'slime-temp-buffer-saved-window-configuration) - (setq slime-temp-buffer-saved-window-configuration ,config) - (goto-char (point-min)) - (slime-mode 1) - (set-syntax-table lisp-mode-syntax-table) - (slime-temp-buffer-mode 1) - (setq buffer-read-only t) - (unless (get-buffer-window (current-buffer) t) - (switch-to-buffer-other-window (current-buffer))))))))) + `(let ((,config (current-window-configuration)) + (standard-output (with-current-buffer (get-buffer-create ,name) + (setq buffer-read-only nil) + (erase-buffer) + (current-buffer)))) + (prog1 (progn , at body) + (with-current-buffer standard-output + (make-local-variable 'slime-temp-buffer-saved-window-configuration) + (setq slime-temp-buffer-saved-window-configuration ,config) + (goto-char (point-min)) + (slime-mode 1) + (set-syntax-table lisp-mode-syntax-table) + (slime-temp-buffer-mode 1) + (setq buffer-read-only t) + (unless (get-buffer-window (current-buffer) t) + (switch-to-buffer-other-window (current-buffer)))))))) (put 'slime-with-output-to-temp-buffer 'lisp-indent-function 1) @@ -2038,8 +2040,12 @@ "Move forward through a sourcepath from a fixed position. The point is assumed to already be at the outermost sexp, making the first element of the source-path redundant." - (ignore-errors (down-list 1)) - (slime-forward-source-path (cdr source-path))) + (ignore-errors + (slime-forward-sexp) + (beginning-of-defun)) + (when-let (source-path (cdr source-path)) + (down-list 1) + (slime-forward-source-path source-path))) (defun slime-forward-source-path (source-path) (let ((origin (point))) @@ -2054,21 +2060,20 @@ (beginning-of-sexp)) (error (goto-char origin))))) -(defun slime-goto-source-location (location) - "Move to the source location LOCATION. - -LOCATION is a plist and defines a position in a buffer. Several kinds -of locations are supported: - - (:file ,filename ,position[ ,align-p]) - A position in a file. - (:emacs-buffer ,buffername ,position[ ,align-p]) - A position in a buffer. - (:sexp ,string) - A sexp where no file is available. - -align-p means the location is not character-accurate, and should be -aligned to the start of the sexp in front." +(defun slime-goto-source-location (location &optional noerror) + "Move to the source location LOCATION. Several kinds of locations +are supported: + + ::= (:location ) + | (:error ) + + ::= (:file ) + | (:buffer ) + | (:source-form ) + + ::= (:position []) ; 1 based + | (:function-name ) + | (:source-path ) " (destructure-case location ((:location buffer position) (destructure-case buffer @@ -2077,71 +2082,32 @@ (goto-char (point-min))) ((:buffer buffer) (set-buffer buffer) + (goto-char (point-min))) + ((:source-form string) + (set-buffer (get-buffer-create "*SLIME Source Form*")) + (erase-buffer) + (insert string) (goto-char (point-min)))) (destructure-case position - ((:position pos) - (goto-char pos)) - ((:dspec name) + ((:position pos &optional align-p) + (goto-char pos) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) + ((:function-name name) (let ((case-fold-search t)) - (re-search-forward (format "^(def.*[ \n\t(]%s[ \t)]" name))) - (goto-char (match-beginning 0))))) - ((:file filename position &optional align-p) - (set-buffer (find-file-noselect filename t)) - (goto-char position) - (when align-p - (slime-forward-sexp) - (beginning-of-sexp))) - ((:emacs-buffer buffer position &optional align-p) - (set-buffer buffer) - (goto-char position) - (when align-p - (slime-forward-sexp) - (beginning-of-sexp))) - ((:sexp string) - (with-output-to-temp-buffer "*SLIME SEXP*" - (princ string))) - ((:dspec origin dspec) - (destructure-case origin - ((:file filename) - (set-buffer (find-file-noselect filename t)) - (goto-char 1)) - ((:buffer buffer position) - (set-buffer buffer) - (goto-char position))) - (when dspec - (let ((case-fold-search t)) - (re-search-forward (format "^(def.*[ \n\t(]%s[ \t)]" dspec))) - (goto-char (match-beginning 0)))) - ((:openmcl filename function-name) - (set-buffer (find-file-noselect filename t)) - (goto-char (point-min)) - (re-search-forward (format "^(def.*[ \n\t(]%s[ \t)]" function-name)) - (beginning-of-line)) - ((:sbcl - &key from buffername buffer-offset - filename position info source-path path source-form function-name) - (cond (function-name - (ignore-errors - (when filename - (set-buffer (find-file-noselect filename))) - (goto-char (point-min)) - (re-search-forward (format "^(def\\S-+\\s +%s\\s +" - function-name)) - (beginning-of-line))) - ((and (eq filename :lisp) (not buffername)) - (beginning-of-defun)) - (t - (cond (buffername - (set-buffer buffername) (goto-char buffer-offset)) - (filename - (set-buffer (find-file-noselect filename)) - (when position (goto-char position)))) - (cond (path - (slime-forward-source-path (cdr path))) - (source-path - (slime-forward-positioned-source-path source-path)) - (t - (forward-sexp) (backward-sexp)))))))) + (re-search-forward (format "^(\\(def.*[ \n\t(]\\)?%s[ \t)]" name))) + (goto-char (match-beginning 0))) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))))) + ((:error message) + (if noerror + (slime-message "%s" message) + (error "%s" message))))) (defmacro slime-point-moves-p (&rest body) "Execute BODY and return true if the current buffer's point moved." @@ -2509,13 +2475,14 @@ (delete-region beg end) (insert-and-inherit completed-prefix) (goto-char (+ beg (length completed-prefix))) - (cond ((member completed-prefix completion-set) - (if (= (length completion-set) 1) - (slime-minibuffer-respecting-message "Sole completion") - (slime-minibuffer-respecting-message "Complete but not unique")) + (cond ((and (member completed-prefix completion-set) + (= (length completion-set) 1)) + (slime-minibuffer-respecting-message "Sole completion") (slime-complete-restore-window-configuration)) ;; Incomplete (t + (when (member completed-prefix completion-set) + (slime-minibuffer-respecting-message "Complete but not unique")) (let ((unambiguous-completion-length (loop for c in completion-set minimizing (or (mismatch completed-prefix c) @@ -2682,49 +2649,29 @@ function name is prompted." (interactive (list (slime-read-symbol-name "Function name: "))) (let ((origin (point-marker)) - (source-location - (slime-eval `(swank:function-source-location-for-emacs ,name) - (slime-buffer-package)))) - (cond ((or (null source-location) (equal source-location '(:null))) - (message "No definition found: %s" name)) - ((equal (car source-location) :error) - (slime-message "%s" (cadr source-location))) - (t - (slime-goto-source-location source-location) + (locations (slime-eval `(swank:find-function-locations ,name) + (slime-buffer-package)))) + (assert locations) + (ring-insert-at-beginning slime-find-definition-history-ring origin) + (cond ((null (cdr locations)) + (slime-goto-source-location (car locations)) (cond ((not other-window) (switch-to-buffer (current-buffer))) (t - (switch-to-buffer-other-window (current-buffer)))) - (ring-insert-at-beginning - slime-find-definition-history-ring origin))))) + (switch-to-buffer-other-window (current-buffer))))) + (t (slime-show-definitions name locations))))) (defun slime-edit-fdefinition-other-window (name) "Like `slime-edit-fdefinition' but switch to the other window." (interactive (list (slime-read-symbol-name "Function name: "))) (slime-edit-fdefinition name t)) -(defun slime-find-fdefinitions (name) - "Like `slime-edit-fdefinition' but with support for generic functions." - (interactive (list (slime-read-symbol-name "Function name: "))) - (let ((origin (point-marker)) - (locations (slime-eval `(swank:find-fdefinitions ,name) - (slime-buffer-package)))) - (assert locations) - (cond ((null (cdr locations)) - (slime-goto-source-location (car locations)) - (switch-to-buffer (current-buffer)) - (ring-insert-at-beginning slime-find-definition-history-ring - origin)) - (t - (slime-show-definitions name locations))))) - (defun slime-show-definitions (name locations) (slime-show-xrefs `((,name . ,(loop for l in locations collect (cons (format "%s" l) l)))) 'definition name (slime-buffer-package))) - ;;; Interactive evaluation. @@ -2870,6 +2817,12 @@ (error "No symbol given")) (slime-eval-describe `(swank:describe-symbol ,symbol-name))) +(defun slime-describe-function (symbol-name) + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-function ,symbol-name))) + (defun slime-apropos (string &optional only-external-p package) (interactive (if current-prefix-arg @@ -2957,44 +2910,52 @@ ;;; XREF: cross-referencing -(defvar slime-xref-summary nil - "Summary of a cross reference list, for the mode line.") +(defvar slime-xref-mode-map) -(define-minor-mode slime-xref-mode - "\\" - nil - nil - '(("RET" . slime-goto-xref) - ("\C-m" . slime-goto-xref) - )) - -;; Setup the mode-line to say when we're in slime-mode, and which CL -;; package we think the current buffer belongs to. -(add-to-list 'minor-mode-alist '(slime-xref-mode slime-xref-summary)) +(define-derived-mode slime-xref-mode lisp-mode "xref" + "\\ +\\{slime-xref-mode-map}" + (setq font-lock-defaults nil) + (slime-mode -1)) + +(slime-define-keys slime-xref-mode-map + ((kbd "RET") 'slime-show-xref) + ("\C-m" 'slime-show-xref) + (" " 'slime-goto-xref) + ("q" 'slime-xref-quit) + ;;("n" 'slime-xref-next) + ;;("p" 'slime-xref-previous) + ) + +(dolist (spec slime-keys) + (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec + (when sldb + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key slime-xref-mode-map key command))))) (defun slime-who-calls (symbol) "Show all known callers of the function SYMBOL." - (interactive (list (slime-read-symbol "Who calls: "))) + (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 "Who references: "))) + (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 "Who binds: "))) + (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 "Who sets: "))) + (interactive (list (slime-read-symbol-name "Who sets: " t))) (slime-xref 'sets symbol)) (defun slime-who-macroexpands (symbol) "Show all known expanders of the macro SYMBOL." - (interactive (list (slime-read-symbol "Who macroexpands: "))) + (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) (slime-xref 'macroexpands symbol)) (defun slime-xref (type symbol) @@ -3013,17 +2974,14 @@ (if (null xrefs) (message "No references found for %s." symbol) (setq slime-next-location-function 'slime-goto-next-xref) - (with-current-buffer (slime-xref-buffer t) - (slime-init-xref-buffer package type symbol) + (slime-with-xref-buffer (package type symbol) (slime-insert-xrefs xrefs) - (setq buffer-read-only t) (goto-char (point-min)) - (save-selected-window - (delete-windows-on (slime-xref-buffer)) - (slime-display-xref-buffer))))) + (forward-line) + (skip-chars-forward " \t")))) (defun slime-insert-xrefs (xrefs) - "Insert the cross-references for a file. + "Insert XREFS in the current-buffer. XREFS is a list of the form ((GROUP . ((LABEL . LOCATION) ...)) ...) GROUP and LABEL are for decoration purposes. LOCATION is a source-location." (unless (bobp) (insert "\n")) @@ -3049,15 +3007,34 @@ (defun slime-init-xref-buffer (package ref-type symbol) "Initialize the current buffer for displaying XREF information." - (slime-xref-mode t) + (slime-xref-mode) (setq buffer-read-only nil) (erase-buffer) - (set-syntax-table lisp-mode-syntax-table) - (slime-mode t) (setq slime-buffer-package package) - (slime-set-truncate-lines) - (setq slime-xref-summary - (format " XREF[%s: %s]" ref-type symbol))) + (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) (defun slime-display-xref-buffer () "Display the XREF results buffer in a window and select it." @@ -3072,15 +3049,25 @@ ;;;; XREF navigation + +(defun slime-xref-location-at-point () + (or (get-text-property (point) 'slime-location) + (error "No reference at point."))) + (defun slime-goto-xref () "Goto the cross-referenced location at point." (interactive) - (let ((location (get-text-property (point) 'slime-location))) - (unless location - (error "No reference at point.")) - (slime-show-source-location location))) - + (let ((location (slime-xref-location-at-point))) + (slime-xref-cleanup) + (slime-goto-source-location location) + (switch-to-buffer (current-buffer)))) +(defun slime-show-xref () + "Display the xref at point in the other window." + (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 @@ -3104,138 +3091,44 @@ (error "No context for finding locations.")) (funcall slime-next-location-function)) +(defun slime-xref-quit () + "Kill the current xref buffer and restore the window configuration." + (interactive) + (let ((config slime-xref-saved-window-configuration)) + (slime-xref-cleanup) + (set-window-configuration config))) + +(defun slime-xref-cleanup () + "Delete overlays created by xref mode and kill the xref buffer." + (sldb-delete-overlays) + (let ((buffer (current-buffer))) + (delete-windows-on buffer) + (kill-buffer buffer))) + ;;; List callers/callees -(defvar slime-select-mode-map) -(defvar slime-previous-selected-line) -(defvar slime-select-finish) -(defvar slime-select-follow) -(defvar slime-select-saved-window-configuration) +(defun slime-eval-show-function-list (form type name) + "Eval FROM in Lisp and display the result in a xref window." + (ring-insert-at-beginning slime-find-definition-history-ring (point-marker)) + (lexical-let ((package (slime-buffer-package)) + (name name) + (type type)) + (slime-eval-async form package + (lambda (result) + (slime-show-xrefs result type name package))))) (defun slime-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window." (interactive (list (slime-read-symbol-name "List callers: "))) - (slime-eval-select-function-list `(swank:list-callers ,symbol-name))) + (slime-eval-show-function-list `(swank:list-callers ,symbol-name) + 'callers symbol-name)) (defun slime-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window." (interactive (list (slime-read-symbol-name "List callees: "))) - (slime-eval-select-function-list `(swank:list-callees ,symbol-name))) - -(defun slime-eval-select-function-list (sexp) - (lexical-let ((package (slime-buffer-package))) - (slime-eval-async sexp package - (lambda (names) - (slime-select-function names package))) - (slime-save-window-configuration))) - -(defun slime-select-function (function-names package) - (if (null function-names) - (message "No callers") - (with-lexical-bindings (function-names package) - (slime-select - function-names - (lambda (index) - (slime-eval-async `(swank:function-source-location-for-emacs - ,(nth index function-names)) - package - (lambda (loc) - (let ((pop-up-windows nil)) - (slime-carefully-show-source-location loc))))) - (lambda (index)))))) - -(defun slime-carefully-show-source-location (location) - (condition-case e - (slime-show-source-location location) - (error (message "%s" (error-message-string e)) - (ding)))) - -(defvar slime-select-split-window-vectically nil) - -(defun slime-get-select-window (labels) - (cond (slime-select-split-window-vectically - (split-window (selected-window) - (- (frame-width) - (min (1+ (max - (loop for l in labels maximize (length l)) - window-min-width)) - 25)) - t)) - (t - (cond ((one-window-p) - (split-window (selected-window))) - (t (next-window)))))) - -(defun slime-select-pop-to-window (buffer labels) - (let ((window (slime-get-select-window labels))) - (set-window-buffer window (current-buffer)) - (select-window window) - (shrink-window-if-larger-than-buffer window))) - -(defun slime-select (labels follow finish) - "Select an item form the list LABELS. - -The list is displayed in a new buffer. FOLLOW is called with the -current index whenever a new line is selected. FINISH is called with -the current index when the selection is completed." - (set-buffer (get-buffer-create "*SLIME Select*")) - (setq buffer-read-only nil) - (erase-buffer) - (loop for (label . r) on labels - do (progn (insert label) - (when r (insert "\n")))) - (goto-char (point-min)) - (slime-select-mode) - (setq slime-select-follow follow) - (setq slime-select-finish finish) - (setq buffer-read-only t) - (setq slime-select-saved-window-configuration - (current-window-configuration)) - (slime-select-pop-to-window (current-buffer) labels) - (slime-select-post-command-hook)) - -(defun slime-selected-line () - (count-lines (point-min) (save-excursion (beginning-of-line) (point)))) - -(define-derived-mode slime-select-mode fundamental-mode "SLIME-Select" - "Mode to select an item from a list." - (mapc #'make-variable-buffer-local - '(slime-previous-selected-line - slime-select-follow - slime-select-finish - slime-select-saved-window-configuration)) - (setq slime-previous-selected-line -1) - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'slime-select-post-command-hook nil t) - (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) - (slime-mode t)) - -(defun slime-select-post-command-hook () - (unless (eq slime-previous-selected-line (slime-selected-line)) - (let ((line (slime-selected-line))) - (setq slime-previous-selected-line line) - (ignore-errors (funcall slime-select-follow line))))) - -(defun slime-select-done () - (interactive) - (save-current-buffer - (funcall slime-select-finish (slime-selected-line))) - (slime-select-cleanup)) - -(defun slime-select-cleanup () - (let ((buffer (current-buffer))) - (delete-windows-on buffer) - (kill-buffer buffer))) - -(defun slime-select-quit () - (interactive) - (set-window-configuration slime-select-saved-window-configuration) - (slime-select-cleanup)) - -(slime-define-keys slime-select-mode-map - ([return] 'slime-select-done) - ("q" 'slime-select-quit)) - -;;; + (slime-eval-show-function-list `(swank:list-callees ,symbol-name) + 'callees symbol-name)) ;;; Macroexpansion @@ -3245,11 +3138,15 @@ (slime-eval-describe `(,expander ,string)))) (defun slime-macroexpand-1 (&optional repeatedly) + "Display the macro expansion of the form at point. The form is +expanded with CL:MACROEXPAND-1 or, if a prefix argument is given, with +CL:MACROEXPAND." (interactive "P") (slime-eval-macroexpand (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1))) (defun slime-macroexpand-all () + "Display the recursively macro expanded sexp at point." (interactive) (slime-eval-macroexpand 'swank:swank-macroexpand-all)) From heller at common-lisp.net Sun Nov 30 08:09:46 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 30 Nov 2003 03:09:46 -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-serv30260 Modified Files: swank-cmucl.lisp Log Message: Use the format for source locations. (find-function-locations): New function. Replaces function-source-location-for-emacs. Returns a list of source-locations. (resolve-note-location): Renamed from resolve-location. Simplified. (brief-compiler-message-for-emacs): Print the source context (that's the thing after ==>). (who-xxxx): Take strings, not symbols, as arguments. (function-callees, function-callers): Use the same format as the who-xxx functions. Support for byte-compiled stuff. (code-location-stream-position): Try to be clever is the source path doesn't match the form. (call-with-debugging-environment): Bind *print-readably* to nil. Date: Sun Nov 30 03:09:44 2003 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.29 slime/swank-cmucl.lisp:1.30 --- slime/swank-cmucl.lisp:1.29 Sat Nov 29 02:58:00 2003 +++ slime/swank-cmucl.lisp Sun Nov 30 03:09:44 2003 @@ -176,17 +176,6 @@ (defvar *swank-source-info* nil "Bound to a SOURCE-INFO object during compilation.") -(defclass source-info () () - (:documentation "Some info about the current compilatoin unit.")) - -(defclass file-source-info (source-info) - ((filename :initarg :filename))) - -(defclass buffer-source-info (source-info) - ((buffer :initarg :buffer) - (start-offset :initarg :start-offset) - (string :initarg :string))) - (defvar *previous-compiler-condition* nil "Used to detect duplicates.") @@ -196,6 +185,11 @@ (defvar *compiler-notes* '() "List of compiler notes for the last compilation unit.") +(defvar *buffer-name* nil) +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) +(defvar *compile-filename* nil) + ;;;;; Trapping notes @@ -219,18 +213,6 @@ :message (brief-compiler-message-for-emacs condition context) :location (compiler-note-location context)))) -(defun compiler-note-location (context) - (cond (context - (let ((cx context)) - (resolve-location - *swank-source-info* - (c::compiler-error-context-file-name cx) - (c::compiler-error-context-file-position cx) - (reverse (c::compiler-error-context-original-source-path cx)) - (c::compiler-error-context-original-source cx)))) - (t - (resolve-location *swank-source-info* nil nil nil nil)))) - (defun severity-for-emacs (condition) "Return the severity of CONDITION." (etypecase condition @@ -244,40 +226,59 @@ and the source form highlighted. This makes much of the information in the error-context redundant." (declare (type (or c::compiler-error-context null) error-context)) - (let ((enclosing (and error-context - (c::compiler-error-context-enclosing-source - error-context)))) - (if enclosing - (format nil "--> ~{~<~%--> ~1:;~A~> ~}~%~A" enclosing condition) - (format nil "~A" condition)))) - -(defgeneric resolve-location (source-info - file-name file-position - source-path source)) - -(defmethod resolve-location (i (f pathname) position path source) - `(:file ,(unix-truename f) ,(1+ (source-path-file-position path f)))) - -(defmethod resolve-location ((i buffer-source-info) (f (eql :stream)) - position path source) - (with-slots (buffer start-offset string) i - `(:emacs-buffer - ,buffer - ,(+ start-offset (source-path-string-position path string))))) - -(defmethod resolve-location (i (f (eql :lisp)) position path source) - '(:null)) - -(defmethod resolve-location (i (f (eql nil)) - (pos (eql nil)) - (path (eql nil)) - (source (eql nil))) - '(:null)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A" + enclosing source condition))) + +(defun compiler-note-location (context) + (cond (context + (resolve-note-location + *buffer-name* + (c::compiler-error-context-file-name context) + (c::compiler-error-context-file-position context) + (reverse (c::compiler-error-context-original-source-path context)) + (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 ,(unix-truename f)) + `(:position ,(1+ (source-path-file-position path f))))) + +(defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source) + (make-location + `(:buffer ,b) + `(:position ,(+ *buffer-start-position* + (source-path-string-position path *buffer-substring*))))) + +(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-start-position*))) + (*compile-file-truename* + (make-location (list :file (namestring *compile-file-truename*)) + (list :position 0))) + (*compile-filename* + (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)) + (*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)) @@ -286,17 +287,17 @@ (defmethod compile-file-for-emacs (filename load-p) (clear-xref-info filename) (with-compilation-hooks () - (let ((*swank-source-info* (make-instance 'file-source-info - :filename filename))) - (compile-file filename :load load-p)))) + (let ((*buffer-name* nil) + (*compile-filename* filename)) + (compile-file filename :load load-p)))) (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () (let ((*package* *buffer-package*) - (*swank-source-info* (make-instance 'buffer-source-info - :buffer buffer - :start-offset position - :string string))) + (*compile-filename* nil) + (*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) (with-input-from-string (stream string) (ext:compile-from-stream stream @@ -307,26 +308,45 @@ ;;;; XREF +(defun lookup-xrefs (finder name) + (xref-results-for-emacs (funcall finder (from-string name)))) + (defslimefun who-calls (function-name) "Return the places where FUNCTION-NAME is called." - (xref-results-for-emacs (xref:who-calls function-name))) + (lookup-xrefs #'xref:who-calls function-name)) (defslimefun who-references (variable) "Return the places where the global variable VARIABLE is referenced." - (xref-results-for-emacs (xref:who-references variable))) + (lookup-xrefs #'xref:who-references variable)) (defslimefun who-binds (variable) "Return the places where the global variable VARIABLE is bound." - (xref-results-for-emacs (xref:who-binds variable))) + (lookup-xrefs #'xref:who-binds variable)) (defslimefun who-sets (variable) "Return the places where the global variable VARIABLE is set." - (xref-results-for-emacs (xref:who-sets variable))) + (lookup-xrefs #'xref:who-sets variable)) #+cmu19 (defslimefun who-macroexpands (macro) "Return the places where MACRO is expanded." - (xref-results-for-emacs (xref:who-macroexpands macro))) + (lookup-xrefs #'xref:who-macroexpands macro)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unkown source location: ~S ~S ~S " + name file source-path)))))) + (defun xref-results-for-emacs (contexts) "Prepare a list of xref contexts for Emacs. @@ -335,13 +355,9 @@ reference ::= (FUNCTION-SPECIFIER . SOURCE-LOCATION)" (let ((xrefs '())) (dolist (cxt contexts) - (let* ((name (xref:xref-context-name cxt)) - (file (xref:xref-context-file cxt)) - (source-path (xref:xref-context-source-path cxt)) - (position (source-path-file-position source-path file))) + (let ((name (xref:xref-context-name cxt))) (push (cons (to-string name) - (make-location (list :file (unix-truename file)) - (list :position (1+ position)))) + (resolve-xref-location cxt)) xrefs))) (group-xrefs xrefs))) @@ -349,9 +365,6 @@ (defun location-buffer= (location1 location2) (equalp location1 location2)) -;; (xref-results-for-emacs (xref:who-binds '*package*)) - - (defun file-xrefs-for-emacs (unix-filename contexts) "Return a summary of the references from a particular file. The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))" @@ -418,14 +431,13 @@ do (funcall fn (kernel:code-header-ref code i)))) (defun function-callees (function) - "Return FUNCTION's callees as a list of names." + "Return FUNCTION's callees as a list of functions." (let ((callees '())) (map-code-constants (vm::find-code-object function) (lambda (obj) (when (kernel:fdefn-p obj) - (push (kernel:fdefn-name obj) - callees)))) + (push (kernel:fdefn-function obj) callees)))) callees)) (declaim (ext:maybe-inline map-allocated-code-components)) @@ -461,33 +473,64 @@ (defun function-callers (function &optional (spaces '(:read-only :static :dynamic))) - "Return FUNCTION's callers as a list of names." + "Return FUNCTION's callers. The result is a list of code-objects." (let ((referrers '())) (declare (inline map-caller-code-components)) - (map-caller-code-components - function - spaces - (lambda (code) - (let ((entry (kernel:%code-entry-points code))) - (cond ((not entry) - (push (princ-to-string code) referrers)) - (t - (loop for e = entry then (kernel::%function-next e) - while e - for name = (kernel:%function-name e) - do (pushnew name referrers :test #'equal))))))) + (ext:gc :full t) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) referrers)) - -(defun stringify-function-name-list (list) - (let ((*print-pretty* nil)) - (mapcar #'to-string (remove-if-not #'ext:valid-function-name-p list)))) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used +for code-object without entry points, i.e., byte compiled +code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list + (cons name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name name))))))))) + +(defun code-component-entry-points (code) + "Return a list ((NAME . LOCATION) ...) of function definitons for +the code omponent CODE." + (delete-duplicates + (loop for e = (kernel:%code-entry-points code) + then (kernel::%function-next e) + while e + collect (cons (to-string (kernel:%function-name e)) + (function-source-location e))) + :test #'equal)) (defslimefun list-callers (symbol-name) - (stringify-function-name-list (function-callers (from-string symbol-name)))) + "Return a list ((FILE . ((NAME . LOCATION) ...)) ...) of callers." + (let ((components (function-callers (from-string symbol-name))) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + (group-xrefs xrefs))) (defslimefun list-callees (symbol-name) - (stringify-function-name-list (function-callees (from-string symbol-name)))) + (let ((fns (function-callees (from-string symbol-name)))) + (group-xrefs (mapcar (lambda (fn) + (cons (to-string (kernel:%function-name fn)) + (function-source-location fn))) + fns)))) ;;;; Definitions @@ -557,13 +600,16 @@ (let ((def-source (pcl::definition-source gf)) (name (string (pcl:generic-function-name gf)))) (etypecase def-source - (pathname `(:dspec (:file ,(guess-source-file def-source)) ,name)) + (pathname (make-location + `(:file ,(guess-source-file def-source)) + `(:function-name ,name))) (cons (destructuring-bind ((dg name) pathname) def-source (declare (ignore dg)) - (if pathname - `(:dspec (:file ,(guess-source-file pathname)) - ,(string name))))))))) + (etypecase pathname + (pathname + (make-location `(:file ,(guess-source-file pathname)) + `(:function-name ,(string name))))))))))) (defun method-source-location (method) (function-source-location (or (pcl::method-fast-function method) @@ -604,11 +650,7 @@ (destructuring-bind (first) (function-source-locations function) first)) -(defmethod function-source-location-for-emacs (fname) - "Return the source-location of FNAME's definition." - (car (find-fdefinitions fname))) - -(defslimefun find-fdefinitions (symbol-name) +(defslimefun 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) @@ -623,8 +665,6 @@ (format nil "Symbol not fbound: ~A" symbol-name)))) ))) -;; (find-fdefinitions "function-source-location-for-emacs") - ;;;; Documentation. @@ -881,7 +921,10 @@ (dotimes (i tlf-offset) (read stream)) (multiple-value-bind (tlf position-map) (read-and-record-source-map stream) (let* ((path-table (di:form-number-translations tlf 0)) - (source-path (reverse (cdr (aref path-table form-number))))) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) (source-path-source-position source-path tlf position-map))))) (defun code-location-string-offset (code-location string) @@ -893,14 +936,14 @@ (code-location-stream-position code-location s))) (defun make-file-location (pathname code-location) - (list :file - (unix-truename pathname) - (1+ (code-location-file-position code-location pathname)))) + (make-location + `(:file ,(unix-truename pathname)) + `(:position ,(1+ (code-location-file-position code-location pathname))))) (defun make-buffer-location (buffer start string code-location) - (list :emacs-buffer - buffer - (+ start (code-location-string-offset code-location string)))) + (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))) @@ -908,29 +951,32 @@ (consp info) (eq :emacs-buffer (car info))))) -(defun code-location-from-source-location (code-location) +(defun source-location-from-code-location (code-location) "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + (error "Bogus debug function: ~A" debug-fun))) (let* ((debug-source (di:code-location-debug-source code-location)) - (from (di:debug-source-from debug-source)) - (name (di:debug-source-name debug-source))) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) (ecase from (:file (make-file-location name code-location)) (: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-buffer-location (getf info :emacs-buffer) + (getf info :emacs-buffer-offset) + (getf info :emacs-buffer-string) + code-location))) (:lisp `(:sexp , (with-output-to-string (*standard-output*) - (debug::print-code-location-source-form - code-location 100 t))))))) + (debug::print-code-location-source-form + code-location 100 t))))))) (defun code-location-source-location (code-location) "Safe wrapper around `code-location-from-source-location'." (safe-definition-finding - (code-location-from-source-location code-location))) + (source-location-from-code-location code-location))) (defslimefun getpid () (unix:unix-getpid)) @@ -949,7 +995,8 @@ (*debugger-hook* nil) (*readtable* (or debug:*debug-readtable* *readtable*)) (*print-level* debug:*debug-print-level*) - (*print-length* debug:*debug-print-length*)) + (*print-length* debug:*debug-print-length*) + (*print-readably* nil)) (handler-bind ((di:debug-condition (lambda (condition) (signal (make-condition From heller at common-lisp.net Sun Nov 30 08:12:12 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 30 Nov 2003 03:12:12 -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-serv31046 Modified Files: swank-lispworks.lisp Log Message: Use the new format for source locations. Implement the find-function-locations. (list-callers, list-callers): New functions. Date: Sun Nov 30 03:12:12 2003 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.3 slime/swank-lispworks.lisp:1.4 --- slime/swank-lispworks.lisp:1.3 Sat Nov 29 02:59:12 2003 +++ slime/swank-lispworks.lisp Sun Nov 30 03:12:11 2003 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.3 2003/11/29 07:59:12 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.4 2003/11/30 08:12:11 heller Exp $ ;;; (in-package :swank) @@ -123,6 +123,18 @@ (if result (list* :designator (to-string symbol) result))))) +(defslimefun describe-function (symbol-name) + (with-output-to-string (*standard-output*) + (let ((sym (from-string symbol-name))) + (cond ((fboundp sym) + (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%" + (string-downcase sym) + (mapcar #'string-upcase + (lispworks:function-lambda-list sym)) + (documentation sym 'function)) + (describe (symbol-function sym))) + (t (format t "~S is not fbound" sym)))))) + #+(or) (defmethod describe-object ((sym symbol) *standard-output*) (format t "~A is a symbol in package ~A." sym (symbol-package sym)) @@ -231,15 +243,16 @@ (dspec-source-location func)))))) (defun dspec-source-location (dspec) - (let ((locations (dspec:dspec-definition-locations dspec))) + (destructuring-bind (first) (dspec-source-locations dspec) + first)) + +(defun dspec-source-locations (dspec) + (let ((locations (dspec:find-dspec-locations dspec))) (cond ((not locations) (list :error (format nil "Cannot find source for ~S" dspec))) (t - (destructuring-bind ((dspec file) . others) locations - (declare (ignore others)) - (if (eq file :unknown) - (list :error (format nil "Cannot find source for ~S" dspec)) - (make-dspec-location dspec file))))))) + (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 @@ -247,6 +260,9 @@ able to return the file name in which the definition occurs." (dspec-source-location (from-string fname))) +(defslimefun find-function-locations (fname) + (dspec-source-locations (from-string fname))) + ;;; callers (defun stringify-function-name-list (list) @@ -296,17 +312,32 @@ (delete-file filename))) (defun make-dspec-location (dspec location &optional tmpfile buffer position) - (flet ((from-buffer-p () (and (pathnamep location) tmpfile - (pathname-match-p location tmpfile)))) - (make-location - (etypecase location - (pathname (cond ((from-buffer-p) `(:buffer ,buffer)) - (t `(:file ,(namestring (truename location))))))) - (cond ((from-buffer-p) `(:position ,position)) - (t `(:dspec , (etypecase dspec - (symbol (symbol-name dspec)) - (cons (symbol-name - (dspec:dspec-primary-name dspec)))))))))) + (flet ((from-buffer-p () + (and (pathnamep location) tmpfile + (pathname-match-p location tmpfile))) + (filename (pathname) + (multiple-value-bind (truename condition) + (ignore-errors (truename pathname)) + (cond (condition + (return-from make-dspec-location + (list :error (format nil "~A" condition)))) + (t (namestring truename))))) + (function-name (dspec) + (etypecase dspec + (symbol (symbol-name dspec)) + (cons (symbol-name (dspec:dspec-primary-name dspec)))))) + (cond ((from-buffer-p) + (make-location `(:buffer ,buffer) `(:position ,position))) + (t + (etypecase location + (pathname + (make-location `(:file ,(filename location)) + `(:function-name ,(function-name dspec)))) + ((member :listener) + `(:error ,(format nil "Function defined in listener: ~S" dspec))) + ((member :unknown) + `(:error ,(format nil "Function location unkown: ~S" dspec)))) + )))) (defun signal-error-data-base (database &optional tmpfile buffer position) (map-error-database @@ -343,17 +374,20 @@ ;;; xref +(defun lookup-xrefs (finder name) + (xref-results-for-emacs (funcall finder (from-string name)))) + (defslimefun who-calls (function-name) - (xref-results-for-emacs (hcl:who-calls function-name))) + (lookup-xrefs #'hcl:who-calls function-name)) (defslimefun who-references (variable) - (xref-results-for-emacs (hcl:who-references variable))) + (lookup-xrefs #'hcl:who-references variable)) (defslimefun who-binds (variable) - (xref-results-for-emacs (hcl:who-binds variable))) + (lookup-xrefs #'hcl:who-binds variable)) (defslimefun who-sets (variable) - (xref-results-for-emacs (hcl:who-sets variable))) + (lookup-xrefs #'hcl:who-sets variable)) (defun xref-results-for-emacs (dspecs) (let ((xrefs '())) @@ -363,6 +397,12 @@ (make-dspec-location dspec location)) xrefs))) (group-xrefs xrefs))) + +(defslimefun list-callers (symbol-name) + (lookup-xrefs #'hcl:who-calls symbol-name)) + +(defslimefun list-callees (symbol-name) + (lookup-xrefs #'hcl:calls-who symbol-name)) ;; (dspec:at-location ;; ('(:inside (:buffer "foo" 34))) From heller at common-lisp.net Sun Nov 30 08:14:29 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 30 Nov 2003 03:14:29 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32295 Modified Files: swank.lisp Log Message: (group-xrefs): Handle unresolved source locations. (describe-symbol): Print something sensible about unknown symbols. Date: Sun Nov 30 03:14:28 2003 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.73 slime/swank.lisp:1.74 --- slime/swank.lisp:1.73 Sat Nov 29 17:15:00 2003 +++ slime/swank.lisp Sun Nov 30 03:14:28 2003 @@ -17,7 +17,7 @@ (in-package :swank) (defvar *swank-io-package* - (let ((package (make-package "SWANK-IO-PACKAGE"))) + (let ((package (make-package "SWANK-IO-PACKAGE" :use '()))) (import '(nil t quote) package) package)) @@ -638,8 +638,8 @@ If the rows are of unequal length, truncate uniformly to the shortest. For example: -\(transpose-lists '(("ONE" "TWO" "THREE") ("1" "2"))) - => (("ONE" "1") ("TWO" "2"))" +\(transpose-lists '((ONE TWO THREE) (1 2))) + => ((ONE 1) (TWO 2))" ;; A cute function from PAIP p.574 (if lists (apply #'mapcar #'list lists))) @@ -710,7 +710,12 @@ (print-output-to-string (lambda () (describe object)))) (defslimefun describe-symbol (symbol-name) - (print-description-to-string (find-symbol-designator symbol-name))) + (multiple-value-bind (symbol foundp) + (find-symbol-designator symbol-name) + (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 @@ -745,20 +750,12 @@ (defstruct (:location (:type list) :named (:constructor make-location (buffer position))) - buffer - position) + buffer position) -(defstruct (:file (:type list) :named (:constructor)) - name) - -(defstruct (:buffer (:type list) :named (:constructor)) - name) - -(defstruct (:position (:type list) :named (:constructor)) - pos) - -(defstruct (:buffer-position (:type list) :named (:constructor)) - pos) +(defstruct (:error (:type list) :named (:constructor)) message) +(defstruct (:file (:type list) :named (:constructor)) name) +(defstruct (:buffer (:type list) :named (:constructor)) name) +(defstruct (:position (:type list) :named (:constructor)) pos) (defun alistify (list key test) "Partition the element of LIST into an alist. KEY extracts the key @@ -776,19 +773,27 @@ (cond ((and (position-p pos1) (position-p pos2)) (< (position-pos pos1) (position-pos pos2))) - ((and (buffer-position-p pos1) (buffer-position-p pos2)) - (< (buffer-position-pos pos1) - (buffer-position-pos pos2))) (t nil))) - + +(defun partition (list predicate) + (loop for e in list + 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)))) - (let ((alist (alistify xrefs #'xref-buffer #'equal))) - (loop for (key . list) in alist - collect (cons (to-string key) - (sort list #'location-position< - :key #'xref-position)))))) + (multiple-value-bind (resolved errors) + (partition xrefs (lambda (x) (location-p (cdr x)))) + (let ((alist (alistify resolved #'xref-buffer #'equal))) + (append + (loop for (key . list) in alist + collect (cons (to-string key) + (sort list #'location-position< + :key #'xref-position))) + (if errors + `(("Unresolved" . ,errors)))))))) ;;; Local Variables: From heller at common-lisp.net Sun Nov 30 08:15:27 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 30 Nov 2003 03:15:27 -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-serv32674 Modified Files: swank-openmcl.lisp Log Message: Use the new format for source locations and implement find-function-locations (just calls the old code). Date: Sun Nov 30 03:15:27 2003 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.24 slime/swank-openmcl.lisp:1.25 --- slime/swank-openmcl.lisp:1.24 Sun Nov 23 09:16:42 2003 +++ slime/swank-openmcl.lisp Sun Nov 30 03:15: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.24 2003/11/23 14:16:42 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.25 2003/11/30 08:15:26 heller Exp $ ;;; ;;; @@ -157,11 +157,12 @@ :location (let ((position (condition-source-position condition))) (if *buffer-name* - (list :emacs-buffer *buffer-name* position t) - (list :file - (ccl::compiler-warning-file-name condition) - position - t)))))) + (make-location + (list :buffer *buffer-name*) + (list :position position t)) + (make-location + (list :file (ccl::compiler-warning-file-name condition)) + (list :position position t))))))) (defun temp-file-name () "Return a temporary file name to compile strings into." @@ -324,9 +325,12 @@ (let ((source-info (ccl::%source-files symbol))) ;; This is not entirely correct---%SOURCE-FILES can apparently ;; return a list under some circumstances... - (when (and source-info (atom source-info)) - (let ((filename (namestring (truename source-info)))) - (list :openmcl filename (symbol-name symbol)))))) + (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)))))) (defmethod frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the @@ -410,6 +414,9 @@ 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) + (list (function-source-location-for-emacs fname))) ;;; Macroexpansion From heller at common-lisp.net Sun Nov 30 08:15:42 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 30 Nov 2003 03:15:42 -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-serv32724 Modified Files: swank-sbcl.lisp Log Message: Use the new format for source locations and implement find-function-locations (just calls the old code). Date: Sun Nov 30 03:15:42 2003 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.31 slime/swank-sbcl.lisp:1.32 --- slime/swank-sbcl.lisp:1.31 Sat Nov 29 18:31:29 2003 +++ slime/swank-sbcl.lisp Sun Nov 30 03:15:42 2003 @@ -188,18 +188,19 @@ "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)) - (file (if (typep file-name 'pathname) - (namestring file-name) - file-name))) - (list :sbcl - :buffername (if (boundp '*buffername*) *buffername*) - :buffer-offset (if (boundp '*buffer-offset*) *buffer-offset*) - :position file-pos - :filename (etypecase file - (symbol file) - ((or string pathname) - (namestring (truename file)))) - :source-path (current-compiler-error-source-path context)))) + (source-path (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 + (etypecase file-name + (pathname + (make-location + (list :file (namestring (truename file-name))) + (list :source-path source-path file-pos)))))))) (defun brief-compiler-message-for-emacs (condition error-context) "Briefly describe a compiler error for Emacs. @@ -240,20 +241,12 @@ (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () - (let ((*package* *buffer-package*)) - (prog1 - (eval (from-string - (format nil "(funcall (compile nil '(lambda () ~A)))" - string))) - (loop for n in *compiler-notes* - for loc = (getf n :location) - for (_ . l) = loc - for sp = (getf l :source-path) - ;; account for the added lambda, replace leading - ;; position with 0 - do (setf (getf l :source-path) (cons 0 (cddr sp)) - (getf l :buffername) buffer - (getf l :buffer-offset) position)))))) + (let ((*package* *buffer-package*) + (*buffername* buffer) + (*buffer-offset* position)) + (eval (from-string + (format nil "(funcall (compile nil '(lambda () ~A)))" + string)))))) ;;;; xref stuff doesn't exist for sbcl yet @@ -284,15 +277,23 @@ "Try to find the canonical source location of FUNCTION." (let* ((def (sb-introspect:find-definition-source function)) (pathname (sb-introspect:definition-source-pathname def)) - (path (sb-introspect:definition-source-form-path def))) - (list :sbcl - :filename (and pathname (namestring (truename pathname))) - :position (sb-introspect:definition-source-character-offset def) - :path path - ;; source-paths depend on the file having been compiled with - ;; lotsa debugging. If not present, return the function name - ;; for emacs to attempt to find with a regex - :function-name (unless path fname)))) + (path (sb-introspect:definition-source-form-path def)) + (position (sb-introspect:definition-source-character-offset def))) + (unless pathname + (return-from function-source-location + (list :error (format nil "No filename for: ~S" fname)))) + (multiple-value-bind (truename condition) + (ignore-errors (truename pathname)) + (when condition + (return-from function-source-location + (list :error (format nil "~A" condition)))) + (make-location + (list :file (namestring truename)) + ;; source-paths depend on the file having been compiled with + ;; 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))))))) (defmethod function-source-location-for-emacs (fname-string) "Return the source-location of FNAME's definition." @@ -314,7 +315,11 @@ (if *debug-definition-finding* (finder fname) (handler-case (finder fname) - (error (e) (list :error (format nil "Error: ~A" e)))))))) + (error (e) + (list :error (format nil "Error: ~A" e)))))))) + +(defslimefun find-function-locations (name) + (list (function-source-location-for-emacs name))) (defmethod describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. @@ -390,7 +395,8 @@ (*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-length* nil #+nil sb-debug:*debug-print-length*) + (*print-readably* nil)) (handler-bind ((sb-di:debug-condition (lambda (condition) (signal (make-condition @@ -421,7 +427,7 @@ (defun format-frame-for-emacs (frame) (list (sb-di:frame-number frame) (with-output-to-string (*standard-output*) - (let ((*print-pretty* nil)) + (let ((*print-pretty* *sldb-pprint-frames*)) (sb-debug::print-frame-call frame :verbosity 1 :number t))))) (defun compute-backtrace (start end) @@ -478,25 +484,24 @@ (let* ((debug-source (sb-di:code-location-debug-source code-location)) (from (sb-di:debug-source-from debug-source)) (name (sb-di:debug-source-name debug-source))) - (list - :sbcl - :from from - :filename (if (eq from :file) - (namestring (truename name))) - :position (if (eq from :file) - (code-location-file-position code-location)) - :info (and (debug-source-info-from-emacs-buffer-p debug-source) - (sb-c::debug-source-info debug-source)) - :path (code-location-source-path code-location) - :source-form - (unless (or (eq from :file) - (debug-source-info-from-emacs-buffer-p debug-source)) - (with-output-to-string (*standard-output*) - (sb-debug::print-code-location-source-form code-location 100)))))) + (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)))) + (:lisp + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (sb-debug::print-code-location-source-form + code-location 100))) + (list :position 0)))))) (defun safe-source-location-for-emacs (code-location) (handler-case (source-location-for-emacs code-location) - (t (c) (list :error (princ-to-string c))))) + (t (c) (list :error (format nil "~A" c))))) (defmethod frame-source-location-for-emacs (index) (safe-source-location-for-emacs From heller at common-lisp.net Sun Nov 30 08:20:40 2003 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 30 Nov 2003 03:20:40 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2468 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Nov 30 03:20:40 2003 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.123 slime/ChangeLog:1.124 --- slime/ChangeLog:1.123 Sat Nov 29 18:31:43 2003 +++ slime/ChangeLog Sun Nov 30 03:20:40 2003 @@ -1,3 +1,48 @@ +2003-11-29 Helmut Eller + + * slime.el: Rewrite the xref code to work with other source + locations. + (slime-edit-fdefinition): Use the xref window to display generic + functions with methods. + (slime-goto-source-location): New representation for source + locations. Drop old code. + (slime-list-callers, slime-list-callees): Use the xref window. + Remove the slime-select-* stuff. + (slime-describe-function): New command. Bound to C-c C-f. + Primarily useful in Lispworks. + (slime-complete-symbol): Display the completion window if the + prefix is complete but not unique. + (slime-forward-positioned-source-path): Enter the sexp only if the + remaining sourcepath is not empty. + (slime-read-symbol-name): New optional argument QUERY forces + querying. + + * swank.lisp (group-xrefs): Handle unresolved source locations. + (describe-symbol): Print something sensible about unknown symbols. + + * swank-cmucl.lisp: Use the new format for source locations. + (find-function-locations): New function. Replaces + function-source-location-for-emacs. Returns a list of + source-locations. + (resolve-note-location): Renamed from resolve-location. + Simplified. + (brief-compiler-message-for-emacs): Print the source context + (that's the thing after ==>). + (who-xxxx): Take strings, not symbols, as arguments. + (function-callees, function-callers): Use the same format as the + who-xxx functions. Support for byte-compiled stuff. + (code-location-stream-position): Try to be clever is the source + path doesn't match the form. + (call-with-debugging-environment): Bind *print-readably* to nil. + + * swank-lispworks.lisp: Use the new format for source + locations. Implement the find-function-locations. + (list-callers, list-callers): New functions. + + * swank-sbcl.lisp, swank-openmcl.lisp: Use the new format for + source locations and implement find-function-locations (just calls + the old code). + 2003-11-29 Daniel Barlow * swank-sbcl.lisp (source-location-for-emacs):