Function: cond*-subpat
cond*-subpat is a byte-compiled function defined in cond-star.el.gz.
Signature
(cond*-subpat SUBPAT CDR-IGNORE BINDINGS INSIDE-OR BACKTRACK-ALIASES DATA)
Documentation
Generate code to match the subpattern within match*.
SUBPAT is the subpattern to handle. CDR-IGNORE if true means don't verify there are no extra elts in a list. BINDINGS is the list of bindings made by the containing and previous subpatterns of this pattern. Each element of BINDINGS must have the form (VAR VALUE). BACKTRACK-ALIASES is used to pass data upward. Initial call should pass (list). The cdr of this collects backtracking aliases made for variables bound within (or...) patterns so that the caller can bind them etc. Each of them has the form (USER-SYMBOL . GENSYM). DATA is the expression for the data that this subpattern is supposed to match against.
Return Value has the form (BINDINGS . CONDITION), where BINDINGS is the list of bindings to be made for SUBPAT plus the subpatterns that contain/precede it. Each element of BINDINGS has the form (VAR VALUE). CONDITION is the condition to be tested to decide whether SUBPAT (as well as the subpatterns that contain/precede it) matches,
Source Code
;; Defined in /usr/src/emacs/lisp/emacs-lisp/cond-star.el.gz
;; ??? Structure type patterns not implemented yet.
;; ??? Probably should optimize the `nth' calls in handling `list'.
(defun cond*-subpat (subpat cdr-ignore bindings inside-or backtrack-aliases data)
"Generate code to match the subpattern within `match*'.
SUBPAT is the subpattern to handle.
CDR-IGNORE if true means don't verify there are no extra elts in a list.
BINDINGS is the list of bindings made by
the containing and previous subpatterns of this pattern.
Each element of BINDINGS must have the form (VAR VALUE).
BACKTRACK-ALIASES is used to pass data upward. Initial call should
pass (list). The cdr of this collects backtracking aliases made for
variables bound within (or...) patterns so that the caller
can bind them etc. Each of them has the form (USER-SYMBOL . GENSYM).
DATA is the expression for the data that this subpattern is
supposed to match against.
Return Value has the form (BINDINGS . CONDITION), where
BINDINGS is the list of bindings to be made for SUBPAT
plus the subpatterns that contain/precede it.
Each element of BINDINGS has the form (VAR VALUE).
CONDITION is the condition to be tested to decide
whether SUBPAT (as well as the subpatterns that contain/precede it) matches,"
(if (equal cond*-debug-pattern subpat)
(debug))
;;; (push subpat subpat-log)
(cond ((eq subpat '_)
;; _ as pattern makes no bindings and matches any data.
(cons bindings t))
((memq subpat '(nil t))
(cons bindings `(eq ,subpat ,data)))
((keywordp subpat)
(cons bindings `(eq ,subpat ,data)))
((symbolp subpat)
(let ((this-binding (assq subpat bindings))
(this-alias (assq subpat (cdr backtrack-aliases))))
(if this-binding
;; Variable already bound.
;; Compare what this variable should be bound to
;; to the data it is supposed to match.
;; That is because we don't actually bind these bindings
;; around the condition-testing expression.
(cons bindings `(equal ,(cadr this-binding) ,data))
(if inside-or
(let (alias-gensym)
(if this-alias
;; Inside `or' subpattern, if this symbol already
;; has an alias for backtracking, just use that.
;; This means the symbol was matched
;; in a previous arm of the `or'.
(setq alias-gensym (cdr this-alias))
;; Inside `or' subpattern, but this symbol has no alias,
;; make an alias for it.
(setq alias-gensym (gensym "ba"))
(push (cons subpat alias-gensym) (cdr backtrack-aliases)))
;; Make a binding for the symbol, to its backtrack-alias,
;; and set the alias (a gensym) to nil.
(cons `((,subpat ,alias-gensym) . ,bindings)
`(setq ,alias-gensym ,data)))
;; Not inside `or' subpattern: ask for a binding for this symbol
;; and say it does match whatever datum.
(cons `((,subpat ,data) . ,bindings)
t)))))
;; Various constants.
((numberp subpat)
(cons bindings `(eql ,subpat ,data)))
;; Regular expressions as strings.
((stringp subpat)
(cons bindings `(string-match ,(concat subpat "\\'") ,data)))
;; All other atoms match with `equal'.
((not (consp subpat))
(cons bindings `(equal ,subpat ,data)))
((not (consp (cdr subpat)))
(byte-compile-warn-x subpat "%s subpattern with malformed or missing arguments" (car subpat)))
;; Regular expressions specified as list structure.
;; (rx REGEXP VARS...)
((eq (car subpat) 'rx)
(let* ((rxpat (concat (rx-to-string (cadr subpat) t) "\\'"))
(vars (cddr subpat)) setqs (varnum 0)
(match-exp `(string-match ,rxpat ,data)))
(if (null vars)
(cons bindings match-exp)
;; There are variables to bind to the matched substrings.
(if (> (length vars) 10)
(byte-compile-warn-x vars "Too many variables specified for matched substrings"))
(dolist (elt vars)
(unless (symbolp elt)
(byte-compile-warn-x vars "Non-symbol %s given as name for matched substring" elt)))
;; Bind these variables to nil, before the pattern.
(setq bindings (nconc (mapcar #'list vars) bindings))
;; Make the expressions to set the variables.
(setq setqs (mapcar
(lambda (var)
(prog1 `(setq ,var (match-string ,varnum ,data))
(setq varnum (1+ varnum))))
vars))
(cons bindings `(if ,match-exp
(progn ,@setqs t))))))
;; Quoted object as constant to match with `eq' or `equal'.
((eq (car subpat) 'quote)
(if (symbolp (car-safe (cdr-safe subpat)))
(cons bindings `(eq ,subpat ,data))
(cons bindings `(equal ,subpat ,data))))
;; Match a call to `cons' by destructuring.
((eq (car subpat) 'cons)
(let (car-result cdr-result car-exp cdr-exp)
(setq car-result
(cond*-subpat (nth 1 subpat) cdr-ignore bindings inside-or backtrack-aliases `(car ,data)))
(setq bindings (car car-result)
car-exp (cdr car-result))
(setq cdr-result
(cond*-subpat (nth 2 subpat) cdr-ignore bindings inside-or backtrack-aliases `(cdr ,data)))
(setq bindings (car cdr-result)
cdr-exp (cdr cdr-result))
(cons bindings
(cond*-and `((consp ,data) ,car-exp ,cdr-exp)))))
;; Match a call to `list' by destructuring.
((eq (car subpat) 'list)
(let ((i 0) expressions)
;; Check for bad structure of SUBPAT here?
(dolist (this-elt (cdr subpat))
(let ((result
(cond*-subpat this-elt cdr-ignore bindings inside-or
backtrack-aliases `(nth ,i ,data))))
(setq bindings (car result))
(push `(consp ,(if (zerop i) data `(nthcdr ,i ,data)))
expressions)
(setq i (1+ i))
(push (cdr result) expressions)))
;; Verify that list ends here, if we are supposed to check that.
(unless cdr-ignore
(push `(null (nthcdr ,i ,data)) expressions))
(cons bindings (cond*-and (nreverse expressions)))))
;; Match (apply 'vector (backquote-list* LIST...)), destructuring.
((eq (car subpat) 'apply)
;; We only try to handle the case generated by backquote.
;; Convert it to a call to `vector' and handle that.
(let ((cleaned-up
`(vector . ,(cond*-un-backquote-list* (cdr (nth 2 subpat))))))
;; (cdr (nth 2 subpat)) gets LIST as above.
(cond*-subpat cleaned-up
cdr-ignore bindings inside-or backtrack-aliases data)))
;; Match a call to `vector' by destructuring.
((eq (car subpat) 'vector)
(let* ((elts (cdr subpat))
(length (length elts))
expressions (i 0))
(dolist (elt elts)
(let* ((result
(cond*-subpat elt cdr-ignore bindings inside-or
backtrack-aliases `(aref ,i ,data))))
(setq i (1+ i))
(setq bindings (car result))
(push (cdr result) expressions)))
(cons bindings
(cond*-and `((vectorp ,data) (= (length ,data) ,length)
. ,(nreverse expressions))))))
;; Subpattern to set the cdr-ignore flag.
((eq (car subpat) 'cdr-ignore)
(cond*-subpat (cadr subpat) t bindings inside-or backtrack-aliases data))
;; Subpattern to clear the cdr-ignore flag.
((eq (car subpat) 'cdr)
(cond*-subpat (cadr subpat) nil bindings inside-or backtrack-aliases data))
;; Handle conjunction subpatterns.
((eq (car subpat) 'and)
(let (expressions)
;; Check for bad structure of SUBPAT here?
(dolist (this-elt (cdr subpat))
(let ((result
(cond*-subpat this-elt cdr-ignore bindings inside-or
backtrack-aliases data)))
(setq bindings (car result))
(push (cdr result) expressions)))
(cons bindings (cond*-and (nreverse expressions)))))
;; Handle disjunction subpatterns.
((eq (car subpat) 'or)
;; The main complexity is unsetting the pattern variables
;; that tentatively match in an or-branch that later failed.
(let (expressions
(bindings-before-or bindings)
(aliases-before-or (cdr backtrack-aliases)))
;; Check for bad structure of SUBPAT here?
(dolist (this-elt (cdr subpat))
(let* ((bindings bindings-before-or)
bindings-to-clear expression
result)
(setq result
(cond*-subpat this-elt cdr-ignore bindings t
backtrack-aliases data))
(setq bindings (car result))
(setq expression (cdr result))
;; Were any bindings made by this arm of the disjunction?
(when (not (eq bindings bindings-before-or))
;; OK, arrange to clear their backtrack aliases
;; if this arm does not match.
(setq bindings-to-clear bindings)
(let (clearing)
;; For each of those bindings, ...
(while (not (eq bindings-to-clear bindings-before-or))
;; ... make an expression to set it to nil, in CLEARING.
(let* ((this-variable (caar bindings-to-clear))
(this-backtrack (assq this-variable
(cdr backtrack-aliases))))
(push `(setq ,(cdr this-backtrack) nil) clearing))
(setq bindings-to-clear (cdr bindings-to-clear)))
;; Wrap EXPRESSION to clear those backtrack aliases
;; if EXPRESSION is false.
(setq expression
(if (null clearing)
expression
(if (null (cdr clearing))
`(or ,expression
,(car clearing))
`(progn ,@clearing))))))
(push expression expressions)))
;; At end of (or...), EACH variable bound by any arm
;; has a backtrack alias gensym. At run time, that gensym's value
;; will be what was bound in the successful arm, or nil.
;; Now make a binding for each variable from its alias gensym.
(let ((aliases (cdr backtrack-aliases)))
(while (not (eq aliases aliases-before-or))
(push `(,(caar aliases) ,(cdar aliases)) bindings)
(pop aliases)))
(cons bindings `(or . ,(nreverse expressions)))))
;; Expand cond*-macro call, treat result as a subpattern.
((get (car subpat) 'cond*-expander)
;; Treat result as a subpattern.
(cond*-subpat (funcall (get (car subpat) 'cond*-expander) subpat)
cdr-ignore bindings inside-or backtrack-aliases data))
((macrop (car subpat))
(cond*-subpat (macroexpand subpat) cdr-ignore bindings inside-or
backtrack-aliases data))
;; Simple constrained variable, as in (symbolp x).
((functionp (car subpat))
;; Without this, nested constrained variables just work.
(unless (symbolp (cadr subpat))
(byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern"))
(let* ((rest-args (cddr subpat))
;; Process VAR to get a binding for it.
(result (cond*-subpat (cadr subpat) cdr-ignore bindings inside-or backtrack-aliases data))
(new-bindings (car result))
(expression (cdr result))
(combined-exp
(cond*-and (list `(,(car subpat) ,data . ,rest-args) expression))))
(cons new-bindings
(cond*-bind-around new-bindings combined-exp))))
;; Generalized constrained variable: (constrain VAR EXP)
((eq (car subpat) 'constrain)
;; Without this, nested constrained variables just work.
(unless (symbolp (cadr subpat))
(byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern"))
;; Process VAR to get a binding for it.
(let ((result
(cond*-subpat (cadr subpat) cdr-ignore bindings inside-or
backtrack-aliases data)))
(cons (car result)
;; This is the test condition.
(cond*-bind-around (car result) (nth 2 subpat)))))
(t
(byte-compile-warn-x subpat "Undefined pattern type `%s' in `cond*'" (car subpat)))))