[Sbcl-commits] master: Allow readable printing of base strings

[Douglas K. <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  f8b76ace8c400d56f9ccb10378142e1157a35086 (commit)
      from  4d9f78924216e0e8ddc026e18977477c85e2186a (commit)

- Log -----------------------------------------------------------------
commit f8b76ace8c400d56f9ccb10378142e1157a35086
Author: Douglas Katzman <do...@go...>
Date:   Sun Aug 28 08:43:01 2016 -0400

    Allow readable printing of base strings
---
 NEWS                |    2 ++
 src/code/print.lisp |   40 ++++++++++++++++++++++++----------------
 2 files changed, 26 insertions(+), 16 deletions(-)

diff --git a/NEWS b/NEWS
index 2e0b1ed..d2f6220 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,8 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
 changes relative to sbcl-1.3.8:
+  * minor incompatible change: NAMESTRING prefers to return a BASE-STRING
+    instead of (ARRAY CHARACTER (*)) when possible.
   * enhancement: cached make-instance/allocate-instance constructors can now
     get garbage collected. 
   * optimization: better performance for some unoptimized operations on
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 98392aa..838ff78 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -926,22 +926,31 @@ variable: an unreadable object representing the error is printed instead.")
                   '(simple-array ,(array-element-type vector) (*)))
          :stream stream))
 
-(defun output-vector (vector stream)
+(defun output-vector (vector stream &aux (readably *print-readably*))
   (declare (vector vector))
   (cond ((stringp vector)
-         (cond ((and *print-readably*
-                     (not (eq (array-element-type vector)
-                              (load-time-value
-                               (array-element-type
-                                (make-array 0 :element-type 'character))))))
-                (print-not-readable-error vector stream))
-               ((or *print-escape* *print-readably*)
-                (write-char #\" stream)
-                (quote-string vector stream)
-                (write-char #\" stream))
-               (t
-                (write-string vector stream))))
-        ((not (or *print-array* *print-readably*))
+         (let ((coerce-p
+                #!+sb-unicode (and readably (base-string-p vector))))
+           (cond ((and coerce-p (not *read-eval*))
+                  (print-not-readable-error vector stream))
+                 ((or *print-escape* readably)
+                  (when coerce-p
+                    ;; OUTPUT-UNREADABLE-VECTOR-READABLY would output each char
+                    ;; in #\c syntax. In addition to wasting time coercing to a
+                    ;; general vector, it's not nice looking.
+                    (write-string "#.(" stream)
+                    (write 'coerce :stream stream) ; package-qualify / casify as needed
+                    (write-char #\Space stream))
+                  (write-char #\" stream)
+                  (quote-string vector stream)
+                  (write-char #\" stream)
+                  (when coerce-p
+                    (write-char #\Space stream)
+                    (write ''base-string :stream stream)
+                    (write-char #\) stream)))
+                 (t
+                  (write-string vector stream)))))
+        ((not (or *print-array* readably))
          (output-terse-array vector stream))
         ((bit-vector-p vector)
          (write-string "#*" stream)
@@ -949,8 +958,7 @@ variable: an unreadable object representing the error is printed instead.")
            ;; (Don't use OUTPUT-OBJECT here, since this code
            ;; has to work for all possible *PRINT-BASE* values.)
            (write-char (if (zerop bit) #\0 #\1) stream)))
-        ((or (not *print-readably*)
-             (array-readably-printable-p vector))
+        ((or (not readably) (array-readably-printable-p vector))
          (descend-into (stream)
                        (write-string "#(" stream)
                        (dotimes (i (length vector))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL