0.8.16.22:

[sbcl.git] / src / code / stream.lisp

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index a99b5e3..b33dfb9 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -1233,14 +1233,19 @@
         (element-type (string-output-stream-element-type stream))
         (result 
          (case element-type
-           ;; Overwhelmingly common case; can be inlined.
+           ;; overwhelmingly common case: can be inlined
            ((character) (make-string length))
+           ;; slightly less common cases: inline it anyway
+           ((base-char standard-char)
+            (make-string length :element-type 'base-char))
            (t (make-string length :element-type element-type)))))
     ;; For the benefit of the REPLACE transform, let's do this, so
     ;; that the common case isn't ludicrously expensive.
     (etypecase result 
       ((simple-array character (*)) 
        (replace result (string-output-stream-string stream)))
+      (simple-base-string
+       (replace result (string-output-stream-string stream)))
       ((simple-array nil (*))
        (replace result (string-output-stream-string stream))))
     (setf (string-output-stream-index stream) 0
@@ -1263,6 +1268,8 @@
 ;;; the CLM, but they are required for the implementation of
 ;;; WITH-OUTPUT-TO-STRING.
 
+;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL),
+;;; ideally without destroying all hope of efficiency.
 (deftype string-with-fill-pointer ()
   '(and (vector character)
        (satisfies array-has-fill-pointer-p)))
@@ -1292,9 +1299,9 @@
        (if (= offset-current end)
            (let* ((new-length (1+ (* current 2)))
                   (new-workspace (make-string new-length)))
-             (declare (simple-string new-workspace))
-             (%byte-blt workspace start
-                        new-workspace 0 current)
+             (declare (type (simple-array character (*)) new-workspace))
+              (replace new-workspace workspace
+                       :start2 start :end2 offset-current)
              (setf workspace new-workspace
                    offset-current current)
              (set-array-header buffer workspace new-length
@@ -1322,21 +1329,16 @@
            (let* ((new-length (+ (the fixnum (* current 2)) string-len))
                   (new-workspace (make-string new-length)))
              (declare (type (simple-array character (*)) new-workspace))
-             (%byte-blt workspace dst-start
-                        new-workspace 0 current)
-             (setf workspace new-workspace)
-             (setf offset-current current)
-             (setf offset-dst-end dst-end)
-             (set-array-header buffer
-                               workspace
-                               new-length
-                               dst-end
-                               0
-                               new-length
-                               nil))
+              (replace new-workspace workspace
+                       :start2 dst-start :end2 offset-current)
+             (setf workspace new-workspace
+                    offset-current current
+                    offset-dst-end dst-end)
+             (set-array-header buffer workspace new-length
+                               dst-end 0 new-length nil))
            (setf (fill-pointer buffer) dst-end))
-       (%byte-blt string start
-                  workspace offset-current offset-dst-end)))
+       (replace workspace string
+                 :start1 offset-current :start2 start :end2 end)))
     dst-end))
 
 (defun fill-pointer-misc (stream operation &optional arg1 arg2)