Function: comp-cstr-union-1-no-mem

comp-cstr-union-1-no-mem is a byte-compiled function defined in comp-cstr.el.gz.

Signature

(comp-cstr-union-1-no-mem RANGE &rest SRCS)

Documentation

Combine SRCS by union set operation setting the result in DST.

Do range propagation when RANGE is non-nil. Non memoized version of comp-cstr-union-1. DST is returned.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/comp-cstr.el.gz
(cl-defun comp-cstr-union-1-no-mem (range &rest srcs)
  "Combine SRCS by union set operation setting the result in DST.
Do range propagation when RANGE is non-nil.
Non memoized version of `comp-cstr-union-1'.
DST is returned."
  (with-comp-cstr-accessors
    (let ((dst (make-comp-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.
        (when-let ((res (comp-cstrs-homogeneous srcs)))
          (apply #'comp-cstr-union-homogeneous range dst srcs)
          (cl-return-from comp-cstr-union-1-no-mem dst))

        ;; Some are negated and some are not
        (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
          (let* ((pos (apply #'comp-cstr-union-homogeneous range
                             (make-comp-cstr) positives))
                 ;; We'll always use neg as result as this is almost
                 ;; always necessary for describing open intervals
                 ;; resulting from negated constraints.
                 (neg (apply #'comp-cstr-union-homogeneous range
                             (make-comp-cstr :neg t) negatives)))
            ;; Type propagation.
            (when (and (typeset pos)
                       ;; When every pos type is a subtype of some neg ones.
                       (cl-every (lambda (x)
                                   (cl-some (lambda (y)
                                              (comp-subtype-p x y))
                                            (append (typeset neg)
                                                    (when (range neg)
                                                      '(integer)))))
                                 (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))

            ;; When every neg type is a subtype of some pos one.
            ;; In case return pos.
            (when (and (typeset neg)
                       (cl-every (lambda (x)
                                   (cl-some (lambda (y)
                                              (comp-subtype-p x y))
                                            (append (typeset pos)
                                                    (when (range pos)
                                                      '(integer)))))
                                 (typeset neg)))
              (setf (typeset dst) (typeset pos)
                    (valset dst) (valset pos)
                    (range dst) (range pos)
                    (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 (comp-union-valsets (valset pos) (valset neg))
                          (valset pos)))
              ;; Pos is a superset of neg.
              (give-up))
             ((cl-some (lambda (x)
                         (cl-some (lambda (y)
                                    (comp-subtype-p y x))
                                  (mapcar #'type-of (valset pos))))
                       (typeset neg))
              (give-up))
             (t
              ;; pos is a subset or eq to neg
              (setf (valset neg)
                    (cl-nset-difference (valset neg) (valset pos)))))

            ;; Range propagation
            (when range
              ;; Handle apart (or (integer 1 1) (not (integer 1 1)))
              ;; like cases.
              (if (and (range pos) (range neg)
                       (equal (range pos) (range neg)))
                  (give-up)
                (setf (range neg)
                      (comp-range-negation
                       (comp-range-union
                        (comp-range-negation (range neg))
                        (range pos))))))

            (if (comp-cstr-empty-p 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)))))

        ;; (not null) => t
        (when (and (neg dst)
                   (null (typeset dst))
                   (null (valset dst))
                   (null (range dst)))
          (give-up)))

      dst)))