string-output-stream improvements

- Avoid an extraneous type check in %MAKE-STRING-OUTPUT-STREAM.

- Test in WRITE-{CHAR,STRING} that the characters written are of the
  stream's element-type rather than failing in GET-OUTPUT-STREAM-STRING.

- {PRINx,WRITE}-TO-STRING and (FORMAT NIL ...) may return a base-string
  depending on what was placed into the string. Although the spec says that
  "with-output-from-string [sic] produces a stream that accepts characters
  and returns a string of the indicated element-type" it does not constrain
  all uses of string output streams to return a string whose element-type
  is the same as the stream element type.

NEWS

@@ -4,6 +4,8 @@ changes relative to sbcl-1.3.17:
   * minor incompatible change: existing values of CFLAGS, ASFLAGS,
     CPPFLAGS, and LINKFLAGS will be incorporated into C compiler
     invocations when building from source.
+  * minor incompatible change: the result of WRITE-TO-STRING may be
+    a BASE-STRING if all characters written are of type BASE-CHAR.
   * minor incompatible change: the broadcast stream with no output
     streams is a singleton object. That object satisfies OPEN-STREAM-P
     regardless of how many times CLOSE is invoked on it.

src/code/early-extensions.lisp

@@ -1698,14 +1698,14 @@ to :INTERPRET, an interpreter will be used.")
         `(let ((,var (sb!impl::make-fill-pointer-output-stream ,string)))
            ,@decls
            ,@forms)
-        `(let ((,var (make-string-output-stream)))
+        `(let ((,var #+sb-xc-host (make-string-output-stream)
+                     #-sb-xc-host (sb!impl::%make-string-output-stream
+                                   (or #!-sb-unicode 'character :default)
+                                   #'sb!impl::string-ouch)))
+
            ,@decls
            ,@forms
-           (truly-the (simple-array character (*))
-                      #+sb-xc-host (get-output-stream-string ,var)
-                      #-sb-xc-host
-                      (set-header-data (get-output-stream-string ,var)
-                                       +string-downgradable+))))))
+           (get-output-stream-string ,var)))))
 
 ;;; Ensure basicness if possible, and simplicity always
 (defun possibly-base-stringize (s)

src/code/stream.lisp

@@ -1360,10 +1360,9 @@
 
 (defstruct (string-output-stream
             (:include ansi-stream
-                      (out #'string-ouch)
                       (sout #'string-sout)
                       (misc #'string-out-misc))
-            (:constructor %make-string-output-stream (element-type))
+            (:constructor %make-string-output-stream (element-type out))
             (:copier nil)
             (:predicate nil))
   ;; The string we throw stuff in.
@@ -1382,10 +1381,12 @@
   ;; end of the stream.
   (index-cache 0 :type index)
   ;; Requested element type
-  ;; FIXME: there seems to be no way to skip the type-check in the ctor,
-  ;; which is redundant with the check in MAKE-STRING-OUTPUT-STREAM.
-  (element-type 'character :type type-specifier
-                           :read-only t))
+  (element-type nil
+                ;; It doesn't help anything to declare this slot's type.
+                ;; Readers don't really benefit, and the public constructor
+                ;; checks for validity.
+                #|:type (or #!+sb-unicode (eql :default) type-specifier)|#
+                :read-only t))
 
 (declaim (freeze-type string-output-stream))
 (defun make-string-output-stream (&key (element-type 'character))
@@ -1393,7 +1394,10 @@
 benefit of the function GET-OUTPUT-STREAM-STRING."
   (declare (explicit-check))
   (if (csubtypep (specifier-type element-type) (specifier-type 'character))
-      (%make-string-output-stream element-type)
+      (%make-string-output-stream
+       element-type (case element-type
+                      (base-char #'string-ouch/base-char)
+                      (t #'string-ouch)))
       (error "~S is not a subtype of CHARACTER" element-type)))
 
 (defstruct (finite-base-string-output-stream
@@ -1459,23 +1463,29 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
            (decf (string-output-stream-index stream) skipped)
            nil))))
 
-(defun string-ouch (stream character)
-  (/noshow0 "/string-ouch")
-  (let ((pointer (string-output-stream-pointer stream))
-        (buffer (string-output-stream-buffer stream))
-        (index (string-output-stream-index stream)))
-    (cond ((= pointer (length buffer))
-           (setf buffer (string-output-stream-new-buffer stream index)
-                 (aref buffer 0) character
-                 (string-output-stream-pointer stream) 1))
-          (t
-           (setf (aref buffer pointer) character
-                 (string-output-stream-pointer stream) (1+ pointer))))
-    (setf (string-output-stream-index stream) (1+ index))))
+(macrolet ((def (name char-type)
+  `(defun ,name (stream character)
+    (let ((pointer (string-output-stream-pointer stream))
+          (buffer (string-output-stream-buffer stream))
+          (index (string-output-stream-index stream)))
+      (when (= pointer (length buffer))
+        (setf buffer (string-output-stream-new-buffer stream index)
+              pointer 0))
+      (setf (aref buffer pointer) (the ,char-type character)
+            (string-output-stream-pointer stream) (1+ pointer))
+      (setf (string-output-stream-index stream) (1+ index))))))
+  (def string-ouch character)
+  (def string-ouch/base-char base-char))
 
 (defun string-sout (stream string start end)
   (declare (type simple-string string)
            (type index start end))
+  #!+sb-unicode
+  (when (and (typep string 'sb!kernel:simple-character-string)
+             (eq (string-output-stream-element-type stream) 'base-char))
+    (do ((i (1- end) (1- i))) ((< i start))
+      (declare (optimize (sb!c::insert-array-bounds-checks 0)))
+      (the base-char (char string i))))
   (let* ((full-length (- end start))
          (length full-length)
          (buffer (string-output-stream-buffer stream))
@@ -1588,7 +1598,10 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
     (:close
      (/noshow0 "/string-out-misc close")
      (set-closed-flame stream))
-    (:element-type (string-output-stream-element-type stream))
+    (:element-type
+     (let ((et (string-output-stream-element-type stream)))
+       ;; Always return a valid type-specifier
+       (if (eq et :default) 'character et)))
     (:element-mode 'character)))
 
 ;;; Return a string of all the characters sent to a stream made by
@@ -1601,6 +1614,20 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
          (prev (nreverse (string-output-stream-prev stream)))
          (this (string-output-stream-buffer stream))
          (next (string-output-stream-next stream))
+         #!+sb-unicode
+         (element-type
+          (if (eq element-type :default)
+              (if (or next
+                      (dolist (buf prev)
+                         (unless (every #'base-char-p
+                                        (truly-the simple-character-string buf))
+                           (return t)))
+                      (dotimes (i (string-output-stream-pointer stream))
+                        (unless (base-char-p (char this i))
+                          (return t))))
+                  'character
+                  'base-char)
+              element-type))
          (result
           (case element-type
             ;; overwhelmingly common case: can be inlined

src/code/target-package.lisp

@@ -963,30 +963,7 @@ implementation it is ~S." *!default-package-use-list*)
              (setf (values symbol where) (%find-symbol name length package))
              (if where
                  (values symbol where)
-                 ;; The common idiom of (INTERN (FORMAT NIL "~A-~A"))
-                 ;; should use a base-string for the name if possible.
-                 ;; As far as I can tell, it would be permissible for a
-                 ;; string-output-stream to return a base-string regardless
-                 ;; of the stream's element type. Barring some nontrivial
-                 ;; changes to get string-streams to remember whether they
-                 ;; contain any non-base characters, it's straightforward
-                 ;; to hint to INTERN that its first argument might have a
-                 ;; different type from the resulting symbol's pname.
-                 ;; Users' expectations are misplaced if they believe
-                 ;; that INTERN uses the first argument as-is. However,
-                 ;; we'll still "meet expectations" when the user supplies a
-                 ;; non-base string that was not produced via string-stream.
-                 (let* ((elt-type
-                         #!-sb-unicode elt-type
-                         #!+sb-unicode
-                         (if (or (eq elt-type 'base-char)
-                                 (and (simple-character-string-p name) ; non-base string
-                                      (logtest +string-downgradable+   ; from a string-stream
-                                               (get-header-data name))
-                                      (every #'base-char-p name)))
-                             'base-char
-                             'character))
-                        (symbol-name
+                 (let* ((symbol-name
                          (logically-readonlyize
                           (replace (make-string length :element-type elt-type)
                                    name))))

src/compiler/generic/early-vm.lisp

@@ -111,15 +111,6 @@
 ;; which can be expressed in 8 bits.
 (defconstant short-header-max-words #x7fff)
 
-;; A string which is tagged +STRING-DOWNGRADABLE+ is created as
-;; an array of CHARACTER, but when there is no express requirement
-;; in the spec to use CHARACTER as opposed to BASE-CHAR.
-;; As such, certain operations on the string are permitted
-;; to return an array of BASE-CHAR in the interest of memory savings.
-;; Presently, use of strings so tagged is for INTERN on the string
-;; resulting from writing to a string stream.
-(def!constant +string-downgradable+ 1)
-
 ;; A string tagged as +STRING-SHAREABLE+ is logically readonly,
 ;; and permitted to be shared with another string per the CLHS standard
 ;; under the concept of similarity as constant. A string so tagged is

src/compiler/srctran.lisp

@@ -4512,7 +4512,7 @@
   (declare (ignore control args))
   (when (and (constant-lvar-p dest)
              (null (lvar-value dest)))
-    (specifier-type '(simple-array character (*)))))
+    (specifier-type 'simple-string)))
 
 ;;; We disable this transform in the cross-compiler to save memory in
 ;;; the target image; most of the uses of FORMAT in the compiler are for
@@ -4995,7 +4995,11 @@
                                (and (csubtypep specifier (specifier-type 'character))
                                     (type-specifier specifier)))))))
    (if element-type
-       `(sb!impl::%make-string-output-stream ',element-type)
+       `(sb!impl::%make-string-output-stream
+         ',element-type
+         (function ,(case element-type
+                      (base-char 'sb!impl::string-ouch/base-char)
+                      (t 'sb!impl::string-ouch))))
        (give-up-ir1-transform))))
 
 (deftransform set ((symbol value) ((constant-arg symbol) *))

tests/stream.impure-cload.lisp

@@ -29,7 +29,7 @@
 (defvar *scratch-file-stream*)
 (dolist (scratch-file-length '(1 ; everyone's favorite corner case
                                200123)) ; hopefully much bigger than buffer
-  (format t "/SCRATCH-FILE-LENGTH=~W~%" scratch-file-length)
+  ; (format t "/SCRATCH-FILE-LENGTH=~W~%" scratch-file-length)
   (with-open-file (s *scratch-file-name* :direction :output)
     (dotimes (i scratch-file-length)
       (write-char #\x s)))
@@ -43,7 +43,7 @@
                  (lambda (wrapped-stream-name)
                    (make-concatenated-stream (symbol-value wrapped-stream-name)
                                              (make-string-input-stream "")))))
-    (format t "/WRAP-NAMED-STREAM-FN=~S~%" wrap-named-stream-fn)
+    ; (format t "/WRAP-NAMED-STREAM-FN=~S~%" wrap-named-stream-fn)
     (with-open-file (*scratch-file-stream* *scratch-file-name*
                                            :direction :input)
       (let ((ss (funcall wrap-named-stream-fn '*scratch-file-stream*)))