master 18491f48d97: Install cond*

[Richard M. Stallman]

branch: master
commit 18491f48d973c9cbc453d9f742ec7f73e83df3bb
Author: Richard Stallman <rms@gnu.org>
Commit: Richard Stallman <rms@gnu.org>

    Install cond*
    
    * oond-star.el: New file.
---
 lisp/emacs-lisp/cond-star.el | 707 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 707 insertions(+)

diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el
new file mode 100644
index 00000000000..6309b0d1a15
--- /dev/null
+++ b/lisp/emacs-lisp/cond-star.el
@@ -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)))))
+
+
+