mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-30 19:53:09 +00:00
Code Issues Releases Activity

* Add initial negated non-negegated intersection support

Browse Source 
* lisp/emacs-lisp/comp-cstr.el (comp-range-intersection): Cosmetic.
	(comp-cstr-intersection-homogeneous): Rename from
	`comp-cstr-intersection'.
	(comp-cstr-intersection): New function.
This commit is contained in:
Andrea Corallo 2020-12-08 21:24:14 +01:00
parent 6286945396
commit 0ded37fdad
2 changed files with 116 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

114
lisp/emacs-lisp/comp-cstr.el
View File

@ -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))

24
test/lisp/emacs-lisp/comp-cstr-tests.el
View File

@ -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 ()