[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 2eb41ec 7/8: More improvements to `comp-cstr-union-1
From: |
Andrea Corallo |
Subject: |
feature/native-comp 2eb41ec 7/8: More improvements to `comp-cstr-union-1' for mixed positive/negative cases |
Date: |
Sat, 5 Dec 2020 17:07:34 -0500 (EST) |
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 ()
- feature/native-comp updated (eb8d155 -> 09ec39e), Andrea Corallo, 2020/12/05
- feature/native-comp 9b85ae6 1/8: Initial constraint negation support, Andrea Corallo, 2020/12/05
- feature/native-comp 7c1d90a 3/8: Initial support for union of negated constraints, Andrea Corallo, 2020/12/05
- feature/native-comp 726e40f 5/8: Fix union of homogeneously negated input constraints, Andrea Corallo, 2020/12/05
- feature/native-comp f923de6 6/8: * Fix `comp-cstr-to-type-spec', Andrea Corallo, 2020/12/05
- feature/native-comp 09ec39e 8/8: * Memoize `comp-cstr-union-1', Andrea Corallo, 2020/12/05
- feature/native-comp 1fb249f 2/8: * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-no-range): Cosmetic., Andrea Corallo, 2020/12/05
- feature/native-comp cbbdb4e 4/8: * Add `with-comp-cstr-accessors' macro., Andrea Corallo, 2020/12/05
- feature/native-comp 2eb41ec 7/8: More improvements to `comp-cstr-union-1' for mixed positive/negative cases,
Andrea Corallo <=