[prev in list] [next in list] [prev in thread] [next in thread] 

List:       sbcl-commits
Subject:    [Sbcl-commits] master: Stronger canonization of RATIONAL bounds
From:       Christophe Rhodes via Sbcl-commits <sbcl-commits () lists ! sourceforge ! net>
Date:       2022-11-29 22:07:06
Message-ID: 1669759626.650328.27784 () sfp-scm-5 ! v30 ! lw ! sourceforge ! com
[Download RAW message or body]

The branch "master" has been updated in SBCL:
       via  caaa008fd92f0948f255c755fe65b54bb511cb67 (commit)
      from  006d3a9107e4e673dafaa13ca746072b728c112a (commit)

- Log -----------------------------------------------------------------
commit caaa008fd92f0948f255c755fe65b54bb511cb67
Author: Christophe Rhodes <csr21@cantab.net>
Date:   Sun Nov 27 09:00:20 2022 +0000

    Stronger canonization of RATIONAL bounds
    
    If the RATIONAL type has closed integer bounds and is intersected with
    a subtype of (NOT INTEGER), make the bounds open.
    
    Add some tests, and make sure to execute some existing tests.
    
    Fixes lp#1998008
---
 NEWS                 |  2 ++
 src/code/type.lisp   | 16 ++++++++++++++++
 tests/type.pure.lisp | 25 +++++++++++++++++++++++--
 3 files changed, 41 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index 895e43f1c..5d4e38783 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@
 changes relative to sbcl-2.2.11:
   * enhancement: support for SLOT-VALUE and friends has been extended to
     structure and condition instances.
+  * bug fix: type intersections of RATIONAL ranges with (NOT INTEGER) are
+    computed more consistently.  (lp#1998008)
 
 changes in sbcl-2.2.11 relative to sbcl-2.2.10:
   * platform support:
diff --git a/src/code/type.lisp b/src/code/type.lisp
index 8d8448dbd..cba028fea 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -2425,6 +2425,17 @@ expansion happened."
                        :specialized-element-type (array-type-specialized-element-type type1)
                        :element-type (array-type-element-type type1)))))
 
+(defun remove-integer-bounds (type)
+  (let ((low (numeric-type-low type))
+        (high (numeric-type-high type)))
+    (make-numeric-type
+     :class (numeric-type-class type)
+     :format (numeric-type-format type)
+     :complexp (numeric-type-complexp type)
+     :low (if (integerp low) (list low) low)
+     :high (if (integerp high) (list high) high)
+     :enumerable (numeric-type-enumerable type))))
+
 (define-type-method (negation :complex-intersection2) (type1 type2)
   (cond
     ((csubtypep type1 (negation-type-type type2)) *empty-type*)
@@ -2432,6 +2443,11 @@ expansion happened."
      type1)
     ((and (array-type-p type1) (array-type-p (negation-type-type type2)))
      (maybe-complex-array-refinement type1 type2))
+    ((and (numeric-type-p type1)
+          (eql (numeric-type-class type1) 'rational)
+          (csubtypep (sb-kernel:specifier-type 'integer) (negation-type-type type2))
+          (or (integerp (numeric-type-low type1)) (integerp (numeric-type-high type1))))
+     (type-intersection (remove-integer-bounds type1) type2))
     (t nil)))
 
 (define-type-method (negation :simple-union2) (type1 type2)
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 588ff7fa9..ae20cae58 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -775,6 +775,10 @@
   (let ((type '(or (integer * -1) (rational -1/2 1/2) (integer 1) (not integer))))
     (assert-tri-eq t t (subtypep t type))))
 
+(with-test (:name (:rational-union :wider-equivalent-to-t))
+  (let ((type '(or (integer * -2) (rational -3/2 3/2) (integer 2) (not integer))))
+    (assert-tri-eq t t (subtypep t type))))
+
 (with-test (:name (:rational-union :no-integers-in-rational))
   (let ((type '(or (integer 1 1) (rational 1/2 1/2))))
     (assert-tri-eq t t (subtypep type 'rational))
@@ -797,7 +801,8 @@
                  (t2 '(or (not (cons t (real -1 1)))
                        (not (cons sequence (eql 2))))))
              (assert-tri-eq t t (subtypep t1 t2))
-             (assert-tri-eq t t (subtypep `(not ,t2) `(not ,t1))))))))
+             (assert-tri-eq t t (subtypep `(not ,t2) `(not ,t1))))))
+    (bug039)))
 
 (with-test (:name (:rational-union :lp1912863 :bug041))
   (flet ((bug041 ()
@@ -806,7 +811,8 @@
                  (t3 '(cons simple-array t)))
              (assert-tri-eq t t (subtypep t1 t2))
              (assert-tri-eq t t (subtypep `(not (or ,t2 ,t3)) `(not ,t1)))
-             (assert-tri-eq t t (subtypep `(and (not ,t2) (not ,t3)) `(not ,t1))))))))
+             (assert-tri-eq t t (subtypep `(and (not ,t2) (not ,t3)) `(not ,t1))))))
+    (bug041)))
 
 (with-test (:name (:lp1916040 :answer))
   (let* ((t1 '(cons sequence short-float))
@@ -833,3 +839,18 @@
              (checked-compile
               `(lambda (a) (array-rank (the (not (array t)) a))))))
            `(values array-rank &optional))))
+
+(with-test (:name (:rational-intersection :lp1998008))
+  (flet ((bug101 ()
+           (let ((t1 '(or (not (real 1 3)) (eql 2))))
+             (assert-tri-eq t t (subtypep `(not (not ,t1)) t1))
+             (assert-tri-eq t t (subtypep t1 `(not (not ,t1)))))))
+    (bug101)))
+
+(with-test (:name (:rational-intersection :integer-bounds))
+  (let ((t1 '(and (not integer) (rational 3 5)))
+        (t2 '(and (not integer) (rational (3) (5)))))
+    (assert-tri-eq t t (subtypep t1 t2))
+    (assert-tri-eq t t (subtypep t2 t1))
+    (assert-tri-eq t t (subtypep `(not ,t1) `(not ,t2)))
+    (assert-tri-eq t t (subtypep `(not ,t2) `(not ,t1)))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL


_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]