[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 0ded37f 1/4: * Add initial negated non-negegated int
From: |
Andrea Corallo |
Subject: |
feature/native-comp 0ded37f 1/4: * Add initial negated non-negegated intersection support |
Date: |
Sat, 12 Dec 2020 18:58:42 -0500 (EST) |
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 ()