Code for cond*

[Richard Stallman <rms@gnu.org>]

[[[ To any NSA and FBI agents reading my email: please consider    ]]]
[[[ whether defending the US Constitution against all enemies,     ]]]
[[[ foreign or domestic, requires you to follow Snowden's example. ]]]

Here is the first draft of cond*.  I have tested some cases
but I ask others to help in testing it more thoroughly.

I invite constructive comments, bug reports, patches,
and suggestions.

First, here is the draft documentation.


A cond* clause is a "non-exit" clause if it (1) starts with t, (2) has
only one element, or (3) has a keyword as the first or last element.
After a non-exit clause finishes, control proceeds to the following
clause.

All other clauses are like cond clauses, in that when the condition is
true, it executes its clause body and then exits the cond*.

  (cond* 
       ;; Same as a clause in `cond',
       (CONDITION
        DO-THIS-IF-TRUE-THEN-EXIT...)

       ;; Execute FORM, and ignore its value
       ;; (except if this is the last clause).
       (FORM)

       ;; Variables to bind, as in let*, around the rest
       ;; of the cond*.
       ((bind* (x foobar) y z (foo 5) a))
       ;; Bindings continue in effect for the whole cond* construct.

       ;; Bind variables for the clause, as in let*.
       ((bind* (foo 5) (condition (hack-it foo)))
        ;; condition is that the last variable bound be non-nil.
        BODY...)
       ;; Bindings no longer in effect.

       ;; Extracts substructure and binds variables for the clause.
       ((match* `(expt ,foo ,bar) x)
        DO-THIS-IF-IT-MATCHED-THEN-EXIT...)
       ;; Bindings no longer in effect.

       ;; Extracts substructure and binds variables
       ;; for the rest of the cond*.
       ;; Like above but always falls thru to next clause.
       ;; All the variables mentioned in the pattern
       ;; are bound whether match succeeds or not.
       ;; If a value can be determined from an incomplete match,
       ;; the variable gets that value.
       ((match* `(expt ,foo ,bar) x))
       ;; Bindings continue in effect.

       ;; Another example of fall-through match* clause.
       ;; All the variables mentioned in the pattern
       ;; are bound in all cases.
       ((match* (or `() `(,macroexp-const-p const)) body)

;; The `match-set*' is a tentative proposal.  It may not be worth including.
       ;; Extracts substructure and sets variables if match succeeds
       ((match-set* `(expt ,foo ,bar) x)
        DO-THIS-IF-IT-MATCHED-THEN-EXIT...)

       ;; Extracts substructure and sets variables without binding them.
       ;; Always falls thru to next clause.
       ((match-set* `(expt ,foo ,bar) x))
       )

To execute several expressions and not exit, use this:

       ((progn DO-THIS-UNCONDITIONALLY-AND-DONT-STOP...)

To test CONDITION and return its value if non-nil, use this:

       (CONDITION CONDITION)

That is the best way when CONDITION is simple.  When it is complex,
this may be clearer and shorter than repeating CONDITION:

       ((bind* (value CONDITION)) value)
\f
**Possible types of patterns for match*.

CONSTANT: nil, t, a keyword, a quoted constant,
          fixed parts of a backquote.

  This matches any value equal to CONSTANT.

_

  _ means to match any value and not store it anywhere.

VARIABLE: a symbol

  A symbol means to match any value and set VARIABLE to it.

MACRO-CALL: a list which is a call to a macro.

  The macro call will be expanded, then the expansion
  used as a pattern.

A vector

  Each element is a subpattern.  This
  matches a vector of data if each element of that vector is
  matched by the corresponding subpattern.

A backquoted cons cell

  The car and the cdr are subpattenrs.  The cons cell pattern
  matches any cons cell whose car and cdr match those two subpatterns.
  How nil as a cdr matches is controlled by the nil-match-all flag.

  When the nil-match-all flag is false, nil as a cdr matches
  only nil itself.

  When the nil-match-all flag is true, nil as a cdr matches
  any object and ignores that object.

  The nil-match-all flag is false by default.  The `cdr' pattern maks
  it false within its its subpattern, and the `cdr-safe' pattern makes
  it true forwithin its its subpattern.

  The nil-match-all flag has no effect on subpatterns other
  than backquoted cons cells.

(cdr-safe BACKQUOTED-CONS-CELL)

  This pattern is equivalent to BACKQUOTED-CONS-CELL by itself
  except that it makes the nil-match-all flag true within it.

     (cdr-safe `(a b))  matches (a b), (a b c), (a b . d), etc.

  The nil-match-all flag has no effect on subpatterns other
  than backquoted cons cells.

(cdr BACKQUOTED-CONS-CELL)

  This pattern is equivalent to QUOTED-CONS-CELL by itself
  except that it makes the nil-match-all flag false within it.

     (cdr `(a b))  matches only (a b).

A string

  The string is interpreted as a regular expression and can match
  against a data object if the object is a string.

  If you want to match exactly the string `foo', you can write a
  regexp which matches only that string.

     "foo\\>"

  Or you can evaluate (regexp-quote "foo"), add "\>" at the end, and
  copy that string into your pattern.

  Or you can write a constrained variable pattern using the string
  itself, like this:

     (equal foo "xyz")

(rx RX-PATTERN)

  This is another way of specifying a regular expression,
  using the Lisp-like syntax that the `rx' function uses.

(rx RX-PATTERN VARS...)

  Like the basic`rx' pattern except that it binds the variables
  VARS to the matched substrings.  (nth 0 VARS) is bound to
  substring 0 (the whole match),   (nth 0 VARS) is bound to
  substring 1 as specified in RX-PATTERN, and so on.
  Since this is implemented using `string-match', you can't
  use more substrings than `string-match' itself supports.

A backquoted structure constructor

  Each field is a subpattern.  This matches a structure as data if
  each field element of that structure is matched by the corresponding
  subpattern.

  This is not yet implemented.

Alternatives: (or SUBPATTERNS...)

  This tries to match each of the SUBPATTERNS in order until one matches.
  If the pattern is being used to bind variables, it binds all the variables
  specified in any of SUBPATTERNS.

Conjunction: (and SUBPATTERNS...)

  This tries to match each of the SUBPATTERNS in order.  It succeeds
  in matching if every one of the SUBPATTERNS matches.

  If the pattern is being used to bind variables, it binds all the variables
  specified in any of SUBPATTERNS.  If one of the SUBPATTERNS tries to bind
  a variable and that variable has already been bound in thhis patter,
  it insists on the same value.

Constrained variable: (PRED VARIABLE)  or, more generally,
                      (PRED VARIABLE OTHER-ARGS...)

  This matches any value VALUE that satisfies the specified
  constraint.  PRED is a function to test the constraint.  It receives
  VALUE as its first argument.  If PRED returns true, that means VALUE
  satisfies the constraint, so this pattern binds (or sets) VARIABLE
  to that value.  For instance,

     (symbolp sym)   ; Match any symbol, bind `sym' to it.

  If you wish, you can specify additional arguments to pass to PRED.
  The OTHER-ARGS are not patterns to match, they are Lisp expressions
  whose values specify the additional arguments to pass to PRED,
  following the first argument which is VALUE.  In effect, the call
  to PRED looks like this:

      (apply PRED VALUE (mapcar 'eval OTHER-ARGS))

  Here are two examples of passing an additional argument.
 
     (> num-foos 1)  ; Match any number greater than 1, bind `num-foos' to it.
     (>= num-foos min-foos)  ; Match any number not less than MIN-FOOS,
                            ;  bind `num-foos' to it.

  It is often useful to make a conjunction of constrained variable patterns..
  For instance, this matches and binds `num-foos' provided the value to
  match is an integer and not less than min-num-foos.

     (and (integerp num-foos) (>= num-foos min-num-foos))

  When matching to bind variables, the presence of a constrained
  variable pattern, as a subpattern of the overall pattern to be
  matched, unconditionally binds VARIABLE whether the subpattern
  matches or not.

  Errors in constrained variable constructs:

  If an error occurs in testing the constraint, or calculating 
  the other arguments to pass to the predicate, that pattern fails
  to match but does not terminate the cond* form.

General constrained variable: (constrain VAR EXPRESSION)

  This general constrained variable pattern binds VAR to the
  value being matched against, tentatively, then evaluates EXPRESSION.
  If the result is true, the match succeeds and leaves VAR
  bound to that value.

  For instance,

    (constrain x (and (> x 0) (< x 100)))

  succeeds if the value being matched aainst is in the open interval (0, 100),
  and in that case it binds x to that value.

\f
;;; ??? Should use use byte-compile-warn-x.

;; Copyright (C) 1985-2024 Free Software Foundation, Inc.

;; Maintainer: emacs-devel@gnu.org
;; Keywords: abbrev convenience
;; Package: emacs

;; This file is cond*,  not yet part of GNU Emacs.

;; 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/>.

(defmacro cond* (&rest clauses)
;;;??? Doc string will go here.
  (cond*-convert clauses))

(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 test-cond*-non-exit-clause-p ()
  ;; Should return (nil nil t t t t).
  (list
   (cond*-non-exit-clause-p '((memq foo list) (setq foo 1)))
   (cond*-non-exit-clause-p '(nil (setq foo 1)))
   (cond*-non-exit-clause-p '((setq foo 1)))
   (cond*-non-exit-clause-p '(t (setq foo 1)))
   (cond*-non-exit-clause-p '(:non-exit (setq foo 1)))
   (cond*-non-exit-clause-p '((setq foo 1) :non-exit))))

(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 "Clase is both exiting and non-exiting-nil"))
  (let ((pat-type (car-safe condition)))
    (cond ((eq pat-type 'bind*)
           ;; When a bind* needs to be tested as a condition,
           ;; which is whenever that clause has elements after
           ;; the bind* element itself, the condition value
           ;; is the value of the last binding made.
           (let* ((lastbinding
                   ;; The last binding.
                   (car-safe (last condition)))
                  (last-value
                   ;; The initial value specified in the last binding.
                   (if (symbolp lastbinding) nil
                     (car-safe (cdr-safe lastbinding)))))
             (if rest
                 ;; bind* starts an exiting clause which is not final.
                 `(if ,last-value
                      (let* ,(cdr condition)
                        . ,true-exps)
                    ,iffalse)
               (if uncondit-clauses
                   ;; bind* starts a non-exit clause.
                   ;; Run the TRUE-EXPS.
                   ;; Then always go on to run the UNCONDIT-CLAUSES.
                   `(progn
                      (if ,last-value
                          (let* ,(cdr condition)
                            . ,true-exps))
                      (let* ,(cdr condition)
                        ,(cond*-convert uncondit-clauses)))
                 ;; bind* starts an exiting clause which is final.
                 ;; If there are TRUE-EXPS, run them if condition succeeded.
                 ;; Always make the bindings, in case the
                 ;; initial values have side effects.
                 `(if ,last-value
                      (let* ,(cdr condition)
                        . ,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)))))))
\f
(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))))
    (error "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))
         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 backtrack-aliases inner-data))
    (setq expression (cdr raw-result))
    ;; Run TRUE-EXPS if match succeeded.  Bind our bindings around it.
    (setq expression
          `(if ,expression
               ,(if (not (and backtrack-aliases (null uncondit-clauses)))
                    ;; Bind these here if there are no UNCONDIT-CLAUSES.
                    `(let ,(mapcar 'cdr (cdr backtrack-aliases)
                       (let* ,(car raw-result)
                        ,@true-exps)))
                  `(let* ,(car raw-result)
                     ,@true-exps))
             ;; For a non-final exiting clause, run IFFALSE if match failed.
             ;; Don't bind the bindings for following clauses
             ;; 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 
                      (let* ,(car raw-result)
                        ,(cond*-convert uncondit-clauses)))))
    ;; If there are backtrack aliases, bind them around the UNCONDIT-CLAUSES.
    (if (and backtrack-aliases uncondit-clauses)
      (setq expression `(let ,(mapcar 'cdr (cdr backtrack-aliases))
                          ,expression)))
    ;; If we used a gensym, add code to bind it.
    (if gensym
        `(let ((,gensym ,data)) ,expression)
      expression)))

(defun cond*-bind-around (bindings exp)
  "Wrap a `let*' around EXP, to bind those of BINDINGS used in EXP."
  `(let* ,(nreverse (cond*-used-within bindings 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))
           (while rest
             (let ((in-this-elt (cond*-used-within bindings (car rest))))
               (while in-this-elt
                 (unless (assq (car-safe in-this-elt) combined)
                   (push (car-safe in-this-elt) combined))
                 (pop in-this-elt)))
             (pop rest))
           combined))))

;;; ??? Structure type patterns not implemented yet.
;;; ??? Probably should optimize the `nth' calls in handling `list'.

(defun cond*-subpat (subpat cdr-safe bindings backtrack-aliases data)
  "Generate code to match ibe subpattern within `match*'.
SUBPAT is the subpattern to handle.
CDR-SAFE 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 frm (VAR VALUE).
BACKTRACK-ALIASES is used to pass adta uward.  Initial call should
pass (list).  The cdr of this collects backtracking aliases made for
variables boung within (or...) patterns so that the caller
dna bind them etc.
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,"
  (cond ((eq subpat '_)
         ;; _ as pattern makes no bindings and matches any data.
         (cons bindings t))
        ((symbolp subpat)
         ;; Bind or match a symbol to this data
         (let ((this-binding (assq subpat bindings)))
           (if this-binding
               ;; Variable already bound.
               ;; Compare what this variable should be bound to
               ;; to the fata it is supposed to match.
               ;; That is because we don't actually bind thes bindings
               ;; around the condition-testing expression.
               (cons bindings `(equal ,(cdr this-binding) ,data))
             ;; Inside or subpattern, if this symbol already has an alias
             ;; for backtracking, just use that.
             (let ((this-alias (assq subpat (cdr backtrack-aliases))))
               (if this-alias (cdr this-alias)
                 (if backtrack-aliases
                     ;; Inside or subpattern but this symbol has no alias,
                     ;; make one for it.
                     (progn (setcdr backtrack-aliases (cons (cons subpat (gensym "ba"))
                                                            (cdr backtrack-aliases)))
                            ;; Init the binding to symbol's backtrack-alias
                            ;; and set the alias to nil.
                            (cons `((,subpat ,(cdar (cdr backtrack-aliases))) . ,bindings)
                                  t                                  ))
                   (cons `((,subpat ,data) . ,bindings)
                         t)))))))
;;; This is not true any more.
;;;         ;; Actually we bind it to nil at the start of the clause
;;;         ;; and set it to the matched value if it matches.
;;;         (cons `((,subpat nil) . ,bindings)
;;;               `(progn (setq ,subpat ,data) t)))
        ;; Various constants.
        ((numberp subpat)
         (cons bindings `(eql ,subpat ,data)))
        ((keywordp subpat)
         (cons bindings `(eq ,subpat ,data)))
        ((memq subpat '(nil t))
         (cons bindings `(eq ,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)))
         (error "%s subpattern malformed or missing arguments" (car suboat)))
        ;; Regular expressions specified as list structure.
        ;; (rx REGEXP VARS...)
        ((eq (car subpat) 'rx)
         (let* ((rxpat (concat (funcall 'rx (cadr subpat)) "\\>"))
                (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)
                 (error "Too many variables specified for matched substrings"))
             (dolist (elt vars)
               (unless (symbolp elt)
                 (error "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 `equal'.
        ((eq (car subpat) 'quote)
         (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-safe bindings backtrack-aliases `(car ,data)))
           (setq bindings (car car-result)
                 car-exp (cdr car-result))
           (setq cdr-result
                 (cond*-subpat (nth 2 subpat) cdr-safe bindings backtrack-aliases `(cdr ,data)))
           (setq bindings (car cdr-result)
                 cdr-exp (cdr cdr-result))
           (cons bindings
                 `(and ,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-safe bindings backtrack-aliases `(nth ,i ,data))))
               (setq i (1+ i))
               (setq bindings (car result))
               (push (cdr result) expressions)))
           ;; Verify that list ends here, if we are suppose to check that.
           (unless cdr-safe
             (push `(null (nthcdr ,i ,data)) expressions))
           (cons bindings `(and . ,(nreverse expressions)))))
        ;; Match a call to `vector' by destructuring.
        ((eq (car subpat) 'vector)
         (let ((length (length vector)) (vector (cadr subpat))
               (i 0) expressions)
           (dotimes (i length)
             (let* ((this-elt (aref i vector))
                    (result 
                     (cond*-subpat (aref i vector) cdr-safe
                                   bindings backtrack-aliases `(aref ,i ,data))))
               (setq i (1+ i))
               (setq bindings (car result))
               (push (cdr result) expressions)))
           (cons bindings `(and . ,(nreverse expressions)))))
        ;; Subpattern to set the cdr-safe flag
        ((eq (car subpat) 'cdr-safe)
         (cond*-subpat (cadr subpat) t bindings backtrack-aliases data))
        ;; Subpattern to clear the cdr-safe flag
        ((eq (car subpat) 'cdr)
         (cond*-subpat (cadr subpat) nil bindings 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-safe bindings backtrack-aliases data)))
               (setq bindings (car result))
               (push (cdr result) expressions)))
           (cons bindings `(and . ,(nreverse expressions)))))
        ;; Handle disjunction subpatterns.
        ((eq (car subpat) 'or)
         ;; The main complexity is unsetting the pattern variables
         ;; that will not have matched.
         (let (expressions)
           ;; Check for bad structure of SUBPAT here?
           (dolist (this-elt (cdr subpat))
             (let* ((backtrack-aliases-before backtrack-aliases)
                    (result 
                     (cond*-subpat this-elt cdr-safe bindings backtrack-aliases data))
                    (bindings-before-or bindings)
                    bindings-to-clear expression)
               (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)))
           (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-safe bindings backtrack-aliases data))
        ((macrop (car subpat))
         (cond*-subpat (macroexpand subpat) cdr-safe bindings backtrack-aliases data))
        ;; Simple constrained variable, as in (symbolp x).
        ((functionp (car subpat))
         ;; Without this, nested constrained variables just worked.
;;;         (unless (symbolp (cadr subpat))
;;;           (error "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-safe bindings backtrack-aliases data))
                (new-bindings (car result))
                (expression (cdr result))
                (combined-exp
                 `(and (,(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)
         (unless (symbolp (cadr subpat))
           (error "Complex pattern nested in constrained variable pattern"))
         ;; Process VAR to get a binding for it.
         (let ((result (cond*-subpat (cadr subpat) cdr-safe bindings backtrack-aliases data)))
           (cons (car result)
                 ;; This is the test condition 
                 (cond*-bind-around (car result) (nth 2 subpat)))))
        (t (error "Undefined pattern type `%s' in `cond*'" (car subpat)))))

-- 
Dr Richard Stallman (https://stallman.org)
Chief GNUisance of the GNU Project (https://gnu.org)
Founder, Free Software Foundation (https://fsf.org)
Internet Hall-of-Famer (https://internethalloffame.org)