X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=58084a780831302ee7a85e13d30edf61861157ad;hb=902e93736a0888aa6b04dc328b1eb328423bf426;hp=b081375d4e378e9dc5b6061c66a40f4421616f45;hpb=937a46e64983862cb9e21761db95e58700341940;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index b081375..58084a7 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -254,7 +254,20 @@
   "Return a sequence of the given TYPE and LENGTH, with elements initialized
   to :INITIAL-ELEMENT."
   (declare (fixnum length))
-  (let ((type (specifier-type type)))
+  (let* ((adjusted-type
+	  (typecase type
+	    (atom (cond
+		    ((eq type 'string) '(vector character))
+		    ((eq 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 ,@(when (cdr type)
+						      (list (cdr type)))))
+		    (t type)))
+	    (t type)))
+	 (type (specifier-type adjusted-type)))
     (cond ((csubtypep type (specifier-type 'list))
 	   (cond
 	     ((type= type (specifier-type 'list))
@@ -279,29 +292,28 @@
 	     ;; it was stranger to feed that type in to MAKE-SEQUENCE.
 	     (t (sequence-type-too-hairy (type-specifier type)))))
 	  ((csubtypep type (specifier-type 'vector))
-	   (if (typep type 'array-type)
-	       ;; KLUDGE: the above test essentially asks "Do we know
-	       ;; what the upgraded-array-element-type is?" [consider
-	       ;; (OR STRING BIT-VECTOR)]
-	       (progn
-		 (aver (= (length (array-type-dimensions type)) 1))
-		 (let* ((etype (type-specifier
-                                (array-type-specialized-element-type type)))
-                        (etype (if (eq etype '*) t etype))
+	   (cond
+	     (;; is it immediately obvious what the result type is?
+	      (typep type 'array-type)
+	      (progn
+		(aver (= (length (array-type-dimensions type)) 1))
+		(let* ((etype (type-specifier
+			       (array-type-specialized-element-type type)))
+		       (etype (if (eq etype '*) t etype))
 		       (type-length (car (array-type-dimensions type))))
-		   (unless (or (eq type-length '*)
-			       (= type-length length))
-		     (sequence-type-length-mismatch-error type length))
-		   ;; FIXME: These calls to MAKE-ARRAY can't be
-		   ;; open-coded, as the :ELEMENT-TYPE argument isn't
-		   ;; constant.  Probably we ought to write a
-		   ;; DEFTRANSFORM for MAKE-SEQUENCE.  -- CSR,
-		   ;; 2002-07-22
-		   (if iep
-		       (make-array length :element-type etype
-				   :initial-element initial-element)
-		       (make-array length :element-type etype))))
-	       (sequence-type-too-hairy (type-specifier type))))
+		  (unless (or (eq type-length '*)
+			      (= type-length length))
+		    (sequence-type-length-mismatch-error type length))
+		  ;; FIXME: These calls to MAKE-ARRAY can't be
+		  ;; open-coded, as the :ELEMENT-TYPE argument isn't
+		  ;; constant.  Probably we ought to write a
+		  ;; DEFTRANSFORM for MAKE-SEQUENCE.  -- CSR,
+		  ;; 2002-07-22
+		  (if iep
+		      (make-array length :element-type etype
+				  :initial-element initial-element)
+		      (make-array length :element-type etype)))))
+	     (t (sequence-type-too-hairy (type-specifier type)))))
 	  (t (bad-sequence-type-error (type-specifier type))))))
 
 ;;;; SUBSEQ
@@ -699,6 +711,8 @@
   "Return a new sequence of all the argument sequences concatenated together
   which shares no structure with the original argument sequences of the
   specified OUTPUT-TYPE-SPEC."
+  (/show0 "full call to CONCATENATE, OUTPUT-TYPE-SPEC=..")
+  (/hexstr output-type-spec)
   (let ((type (specifier-type output-type-spec)))
   (cond
     ((csubtypep type (specifier-type 'list))
@@ -1972,7 +1986,7 @@
 						 (frob sequence nil))))
 			 (typecase sequence
 			   (simple-vector (frob2))
-			   (simple-string (frob2))
+			   (simple-base-string (frob2))
 			   (t (vector*-frob sequence))))
 		     (declare (type (or index null) p))
 		     (values f (and p (the index (+ p offset))))))))))