[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv2129

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (*sldb-pprint-dispatch-table*): Be careful when
calling WRITE recursively: set :circle to nil which avoids
interference with cycle-detection.
(escape-string): New helper function.
(*backtrace-pprint-dispatch-table*): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/15 18:47:38	1.1753
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/16 11:28:31	1.1754
@@ -1,3 +1,11 @@
+2009-05-16  Helmut Eller  <heller at common-lisp.net>
+
+	* swank.lisp (*sldb-pprint-dispatch-table*): Be careful when
+	calling WRITE recursively: set :circle to nil which avoids
+	interference with cycle-detection.
+	(escape-string): New helper function.
+	(*backtrace-pprint-dispatch-table*): Use it.
+
 2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-allegro.lisp (swank-compile-string): Forgot to remove old
--- /project/slime/cvsroot/slime/swank.lisp	2009/05/08 17:56:06	1.641
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:28:31	1.642
@@ -98,40 +98,33 @@
 ;;;
 ;;; We use a customized pprint dispatch table to do it for us.
 
-(declaim (special *sldb-string-length*))
-(declaim (special *sldb-bitvector-length*))
+(defvar *sldb-string-length* nil)
+(defvar *sldb-bitvector-length* nil)
 
 (defvar *sldb-pprint-dispatch-table*
   (let ((initial-table (copy-pprint-dispatch nil))
         (result-table  (copy-pprint-dispatch nil)))
     (flet ((sldb-bitvector-pprint (stream bitvector)
              ;;; Truncate bit-vectors according to *SLDB-BITVECTOR-LENGTH*.
-             (if (or (not *print-array*) (not *print-length*))
-                 (let ((*print-pprint-dispatch* initial-table))
-                   (write bitvector :stream stream))
+             (if (not *sldb-bitvector-length*)
+                 (write bitvector :stream stream :circle nil
+                        :pprint-dispatch initial-table)
                  (loop initially (write-string "#*" stream)
                        for i from 0 and bit across bitvector do
                        (when (= i *sldb-bitvector-length*)
                          (write-string "..." stream)
                          (loop-finish))
-                       (write bit :stream stream))))
+                       (write-char (if bit #\1 #\0) stream))))
            (sldb-string-pprint (stream string)
              ;;; Truncate strings according to *SLDB-STRING-LENGTH*.
-             (cond ((or (not *print-array*) (not *print-length*))
-                    (let ((*print-pprint-dispatch* initial-table))
-                      (write string :stream stream)))
-                   ((not *print-escape*)
+             (cond ((not *print-escape*)
                     (write-string string stream))
+                   ((not *sldb-string-length*)
+                    (write string :stream stream :circle nil
+                           :pprint-dispatch initial-table))
                    (t
-                    (loop initially (write-char #\" stream)
-                          for i from 0 and char across string do
-                          (cond ((= i *sldb-string-length*)
-                                 (write-string "..." stream)
-                                 (loop-finish))
-                                ((char= char #\")
-                                 (write-string "\\\"" stream))
-                                (t (write-char char stream)))
-                          finally (write-char #\" stream))))))
+                    (escape-string string stream
+                                   :length *sldb-string-length*)))))
       (set-pprint-dispatch 'bit-vector #'sldb-bitvector-pprint 0 result-table)
       (set-pprint-dispatch 'string #'sldb-string-pprint 0 result-table)
       result-table)))
@@ -156,18 +149,15 @@
 
 (defvar *backtrace-pprint-dispatch-table*
   (let ((table (copy-pprint-dispatch nil)))
-    (flet ((escape-string (stream string)
+    (flet ((print-string (stream string)
              (cond (*print-escape* 
-                    (write-char #\" stream)
-                    (loop for c across string do
-                          (case c
-                            (#\" (write-string "\\\"" stream))
-                            (#\newline (write-string "\\n" stream))
-                            (#\return (write-string "\\r" stream))
-                            (t (write-char c stream))))
-                    (write-char #\" stream))
+                    (escape-string string stream
+                                   :map '((#\" . "\\\"")
+                                          (#\\ . "\\\\")
+                                          (#\newline . "\\n")
+                                          (#\return . "\\r"))))
                    (t (write-string string stream)))))
-      (set-pprint-dispatch 'string  #'escape-string 0 table)
+      (set-pprint-dispatch 'string  #'print-string 0 table)
       table)))
 
 (defvar *backtrace-printer-bindings*
@@ -2300,6 +2290,23 @@
           (finish-output stream)
           (subseq buffer 0 fill-pointer))))))
 
+(defun escape-string (string stream &key length (map '((#\" . "\\\"")
+                                                       (#\\ . "\\\\"))))
+  "Write STRING to STREAM with surronded by double-quotes.
+LENGTH -- if non-nil truncate output after LENGTH chars.
+MAP -- rewrite the chars in STRING according this alist."
+  (let ((limit (or length array-dimension-limit)))
+    (write-char #\" stream)
+    (loop for c across string 
+          for i from 0 do
+          (when (= i limit)
+            (write-string "..." stream)
+            (return))
+          (let ((probe (assoc c map)))
+            (cond (probe (write-string (cadr probe) stream))
+                  (t (write-char c stream)))))
+    (write-char #\" stream)))
+
 (defun package-string-for-prompt (package)
   "Return the shortest nickname (or canonical name) of PACKAGE."
   (unparse-name