3
;;; This code has been placed in the Public Domain. All warranties
6
;; A mechanism for printing to the slime repl so that the printed
7
;; result remembers what object it is associated with. Depends on the
8
;; ilisp bridge code being installed and ready to intercept messages
9
;; in the printed stream. We encode the information with a message
10
;; saying that we are starting to print an object corresponding to a
11
;; given id and another when we are done. The process filter notices these
12
;; and adds the necessary text properties to the output.
14
;; We only do this if we know we are printing to a slime stream,
15
;; checked with the method slime-stream-p. Initially this checks for
16
;; the knows slime streams looking at *connections*. In cmucl and
17
;; openmcl it also checks if it is a pretty-printing stream which
18
;; ultimately prints to a slime stream.
21
(defvar *enable-presenting-readable-objects* t
22
"set this to enable automatically printing presentations for some
23
subset of readable objects, such as pathnames." )
27
(defmacro presenting-object (object stream &body body)
28
"What you use in your code. Wrap this around some printing and that text will
29
be sensitive and remember what object it is in the repl"
30
`(presenting-object-1 ,object ,stream #'(lambda () ,@body)))
32
(defmacro presenting-object-if (predicate object stream &body body)
33
"What you use in your code. Wrap this around some printing and that text will
34
be sensitive and remember what object it is in the repl if predicate is true"
35
(let ((continue (gensym)))
36
`(let ((,continue #'(lambda () ,@body)))
38
(presenting-object-1 ,object ,stream ,continue)
39
(funcall ,continue)))))
41
;;; Get pretty printer patches for SBCL
43
(eval-when (:compile-toplevel :load-toplevel :execute)
44
(handler-bind ((simple-error
47
(let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
48
(when clobber-it (invoke-restart clobber-it))))))
49
(sb-ext:without-package-locks
50
(swank-backend::with-debootstrapping
52
:name "sbcl-pprint-patch"
54
:directory (pathname-directory swank-loader:*source-directory*)))))))
56
(let ((last-stream nil)
58
(defun slime-stream-p (stream)
59
"Check if stream is one of the slime streams, since if it isn't we
60
don't want to present anything"
61
(if (eq last-stream stream)
64
(setq last-stream stream)
66
(setq stream *standard-output*))
69
(and (typep stream 'ccl::xp-stream)
70
;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure)))
71
(slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1)))
73
(or (and (typep stream 'lisp::indenting-stream)
74
(slime-stream-p (lisp::indenting-stream-stream stream)))
75
(and (typep stream 'pretty-print::pretty-stream)
76
(fboundp 'pretty-print::enqueue-annotation)
77
(not *use-dedicated-output-stream*)
78
;; Printing through CMUCL pretty streams
79
;; is only cleanly possible if we are
80
;; using the bridge-less protocol with
81
;; annotations, because the bridge escape
82
;; sequences disturb the pretty printer
84
(slime-stream-p (pretty-print::pretty-stream-target stream))))
86
(or (and (typep stream 'sb-impl::indenting-stream)
87
(slime-stream-p (sb-impl::indenting-stream-stream stream)))
88
(and (typep stream 'sb-pretty::pretty-stream)
89
(fboundp 'sb-pretty::enqueue-annotation)
90
(not *use-dedicated-output-stream*)
91
(slime-stream-p (sb-pretty::pretty-stream-target stream))))
93
(and (typep stream 'excl:xp-simple-stream)
94
(slime-stream-p (excl::stream-output-handle stream)))
95
(loop for connection in *connections*
96
thereis (or (eq stream (connection.dedicated-output connection))
97
(eq stream (connection.socket-io connection))
98
(eq stream (connection.user-output connection))
99
(eq stream (connection.user-io connection))
100
(eq stream (connection.repl-results connection))))))))))
102
(defun can-present-readable-objects (&optional stream)
103
(declare (ignore stream))
104
*enable-presenting-readable-objects*)
106
;; If we are printing to an XP (pretty printing) stream, printing the
107
;; escape sequences directly would mess up the layout because column
108
;; counting is disturbed. Use "annotations" instead.
110
(defun write-annotation (stream function arg)
111
(if (typep stream 'excl:xp-simple-stream)
112
(excl::schedule-annotation stream function arg)
113
(funcall function arg stream nil)))
115
(defun write-annotation (stream function arg)
116
(if (and (typep stream 'pp:pretty-stream)
117
(fboundp 'pp::enqueue-annotation))
118
(pp::enqueue-annotation stream function arg)
119
(funcall function arg stream nil)))
121
(defun write-annotation (stream function arg)
122
(if (typep stream 'sb-pretty::pretty-stream)
123
(sb-pretty::enqueue-annotation stream function arg)
124
(funcall function arg stream nil)))
125
#-(or allegro cmu sbcl)
126
(defun write-annotation (stream function arg)
127
(funcall function arg stream nil))
129
(defstruct presentation-record
133
(defun presentation-start (record stream truncatep)
135
;; Don't start new presentations when nothing is going to be
136
;; printed due to *print-lines*.
137
(let ((pid (presentation-record-id record)))
138
(cond (*use-dedicated-output-stream*
139
(write-string "<" stream)
141
(write-string " " stream))
143
(finish-output stream)
144
(send-to-emacs `(:presentation-start ,pid)))))
145
(setf (presentation-record-printed-p record) t)))
147
(defun presentation-end (record stream truncatep)
148
(declare (ignore truncatep))
149
;; Always end old presentations that were started.
150
(when (presentation-record-printed-p record)
151
(let ((pid (presentation-record-id record)))
152
(cond (*use-dedicated-output-stream*
153
(write-string ">" stream)
155
(write-string " " stream))
157
(finish-output stream)
158
(send-to-emacs `(:presentation-end ,pid)))))))
160
(defun presenting-object-1 (object stream continue)
161
"Uses the bridge mechanism with two messages >id and <id. The first one
162
says that I am starting to print an object with this id. The second says I am finished"
163
(if (and *record-repl-results* (slime-stream-p stream))
164
(let* ((pid (swank::save-presented-object object))
165
(record (make-presentation-record :id pid :printed-p nil)))
166
(write-annotation stream #'presentation-start record)
167
(multiple-value-prog1
169
(write-annotation stream #'presentation-end record)))
172
(defun send-repl-results-to-emacs (values)
173
;; Override a function in swank.lisp, so that
174
;; nested presentations work in the REPL result.
175
(let ((repl-results (connection.repl-results *emacs-connection*)))
177
(presenting-object value repl-results
178
(prin1 value repl-results))
179
(terpri repl-results)))
182
(princ "; No value" repl-results)
183
(terpri repl-results))
184
(mapc #'send values)))
185
(finish-output repl-results)))
187
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
189
;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class)
193
(let ((*warn-if-redefine-kernel* nil)
194
(*warn-if-redefine* nil))
195
(defun %print-unreadable-object (object stream type id thunk)
196
(cond ((null stream) (setq stream *standard-output*))
197
((eq stream t) (setq stream *terminal-io*)))
198
(swank::presenting-object object stream
199
(write-unreadable-start object stream)
201
(princ (type-of object) stream)
202
(stream-write-char stream #\space))
206
(%write-address object stream #\>)
207
(pp-end-block stream ">"))
209
(defmethod print-object :around ((pathname pathname) stream)
210
(swank::presenting-object-if
211
(swank::can-present-readable-objects stream)
212
pathname stream (call-next-method))))
215
(ccl::def-load-pointers clear-presentations ()
216
(swank::clear-presentation-tables))
222
(fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body)
223
(presenting-object object stream
224
(fwrappers:call-next-function)))
226
(fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth)
227
(presenting-object-if (can-present-readable-objects stream) pathname stream
228
(fwrappers:call-next-function)))
230
(fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper)
231
(fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper)
236
(defvar *saved-%print-unreadable-object*
237
(fdefinition 'sb-impl::%print-unreadable-object))
238
(sb-ext:without-package-locks
239
(setf (fdefinition 'sb-impl::%print-unreadable-object)
240
(lambda (object stream type identity body)
241
(presenting-object object stream
242
(funcall *saved-%print-unreadable-object*
243
object stream type identity body))))
244
(defmethod print-object :around ((object pathname) stream)
245
(presenting-object object stream
246
(call-next-method)))))
250
(excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation)
251
(swank::presenting-object object stream (excl:call-next-fwrapper)))
252
(excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth)
253
(presenting-object-if (can-present-readable-objects stream) pathname stream
254
(excl:call-next-fwrapper)))
255
(excl:fwrap 'excl::print-unreadable-object-1
256
'print-unreadable-present 'presenting-unreadable-wrapper)
257
(excl:fwrap 'excl::pathname-printer
258
'print-pathname-present 'presenting-pathname-wrapper))
added
removed
present.lisp
