[slime-cvs] CVS slime
heller
heller at common-lisp.net
Fri Aug 22 21:15:19 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv22951
Modified Files:
ChangeLog swank-backend.lisp swank-cmucl.lisp swank-gray.lisp
swank.lisp
Log Message:
Implement streams with a length limit.
Use them to truncate printer output in backtraces.
* swank-backend.lisp (make-output-stream, make-input-stream):
Split make-fn-streams up into two functions.
* swank.lisp (call/truncated-output-to-string): New function.
(backtrace, istate>elisp, to-line): Use it.
(frame-locals-for-emacs): Use to-line.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:12 1.1469
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/22 21:15:19 1.1470
@@ -1,5 +1,17 @@
2008-08-22 Helmut Eller <heller at common-lisp.net>
+ Implement streams with a length limit.
+ Use them to truncate printer output in backtraces.
+
+ * swank-backend.lisp (make-output-stream, make-input-stream):
+ Split make-fn-streams up into two functions.
+
+ * swank.lisp (call/truncated-output-to-string): New function.
+ (backtrace, istate>elisp, to-line): Use it.
+ (frame-locals-for-emacs): Use to-line.
+
+2008-08-22 Helmut Eller <heller at common-lisp.net>
+
In backtraces, escape newlines in strings as \n.
* swank.lisp (*backtrace-pprint-dispatch-table*): New.
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/22 14:28:41 1.146
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/22 21:15:19 1.147
@@ -458,6 +458,14 @@
;;;; Streams
+(definterface make-output-stream (write-string)
+ "Return a new character output stream.
+The stream calls WRITE-STRING when output is ready.")
+
+(definterface make-input-stream (read-string)
+ "Return a new character input stream.
+The stream calls READ-STRING when input is needed.")
+
(definterface make-fn-streams (input-fn output-fn)
"Return character input and output streams backended by functions.
When input is needed, INPUT-FN is called with no arguments to
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/17 08:31:26 1.188
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/22 21:15:19 1.189
@@ -196,6 +196,12 @@
;;;; Stream handling
;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
+(defimplementation make-output-stream (write-string)
+ (make-slime-output-stream write-string))
+
+(defimplementation make-input-stream (read-string)
+ (make-slime-input-stream read-string))
+
(defimplementation make-fn-streams (input-fn output-fn)
(let* ((output (make-slime-output-stream output-fn))
(input (make-slime-input-stream input-fn output)))
--- /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/05 17:38:44 1.14
+++ /project/slime/cvsroot/slime/swank-gray.lisp 2008/08/22 21:15:19 1.15
@@ -161,6 +161,13 @@
;;;
+
+(defimplementation make-output-stream (write-string)
+ (make-instance 'slime-output-stream :output-fn output-fn))
+
+(defimplementation make-input-stream (read-string)
+ (make-instance 'slime-output-stream :input-fn output-fn))
+
(defimplementation make-fn-streams (input-fn output-fn)
(let* ((output (make-instance 'slime-output-stream
:output-fn output-fn))
--- /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:13 1.574
+++ /project/slime/cvsroot/slime/swank.lisp 2008/08/22 21:15:19 1.575
@@ -1485,11 +1485,11 @@
(defun encode-message (message stream)
(let* ((string (prin1-to-string-for-emacs message))
(length (length string)))
+ (assert (<= length #xffffff))
(log-event "WRITE: ~A~%" string)
- (without-interrupts
- (let ((*print-pretty* nil))
- (format stream "~6,'0x" length))
- (write-string string stream))
+ (let ((*print-pretty* nil))
+ (format stream "~6,'0x" length))
+ (write-string string stream)
;;(terpri stream)
(finish-output stream)))
@@ -1958,6 +1958,27 @@
(ellipsis (cat (subseq string 0 width) ellipsis))
(t (subseq string 0 width)))))
+(defun call/truncated-output-to-string (length function
+ &optional (ellipsis ".."))
+ "Call FUNCTION with a new stream, return the output written to the stream.
+If FUNCTION tries to write more than LENGTH characters, it will be
+aborted and return immediately with the output written so far."
+ (let ((buffer (make-string (+ length (length ellipsis))))
+ (fill-pointer 0))
+ (block buffer-full
+ (flet ((write-output (string)
+ (let* ((free (- length fill-pointer))
+ (count (min free (length string))))
+ (replace buffer string :start1 fill-pointer :end2 count)
+ (incf fill-pointer count)
+ (when (> (length string) free)
+ (replace buffer ellipsis :start1 fill-pointer)
+ (return-from buffer-full buffer)))))
+ (let ((stream (make-output-stream #'write-output)))
+ (funcall function stream)
+ (finish-output stream)
+ (subseq buffer 0 fill-pointer))))))
+
(defun package-string-for-prompt (package)
"Return the shortest nickname (or canonical name) of PACKAGE."
(unparse-name
@@ -2191,13 +2212,16 @@
"Return a list ((I FRAME) ...) of frames from START to END.
I is an integer describing and FRAME a string."
(loop for frame in (compute-backtrace start end)
- for i from start
- collect (list i (with-output-to-string (stream)
- (handler-case
- (with-bindings *backtrace-printer-bindings*
- (print-frame frame stream))
- (t ()
- (format stream "[error printing frame]")))))))
+ for i from start collect
+ (list i
+ (call/truncated-output-to-string
+ 100
+ (lambda (stream)
+ (handler-case
+ (with-bindings *backtrace-printer-bindings*
+ (print-frame frame stream))
+ (t ()
+ (format stream "[error printing frame]"))))))))
(defslimefun debugger-info-for-emacs (start end)
"Return debugger state, with stack frames from START to END.
@@ -2283,7 +2307,7 @@
(mapcar (lambda (frame-locals)
(destructuring-bind (&key name id value) frame-locals
(list :name (prin1-to-string name) :id id
- :value (to-string value))))
+ :value (to-line value))))
(frame-locals index))))
(defslimefun frame-catch-tags-for-emacs (frame-index)
@@ -2848,9 +2872,11 @@
(emacs-inspect object)))
(defun istate>elisp (istate)
- (list :title (with-output-to-string (s)
- (print-unreadable-object ((istate.object istate)
- s :type t :identity t)))
+ (list :title (call/truncated-output-to-string
+ 200
+ (lambda (s)
+ (print-unreadable-object ((istate.object istate)
+ s :type t :identity t))))
:id (assign-index (istate.object istate) (istate.parts istate))
:content (content-range (inspector-content istate) 0 500)))
@@ -2889,10 +2915,11 @@
;; Print OBJECT to a single line. Return the string.
(defun to-line (object &optional (width 75))
- (truncate-string
- (with-output-to-string (*standard-output*)
+ (call/truncated-output-to-string
+ width
+ (lambda (*standard-output*)
(write object :right-margin width :lines 1))
- 80 ".."))
+ ".."))
(defun content-range (list start end)
(let* ((len (length list)) (end (min len end)))
More information about the slime-cvs
mailing list