From f066ad2b0b89c016ab9ceaac6de0758e4eb4c1fb Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cantab.net>
Date: Fri, 12 Aug 2011 13:57:51 +0100
Subject: [PATCH] allow user-defined STRING synonyms in MAKE-SEQUENCE

...and MAP, MERGE, COERCE and CONCATENATE too.  This also meant
working a bit on TYPEXPAND, to make (STRING <N>) be unexpanded in the
same way as STRING, and consequently on VALUES-SPECIFIER-TYPE to
ensure that the system would still recognize those types.

Include test cases for the sequence functions but not for TYPEXPAND.
---
 src/code/early-type.lisp |    7 +++++++
 src/code/seq.lisp        |   17 +++++++++--------
 tests/seq.impure.lisp    |   21 +++++++++++++++++++++
 3 files changed, 37 insertions(+), 8 deletions(-)

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index ec513da..5b761c0 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -547,6 +547,10 @@
           (cond
            ((and (not (eq spec u))
                  (info :type :builtin spec)))
+           ((and (consp spec) (symbolp (car spec))
+                 (info :type :builtin (car spec))
+                 (let ((expander (info :type :expander (car spec))))
+                   (and expander (values-specifier-type (funcall expander spec))))))
            ((eq (info :type :kind spec) :instance)
             (find-classoid spec))
            ((typep spec 'classoid)
@@ -615,6 +619,9 @@ expansion happened."
                (values nil nil))
               ((symbolp spec)
                (values (info :type :expander spec) (list spec)))
+              ((and (consp spec) (symbolp (car spec)) (info :type :builtin (car spec)))
+               ;; see above
+               (values nil nil))
               ((and (consp spec) (symbolp (car spec)))
                (values (info :type :expander (car spec)) spec))
               (t nil)))
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 4fb5911..d37da2c 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -296,17 +296,18 @@
   "Return a sequence of the given TYPE and LENGTH, with elements initialized
   to INITIAL-ELEMENT."
   (declare (fixnum length))
-  (let* ((adjusted-type
-          (typecase type
+  (let* ((expanded-type (typexpand type))
+         (adjusted-type
+          (typecase expanded-type
             (atom (cond
-                    ((eq type 'string) '(vector character))
-                    ((eq type 'simple-string) '(simple-array character (*)))
+                    ((eq expanded-type 'string) '(vector character))
+                    ((eq expanded-type 'simple-string) '(simple-array character (*)))
                     (t type)))
             (cons (cond
-                    ((eq (car type) 'string) `(vector character ,@(cdr type)))
-                    ((eq (car type) 'simple-string)
-                     `(simple-array character ,(if (cdr type)
-                                                   (cdr type)
+                    ((eq (car expanded-type) 'string) `(vector character ,@(cdr expanded-type)))
+                    ((eq (car expanded-type) 'simple-string)
+                     `(simple-array character ,(if (cdr expanded-type)
+                                                   (cdr expanded-type)
                                                    '(*))))
                     (t type)))
             (t type)))
diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index ffb1ec7..7de0756 100644
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -1118,4 +1118,25 @@
                   (error ()
                     :error))))))
 
+;;; tests of deftype types equivalent to STRING or SIMPLE-STRING
+(deftype %string () 'string)
+(deftype %simple-string () 'simple-string)
+(deftype string-3 () '(string 3))
+(deftype simple-string-3 () '(simple-string 3))
+
+(with-test (:name :user-defined-string-types-map-etc)
+  (dolist (type '(%string %simple-string string-3 simple-string-3))
+    (assert (string= "foo" (coerce '(#\f #\o #\o) type)))
+    (assert (string= "foo" (map type 'identity #(#\f #\o #\o))))
+    (assert (string= "foo" (merge type '(#\o) '(#\f #\o) 'char<)))
+    (assert (string= "foo" (concatenate type '(#\f) "oo")))
+    (assert (string= "ooo" (make-sequence type 3 :initial-element #\o)))))
+(with-test (:name :user-defined-string-types-map-etc-error)
+  (dolist (type '(string-3 simple-string-3))
+    (assert (raises-error? (coerce '(#\q #\u #\u #\x) type)))
+    (assert (raises-error? (map type 'identity #(#\q #\u #\u #\x))))
+    (assert (raises-error? (merge type '(#\q #\x) "uu" 'char<)))
+    (assert (raises-error? (concatenate type "qu" '(#\u #\x))))
+    (assert (raises-error? (make-sequence type 4 :initial-element #\u)))))
+
 ;;; success
-- 
1.7.10.4