Eliminate an infinite recursion in TYPE-UNION of INTERSECTION types

Reported by Eric Marsden on sbcl-devel.

Fixes lp#883498.

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 2ae43c5..13e3368 100644 (file)
--- 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 (file)
--- 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))))))