feature/native-comp 0ded37f 1/4: * Add initial negated non-negegated intersection support

[Andrea Corallo]

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

    * Add initial negated non-negegated intersection support
    
        * lisp/emacs-lisp/comp-cstr.el (comp-range-intersection): Cosmetic.
        (comp-cstr-intersection-homogeneous): Rename from
        `comp-cstr-intersection'.
        (comp-cstr-intersection): New function.
---
 lisp/emacs-lisp/comp-cstr.el            | 114 ++++++++++++++++++++++++++------
 test/lisp/emacs-lisp/comp-cstr-tests.el |  24 ++++++-
 2 files changed, 116 insertions(+), 22 deletions(-)

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 6991c93..ba93ee9 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -302,11 +302,11 @@ Return them as multiple value."
    with nest = 0
    with low = nil
    with res = ()
+   for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
    initially (when (cl-some #'null ranges)
                ;; Intersecting with a null range always results in a
                ;; null range.
                (cl-return '()))
-   for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
    if (eq x 'l)
    do
    (cl-incf nest)
@@ -502,27 +502,9 @@ DST is returned."
           (puthash srcs (comp-cstr-copy res) mem-h)
          res)))))
 
-
-;;; Entry points.
-
-(defun comp-cstr-union-no-range (dst &rest srcs)
-  "Combine SRCS by union set operation setting the result in DST.
-Do not propagate the range component.
-DST is returned."
-  (apply #'comp-cstr-union-1 nil dst srcs))
-
-(defun comp-cstr-union (dst &rest srcs)
-  "Combine SRCS by union set operation setting the result in DST.
-DST is returned."
-  (apply #'comp-cstr-union-1 t dst srcs))
-
-(defun comp-cstr-union-make (&rest srcs)
-  "Combine SRCS by union set operation and return a new constraint."
-  (apply #'comp-cstr-union (make-comp-cstr) srcs))
-
-;; TODO memoize
-(cl-defun comp-cstr-intersection (dst &rest srcs)
+(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs)
   "Combine SRCS by intersection set operation setting the result in DST.
+All SRCS constraints must be homogeneously negated or non-negated.
 DST is returned."
 
   ;; Value propagation.
@@ -569,6 +551,96 @@ DST is returned."
                  (mapcar #'comp-cstr-typeset srcs))))
   dst)
 
+
+;;; Entry points.
+
+(defun comp-cstr-union-no-range (dst &rest srcs)
+  "Combine SRCS by union set operation setting the result in DST.
+Do not propagate the range component.
+DST is returned."
+  (apply #'comp-cstr-union-1 nil dst srcs))
+
+(defun comp-cstr-union (dst &rest srcs)
+  "Combine SRCS by union set operation setting the result in DST.
+DST is returned."
+  (apply #'comp-cstr-union-1 t dst srcs))
+
+(defun comp-cstr-union-make (&rest srcs)
+  "Combine SRCS by union set operation and return a new constraint."
+  (apply #'comp-cstr-union (make-comp-cstr) srcs))
+
+(cl-defun comp-cstr-intersection (dst &rest srcs)
+  "Combine SRCS by intersection set operation setting the result in DST.
+DST is returned."
+  (with-comp-cstr-accessors
+    (cl-flet ((return-empty ()
+                (setf (typeset dst) ()
+                      (valset dst) ()
+                      (range dst) ()
+                      (neg dst) nil)
+                (cl-return-from comp-cstr-intersection dst)))
+      (when-let ((res (comp-cstrs-homogeneous srcs)))
+        (apply #'comp-cstr-intersection-homogeneous dst srcs)
+        (setf (neg dst) (eq res 'neg))
+        (cl-return-from comp-cstr-intersection dst))
+
+      ;; Some are negated and some are not
+      (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
+        (let* ((pos (apply #'comp-cstr-intersection-homogeneous
+                           (make-comp-cstr) positives))
+               (neg (apply #'comp-cstr-intersection-homogeneous
+                           (make-comp-cstr :neg t) negatives)))
+
+          ;; In case pos is not relevant return directly the content
+          ;; of neg.
+          (when (equal (typeset pos) '(t))
+            (setf (typeset dst) (typeset neg)
+                  (valset dst) (valset neg)
+                  (range dst) (range neg)
+                  (neg dst) t)
+            (cl-return-from comp-cstr-intersection dst))
+
+          (when (cl-some
+                 (lambda (ty)
+                   (memq ty (typeset neg)))
+                 (typeset pos))
+            (return-empty))
+
+          ;; Some negated types are subtypes of some non-negated one.
+          ;; Transform the corresponding set of types from neg to pos.
+          (cl-loop
+           for neg-type in (typeset neg)
+           do (cl-loop
+               for pos-type in (copy-sequence (typeset pos))
+               when (and (not (eq neg-type pos-type))
+                         (comp-subtype-p neg-type pos-type))
+               do (cl-loop
+                   with found
+                   for (type . _) in (comp-supertypes neg-type)
+                   when found
+                     collect type into res
+                   when (eq type pos-type)
+                     do (setf (typeset pos) (cl-union (typeset pos) res))
+                        ;; (delq neg-type (typeset neg))
+                        (cl-return)
+                   when (eq type neg-type)
+                     do (setf found t))))
+
+          (setf (range pos)
+                (if (memq 'integer (typeset pos))
+                    (progn
+                      (setf (typeset pos) (delq 'integer (typeset pos)))
+                      (comp-range-negation (range neg)))
+                  (comp-range-intersection (range pos)
+                                           (comp-range-negation (range neg)))))
+
+          ;; Return a non negated form.
+          (setf (typeset dst) (typeset pos)
+                (valset dst) (valset pos)
+                (range dst) (range pos)
+                (neg dst) nil)))
+      dst)))
+
 (defun comp-cstr-intersection-make (&rest srcs)
   "Combine SRCS by intersection set operation and return a new constraint."
   (apply #'comp-cstr-intersection (make-comp-cstr) srcs))
diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el 
b/test/lisp/emacs-lisp/comp-cstr-tests.el
index 392669f..bd141e1 100644
--- a/test/lisp/emacs-lisp/comp-cstr-tests.el
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -155,7 +155,29 @@
     ;; 57
     ((or atom (not (integer 1 2))) . t)
     ;; 58
-    ((or atom (not (member foo))) . t))
+    ((or atom (not (member foo))) . t)
+    ;; 59
+    ((and symbol (not cons)) . symbol)
+    ;; 60
+    ((and symbol (not symbol)) . nil)
+    ;; 61
+    ((and atom (not symbol)) . atom)
+    ;; 62
+    ((and atom (not string)) . (or array sequence atom))
+    ;; 63 Conservative
+    ((and symbol (not (member foo))) . symbol)
+    ;; 64 Conservative
+    ((and symbol (not (member 3))) . symbol)
+    ;; 65
+    ((and (not (member foo)) (integer 1 10)) . (integer 1 10))
+    ;; 66
+    ((and (member foo) (not (integer 1 10))) . (member foo))
+    ;; 67
+    ((and t (not (member foo))) . (not (member foo)))
+    ;; 68
+    ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *)))
+    ;; 69
+    ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 
20))))
   "Alist type specifier -> expected type specifier.")
 
 (defmacro comp-cstr-synthesize-tests ()