- slime-devel - mailman3.common-lisp.net

[slime-devel] Reverting the runnnig image
by Peter Schuller 07 Aug '05

07 Aug '05

Hello, when developing using slime I often find myself hindered by a "dirty" image, and falling back to using a manual "clean" compile externally. A typical example is wanting to use B:X in A, but having forgot to export X in B. Compilation of A results in the compiler interning X in A. So now I have to manually unintern the symbol in order to get A to compile, using the symbol from B. Other situations similar in nature have arissen. The cause is obvious; but my question is whether anybody uses any particular 'tricks' or procedures to avoid issues like this? -- / Peter Schuller, InfiDyne Technologies HB PGP userID: 0xE9758B7D or 'Peter Schuller <peter.schuller(a)infidyne.com>' Key retrieval: Send an E-Mail to getpgpkey(a)scode.org E-Mail: peter.schuller(a)infidyne.com Web: http://www.scode.org

3 2

[slime-devel] Daily ChangeLog diff
by lgorrie＠common-lisp.net 07 Aug '05

07 Aug '05

Index: slime/ChangeLog diff -u slime/ChangeLog:1.733 slime/ChangeLog:1.734 --- slime/ChangeLog:1.733 Sat Aug 6 16:51:11 2005 +++ slime/ChangeLog Sun Aug 7 19:06:41 2005 @@ -1,3 +1,16 @@ +2005-08-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Fix for the presentations menu. Reported by Aleksandar Bakic. + + * present.lisp (lookup-presented-object): Handle ids that are + conses. + (execute-menu-choice-for-presentation-id): Use equal for comparing + ids, to handle the cons case. + (menu-choices-for-presentation): Quote the presentation id, as it + can be a cons. + * slime.el (slime-presentation-menu, slime-presentation-menu) + (slime-inspect-presented-object): Quote the presentation id. + 2005-08-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> * swank.lisp (form-completion): New generic function, factored out

1 0

[slime-devel] Daily ChangeLog diff
by lgorrie＠common-lisp.net 06 Aug '05

06 Aug '05

Index: slime/ChangeLog diff -u slime/ChangeLog:1.732 slime/ChangeLog:1.733 --- slime/ChangeLog:1.732 Thu Aug 4 22:27:01 2005 +++ slime/ChangeLog Sat Aug 6 16:51:11 2005 @@ -1,3 +1,14 @@ +2005-08-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * swank.lisp (form-completion): New generic function, factored out + from complete-form. + (complete-form): Factor out form-completion. + (form-completion): Specialize on defmethod forms to insert arglist + of generic function. + + * doc/slime.texi (Programming Helpers): Document C-c C-s, + slime-complete-form. + 2005-08-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> Improvements to the presentations feature. Parts of presentations

1 0

[slime-devel] loading foreign libraries at startup under CMUCL
by rif 05 Aug '05

05 Aug '05

Hi. I'm using CVS slime from yesterday, and the CMUCL 19b release on x86. I have a collection of libraries I load at startup. One of these involves loading a C .o file (to get some C functions). If my .cmucl-init file loads everything explicitly, it works fine. I've never had any luck making a core file that includes foreign libraries (is this even possible?), so I made a core that loads all the asdf systems except the one that contains the foreign libraries (and also commented out all the earlier parts of the .cmucl-init file). If I do this, everything's fine if I start cmucl from the command-line, but if I start it in slime, it appears to hang loading the foreign library: it prints ";;; Running /usr/bin/ld..." and then hangs indefinitely. This seems to be happening even with the communication style set to :fd-handler (my naive first line of defense against SLIME issues). Any ideas about this? rif

2 1

[slime-devel] Daily ChangeLog diff
by lgorrie＠common-lisp.net 04 Aug '05

04 Aug '05

Index: slime/ChangeLog diff -u slime/ChangeLog:1.729 slime/ChangeLog:1.732 --- slime/ChangeLog:1.729 Fri Jul 29 14:34:56 2005 +++ slime/ChangeLog Thu Aug 4 22:27:01 2005 @@ -1,3 +1,96 @@ +2005-08-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Improvements to the presentations feature. Parts of presentations + can be copied reliably using all available Emacs facilities (not + just kill-ring-save), and they are no longer "semi-readonly" (in + the sense that keypresses are silently ignored). Whenever a user + attempts to edit a presentation, it now simply turns into plain + text (which is indicated by changing the face); this can be + undone. Presentations are now also supported if + *use-dedicated-output-stream* is nil. It is now possible to + access the individual values of multiple-value results. For some + systems (Allegro CL and upcoming CMUCL snapshots), presentations + can be reliably printed through pretty-printing streams. + + * present.lisp (slime-stream-p) [allegro]: Allow printing + presentations through pretty printing streams. + [cmu]: Allow printing presentations through pretty printing + streams, if CMUCL has annotations support and we are using the + bridge-less protocol. + [sbcl]: Allow printing presentations through indenting streams. + + * present.lisp (write-annotation): New function. + (presentation-record): New structure. + (presentation-start, presentation-end): New functions, supporting + both bridge protocol and bridge-less protocol. + (presenting-object-1): Use them here. + + * present.lisp [sbcl, allegro]: Add printer hooks for unreadable + objects and pathnames. + + * swank.lisp (*can-print-presentation*): New variable, moved here + from present.lisp. + * swank.lisp (interactive-eval, listener-eval, backtrace) + (swank-compiler, compile-file-for-emacs, load-file) + (init-inspector): Bind *can-print-presentation* to an appropriate + value. + * present.lisp: Remove code duplication with swank.lisp for the + functions above. + + * swank.lisp (encode-message): Don't use the pretty printer for + printing the message length. + + * slime.el (slime-dispatch-event): New events :presentation-start, + :presentation-end for bridge-less presentation markup. + * swank.lisp (dispatch-event, send-to-socket-io): Likewise. + + * swank.lisp (listener-eval): Store the whole values-list with + add-repl-result. + * slime.el (slime-repl-insert-prompt): Accept a list of strings, + representing individual values of a multiple-value result. Mark + them up as separate presentations. + (reify-old-output): Support reifying individual values of a + multiple-value result. + + * slime.el (slime-pre-command-hook): Don't call + slime-presentation-command-hook. + (slime-post-command-hook): Don't call + slime-presentation-post-command-hook. + (slime-presentation-command-hook): Removed. + (slime-presentation-post-command-hook): Removed. + + * slime.el (slime-presentation-whole-p): New. + (slime-same-presentation-p): New. + (slime-presentation-start, slime-presentation-end): New. + (slime-presentation-around-point): New. + (slime-after-change-function): New. + (slime-setup-command-hooks): Install slime-after-change-function + as an after-change-function. + + * slime.el (slime-repl-enable-presentations): Make + slime-repl-presentation nonsticky. + (slime-mark-presentation-start, slime-mark-presentation-end): New + functions. + (slime-mark-presentation-start-handler): Renamed from + slime-mark-presentation-start. + (slime-mark-presentation-end-handler): Renamed from + slime-mark-presentation-end. + (slime-presentation): New structure. + (slime-add-presentation-properties): New function. + (slime-insert-presentation): New function. + +2005-08-03 Zach Beane <xach(a)gwi.net> + + * swank-sbcl.lisp (swank-compile-string): Restore honoring of + *trap-load-time-warnings*. + +2005-08-03 Juho Snellman <jsnell(a)iki.fi> + + * swank-sbcl.lisp: Remove SBCL 0.9.1 support. + (swank-compile-string): Funcall the compiled function outside + with-compilation-hooks to prevent runtime warnings from + popping up a *compiler-notes* buffer. + 2005-07-29 Marco Baringer <mb(a)bese.it> * doc/slime.texi (Other configurables): Document

1 0

[slime-devel] slime + CLISP: jump to source code
by Onay 04 Aug '05

04 Aug '05

I wonder if there is a possibility to implement the mentioned feature since, at least IMO, it would be VERY MUCH appreciated. Often, files are loaded which do contain errors and the sldb just shows some info about the form. But then, it is quite a search to find the right place (file + line). * does CLISP provide source file+line debug info when compiling/loading? * if yes, is it possible to benefit from this whithin slime? * is anyone working on this? * if not, i would like to work on it with help from the slime community... (since i am just a newbie in lisp, but an experienced c/c++'er) thx

2 1

[slime-devel] Stupid question
by Marco Antoniotti 04 Aug '05

04 Aug '05

Hi I am very new to SLIME and I have noticed a slightly annoying problem. I am using an old CMUCL 18e on a Linux box. Once I start SLIME I keep getting "Polling ...." messages in the minibuffer. Is there something obvious I am missing? Cheers -- Marco Antoniotti http://bioinformatics.nyu.edu NYU Courant Bioinformatics Group tel. +1 - 212 - 998 3488 715 Broadway 10th FL fax. +1 - 212 - 998 3484 New York, NY, 10003, U.S.A.

3 3

[slime-devel] Updated patch to improve SLIME presentations
by Matthias Koeppe 04 Aug '05

04 Aug '05

Hi, I am sending a new version of my patch of June 23. The patch makes the presentations feature more robust and intuitive. With the patch, parts of presentations can be copied reliably using all available Emacs facilities (not just kill-ring-save), and they are no longer "semi-readonly" (in the sense that keypresses are silently ignored). Whenever a user attempts to edit a presentation, it now simply turns into plain text (which is indicated by changing the face); this can be undone. The patch removes the pre-command and post-command hooks and the classification of some modification commands into "action-type"s. In an after-change-function, I check whether only a part of a presentation has been pasted or whether a presentation has been edited. The patch also makes it possible to access the individual values of multiple-value results. The patch also adds a "bridge"-less protocol for SLIME presentations. Would someone like to handle this patch? Cheers, Matthias -- Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe 2005-07-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> * slime.el (slime-dispatch-event): New events :presentation-start, :presentation-end for bridge-less presentation markup. * swank.lisp (dispatch-event, send-to-socket-io): Likewise. * swank.lisp (listener-eval): Store the whole values-list with add-repl-result. * slime.el (slime-repl-insert-prompt): Accept a list of strings, representing individual values of a multiple-value result. Mark them up as separate presentations. (reify-old-output): Support reifying individual values of a multiple-value result. * slime.el (slime-pre-command-hook): Don't call slime-presentation-command-hook. (slime-post-command-hook): Don't call slime-presentation-post-command-hook. (slime-presentation-command-hook): Removed. (slime-presentation-post-command-hook): Removed. * slime.el (slime-presentation-whole-p): New. (slime-same-presentation-p): New. (slime-presentation-start, slime-presentation-end): New. (slime-presentation-around-point): New. (slime-after-change-function): New. (slime-setup-command-hooks): Install slime-after-change-function as an after-change-function. * slime.el (slime-repl-enable-presentations): Make slime-repl-presentation nonsticky. (slime-mark-presentation-start, slime-mark-presentation-end): New functions. (slime-mark-presentation-start-handler): Renamed from slime-mark-presentation-start. (slime-mark-presentation-end-handler): Renamed from slime-mark-presentation-end. (slime-presentation): New structure. (slime-add-presentation-properties): New function. (slime-insert-presentation): New function. Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v retrieving revision 1.515 diff -u -p -r1.515 slime.el --- slime.el 29 Jul 2005 12:37:24 -0000 1.515 +++ slime.el 29 Jul 2005 20:02:26 -0000 @@ -868,15 +868,13 @@ This list of flushed between commands.") "Execute all functions in `slime-pre-command-actions', then NIL it." (dolist (undo-fn slime-pre-command-actions) (ignore-errors (funcall undo-fn))) - (setq slime-pre-command-actions nil) - (slime-presentation-command-hook)) + (setq slime-pre-command-actions nil)) (defun slime-post-command-hook () (when (and slime-mode (slime-connected-p)) (slime-process-available-input)) (when (null pre-command-hook) ; sometimes this is lost - (add-hook 'pre-command-hook 'slime-pre-command-hook)) - (slime-presentation-post-command-hook) ) + (add-hook 'pre-command-hook 'slime-pre-command-hook))) (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-h'ook' to call `slime-pre-command-hook'." @@ -884,7 +882,8 @@ This list of flushed between commands.") (make-local-hook 'post-command-hook) ;; alanr: need local t (add-hook 'pre-command-hook 'slime-pre-command-hook nil t) - (add-hook 'post-command-hook 'slime-post-command-hook nil t)) + (add-hook 'post-command-hook 'slime-post-command-hook nil t) + (add-hook 'after-change-functions 'slime-after-change-function nil t)) ;(add-hook 'slime-mode-hook 'slime-setup-command-hooks) ;(setq post-command-hook nil) @@ -2285,6 +2284,10 @@ slime-repl-insert-prompt.") (destructure-case event ((:read-output output) (slime-output-string output)) + ((:presentation-start id) + (slime-mark-presentation-start id)) + ((:presentation-end id) + (slime-mark-presentation-end id)) ;; ((:emacs-rex form package thread continuation) (slime-set-state "|eval...") @@ -2566,40 +2569,85 @@ update window-point afterwards. If poin (when (boundp 'text-property-default-nonsticky) (pushnew '(slime-repl-old-output . t) text-property-default-nonsticky :test 'equal) + (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky + :test 'equal) (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky :test 'equal))) (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) -(defun slime-mark-presentation-start (process string) +(defun slime-mark-presentation-start (id) + (setf (gethash id slime-presentation-start-to-point) + (with-current-buffer (slime-output-buffer) + (marker-position (symbol-value 'slime-output-end))))) + +(defun slime-mark-presentation-start-handler (process string) (if (and string (string-match "<\\([0-9]+\\)" string)) - (progn - (let* ((match (substring string (match-beginning 1) (match-end 1))) - (id (car (read-from-string match)))) - (setf (gethash id slime-presentation-start-to-point) - (with-current-buffer (slime-output-buffer) - (marker-position (symbol-value 'slime-output-end)))))))) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-start id)))) + +(defun slime-mark-presentation-end (id) + (let ((start (gethash id slime-presentation-start-to-point))) + (setf (gethash id slime-presentation-start-to-point) nil) + (when start + (with-current-buffer (slime-output-buffer) + (slime-add-presentation-properties start (symbol-value 'slime-output-end) + id nil))))) -(defun slime-mark-presentation-end (process string) +(defun slime-mark-presentation-end-handler (process string) (if (and string (string-match ">\\([0-9]+\\)" string)) - (progn - (let* ((match (substring string (match-beginning 1) (match-end 1))) - (id (car (read-from-string match)))) - (let ((start (gethash id slime-presentation-start-to-point))) - (setf (gethash id slime-presentation-start-to-point) nil) - (when start - (with-current-buffer (slime-output-buffer) - (add-text-properties - start (symbol-value 'slime-output-end) - `(face slime-repl-result-face - slime-repl-old-output ,id - mouse-face slime-repl-output-mouseover-face - keymap ,slime-presentation-map - rear-nonsticky (slime-repl-old-output - slime-repl-result-face - slime-repl-output-mouseover-face)))))))))) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-end id)))) + +(defstruct (slime-presentation) + (text) + (id) + (start-p) + (stop-p)) + +(defun slime-add-presentation-properties (start end id result-p) + "Make the text between START and END a presentation with ID. +RESULT-P decides whether a face for a return value or output text is used." + (add-text-properties start end + `(face slime-repl-inputed-output-face + slime-repl-old-output ,id + mouse-face slime-repl-output-mouseover-face + keymap ,slime-presentation-map + rear-nonsticky (slime-repl-old-output + slime-repl-presentation + face mouse-face))) + (let ((text (buffer-substring-no-properties start end))) + (case (- end start) + (0) + (1 + (add-text-properties start end + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p t :stop-p t)))) + (t + (let ((inhibit-modification-hooks t)) + (add-text-properties start (1+ start) + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p t :stop-p nil))) + (when (> (- end start) 2) + (add-text-properties (1+ start) (1- end) + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p nil :stop-p nil)))) + (add-text-properties (1- end) end + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p nil :stop-p t)))))))) +(defun slime-insert-presentation (result output-id) + (let ((start (point))) + (insert result) + (slime-add-presentation-properties start (point) output-id t))) + (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" (slime-with-connection-buffer () @@ -2615,8 +2663,8 @@ update window-point afterwards. If poin (install-bridge) (setq bridge-destination-insert nil) (setq bridge-source-insert nil) - (setq bridge-handlers (list* '("<" . slime-mark-presentation-start) - '(">" . slime-mark-presentation-end) + (setq bridge-handlers (list* '("<" . slime-mark-presentation-start-handler) + '(">" . slime-mark-presentation-end-handler) bridge-handlers)) (set-process-coding-system stream slime-net-coding-system @@ -2752,61 +2800,105 @@ joined together.")) (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) -(defvar slime-not-copying-whole-presentation nil) - -;; alanr -(defun slime-presentation-command-hook () - (let* ((props-here (text-properties-at (point))) - (props-before (and (not (= (point) (point-min))) - (text-properties-at (1- (point))))) - (inside (and (getf props-here 'slime-repl-old-output))) - (at-beginning (and inside - (not (getf props-before 'slime-repl-old-output)))) - (at-end (and (or (= (point) (point-max)) - (not (getf props-here 'slime-repl-old-output))) - (getf props-before 'slime-repl-old-output))) - (start (cond (at-beginning (point)) - (inside (previous-single-property-change - (point) 'slime-repl-old-output)) - (at-end (previous-single-property-change - (1- (point)) 'slime-repl-old-output)))) - (end (cond (at-beginning (or (next-single-property-change - (point) 'slime-repl-old-output) - (point-max))) - (inside (or (next-single-property-change (point) 'slime-repl-old-output) - (point-max))) - (at-end (point))))) - ; (setq message (format "%s %s %s %s %s" at-beginning inside at-end start end)) - (when (and (or inside at-end) start end (> end start)) - (let ((kind (get this-command 'action-type))) - ; (message (format "%s %s %s %s" at-beginning inside at-end kind)) - (cond ((and (eq kind 'inserts) inside (not at-beginning)) - (setq this-command 'ignore)) - ((and (eq kind 'deletes-forward) inside (not at-end)) - (kill-region start end) - (setq this-command 'ignore)) - ((and (eq kind 'deletes-backward) (or inside at-end) (not at-beginning)) - (kill-region start end) - (setq this-command 'ignore)) - ((eq kind 'copies) - (multiple-value-bind (start end) (slime-property-bounds 'slime-repl-old-input) - (setq slime-not-copying-whole-presentation - (not (or (and at-beginning (>= (mark) end)) - (and at-end (<= (mark) start))))))) - ;(message (format "%s %s" length (abs (- (point) (mark)))))))) - ))))) - -;; if we did not copy the whole presentation, then remove the text properties from the -;; top of the kill ring - -(defun slime-presentation-post-command-hook () - (when (eq (get this-command 'action-type) 'copies) - (when slime-not-copying-whole-presentation - (remove-text-properties 0 (length (car kill-ring)) - '(slime-repl-old-output t mouse-face t rear-nonsticky t) - (car kill-ring)))) - (setq slime-not-copying-whole-presentation nil) - ) +(defun slime-presentation-whole-p (start end) + (let ((presentation (get-text-property start 'slime-repl-presentation))) + (and presentation + (string= (buffer-substring-no-properties start end) + (slime-presentation-text presentation))))) + +(defun slime-same-presentation-p (a b) + (and (string= (slime-presentation-text a) (slime-presentation-text b)) + (equal (slime-presentation-id a) (slime-presentation-id b)))) + +(defun* slime-presentation-start () + "Find start of presentation at point. Return buffer index and + whether a start-tag was found. When there is no presentation at + point, return nil and nil." + (let* ((presentation (get-text-property (point) 'slime-repl-presentation)) + (this-presentation presentation)) + (unless presentation + (return-from slime-presentation-start + (values nil nil))) + (save-excursion + (while (not (slime-presentation-start-p this-presentation)) + (let ((change-point (previous-single-property-change (point) 'slime-repl-presentation))) + (unless change-point + (return-from slime-presentation-start + (values (point-min) nil))) + (setq this-presentation (get-text-property change-point 'slime-repl-presentation)) + (unless (and this-presentation + (slime-same-presentation-p presentation this-presentation)) + (return-from slime-presentation-start + (values (point) nil))) + (goto-char change-point))) + (values (point) t)))) + +(defun* slime-presentation-end () + "Find end of presentation at point. Return buffer index (after last + character of the presentation) and whether an end-tag was found." + (let* ((presentation (get-text-property (point) 'slime-repl-presentation)) + (this-presentation presentation)) + (unless presentation + (return-from slime-presentation-end + (values nil nil))) + (save-excursion + (while (and this-presentation + (slime-same-presentation-p presentation this-presentation) + (not (slime-presentation-stop-p this-presentation))) + (let ((change-point (next-single-property-change (point) 'slime-repl-presentation))) + (unless change-point + (return-from slime-presentation-end + (values (point-max) nil))) + (goto-char change-point) + (setq this-presentation (get-text-property (point) 'slime-repl-presentation)))) + (if (and this-presentation + (slime-same-presentation-p presentation this-presentation)) + (let ((after-end (next-single-property-change (point) 'slime-repl-presentation))) + (if (not after-end) + (values (point-max) t) + (values after-end t))) + (values (point) nil))))) + +(defun slime-presentation-around-point () + "Return start index, end index, and whether the presentation is complete." + (multiple-value-bind (start good-start) + (slime-presentation-start) + (multiple-value-bind (end good-end) + (slime-presentation-end) + (values start end + (and good-start good-end + (slime-presentation-whole-p start end)))))) + +(defun slime-after-change-function (start end old-len) + "Check all presentations within and adjacent to the change. When a + presentation has been altered, change it to plain text." + (unless undo-in-progress + (let ((real-start (max (point-min) (1- start))) + (real-end (min (point-max) (1+ end))) + (any-change nil)) + ;; positions around the change + (save-excursion + (goto-char real-start) + (while (< (point) real-end) + (let ((presentation (get-text-property (point) 'slime-repl-presentation))) + (when presentation + (multiple-value-bind (from to whole) + (slime-presentation-around-point) + ;;(message "presentation %s whole-p %s" (buffer-substring from to) whole) + (unless whole + (setq any-change t) + (remove-text-properties from to + '(slime-repl-old-output t + slime-repl-inputed-output-face t + face t mouse-face t rear-nonsticky t + slime-repl-presentation t)))))) + (let ((next-change + (next-single-property-change (point) 'slime-repl-presentation nil + real-end))) + (if next-change + (goto-char next-change) + (undo-boundary) + (return)))))))) (defun slime-copy-presentation-at-point (event) (interactive "e") @@ -2830,20 +2922,6 @@ joined together.")) (goto-char (point-max)) (do-insertion))))))) -(put 'self-insert-command 'action-type 'inserts) -(put 'self-insert-command-1 'action-type 'inserts) -(put 'yank 'action-type 'inserts) -(put 'kill-word 'action-type 'deletes-forward) -(put 'delete-char 'action-type 'deletes-forward) -(put 'kill-sexp 'action-type 'deletes-forward) -(put 'backward-kill-sexp 'action-type 'deletes-backward) -(put 'backward-delete-char 'action-type 'deletes-backward) -(put 'delete-backward-char 'action-type 'deletes-backward) -(put 'backward-kill-word 'action-type 'deletes-backward) -(put 'backward-delete-char-untabify 'action-type 'deletes-backward) -(put 'slime-repl-newline-and-indent 'action-type 'inserts) -(put 'kill-ring-save 'action-type 'copies) - (defvar slime-presentation-map (make-sparse-keymap)) (define-key slime-presentation-map [mouse-2] 'slime-copy-presentation-at-point) @@ -2887,36 +2965,42 @@ joined together.")) (defun slime-repl-insert-prompt (result &optional time) "Goto to point max, insert RESULT and the prompt. Set slime-output-end to start of the inserted text slime-input-start to -end end." +end end. If RESULT is not a string, it must be a list of +result strings, each of which is marked-up as a presentation." (slime-flush-output) (goto-char (point-max)) (let ((start (point))) (unless (bolp) (insert "\n")) - (unless (string= "" result) - (slime-propertize-region `(face slime-repl-result-face) - (slime-propertize-region - (and slime-repl-enable-presentations - `(face slime-repl-result-face - slime-repl-old-output ,(- slime-current-output-id) - mouse-face slime-repl-output-mouseover-face - keymap ,slime-presentation-map)) - (insert result))) - (unless (bolp) (insert "\n")) - (let ((inhibit-read-only t)) - (put-text-property (- (point) 2) (point) - 'rear-nonsticky - '(slime-repl-old-output face read-only)))) + (flet ((insert-result (result id) + (if (and slime-repl-enable-presentations id) + (slime-insert-presentation result id) + (slime-propertize-region `(face slime-repl-result-face) + (insert result))) + (unless (bolp) (insert "\n")) + (let ((inhibit-read-only t)) + (put-text-property (- (point) 2) (point) + 'rear-nonsticky + '(slime-repl-old-output slime-repl-presentation face read-only))))) + (etypecase result + (list + (loop + for res in result + for index from 0 + do (insert-result res (cons (- slime-current-output-id) index)))) + (string + (unless (string= result "") + (insert-result result nil))))) (let ((prompt-start (point)) (prompt (format "%s> " (slime-lisp-package-prompt-string)))) (slime-propertize-region '(face slime-repl-prompt-face - read-only t - intangible t - slime-repl-prompt t - ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) - ;; xemacs stuff - start-open t end-open t) + read-only t + intangible t + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) (insert prompt)) ;; FIXME: we could also set beginning-of-defun-function (setq defun-prompt-regexp (concat "^" prompt)) @@ -2969,7 +3053,11 @@ buffer. Presentations of old results are (concat (substring str-no-props 0 pos) ;; Eval in the reader so that we play nice with quote. ;; -luke (19/May/2005) - "#." (slime-prin1-to-string `(swank:get-repl-result ,id)) + "#." (slime-prin1-to-string + (if (consp id) + `(cl:nth ,(cdr id) + (swank:get-repl-result ,(car id))) + `(swank:get-repl-result ,id))) (reify-old-output (substring str-props end-pos) (substring str-no-props end-pos))))))) @@ -3023,8 +3111,11 @@ buffer. Presentations of old results are (set-marker slime-output-end position))) (defun slime-mark-output-end () + ;; Don't put slime-repl-output-face again; it would remove the + ;; special presentation face, for instance in the SBCL inspector. (add-text-properties slime-output-start slime-output-end - '(face slime-repl-output-face rear-nonsticky (face)))) + '(;;face slime-repl-output-face + rear-nonsticky (face)))) (defun slime-repl-bol () "Go to the beginning of line or the prompt." Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v retrieving revision 1.313 diff -u -p -u -r1.313 swank.lisp --- swank.lisp 29 Jul 2005 12:38:21 -0000 1.313 +++ swank.lisp 29 Jul 2005 20:28:45 -0000 @@ -599,7 +599,8 @@ of the toplevel restart." (encode-message `(:eval ,(thread-id thread) ,@args) socket-io)) ((:emacs-return thread-id tag value) (send (find-thread thread-id) `(take-input ,tag ,value))) - (((:read-output :new-package :new-features :ed :%apply :indentation-update + (((:read-output :presentation-start :presentation-end + :new-package :new-features :ed :%apply :indentation-update :eval-no-wait) &rest _) (declare (ignore _)) @@ -719,6 +720,7 @@ of the toplevel restart." (declare (ignore thread)) (send `(:return ,@args))) (((:read-output :new-package :new-features :debug-condition + :presentation-start :presentation-end :indentation-update :ed :%apply :eval-no-wait) &rest _) (declare (ignore _)) @@ -1839,23 +1842,23 @@ Return its name and the string to use in (defparameter *repl-results* '() "Association list of old repl results.") (defslimefun listener-eval (string) (clear-user-input) (with-buffer-syntax () (let ((*slime-repl-suppress-output* :unset) (*slime-repl-advance-history* :unset)) (unless (or (and (eq values nil) (eq last-form nil)) (eq *slime-repl-advance-history* nil)) (setq *** ** ** * * (car values) /// // // / / values) (when *record-repl-results* - (add-repl-result *current-id* *))) + (add-repl-result *current-id* values))) (setq +++ ++ ++ + + last-form) (if (eq *slime-repl-suppress-output* t) "" (cond ((null values) "; No value") (t - (format nil "~{~S~^~%~}" values)))))))) + (mapcar #'prin1-to-string values)))))))) (defun add-repl-result (id val) (push (cons id val) *repl-results*)

1 1

[slime-devel] Re: [Sbcl-devel] Would McCLIM benefit from this pretty printer patch for CMUCL/SBCL?
by Matthias Koeppe 03 Aug '05

03 Aug '05

Raymond Toy <raymond.toy(a)ericsson.com> writes: >>>>>> "Matthias" == Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> writes: > Matthias> The only thing that is not covered by my patch is the hooks into > Matthias> START-LOGICAL-BLOCK, END-LOGICAL-BLOCK, PPRINT-LOGICAL-BLOCK. These > Matthias> changes are independent of my patch. > > Do you think the missing parts could be added? I think we would need a general system of hooks that hook into both the pretty printer and various functions of the ugly printer. As an example, SLIME currently only hooks into the printer functions LISP::%PRINT-PATHNAME and LISP::%PRINT-UNREADABLE-OBJECT: (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) (presenting-object object stream (fwrappers:call-next-function))) (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) (presenting-object pathname stream (fwrappers:call-next-function))) (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper) I would be willing to work on a system of printer hooks that is suitable for the purposes of SLIME and of McCLIM. I see this as a second step, though; for the current purposes of SLIME, it would be sufficient to get the annotations support merged; as the above hooks into the printer are rather unobtrusive, they would be easily maintainable in SLIME itself. It is also not clear at the moment whether a more complete presentation support (covering nested lists) is desired for SLIME. > You mentioned that you use this with slime presentations. What does > these annotations do for slime presentations? Could you describe > what happens? I'm trying to understand exactly what new > capabilities you would get with these annotations. And a way to > test the result after I've patched cmucl with these changes. :-) You can test with CVS SLIME plus my SLIME patch below. In SLIME, it is possible to refer to old REPL results (even #<unreadable> ones) simply by copying their textual representation within Emacs. This does not require any printer patches. Moreover, after the file present.lisp is loaded, it is also possible to refer to (unreadable) objects that were only printed (as a side effect of the computation). Try (DESCRIBE 'STANDARD-OBJECT) and then copy one of the highlighted #<unreadable> objects as new REPL input. The mechanism is that %PRINT-UNREADABLE-OBJECT (via PRESENTING-OBJECT) stores the object in a hash table and sends a unique id to Emacs. So if we want to print (A B C #<unreadable> D E F), Emacs sees the SLIME protocol messages (:READ-OUTPUT "(A B C ") (:START-PRESENTATION 17) (:READ-OUTPUT "#<unreadable>") (:END-PRESENTATION 17) (:READ-OUTPUT " D E F") No annotations needed so far. The stream connected to *STANDARD-OUTPUT* is a Gray stream that takes care of directing ordinary character output to Emacs. When a presentation needs to be started or ended, I flush the stream, which yields a :READ-OUTPUT message; then I send the :START-PRESENTATION or :END-PRESENTATION message. The problem arises when we are not printing directly to a SLIME stream but through a pretty printing stream. Such a stream buffers the ordinary character output until layout decisions can be taken; only then it forwards them to the target stream (in our case, a SLIME stream). In order to send the :START-PRESENTATION and :END-PRESENTATION messages at the right positions, they must be buffered as well in the pretty printing stream. This is what annotations implement. Cheers, Matthias -- Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v retrieving revision 1.515 diff -u -p -r1.515 slime.el --- slime.el 29 Jul 2005 12:37:24 -0000 1.515 +++ slime.el 3 Aug 2005 20:24:02 -0000 @@ -868,15 +868,13 @@ This list of flushed between commands.") "Execute all functions in `slime-pre-command-actions', then NIL it." (dolist (undo-fn slime-pre-command-actions) (ignore-errors (funcall undo-fn))) - (setq slime-pre-command-actions nil) - (slime-presentation-command-hook)) + (setq slime-pre-command-actions nil)) (defun slime-post-command-hook () (when (and slime-mode (slime-connected-p)) (slime-process-available-input)) (when (null pre-command-hook) ; sometimes this is lost - (add-hook 'pre-command-hook 'slime-pre-command-hook)) - (slime-presentation-post-command-hook) ) + (add-hook 'pre-command-hook 'slime-pre-command-hook))) (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-h'ook' to call `slime-pre-command-hook'." @@ -884,7 +882,8 @@ This list of flushed between commands.") (make-local-hook 'post-command-hook) ;; alanr: need local t (add-hook 'pre-command-hook 'slime-pre-command-hook nil t) - (add-hook 'post-command-hook 'slime-post-command-hook nil t)) + (add-hook 'post-command-hook 'slime-post-command-hook nil t) + (add-hook 'after-change-functions 'slime-after-change-function nil t)) ;(add-hook 'slime-mode-hook 'slime-setup-command-hooks) ;(setq post-command-hook nil) @@ -2285,6 +2284,10 @@ slime-repl-insert-prompt.") (destructure-case event ((:read-output output) (slime-output-string output)) + ((:presentation-start id) + (slime-mark-presentation-start id)) + ((:presentation-end id) + (slime-mark-presentation-end id)) ;; ((:emacs-rex form package thread continuation) (slime-set-state "|eval...") @@ -2566,40 +2569,85 @@ update window-point afterwards. If poin (when (boundp 'text-property-default-nonsticky) (pushnew '(slime-repl-old-output . t) text-property-default-nonsticky :test 'equal) + (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky + :test 'equal) (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky :test 'equal))) (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) -(defun slime-mark-presentation-start (process string) +(defun slime-mark-presentation-start (id) + (setf (gethash id slime-presentation-start-to-point) + (with-current-buffer (slime-output-buffer) + (marker-position (symbol-value 'slime-output-end))))) + +(defun slime-mark-presentation-start-handler (process string) (if (and string (string-match "<\\([0-9]+\\)" string)) - (progn - (let* ((match (substring string (match-beginning 1) (match-end 1))) - (id (car (read-from-string match)))) - (setf (gethash id slime-presentation-start-to-point) - (with-current-buffer (slime-output-buffer) - (marker-position (symbol-value 'slime-output-end)))))))) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-start id)))) + +(defun slime-mark-presentation-end (id) + (let ((start (gethash id slime-presentation-start-to-point))) + (setf (gethash id slime-presentation-start-to-point) nil) + (when start + (with-current-buffer (slime-output-buffer) + (slime-add-presentation-properties start (symbol-value 'slime-output-end) + id nil))))) -(defun slime-mark-presentation-end (process string) +(defun slime-mark-presentation-end-handler (process string) (if (and string (string-match ">\\([0-9]+\\)" string)) - (progn - (let* ((match (substring string (match-beginning 1) (match-end 1))) - (id (car (read-from-string match)))) - (let ((start (gethash id slime-presentation-start-to-point))) - (setf (gethash id slime-presentation-start-to-point) nil) - (when start - (with-current-buffer (slime-output-buffer) - (add-text-properties - start (symbol-value 'slime-output-end) - `(face slime-repl-result-face - slime-repl-old-output ,id - mouse-face slime-repl-output-mouseover-face - keymap ,slime-presentation-map - rear-nonsticky (slime-repl-old-output - slime-repl-result-face - slime-repl-output-mouseover-face)))))))))) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-end id)))) + +(defstruct (slime-presentation) + (text) + (id) + (start-p) + (stop-p)) + +(defun slime-add-presentation-properties (start end id result-p) + "Make the text between START and END a presentation with ID. +RESULT-P decides whether a face for a return value or output text is used." + (add-text-properties start end + `(face slime-repl-inputed-output-face + slime-repl-old-output ,id + mouse-face slime-repl-output-mouseover-face + keymap ,slime-presentation-map + rear-nonsticky (slime-repl-old-output + slime-repl-presentation + face mouse-face))) + (let ((text (buffer-substring-no-properties start end))) + (case (- end start) + (0) + (1 + (add-text-properties start end + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p t :stop-p t)))) + (t + (let ((inhibit-modification-hooks t)) + (add-text-properties start (1+ start) + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p t :stop-p nil))) + (when (> (- end start) 2) + (add-text-properties (1+ start) (1- end) + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p nil :stop-p nil)))) + (add-text-properties (1- end) end + `(slime-repl-presentation + ,(make-slime-presentation :text text :id id + :start-p nil :stop-p t)))))))) +(defun slime-insert-presentation (result output-id) + (let ((start (point))) + (insert result) + (slime-add-presentation-properties start (point) output-id t))) + (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" (slime-with-connection-buffer () @@ -2615,8 +2663,8 @@ update window-point afterwards. If poin (install-bridge) (setq bridge-destination-insert nil) (setq bridge-source-insert nil) - (setq bridge-handlers (list* '("<" . slime-mark-presentation-start) - '(">" . slime-mark-presentation-end) + (setq bridge-handlers (list* '("<" . slime-mark-presentation-start-handler) + '(">" . slime-mark-presentation-end-handler) bridge-handlers)) (set-process-coding-system stream slime-net-coding-system @@ -2752,61 +2800,105 @@ joined together.")) (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) -(defvar slime-not-copying-whole-presentation nil) - -;; alanr -(defun slime-presentation-command-hook () - (let* ((props-here (text-properties-at (point))) - (props-before (and (not (= (point) (point-min))) - (text-properties-at (1- (point))))) - (inside (and (getf props-here 'slime-repl-old-output))) - (at-beginning (and inside - (not (getf props-before 'slime-repl-old-output)))) - (at-end (and (or (= (point) (point-max)) - (not (getf props-here 'slime-repl-old-output))) - (getf props-before 'slime-repl-old-output))) - (start (cond (at-beginning (point)) - (inside (previous-single-property-change - (point) 'slime-repl-old-output)) - (at-end (previous-single-property-change - (1- (point)) 'slime-repl-old-output)))) - (end (cond (at-beginning (or (next-single-property-change - (point) 'slime-repl-old-output) - (point-max))) - (inside (or (next-single-property-change (point) 'slime-repl-old-output) - (point-max))) - (at-end (point))))) - ; (setq message (format "%s %s %s %s %s" at-beginning inside at-end start end)) - (when (and (or inside at-end) start end (> end start)) - (let ((kind (get this-command 'action-type))) - ; (message (format "%s %s %s %s" at-beginning inside at-end kind)) - (cond ((and (eq kind 'inserts) inside (not at-beginning)) - (setq this-command 'ignore)) - ((and (eq kind 'deletes-forward) inside (not at-end)) - (kill-region start end) - (setq this-command 'ignore)) - ((and (eq kind 'deletes-backward) (or inside at-end) (not at-beginning)) - (kill-region start end) - (setq this-command 'ignore)) - ((eq kind 'copies) - (multiple-value-bind (start end) (slime-property-bounds 'slime-repl-old-input) - (setq slime-not-copying-whole-presentation - (not (or (and at-beginning (>= (mark) end)) - (and at-end (<= (mark) start))))))) - ;(message (format "%s %s" length (abs (- (point) (mark)))))))) - ))))) - -;; if we did not copy the whole presentation, then remove the text properties from the -;; top of the kill ring - -(defun slime-presentation-post-command-hook () - (when (eq (get this-command 'action-type) 'copies) - (when slime-not-copying-whole-presentation - (remove-text-properties 0 (length (car kill-ring)) - '(slime-repl-old-output t mouse-face t rear-nonsticky t) - (car kill-ring)))) - (setq slime-not-copying-whole-presentation nil) - ) +(defun slime-presentation-whole-p (start end) + (let ((presentation (get-text-property start 'slime-repl-presentation))) + (and presentation + (string= (buffer-substring-no-properties start end) + (slime-presentation-text presentation))))) + +(defun slime-same-presentation-p (a b) + (and (string= (slime-presentation-text a) (slime-presentation-text b)) + (equal (slime-presentation-id a) (slime-presentation-id b)))) + +(defun* slime-presentation-start () + "Find start of presentation at point. Return buffer index and + whether a start-tag was found. When there is no presentation at + point, return nil and nil." + (let* ((presentation (get-text-property (point) 'slime-repl-presentation)) + (this-presentation presentation)) + (unless presentation + (return-from slime-presentation-start + (values nil nil))) + (save-excursion + (while (not (slime-presentation-start-p this-presentation)) + (let ((change-point (previous-single-property-change (point) 'slime-repl-presentation))) + (unless change-point + (return-from slime-presentation-start + (values (point-min) nil))) + (setq this-presentation (get-text-property change-point 'slime-repl-presentation)) + (unless (and this-presentation + (slime-same-presentation-p presentation this-presentation)) + (return-from slime-presentation-start + (values (point) nil))) + (goto-char change-point))) + (values (point) t)))) + +(defun* slime-presentation-end () + "Find end of presentation at point. Return buffer index (after last + character of the presentation) and whether an end-tag was found." + (let* ((presentation (get-text-property (point) 'slime-repl-presentation)) + (this-presentation presentation)) + (unless presentation + (return-from slime-presentation-end + (values nil nil))) + (save-excursion + (while (and this-presentation + (slime-same-presentation-p presentation this-presentation) + (not (slime-presentation-stop-p this-presentation))) + (let ((change-point (next-single-property-change (point) 'slime-repl-presentation))) + (unless change-point + (return-from slime-presentation-end + (values (point-max) nil))) + (goto-char change-point) + (setq this-presentation (get-text-property (point) 'slime-repl-presentation)))) + (if (and this-presentation + (slime-same-presentation-p presentation this-presentation)) + (let ((after-end (next-single-property-change (point) 'slime-repl-presentation))) + (if (not after-end) + (values (point-max) t) + (values after-end t))) + (values (point) nil))))) + +(defun slime-presentation-around-point () + "Return start index, end index, and whether the presentation is complete." + (multiple-value-bind (start good-start) + (slime-presentation-start) + (multiple-value-bind (end good-end) + (slime-presentation-end) + (values start end + (and good-start good-end + (slime-presentation-whole-p start end)))))) + +(defun slime-after-change-function (start end old-len) + "Check all presentations within and adjacent to the change. When a + presentation has been altered, change it to plain text." + (unless undo-in-progress + (let ((real-start (max (point-min) (1- start))) + (real-end (min (point-max) (1+ end))) + (any-change nil)) + ;; positions around the change + (save-excursion + (goto-char real-start) + (while (< (point) real-end) + (let ((presentation (get-text-property (point) 'slime-repl-presentation))) + (when presentation + (multiple-value-bind (from to whole) + (slime-presentation-around-point) + ;;(message "presentation %s whole-p %s" (buffer-substring from to) whole) + (unless whole + (setq any-change t) + (remove-text-properties from to + '(slime-repl-old-output t + slime-repl-inputed-output-face t + face t mouse-face t rear-nonsticky t + slime-repl-presentation t)))))) + (let ((next-change + (next-single-property-change (point) 'slime-repl-presentation nil + real-end))) + (if next-change + (goto-char next-change) + (undo-boundary) + (return)))))))) (defun slime-copy-presentation-at-point (event) (interactive "e") @@ -2830,20 +2922,6 @@ joined together.")) (goto-char (point-max)) (do-insertion))))))) -(put 'self-insert-command 'action-type 'inserts) -(put 'self-insert-command-1 'action-type 'inserts) -(put 'yank 'action-type 'inserts) -(put 'kill-word 'action-type 'deletes-forward) -(put 'delete-char 'action-type 'deletes-forward) -(put 'kill-sexp 'action-type 'deletes-forward) -(put 'backward-kill-sexp 'action-type 'deletes-backward) -(put 'backward-delete-char 'action-type 'deletes-backward) -(put 'delete-backward-char 'action-type 'deletes-backward) -(put 'backward-kill-word 'action-type 'deletes-backward) -(put 'backward-delete-char-untabify 'action-type 'deletes-backward) -(put 'slime-repl-newline-and-indent 'action-type 'inserts) -(put 'kill-ring-save 'action-type 'copies) - (defvar slime-presentation-map (make-sparse-keymap)) (define-key slime-presentation-map [mouse-2] 'slime-copy-presentation-at-point) @@ -2887,36 +2965,42 @@ joined together.")) (defun slime-repl-insert-prompt (result &optional time) "Goto to point max, insert RESULT and the prompt. Set slime-output-end to start of the inserted text slime-input-start to -end end." +end end. If RESULT is not a string, it must be a list of +result strings, each of which is marked-up as a presentation." (slime-flush-output) (goto-char (point-max)) (let ((start (point))) (unless (bolp) (insert "\n")) - (unless (string= "" result) - (slime-propertize-region `(face slime-repl-result-face) - (slime-propertize-region - (and slime-repl-enable-presentations - `(face slime-repl-result-face - slime-repl-old-output ,(- slime-current-output-id) - mouse-face slime-repl-output-mouseover-face - keymap ,slime-presentation-map)) - (insert result))) - (unless (bolp) (insert "\n")) - (let ((inhibit-read-only t)) - (put-text-property (- (point) 2) (point) - 'rear-nonsticky - '(slime-repl-old-output face read-only)))) + (flet ((insert-result (result id) + (if (and slime-repl-enable-presentations id) + (slime-insert-presentation result id) + (slime-propertize-region `(face slime-repl-result-face) + (insert result))) + (unless (bolp) (insert "\n")) + (let ((inhibit-read-only t)) + (put-text-property (- (point) 2) (point) + 'rear-nonsticky + '(slime-repl-old-output slime-repl-presentation face read-only))))) + (etypecase result + (list + (loop + for res in result + for index from 0 + do (insert-result res (cons (- slime-current-output-id) index)))) + (string + (unless (string= result "") + (insert-result result nil))))) (let ((prompt-start (point)) (prompt (format "%s> " (slime-lisp-package-prompt-string)))) (slime-propertize-region '(face slime-repl-prompt-face - read-only t - intangible t - slime-repl-prompt t - ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) - ;; xemacs stuff - start-open t end-open t) + read-only t + intangible t + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) (insert prompt)) ;; FIXME: we could also set beginning-of-defun-function (setq defun-prompt-regexp (concat "^" prompt)) @@ -2969,7 +3053,11 @@ buffer. Presentations of old results are (concat (substring str-no-props 0 pos) ;; Eval in the reader so that we play nice with quote. ;; -luke (19/May/2005) - "#." (slime-prin1-to-string `(swank:get-repl-result ,id)) + "#." (slime-prin1-to-string + (if (consp id) + `(cl:nth ,(cdr id) + (swank:get-repl-result ,(car id))) + `(swank:get-repl-result ,id))) (reify-old-output (substring str-props end-pos) (substring str-no-props end-pos))))))) @@ -3023,8 +3111,11 @@ buffer. Presentations of old results are (set-marker slime-output-end position))) (defun slime-mark-output-end () + ;; Don't put slime-repl-output-face again; it would remove the + ;; special presentation face, for instance in the SBCL inspector. (add-text-properties slime-output-start slime-output-end - '(face slime-repl-output-face rear-nonsticky (face)))) + '(;;face slime-repl-output-face + rear-nonsticky (face)))) (defun slime-repl-bol () "Go to the beginning of line or the prompt." Index: present.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/present.lisp,v retrieving revision 1.4 diff -u -p -r1.4 present.lisp --- present.lisp 24 May 2005 02:42:01 -0000 1.4 +++ present.lisp 3 Aug 2005 20:24:03 -0000 @@ -15,9 +15,6 @@ ;; ultimately prints to a slime stream. ;; Control -(defvar *can-print-presentation* nil - "set this to t in contexts where it is ok to print presentations at all") - (defvar *enable-presenting-readable-objects* t "set this to enable automatically printing presentations for some subset of readable objects, such as pathnames." ) @@ -82,8 +79,18 @@ don't want to present anything" ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) #+cmu - (and (typep stream 'pretty-print::pretty-stream) - (slime-stream-p (pretty-print::pretty-stream-target stream))) + (or (and (typep stream 'lisp::indenting-stream) + (slime-stream-p (lisp::indenting-stream-stream stream))) + (and (typep stream 'pretty-print::pretty-stream) + (slime-stream-p (pretty-print::pretty-stream-target stream)))) + #+sbcl + (or (and (typep stream 'sb-impl::indenting-stream) + (slime-stream-p (sb-impl::indenting-stream-stream stream))) + (and (typep stream 'sb-pretty::pretty-stream) + (slime-stream-p (sb-pretty::pretty-stream-target stream)))) + #+allegro + (and (typep stream 'excl:xp-simple-stream) + (slime-stream-p (excl::stream-output-handle stream))) (loop for connection in *connections* thereis (or (eq stream (connection.dedicated-output connection)) (eq stream (connection.socket-io connection)) @@ -94,43 +101,91 @@ don't want to present anything" (declare (ignore stream)) *enable-presenting-readable-objects*) +;;; Get pretty printer patches for CMUCL +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (handler-bind ((simple-error + (lambda (c) + (let ((clobber-it (find-restart 'kernel::clobber-it))) + (when clobber-it (invoke-restart clobber-it)))))) + (ext:without-package-locks (load "cmucl-pprint-patch.lisp")))) +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (handler-bind ((simple-error + (lambda (c) + (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) + (when clobber-it (invoke-restart clobber-it)))))) + (sb-ext:without-package-locks + (swank-backend::with-debootstrapping (load "sbcl-pprint-patch.lisp"))))) + +;; If we are printing to an XP (pretty printing) stream, printing the +;; escape sequences directly would mess up the layout because column +;; counting is disturbed. Use "annotations" instead. +#+allegro +(defun write-annotation (stream function arg) + (if (typep stream 'excl:xp-simple-stream) + (excl::schedule-annotation stream function arg) + (funcall function arg stream nil))) +#+cmu +(defun write-annotation (stream function arg) + (if (typep stream 'pp:pretty-stream) + (pp::enqueue-annotation stream function arg) + (funcall function arg stream nil))) +#+sbcl +(defun write-annotation (stream function arg) + (if (typep stream 'sb-pretty::pretty-stream) + (sb-pretty::enqueue-annotation stream function arg) + (funcall function arg stream nil))) +#-(or allegro cmu sbcl) +(defun write-annotation (stream function arg) + (funcall function arg stream nil)) + +(defstruct presentation-record + (id) + (printed-p)) + +(defun presentation-start (record stream truncatep) + (unless truncatep + ;; Don't start new presentations when nothing is going to be + ;; printed due to *print-lines*. + (let ((pid (presentation-record-id record))) + (cond (*use-dedicated-output-stream* + (write-string "<" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (force-output stream) + (send-to-emacs `(:presentation-start ,pid))))) + (setf (presentation-record-printed-p record) t))) + +(defun presentation-end (record stream truncatep) + (declare (ignore truncatep)) + ;; Always end old presentations that were started. + (when (presentation-record-printed-p record) + (let ((pid (presentation-record-id record))) + (cond (*use-dedicated-output-stream* + (write-string ">" stream) + (prin1 pid stream) + (write-string "" stream)) + (t + (force-output stream) + (send-to-emacs `(:presentation-end ,pid))))))) + (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and <id. The first one says that I am starting to print an object with this id. The second says I am finished" (if (and *record-repl-results* *can-print-presentation* (slime-stream-p stream)) - (let ((pid (swank::save-presented-object object))) - (write-string "<" stream) - (prin1 pid stream) - (write-string "" stream) + (let* ((pid (swank::save-presented-object object)) + (record (make-presentation-record :id pid :printed-p nil))) + (write-annotation stream #'presentation-start record) (multiple-value-prog1 (funcall continue) - (write-string ">" stream) - (prin1 pid stream) - (write-string "" stream))) + (write-annotation stream #'presentation-end record))) (funcall continue))) ;; enable presentations inside listener eval, when compiling, when evaluating -(defslimefun listener-eval (string) - (clear-user-input) - (with-buffer-syntax () - (let ((*slime-repl-suppress-output* :unset) - (*slime-repl-advance-history* :unset)) - (multiple-value-bind (values last-form) - (let ((*can-print-presentation* t)) - (eval-region string t)) - (unless (or (and (eq values nil) (eq last-form nil)) - (eq *slime-repl-advance-history* nil)) - (setq *** ** ** * * (car values) - /// // // / / values) - (when *record-repl-results* - (add-repl-result *current-id* *))) - (setq +++ ++ ++ + + last-form) - (if (eq *slime-repl-suppress-output* t) - "" - (cond ((null values) "; No value") - (t - (format nil "~{~S~^~%~}" values)))))))) + (defslimefun compile-string-for-emacs (string buffer position directory) "Compile STRING (exerpted from BUFFER at POSITION). @@ -371,3 +426,29 @@ I is an integer describing and FRAME a s (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper) ) + +#+sbcl +(progn + (defvar *saved-%print-unreadable-object* + (fdefinition 'sb-impl::%print-unreadable-object)) + (sb-ext:without-package-locks + (setf (fdefinition 'sb-impl::%print-unreadable-object) + (lambda (object stream type identity body) + (presenting-object object stream + (funcall *saved-%print-unreadable-object* + object stream type identity body)))) + (defmethod print-object :around ((object pathname) stream) + (presenting-object object stream + (call-next-method))))) + +#+allegro +(progn + (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) + (swank::presenting-object object stream (excl:call-next-fwrapper))) + (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (excl:call-next-fwrapper))) + (excl:fwrap 'excl::print-unreadable-object-1 + 'print-unreadable-present 'presenting-unreadable-wrapper) + (excl:fwrap 'excl::pathname-printer + 'print-pathname-present 'presenting-pathname-wrapper)) Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v retrieving revision 1.313 diff -u -p -r1.313 swank.lisp --- swank.lisp 29 Jul 2005 12:38:21 -0000 1.313 +++ swank.lisp 3 Aug 2005 20:24:05 -0000 @@ -329,7 +329,7 @@ Useful for low level debugging." ;;;; TCP Server -(defvar *use-dedicated-output-stream* t +(defvar *use-dedicated-output-stream* nil "When T swank will attempt to create a second connection to Emacs which is used just to send output.") (defvar *dedicated-output-stream-port* 0 @@ -599,7 +599,8 @@ of the toplevel restart." (encode-message `(:eval ,(thread-id thread) ,@args) socket-io)) ((:emacs-return thread-id tag value) (send (find-thread thread-id) `(take-input ,tag ,value))) - (((:read-output :new-package :new-features :ed :%apply :indentation-update + (((:read-output :presentation-start :presentation-end + :new-package :new-features :ed :%apply :indentation-update :eval-no-wait) &rest _) (declare (ignore _)) @@ -719,6 +720,7 @@ of the toplevel restart." (declare (ignore thread)) (send `(:return ,@args))) (((:read-output :new-package :new-features :debug-condition + :presentation-start :presentation-end :indentation-update :ed :%apply :eval-no-wait) &rest _) (declare (ignore _)) @@ -915,7 +917,7 @@ NIL if streams are not globally redirect (out (connection.user-output connection)) (*standard-output* out) (*error-output* out) - (*trace-output* out) + ;;(*trace-output* out) (*debug-io* io) (*query-io* io) (*standard-input* in) @@ -973,7 +975,8 @@ If a protocol error occurs then a SLIME- (let* ((string (prin1-to-string-for-emacs message)) (length (1+ (length string)))) (log-event "WRITE: ~A~%" string) - (format stream "~6,'0x" length) + (let ((*print-pretty* nil)) + (format stream "~6,'0x" length)) (write-string string stream) (terpri stream) (force-output stream))) @@ -1839,24 +1842,29 @@ Return its name and the string to use in (defparameter *repl-results* '() "Association list of old repl results.") +(defvar *can-print-presentation* nil + "set this to t in contexts where it is ok to print presentations at all") + (defslimefun listener-eval (string) (clear-user-input) (with-buffer-syntax () (let ((*slime-repl-suppress-output* :unset) (*slime-repl-advance-history* :unset)) - (multiple-value-bind (values last-form) (eval-region string t) + (multiple-value-bind (values last-form) + (let ((*can-print-presentation* t)) + (eval-region string t)) (unless (or (and (eq values nil) (eq last-form nil)) (eq *slime-repl-advance-history* nil)) (setq *** ** ** * * (car values) /// // // / / values) (when *record-repl-results* - (add-repl-result *current-id* *))) + (add-repl-result *current-id* values))) (setq +++ ++ ++ + + last-form) (if (eq *slime-repl-suppress-output* t) "" (cond ((null values) "; No value") (t - (format nil "~{~S~^~%~}" values)))))))) + (mapcar #'prin1-to-string values)))))))) (defun add-repl-result (id val) (push (cons id val) *repl-results*)

1 0

[slime-devel] Suppressing function redefinition warnings with SBCL
by Zach Beane 03 Aug '05

03 Aug '05

Here's a patch that makes the SBCL backend honor *tramp-load-time-warnings* again. It makes the the "Style Warning: redefining FUNK in DEFUN" warning less annoying. Zach Index: ChangeLog =================================================================== RCS file: /project/slime/cvsroot/slime/ChangeLog,v retrieving revision 1.729 diff -u -r1.729 ChangeLog --- ChangeLog 29 Jul 2005 12:34:56 -0000 1.729 +++ ChangeLog 3 Aug 2005 19:03:50 -0000 @@ -1,3 +1,8 @@ +2005-08-03 Zach Beane <xach(a)gwi.net> + + * swank-sbcl.lisp (swank-compile-string): Restore honoring of + *trap-load-time-warnings*. + 2005-07-29 Marco Baringer <mb(a)bese.it> * doc/slime.texi (Other configurables): Document Index: swank-sbcl.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v retrieving revision 1.138 diff -u -r1.138 swank-sbcl.lisp --- swank-sbcl.lisp 26 Jul 2005 14:59:45 -0000 1.138 +++ swank-sbcl.lisp 3 Aug 2005 19:03:50 -0000 @@ -458,20 +458,21 @@ #+swank-backend::source-plist (defimplementation swank-compile-string (string &key buffer position directory) (declare (ignore directory)) - (let ((*buffer-name* buffer) - (*buffer-offset* position) - (*buffer-substring* string)) - (with-compilation-hooks () - (with-compilation-unit (:source-plist - (list :emacs-buffer buffer - :emacs-string string - :emacs-position position)) - #+nil - (with-input-from-string (stream string) - (load stream)) - (funcall (compile nil - `(lambda () - ,(read-from-string string)))))))) + (flet ((compileit (cont) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string)) + (with-compilation-hooks () + (with-compilation-unit (:source-plist + (list :emacs-buffer buffer + :emacs-string string + :emacs-position position)) + (funcall cont (compile nil + `(lambda () + ,(read-from-string string))))))))) + (if *trap-load-time-warnings* + (compileit #'funcall) + (funcall (compileit #'identity))))) ;;;; Definitions

1 0