Function: comp-cstr-intersection-no-mem

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

Signature

(comp-cstr-intersection-no-mem &rest SRCS)

Documentation

Combine SRCS by intersection set operation.

Non memoized version of comp-cstr-intersection-no-mem.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/comp-cstr.el.gz
(cl-defun comp-cstr-intersection-no-mem (&rest srcs)
  "Combine SRCS by intersection set operation.
Non memoized version of `comp-cstr-intersection-no-mem'."
  (let ((dst (make-comp-cstr)))
    (with-comp-cstr-accessors
      (cl-flet ((return-empty ()
                              (setf (typeset dst) ()
                                    (valset dst) ()
                                    (range dst) ()
                                    (neg dst) nil)
                              (cl-return-from comp-cstr-intersection-no-mem dst)))
        (when-let ((res (comp-cstrs-homogeneous srcs)))
          (if (eq res 'neg)
              (apply #'comp-cstr-union-homogeneous t dst srcs)
            (apply #'comp-cstr-intersection-homogeneous dst srcs))
          (cl-return-from comp-cstr-intersection-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-intersection-homogeneous
                             (make-comp-cstr) positives))
                 (neg (apply #'comp-cstr-intersection-homogeneous
                             (make-comp-cstr) negatives)))

            ;; In case pos is not relevant return directly the content
            ;; of neg.
            (when (equal (typeset pos) '(t))
              (comp-cstr-shallow-copy dst neg)
              (setf (neg dst) t)

              ;; (not t) => nil
              (when (and (null (valset dst))
                         (null (range dst))
                         (neg dst)
                         (equal '(t) (typeset dst)))
                (setf (typeset dst) ()
                      (neg dst) nil))

              (cl-return-from comp-cstr-intersection-no-mem dst))

            (when (cl-some
                   (lambda (ty)
                     (memq ty (typeset neg)))
                   (typeset pos))
              (return-empty))

            ;; Some negated types are subtypes of some non-negated one.
            ;; Transform the corresponding set of types from neg to pos.
            (cl-loop
             for neg-type in (typeset neg)
             do (cl-loop
                 for pos-type in (copy-sequence (typeset pos))
                 when (and (not (eq neg-type pos-type))
                           (comp-subtype-p neg-type pos-type))
                   do (cl-loop
                       with found
                       for (type . _) in (comp-supertypes neg-type)
                       when found
                         collect type into res
                       when (eq type pos-type)
                         do (setf (typeset pos) (cl-union (typeset pos) res))
                            (cl-return)
                       when (eq type neg-type)
                         do (setf found t))))

            (setf (range pos)
                  (comp-range-intersection (range pos)
                                           (comp-range-negation (range neg)))
                  (valset pos)
                  (cl-set-difference (valset pos) (valset neg)))

            ;; Return a non negated form.
            (comp-cstr-shallow-copy dst pos)
            (setf (neg dst) nil)))
        dst))))