0.7.8.8:

[sbcl.git] / src / compiler / seqtran.lisp

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index f7e170a..9792a4b 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -93,7 +93,7 @@
                 `(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)))
@@ -293,17 +293,22 @@
                    :policy (> speed space))
   "open code"
   (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
-    `(with-array-data ((data seq)
-                      (start start)
-                      (end end))
+    (values 
+     `(with-array-data ((data seq)
+                       (start start)
+                       (end end))
        (declare (type (simple-array ,element-type 1) data))
+       (declare (type fixnum start end))
        (do ((i start (1+ i)))
           ((= i end) seq)
         (declare (type index i))
         ;; WITH-ARRAY-DATA did our range checks once and for all, so
-        ;; it'd be wasteful to check again on every AREF.
+        ;; it'd be wasteful to check again on every AREF...
         (declare (optimize (safety 0))) 
-        (setf (aref data i) item)))))
+        (setf (aref data i) item)))
+     ;; ... though we still need to check that the new element can fit
+     ;; into the vector in safe code. -- CSR, 2002-07-05
+     `((declare (type ,element-type item))))))
 \f
 ;;;; utilities
 
@@ -647,15 +652,18 @@
 ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
 ;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
 ;;; at least once DYNAMIC-EXTENT works.
+;;;
+;;; 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)
            (args))
     (dolist (seq sequences)
-      (declare (ignore seq))
+      (declare (ignorable seq))
       (let ((n-seq (gensym))
            (n-length (gensym)))
        (args n-seq)
@@ -664,16 +672,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)))))
 \f
 ;;;; CONS accessor DERIVE-TYPE optimizers