[slime-cvs] CVS slime/contrib
mkoeppe
mkoeppe at common-lisp.net
Sat Aug 25 00:51:52 UTC 2007
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv15975/contrib
Added Files:
swank-presentation-streams.lisp
Log Message:
* swank-presentation-streams.lisp [sbcl]: Load the pretty-printer
patch only at load time. Add some trickery so that SBCL does not
complain about the changed layout of the pretty-stream class.
* swank-presentation-streams.lisp (slime-stream-p): Using special
return values, indicate whether we are printing to the
REPL-results stream, or a dedicated stream.
(presentation-record): New slot "target".
(presentation-start, presentation-end): Use it (rather than the
global variable *use-dedicated-output-stream*) to decide whether
to use the bridge protocol or the :presentation-start/-end
protocol. Also use it as the TARGET argument of
:presentation-start/-end messages.
(presenting-object-1): Use the new return values of
slime-stream-p.
* swank-presentation-streams.lisp: New file, moved here from
../present.lisp
--- /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 00:51:52 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/25 00:51:52 1.1
;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities
;;; to portions of output
;;;
;;; Authors: Alan Ruttenberg <alanr-l at mumble.net>
;;; Matthias Koeppe <mkoeppe at mail.math.uni-magdeburg.de>
;;; Helmut Eller <heller at common-lisp.net>
;;;
;;; License: This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
(in-package :swank)
;; A mechanism for printing to the slime repl so that the printed
;; result remembers what object it is associated with. Depends on the
;; ilisp bridge code being installed and ready to intercept messages
;; in the printed stream. We encode the information with a message
;; saying that we are starting to print an object corresponding to a
;; given id and another when we are done. The process filter notices these
;; and adds the necessary text properties to the output.
;; We only do this if we know we are printing to a slime stream,
;; checked with the method slime-stream-p. Initially this checks for
;; the knows slime streams looking at *connections*. In cmucl and
;; openmcl it also checks if it is a pretty-printing stream which
;; ultimately prints to a slime stream.
;; Control
(defvar *enable-presenting-readable-objects* t
"set this to enable automatically printing presentations for some
subset of readable objects, such as pathnames." )
;; doing it
(defmacro presenting-object (object stream &body body)
"What you use in your code. Wrap this around some printing and that text will
be sensitive and remember what object it is in the repl"
`(presenting-object-1 ,object ,stream #'(lambda () , at body)))
(defmacro presenting-object-if (predicate object stream &body body)
"What you use in your code. Wrap this around some printing and that text will
be sensitive and remember what object it is in the repl if predicate is true"
(let ((continue (gensym)))
`(let ((,continue #'(lambda () , at body)))
(if ,predicate
(presenting-object-1 ,object ,stream ,continue)
(funcall ,continue)))))
;;; Get pretty printer patches for SBCL at load (not compile) time.
#+sbcl
(eval-when (:load-toplevel)
(handler-bind ((simple-error
(lambda (c)
(declare (ignore 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 (make-pathname
:name "sbcl-pprint-patch"
:type "lisp"
:directory (pathname-directory swank-loader:*source-directory*)))))))
(let ((last-stream nil)
(last-answer nil))
(defun slime-stream-p (stream)
"Check if stream is one of the slime streams, since if it isn't we
don't want to present anything.
Two special return values:
:DEDICATED -- Output ends up on a dedicated output stream
:REPL-RESULT -- Output ends up on the :repl-results target.
"
(if (eq last-stream stream)
last-answer
(progn
(setq last-stream stream)
(if (eq stream t)
(setq stream *standard-output*))
(setq last-answer
(or #+openmcl
(and (typep stream 'ccl::xp-stream)
;(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
(or (and (typep stream 'lisp::indenting-stream)
(slime-stream-p (lisp::indenting-stream-stream stream)))
(and (typep stream 'pretty-print::pretty-stream)
(fboundp 'pretty-print::enqueue-annotation)
(not *use-dedicated-output-stream*)
;; Printing through CMUCL pretty streams
;; is only cleanly possible if we are
;; using the bridge-less protocol with
;; annotations, because the bridge escape
;; sequences disturb the pretty printer
;; layout.
(slime-stream-p (pretty-print::pretty-stream-target stream))))
#+sbcl
(let ()
(declare (notinline sb-pretty::pretty-stream-target))
(or (and (typep stream 'sb-impl::indenting-stream)
(slime-stream-p (sb-impl::indenting-stream-stream stream)))
(and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))
(find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)
(not *use-dedicated-output-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 (and (eq stream (connection.dedicated-output connection))
:dedicated)
(eq stream (connection.socket-io connection))
(eq stream (connection.user-output connection))
(eq stream (connection.user-io connection))
(and (eq stream (connection.repl-results connection))
:repl-result)))))))))
(defun can-present-readable-objects (&optional stream)
(declare (ignore stream))
*enable-presenting-readable-objects*)
;; 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 (and (typep stream 'pp:pretty-stream)
(fboundp 'pp::enqueue-annotation))
(pp::enqueue-annotation stream function arg)
(funcall function arg stream nil)))
#+sbcl
(defun write-annotation (stream function arg)
(let ((enqueue-annotation
(find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)))
(if (and enqueue-annotation
(typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)))
(funcall 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)
(target))
(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))
(target (presentation-record-target record)))
(case target
(:dedicated
;; Use bridge protocol
(write-string "<" stream)
(prin1 pid stream)
(write-string " " stream))
(t
(finish-output stream)
(send-to-emacs `(:presentation-start ,pid ,target)))))
(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))
(target (presentation-record-target record)))
(case target
(:dedicated
;; Use bridge protocol
(write-string ">" stream)
(prin1 pid stream)
(write-string " " stream))
(t
(finish-output stream)
(send-to-emacs `(:presentation-end ,pid ,target)))))))
(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"
(let ((slime-stream-p
(and *record-repl-results* (slime-stream-p stream))))
(if slime-stream-p
(let* ((pid (swank::save-presented-object object))
(record (make-presentation-record :id pid :printed-p nil
:target (if (eq slime-stream-p :repl-result)
:repl-result
nil))))
(write-annotation stream #'presentation-start record)
(multiple-value-prog1
(funcall continue)
(write-annotation stream #'presentation-end record)))
(funcall continue))))
(defun send-repl-results-to-emacs (values)
;; Override a function in swank.lisp, so that
;; nested presentations work in the REPL result.
(let ((repl-results (connection.repl-results *emacs-connection*)))
(flet ((send (value)
(presenting-object value repl-results
(prin1 value repl-results))
(terpri repl-results)))
(if (null values)
(progn
(princ "; No value" repl-results)
(terpri repl-results))
(mapc #'send values)))
(finish-output repl-results)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class)
#+openmcl
(in-package :ccl)
#+openmcl
(let ((*warn-if-redefine-kernel* nil)
(*warn-if-redefine* nil))
(defun %print-unreadable-object (object stream type id thunk)
(cond ((null stream) (setq stream *standard-output*))
((eq stream t) (setq stream *terminal-io*)))
(swank::presenting-object object stream
(write-unreadable-start object stream)
(when type
(princ (type-of object) stream)
(stream-write-char stream #\space))
(when thunk
(funcall thunk))
(if id
(%write-address object stream #\>)
(pp-end-block stream ">"))
nil))
(defmethod print-object :around ((pathname pathname) stream)
(swank::presenting-object-if
(swank::can-present-readable-objects stream)
pathname stream (call-next-method))))
#+openmcl
(ccl::def-load-pointers clear-presentations ()
(swank::clear-presentation-tables))
(in-package :swank)
#+cmu
(progn
(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-if (can-present-readable-objects stream) pathname stream
(fwrappers:call-next-function)))
(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))
(provide :swank-presentation-streams)
More information about the slime-cvs
mailing list