1.0.29.1: fix FILL

* Imaginary parts were messed up on 64 bit platforms when filling arrays of (COMPLEX SINGLE-FLOAT). Thanks to Paul Khuong. * Also delay the transform of FILL till constraint propagation has run, to get the constant argument form MAKE-ARRAY in properly. * ...and eradicate remaining references to the SUPPORT file.
dmitryvk · Jun 4, 2009 · fd79e33 · fd79e33
1 parent e834360
commit fd79e33
Show file tree

Hide file tree

Showing 8 changed files with 56 additions and 34 deletions.
diff --git a/INSTALL b/INSTALL
@@ -259,5 +259,9 @@ INSTALLING SBCL
     by e.g. testing during the monthly freeze periods, and most
     importantly by reporting any problems.
 
-    If you need support beyond what is available on the mailing lists,
-    see "Consultants" in the "SUPPORT" file.
+    For further support, see Getting Support and Reporting Bugs
+    in the manual, or
+
+      http://www.sbcl.org/manual/Getting-Support-and-Reporting-Bugs.html
+
+    if you do not have the manual for some reason.
diff --git a/NEWS b/NEWS
@@ -1,4 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+  * bug fix: on 64 bit platforms FILL worked incorrectly on arrays with
+    upgraded element type (COMPLEX SINGLE-FLOAT), regression from 1.0.28.55.
+    (thanks to Paul Khuong)
+
+changes in sbcl-1.0.29 relative to 1.0.28:
   * IMPORTANT: bug database has moved from the BUGS file to Launchpad
         https://bugs.launchpad.net/sbcl
     Bugs can be reported directly there, or by sending email to

diff --git a/binary-distribution.sh b/binary-distribution.sh
@@ -12,7 +12,7 @@ set -e
 b=${1:?"missing base directory name argument"}
 tar -cf $b-binary.tar \
     $b/output/sbcl.core $b/src/runtime/sbcl \
-    $b/BUGS $b/COPYING $b/CREDITS $b/INSTALL $b/NEWS $b/README $b/SUPPORT \
+    $b/BUGS $b/COPYING $b/CREDITS $b/INSTALL $b/NEWS $b/README \
     $b/install.sh $b/find-gnumake.sh $b/sbcl-pwd.sh $b/run-sbcl.sh \
     $b/doc/sbcl.1 \
     $b/pubring.pgp \

diff --git a/html-distribution.sh b/html-distribution.sh
@@ -8,5 +8,5 @@ set -e
 b=${1:?missing base directory name argument}
 tar cf $b-documentation-html.tar \
     `find $b -name '*.htm*'` \
-    $b/COPYING $b/CREDITS $b/README $b/SUPPORT \
+    $b/COPYING $b/CREDITS $b/README \
     $b/pubring.pgp
diff --git a/install.sh b/install.sh
@@ -138,7 +138,7 @@ do
       && echo " html $BUILD_ROOT$DOC_DIR/html/`basename $html`/index.html"
 done
 
-for f in BUGS SUPPORT CREDITS COPYING NEWS
+for f in BUGS CREDITS COPYING NEWS
 do
   cp $f "$BUILD_ROOT$DOC_DIR"/
 done
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
@@ -569,40 +569,44 @@
                                         #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                                         (:complex-single-float
                                          (logior (ash (single-float-bits (imagpart tmp)) 32)
-                                                 (single-float-bits (realpart tmp)))))))
+                                                 (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))
-                                                  #!+#.(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)
-                                                            (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))))
+                       (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)

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
@@ -1084,6 +1084,15 @@
   (assert (equal "GOOD!"
                  (progv '(*hairy-progv-var*) (list (eval "GOOD!"))
                     *hairy-progv-var*))))
+
+(with-test (:name :fill-complex-single-float)
+  (assert (eql #c(-1.0 2.0)
+               (aref (funcall
+                      (lambda ()
+                        (make-array 2
+                                    :element-type '(complex single-float)
+                                    :initial-element #c(-1.0 2.0))))
+                     0))))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

diff --git a/version.lisp-expr b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.29"
+"1.0.29.1"