X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=4ff8a4dcd8bc531953dd22b4fddac3fcdf4bfb8a;hb=71d9292d4c2627c4d76b763443be759f95423c2c;hp=3c25cc46ea8ef0a4eca77d954adf01c5c991c206;hpb=cfc3b695e6452907fef6492710777511ac4af979;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3c25cc4..4ff8a4d 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -317,6 +317,8 @@
            function-name key-functions variant)))
 
 (defun transform-list-item-seek (name item list key test test-not node)
+  (when (and test test-not)
+    (abort-ir1-transform "Both ~S and ~S supplied to ~S." :test :test-not name))
   ;; If TEST is EQL, drop it.
   (when (and test (lvar-fun-is test '(eql)))
     (setf test nil))
@@ -535,8 +537,14 @@
                   (kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
                               ((member element-type '(character base-char)) :char)
                               ((eq element-type 'single-float) :single-float)
+                              #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                               ((eq element-type 'double-float) :double-float)
-                              (t :bits)))
+                              #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                              ((equal element-type '(complex single-float))
+                               :complex-single-float)
+                              (t
+                               (aver (integer-type-p element-ctype))
+                               :bits)))
                   ;; BASH-VALUE is a word that we can repeatedly smash
                   ;; on the array: for less-than-word sized elements it
                   ;; contains multiple copies of the fill item.
@@ -556,37 +564,51 @@
                                          tmp)
                                         (:single-float
                                          (single-float-bits tmp))
+                                        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                                         (:double-float
                                          (logior (ash (double-float-high-bits tmp) 32)
-                                                 (double-float-low-bits tmp))))))
+                                                 (double-float-low-bits tmp)))
+                                        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                                        (:complex-single-float
+                                         (logior (ash (single-float-bits (imagpart tmp)) 32)
+                                                 (ldb (byte 32 0)
+                                                      (single-float-bits (realpart tmp))))))))
                                 (res bits))
                            (loop for i of-type sb!vm:word from n-bits by n-bits
                                  until (= i sb!vm:n-word-bits)
                                  do (setf res (ldb (byte sb!vm:n-word-bits 0)
                                                    (logior res (ash bits i)))))
                            res))
-                       `(let* ((bits (ldb (byte ,n-bits 0)
-                                          ,(ecase kind
-                                                  (:tagged
-                                                   `(ash item ,sb!vm:n-fixnum-tag-bits))
-                                                  (:char
-                                                   `(char-code item))
-                                                  (:bits
-                                                   `item)
-                                                  (:single-float
-                                                   `(single-float-bits item))
-                                                  (:double-float
-                                                   `(logior (ash (double-float-high-bits item) 32)
-                                                            (double-float-low-bits item))))))
-                               (res bits))
-                          (declare (type sb!vm:word res))
-                          ,@(unless (= sb!vm:n-word-bits n-bits)
-                                    `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits
-                                            until (= i sb!vm:n-word-bits)
-                                            do (setf res
-                                                     (ldb (byte ,sb!vm:n-word-bits 0)
-                                                          (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
-                          res))))
+                       (progn
+                         (delay-ir1-transform node :constraint)
+                        `(let* ((bits (ldb (byte ,n-bits 0)
+                                           ,(ecase kind
+                                                   (:tagged
+                                                    `(ash item ,sb!vm:n-fixnum-tag-bits))
+                                                   (:char
+                                                    `(char-code item))
+                                                   (:bits
+                                                    `item)
+                                                   (:single-float
+                                                    `(single-float-bits item))
+                                                   #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                                                   (:double-float
+                                                    `(logior (ash (double-float-high-bits item) 32)
+                                                             (double-float-low-bits item)))
+                                                   #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                                                   (:complex-single-float
+                                                    `(logior (ash (single-float-bits (imagpart item)) 32)
+                                                             (ldb (byte 32 0)
+                                                                  (single-float-bits (realpart item))))))))
+                                (res bits))
+                           (declare (type sb!vm:word res))
+                           ,@(unless (= sb!vm:n-word-bits n-bits)
+                                     `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits
+                                             until (= i sb!vm:n-word-bits)
+                                             do (setf res
+                                                      (ldb (byte ,sb!vm:n-word-bits 0)
+                                                           (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
+                           res)))))
              (values
               `(with-array-data ((data seq)
                                  (start start)