0.8.0.71:

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

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index b640f51..82a5fa7 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -44,13 +44,14 @@
             `(let ((,fn-sym ,fn)
                    (,map-result (list nil)))
                (do-anonymous ((,temp ,map-result) . ,(do-clauses))
-                             (,endtest (cdr ,map-result))
+                             (,endtest (truly-the list (cdr ,map-result)))
                  (rplacd ,temp (setq ,temp (list ,call)))))))
          ((nil)
           `(let ((,fn-sym ,fn)
                  (,n-first ,(first arglists)))
              (do-anonymous ,(do-clauses)
-                           (,endtest ,n-first) ,call))))))))
+                           (,endtest (truly-the list ,n-first))
+                            ,call))))))))
 
 (define-source-transform mapc (function list &rest more-lists)
   (mapfoo-transform function (cons list more-lists) nil t))
@@ -130,7 +131,7 @@
   (declare (type list seqs seq-names)
            (type symbol into))
   (collect ((bindings)
-           (declarations)
+           (declarations)
             (vector-lengths)
             (tests)
             (places))
@@ -145,7 +146,7 @@
            for seq-name in seq-names
            for type = (continuation-type seq)
            do (cond ((csubtypep type (specifier-type 'list))
-                     (let ((index (gensym "I")))
+                    (with-unique-names (index)
                        (bindings `(,index ,seq-name (cdr ,index)))
                        (declarations `(type list ,index))
                        (places `(car ,index))
@@ -721,33 +722,31 @@
                           (t &rest simple-string)
                           simple-string
                           :policy (< safety 3))
-  (collect ((lets)
-           (forms)
-           (all-lengths)
-           (args))
-    (dolist (seq sequences)
-      (declare (ignorable seq))
-      (let ((n-seq (gensym))
-           (n-length (gensym)))
-       (args n-seq)
-       (lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
-       (all-lengths n-length)
-       (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
-                              res start
-                              ,n-length))
-       (forms `(setq start (opaque-identity (+ start ,n-length))))))
-    `(lambda (rtype ,@(args))
-       (declare (ignore rtype))
-       ;; 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)))))
+  (loop for rest-seqs on sequences
+        for n-seq = (gensym "N-SEQ")
+        for n-length = (gensym "N-LENGTH")
+        for start = vector-data-bit-offset then next-start
+        for next-start = (gensym "NEXT-START")
+        collect n-seq into args
+        collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+        collect n-length into all-lengths
+        collect next-start into starts
+        collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+                                res ,start ,n-length)
+                into forms
+        collect `(setq ,next-start (+ ,start ,n-length)) into forms
+        finally
+        (return
+          `(lambda (rtype ,@args)
+             (declare (ignore rtype))
+             (let* (,@lets
+                      (res (make-string (truncate (the index (+ ,@all-lengths))
+                                                  sb!vm:n-byte-bits))))
+               (declare (type index ,@all-lengths))
+               (let (,@(mapcar (lambda (name) `(,name 0)) starts))
+                 (declare (type index ,@starts))
+                 ,@forms)
+               res)))))
 \f
 ;;;; CONS accessor DERIVE-TYPE optimizers
 
@@ -866,13 +865,7 @@
                                                            end-arg
                                                            element
                                                            done-p-expr)
-  (let ((offset (gensym "OFFSET"))
-       (block (gensym "BLOCK"))
-       (index (gensym "INDEX"))
-       (n-sequence (gensym "N-SEQUENCE-"))
-       (sequence (gensym "SEQUENCE"))
-       (n-end (gensym "N-END-"))
-       (end (gensym "END-")))
+  (with-unique-names (offset block index n-sequence sequence n-end end)
     `(let ((,n-sequence ,sequence-arg)
           (,n-end ,end-arg))
        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
@@ -901,7 +894,7 @@
 
 (def!macro %find-position-vector-macro (item sequence
                                             from-end start end key test)
-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end
@@ -915,7 +908,7 @@
 
 (def!macro %find-position-if-vector-macro (predicate sequence
                                                     from-end start end key)
-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end
@@ -926,7 +919,7 @@
 
 (def!macro %find-position-if-not-vector-macro (predicate sequence
                                                         from-end start end key)
-  (let ((element (gensym "ELEMENT")))
+  (with-unique-names (element)
     (%find-position-or-find-position-if-vector-expansion
      sequence
      from-end