From: Richard Stallman Date: Fri, 2 Aug 2024 16:03:45 +0000 (-0400) Subject: Install cond* X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=7cd37ca6f489358ebc4f2117e9c8ec341cc837cd;p=emacs.git Install cond* * oond-star.el: New file. (cherry picked from commit 18491f48d973c9cbc453d9f742ec7f73e83df3bb) --- 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 . + +;; 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))))) + + +