From 135374df8fa88387a532e438093082c008528599 Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Wed, 4 Jan 2017 08:37:01 -0500
Subject: [PATCH] Change an ETYPECASE to STRING-DISPATCH

Also export SIMPLE-CHARACTER-STRING from SB-KERNEL regardless of #+sb-unicode
---
 package-data-list.lisp-expr       |  1 +
 src/code/deftypes-for-target.lisp |  6 ++++++
 src/code/stream.lisp              | 22 ++++++----------------
 3 files changed, 13 insertions(+), 16 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index f372fbc83..151cb4f88 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1888,6 +1888,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "SIMPLE-ARRAY-SIGNED-BYTE-32-P"
                "SIMPLE-ARRAY-SIGNED-BYTE-64-P"
                "SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-BASE-STRING-P"
+               "SIMPLE-CHARACTER-STRING"
                #!+sb-unicode "SIMPLE-CHARACTER-STRING-P"
                "SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY"
                "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp
index 1a2bd57b9..38adaeec7 100644
--- a/src/code/deftypes-for-target.lisp
+++ b/src/code/deftypes-for-target.lisp
@@ -108,6 +108,12 @@
   `(or (simple-array character (,size))
        (simple-array nil (,size))
        (simple-base-string ,size)))
+;;; On Unicode builds, SIMPLE-CHARACTER-STRING is a builtin type.
+;;; For non-Unicode it is convenient to be able to use the type name
+;;; as an alias of SIMPLE-BASE-STRING.
+#!-sb-unicode
+(sb!xc:deftype simple-character-string (&optional size)
+  `(simple-base-string ,size))
 
 (sb!xc:deftype bit-vector (&optional size)
   `(array bit (,size)))
diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 1aa16d78b..b18dc4f81 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -1469,13 +1469,10 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
     (tagbody
      :more
        (when (plusp here)
-         (etypecase string
-           ((simple-array character (*))
+         (string-dispatch
+              (simple-character-string simple-base-string sb!kernel::simple-array-nil)
+              string
             (replace buffer string :start1 pointer :start2 start :end2 stop))
-           (simple-base-string
-            (replace buffer string :start1 pointer :start2 start :end2 stop))
-           ((simple-array nil (*))
-            (replace buffer string :start1 pointer :start2 start :end2 stop)))
          (setf (string-output-stream-pointer stream) (+ here pointer)))
        (when (plusp overflow)
          (setf start stop
@@ -1677,10 +1674,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
          (current+1 (1+ current)))
     (declare (fixnum current))
     (with-array-data ((workspace buffer) (start) (end))
-      (string-dispatch
-          ((simple-array character (*))
-           (simple-array base-char (*)))
-          workspace
+      (string-dispatch (simple-character-string simple-base-string) workspace
         (let ((offset-current (+ start current)))
           (declare (fixnum offset-current))
           (if (= offset-current end)
@@ -1702,10 +1696,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
 
 (defun fill-pointer-sout (stream string start end)
   (declare (fixnum start end))
-  (string-dispatch
-      ((simple-array character (*))
-       (simple-array base-char (*)))
-      string
+  (string-dispatch (simple-character-string simple-base-string) string
     (let* ((buffer (fill-pointer-output-stream-string stream))
            (current (fill-pointer buffer))
            (string-len (- end start))
@@ -2174,8 +2165,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
                         (len (min (- end %frc-index%)
                                   (- needed read))))
                    (declare (type index end len read needed))
-                   (string-dispatch (simple-base-string
-                                     (simple-array character (*)))
+                   (string-dispatch (simple-base-string simple-character-string)
                        seq
                      (replace seq %frc-buffer%
                               :start1 (+ start read)
-- 
2.11.4.GIT