[mcclim-devel] Re: [Sbcl-devel] Would McCLIM benefit from this pretty printer patch for CMUCL/SBCL?
Matthias Koeppe
mkoeppe+slime at mail.math.uni-magdeburg.de
Wed Aug 3 21:07:19 UTC 2005
Raymond Toy <raymond.toy at ericsson.com> writes:
>>>>>> "Matthias" == Matthias Koeppe <mkoeppe at 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) , at 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 , at 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*)
More information about the mcclim-devel
mailing list