From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Tue, 15 Jan 2008 23:24:04 +0000 (+0000)
Subject: 1.0.13.43: DIVIDE-BY-ZERO from BIGNUM-TRUNCATE
X-Git-Url: https://repo.or.cz/w/sbcl/simd.git/commitdiff_plain/2f10546bc6638ee44bd9ba317fab1dff81be1bb6

1.0.13.43: DIVIDE-BY-ZERO from BIGNUM-TRUNCATE

 * Pre 1.0.6.19 version ended up calling %FLOOR, and all was well. Now
   we need to check explicitly for zero. Reported by Michael Weber.
---

diff --git a/NEWS b/NEWS
index 4c7081bad..25b0f557f 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,9 @@ changes in sbcl-1.0.14 relative to sbcl-1.0.13:
   * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits
     (see documentation for details.)
   * revived support for OpenBSD (contributed by Josh Elsasser)
+  * bug fix: (TRUNCATE X 0) when X is a bignum now correctly signals
+    DIVISION-BY-ZERO. Similarly for MOD and REM (which suffered due to
+    the bug in TRUNCATE.) (reported by Michael Weber)
   * bug fix: SB-SPROF:REPORT no longer signals an error if there are
     no samples. (reported by Andy Hefner)
   * bug fix: functions compiled using (COMPILE NIL '(LAMBDA ...))
diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp
index 7f54a05fa..5ee6b3ada 100644
--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -1586,24 +1586,27 @@
              (declare (type bignum-element-type y))
              (if (not (logtest y (1- y)))
                  ;; Y is a power of two.
-                 (if (= y 1)
-                     ;; SHIFT-RIGHT-UNALIGNED won't do the right thing
-                     ;; with a shift count of 0, so special case this.
-                     ;; We could probably get away with (VALUES X 0)
-                     ;; here, but it's not clear that some of the
-                     ;; normalization logic further down would avoid
-                     ;; mutilating X.  Just go ahead and cons, consing's
-                     ;; cheap.
-                     (values (copy-bignum x len-x) 0)
-                     (let ((n-bits (1- (integer-length y))))
-                       (values
-                        (shift-right-unaligned x 0 n-bits len-x
-                                               ((= j res-len-1)
-                                                (setf (%bignum-ref res j)
-                                                      (%ashr (%bignum-ref x i) n-bits))
-                                                res)
-                                               res)
-                        (logand (%bignum-ref x 0) (1- y)))))
+                 ;; SHIFT-RIGHT-UNALIGNED won't do the right thing
+                 ;; with a shift count of 0 or -1, so special case this.
+                 (cond ((= y 0)
+                        (error 'division-by-zero))
+                       ((= y 1)
+                        ;; We could probably get away with (VALUES X 0)
+                        ;; here, but it's not clear that some of the
+                        ;; normalization logic further down would avoid
+                        ;; mutilating X.  Just go ahead and cons, consing's
+                        ;; cheap.
+                        (values (copy-bignum x len-x) 0))
+                       (t
+                        (let ((n-bits (1- (integer-length y))))
+                          (values
+                           (shift-right-unaligned x 0 n-bits len-x
+                                                  ((= j res-len-1)
+                                                   (setf (%bignum-ref res j)
+                                                         (%ashr (%bignum-ref x i) n-bits))
+                                                   res)
+                                                  res)
+                           (logand (%bignum-ref x 0) (1- y))))))
                  (do ((i (1- len-x) (1- i))
                       (q (%allocate-bignum len-x))
                       (r 0))
diff --git a/version.lisp-expr b/version.lisp-expr
index 68d14b492..21bbaac68 100644
--- 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.13.42"
+"1.0.13.43"