Function: pcase--split-pred

pcase--split-pred is a byte-compiled function defined in pcase.el.gz.

Signature

(pcase--split-pred VARS UPAT PAT)

Documentation

Indicate the overlap or mutual-exclusion between UPAT and PAT.

More specifically returns a pair (A . B) where A indicates whether PAT can match when UPAT has matched, and B does the same for the case where UPAT failed to match. A and B can be one of:
- nil if we don't know
- :pcase--fail if UPAT match's result implies that PAT can't match
- :pcase--succeed if UPAT match's result implies that PAT matches

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/pcase.el.gz
(defun pcase--split-pred (vars upat pat)
  "Indicate the overlap or mutual-exclusion between UPAT and PAT.
More specifically returns a pair (A . B) where A indicates whether PAT
can match when UPAT has matched, and B does the same for the case
where UPAT failed to match.
A and B can be one of:
- nil if we don't know
- `:pcase--fail' if UPAT match's result implies that PAT can't match
- `:pcase--succeed' if UPAT match's result implies that PAT matches"
  (let (test)
    (cond
     ((and (equal upat pat)
           ;; For predicates like (pred (> a)), two such predicates may
           ;; actually refer to different variables `a'.
           (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
               ;; FIXME: `vars' gives us the environment in which `upat' will
               ;; run, but we don't have the environment in which `pat' will
               ;; run, so we can't do a reliable verification.  But let's try
               ;; and catch at least the easy cases such as (bug#14773).
               (not (macroexp--fgrep vars (cadr upat)))))
      '(:pcase--succeed . :pcase--fail))
     ;; In case PAT is of the form (pred (not PRED))
     ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
      (let* ((test (cadr (cadr pat)))
             (res (pcase--split-pred vars upat `(pred ,test)))
             (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
                                   ((eq x :pcase--fail) :pcase--succeed)))))
        (cons (funcall reverse (car res))
              (funcall reverse (cdr res)))))
     ;; All the rest below presumes UPAT is of the form (pred ...).
     ((not (eq 'pred (car upat))) nil)
     ;; In case UPAT is of the form (pred (not PRED))
     ((eq 'not (car-safe (cadr upat)))
      (let* ((test (cadr (cadr upat)))
             (res (pcase--split-pred vars `(pred ,test) pat)))
        (cons (cdr res) (car res))))
     ((let ((otherpred
             (cond ((eq 'pred (car-safe pat)) (cadr pat))
                   ((not (eq 'quote (car-safe pat))) nil)
                   ((consp (cadr pat)) #'consp)
                   ((stringp (cadr pat)) #'stringp)
                   ((vectorp (cadr pat)) #'vectorp)
                   ((compiled-function-p (cadr pat))
                    #'compiled-function-p))))
        (pcase--mutually-exclusive-p (cadr upat) otherpred))
      '(:pcase--fail . nil))
     ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
     ;; try and preserve the info we get from that memq test.
     ((and (eq 'pcase--flip (car-safe (cadr upat)))
           (memq (cadr (cadr upat)) '(memq member memql))
           (eq 'quote (car-safe (nth 2 (cadr upat))))
           (eq 'quote (car-safe pat)))
      (let ((set (cadr (nth 2 (cadr upat)))))
        (if (member (cadr pat) set)
            '(nil . :pcase--fail)
          '(:pcase--fail . nil))))
     ((and (eq 'quote (car-safe pat))
           (symbolp (cadr upat))
           (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
           (get (cadr upat) 'side-effect-free)
           (ignore-errors
             (setq test (list (funcall (cadr upat) (cadr pat))))))
      (if (car test)
          '(nil . :pcase--fail)
        '(:pcase--fail . nil))))))