From: Andrea Corallo <akrl@sdf.org>
Date: Sun, 6 Dec 2020 17:01:28 +0000 (+0100)
Subject: * Unify common fallback exit point in `comp-cstr-union-1-no-mem'.
X-Git-Tag: emacs-28.0.90~2727^2~280
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=27f666e111a34d64de81a214024e1e30928b416e;p=emacs.git

* 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.
---

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index d4e47cf302f..892a8d349d9 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -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)))
-
-    ;; 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.
-         (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))
-           (setf (typeset dst) '(t)
-                 (valset dst) ()
-                 (range dst) ()
-                 (neg dst) nil)
-           (cl-return-from comp-cstr-union-1-no-mem dst)))
-
-       ;; 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)))))
-
-       ;; 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.
+    (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)))
+
+      ;; 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)))
+
+      ;; 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))
+             (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.
+           (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.
+               (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)