From 2e0256e0a02edad129e0af1ea97b9e263c5d83fb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Nov 2020 21:30:03 +0100 Subject: [PATCH] Add intersection support into comp-cstr.el --- lisp/emacs-lisp/comp-cstr.el | 80 ++++++++++++++++++++++--- test/lisp/emacs-lisp/comp-cstr-tests.el | 23 +++++-- test/src/comp-tests.el | 20 ------- 3 files changed, 91 insertions(+), 32 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index fcbb32fab2e..40fa48ee8e1 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -143,6 +143,19 @@ Integer values are handled in the `range' slot.") finally (cl-return (cl-remove-duplicates res))) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) +(defun comp-intersect-typesets (&rest typesets) + "Intersect types present into TYPESETS." + (when-let ((ty (apply #'append typesets))) + (if (> (length ty) 1) + (cl-reduce + (lambda (x y) + (let ((st (comp-common-supertype-2 x y))) + (cond + ((eq st x) (list y)) + ((eq st y) (list x))))) + ty) + ty))) + ;;; Integer range handling @@ -252,7 +265,7 @@ Integer values are handled in the `range' slot.") "Combine SRCS by union set operation setting the result in DST. DST is returned." (apply #'comp-cstr-union-no-range dst srcs) - ;; Range propagation + ;; Range propagation. (setf (comp-cstr-range dst) (when (cl-notany (lambda (x) (comp-subtype-p 'integer x)) @@ -266,6 +279,59 @@ DST is returned." "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) + "Combine SRCS by intersection set operation setting the result in DST. +DST is returned." + + ;; Value propagation. + (setf (comp-cstr-valset dst) + ;; TODO sort. + (let ((values (cl-loop for src in srcs + for v = (comp-cstr-valset src) + when v + collect v))) + (when values + (cl-reduce (lambda (x y) + (cl-intersection x y :test #'equal)) + values)))) + + ;; Range propagation. + (when (cl-some #'identity (mapcar #'comp-cstr-range srcs)) + (if (comp-cstr-valset dst) + (progn + (setf (comp-cstr-valset dst) nil + (comp-cstr-range dst) nil + (comp-cstr-typeset dst) nil) + (cl-return-from comp-cstr-intersection dst)) + ;; TODO memoize? + (setf (comp-cstr-range dst) + (apply #'comp-range-intersection + (mapcar #'comp-cstr-range srcs))))) + + ;; Type propagation. + (setf (comp-cstr-typeset dst) + (if (or (comp-cstr-range dst) (comp-cstr-valset dst)) + (cl-loop + with type-val = (cl-remove-duplicates + (append (mapcar #'type-of + (comp-cstr-valset dst)) + (when (comp-cstr-range dst) + '(integer)))) + for type in (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs)) + when (and type (not (member type type-val))) + do (setf (comp-cstr-valset dst) nil + (comp-cstr-range dst) nil) + (cl-return nil)) + (apply #'comp-intersect-typesets + (mapcar #'comp-cstr-typeset srcs)))) + 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)) + (defun comp-type-spec-to-cstr (type-spec &optional fn) "Convert a type specifier TYPE-SPEC into a `comp-cstr'. FN non-nil indicates we are parsing a function lambda list." @@ -287,11 +353,8 @@ FN non-nil indicates we are parsing a function lambda list." (apply #'comp-cstr-union-make (mapcar #'comp-type-spec-to-cstr rest))) (`(and . ,rest) - (cl-assert nil) - ;; TODO - ;; (apply #'comp-cstr-intersect-make - ;; (mapcar #'comp-type-spec-to-cstr rest)) - ) + (apply #'comp-cstr-intersection-make + (mapcar #'comp-type-spec-to-cstr rest))) (`(not ,cstr) (cl-assert nil) ;; TODO @@ -351,7 +414,10 @@ FN non-nil indicates we are parsing a function lambda list." ;; Empty type specifier nil)))) (pcase res - (`(,(or 'integer 'member) . ,_rest) res) + (`(,(or 'integer 'member) . ,rest) + (if rest + res + (car res))) ((pred atom) res) (`(,_first . ,rest) (if rest diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 38a5e291311..c98ff80cd72 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -48,15 +48,13 @@ ((or (or integer symbol) number) . (or symbol number)) ((or (or integer symbol) (or number list)) . (or list symbol number)) ((or (or integer number) nil) . number) - ;; ((and string array) . string) - ;; ((and cons atom) . (or cons atom)) - ;; ((and (member foo) (member bar)) . symbol) - ;; ((and (member foo) symbol) . (member foo)) ((member foo) . (member foo)) ((member foo bar) . (member foo bar)) ((or (member foo) (member bar)) . (member foo bar)) ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) ((or (member foo) number) . (or (member foo) number)) + ((or (integer 1 3) number) . number) + (integer . integer) ((integer 1 2) . (integer 1 2)) ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) @@ -64,7 +62,22 @@ ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) - ((or (integer -1 2) (integer * 4)) . (integer * 4))) + ((or (integer -1 2) (integer * 4)) . (integer * 4)) + ((and string array) . string) + ((and cons atom) . nil) + ((and (member foo) (member foo bar baz)) . (member foo)) + ((and (member foo) (member bar)) . nil) + ((and (member foo) symbol) . (member foo)) + ((and (member foo) string) . nil) + ((and (member foo) (integer 1 2)) . nil) + ((and (member 1 2) (member 3 2)) . (member 2)) + ((and number (integer 1 2)) . number) + ((and integer (integer 1 2)) . integer) + ((and (integer -1 0) (integer 3 5)) . nil) + ((and (integer -1 2) (integer 3 5)) . nil) + ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) + ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) + ((and (integer -1 5) nil) . nil)) "Alist type specifier -> expected type specifier.") (defmacro comp-cstr-synthesize-tests () diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 88c7b8c0d81..dd97ccd5bd1 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -965,24 +965,4 @@ Return a list of results." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Range propagation tests. ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; FIXME to be removed when movable into comp-cstr-tests.el -(comp-deftest range-simple-intersection () - (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4))) - '())) - (should (equal (comp-range-intersection '((-1 . 2)) '((3 . 4))) - '())) - (should (equal (comp-range-intersection '((-1 . 3)) '((3 . 4))) - '((3 . 3)))) - (should (equal (comp-range-intersection '((-1 . 4)) '((3 . 4))) - '((3 . 4)))) - (should (equal (comp-range-intersection '((-1 . 5)) '((3 . 4))) - '((3 . 4)))) - (should (equal (comp-range-intersection '((-1 . 0)) '()) - '()))) - ;;; comp-tests.el ends here -- 2.39.5