X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=660f804fcde86c6f5d64336cf66b408d5d9f797b;hb=91392754bf1d241cd6913c728268caf18eae1485;hp=e7c0da32dc712564e577c5894d37ebb6c6530203;hpb=88fbde7b3c6e6e66bdde408348337e97068f2568;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index e7c0da3..660f804 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -87,20 +87,33 @@
 				result-type-arg-value)))))
     `(lambda (result-type-arg fun ,@seq-names)
        (truly-the ,result-type
-	 ,(cond ((policy node (> speed safety))
+	 ,(cond ((policy node (< safety 3))
+		 ;; ANSI requires the length-related type check only
+		 ;; when the SAFETY quality is 3... in other cases, we
+		 ;; skip it, because it could be expensive.
 		 bare)
 		((not constant-result-type-arg-p)
 		 `(sequence-of-checked-length-given-type ,bare
 							 result-type-arg))
 		(t
-		 (let ((result-ctype (specifier-type result-type)))
+		 (let ((result-ctype (ir1-transform-specifier-type
+				      result-type)))
 		   (if (array-type-p result-ctype)
-		       (let* ((dims (array-type-dimensions result-ctype))
-			      (dim (first dims)))
-			 (if (eq dim '*)
-			     bare
-			     `(vector-of-checked-length-given-length ,bare
-								     ,dim)))
+		       (let ((dims (array-type-dimensions result-ctype)))
+			 (unless (and (listp dims) (= (length dims) 1))
+			   (give-up-ir1-transform "invalid sequence type"))
+			 (let ((dim (first dims)))
+			   (if (eq dim '*)
+			       bare
+			       `(vector-of-checked-length-given-length ,bare
+				                                       ,dim))))
+		       ;; FIXME: this is wrong, as not all subtypes of
+		       ;; VECTOR are ARRAY-TYPEs [consider, for
+		       ;; example, (OR (VECTOR T 3) (VECTOR T
+		       ;; 4))]. However, it's difficult to see what we
+		       ;; should put here... maybe we should
+		       ;; GIVE-UP-IR1-TRANSFORM if the type is a
+		       ;; subtype of VECTOR but not an ARRAY-TYPE?
 		       bare))))))))
 
 ;;; Try to compile %MAP efficiently when we can determine sequence
@@ -652,10 +665,12 @@
 ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
 ;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
 ;;; at least once DYNAMIC-EXTENT works.
-#+nil ; FIXME: currently commented out because of bug 188
+;;;
+;;; FIXME: currently KLUDGEed because of bug 188
 (deftransform concatenate ((rtype &rest sequences)
 			   (t &rest simple-string)
-			   simple-string)
+			   simple-string
+			   :policy (< safety 3))
   (collect ((lets)
 	    (forms)
 	    (all-lengths)
@@ -670,16 +685,19 @@
 	(forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
 			       res start
 			       ,n-length))
-	(forms `(setq start (+ start ,n-length)))))
+	(forms `(setq start (opaque-identity (+ start ,n-length))))))
     `(lambda (rtype ,@(args))
        (declare (ignore rtype))
-       (let* (,@(lets)
-	      (res (make-string (truncate (the index (+ ,@(all-lengths)))
-					  sb!vm:n-byte-bits)))
-	      (start ,vector-data-bit-offset))
-	 (declare (type index start ,@(all-lengths)))
-	 ,@(forms)
-	 res))))
+       ;; KLUDGE
+       (flet ((opaque-identity (x) x))
+	 (declare (notinline opaque-identity))
+	 (let* (,@(lets)
+		  (res (make-string (truncate (the index (+ ,@(all-lengths)))
+					      sb!vm:n-byte-bits)))
+		  (start ,vector-data-bit-offset))
+	   (declare (type index start ,@(all-lengths)))
+	   ,@(forms)
+	   res)))))
 
 ;;;; CONS accessor DERIVE-TYPE optimizers