X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=58084a780831302ee7a85e13d30edf61861157ad;hb=64a7331285b0eab2c216f52670763c7d192cfdaa;hp=ec14addcb5c658e0d7f0771e509738d9a1891d93;hpb=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index ec14add..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))))))))))
@@ -2240,14 +2254,14 @@
        ((or (null main) (null sub) (= (the fixnum end1) jndex))
 	t)
      (declare (fixnum jndex))
-     (compare-elements (car main) (car sub))))
+     (compare-elements (car sub) (car main))))
 
 (sb!xc:defmacro search-compare-list-vector (main sub)
   `(do ((main ,main (cdr main))
 	(index start1 (1+ index)))
        ((or (null main) (= index (the fixnum end1))) t)
      (declare (fixnum index))
-     (compare-elements (car main) (aref ,sub index))))
+     (compare-elements (aref ,sub index) (car main))))
 
 (sb!xc:defmacro search-compare-vector-list (main sub index)
   `(do ((sub (nthcdr start1 ,sub) (cdr sub))
@@ -2255,14 +2269,14 @@
 	(index ,index (1+ index)))
        ((or (= (the fixnum end1) jndex) (null sub)) t)
      (declare (fixnum jndex index))
-     (compare-elements (aref ,main index) (car sub))))
+     (compare-elements (car sub) (aref ,main index))))
 
 (sb!xc:defmacro search-compare-vector-vector (main sub index)
   `(do ((index ,index (1+ index))
 	(sub-index start1 (1+ sub-index)))
        ((= sub-index (the fixnum end1)) t)
      (declare (fixnum sub-index index))
-     (compare-elements (aref ,main index) (aref ,sub sub-index))))
+     (compare-elements (aref ,sub sub-index) (aref ,main index))))
 
 (sb!xc:defmacro search-compare (main-type main sub index)
   (if (eq main-type 'list)