feature/native-comp 2eb41ec 7/8: More improvements to `comp-cstr-union-1' for mixed positive/negative cases

[Andrea Corallo]

branch: feature/native-comp
commit 2eb41ec137839d06a856e1f910dfa5d2fa97e451
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>

    More improvements to `comp-cstr-union-1' for mixed positive/negative cases
    
        * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1): Better handle
        mixed positive/negated cases.
        * test/lisp/emacs-lisp/comp-cstr-tests.el
        (comp-cstr-typespec-tests-alist): Add a number of tests.
---
 lisp/emacs-lisp/comp-cstr.el            | 88 ++++++++++++++++++++-------------
 test/lisp/emacs-lisp/comp-cstr-tests.el | 15 +++++-
 2 files changed, 67 insertions(+), 36 deletions(-)

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 5a45294..c0e6a57 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -340,22 +340,27 @@ DST is returned."
      else
      collect cstr into positives
      finally
-     (let* ((pos (apply #'comp-cstr-union-homogeneous (make-comp-cstr) 
positives))
-            (neg (apply #'comp-cstr-union-homogeneous (make-comp-cstr) 
negatives)))
+     (let* ((pos (apply #'comp-cstr-union-homogeneous
+                        (make-comp-cstr) positives))
+            ;; We use neg as result as *most* of times this will be
+            ;; negated.
+            (neg (apply #'comp-cstr-union-homogeneous
+                        (make-comp-cstr :neg t) negatives)))
 
        ;; Type propagation.
        (when (and (typeset pos)
-                  ;; When some pos type is not a subtype of any neg ones.
+                  ;; When every pos type is not a subtype of some neg ones.
                   (cl-every (lambda (x)
                               (cl-some (lambda (y)
-                                         (not (comp-subtype-p x y)))
+                                         (not (and (not (eq x y))
+                                                   (comp-subtype-p x y))))
                                        (typeset neg)))
                             (typeset pos)))
-         ;; This is a conservative choice, ATM we can't represent such a
-         ;; disjoint set of types unless we decide to add a new slot
-         ;; into `comp-cstr' list them all.  This probably wouldn't
-         ;; work for the future when we'll support also non-builtin
-         ;; types.
+         ;; This is a conservative choice, ATM we can't represent such
+         ;; a disjoint set of types unless we decide to add a new slot
+         ;; into `comp-cstr' or adopt something like
+         ;; `intersection-type' `union-type' in SBCL.  Keep it
+         ;; "simple" for now.
          (setf (typeset dst) '(t)
                (valset dst) ()
                (range dst) ()
@@ -363,41 +368,56 @@ DST is returned."
          (cl-return-from comp-cstr-union-1 dst))
 
        ;; Value propagation.
-       (setf (valset neg)
-             (cl-nset-difference (valset neg) (valset pos)))
+       (cond
+        ((and (valset pos) (valset neg)
+              (equal (cl-union (valset pos) (valset neg)) (valset pos)))
+         ;; Pos is a superset of neg.
+         (setf (typeset dst) '(t)
+               (valset dst) ()
+               (range dst) ()
+               (neg dst) nil)
+         (cl-return-from comp-cstr-union-1 dst))
+        (t
+         ;; pos is a subset or eq to neg
+         (setf (valset neg)
+               (cl-nset-difference (valset neg) (valset pos)))))
 
        ;; Range propagation
-       (when (and range
-                  (or (range pos)
-                      (range neg))
-                  (cl-notany (lambda (x)
-                               (comp-subtype-p 'integer x))
-                             (typeset pos)))
-         (if (or (valset neg)
-                 (typeset neg))
-             (setf (range neg)
-                   (comp-range-union (comp-range-negation (range pos))
-                                     (range neg)))
-           ;; When possibile do not return a negated cstr.
-           (setf (typeset dst) ()
-                 (valset dst) ()
-                 (range dst) (comp-range-union
-                                        (comp-range-negation (range neg))
-                                        (range pos))
-                 (neg dst) nil)
-           (cl-return-from comp-cstr-union-1 dst)))
+       (if (and range
+                (or (range pos)
+                    (range neg))
+                (cl-notany (lambda (x)
+                             (comp-subtype-p 'integer x))
+                           (typeset pos)))
+           (if (or (valset neg)
+                   (typeset neg))
+               (setf (range neg)
+                     (if (memq 'integer (typeset neg))
+                         (comp-range-negation (range pos))
+                       (comp-range-negation
+                        (comp-range-union (range pos)
+                                          (comp-range-negation (range neg))))))
+             ;; When possibile do not return a negated cstr.
+             (setf (typeset dst) (typeset pos)
+                   (valset dst) (valset pos)
+                   (range dst) (comp-range-union
+                                (comp-range-negation (range neg))
+                                (range pos))
+                   (neg dst) nil)
+             (cl-return-from comp-cstr-union-1 dst))
+         (setf (range neg) ()))
 
        (if (and (null (typeset neg))
                 (null (valset neg))
                 (null (range neg)))
-           (setf (typeset dst) '(t)
-                 (valset dst) ()
-                 (range dst) ()
+           (setf (typeset dst) (typeset pos)
+                 (valset dst) (valset pos)
+                 (range dst) (range pos)
                  (neg dst) nil)
          (setf (typeset dst) (typeset neg)
                (valset dst) (valset neg)
                (range dst) (range neg)
-               (neg dst) t))))
+               (neg dst) (neg neg)))))
     dst))
 
 
diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el 
b/test/lisp/emacs-lisp/comp-cstr-tests.el
index 0b10b7f..bc772fc 100644
--- a/test/lisp/emacs-lisp/comp-cstr-tests.el
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -83,11 +83,22 @@
     ((or (member foo bar) (not (member foo))) . t)
     ;; Intentionally conservative, see `comp-cstr-union'.
     ((or symbol (not sequence)) . t)
+    ((or symbol (not symbol)) . t)
+    ;; Conservative.
+    ((or symbol (not sequence)) . t)
     ((or vector (not sequence)) . (not sequence))
     ((or (integer 1 10) (not (integer * 5))) . (integer 1 *))
-    ((or symbol (integer 1 10) (not (integer * 5))) . (integer 1 *))
+    ((or symbol (integer 1 10) (not (integer * 5))) . (or symbol (integer 1 
*)))
+    ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol 
(integer * 0))))
     ((or symbol (not (member foo))) . (not (member foo)))
-    ((or (not symbol) (not (member foo))) . (not symbol)))
+    ((or (not symbol) (not (member foo))) . (not symbol))
+    ;; Conservative.
+    ((or (not (member foo)) string) . (not (member foo)))
+    ;; Conservative.
+    ((or (member foo) (not string)) . (not string))
+    ((or (not (integer 1 2)) integer) . integer)
+    ((or (not (integer 1 2)) (not integer)) . (not integer))
+    ((or (integer 1 2) (not integer)) . (not (or integer (integer * 0) 
(integer 3 *)))))
   "Alist type specifier -> expected type specifier.")
 
 (defmacro comp-cstr-synthesize-tests ()