From: Andrea Corallo Date: Tue, 8 Dec 2020 20:24:14 +0000 (+0100) Subject: * Add initial negated non-negegated intersection support X-Git-Tag: emacs-28.0.90~2727^2~271 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=0ded37fdadc96e7607e2a13e0fd0990e13f3b0b4;p=emacs.git * 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. --- diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 6991c9305f3..ba93ee948d8 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 392669fba02..bd141e13ad5 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 ()