Steel Bank Common Lisp

The branch "master" has been updated in SBCL:
       via  a27847030e4ba8f7298ad3d302b0c5b05a8b8542 (commit)
      from  ec8285d7300b102aa2644ca9877088f0b224405a (commit)

- Log -----------------------------------------------------------------
commit a27847030e4ba8f7298ad3d302b0c5b05a8b8542
Author: Paul Khuong <pvk@...>
Date:   Sun Oct 30 02:32:41 2011 -0400

    Eliminate an infinite recursion in TYPE-UNION of INTERSECTION types
    
    Reported by Eric Marsden on sbcl-devel.
    
    Fixes lp#883498.
---
 src/code/late-type.lisp |   11 ++++++-----
 tests/type.pure.lisp    |   16 ++++++++++++++++
 2 files changed, 22 insertions(+), 5 deletions(-)

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 2ae43c5..13e3368 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -2903,11 +2903,12 @@ used for a COMPLEX component.~:@>"
                           :high (if (null (numeric-type-high type1))
                                     nil
                                     (list (1+ (numeric-type-high type1)))))))
-         (type-union type1
-                     (apply #'type-intersection
-                            (remove (specifier-type '(not integer))
-                                    (intersection-type-types type2)
-                                    :test #'type=))))
+         (let* ((intersected (intersection-type-types type2))
+                (remaining   (remove (specifier-type '(not integer))
+                                     intersected
+                                     :test #'type=)))
+           (and (not (equal intersected remaining))
+                (type-union type1 (apply #'type-intersection remaining)))))
         (t
          (let ((accumulator *universal-type*))
            (do ((t2s (intersection-type-types type2) (cdr t2s)))
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 6eea7d3..919d705 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -424,3 +424,19 @@ ACTUAL ~D DERIVED ~D~%"
 (with-test (:name :bug-485972)
   (assert (equal (multiple-value-list (subtypep 'symbol 'keyword)) '(nil t)))
   (assert (equal (multiple-value-list (subtypep 'keyword 'symbol)) '(t t))))
+
+;; WARNING: this test case would fail by recursing into the stack's guard page.
+(with-test (:name :bug-883498)
+  (sb-kernel:specifier-type
+   `(or (INTEGER -2 -2)
+        (AND (SATISFIES FOO) (RATIONAL -3/2 -3/2)))))
+
+;; The infinite recursion mentioned in the previous test was caused by an
+;; attempt to get the following right.
+(with-test (:name :quirky-integer-rational-union)
+  (assert (subtypep `(or (integer * -1)
+                         (and (rational * -1/2) (not integer)))
+                    `(rational * -1/2)))
+  (assert (subtypep `(rational * -1/2)
+                    `(or (integer * -1)
+                         (and (rational * -1/2) (not integer))))))

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


hooks/post-receive
-- 
SBCL