0.8.21.30:

        * Fix misc.548: weakening of (VALUES (MEMBER A B C) &OPTIONAL)
          produces (VALUES &OPTIONAL SYMBOL) with different number of
          required/optional parameters.
        * Fix DATA-VECTOR-SET-C/SIMPLE-BIT-VECTOR on Alpha-32: srl-sll
          does not clean up upper bit (found by regression tests).

diff --git a/NEWS b/NEWS
index a11e227..041ea38 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -36,6 +36,8 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21:
   * optimization: type testing for non-vector arrays should be faster.
   * fixed TRACE :ENCAPSULATE NIL, added support for :ENCAPSULATE NIL
     on x86-64
   * optimization: type testing for non-vector arrays should be faster.
   * fixed TRACE :ENCAPSULATE NIL, added support for :ENCAPSULATE NIL
     on x86-64

+  * bug fix: setting 31st element of a bit vector to zero did not work
+    on Alpha-32.

   * fixed some bugs related to Unicode integration:
     ** the restarts for recovering from input and output encoding
        errors only appear when there is in fact such an error to
   * fixed some bugs related to Unicode integration:
     ** the restarts for recovering from input and output encoding
        errors only appear when there is in fact such an error to

@@ -55,6 +57,8 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21:
     ** accessing double-floats stored on the stack now works on x86-64.
     ** debugger internals could sometimes create invalid lispobjs, 
        resulting in GC crashes.
     ** accessing double-floats stored on the stack now works on x86-64.
     ** debugger internals could sometimes create invalid lispobjs, 
        resulting in GC crashes.

+    ** MISC.548: type check weakening can convert required type into
+       optional.

 
 changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20:
   * incompatible change: thread support for non-NPTL systems has
 
 changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20:
   * incompatible change: thread support for non-NPTL systems has

diff --git a/src/compiler/alpha/array.lisp b/src/compiler/alpha/array.lisp
index 1c19682..d2c11d5 100644 (file)
--- a/src/compiler/alpha/array.lisp
+++ b/src/compiler/alpha/array.lisp
@@ -252,7 +252,10 @@
                                   (unless (and (sc-is value immediate)
                                                (= (tn-value value)
                                                  ,(1- (ash 1 bits))))
                                   (unless (and (sc-is value immediate)
                                                (= (tn-value value)
                                                  ,(1- (ash 1 bits))))

-                                    (cond ((= extra ,(1- elements-per-word))
+                                    (cond #+#.(cl:if
+                                             (cl:= sb-vm:n-word-bits sb-vm:n-machine-word-bits)
+                                             '(and) '(or))
+                                          ((= extra ,(1- elements-per-word))

                                            (inst sll old ,bits old)
                                            (inst srl old ,bits old))
                                           (t
                                            (inst sll old ,bits old)
                                            (inst srl old ,bits old))
                                           (t

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 3fd81d5..ddad0b6 100644 (file)
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -262,16 +262,18 @@
           ((lvar-single-value-p lvar)
            ;; exactly one value is consumed
            (principal-lvar-single-valuify lvar)
           ((lvar-single-value-p lvar)
            ;; exactly one value is consumed
            (principal-lvar-single-valuify lvar)

-           (let ((creq (car (args-type-required ctype))))
-             (multiple-value-setq (ctype atype)
-               (if creq
-                   (values creq (car (args-type-required atype)))
-                   (values (car (args-type-optional ctype))
-                           (car (args-type-optional atype)))))
-             (maybe-negate-check value
-                                 (list ctype) (list atype)
-                                 force-hairy
-                                 n-required)))
+           (flet ((get-type (type)
+                    (acond ((args-type-required type)
+                            (car it))
+                           ((args-type-optional type)
+                            (car it))
+                           (t (bug "type ~S is too hairy" type)))))
+             (multiple-value-bind (ctype atype)
+                 (values (get-type ctype) (get-type atype))
+               (maybe-negate-check value
+                                   (list ctype) (list atype)
+                                   force-hairy
+                                   n-required))))

           ((and (mv-combination-p dest)
                 (eq (mv-combination-kind dest) :local))
            ;; we know the number of consumed values
           ((and (mv-combination-p dest)
                 (eq (mv-combination-kind dest) :local))
            ;; we know the number of consumed values

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 514ec6f..4bc68b9 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1678,19 +1678,24 @@
 
 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
 ;;; constant index and value.
 
 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
 ;;; constant index and value.

-(let* ((n (* 2 sb-vm::n-word-bits))
-       (array1 (make-array n :element-type 'bit))
-       (array2 (make-array n :element-type 'bit)))
-  (dotimes (i n)
-    (dotimes (v 2)
-      (let ((f (compile nil `(lambda (a)
-                               (declare (type (simple-array bit (,n)) a))
-                               (setf (bit a ,i) ,v)))))
-        (fill array1 (- 1 v))
-        (fill array2 (- 1 v))
-        (funcall f array1)
-        (setf (aref array2 i) v)
-        (assert (equal array1 array2))))))
+(loop for n-bits = 1 then (* n-bits 2)
+      for type = `(unsigned-byte ,n-bits)
+      and v-max = (1- (ash 1 n-bits))
+      while (<= n-bits sb-vm:n-word-bits)
+      do
+      (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
+             (array1 (make-array n :element-type type))
+             (array2 (make-array n :element-type type)))
+        (dotimes (i n)
+          (dolist (v (list 0 v-max))
+            (let ((f (compile nil `(lambda (a)
+                                     (declare (type (simple-array ,type (,n)) a))
+                                     (setf (aref a ,i) ,v)))))
+              (fill array1 (- v-max v))
+              (fill array2 (- v-max v))
+              (funcall f array1)
+              (setf (aref array2 i) v)
+              (assert (every #'= array1 array2)))))))

 
 (let ((fn (compile nil '(lambda (x)
                          (declare (type bit x))
 
 (let ((fn (compile nil '(lambda (x)
                          (declare (type bit x))

@@ -1752,3 +1757,14 @@
      (or p1 (the (eql t) p2))))
    nil t)
   t))
      (or p1 (the (eql t) p2))))
    nil t)
   t))

+
+;;; MISC.548: type check weakening converts required type into
+;;; optional
+(assert (eql t
+  (funcall
+   (compile
+    nil
+    '(lambda (p1)
+      (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
+      (atom (the (member f assoc-if write-line t w) p1))))
+   t)))

diff --git a/version.lisp-expr b/version.lisp-expr
index e1dbf71..a795dd1 100644 (file)
--- 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".)
 ;;; 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".)

-"0.8.21.29"
+"0.8.21.30"