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)))
+
\f
;;; Integer range handling
"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))
"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."
(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
;; 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
((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))
((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 ()
(equal (comp-mvar-typeset mvar)
comp-tests-cond-rw-expected-type))))))))
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 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
projects / emacs.git / commitdiff