mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-03 10:31:37 -08:00
Code Issues Projects Releases Wiki Activity

* Unify common fallback exit point in `comp-cstr-union-1-no-mem'.

Browse source 
* lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Define
	a local function `give-up' as a common fall-back exit point.
This commit is contained in:
Andrea Corallo 2020-12-06 18:01:28 +01:00
parent ac40a60696
commit 27f666e111
1 changed files with 101 additions and 107 deletions
Download patch file Download diff file Expand all files Collapse all files

208
lisp/emacs-lisp/comp-cstr.el
View file

@ -333,121 +333,115 @@ Do range propagation when RANGE is non-nil.
Non memoized version of `comp-cstr-union-1'. Non memoized version of `comp-cstr-union-1'.
DST is returned." DST is returned."
(with-comp-cstr-accessors (with-comp-cstr-accessors
;; Check first if we are in the simple case of all input non-negate (cl-flet ((give-up ()
;; or negated so we don't have to cons. (setf (typeset dst) '(t)
(cl-loop (valset dst) ()
for cstr in srcs (range dst) ()
unless (neg cstr) (neg dst) nil)
count t into n-pos (cl-return-from comp-cstr-union-1-no-mem dst)))
else
count t into n-neg
finally
(when (or (zerop n-pos) (zerop n-neg))
(apply #'comp-cstr-union-homogeneous dst srcs)
(when (zerop n-pos)
(setf (neg dst) t))
(cl-return-from comp-cstr-union-1-no-mem dst)))
;; Some are negated and some are not ;; Check first if we are in the simple case of all input non-negate
(cl-loop ;; or negated so we don't have to cons.
for cstr in srcs (cl-loop
if (neg cstr) for cstr in srcs
collect cstr into negatives unless (neg cstr)
else count t into n-pos
collect cstr into positives else
finally count t into n-neg
(let* ((pos (apply #'comp-cstr-union-homogeneous finally
(make-comp-cstr) positives)) (when (or (zerop n-pos) (zerop n-neg))
;; We use neg as result as *most* of times this will be (apply #'comp-cstr-union-homogeneous dst srcs)
;; negated. (when (zerop n-pos)
(neg (apply #'comp-cstr-union-homogeneous (setf (neg dst) t))
(make-comp-cstr :neg t) negatives))) (cl-return-from comp-cstr-union-1-no-mem dst)))
;; Type propagation. ;; Some are negated and some are not
(when (and (typeset pos) (cl-loop
;; When every pos type is not a subtype of some neg ones. for cstr in srcs
(cl-every (lambda (x) if (neg cstr)
(cl-some (lambda (y) collect cstr into negatives
(not (and (not (eq x y)) else
(comp-subtype-p x y)))) collect cstr into positives
(typeset neg))) finally
(typeset pos))) (let* ((pos (apply #'comp-cstr-union-homogeneous
;; This is a conservative choice, ATM we can't represent such (make-comp-cstr) positives))
;; a disjoint set of types unless we decide to add a new slot ;; We use neg as result as *most* of times this will be
;; into `comp-cstr' or adopt something like ;; negated.
;; `intersection-type' `union-type' in SBCL. Keep it (neg (apply #'comp-cstr-union-homogeneous
;; "simple" for now. (make-comp-cstr :neg t) negatives)))
(setf (typeset dst) '(t) ;; Type propagation.
(valset dst) () (when (and (typeset pos)
(range dst) () ;; When every pos type is not a subtype of some neg ones.
(neg dst) nil) (cl-every (lambda (x)
(cl-return-from comp-cstr-union-1-no-mem dst)) (cl-some (lambda (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' or adopt something like
;; `intersection-type' `union-type' in SBCL. Keep it
;; "simple" for now.
(give-up))
;; Verify disjoint condition between positive types and ;; Verify disjoint condition between positive types and
;; negative types coming from values, in case give-up. ;; negative types coming from values, in case give-up.
(let ((neg-value-types (nconc (mapcar #'type-of (valset neg)) (let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
(when (range neg) (when (range neg)
'(integer))))) '(integer)))))
(when (cl-some (lambda (x) (when (cl-some (lambda (x)
(cl-some (lambda (y) (cl-some (lambda (y)
(and (not (eq y x)) (and (not (eq y x))
(comp-subtype-p y x))) (comp-subtype-p y x)))
neg-value-types)) neg-value-types))
(typeset pos)) (typeset pos))
(setf (typeset dst) '(t) (give-up)))
(valset dst) ()
(range dst) ()
(neg dst) nil)
(cl-return-from comp-cstr-union-1-no-mem dst)))
;; Value propagation. ;; Value propagation.
(cond (cond
((and (valset pos) (valset neg) ((and (valset pos) (valset neg)
(equal (cl-union (valset pos) (valset neg)) (valset pos))) (equal (cl-union (valset pos) (valset neg)) (valset pos)))
;; Pos is a superset of neg. ;; Pos is a superset of neg.
(setf (typeset dst) '(t) (give-up))
(valset dst) () (t
(range dst) () ;; pos is a subset or eq to neg
(neg dst) nil) (setf (valset neg)
(cl-return-from comp-cstr-union-1-no-mem dst)) (cl-nset-difference (valset neg) (valset pos)))))
(t
;; pos is a subset or eq to neg
(setf (valset neg)
(cl-nset-difference (valset neg) (valset pos)))))
;; Range propagation ;; Range propagation
(if (and range (if (and range
(or (range pos) (or (range pos)
(range neg))) (range neg)))
(if (or (valset neg) (typeset neg)) (if (or (valset neg) (typeset neg))
(setf (range neg) (setf (range neg)
(if (memq 'integer (typeset neg)) (if (memq 'integer (typeset neg))
(comp-range-negation (range pos)) (comp-range-negation (range pos))
(comp-range-negation (comp-range-negation
(comp-range-union (range pos) (comp-range-union (range pos)
(comp-range-negation (range neg)))))) (comp-range-negation (range neg))))))
;; When possibile do not return a negated cstr. ;; When possibile do not return a negated cstr.
(setf (typeset dst) (typeset pos)
(valset dst) (valset pos)
(range dst) (unless (memq 'integer (typeset dst))
(comp-range-union
(comp-range-negation (range neg))
(range pos)))
(neg dst) nil)
(cl-return-from comp-cstr-union-1-no-mem dst))
(setf (range neg) ()))
(if (and (null (typeset neg))
(null (valset neg))
(null (range neg)))
(setf (typeset dst) (typeset pos) (setf (typeset dst) (typeset pos)
(valset dst) (valset pos) (valset dst) (valset pos)
(range dst) (unless (memq 'integer (typeset dst)) (range dst) (range pos)
(comp-range-union
(comp-range-negation (range neg))
(range pos)))
(neg dst) nil) (neg dst) nil)
(cl-return-from comp-cstr-union-1-no-mem dst)) (setf (typeset dst) (typeset neg)
(setf (range neg) ())) (valset dst) (valset neg)
(range dst) (range neg)
(if (and (null (typeset neg)) (neg dst) (neg neg))))))
(null (valset neg))
(null (range neg)))
(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) (neg neg)))))
dst)) dst))
(defun comp-cstr-union-1 (range dst &rest srcs) (defun comp-cstr-union-1 (range dst &rest srcs)