From: Andrea Corallo Date: Wed, 2 Dec 2020 22:51:19 +0000 (+0100) Subject: More improvements to `comp-cstr-union-1' for mixed positive/negative cases X-Git-Tag: emacs-28.0.90~2727^2~283 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2eb41ec137839d06a856e1f910dfa5d2fa97e451;p=emacs.git 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. --- diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5a45294ed80..c0e6a57f4dc 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 0b10b7f80a1..bc772fcb0d2 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 ()