mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-06 14:30:50 -08:00
* Unify common fallback exit point in `comp-cstr-union-1-no-mem'.
* 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
parent
ac40a60696
commit
27f666e111
1 changed files with 101 additions and 107 deletions
|
|
@ -333,121 +333,115 @@ Do range propagation when RANGE is non-nil.
|
|||
Non memoized version of `comp-cstr-union-1'.
|
||||
DST is returned."
|
||||
(with-comp-cstr-accessors
|
||||
;; Check first if we are in the simple case of all input non-negate
|
||||
;; or negated so we don't have to cons.
|
||||
(cl-loop
|
||||
for cstr in srcs
|
||||
unless (neg cstr)
|
||||
count t into n-pos
|
||||
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)))
|
||||
(cl-flet ((give-up ()
|
||||
(setf (typeset dst) '(t)
|
||||
(valset dst) ()
|
||||
(range dst) ()
|
||||
(neg dst) nil)
|
||||
(cl-return-from comp-cstr-union-1-no-mem dst)))
|
||||
|
||||
;; Some are negated and some are not
|
||||
(cl-loop
|
||||
for cstr in srcs
|
||||
if (neg cstr)
|
||||
collect cstr into negatives
|
||||
else
|
||||
collect cstr into positives
|
||||
finally
|
||||
(let* ((pos (apply #'comp-cstr-union-homogeneous
|
||||
(make-comp-cstr) positives))
|
||||
;; We use neg as result as *most* of times this will be
|
||||
;; negated.
|
||||
(neg (apply #'comp-cstr-union-homogeneous
|
||||
(make-comp-cstr :neg t) negatives)))
|
||||
;; Check first if we are in the simple case of all input non-negate
|
||||
;; or negated so we don't have to cons.
|
||||
(cl-loop
|
||||
for cstr in srcs
|
||||
unless (neg cstr)
|
||||
count t into n-pos
|
||||
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)))
|
||||
|
||||
;; Type propagation.
|
||||
(when (and (typeset pos)
|
||||
;; When every pos type is not a subtype of some neg ones.
|
||||
(cl-every (lambda (x)
|
||||
(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.
|
||||
(setf (typeset dst) '(t)
|
||||
(valset dst) ()
|
||||
(range dst) ()
|
||||
(neg dst) nil)
|
||||
(cl-return-from comp-cstr-union-1-no-mem dst))
|
||||
;; Some are negated and some are not
|
||||
(cl-loop
|
||||
for cstr in srcs
|
||||
if (neg cstr)
|
||||
collect cstr into negatives
|
||||
else
|
||||
collect cstr into positives
|
||||
finally
|
||||
(let* ((pos (apply #'comp-cstr-union-homogeneous
|
||||
(make-comp-cstr) positives))
|
||||
;; We use neg as result as *most* of times this will be
|
||||
;; negated.
|
||||
(neg (apply #'comp-cstr-union-homogeneous
|
||||
(make-comp-cstr :neg t) negatives)))
|
||||
;; Type propagation.
|
||||
(when (and (typeset pos)
|
||||
;; When every pos type is not a subtype of some neg ones.
|
||||
(cl-every (lambda (x)
|
||||
(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
|
||||
;; negative types coming from values, in case give-up.
|
||||
(let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
|
||||
(when (range neg)
|
||||
'(integer)))))
|
||||
(when (cl-some (lambda (x)
|
||||
(cl-some (lambda (y)
|
||||
(and (not (eq y x))
|
||||
(comp-subtype-p y x)))
|
||||
neg-value-types))
|
||||
(typeset pos))
|
||||
(setf (typeset dst) '(t)
|
||||
(valset dst) ()
|
||||
(range dst) ()
|
||||
(neg dst) nil)
|
||||
(cl-return-from comp-cstr-union-1-no-mem dst)))
|
||||
;; Verify disjoint condition between positive types and
|
||||
;; negative types coming from values, in case give-up.
|
||||
(let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
|
||||
(when (range neg)
|
||||
'(integer)))))
|
||||
(when (cl-some (lambda (x)
|
||||
(cl-some (lambda (y)
|
||||
(and (not (eq y x))
|
||||
(comp-subtype-p y x)))
|
||||
neg-value-types))
|
||||
(typeset pos))
|
||||
(give-up)))
|
||||
|
||||
;; Value propagation.
|
||||
(cond
|
||||
((and (valset pos) (valset neg)
|
||||
(equal (cl-union (valset pos) (valset neg)) (valset pos)))
|
||||
;; Pos is a superset of neg.
|
||||
(setf (typeset dst) '(t)
|
||||
(valset dst) ()
|
||||
(range dst) ()
|
||||
(neg dst) nil)
|
||||
(cl-return-from comp-cstr-union-1-no-mem dst))
|
||||
(t
|
||||
;; pos is a subset or eq to neg
|
||||
(setf (valset neg)
|
||||
(cl-nset-difference (valset neg) (valset pos)))))
|
||||
;; Value propagation.
|
||||
(cond
|
||||
((and (valset pos) (valset neg)
|
||||
(equal (cl-union (valset pos) (valset neg)) (valset pos)))
|
||||
;; Pos is a superset of neg.
|
||||
(give-up))
|
||||
(t
|
||||
;; pos is a subset or eq to neg
|
||||
(setf (valset neg)
|
||||
(cl-nset-difference (valset neg) (valset pos)))))
|
||||
|
||||
;; Range propagation
|
||||
(if (and range
|
||||
(or (range pos)
|
||||
(range neg)))
|
||||
(if (or (valset neg) (typeset neg))
|
||||
(setf (range neg)
|
||||
(if (memq 'integer (typeset neg))
|
||||
(comp-range-negation (range pos))
|
||||
(comp-range-negation
|
||||
(comp-range-union (range pos)
|
||||
(comp-range-negation (range neg))))))
|
||||
;; When possibile do not return a negated cstr.
|
||||
;; Range propagation
|
||||
(if (and range
|
||||
(or (range pos)
|
||||
(range neg)))
|
||||
(if (or (valset neg) (typeset neg))
|
||||
(setf (range neg)
|
||||
(if (memq 'integer (typeset neg))
|
||||
(comp-range-negation (range pos))
|
||||
(comp-range-negation
|
||||
(comp-range-union (range pos)
|
||||
(comp-range-negation (range neg))))))
|
||||
;; 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)
|
||||
(valset dst) (valset pos)
|
||||
(range dst) (unless (memq 'integer (typeset dst))
|
||||
(comp-range-union
|
||||
(comp-range-negation (range neg))
|
||||
(range pos)))
|
||||
(range dst) (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)
|
||||
(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)))))
|
||||
(setf (typeset dst) (typeset neg)
|
||||
(valset dst) (valset neg)
|
||||
(range dst) (range neg)
|
||||
(neg dst) (neg neg))))))
|
||||
dst))
|
||||
|
||||
(defun comp-cstr-union-1 (range dst &rest srcs)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue