procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Install cond*

Browse source 
* oond-star.el: New file.
This commit is contained in:
Richard Stallman 2024-08-02 12:03:45 -04:00
parent 80108438e5
commit 18491f48d9
1 changed files with 707 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

707
lisp/emacs-lisp/cond-star.el Normal file
View file

@ -0,0 +1,707 @@
;;; -*-lexical-binding: t; -*-
;; Copyright (C) 1985-2024 Free Software Foundation, Inc.
;; Maintainer: rms@gnu.org
;; Package: emacs
;; This file is part of GNU Emacs. It implements `cond*'.
;; cond* is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; cond* is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;; Here is the list of functions the generated code is known to call:
;; car, cdr, car-safe, cdr-safe, nth, nthcdr, null, eq, equal, eql, =,
;; vectorp, length.
;; It also uses these control and binding promitives:
;; and, or, if, progn, let, let*, setq.
;; For regexp matching only, it can call string-match and match-string.
;;; ??? If a clause starts with a keyword,
;;; should the element after the kwyword be treated in the usual way
;;; as a pattern? Curently `cond*-non-exit-clause-substance' explicitly
;;; prevents that by adding t at the front of its value.
(defmacro cond* (&rest clauses)
"Extended form of traditional Lisp `cond' construct.
A `cond*' construct is a series of clauses, and a clause
normally has the form (CONDITION BDOY...).
CONDITION can be a Lisp expression, as in `cond'.
Or it can be `(bind* BINDINGS...)' or `(match* PATTERN DATUM)'.
`(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*')
for the body of the clause. As a condition, it counts as true
if the first binding's value is non-nil. All the bindings are made
unconditionally for whatever scope they cover.
`(match* PATTERN DATUM)' means to match DATUM against the pattern PATTERN
The condition counts as true if PATTERN matches DATUM.
When a clause's condition is true, and it exits the `cond*'
or is the last clause, the value of the last expression
in its body becomes the return value of the `cond*' construct.
Mon-exit clause:
If a clause has only one element, or if its first element is
t, or if it ends with the keyword :non-exit, then
this clause never exits the `cond*' construct. Instead,
control falls through to the next clause (if any).
The bindings made in CONDITION for the BODY of the non-exit clause
are passed along to the rest of the clauses in this `cond*' construct.
\\[match*\\] for documentation of the patterns for use in `match*'."
(cond*-convert clauses))
(defmacro match* (pattern datum)
"This specifies matching DATUM against PATTERN.
It is not really a LIsp function, and it is meaningful
only in the CONDITION of a `cond*' clause.
`_' matches any value.
KEYWORD matches that keyword.
nil matches nil.
t matches t.
SYMBOL matches any value and binds SYMBOL to that value.
If SYMBOL has been matched and bound earlier in this pattern,
it matches here the same value that it matched before.
REGEXP matches a string if REGEXP matches it.
The match must cover the entire string from its first char to its last.
ATOM (meaning any other kind of non-list not described above)
matches anything `equal' to it.
(rx REGEXP) uses a regexp specified in s-expression form,
as in the function `rx', and matches the data that way.
(rx REGEXP SYM0 SYM1...) uses a regexp specified in s-expression form,
and binds the symbols SYM0, SYM1, and so on
to (match-string 0 DATUM), (match-string 1 DATUM), and so on.
You can use as many SYMs as regexp matching supports.
`OBJECT matches any value `equal' to OBJECT.
(cons CARPAT CDRPAT)
matches a cons cell if CARPAT matches its car and CDRPAT matches its cdr.
(list ELTPATS...)
matches a list if the ELTPATS match its elements.
The first ELTPAT should match the list's first element.
The second ELTPAT should match the list's second element. And so on.
(vector ELTPATS...)
matches a vector if the ELTPATS match its elements.
The first ELTPAT should match the vector's first element.
The second ELTPAT should match the vector's second element. And so on.
(cdr PATTERN) matches PATTERN with strict checking of cdrs.
That means that `list' patterns verify that the final cdr is nil.
Strict checking is the default.
(cdr-safe PATTERN) matches PATTERN with lax checking of cdrs.
That means that `list' patterns do not examine the final cdr.
(and CONJUNCTS...) matches each of the CONJUNCTS against the same data.
If all of them match, this pattern succeeds.
If one CONJUNCT fails, this pattern fails and does not try more CONJUNCTS.
(or DISJUNCTS...) matches each of te DISJUNCTS against the same data.
If one DISJUNCT succeeds, this pattern succeeds
and does not try more DISJUNCTs.
If all of them fail, this pattern fails.
(COND*-EXPANDER ...)
Here the car is a symbol that has a `cond*-expander' property
which defines how to handle it in a pattern. The property value
is a function. Trying to match such a pattern calls that
function with one argument, the pattern in question (including its car).
The function should return an equivalent pattern
to be matched inetead.
(PREDICATE SYMBOL)
matches datum if (PREDICATE DATUM) is true,
then binds SYMBOL to DATUM.
(PREDICATE SYMBOL MORE-ARGS...)
matches datum if (PREDICATE DATUM MORE-ARGS...) is true,
then binds SYMBOL to DATUM.
MORE-ARGS... can refer to symbols bound earlier in the pattern.
(constrain SYMBOL EXP)
matches datum if the form EXP is true.
EXP can refer to symbols bound earlier in the pattern."
(ignore datum)
(byte-compile-warn-x pattern "`match*' used other than as a `cond*' condition"))
(defun cond*-non-exit-clause-p (clause)
"If CLAUSE, a cond* clause, is a non-exit clause, return t."
(or (null (cdr-safe clause)) ;; clause has only one element.
(and (cdr-safe clause)
;; Starts with t.
(or (eq (car clause) t)
;; Begins with keyword.
(keywordp (car clause))))
;; Ends with keyword.
(keywordp (car (last clause)))))
(defun cond*-non-exit-clause-substance (clause)
"For a non-exit cond* clause CLAUSE, return its substance.
This removes a final keyword if that's what makes CLAUSE non-exit."
(cond ((null (cdr-safe clause)) ;; clause has only one element.
clause)
;; Starts with t or a keyword.
;; Include t as the first element of the substancea
;; so that the following element is not treated as a pattern.
((and (cdr-safe clause)
(or (eq (car clause) t)
(keywordp (car clause))))
;; Standardize on t as the first element.
(cons t (cdr clause)))
;; Ends with keyword.
((keywordp (car (last clause)))
;; Do NOT include the final keyword.
(butlast clause))))
(defun cond*-convert (clauses)
"Process a list of cond* clauses, CLAUSES.
Returns the equivalent Lisp expression."
(if clauses
(cond*-convert-clause (car-safe clauses) (cdr-safe clauses))))
(defun cond*-convert-clause (clause rest)
"Process one `cond*' clause, CLAUSE.
REST is the rest of the clauses of this cond* expression."
(if (cond*-non-exit-clause-p clause)
;; Handle a non-exit clause. Make its bindings active
;; around the whole rest of this cond*, treating it as
;; a condition whose value is always t, around the rest
;; of this cond*.
(let ((substance (cond*-non-exit-clause-substance clause)))
(cond*-convert-condition
;; Handle the first substantial element in the non-exit clause
;; as a matching condition.
(car substance)
;; Any following elements in the
;; non-exit clause are just expressions.
(cdr substance)
;; Remaining clauses will be UNCONDIT-CLAUSES:
;; run unconditionally and handled as a cond* body.
rest
nil nil))
;; Handle a normal (conditional exit) clauss.
(cond*-convert-condition (car-safe clause) (cdr-safe clause) nil
rest (cond*-convert rest))))
(defun cond*-convert-condition (condition true-exps uncondit-clauses rest iffalse)
"Process the condition part of one cond* clause.
TRUE-EXPS is a list of Lisp expressions to be executed if this
condition is true, and inside its bindings.
UNCONDIT-CLAUSES is a list of cond*-clauses to be executed if this
condition is true, and inside its bindings.
This is used for non-exit clauses; it is nil for conditional-exit clauses.
REST and IFFALSE are non-nil for conditional-exit clauses that are not final.
REST is a list of clauses to process after this one if
this one could have exited but does not exit.
This is used for conditional exit clauses.
IFFALSE is the value to compute after this one if
this one could have exited but does not exit.
This is used for conditional exit clauses."
(if (and uncondit-clauses rest)
(error "Clause is both exiting and non-exit"))
(let ((pat-type (car-safe condition)))
(cond ((eq pat-type 'bind*)
(let* ((bindings (cdr condition))
(first-binding (car bindings))
(first-variable (if (symbolp first-binding) first-binding
(car first-binding)))
(first-value (if (symbolp first-binding) nil
(cadr first-binding)))
(init-gensym (gensym "init"))
;; BINDINGS with the initial value of the first binding
;; replaced by INIT-GENSYM.
(mod-bindings
(cons (list first-variable init-gensym) (cdr bindings))))
;;; ??? Here pull out all nontrivial initial values
;;; ??? to compute them earlier.
(if rest
;; bind* starts an exiting clause which is not final.
;; Therefore, must run IFFALSE.
`(let ((,init-gensym ,first-value))
(if ,init-gensym
(let* ,mod-bindings
. ,true-exps)
;; Always calculate all bindings' initial values,
;; but the bindings must not cover IFFALSE.
(let* ,mod-bindings nil)
,iffalse))
(if uncondit-clauses
;; bind* starts a non-exit clause which is not final.
;; Run the TRUE-EXPS if condition value is true.
;; Then always go on to run the UNCONDIT-CLAUSES.
(if true-exps
`(let ((,init-gensym ,first-value))
;;; ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES.
;;; as the doc string says, for uniformity with match*?
(let* ,mod-bindings
(when ,init-gensym
. ,true-exps)
,(cond*-convert uncondit-clauses)))
`(let* ,bindings
,(cond*-convert uncondit-clauses)))
;; bind* starts a final clause.
;; If there are TRUE-EXPS, run them if condition succeeded.
;; Always make the bindings, in case the
;; initial values have side effects.
`(let ((,init-gensym ,first-value))
;; Calculate all binding values unconditionally.
(let* ,mod-bindings
(when ,init-gensym
. ,true-exps)))))))
((eq pat-type 'match*)
(cond*-match condition true-exps uncondit-clauses iffalse))
(t
;; Ordinary Lixp expression is the condition
(if rest
;; A nonfinal exiting clause.
;; If condition succeeds, run the TRUE-EXPS.
;; There are following clauses, so run IFFALSE
;; if the condition fails.
`(if ,condition
(progn . ,true-exps)
,iffalse)
(if uncondit-clauses
;; A non-exit clause.
;; If condition succeeds, run the TRUE-EXPS.
;; Then always go on to run the UNCONDIT-CLAUSES.
`(progn (if ,condition
(progn . ,true-exps))
,(cond*-convert uncondit-clauses))
;; An exiting clause which is also final.
;; If there are TRUE-EXPS, run them if CONDITION succeeds.
(if true-exps
`(if ,condition (progn . ,true-exps))
;; Run and return CONDITION.
condition)))))))
(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 unonditional 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 bindigs.
(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)))
(defun cond*-bind-pattern-syms (bindings expr)
"Wrap EXPR in code to bind the BINDINGS.
This is used for the bindings specified explicitly in match* patterns."
;; They can't have side effects. Skip them
;; if we don't actually need them.
(if (equal expr '(progn))
nil
(if bindings
(if (eq (car expr) 'progn)
`(let* ,bindings . ,(cdr expr))
`(let* ,bindings ,expr))
expr)))
(defvar cond*-debug-pattern nil)
;;; ??? 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 matche 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)))))
;;; Subroutines of cond*-subpat.
(defun cond*-bind-around (bindings exp)
"Wrap a `let*' around EXP, to bind those of BINDINGS used in EXP."
(let ((what-to-bind (cond*-used-within bindings exp)))
(if what-to-bind
`(let* ,(nreverse what-to-bind) ,exp)
exp)))
(defun cond*-used-within (bindings exp)
"Return the list of those bindings in BINDINGS which EXP refers to.
This operates naively and errs on the side of overinclusion,
and does not distinguish function names from variable names.
That is safe for the purpose this is used for."
(cond ((symbolp exp)
(let ((which (assq exp bindings)))
(if which (list which))))
((listp exp)
(let (combined (rest exp))
;; Find the bindings used in each element of EXP
;; and merge them together in COMBINED.
;; It would be simpler to use dolist at each level,
;; but this avoids errors from improper lists.
(while rest
(let ((in-this-elt (cond*-used-within bindings (car rest))))
(while in-this-elt
;; Don't insert the same binding twice.
(unless (memq (car-safe in-this-elt) combined)
(push (car-safe in-this-elt) combined))
(pop in-this-elt)))
(pop rest))
combined))))
;; Construct a simplified equivalent to `(and . ,CONJUNCTS),
;; assuming that it will be used only as a truth value.
;; We don't bother checking for nil in CONJUNCTS
;; because that would not normally happen.
(defun cond*-and (conjuncts)
(setq conjuncts (remq t conjuncts))
(if (null conjuncts)
t
(if (null (cdr conjuncts))
(car conjuncts)
`(and . ,conjuncts))))
;; Convert the arguments in a form that calls `backquote-list*'
;; into equivalent args to pass to `list'.
;; We assume the last argument has the form 'LIST.
;; That means quotify each of that list's elements,
;; and preserve the other arguments in front of them.
(defun cond*-un-backquote-list* (args)
(if (cdr args)
(cons (car args)
(cond*-un-backquote-list* (cdr args)))
(mapcar (lambda (x) (list 'quote x)) (cadr (car args)))))