[mcclim-devel] Would McCLIM benefit from this pretty printer patch for CMUCL/SBCL?
Dear McCLIM list, I have worked on a patch for the pretty printer of CMUCL and SBCL that helps support the new presentation-like features of SLIME in conjunction with the pretty printer. I'd like to ask if someone of you could comment on whether this patch would be useful for McCLIM as well. If so, this would be another reason for including it at as a core extension into SBCL and CMUCL. The patch implements a feature of the Allegro CL pretty printer, which is called SCHEDULE-ANNOTATION there. This function queues arbitrary functions ("annotations") in the pretty-printing stream in sequence with the characters that are printed to the stream, until the stream has decided on the concrete layout. When the characters are forwarded to the target stream, the annotations are invoked at the right position. In my changes to SLIME, I use the function as follows. I believe (without knowing much about CLIM) that it should be possible to use similar code to send CLIM presentation data (output records?), font changes, etc. cleanly through pretty-printing streams. ;; 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)) (record (make-presentation-record :id pid :printed-p nil))) (write-annotation stream #'presentation-start record) (multiple-value-prog1 (funcall continue) (write-annotation stream #'presentation-end record))) (funcall continue))) I am including the pretty-printer patch (for SBCL) at the end of this message. Cheers, -- Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe diff -u /home/mkoeppe/s/slime/sbcl/pprint.lisp.orig /home/mkoeppe/s/slime/sbcl/pprint.lisp --- /home/mkoeppe/s/slime/sbcl/pprint.lisp.orig 2005-07-19 22:56:54.000000000 +0200 +++ /home/mkoeppe/s/slime/sbcl/pprint.lisp 2005-07-24 19:27:29.000000000 +0200 @@ -89,7 +89,12 @@ (queue-tail nil :type list) (queue-head nil :type list) ;; Block-start queue entries in effect at the queue head. - (pending-blocks nil :type list)) + (pending-blocks nil :type list) + ;; Queue of annotations to the buffer. + ;; Annotations are first put into the queue of pending operations. + ;; Just before output they are put into the queue of annotations. + (annotations-tail nil :type list) + (annotations-head nil :type list)) (def!method print-object ((pstream pretty-stream) stream) ;; FIXME: CMU CL had #+NIL'ed out this code and done a hand-written ;; FORMAT hack instead. Make sure that this code actually works instead @@ -360,6 +365,11 @@ (:section-relative (values t t))) (enqueue stream tab :sectionp sectionp :relativep relativep :colnum colnum :colinc colinc))) + +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) + ;;;; tab support @@ -452,6 +462,101 @@ (unless (eq new-buffer buffer) (replace new-buffer buffer :end1 end :end2 end)))))) +;;;; Annotation support + +(defun enqueue-annotation (stream handler record) + #!+sb-doc + "Insert an annotation into the pretty-printing stream STREAM. +HANDLER is a function, and RECORD is an arbitrary datum. The +pretty-printing stream conceptionally queues annotations in sequence +with the characters that are printed to the stream, until the stream +has decided on the concrete layout. When the characters are forwarded +to the target stream, annotations are invoked at the right position. +An annotation is invoked by calling the function HANDLER with the +three arguments RECORD, TARGET-STREAM, and TRUNCATEP. The argument +TRUNCATEP is true if the text surrounding the annotation is suppressed +due to line abbreviation (see *PRINT-LINES*). +If STREAM is not a pretty-printing stream, simply call HANDLER +with the arguments RECORD, STREAM and nil." + (if (pretty-stream-p stream) + (enqueue stream annotation :handler handler + :record record) + (funcall handler record stream nil))) + +(defun re-enqueue-annotation (stream annotation) + #!+sb-doc + "Insert ANNOTATION into the queue of annotations in STREAM." + (let* ((annotation-cons (list annotation)) + (head (pretty-stream-annotations-head stream))) + (if head + (setf (cdr head) annotation-cons) + (setf (pretty-stream-annotations-tail stream) annotation-cons)) + (setf (pretty-stream-annotations-head stream) annotation-cons))) + +(defun re-enqueue-annotations (stream end) + #!+sb-doc + "Insert all annotations in STREAM from the queue of pending +operations into the queue of annotations. When END is non-nil, +stop before reaching the queued-op END." + (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) + while (and tail (not (eql tail end))) + when (annotation-p (car tail)) + do (re-enqueue-annotation stream (car tail)))) + +(defun dequeue-annotation (stream &key end-posn) + #!+sb-doc + "Dequeue the next annotation from the queue of annotations of STREAM +and return it. Return nil if there are no more annotations. When +:END-POSN is given and the next annotation has a posn greater than +this, also return nil." + (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) + (when next-annotation + (when (or (not end-posn) + (<= (annotation-posn next-annotation) end-posn)) + (pop (pretty-stream-annotations-tail stream)) + (unless (pretty-stream-annotations-tail stream) + (setf (pretty-stream-annotations-head stream) nil)) + next-annotation)))) + +(defun invoke-annotation (stream annotation truncatep) + (let ((target (pretty-stream-target stream))) + (funcall (annotation-handler annotation) + (annotation-record annotation) + target + truncatep))) + +(defun output-buffer-with-annotations (stream end) + #!+sb-doc + "Output the buffer of STREAM up to (excluding) the buffer index END. +When annotations are present, invoke them at the right positions." + (let ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (end-posn (index-posn end stream)) + (start 0)) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do + (let ((annotation-index (posn-index (annotation-posn annotation) + stream))) + (when (> annotation-index start) + (write-string buffer target :start start + :end annotation-index) + (setf start annotation-index)) + (invoke-annotation stream annotation nil))) + (when (> end start) + (write-string buffer target :start start :end end)))) + +(defun flush-annotations (stream end truncatep) + #+sb-doc + "Invoke all annotations in STREAM up to (including) the buffer index END." + (let ((end-posn (index-posn end stream))) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do (invoke-annotation stream annotation truncatep)))) + + ;;;; stuff to do the actual outputting (defun ensure-space-in-buffer (stream want) @@ -520,10 +625,11 @@ (ecase (fits-on-line-p stream (block-start-section-end next) force-newlines-p) ((t) - ;; Just nuke the whole logical block and make it look - ;; like one nice long literal. + ;; Just nuke the whole logical block and make it look like one + ;; nice long literal. (But don't nuke annotations.) (let ((end (block-start-block-end next))) (expand-tabs stream end) + (re-enqueue-annotations stream end) (setf tail (cdr (member end tail))))) ((nil) (really-start-logical-block @@ -536,7 +642,9 @@ (block-end (really-end-logical-block stream)) (tab - (expand-tabs stream next)))) + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) (setf (pretty-stream-queue-tail stream) tail)) output-anything)) @@ -582,13 +690,17 @@ (if last-non-blank (1+ last-non-blank) 0))))) - (write-string buffer target :end amount-to-print) + (output-buffer-with-annotations stream amount-to-print) + (flush-annotations stream amount-to-consume nil) (let ((line-number (pretty-stream-line-number stream))) (incf line-number) (when (and (not *print-readably*) (pretty-stream-print-lines stream) (>= line-number (pretty-stream-print-lines stream))) (write-string " .." target) + (flush-annotations stream + (pretty-stream-buffer-fill-pointer stream) + t) (let ((suffix-length (logical-block-suffix-length (car (pretty-stream-blocks stream))))) (unless (zerop suffix-length) @@ -640,8 +752,7 @@ (buffer (pretty-stream-buffer stream))) (when (zerop count) (error "Output-partial-line called when nothing can be output.")) - (write-string buffer (pretty-stream-target stream) - :start 0 :end count) + (output-buffer-with-annotations stream count) (incf (pretty-stream-buffer-start-column stream) count) (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) @@ -650,9 +761,10 @@ (defun force-pretty-output (stream) (maybe-output stream nil) (expand-tabs stream nil) - (write-string (pretty-stream-buffer stream) - (pretty-stream-target stream) - :end (pretty-stream-buffer-fill-pointer stream))) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream))) + ;;;; user interface to the pretty printer
Matthias Koeppe <mkoeppe@merkur.math.uni-magdeburg.de> writes:
I have worked on a patch for the pretty printer of CMUCL and SBCL that helps support the new presentation-like features of SLIME in conjunction with the pretty printer.
I probably can't comment on your patch. But you might be interested in some experimental work Gilbert Baumann did on the CMUCL pretty printer and McCLIM. Here are some screen shots: http://bauhh.dyndns.org:8000/mcclim/screenshots/pprint-1.png http://bauhh.dyndns.org:8000/mcclim/screenshots/pprint-2.png I think the code is here: http://bauhh.dyndns.org:8000/mcclim/pprint/ Paolo -- Lisp Propulsion Laboratory log - http://www.paoloamoroso.it/log
"Matthias" == Matthias Koeppe <mkoeppe@merkur.math.uni-magdeburg.de> writes:
Matthias> Dear McCLIM list, Matthias> I have worked on a patch for the pretty printer of CMUCL and SBCL that Matthias> helps support the new presentation-like features of SLIME in Matthias> conjunction with the pretty printer. I'm not familiar with slime's presentations, but I was going to look into incorporating your patch. However, in light of Paolo's comments, I'm holding off until this is resolved. Ray
Raymond Toy <raymond.toy@ericsson.com> writes:
"Matthias" == Matthias Koeppe <mkoeppe@merkur.math.uni-magdeburg.de> writes: Matthias> Dear McCLIM list, Matthias> I have worked on a patch for the pretty printer of CMUCL and SBCL that Matthias> helps support the new presentation-like features of SLIME in Matthias> conjunction with the pretty printer.
I'm not familiar with slime's presentations, but I was going to look into incorporating your patch.
However, in light of Paolo's comments, I'm holding off until this is resolved.
I have now taken a look at Gilbert Baumann's pretty printer patch (http://bauhh.dyndns.org:8000/mcclim/pprint/) that Paolo pointed out. As far as I can see, the changes there could be easily re-implemented in terms of the more general "annotations" feature implemented in my patch. The only thing that is not covered by my patch is the hooks into START-LOGICAL-BLOCK, END-LOGICAL-BLOCK, PPRINT-LOGICAL-BLOCK. These changes are independent of my patch. (I am including below a new version of the patch for CMUCL that includes docstrings.) Cheers, -- Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe diff -u /home/mkoeppe/s/slime/cmucl/pprint.lisp.orig /home/mkoeppe/s/slime/cmucl/pprint.lisp --- /home/mkoeppe/s/slime/cmucl/pprint.lisp.orig 2005-07-21 22:30:50.000000000 +0200 +++ /home/mkoeppe/s/slime/cmucl/pprint.lisp 2005-07-29 00:11:19.000000000 +0200 @@ -109,6 +109,10 @@ ;; ;; Block-start queue entries in effect at the queue head. (pending-blocks nil :type list) + ;; + ;; Queue of annotations to the buffer + (annotations-tail nil :type list) + (annotations-head nil :type list) ) (defun %print-pretty-stream (pstream stream depth) @@ -381,6 +385,10 @@ (enqueue stream tab :sectionp sectionp :relativep relativep :colnum colnum :colinc colinc))) +(defstruct (annotation (:include queued-op)) + (handler (constantly nil) :type function) + (record)) + ;;;; Tab support. @@ -472,6 +480,91 @@ (replace new-buffer buffer :end1 end :end2 end)))))) +;;;; Annotations support. + +(defun enqueue-annotation (stream handler record) + "Insert an annotation into the pretty-printing stream STREAM. +HANDLER is a function, and RECORD is an arbitrary datum. The +pretty-printing stream conceptionally queues annotations in sequence +with the characters that are printed to the stream, until the stream +has decided on the concrete layout. When the characters are forwarded +to the target stream, annotations are invoked at the right position. +An annotation is invoked by calling the function HANDLER with the +three arguments RECORD, TARGET-STREAM, and TRUNCATEP. The argument +TRUNCATEP is true if the text surrounding the annotation is suppressed +due to line abbreviation (see *PRINT-LINES*). +If STREAM is not a pretty-printing stream, simply call HANDLER +with the arguments RECORD, STREAM and nil." + (enqueue stream annotation :handler handler + :record record)) + +(defun re-enqueue-annotation (stream annotation) + "Insert ANNOTATION into the queue of annotations in STREAM." + (let* ((annotation-cons (list annotation)) + (head (pretty-stream-annotations-head stream))) + (if head + (setf (cdr head) annotation-cons) + (setf (pretty-stream-annotations-tail stream) annotation-cons)) + (setf (pretty-stream-annotations-head stream) annotation-cons))) + +(defun re-enqueue-annotations (stream end) + "Insert all annotations in STREAM from the queue of pending +operations into the queue of annotations. When END is non-nil, +stop before reaching the queued-op END." + (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail) + while (and tail (not (eql (car tail) end))) + when (annotation-p (car tail)) + do (re-enqueue-annotation stream (car tail)))) + +(defun dequeue-annotation (stream &key end-posn) + "Dequeue the next annotation from the queue of annotations of STREAM +and return it. Return nil if there are no more annotations. When +:END-POSN is given and the next annotation has a posn greater than +this, also return nil." + (let ((next-annotation (car (pretty-stream-annotations-tail stream)))) + (when next-annotation + (when (or (not end-posn) + (<= (annotation-posn next-annotation) end-posn)) + (pop (pretty-stream-annotations-tail stream)) + (unless (pretty-stream-annotations-tail stream) + (setf (pretty-stream-annotations-head stream) nil)) + next-annotation)))) + +(defun invoke-annotation (stream annotation truncatep) + (let ((target (pretty-stream-target stream))) + (funcall (annotation-handler annotation) + (annotation-record annotation) + target + truncatep))) + +(defun output-buffer-with-annotations (stream end) + "Output the buffer of STREAM up to (excluding) the buffer index END. +When annotations are present, invoke them at the right positions." + (let ((target (pretty-stream-target stream)) + (buffer (pretty-stream-buffer stream)) + (end-posn (index-posn end stream)) + (start 0)) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do + (let ((annotation-index (posn-index (annotation-posn annotation) + stream))) + (write-string buffer target :start start + :end annotation-index) + (invoke-annotation stream annotation nil) + (setf start annotation-index))) + (write-string buffer target :start start :end end))) + +(defun flush-annotations (stream end truncatep) + "Invoke all annotations in STREAM up to (including) the buffer index END." + (let ((end-posn (index-posn end stream))) + (loop + for annotation = (dequeue-annotation stream :end-posn end-posn) + while annotation + do (invoke-annotation stream annotation truncatep)))) + + ;;;; Stuff to do the actual outputting. (defun assure-space-in-buffer (stream want) @@ -541,9 +634,10 @@ force-newlines-p) ((t) ;; Just nuke the whole logical block and make it look like one - ;; nice long literal. + ;; nice long literal. (But don't nuke annotations.) (let ((end (block-start-block-end next))) (expand-tabs stream end) + (re-enqueue-annotations stream end) (setf tail (cdr (member end tail))))) ((nil) (really-start-logical-block @@ -556,7 +650,9 @@ (block-end (really-end-logical-block stream)) (tab - (expand-tabs stream next)))) + (expand-tabs stream next)) + (annotation + (re-enqueue-annotation stream next)))) (setf (pretty-stream-queue-tail stream) tail)) output-anything)) @@ -600,12 +696,16 @@ (if last-non-blank (1+ last-non-blank) 0))))) - (write-string buffer target :end amount-to-print) + (output-buffer-with-annotations stream amount-to-print) + (flush-annotations stream amount-to-consume nil) (let ((line-number (pretty-stream-line-number stream))) (incf line-number) (when (and (not *print-readably*) *print-lines* (>= line-number *print-lines*)) (write-string " .." target) + (flush-annotations stream + (pretty-stream-buffer-fill-pointer stream) + t) (let ((suffix-length (logical-block-suffix-length (car (pretty-stream-blocks stream))))) (unless (zerop suffix-length) @@ -657,8 +757,7 @@ (buffer (pretty-stream-buffer stream))) (when (zerop count) (error "Output-partial-line called when nothing can be output.")) - (write-string buffer (pretty-stream-target stream) - :start 0 :end count) + (output-buffer-with-annotations stream count) (incf (pretty-stream-buffer-start-column stream) count) (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) @@ -667,9 +766,9 @@ (defun force-pretty-output (stream) (maybe-output stream nil) (expand-tabs stream nil) - (write-string (pretty-stream-buffer stream) - (pretty-stream-target stream) - :end (pretty-stream-buffer-fill-pointer stream))) + (re-enqueue-annotations stream nil) + (output-buffer-with-annotations stream + (pretty-stream-buffer-fill-pointer stream))) ;;;; Utilities.
"Matthias" == Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> writes:
Matthias> I have now taken a look at Gilbert Baumann's pretty printer patch Matthias> (http://bauhh.dyndns.org:8000/mcclim/pprint/) that Paolo pointed out. Matthias> As far as I can see, the changes there could be easily re-implemented Matthias> in terms of the more general "annotations" feature implemented in my Matthias> patch. That's encouraging. 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? Matthias> (I am including below a new version of the patch for CMUCL that includes Matthias> docstrings.) Thanks for the new patch. Just a couple of questions. 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. :-) Ray
Raymond Toy <raymond.toy@ericsson.com> writes:
"Matthias" == Matthias Koeppe <mkoeppe@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*)
"Matthias" == Matthias Koeppe <mkoeppe+slime@mail.math.uni-magdeburg.de> writes:
Matthias> I would be willing to work on a system of printer hooks that is Matthias> suitable for the purposes of SLIME and of McCLIM. I see this as a It would be very nice if you could do this. Matthias> You can test with CVS SLIME plus my SLIME patch below. Matthias> In SLIME, it is possible to refer to old REPL results (even Matthias> #<unreadable> ones) simply by copying their textual representation Matthias> within Emacs. This does not require any printer patches. Matthias> Moreover, after the file present.lisp is loaded, it is also possible Matthias> to refer to (unreadable) objects that were only printed (as a side Matthias> effect of the computation). Try (DESCRIBE 'STANDARD-OBJECT) and then Matthias> copy one of the highlighted #<unreadable> objects as new REPL input. I tried out your patch and present.lisp (after removing the load of cmucl-pprint-patch) using a cmucl built with your pretty-stream annotations. Despite some bugs in slime (possibly because I'm using XEmacs and not Emacs), this looks really cool! The unreadable objects are clickable now, just like the regular output presentations. And since it's hooked into the pretty printer, I see that if I C-c C-k a file, the slime repl buffer has the pathname of the file highlighted and clickabe as well. This didn't happen before. This patch will be in the next snapshot of cmucl. Thanks for the patch! Ray
participants (4)
-
Matthias Koeppe -
Matthias Koeppe -
Paolo Amoroso -
Raymond Toy