Function: cond*-match

cond*-match is a byte-compiled function defined in cond-star.el.gz.

Signature

(cond*-match MATCHEXP TRUE-EXPS UNCONDIT-CLAUSES IFFALSE)

Documentation

Generate code to match a match* pattern PATTERN.

Match it against data represented by the expression DATA. TRUE-EXPS, UNCONDIT-CLAUSES and IFFALSE have the same meanings as in cond*-condition.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/cond-star.el.gz
(defun cond*-match (matchexp true-exps uncondit-clauses iffalse)
  "Generate code to match a match* pattern PATTERN.
Match it against data represented by the expression DATA.
TRUE-EXPS, UNCONDIT-CLAUSES and IFFALSE have the same meanings
as in `cond*-condition'."
  (when (or (null matchexp) (null (cdr-safe matchexp))
            (null (cdr-safe (cdr matchexp)))
            (cdr-safe (cdr (cdr matchexp))))
    (byte-compile-warn-x matchexp "Malformed (match* ...) expression"))
  (let* (raw-result
         (pattern (nth 1 matchexp))
         (data (nth 2 matchexp))
         expression
         (inner-data data)
         ;; Add backtrack aliases for or-subpatterns to cdr of this.
         (backtrack-aliases (list nil))
         run-true-exps
         store-value-swap-outs retrieve-value-swap-outs
         gensym)
    ;; For now, always bind a gensym to the data to be matched.
    (setq gensym (gensym "d") inner-data gensym)
    ;; Process the whole pattern as a subpattern.
    (setq raw-result (cond*-subpat pattern nil nil nil backtrack-aliases inner-data))
    (setq expression (cdr raw-result))
    ;; If there are conditional expressions and some
    ;; unconditional clauses to follow,
    ;; and the pattern bound some variables,
    ;; copy their values into special aliases
    ;; to be copied back at the start of the unconditional clauses.
    (when (and uncondit-clauses true-exps
               (car raw-result))
      (dolist (bound-var (car raw-result))
        (push `(setq ,(gensym "ua") ,(car bound-var)) store-value-swap-outs)
        (push `(,(car bound-var) ,(gensym "ua")) retrieve-value-swap-outs)))

    ;; Make an expression to run the TRUE-EXPS inside our bindings.
    (if store-value-swap-outs
        ;; If we have to store those bindings' values in aliases
        ;; for the UNCONDIT-CLAUSES, do so inside these bindings.
        (setq run-true-exps
              (cond*-bind-pattern-syms
               (car raw-result)
               `(prog1 (progn . ,true-exps) . ,store-value-swap-outs)))
      (setq run-true-exps
            (cond*-bind-pattern-syms
             (car raw-result)
             `(progn . ,true-exps))))
    ;; Run TRUE-EXPS if match succeeded.  Bind our bindings around it.
    (setq expression
          (if (and (null run-true-exps) (null iffalse))
              ;; We MUST compute the expression, even when no decision
              ;; depends on its value, because it may call functions with
              ;; side effects.
              expression
            `(if ,expression
                 ,run-true-exps
               ;; For a non-final exiting clause, run IFFALSE if match failed.
               ;; Don't bind the bindings around it, since
               ;; an exiting clause's bindings don't affect later clauses.
               ,iffalse)))
    ;; For a non-final non-exiting clause,
    ;; always run the UNCONDIT-CLAUSES.
    (if uncondit-clauses
        (setq expression
              `(progn ,expression
                      ,(cond*-bind-pattern-syms
                        (if retrieve-value-swap-outs
                            ;; If we saved the bindings' values after the
                            ;; true-clauses, bind the same variables
                            ;; here to the values we saved then.
                            retrieve-value-swap-outs
                          ;; Otherwise bind them to the values
                          ;; they matched in the pattern.
                          (car raw-result))
                        (cond*-convert uncondit-clauses)))))
    ;; Bind the backtrack-aliases if any.
    ;; We need them bound for the TRUE-EXPS.
    ;; It is harmless to bind them around IFFALSE
    ;; because they are all gensyms anyway.
    (if (cdr backtrack-aliases)
        (setq expression
              `(let ,(mapcar #'cdr (cdr backtrack-aliases))
                 ,expression)))
    (if retrieve-value-swap-outs
        (setq expression
              `(let ,(mapcar #'cadr retrieve-value-swap-outs)
                 ,expression)))
    ;; If we used a gensym, wrap on code to bind it.
    (if gensym
        (if (and (listp expression) (eq (car expression) 'progn))
            `(let ((,gensym ,data)) . ,(cdr expression))
          `(let ((,gensym ,data)) ,expression))
      expression)))