├── .gitignore
├── README.md
├── license.txt
├── shadchen.el
└── tests.el


/.gitignore:
--------------------------------------------------------------------------------
1 | .#*
2 | *.elc


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | Shadchen: A pattern matching library
  2 | ====================================
  3 | 
  4 |     shadchen: Noun
  5 |       matchmaker
  6 |     from Yiddish
  7 | 
  8 | (note: there is an emacs lisp port of this library
  9 |  [here][shadchen-el])
 10 | (note: if you are reading this README for the emacs version of the
 11 |  library, keep in mind that emacs symbols are case sensitive.  Symbols
 12 |  are all lowercase in this library.)
 13 | 
 14 | 
 15 | I love pattern-matching, which I find to be a great way to combine
 16 | destructuring data with type-checking when used in dynamic languages.
 17 | If you aren't familiar with how pattern matching works, here is an
 18 | example:
 19 | 
 20 |     (defun second (lst)
 21 |      (match lst 
 22 |       ((cons _ (cons x rest)) x)))
 23 | 
 24 | `MATCH` introduces a pattern matching expression, which takes a value,
 25 | in this case `LST` and a series of lists, whose first elements are
 26 | descriptions of a data structure and whose subsequent elements are
 27 | code to execute if the match succeeds.  Pattern matching takes the
 28 | description of the data and binds the variables that appear therein to
 29 | the parts of the data structure they indicate.  Above, we match `_` to
 30 | the `car` of a list, `x` to the `car` of that list's `cdr`, and `rest`
 31 | to the `cdr` of that list.  
 32 | 
 33 | If we don't pass in a list, the match fails.  (Because of the behavior
 34 | of CL's `car` and `cdr`, which return `NIL` on `NIL`, the form `cons`
 35 | doesn't enforce a length requirement on the input list, and will
 36 | return `NIL` for an empty list.  This corresponds with the fact that
 37 | in Common Lisp `(car nil)` is `nil` and `(cdr nil)` is `nil`.)
 38 | 
 39 | We might instead write:
 40 | 
 41 |     (defun second-of-two (lst)
 42 |       (match lst
 43 |         ((list _ x) x)))
 44 | 
 45 | Which returns the second element of a list _only_ when a two element
 46 | list is passed in.  `MATCH` can take multiple pattern/body sets, in
 47 | which case patterns are tried in order until one pattern matches, and
 48 | the result of evaluating the associated forms is returned.  If no
 49 | patterns match, an error is raised.
 50 | 
 51 | Built-in Patterns
 52 | -----------------
 53 | 
 54 | Shadchen supports the following built-in patterns.
 55 | 
 56 |     <SYMBOL>
 57 | 
 58 | Matches anything, binding <SYMBOL> to that value in the body
 59 | expressions.
 60 | 
 61 |     <KEYWORD-LITERAL> 
 62 | 
 63 | Matches only when the value is the same keyword.
 64 | 
 65 |     <NUMBER-LITERAL>
 66 | 
 67 | Matches only when the value is the same number.
 68 | 
 69 |     <STRING-LITERAL>
 70 | 
 71 | Matches only when the value is `string=` is the same string.	
 72 | 
 73 |     (CONS <PATTERN1> <PATTERN2>)
 74 | 
 75 | Matches any `CONS` cell, or `NIL`, then matches `<PATTERN1>` and
 76 | `<PATTERN2>`, executing the body in a context where their matches are
 77 | bound.  If the match value is NIL, then each `PATTERN` matches against
 78 | NIL.
 79 | 
 80 |     (LIST <P1> ... <PN>)
 81 | 
 82 | One may also write 
 83 | 
 84 |     (LIST <P1> ... <PN> (TAIL <PT>))
 85 | 
 86 | Where the pattern <PT> is matched against the tail of the list.  This
 87 | is an alternative to LIST-REST.
 88 | 
 89 | Matches a list of length N, then matches each pattern `<PN>` to the
 90 | elements of that list.
 91 | 
 92 |     (LIST-REST <P1> ... <PN> <REST-PATTERN)
 93 | 
 94 | Matches <P1> - <PN> to elements in at list, as in the `LIST` pattern.
 95 | The final `<REST-PATTERN>` is matched against the rest of the list.
 96 | 
 97 |     (QUOTE DATUM)
 98 | 
 99 | Only succeeds when `DATUM` is `EQUALP` to the match-value.  Binds no
100 | values.
101 | 
102 |      (AND <P1> .. <PN>)
103 | 
104 | Tests all `<PN>` against the same value, succeeding only when all
105 | patterns match, and binding all variables in all patterns.
106 | 
107 |      (OR <P1> .. <PN>)
108 | 
109 | Tries each `<PN>` in turn, and succeeds if any `<PN>` succeeds.  The
110 | body of the matched expression is then executed with that `<PN>'s`
111 | bindings.  Each sub-pattern in an OR pattern must bind an identical
112 | set of identifiers or an error is raised. 
113 | 
114 |      (? PREDICATE <PATTERN>)
115 | 
116 | Succeeds when `(FUNCALL PREDICATE MATCH-VALUE)` is true and when
117 | `<PATTERN>` matches the value.  Body has the bindings of `<PATTERN>`.  
118 | 
119 |      (FUNCALL FUN <PATTERN>)
120 | 
121 | Applies `FUN` to the match value, then matches `<PATTERN>` against _the
122 | result_.
123 | 
124 |      (MAYBE-FUNCALL FUN PATTERN)
125 | 
126 | Like `FUNCALL` but if the application of `FUN` to the object being
127 | matched against is `*match-fail*` than the match fails, other wise the
128 | match succeeds only when `PATTERN` matches the result.
129 | 
130 |      (BQ EXPR)
131 | 
132 | Matches as if by `BACKQUOTE`.  If `EXPR` is an atom, then this is
133 | equivalent to `QUOTE`.  If `EXPR` is a list, each element is matches
134 | as in `QUOTE`, unless it is an `(UQ <PATTERN>)` form, in which case it
135 | is matched as a pattern.  Eg:
136 | 
137 |     (match (list 1 2 3)
138 |       ((BQ (1 (UQ x) 2)) x)) 
139 | 
140 | Will succeed, binding `X` to 2.  
141 | 
142 |     (match (list 10 2 20)
143 |        ((BQ (1 (UQ x) 2)) x))
144 | 
145 | Will fail, since `10` and `1` don't match.
146 | 
147 |     (values <P1> ... <PN>)
148 | 
149 | Will match multiple values produced by a `(values ...)` form.
150 | 
151 |     (let (n1 v1) (n2 v2) ... (nn vn))
152 | 
153 | Not a pattern matching pattern, per se.  `let` always succeeds and
154 | produces a context where the bindings are active.  This can be used to
155 | provide default alternatives, as in:
156 | 
157 |     (defun non-nil (x) x)
158 | 
159 |     (match (list 1) 
160 |      ((cons hd (or (? #'non-nil tl)
161 |                    (let (tl '(2 3)))))
162 |       (list hd tl)))
163 | 
164 | Will result in `(1 (2 3))` but 
165 | 
166 |     (match (list 1 4) 
167 |      ((cons hd (or (? #'non-nil tl)
168 |                    (let (tl '(2 3)))))
169 |       (list hd tl)))
170 | 
171 | Will produce `(1 (4))`.  Note that a similar functionality can be
172 | provided with `funcall`.
173 | 
174 |     (concat P1 ... PN)
175 | 
176 | Concat is a powerful string matching pattern.  If each pattern is a
177 | string, its behavior is simple: it simply matches the string that is
178 | the concatenation of the pattern strings.  
179 | 
180 | If any of the patterns are a more complex pattern, then, starting from
181 | the left-most pattern, the shortest substring matching the first
182 | pattern is matched, ad then matching proceeds on the subsequent
183 | patterns and the unmatched part of the string.  If this fails, a
184 | longer initial match is searched for.  Eg:
185 | 
186 |     (match "bobcatdog" 
187 |      ((concat 
188 |        (and (or "bobcat" "cat") which) 
189 |        "dog") which))
190 | 
191 | will produce "bobcat", but the pattern will also match "catdog",
192 | returning "cat".
193 | 
194 | This is a handy pattern for simple parsers.
195 | 
196 |     (append P1 ... PN)
197 | 
198 | Like `concat` except for lists rather than strings:
199 | 
200 |     (match
201 |        (number-sequence 1 10)
202 |      ((append (list 1) _ (list y)) y))  => 10
203 | 
204 | the interveening numbers are matched away.
205 | 
206 |     (must-match pattern)
207 | 
208 | This pattern is a bit unusual in that if the value fails to match
209 | `pattern`, then the match will raise an error indicating this fact.
210 | This is useful if you have compound patterns which are strict in some
211 | parts and for which you wish to raise an error, for instance,
212 | 
213 |     (match `(if (< x 10) true-case false-case nonsense)
214 |      ((list 'if (tail (must-match (list a b c))))
215 |       <compile if>))
216 | 
217 | In the above, we assert that _if_ the head of a list is the symbol
218 | `if`, then the tail must consist of three elements and we want to know
219 | about it immediately if a list with head `if` shows up with a
220 | different tail.  
221 | 
222 |     (must-match pattern fail-binding-pattern expression)
223 | 
224 | This is like the pattern above, except in the case that `pattern`
225 | fails to match, `fail-binding-pattern` is matched, and then `expression`
226 | is evaluated and passed to the `error` raising mechanism, coerced to a
227 | string if need be.  We migth write the above as 
228 | 
229 |     (match `(if (< x 10) true-case false-case nonsense)
230 |       ((list 'if (tail (must-match (list a b c) 
231 |                        actual-tail
232 |                        (format 
233 |                         "if should have three arguments, but got %s" 
234 |                         actual-tail))))
235 |        <compile if>))
236 | 
237 | A full shadchen pattern can be used in the fail-binding-pattern, but
238 | usually you are going to provide just a symbol - after all, if the
239 | pattern failed, you don't know much about the value.  
240 | 
241 | Match-let
242 | ---------
243 | 
244 | Match let is a form which behaves identically to a let expression
245 | with two extra features: first, the each variable can be an arbitrary
246 | shadchen pattern and secondly, one can invoke `recur` in any tail
247 | position of the body to induce a trampolined re-entry into the let
248 | expression, so that self-recursive loops can be implemented without
249 | blowing the stack.
250 | 
251 | eg:
252 | 
253 |     (match-let 
254 |      (((list x y) (list 0 0)))
255 |      (if (< (+ x y) 100)
256 |          (recur (list (+ x 1) (+ y x)))
257 |        (list x y)))
258 | 
259 | Will result in `(14 91)`.
260 | 
261 | If you like this feature, please let me know if you would like it to
262 | check that `recur` is in tail position.  This is an expensive step
263 | which requires walking the body after macro-expansion, which may also
264 | introduce subtle bugs.  The upside of doing this is that you avoid the
265 | possibly strange bugs encountered when `recur` is invoked in a
266 | non-tail position.
267 | 
268 | User feedback will vary how I approach this. 
269 | 
270 | defun-match
271 | -----------
272 | 
273 | This special form allows the definition of functions using pattern
274 | matching where bodies can be specified over multiple `defun-match`
275 | invokations:
276 | 
277 | 
278 |     (defun-match- product (nil)
279 |        "The empty product."
280 |        1)
281 |     
282 |     (defun-match product (nil acc)
283 |        "Recursion termination."
284 |        acc)
285 |     
286 |     (defun-match product 
287 |         ((cons (p #'numberp n)
288 |                (p #'listp rest))
289 |          (p #'numberp acc))
290 |        "Main body of the product function."
291 |        (recur rest (* n acc)))
292 |     
293 |     (defun-match product (lst)
294 |        "Calculate the product of the numbers in LST."
295 |        (recur lst 1))
296 | 
297 | Note that different bodies can `recur` to eachother without growing
298 | the stack.  Documentation for each body is accumulated, along with the
299 | pattern associated with the body, into the function's complete
300 | documentation.
301 | 
302 | The argument list of a `defun-match` form is syntactically equivalent
303 | to the body of a `list` pattern, so you can use `(tail pattern)` to
304 | match against the tail of the arguments passed in.
305 | 
306 |   
307 | 
308 | Extending shadchen
309 | ------------------
310 | 
311 | Users can define their own patterns using the `defpattern` form.  For
312 | instance, the behavior of `CONS`, which matches the empty list, may
313 | not be desired.  We can define a match which doesn't have this
314 | behavior as:
315 | 
316 |     (defun non-nil (x) x)
317 |     (defpattern cons* (car cdr)
318 |      `(? #'non-nil (cons ,car ,cdr)))
319 | 
320 | A pattern is a function which takes the arguments passed into the
321 | custom pattern, and expands them into a new pattern in the language of
322 | the built-in pattern-matching.  
323 | 
324 | We can now say:
325 | 
326 |     (match (cons 10 11)
327 |      ((cons* a b) a)) 
328 | 
329 | Which will produce 10, but:
330 | 
331 |     (match nil
332 |      ((cons* a b) a))
333 | 
334 | Will raise a no-match error.  
335 | 
336 | Judicious application of the matchers `AND`, `FUNCALL`, and `?` allow
337 | the definition of arbitrary matchers without exposing the guts of the
338 | matching system.
339 | 
340 | * * *
341 | 
342 |     Copyright 2012, Vincent Toups
343 |     This program is distributed under the terms of the GNU Lesser 
344 |     General Public License (see license.txt).
345 | 
346 | [shadchen-el]:https://github.com/VincentToups/emacs-utils/blob/master/shadchen.el
347 | 
348 | 


--------------------------------------------------------------------------------
/license.txt:
--------------------------------------------------------------------------------
  1 |                    GNU LESSER GENERAL PUBLIC LICENSE
  2 |                        Version 3, 29 June 2007
  3 | 
  4 |  Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
  5 |  Everyone is permitted to copy and distribute verbatim copies
  6 |  of this license document, but changing it is not allowed.
  7 | 
  8 | 
  9 |   This version of the GNU Lesser General Public License incorporates
 10 | the terms and conditions of version 3 of the GNU General Public
 11 | License, supplemented by the additional permissions listed below.
 12 | 
 13 |   0. Additional Definitions.
 14 | 
 15 |   As used herein, "this License" refers to version 3 of the GNU Lesser
 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU
 17 | General Public License.
 18 | 
 19 |   "The Library" refers to a covered work governed by this License,
 20 | other than an Application or a Combined Work as defined below.
 21 | 
 22 |   An "Application" is any work that makes use of an interface provided
 23 | by the Library, but which is not otherwise based on the Library.
 24 | Defining a subclass of a class defined by the Library is deemed a mode
 25 | of using an interface provided by the Library.
 26 | 
 27 |   A "Combined Work" is a work produced by combining or linking an
 28 | Application with the Library.  The particular version of the Library
 29 | with which the Combined Work was made is also called the "Linked
 30 | Version".
 31 | 
 32 |   The "Minimal Corresponding Source" for a Combined Work means the
 33 | Corresponding Source for the Combined Work, excluding any source code
 34 | for portions of the Combined Work that, considered in isolation, are
 35 | based on the Application, and not on the Linked Version.
 36 | 
 37 |   The "Corresponding Application Code" for a Combined Work means the
 38 | object code and/or source code for the Application, including any data
 39 | and utility programs needed for reproducing the Combined Work from the
 40 | Application, but excluding the System Libraries of the Combined Work.
 41 | 
 42 |   1. Exception to Section 3 of the GNU GPL.
 43 | 
 44 |   You may convey a covered work under sections 3 and 4 of this License
 45 | without being bound by section 3 of the GNU GPL.
 46 | 
 47 |   2. Conveying Modified Versions.
 48 | 
 49 |   If you modify a copy of the Library, and, in your modifications, a
 50 | facility refers to a function or data to be supplied by an Application
 51 | that uses the facility (other than as an argument passed when the
 52 | facility is invoked), then you may convey a copy of the modified
 53 | version:
 54 | 
 55 |    a) under this License, provided that you make a good faith effort to
 56 |    ensure that, in the event an Application does not supply the
 57 |    function or data, the facility still operates, and performs
 58 |    whatever part of its purpose remains meaningful, or
 59 | 
 60 |    b) under the GNU GPL, with none of the additional permissions of
 61 |    this License applicable to that copy.
 62 | 
 63 |   3. Object Code Incorporating Material from Library Header Files.
 64 | 
 65 |   The object code form of an Application may incorporate material from
 66 | a header file that is part of the Library.  You may convey such object
 67 | code under terms of your choice, provided that, if the incorporated
 68 | material is not limited to numerical parameters, data structure
 69 | layouts and accessors, or small macros, inline functions and templates
 70 | (ten or fewer lines in length), you do both of the following:
 71 | 
 72 |    a) Give prominent notice with each copy of the object code that the
 73 |    Library is used in it and that the Library and its use are
 74 |    covered by this License.
 75 | 
 76 |    b) Accompany the object code with a copy of the GNU GPL and this license
 77 |    document.
 78 | 
 79 |   4. Combined Works.
 80 | 
 81 |   You may convey a Combined Work under terms of your choice that,
 82 | taken together, effectively do not restrict modification of the
 83 | portions of the Library contained in the Combined Work and reverse
 84 | engineering for debugging such modifications, if you also do each of
 85 | the following:
 86 | 
 87 |    a) Give prominent notice with each copy of the Combined Work that
 88 |    the Library is used in it and that the Library and its use are
 89 |    covered by this License.
 90 | 
 91 |    b) Accompany the Combined Work with a copy of the GNU GPL and this license
 92 |    document.
 93 | 
 94 |    c) For a Combined Work that displays copyright notices during
 95 |    execution, include the copyright notice for the Library among
 96 |    these notices, as well as a reference directing the user to the
 97 |    copies of the GNU GPL and this license document.
 98 | 
 99 |    d) Do one of the following:
100 | 
101 |        0) Convey the Minimal Corresponding Source under the terms of this
102 |        License, and the Corresponding Application Code in a form
103 |        suitable for, and under terms that permit, the user to
104 |        recombine or relink the Application with a modified version of
105 |        the Linked Version to produce a modified Combined Work, in the
106 |        manner specified by section 6 of the GNU GPL for conveying
107 |        Corresponding Source.
108 | 
109 |        1) Use a suitable shared library mechanism for linking with the
110 |        Library.  A suitable mechanism is one that (a) uses at run time
111 |        a copy of the Library already present on the user's computer
112 |        system, and (b) will operate properly with a modified version
113 |        of the Library that is interface-compatible with the Linked
114 |        Version.
115 | 
116 |    e) Provide Installation Information, but only if you would otherwise
117 |    be required to provide such information under section 6 of the
118 |    GNU GPL, and only to the extent that such information is
119 |    necessary to install and execute a modified version of the
120 |    Combined Work produced by recombining or relinking the
121 |    Application with a modified version of the Linked Version. (If
122 |    you use option 4d0, the Installation Information must accompany
123 |    the Minimal Corresponding Source and Corresponding Application
124 |    Code. If you use option 4d1, you must provide the Installation
125 |    Information in the manner specified by section 6 of the GNU GPL
126 |    for conveying Corresponding Source.)
127 | 
128 |   5. Combined Libraries.
129 | 
130 |   You may place library facilities that are a work based on the
131 | Library side by side in a single library together with other library
132 | facilities that are not Applications and are not covered by this
133 | License, and convey such a combined library under terms of your
134 | choice, if you do both of the following:
135 | 
136 |    a) Accompany the combined library with a copy of the same work based
137 |    on the Library, uncombined with any other library facilities,
138 |    conveyed under the terms of this License.
139 | 
140 |    b) Give prominent notice with the combined library that part of it
141 |    is a work based on the Library, and explaining where to find the
142 |    accompanying uncombined form of the same work.
143 | 
144 |   6. Revised Versions of the GNU Lesser General Public License.
145 | 
146 |   The Free Software Foundation may publish revised and/or new versions
147 | of the GNU Lesser General Public License from time to time. Such new
148 | versions will be similar in spirit to the present version, but may
149 | differ in detail to address new problems or concerns.
150 | 
151 |   Each version is given a distinguishing version number. If the
152 | Library as you received it specifies that a certain numbered version
153 | of the GNU Lesser General Public License "or any later version"
154 | applies to it, you have the option of following the terms and
155 | conditions either of that published version or of any later version
156 | published by the Free Software Foundation. If the Library as you
157 | received it does not specify a version number of the GNU Lesser
158 | General Public License, you may choose any version of the GNU Lesser
159 | General Public License ever published by the Free Software Foundation.
160 | 
161 |   If the Library as you received it specifies that a proxy can decide
162 | whether future versions of the GNU Lesser General Public License shall
163 | apply, that proxy's public statement of acceptance of any version is
164 | permanent authorization for you to choose that version for the
165 | Library.
166 | 


--------------------------------------------------------------------------------
/shadchen.el:
--------------------------------------------------------------------------------
   1 | ;;; shadchen.el --- pattern matching for elisp
   2 | 
   3 | ;; Version: 1.4
   4 | ;; Author: Vincent Toups
   5 | ;; Maintainer: Vincent Toups
   6 | ;; Tags: pattern matching, functional programming
   7 | ;; Contributors: Nic Ferrier
   8 | 
   9 | ;;; Copyright 2012, Vincent Toups
  10 | ;;; This program is distributed under the terms of the GNU Lesser 
  11 | ;;; General Public License (see license.txt).
  12 | 
  13 | ;;; Commentary: 
  14 | ;; Shadchen: A pattern matching library
  15 | ;; ====================================
  16 | ;;
  17 | ;;     shadchen: Noun
  18 | ;;       matchmaker
  19 | ;;     from Yiddish
  20 | ;;
  21 | ;; (note: there is an emacs lisp port of this library
  22 | ;;  [here][shadchen-el])
  23 | ;; (note: if you are reading this README for the emacs version of the
  24 | ;;  library, keep in mind that emacs symbols are case sensitive.  Symbols
  25 | ;;  are all lowercase in this library.)
  26 | ;;
  27 | ;;
  28 | ;; I love pattern-matching, which I find to be a great way to combine
  29 | ;; destructuring data with type-checking when used in dynamic languages.
  30 | ;; If you aren't familiar with how pattern matching works, here is an
  31 | ;; example:
  32 | ;;
  33 | ;;     (defun second (lst)
  34 | ;;      (match lst 
  35 | ;;       ((cons _ (cons x rest)) x)))
  36 | ;;
  37 | ;; `MATCH` introduces a pattern matching expression, which takes a value,
  38 | ;; in this case `LST` and a series of lists, whose first elements are
  39 | ;; descriptions of a data structure and whose subsequent elements are
  40 | ;; code to execute if the match succeeds.  Pattern matching takes the
  41 | ;; description of the data and binds the variables that appear therein to
  42 | ;; the parts of the data structure they indicate.  Above, we match `_` to
  43 | ;; the `car` of a list, `x` to the `car` of that list's `cdr`, and `rest`
  44 | ;; to the `cdr` of that list.  
  45 | ;;
  46 | ;; If we don't pass in a list, the match fails.  (Because of the behavior
  47 | ;; of CL's `car` and `cdr`, which return `NIL` on `NIL`, the form `cons`
  48 | ;; doesn't enforce a length requirement on the input list, and will
  49 | ;; return `NIL` for an empty list.  This corresponds with the fact that
  50 | ;; in Common Lisp `(car nil)` is `nil` and `(cdr nil)` is `nil`.)
  51 | ;;
  52 | ;; We might instead write:
  53 | ;;
  54 | ;;     (defun second-of-two (lst)
  55 | ;;       (match lst
  56 | ;;         ((list _ x) x)))
  57 | ;;
  58 | ;; Which returns the second element of a list _only_ when a two element
  59 | ;; list is passed in.  `MATCH` can take multiple pattern/body sets, in
  60 | ;; which case patterns are tried in order until one pattern matches, and
  61 | ;; the result of evaluating the associated forms is returned.  If no
  62 | ;; patterns match, an error is raised.
  63 | ;;
  64 | ;; Built-in Patterns
  65 | ;; -----------------
  66 | ;;
  67 | ;; Shadchen supports the following built-in patterns.
  68 | ;;
  69 | ;;     <SYMBOL>
  70 | ;;
  71 | ;; Matches anything, binding <SYMBOL> to that value in the body
  72 | ;; expressions.
  73 | ;;
  74 | ;;     <KEYWORD-LITERAL> 
  75 | ;;
  76 | ;; Matches only when the value is the same keyword.
  77 | ;;
  78 | ;;     <NUMBER-LITERAL>
  79 | ;;
  80 | ;; Matches only when the value is the same number.
  81 | ;;
  82 | ;;     <STRING-LITERAL>
  83 | ;;
  84 | ;; Matches only when the value is `string=` is the same string.	
  85 | ;;
  86 | ;;     (CONS <PATTERN1> <PATTERN2>)
  87 | ;;
  88 | ;; Matches any `CONS` cell, or `NIL`, then matches `<PATTERN1>` and
  89 | ;; `<PATTERN2>`, executing the body in a context where their matches are
  90 | ;; bound.  If the match value is NIL, then each `PATTERN` matches against
  91 | ;; NIL.
  92 | ;;
  93 | ;;     (LIST <P1> ... <PN>)
  94 | ;;
  95 | ;; Matches a list of length N, then matches each pattern `<PN>` to the
  96 | ;; elements of that list.
  97 | ;;
  98 | ;;     (LIST-REST <P1> ... <PN> <REST-PATTERN>)
  99 | ;;
 100 | ;; Matches <P1> - <PN> to elements in at list, as in the `LIST` pattern.
 101 | ;; The final `<REST-PATTERN>` is matched against the rest of the list.
 102 | ;;
 103 | ;;     (LIST* <P1> ... <PN> <REST-PATTERN>)
 104 | ;;
 105 | ;; LIST* is an alias for LIST-REST.
 106 | ;;
 107 | ;;     (PLIST key <pattern> ...)
 108 | ;; 
 109 | ;; Matches a plist by matching each <pattern> against the key it is paired with.
 110 | ;;
 111 | ;;     (ALIST key <pattern> ...)
 112 | ;; 
 113 | ;; Matches an alist by matching each <pattern> against the key it is paired with.
 114 | ;;
 115 | ;;     (QUOTE DATUM)
 116 | ;;
 117 | ;; Only succeeds when `DATUM` is `EQUALP` to the match-value.  Binds no
 118 | ;; values.
 119 | ;;
 120 | ;;      (AND <P1> .. <PN>)
 121 | ;;
 122 | ;; Tests all `<PN>` against the same value, succeeding only when all
 123 | ;; patterns match, and binding all variables in all patterns.
 124 | ;;
 125 | ;;      (OR <P1> .. <PN>)
 126 | ;;
 127 | ;; Tries each `<PN>` in turn, and succeeds if any `<PN>` succeeds.  The
 128 | ;; body of the matched expression is then executed with that `<PN>'s`
 129 | ;; bindings.  It is up to the user to ensure that the bindings are
 130 | ;; relevant to the body.
 131 | ;;
 132 | ;;      (? PREDICATE <PATTERN>)
 133 | ;;
 134 | ;; Succeeds when `(FUNCALL PREDICATE MATCH-VALUE)` is true and when
 135 | ;; `<PATTERN>` matches the value.  Body has the bindings of `<PATTERN>`.  
 136 | ;;
 137 | ;;      (FUNCALL FUN <PATTERN>)
 138 | ;;
 139 | ;; Applies `FUN` to the match value, then matches `<PATTERN>` against _the
 140 | ;; result_.
 141 | ;;
 142 | ;;      (BQ EXPR)
 143 | ;;
 144 | ;; Matches as if by `BACKQUOTE`.  If `EXPR` is an atom, then this is
 145 | ;; equivalent to `QUOTE`.  If `EXPR` is a list, each element is matches
 146 | ;; as in `QUOTE`, unless it is an `(UQ <PATTERN>)` form, in which case it
 147 | ;; is matched as a pattern.  Eg:
 148 | ;;
 149 | ;;     (match (list 1 2 3)
 150 | ;;       ((BQ (1 (UQ x) 2)) x)) 
 151 | ;;
 152 | ;; Will succeed, binding `X` to 2.  
 153 | ;;
 154 | ;;     (match (list 10 2 20)
 155 | ;;        ((BQ (1 (UQ x) 2)) x))
 156 | ;;
 157 | ;; Will fail, since `10` and `1` don't match.
 158 | ;;
 159 | ;;     (values <P1> ... <PN>)
 160 | ;;
 161 | ;; Will match multiple values produced by a `(values ...)` form.
 162 | ;;
 163 | ;;     (let (n1 v1) (n2 v2) ... (nn vn))
 164 | ;;
 165 | ;; Not a pattern matching pattern, per se.  `let` always succeeds and
 166 | ;; produces a context where the bindings are active.  This can be used to
 167 | ;; provide default alternatives, as in:
 168 | ;;
 169 | ;;     (defun not-nil (x) x)
 170 | ;;
 171 | ;;     (match (list 1) 
 172 | ;;      ((cons hd (or (? #'non-nil tl)
 173 | ;;                    (let (tl '(2 3)))))
 174 | ;;       (list hd tl)))
 175 | ;;
 176 | ;; Will result in `(1 (2 3))` but 
 177 | ;;
 178 | ;;     (match (list 1 4) 
 179 | ;;      ((cons hd (or (? #'non-nil tl)
 180 | ;;                    (let (tl '(2 3)))))
 181 | ;;       (list hd tl)))
 182 | ;;
 183 | ;; Will produce `(1 (4))`.  Note that a similar functionality can be
 184 | ;; provided with `funcall`.
 185 | ;;
 186 | ;;     (concat P1 ... PN)
 187 | ;;
 188 | ;; Concat is a powerful string matching pattern.  If each pattern is a
 189 | ;; string, its behavior is simple: it simply matches the string that is
 190 | ;; the concatenation of the pattern strings.  
 191 | ;;
 192 | ;; If any of the patterns are a more complex pattern, then, starting from
 193 | ;; the left-most pattern, the shortest substring matching the first
 194 | ;; pattern is matched, ad then matching proceeds on the subsequent
 195 | ;; patterns and the unmatched part of the string.  Eg:
 196 | ;;
 197 | ;;     (match "bobcatdog" 
 198 | ;;      ((concat 
 199 | ;;        (and (or "bobcat" "cat") which) 
 200 | ;;        "dog") which))
 201 | ;;
 202 | ;; will produce "bobcat", but the pattern will also match "catdog",
 203 | ;; returning "cat".
 204 | ;;
 205 | ;; This is a handy pattern for simple parsers.
 206 | ;;
 207 | ;;     (append P1 ... PN)
 208 | ;;
 209 | ;; Like `concat` except for lists rather than strings:
 210 | ;;
 211 | ;;     (match
 212 | ;;        (number-sequence 1 10)
 213 | ;;      ((append (list 1) _ (list y)) y))  => 10
 214 | ;;
 215 | ;; the interveening numbers are matched away.
 216 | ;;
 217 | ;; Match-let
 218 | ;; ---------
 219 | ;;
 220 | ;; Match let is a form which behaves identically to a let expression
 221 | ;; with two extra features: first, the each variable can be an arbitrary
 222 | ;; shadchen pattern and secondly, one can invoke `recur` in any tail
 223 | ;; position of the body to induce a trampolined re-entry into the let
 224 | ;; expression, so that self-recursive loops can be implemented without
 225 | ;; blowing the stack.
 226 | ;;
 227 | ;; eg:
 228 | ;;
 229 | ;;     (match-let 
 230 | ;;      (((list x y) (list 0 0)))
 231 | ;;      (if (< (+ x y) 100)
 232 | ;;          (recur (list (+ x 1) (+ y x)))
 233 | ;;        (list x y)))
 234 | ;;
 235 | ;; Will result in `(14 91)`.
 236 | ;;
 237 | ;; If you like this feature, please let me know if you would like it to
 238 | ;; check that `recur` is in tail position.  This is an expensive step
 239 | ;; which requires walking the body after macro-expansion, which may also
 240 | ;; introduce subtle bugs.  The upside of doing this is that you avoid the
 241 | ;; possibly strange bugs encountered when `recur` is invoked in a
 242 | ;; non-tail position.
 243 | ;;
 244 | ;; User feedback will vary how I approach this. 
 245 | ;;
 246 | ;; defun-match
 247 | ;; -----------
 248 | ;;
 249 | ;; This special form allows the definition of functions using pattern
 250 | ;; matching where bodies can be specified over multiple `defun-match`
 251 | ;; invokations:
 252 | ;;
 253 | ;;
 254 | ;;     (defun-match- product (nil)
 255 | ;;        "The empty product."
 256 | ;;        1)
 257 | ;;  
 258 | ;;     (defun-match product (nil acc)
 259 | ;;        "Recursion termination."
 260 | ;;        acc)
 261 | ;;  
 262 | ;;     (defun-match product 
 263 | ;;         ((cons (p #'numberp n)
 264 | ;;                (p #'listp rest))
 265 | ;;          (p #'numberp acc))
 266 | ;;        "Main body of the product function."
 267 | ;;        (recur rest (* n acc)))
 268 | ;;  
 269 | ;;     (defun-match product (lst)
 270 | ;;        "Calculate the product of the numbers in LST."
 271 | ;;        (recur lst 1))
 272 | ;;
 273 | ;; Note that different bodies can `recur` to eachother without growing
 274 | ;; the stack.  Documentation for each body is accumulated, along with the
 275 | ;; pattern associated with the body, into the function's complete
 276 | ;; documentation.
 277 | ;;
 278 | ;;
 279 | ;;
 280 | ;; Extending shadchen
 281 | ;; ------------------
 282 | ;;
 283 | ;; Users can define their own patterns using the `defpattern` form.  For
 284 | ;; instance, the behavior of `CONS`, which matches the empty list, may
 285 | ;; not be desired.  We can define a match which doesn't have this
 286 | ;; behavior as:
 287 | ;;
 288 | ;;     (defun non-nil (x) x)
 289 | ;;     (defpattern cons* (car cdr)
 290 | ;;      `(? #'non-nil (cons ,car ,cdr)))
 291 | ;;
 292 | ;; A pattern is a function which takes the arguments passed into the
 293 | ;; custom pattern, and expands them into a new pattern in the language of
 294 | ;; the built-in pattern-matching.  
 295 | ;;
 296 | ;; We can now say:
 297 | ;;
 298 | ;;     (match (cons 10 11)
 299 | ;;      ((cons* a b) a)) 
 300 | ;;
 301 | ;; Which will produce 10, but:
 302 | ;;
 303 | ;;     (match nil
 304 | ;;      ((cons* a b) a))
 305 | ;;
 306 | ;; Will raise a no-match error.  
 307 | ;;
 308 | ;; Judicious application of the matchers `AND`, `FUNCALL`, and `?` allow
 309 | ;; the definition of arbitrary matchers without exposing the guts of the
 310 | ;; matching system.
 311 | ;;
 312 | ;; * * *
 313 | ;;
 314 | ;;     Copyright 2012, Vincent Toups
 315 | ;;     This program is distributed under the terms of the GNU Lesser 
 316 | ;;     General Public License (see license.txt).
 317 | ;;
 318 | ;; [shadchen-el]:https://github.com/VincentToups/emacs-utils/blob/master/shadchen.el
 319 | ;;
 320 | 
 321 | (require 'cl)
 322 | 
 323 | (defun shadchen:unique-symbols (lst)
 324 |   (let ((seen (list)))
 325 |     (loop for element in lst do 
 326 |          (when (not (memq element seen))
 327 |            (push element seen)))
 328 |     (reverse seen)))
 329 | (defstruct match-fail-struct)
 330 | 
 331 | (setq max-lisp-eval-depth 10000)
 332 | (setq max-specpdl-size 10000)
 333 | 
 334 | (defvar *match-fail* (make-match-fail-struct))
 335 | (lexical-let ((match-fail *match-fail*)) 
 336 |   (defun match-fail-p (o)
 337 |     "T only for the match fail singleton."
 338 |     (eq match-fail o)))
 339 | (defvar *shadchen-binding-mode* :dynamic)
 340 | (defun adjust-let-for-mode (input)
 341 |   (case *shadchen-binding-mode*
 342 |     (:lexical (case input
 343 |                 (let 'lexical-let)
 344 |                 (let* 'lexical-let*)
 345 |                 (t 
 346 |                  (error "adjust-let-for-mode expects let or let*."))))
 347 |     (:dynamic input)))
 348 | 
 349 | (let ((*shadchen-binding-mode* :lexical))
 350 |   (adjust-let-for-mode 'let)) 
 351 | 
 352 | (defun shadchen:replace-colons (o with)
 353 |   (cond ((eq o ':) with)
 354 |         ((listp o) (mapcar (lambda (o)
 355 |                              (shadchen:replace-colons o with)) o))
 356 |         (:otherwise o)))
 357 | 
 358 | (defun shadchen:pprint-to-string (form)
 359 |   "Pretty print form to a string."
 360 |   (let ((sym (gensym)))
 361 |     (replace-regexp-in-string (regexp-quote (format "%s" sym))
 362 |                               ":" 
 363 |                               (with-temp-buffer 
 364 |                                 (cl-prettyprint (shadchen:replace-colons form sym))
 365 |                                 (buffer-substring (point-min) (point-max))))))
 366 | 
 367 | (defun non-keyword-symbol (o)
 368 |   (and (symbolp o)
 369 |        (not (keywordp o))))
 370 | 
 371 | (defun match-list-expander* (sub-expressions match-value body)
 372 |   (cond 
 373 |     ((not sub-expressions) `(if (not ,match-value) (progn ,@body) *match-fail*))
 374 |     ((and (= 1 (length sub-expressions))
 375 |           (listp (car sub-expressions))
 376 |           (eq (car (car sub-expressions)) 'tail))
 377 |      `(match1 ,(cadr (car sub-expressions)) ,match-value ,@body))
 378 |     (:otherwise
 379 |      (let ((first-expression (car sub-expressions))
 380 |            (list-name (gensym "MATCH-LIST-EXPANDER*-")))
 381 |        `(let ((,list-name ,match-value))
 382 |           (if (and (listp ,list-name)
 383 |                    ,list-name)
 384 |               (match1 ,first-expression (car ,list-name)
 385 |                       (match1 (list ,@(cdr sub-expressions)) (cdr ,list-name) 
 386 |                               ,@body))
 387 |               *match-fail*))))))
 388 | 
 389 | (defun match-list-expander (match-expression match-value body)
 390 |   (match-list-expander* (cdr match-expression) match-value body))
 391 | 
 392 | 
 393 | (defun match-cons-expander (match-expression match-value body)
 394 |   (let ((car-match (elt match-expression 1))
 395 |         (cdr-match (elt match-expression 2))
 396 |         (name (gensym "MATCH-CONS-EXPANDER-")))
 397 |     `(let ((,name ,match-value))
 398 |        (if (listp ,name)
 399 |            (match1 ,car-match (car ,name)
 400 |                    (match1 ,cdr-match (cdr ,name)
 401 |                            ,@body))
 402 |            *match-fail*))))
 403 | 
 404 | (defun match-quote-expander (match-expression match-value body)
 405 |   `(if (equalp ,match-expression ,match-value) (progn ,@body) *match-fail*))
 406 | 
 407 | (defun match-backquote-expander (match-expression match-value body)
 408 |   (let ((datum (cadr match-expression)))
 409 |     (cond 
 410 |       ((not datum) `(progn ,@body))
 411 |       ((and (listp datum)
 412 |             (eq (car datum) 'uq))
 413 |        (let ((sub-match (cadr datum)))
 414 |          `(match1 ,sub-match ,match-value ,@body)))
 415 |       ((listp datum)
 416 |        (let ((first-qt (car datum))
 417 |              (rest-bq (cdr datum))
 418 |              (name (gensym "MATCH-BACKQUOTE-EXPANDER-")))
 419 |          `(let ((,name ,match-value))
 420 |             (if (and ,name
 421 |                      (listp ,name))
 422 |                 (match1 (bq ,first-qt) (car ,name)
 423 |                         (match1 (bq ,rest-bq) (cdr ,name) ,@body))
 424 |                 *match-fail*))))
 425 |       (:otherwise 
 426 |        `(match1 ',datum ,match-value ,@body)))))
 427 | 
 428 | (defun match-and-expander* (sub-expressions match-name body)
 429 |   (cond 
 430 |     ((not sub-expressions) `(progn ,@body))
 431 |     (:otherwise 
 432 |      (let ((s1 (car sub-expressions))
 433 |            (name (gensym "MATCH-AND-EXPANDER*-")))
 434 |        `(match1 ,s1 ,match-name 
 435 |                 (match1 (and ,@(cdr sub-expressions)) ,match-name ,@body))))))
 436 | 
 437 | (defun match-and-expander (match-expression match-value body)
 438 |   (let ((name (gensym "MATCH-AND-EXPANDER-")))
 439 |     `(let ((,name ,match-value))
 440 |        ,(match-and-expander* (cdr match-expression) name body))))
 441 | 
 442 | (defun match-?-expander (match-expression match-value body)
 443 |   (let ((name (gensym "MATCH-?-EXPANDER-NAME-"))
 444 |         (f-name (gensym "MATCH-?-EXPANDER-FUNCTION-")))
 445 |     (case (length (cdr match-expression))
 446 |       (0 (error "MATCH1: MATCH-?-EXPANDER: zero arguments to MATCH-?-EXPANDER.  Needs 1 or 2."))
 447 |       (1 `(let ((,name ,match-value)
 448 |                 (,f-name ,(cadr match-expression)))
 449 |             (if (funcall ,f-name ,name) (progn ,@body) *match-fail*)))
 450 |       (2 `(let ((,name ,match-value)
 451 |                 (,f-name ,(cadr match-expression)))
 452 |             (if (funcall ,f-name ,name) (match1 ,(elt match-expression 2) ,name ,@body)
 453 |                 *match-fail*)))
 454 |       (otherwise
 455 |        (error "MATCH-?-EXPANDER: MATCH-?-EXPANDER takes only 1 or 2 arguments.")))))
 456 | 
 457 | (defun match-values-expander (match-expression match-value body)
 458 |   (let ((name (gensym "MATCH-VALUES-EXPANDER-")))
 459 |     `(let ((,name (multiple-value-list ,match-value)))
 460 |        (match1 (list ,@(cdr match-expression)) ,name ,@body))))
 461 | 
 462 | (defun match-funcall-expander (match-expression match-value body)
 463 |   (assert (and (listp match-expression) (= 3 (length match-expression)))
 464 |           (match-expression)
 465 |           "MATCH-FUNCALL-EXPANDER: FUNCALL match expression must have
 466 | two terms, a function and a match against the result.  Got
 467 | %s." match-expression)
 468 |   (let ((name (gensym "MATCH-FUNCALL-EXPANDER-NAME-"))
 469 |         (fun-name (gensym "MATCH-FUNCALL-EXPANDER-FUN-NAME-"))
 470 |         (result-name (gensym "MATCH-FUNCALL-EXPANDER-RESULT-NAME-")))
 471 |     `(let* ((,name ,match-value)
 472 |             (,fun-name ,(cadr match-expression))
 473 |             (,result-name (funcall ,fun-name ,name)))
 474 |        (match1 ,(caddr match-expression) ,result-name ,@body))))
 475 | 
 476 | (defun match-maybe-funcall-expander (match-expression match-value body)
 477 |   (assert (and (listp match-expression) (= 3 (length match-expression)))
 478 |           (match-expression)
 479 |           "MATCH-FUNCALL-EXPANDER: FUNCALL match expression must have
 480 | two terms, a function and a match against the result.  Got
 481 | %s." match-expression)
 482 |   (let ((name (gensym "MATCH-FUNCALL-EXPANDER-NAME-"))
 483 |         (fun-name (gensym "MATCH-FUNCALL-EXPANDER-FUN-NAME-"))
 484 |         (result-name (gensym "MATCH-FUNCALL-EXPANDER-RESULT-NAME-")))
 485 |     `(let* ((,name ,match-value)
 486 |             (,fun-name ,(cadr match-expression))
 487 |             (,result-name (funcall ,fun-name ,name)))
 488 |        (if (eq ,result-name *match-fail*)
 489 |            *match-fail* 
 490 |            (match1 ,(caddr match-expression) ,result-name ,@body)))))
 491 | 
 492 | (defvar *extended-patterns* (make-hash-table) "Holds user declared patterns.")
 493 | (defun extended-patternp (pattern-head) 
 494 |   "Return T if PATTERN-HEAD indicates a user provided pattern."
 495 |   (gethash pattern-head *extended-patterns*))
 496 | 
 497 | (defun match-extended-pattern-expander (match-expression match-value body)
 498 |   (let* ((pattern-args (cdr match-expression))
 499 |          (pattern-fun (gethash (car match-expression) *extended-patterns*))
 500 |          (expansion (apply pattern-fun pattern-args)))
 501 |     `(match1 ,expansion ,match-value ,@body)))
 502 | 
 503 | (defmacro* defpattern (name args &body body)
 504 |   (let ((stub-args (gensym "args")))
 505 |     `(setf (gethash ',name *extended-patterns*)
 506 |            #'(lambda (&rest ,stub-args)
 507 |                (destructuring-bind ,args ,stub-args ,@body)))))
 508 | 
 509 | (defun match-literal-string (match-expression match-value body)
 510 |   `(if (equalp ,match-expression ,match-value) 
 511 |        (progn ,@body)
 512 |        *match-fail*))
 513 | 
 514 | (defun match-literal-number (match-expression match-value body)
 515 |   `(if (equalp ,match-expression ,match-value)
 516 |        (progn ,@body)
 517 |        *match-fail*))
 518 | 
 519 | (defun match-literal-keyword (match-expression match-value body)
 520 |   `(if (equalp ,match-expression ,match-value)
 521 |        (progn ,@body)
 522 |        *match-fail*))
 523 | 
 524 | (defun match-let-expander (match-expression match-value body)
 525 |   `(,(adjust-let-for-mode 'let) ,(cdr match-expression) ,@body))
 526 | 
 527 | ;; (defun match-or-expander (match-expression match-value body)
 528 | ;;   (cond 
 529 | ;;    ((length=1 (cdr match-expression))
 530 | ;;     `(match1 ,(cadr match-expression) ,match-value ,@body))
 531 | ;;    (:otherwise
 532 | ;; 	(let* ((forms (cdr match-expression))
 533 | ;; 		   (form (car forms))
 534 | ;; 		   (rest (cdr forms))
 535 | ;; 		   (nm (gensym "MATCH-OR-EXPANDER-NM-")))
 536 | ;; 	  `(let* ((,nm ,match-value)
 537 | ;; 			  (result (match1 ,form ,nm ,@body)))
 538 | ;; 		 (if (not (eq *match-fail* result))
 539 | ;; 			 result
 540 | ;; 		   (match1 (or ,@rest) ,nm ,@body)))))))
 541 | 
 542 | (defun match-or-expander-unsafe (match-expression match-value body)
 543 |   (let ((-result-holder- (gensym "result-holder-"))
 544 |         (-value-holder- (gensym "value-holder-")))
 545 |     `(let ((,-value-holder- ,match-value)
 546 |            (,-result-holder- *match-fail*))
 547 |        (cond 
 548 |          ,@(loop for pattern in (cdr match-expression) collect
 549 |                 `((progn 
 550 |                     (setq ,-result-holder- 
 551 |                           (match1 ,pattern ,-value-holder- ,@body))
 552 |                     (not (eq ,-result-holder- *match-fail*)))
 553 |                   ,-result-holder-))
 554 |          (:else *match-fail*)))))
 555 | 
 556 | (defun match-or-expander (match-expression match-value body)
 557 |   (assert (apply #'equal-by-binding (cdr match-expression))
 558 |           (match-expression)
 559 |           "Or sub-expressions %S contains sub-forms which do not bind identical sets of symbols.")
 560 |   (match-or-expander-unsafe match-expression match-value body))
 561 | 
 562 | (defun shadchen:mapcat (f lst)
 563 |   "Concatenate the results of applying f to each element in lst."
 564 |   (loop for item in lst append (funcall f item)))
 565 | 
 566 | (defun shadchen:mapcat2 (f lst1 lst2)
 567 |   "Concatenate the results of applying f to each element in lst."
 568 |   (loop for item1 in lst1
 569 |      and item2 in lst2 
 570 |      append (funcall f item1 item2)))
 571 | 
 572 | (defun calc-pattern-bindings-extended (expr)
 573 |   "Calculate the bound symbols of a user defined pattern."
 574 |   (let* ((pattern-args (cdr expr))
 575 |          (pattern-fun (gethash (car expr) *extended-patterns*))
 576 |          (expansion (apply pattern-fun pattern-args)))
 577 |     (calc-pattern-bindings expansion)))
 578 | 
 579 | (defun calc-backquote-bindings (expr)
 580 |   "Calculate the bindings for a backquote expression."
 581 |   (loop for sub in (cdr expr) 
 582 |      when (and (listp sub)
 583 |                (eq (car sub) 'uq))
 584 |      append 
 585 |        (calc-pattern-bindings (cadr sub))))
 586 | 
 587 | (defun calc-pattern-bindings-list (expr &optional acc)
 588 |   (cond ((null expr)
 589 |          acc)
 590 |         ((and (listp expr)
 591 |               (listp (car expr))
 592 |               (eq 'tail (car (car expr))))
 593 |          (append acc (calc-pattern-bindings (cadr (car expr)))))
 594 |         (t
 595 |          (calc-pattern-bindings-list (cdr expr)
 596 |                                      (append (calc-pattern-bindings (car expr)) acc)))))
 597 | 
 598 | (defun calc-pattern-bindings (expr)
 599 |   "Given a shadchen pattern EXPR return a list of symbols bound
 600 | by that expression."
 601 |   (cond 
 602 |     ((non-keyword-symbol expr)
 603 |      (list expr))
 604 |     ((vectorp expr)
 605 |      (calc-pattern-bindings `(list ,@(coerce expr 'list))))
 606 |     ((or (not expr)
 607 |          (symbolp expr)
 608 |          (numberp expr)
 609 |          (stringp expr)) nil)
 610 |     ((extended-patternp (car expr))
 611 |      (calc-pattern-bindings-extended expr))
 612 |     ((listp expr)
 613 |      (case (car expr)
 614 |        (quote nil)
 615 |        ((and values) 
 616 |         (shadchen:mapcat #'calc-pattern-bindings (cdr expr)))
 617 |        (list (calc-pattern-bindings-list (cdr expr)))
 618 |        (cons (append (calc-pattern-bindings (car expr))
 619 |                      (calc-pattern-bindings (cdr expr))))
 620 |        ((? p funcall maybe-funcall) (if (= 2 (length expr)) nil
 621 |                                         (calc-pattern-bindings (elt expr 2))))
 622 |        (or (calc-pattern-bindings (cadr expr)))
 623 |        (bq (calc-backquote-bindings expr))
 624 |        ((! must-match string number keyword non-keyword-symbol) (calc-pattern-bindings (cadr expr)))
 625 |        (one-of (calc-pattern-bindings (cadr expr)))
 626 |        (let (mapcar #'car (cdr expr)))))
 627 |     (:otherwise 
 628 |      (error "calc-pattern-bindings: unrecognized pattern %S." expr))))
 629 | 
 630 | (defun symbol->string-for-sort (s)
 631 |   (symbol-name s))
 632 | 
 633 | (defun canonical-binding-list (l)
 634 |   (sort* (shadchen:unique-symbols l) #'string< :key #'symbol->string-for-sort))
 635 | 
 636 | (defun equal-by-binding2 (p1 p2)
 637 |   (equal (canonical-binding-list 
 638 |           (calc-pattern-bindings p1))
 639 |          (canonical-binding-list 
 640 |           (calc-pattern-bindings p2))))
 641 | 
 642 | (defun equal-by-binding (&rest patterns)
 643 |   (cond 
 644 |     ((= 1 (length patterns)) t)
 645 |     ((= 2 (length patterns))
 646 |      (equal-by-binding2 (car patterns) (cadr patterns)))
 647 |     (t
 648 |      (and (equal-by-binding2 (car patterns) (cadr patterns))
 649 |           (apply #'equal-by-binding (cdr patterns))))))
 650 | 
 651 | (defun match-one-of-expander (match-expr value-expr body)
 652 |   (let ((-result- (gensym "result-"))
 653 |         (-value- (gensym "value-"))
 654 |         (-element- (gensym "element-")))
 655 |     `(let ((,-result- *match-fail*)
 656 |            (,-value- ,value-expr))
 657 |        (when (listp ,-value-)
 658 |          (loop for ,-element- in ,-value- 
 659 |             do 
 660 |               (setq ,-result-
 661 |                     (match1 ,(cadr match-expr) ,-element- ,@body))
 662 |             until 
 663 |               (not (eq *match-fail* ,-result-))))
 664 |        ,-result-)))
 665 | 
 666 | (defun match-vector-expander (match-expr match-val body)
 667 |   (let ((value (gensym)))
 668 |     `(let ((,value ,match-val))
 669 |        (if (vectorp ,value)
 670 |            (match1 (list ,@(coerce match-expr 'list))
 671 |                    (coerce ,value 'list)
 672 |                    ,@body)
 673 |            *match-fail*))))
 674 | 
 675 | (defun must-match-case (match-expr)
 676 |   (cond 
 677 |     ((and (listp match-expr)
 678 |           (= 2 (length match-expr)))
 679 |      :pattern-only)
 680 |     ((and (listp match-expr)
 681 |           (= 4 (length match-expr)))
 682 |      :pattern+)
 683 |     (t :unrecognized)))
 684 | 
 685 | (defun match-must-match-expander (match-expr val-expr body)
 686 |   (case (must-match-case match-expr)
 687 |     (:pattern-only 
 688 |      (destructuring-bind (_ pattern) match-expr
 689 |        (let ((sym (gensym))) 
 690 |          (match-must-match-expander 
 691 |           `(must-match 
 692 |             ,pattern 
 693 |             ,sym 
 694 |             (format ,(format "must-match pattern (%S) failed to match %%S" pattern) 
 695 |                     ,sym))
 696 |           val-expr body))))
 697 |     (:pattern+
 698 |      (destructuring-bind (_ pattern fail-pattern message-expression) match-expr
 699 |        (let ((bound-symbols (calc-pattern-bindings pattern))
 700 |              (value (gensym))
 701 |              (result (gensym)))
 702 |          `(match1 (funcall 
 703 |                    (lambda (,value)
 704 |                      (let ((,result (match1 ,pattern ,value
 705 |                                             (list ,@bound-symbols))))
 706 |                        (if (eq *match-fail* ,result)
 707 |                            (match ,value
 708 |                                   (,fail-pattern (let ((,value ,message-expression))
 709 |                                                    (if (stringp ,value)
 710 |                                                        (error ,value)
 711 |                                                        (error "%S" ,value))))
 712 |                                   (,(gensym)
 713 |                                     (error 
 714 |                                      (format 
 715 |                                       ,(format "must-match pattern (%S) failed and then the failed-value pattern (%S) also failed on value %%S" 
 716 |                                                pattern fail-pattern) 
 717 |                                       ,value))))
 718 |                            ,result)))
 719 |                    (list ,@bound-symbols))
 720 |                   ,val-expr
 721 |                   ,@body))))
 722 |     (t (error "Unrecognized must-match pattern form %S" match-expr))))
 723 | 
 724 | (defmacro* match1 (match-expression match-value &body body)
 725 |   (cond 
 726 |     ((not match-expression)
 727 |      (match-list-expander '(list) match-value body))
 728 |     ((non-keyword-symbol match-expression)
 729 |      `(,(adjust-let-for-mode 'let) ((,match-expression ,match-value))
 730 |         ,@body))
 731 |     ((stringp match-expression) 
 732 |      (match-literal-string match-expression match-value body))
 733 |     ((numberp match-expression)
 734 |      (match-literal-number match-expression match-value body))
 735 |     ((vectorp match-expression)
 736 |      (match-vector-expander match-expression match-value body))
 737 |     ((keywordp match-expression)
 738 |      (match-literal-keyword match-expression match-value body))
 739 |     ((extended-patternp (car match-expression)) 
 740 |      (match-extended-pattern-expander match-expression match-value body))
 741 |     ((listp match-expression)
 742 |      (if match-expression 
 743 |          (case (car match-expression)
 744 |            ((! must-match) (match-must-match-expander match-expression match-value body))
 745 |            (list (match-list-expander match-expression match-value body))
 746 |            (cons (match-cons-expander match-expression match-value body))
 747 |            (quote (match-quote-expander match-expression match-value body))
 748 |            (and (match-and-expander match-expression match-value body))
 749 |            ((? p) (match-?-expander match-expression match-value body))
 750 |            (funcall (match-funcall-expander match-expression match-value body))
 751 |            (maybe-funcall (match-maybe-funcall-expander match-expression match-value body))
 752 |            (or (match-or-expander match-expression match-value body))
 753 |            (bq (match-backquote-expander match-expression match-value body))
 754 |            (let (match-let-expander match-expression match-value body))
 755 |            (values (match-values-expander match-expression match-value body))
 756 |            (one-of (match-one-of-expander match-expression match-value body))
 757 |            (otherwise "MATCH1: Unrecognized match expression: %s." match-expression))
 758 |          (match-list-expander '(list) match-value body)))
 759 |     (:otherwise (error "MATCH1: Unrecognized match expression: %s." match-expression))))
 760 | 
 761 | (defmacro* match-helper (current-match-form value &body forms)
 762 |   (assert (symbolp value)
 763 |           (value)
 764 |           "MATCH-HELPER: VALUE must be a symbol!  Got %s." value)
 765 |   (cond 
 766 |     ((not forms) `(error "No Match for %s in %S!" ,value ',current-match-form))
 767 |     ((listp forms)
 768 |      (let ((first-form (car forms)))
 769 |        (assert (and (listp first-form)
 770 |                     (> (length first-form) 1))
 771 |                (first-form current-match-form)
 772 |                "Each MATCH SUB-FORM must be at least two elements long, a matcher
 773 | and an expression to evaluate on match. Got %S instead (in %S)." 
 774 |                first-form current-match-form)
 775 |        (let ((match-expression (car first-form))
 776 |              (match-body-exprs (cdr first-form))
 777 |              (result-name (gensym "MATCH-HELPER-RESULT-NAME-")))
 778 |          `(let ((,result-name 
 779 |                  (match1 ,match-expression ,value ,@match-body-exprs)))
 780 |             (if (not (eq *match-fail* ,result-name)) ,result-name
 781 |                 (match-helper ,current-match-form ,value ,@(cdr forms)))))))))
 782 | 
 783 | (defvar current-match-form :no-form)
 784 | (defmacro* match (value &body forms)
 785 |   "Attempt to match VALUE against each of the patterns in the CAR of
 786 | FORMS.  When a match is detected, its subsequent forms are executed as
 787 | in a PROGN where the bindings implied by the match are in effect.  
 788 | 
 789 | An error is thrown when no matches are found."
 790 |   (declare (debug (form &rest sexp))(indent 1))
 791 |   (let ((name (gensym "MATCH-VALUE-NAME-"))
 792 |         (current-match-form `(match ,value ,@forms)))
 793 |     `(let ((,name ,value)) 
 794 |        (match-helper ,current-match-form ,name ,@forms))))
 795 | 
 796 | (defmacro* lexical-match (value &body forms)
 797 |   "Attempt to match VALUE against each of the patterns in the CAR of
 798 | FORMS.  When a match is detected, its subsequent forms are executed as
 799 | in a PROGN where the bindings implied by the match are in effect.  
 800 | 
 801 | An error is thrown when no matches are found.  Bindings are
 802 | lexical via cl.el's lexical let.  An alternative is to use Emacs
 803 | 24's lexical binding mode and use regular match."
 804 |   (declare (debug (form &rest sexp)))
 805 |   (let ((*shadchen-binding-mode* :lexical))
 806 |     (macroexpand-all `(match ,value ,@forms))))
 807 | 
 808 | (defmacro* match-lambda (&body forms) 
 809 |   "Like MATCH except the VALUE is curried."
 810 |   (let ((name (gensym "MATCH-LAMBDA-NAME-")))
 811 |     `(function (lambda (,name) (match ,name ,@forms)))))
 812 | 
 813 | (defun length=1 (lst)
 814 |   "Returns T when LST has one element."
 815 |   (and (consp lst)
 816 |        (not (cdr lst))))
 817 | 
 818 | (defun length=0 (lst)
 819 |   "Returns T when LST has one element."
 820 |   (and (consp lst)
 821 |        (not lst)))
 822 | 
 823 | (defpattern list-rest (&rest patterns)
 824 |   (let ((n (length patterns)))
 825 |     (cond ((= n 0) '(list))
 826 |           ((= n 1) `(list (tail ,(car patterns))))
 827 |           (:otherwise
 828 |            `(list ,@(reverse (cdr (reverse (copy-list patterns))))
 829 |                   (tail ,(car (reverse patterns))))))))
 830 | 
 831 | (defpattern list* (&rest pats)
 832 |   `(list-rest ,@pats))
 833 | 
 834 | (defun cl-struct-prepend (s)
 835 |   (intern (format "cl-struct-%s" s)))
 836 | 
 837 | (defun make-cl-struct-accessor (struct-name slot) 
 838 |   (intern (format "%s-%s" struct-name slot)))
 839 | 
 840 | 
 841 | (defpattern struct (struct-name &rest fields)
 842 |   `(and
 843 |     (? #'vectorp)
 844 |     (? #'(lambda (x) (> (length x) 0)))
 845 |     (? #'(lambda (o)
 846 |            (eq (elt o 0) ',(cl-struct-prepend struct-name))))
 847 |     ,@(loop for f in fields collect
 848 |            `(funcall 
 849 |              #',(make-cl-struct-accessor struct-name (car f))
 850 |              ,(cadr f)))))
 851 | 
 852 | (defpattern let1 (symbol value) 
 853 |   `(let (,symbol ,value)))
 854 | 
 855 | (defpattern vector@-no-bounds/type-check (index pattern)
 856 |   `(funcall 
 857 |     #'(lambda (v)
 858 |         (aref v ,index))
 859 |     ,pattern))
 860 | 
 861 | (defpattern vector@ (index pattern)
 862 |   (let ((ix (gensym "vector@-ix"))
 863 |         (v (gensym "vector@-v")))
 864 |     `(and 
 865 |       (? #'vectorp ,v)
 866 |       (let1 ,ix ,index)
 867 |       (? #'(lambda (v)
 868 |              (< (length v) ,ix)))
 869 |       (vector@-no-bounds/type-check ,ix ,v))))
 870 | 
 871 | ;; (defpattern one-of (pattern)
 872 | ;;   `(and
 873 | ;; 	(? #'listp)
 874 | ;; 	(funcall #'length (? (lambda (x) (> x 0))))
 875 | ;; 	(or (funcall #'car ,pattern)
 876 | ;; 		(funcall #'cdr (one-of ,pattern)))))
 877 | 
 878 | (defpattern one-of-two-lists (pattern)
 879 |   `(and
 880 |     (? #'consp)
 881 |     (or (funcall #'car (one-of ,pattern))
 882 |         (funcall #'cdr (one-of ,pattern)))))
 883 | 
 884 | 
 885 | (defun rotate-list (lst)
 886 |   (reverse (cons (car lst) (reverse (cdr (copy-list lst))))))
 887 | 
 888 | (defpattern list% (&rest patterns)
 889 |   (cond
 890 |     ((not patterns) `(? (lambda (x) (eq nil x))))
 891 |     (:otherwise
 892 |      (let ((pattern1 (car patterns))
 893 |            (rest-patterns (cdr patterns)))
 894 |        `(and 
 895 |          (? #'listp)
 896 |          (? (lambda (x) (message (format "%s" x)) (> (length x) 0)))
 897 |          (or 
 898 |           (and
 899 |            (funcall #'car ,pattern1)
 900 |            (funcall #'cdr (list% ,@rest-patterns)))
 901 |           (list% ,@(rotate-list patterns))))))))
 902 | 
 903 | (defpattern list%+ (&rest patterns)
 904 |   (cond
 905 |     ((not patterns) `(? #'listp))
 906 |     (:otherwise
 907 |      (let ((pattern1 (car patterns))
 908 |            (rest-patterns (cdr patterns)))
 909 |        `(and 
 910 |          (? #'listp)
 911 |          (? (lambda (x) (message (format "%s" x)) (> (length x) 0)))
 912 |          (or 
 913 |           (and
 914 |            (funcall #'car ,pattern1)
 915 |            (funcall #'cdr (list% ,@rest-patterns)))
 916 |           (funcall #'rotate-list (list% ,@patterns))))))))
 917 | 
 918 | (defmacro* match-let ((&rest binders) &body body)
 919 |   "Like let but the left-hand-side of each binder pair can be a
 920 | shadchen-pattern.  Within a match-let body, the phrase `(recur
 921 | arg1 ...)  can be used to trigger a trampolined re-entry into the
 922 | match, but only in tail position.  
 923 | 
 924 | At the moment, this is not checked at compile time, so unexpected
 925 | results can occur if `recur` is used in another position.s"
 926 |   (declare (debug (sexp &rest form))(indent 1))
 927 |   (let ((patterns (mapcar #'car binders))
 928 |         (recursion-sigil (gensym "recursion-sigil-"))
 929 |         (recur-args (gensym "recur-args-"))
 930 |         (recur-results (gensym "recur-results-"))
 931 |         (final-result (gensym "final-result-"))
 932 |         (value-expressions
 933 |          (mapcar #'cadr binders)))
 934 |     `(labels ((recur (&rest ,recur-args)
 935 |                 (cons ',recursion-sigil ,recur-args)))
 936 |        (loop with ,recur-results = 
 937 |             (match (list ,@value-expressions)
 938 |                    ((list ,@patterns)
 939 |                     ,@body))
 940 |           while (and (listp ,recur-results)
 941 |                      (eq (car ,recur-results) ',recursion-sigil))
 942 |           do 
 943 |             (setq ,recur-results 
 944 |                   (match (cdr ,recur-results)
 945 |                          ((list ,@patterns)
 946 |                           ,@body)))
 947 |           finally 
 948 |             (return ,recur-results)))))
 949 | 
 950 | (defmacro* match-let* (binders &body body)
 951 |   "Like let* except patterns may appear at any location a binding symbol appears."
 952 |   (declare (indent 1))
 953 |   (cond ((null binders)
 954 |          `(progn ,@body))
 955 |         (t
 956 |          (let* ((first (car binders))
 957 |                 (pattern (car first))
 958 |                 (value-expr (cadr first))
 959 |                 (rest (cdr binders))
 960 |                 (anything-else (gensym)))
 961 |            `(match ,value-expr
 962 |                    (,pattern (match-let* ,rest ,@body))
 963 |                    (,anything-else 
 964 |                     (format "In match-let* %S failed to match pattern %S." ,anything-else ',pattern)))))))
 965 | 
 966 | (defmacro* lexical-match-let ((&rest binders) &body body)
 967 |   "Like let but the left-hand-side of each binder pair can be a
 968 | shadchen-pattern.  Within a match-let body, the phrase `(recur
 969 | arg1 ...)  can be used to trigger a trampolined re-entry into the
 970 | match, but only in tail position.  
 971 | 
 972 | At the moment, this is not checked at compile time, so unexpected
 973 | results can occur if `recur` is used in another position.
 974 | 
 975 | Bindings are lexical via cl.el's lexical-let.  An alternative is
 976 | to use Emacs 24 & >'s lexical binding mode with regular match-let."
 977 |   (declare (indent 1))
 978 |   (let ((patterns (mapcar #'car binders))
 979 |         (recursion-sigil (gensym "recursion-sigil-"))
 980 |         (recur-args (gensym "recur-args-"))
 981 |         (recur-results (gensym "recur-results-"))
 982 |         (final-result (gensym "final-result-"))
 983 |         (value-expressions
 984 |          (mapcar #'cadr binders)))
 985 |     `(labels ((recur (&rest ,recur-args)
 986 |                 (cons ',recursion-sigil ,recur-args)))
 987 |        (loop with ,recur-results = 
 988 |             (lexical-match (list ,@value-expressions)
 989 |                            ((list ,@patterns)
 990 |                             ,@body))
 991 |           while (and (listp ,recur-results)
 992 |                      (eq (car ,recur-results) ',recursion-sigil))
 993 |           do 
 994 |             (setq ,recur-results 
 995 |                   (match (cdr ,recur-results)
 996 |                          ((list ,@patterns)
 997 |                           ,@body)))
 998 |           finally 
 999 |             (return ,recur-results)))))
1000 | 
1001 | (defvar *match-function-table* (make-hash-table))
1002 | (defvar *match-function-doc-table* (make-hash-table))
1003 | (defvar *match-function-name-table* (make-hash-table))
1004 | (defvar *match-defun-compile-debug-messages* nil)
1005 | 
1006 | (defun match-fboundp (symbol)
1007 |   "Returns T when symbol is a function and a match function."
1008 |   (and (fboundp symbol)
1009 |        (gethash symbol *match-function-table*)))
1010 | 
1011 | (defmacro* shadchen:let/named (name bindings &body body)
1012 |   (let ((arg-names (mapcar #'car bindings))
1013 |         (init-vals (mapcar #'cadr bindings))
1014 |         (results (gensym "results-"))
1015 |         (once (gensym "once-"))
1016 |         (done (gensym "done-"))
1017 |         (sigil (gensym "let/named-sigil-")))
1018 |     `(labels ((,once ,arg-names ,@body)
1019 |               (,name ,arg-names 
1020 |                 (list ',sigil ,@arg-names)))
1021 |        (loop with 
1022 |             ,results = (,once ,@init-vals) 
1023 |           while (and (listp ,results)
1024 |                      (eq (car ,results)
1025 |                          ',sigil)) do
1026 |             (setq ,results (apply #',once (cdr ,results)))
1027 |           finally (return ,results)))))
1028 | 
1029 | (defun make-defun-match-unbound (name)
1030 |   "Make the match function represented by the symbol NAME unbound."
1031 |   (puthash name nil *match-function-doc-table*)
1032 |   (puthash name nil *match-function-table*)
1033 |   (let ((names (gethash name *match-function-name-table*)))
1034 |     (loop for f in names do 
1035 |          (fmakunbound f)))
1036 |   (fmakunbound name))
1037 | 
1038 | (defvar *shadchen-recur-sigils* (make-hash-table) "Ensure
1039 | different bodies of the same shadchen pattern function get the
1040 | same recursion markers.")
1041 | 
1042 | (defun get-recur-sigil-for (function-name)
1043 |   "Fetch the recursion sigil for the match function function-name."
1044 |   (let ((s (gethash function-name *shadchen-recur-sigils*)))
1045 |     (if s s
1046 |         (progn
1047 |           (puthash 
1048 |            function-name 
1049 |            (gensym (format "defun-match-recur-sigil-for-%s-" function-name))
1050 |            *shadchen-recur-sigils*)
1051 |           (get-recur-sigil-for function-name)))))
1052 | 
1053 | ;; (defmacro* defun-match- (name pattern &body body)
1054 | ;;   "Identical to defun-match- except makes any previous
1055 | ;; defun-match definitions unbound before defun'ing the function."
1056 | ;;   `(progn 
1057 | ;; 	 (make-defun-match-unbound ',name)
1058 | ;; 	 (defun-match ,name ,pattern ,@body)))
1059 | 
1060 | (defun shadchen:get-doc-from-body (body)
1061 |   (if (stringp (car body)) (car body)
1062 |       ""))
1063 | 
1064 | (defun shadchen:get-body-from-body (body)
1065 |   body)
1066 | 
1067 | (defun shadchen:make-single-pattern-name (name pattern)
1068 |   (intern (replace-regexp-in-string 
1069 |            (rx (or ")" "(" " "))
1070 |            (lambda (m)
1071 |              (cond ((string= m "(") "(")
1072 |                    ((string= m ")") ")")
1073 |                    ((string= m " ") " ")))
1074 |            (format "%s-%S" name pattern))))
1075 | 
1076 | (defun make-match-defun-main-lambda (name patterns)
1077 |   (let ((f-name (gensym "match-sub-fun-"))
1078 |         (result (gensym "match-result-"))
1079 |         (entry-args (gensym (concat (symbol-name name) "-entry-point-arguments-")))
1080 |         (detect-recur (gensym (concat (symbol-name name) "-recur-detector-")))
1081 |         (funs-to-test (gensym "funs-to-test-"))
1082 |         (funs-left-to-test (gensym "funs-left-to-test-")))
1083 |     `(lambda (&rest ,entry-args)
1084 |        (let ((,result *match-fail*)
1085 |              (,funs-to-test (gethash ',name *match-function-table*))
1086 |              (,funs-left-to-test (gethash ',name *match-function-table*))
1087 |              (,f-name nil))
1088 |          (flet ((recur (&rest args)
1089 |                   (cons ',(get-recur-sigil-for name) args))
1090 |                 (,detect-recur (o)
1091 |                   (and (consp o)
1092 |                        (let ((test-result (eq (car o) ',(get-recur-sigil-for name))))
1093 |                          test-result))))
1094 |            ,@(if *match-defun-compile-debug-messages*
1095 |                  `((message "Entering %s." ',name))
1096 |                  nil)
1097 |            (loop while ,funs-left-to-test
1098 |               do
1099 |                 (setq ,f-name (pop ,funs-left-to-test))
1100 |                 ,@(if *match-defun-compile-debug-messages*
1101 |                       `((message "Trying %s against %S." ,f-name ,entry-args))
1102 |                       nil)
1103 |                 (setq ,result (apply ,f-name ,entry-args))
1104 |               when (and (not (match-fail-p ,result))
1105 |                         (not (,detect-recur ,result)))
1106 |               do
1107 |                 ,@(if *match-defun-compile-debug-messages*
1108 |                       `((message "Terminating with %s." ,result))
1109 |                       nil)
1110 |                 (return ,result)
1111 |               when (,detect-recur ,result)
1112 |               do
1113 |                 ,@(if *match-defun-compile-debug-messages*
1114 |                       `((message "Recurring to %s with %s." ',name ,result))
1115 |                       nil)
1116 |                 (setq ,entry-args (cdr ,result))
1117 |                 (setq ,funs-left-to-test ,funs-to-test))
1118 |            (if (match-fail-p ,result)
1119 |                (error "%s: Match failure for arguments: %S." ',name ,entry-args)
1120 |                ,result))))))
1121 | 
1122 | (defmacro* defun-match- (name patterns &body body)
1123 |   (let* ((doc-string (shadchen:get-doc-from-body body))
1124 |          (real-body (shadchen:get-body-from-body body))
1125 |          (compound-name (shadchen:make-single-pattern-name name patterns))
1126 |          (args (gensym (concat "args-" (symbol-name compound-name))))
1127 |          (extended-doc-string (concat (format "%S" patterns) "- " doc-string (format "\n"))))
1128 |     `(progn 
1129 |        (defun ,compound-name (&rest args)
1130 |          ,extended-doc-string 
1131 |          (match1 (list ,@patterns) args  ,@body))
1132 |        (setf (gethash ',name *match-function-table*)
1133 |              (list #',compound-name))
1134 |        (setf (gethash ',name *match-function-doc-table*)
1135 |              ,extended-doc-string)
1136 |        (setf (gethash ',name *match-function-name-table*)
1137 |              (list ',compound-name))
1138 |        (defalias ',name ,(make-match-defun-main-lambda name patterns) 
1139 |          ,extended-doc-string))))
1140 | 
1141 | (defmacro* defun-match (name patterns &body body)
1142 |   (let* ((doc-string (shadchen:get-doc-from-body body))
1143 |          (real-body (shadchen:get-body-from-body body))
1144 |          (compound-name (shadchen:make-single-pattern-name name patterns))
1145 |          (args (gensym (concat "args-" (symbol-name compound-name))))
1146 |          (extended-doc-string (concat (format "%S" patterns) "- " doc-string (format "\n"))))
1147 |     `(progn 
1148 |        (defun ,compound-name (&rest args)
1149 |          ,extended-doc-string 
1150 |          (match1 (list ,@patterns) args  ,@body))
1151 |        (setf (gethash ',name *match-function-table*)
1152 |              (append (gethash ',name *match-function-table*) 
1153 |                      (list #',compound-name)))
1154 |        (setf (gethash ',name *match-function-doc-table*)
1155 |              (concat (gethash ',name *match-function-doc-table*)
1156 |                      (format "\n")
1157 |                      ,extended-doc-string))
1158 |        (setf (gethash ',name *match-function-name-table*)
1159 |              (cons ',compound-name (gethash ',name *match-function-name-table*)))
1160 |        (defalias ',name ,(make-match-defun-main-lambda name patterns) 
1161 |          (gethash ',name *match-function-doc-table*)))))
1162 | 
1163 | 
1164 | (defpattern simple-concat (&rest patterns)
1165 |   (cond 
1166 |     ((length=0 patterns)
1167 |      "")
1168 |     ((length=1 patterns)
1169 |      `(? #'stringp ,(car patterns)))
1170 |     (:otherwise
1171 |      (let* ((the-string (car patterns))
1172 |             (static-len (length the-string)))
1173 |        `(and 
1174 |          (p #'stringp)
1175 |          (p (lambda (s)
1176 |               (>= (length s) ,static-len)))
1177 |          (p 
1178 |           (lambda (s)
1179 |             (string= (substring s 0 ,static-len) ,the-string)))
1180 |          (funcall (lambda (s)
1181 |                     (substring s ,static-len))
1182 |                   (concat ,@(cdr patterns))))))))
1183 | 
1184 | 
1185 | (defpattern full-concat (pivot &rest patterns)
1186 |   (assert (numberp pivot)
1187 |           ()
1188 |           "Pivot should be a number.")
1189 |   (cond 
1190 |     ((length=0 patterns)
1191 |      "")
1192 |     ((length=1 patterns)
1193 |      `(? #'stringp ,(car patterns)))
1194 |     (:otherwise
1195 |      `(and 
1196 |        (p (lambda (s)
1197 |             (>= (length s) ,pivot)))
1198 |        (or 
1199 |         (and (funcall
1200 |               (lambda (s)
1201 |                 (substring s 0 ,pivot))
1202 |               ,(car patterns))
1203 |              (or 
1204 |               (funcall 
1205 |                (lambda (s)
1206 |                  (substring s ,pivot))
1207 |                (concat ,@(cdr patterns)))
1208 |               (full-concat ,(+ pivot 1) ,@patterns)))
1209 |         (full-concat ,(+ pivot 1) ,@patterns))))))
1210 | 
1211 | 
1212 | 
1213 | (defpattern append-helper (head-pattern tail-patterns)
1214 |   `(or 
1215 |     (cons ,head-pattern (append ,@tail-patterns))
1216 |     (and 
1217 |      (p #'(lambda (l) (cdr l)))
1218 |      (funcall 
1219 |       (lambda (p)
1220 |         (let ((candidate (car p))
1221 |               (rest (cdr p)))
1222 |           (cons (reverse (cons (car rest) (reverse candidate)))
1223 |                 (cdr rest))))
1224 |       (append-helper ,head-pattern ,tail-patterns)))))
1225 | 
1226 | (defpattern append (&rest patterns)
1227 |   (cond 
1228 |     ((length=0 patterns) nil)
1229 |     ((length=1 patterns)
1230 |      `(and (p #'listp ,(car patterns))))
1231 |     (:otherwise
1232 |      (let ((hd (car patterns))
1233 |            (rest (cdr patterns)))
1234 |        `(funcall (lambda (l) 
1235 |                    (cons nil l)) (append-helper ,hd ,rest))))))
1236 | 
1237 | (defmacro* match-lambda (&body body)
1238 |   "Produce a lambda accepting a single argument and exectuting
1239 | the matching expression from the body."
1240 |   (let ((arg (gensym "arg-")))
1241 |     `(lambda (,arg)
1242 |        (match ,arg 
1243 |               ,@body))))
1244 | 
1245 | (defmacro* shadchen:sequentially (bindings &body body)
1246 |   "List comprehension monad form."
1247 |   (cond ((null bindings)
1248 |          `(progn ,@body))
1249 |         (:else
1250 |          (let* ((binding (car bindings))
1251 |                 (sym (car binding))
1252 |                 (expr (cadr binding)))
1253 |            `(loop for ,sym in ,expr append 
1254 |                  (shadchen:sequentially ,(cdr bindings) ,@body))))))
1255 | 
1256 | (defun* shadchen:enumerate-segments (len n &optional (offset 0) acc) 
1257 |   (cond 
1258 |     ((= n 0) (reverse acc))
1259 |     ((= n 1) (reverse (cons (list (list offset (- len 1))) acc)))
1260 |     ((= n 2) (loop for i from offset to len collect
1261 |                   (append acc (list (list offset i)
1262 |                                     (list i len)) )))
1263 |     (:else
1264 |      (loop for i from offset to len append
1265 |           (progn 
1266 |             (shadchen:enumerate-segments len (- n 1) i 
1267 |                                          (cons (list offset i) acc)))))))
1268 | 
1269 | (defun shadchen:substrings (string delims)
1270 |   (mapcar (lambda (delim)
1271 |             (substring string (car delim) (cadr delim)))
1272 |           delims))
1273 | 
1274 | (defun shadchen:enumerate-substrings (string n-sub)
1275 |   (let ((segments (shadchen:enumerate-segments (length string) n-sub)))
1276 |     (reverse (mapcar
1277 |               (lambda (segment)
1278 |                 (shadchen:substrings string segment))
1279 |               segments))))
1280 | 
1281 | ;; (defpattern concat (&rest patterns)
1282 | ;;   (cond 
1283 | ;;    ((length=0 patterns)
1284 | ;; 	"")
1285 | ;;    ((length=1 patterns)
1286 | ;; 	`(? #'stringp ,(car patterns)))
1287 | ;;    (:otherwise
1288 | ;; 	(cond 
1289 | ;; 	 ((stringp (car patterns))
1290 | ;; 	  `(simple-concat ,@patterns))
1291 | ;; 	 (:otherwise 
1292 | ;; 	  `(full-concat 0 ,@patterns))))))
1293 | 
1294 | (defpattern concat (&rest patterns)
1295 |   (let ((-string- (gensym "-string-")))
1296 |     `(and (p #'stringp)
1297 |           (funcall
1298 |            (lambda (,-string-)
1299 |              (shadchen:enumerate-substrings ,-string- ,(length patterns)))
1300 |            (one-of (list ,@patterns))))))
1301 | 
1302 | (defun shadchen:non-keyword-symbolp (o)
1303 |   (and (symbolp o)
1304 |        (not (keywordp o))))
1305 | 
1306 | (defpattern keyword (pattern) 
1307 |   `(p #'keywordp ,pattern))
1308 | 
1309 | (defpattern symbol (pattern) 
1310 |   `(p #'symbolp ,pattern))
1311 | 
1312 | (defpattern non-kw-symbol (pattern)
1313 |   `(p #'shadchen:non-keyword-symbolp ,pattern))
1314 | 
1315 | (defpattern string (pattern)
1316 |   `(p #'stringp ,pattern))
1317 | 
1318 | (defpattern number (pattern)
1319 |   `(p #'numberp ,pattern))
1320 | 
1321 | (defpattern equal (value &optional pattern)
1322 |   (let ((arg (gensym "arg")))
1323 |     (if pattern `(p #'(lambda (,arg) (equal ,arg ,value)) ,pattern)
1324 |         `(p #'(lambda (,arg) (equal ,arg ,value))))))
1325 | 
1326 | (defpattern not-equal (value &optional pattern)
1327 |   (let ((arg (gensym "arg")))
1328 |     (if pattern `(p #'(lambda (,arg) (not (equal ,arg ,value))) ,pattern)
1329 |         `(p #'(lambda (,arg) (not (equal ,arg ,value)))))))
1330 | 
1331 | (defpattern non-null (&optional (pattern (gensym)))
1332 |   (let ((arg (gensym)))
1333 |     `(p (lambda (,arg)
1334 |           (not (null ,arg)))
1335 |         ,pattern)))
1336 | 
1337 | (defpattern cons* (car-pattern cdr-pattern)
1338 |   `(p #'consp (cons ,car-pattern ,cdr-pattern)))
1339 | 
1340 | (defstruct monad bind return plus zero)
1341 | (defun copy-monad (m)
1342 |   (make-monad 
1343 |    :bind (monad-bind m)
1344 |    :return (monad-return m)
1345 |    :plus (monad-plus m)
1346 |    :zero (monad-zero m)))
1347 | (defvar monad:id 
1348 |   (make-monad :bind (lambda (x f) (funcall f x))
1349 | 			  :return (lambda (x) x)))
1350 | (defvar *current-monad* monad:id)
1351 | 
1352 | (defun current-monad-bind (mv mf)
1353 |   (funcall (monad-bind *current-monad*) mv mf))
1354 | (defun current-monad-return (v)
1355 |   (funcall (monad-return *current-monad*) v))
1356 | ;;(defun -> (v)
1357 | ;;  (current-monad-return v))
1358 | (defun current-monad-plus (mv1 mv2)
1359 |   (funcall (monad-plus *current-monad*)
1360 | 		   mv1 mv2))
1361 | (defvar current-monad-zero nil)
1362 | 
1363 | (defmacro flet-aliases (binders expressions)
1364 |   (let ((gensyms (mapcar (lambda (_) (gensym)) binders))
1365 | 		(exprs (mapcar (match-lambda 
1366 | 						((list _ expr) expr)) binders))
1367 | 		(names (mapcar (match-lambda
1368 | 						((list name _) name)) binders))
1369 | 		(lets (mapcar* #'list gensyms exprs))
1370 | 		(flets 
1371 | 		 (mapcar* 
1372 | 		  (lambda (name gen-name)
1373 | 			(let ((args (gensym)))
1374 | 			  `(,name (&rest ,args)
1375 | 					  (apply ,gen-name ,args)))))))
1376 | 	`(let ,lets
1377 | 	   (flet ,flets ,@expressions))))
1378 | 
1379 | (defmacro labels-aliases (binders expressions)
1380 |   (let ((gensyms (mapcar (lambda (_) (gensym)) binders))
1381 | 		(exprs (mapcar (match-lambda 
1382 | 						((list _ expr) expr)) binders))
1383 | 		(names (mapcar (match-lambda
1384 | 						((list name _) name)) binders))
1385 | 		(lets (mapcar* #'list gensyms exprs))
1386 | 		(flets 
1387 | 		 (mapcar* 
1388 | 		  (lambda (name gen-name)
1389 | 			(let ((args (gensym)))
1390 | 			  `(,name (&rest ,args)
1391 | 					  (apply ,gen-name ,args)))))))
1392 | 	`(let ,lets
1393 | 	   (labels ,flets ,@expressions))))
1394 | 
1395 | (eval-when (load compile eval) 
1396 |   (defvar shadchen:absent 'e5671794bf87ebab2a0d5e0ded530e68)
1397 |   (defun shadchen:absent (x)
1398 | 	(eq x shadchen:absent))
1399 |   (defun shadchen:not-absent (x)
1400 | 	(not (shadchen:absent x)))
1401 |   (defun-match- shadchen:all-absent (nil)
1402 | 	t)
1403 |   (defun-match shadchen:all-absent ((list hd (tail tl)))
1404 | 	(if (shadchen:absent hd) 
1405 | 		(recur tl)
1406 | 	  nil))
1407 |   (defpattern shadchen:monad-bind (pattern expr)
1408 | 	`(or (list :bind ,pattern ,expr)
1409 | 		 (list ,pattern '<- ,expr)))
1410 |   (defpattern shadchen:monad-let (pattern expr)
1411 | 	`(or (list :let ,pattern ,expr)
1412 | 		 (list ,pattern '= ,expr))))
1413 | 
1414 | (defmacro* monadically-helper (&body expressions)
1415 |   (match expressions
1416 | 		 ((list (shadchen:monad-bind pattern expr) (tail subsequents))
1417 | 		  (let ((val (gensym)))
1418 | 			`(current-monad-bind 
1419 | 			  ,expr
1420 | 			  (lambda (,val)
1421 | 				(match ,val
1422 | 					   (,pattern ,(if subsequents `(monadically-helper ,@subsequents) val))
1423 | 					   (,val (error "monadically pattern <%s> failed to match %s during monadic-bind." ',pattern ,val)))))))
1424 | 		 ((list (shadchen:monad-let pattern expr) (tail subsequents))
1425 | 		  (let ((val (gensym)))
1426 | 			`(match ,expr
1427 | 					((and ,val ,pattern) ,(if subsequents `(monadically-helper ,@subsequents) val))
1428 | 					(,val (error "monadically pattern <%s> failed to match %s during non-monadic bind." ',pattern ,val)))))
1429 | 		 ((list (list :aside (tail expressions)) rest0 (tail rest))
1430 | 		  `(progn ,@expressions
1431 | 				  (monadically-helper ,rest0 ,@rest)))
1432 | 		 ((list expr subsequents0 (tail subsequents))
1433 | 		  (let ((val (gensym)))
1434 | 			`(current-monad-bind ,expr
1435 | 								 (lambda (,val)
1436 | 								   (monadically-helper subsequents0 ,@subsequents)))))
1437 | 		 ((list expr)
1438 | 		  expr)))
1439 | 
1440 | 
1441 | 
1442 | 
1443 | (defmacro* monadically ((&key 
1444 | 						 (monad shadchen:absent) 
1445 | 						 (bind shadchen:absent) 
1446 | 						 (return shadchen:absent) 
1447 | 						 (plus shadchen:absent) 
1448 | 						 (zero shadchen:absent)) 
1449 | 						&body body)
1450 |   (cond 
1451 |    ((shadchen:all-absent (list monad bind return plus zero))
1452 | 	`(symbol-macrolet ((current-monad-zero '(monad-zero *current-monad*))) 
1453 | 	   (monadically-helper ,@body)))
1454 |    (:otherwise 
1455 | 	(let ((-monad (gensym)))
1456 | 	  `(let ((,-monad (copy-monad ,(if (shadchen:absent monad) `*current-monad*
1457 | 									 monad))))
1458 | 		 ,@(if (shadchen:absent bind) nil (list `(setf (monad-bind ,-monad) ,bind)))
1459 | 		 ,@(if (shadchen:absent return) nil (list `(setf (monad-return ,-monad) ,return)))
1460 | 		 ,@(if (shadchen:absent plus) nil (list `(setf (monad-plus ,-monad) ,plus)))
1461 | 		 ,@(if (shadchen:absent zero) nil (list `(setf (monad-zero ,-monad) ,zero)))
1462 | 		 (let ((*current-monad* ,-monad))
1463 | 		   (monadically-helper ,@body)))))))
1464 | 
1465 | (defvar list-monad
1466 |   (make-monad :bind 
1467 | 			  (lambda (mv mf)
1468 | 				(shadchen:mapcat mf mv))
1469 | 			  :return #'list
1470 | 			  :plus #'append
1471 | 			  :zero nil))
1472 | 
1473 | (defun Just (x)
1474 |   `(Just ,x))
1475 | (defun None (&optional reasons)
1476 |   `(None ,reasons))
1477 | 
1478 | (eval-when (load compile eval)
1479 |   (defpattern Just (&optional (pattern (gensym)))
1480 | 	`(list 'Just ,pattern))
1481 |   (defpattern None (&optional (pattern (gensym)))
1482 | 	`(list 'None ,pattern)))
1483 | 
1484 | (defvar maybe-monad 
1485 |   (make-monad :bind (lambda (mv mf)
1486 | 					  (match mv 
1487 | 							 ((Just value)
1488 | 							  (funcall mf value))
1489 | 							 ((None reason)
1490 | 							  mv)))
1491 | 			  :return (lambda (v) (Just v))
1492 | 			  :plus (lambda (mv1 mv2)
1493 | 					  (match mv1
1494 | 							 ((Just value)
1495 | 							  mv2)
1496 | 							 ((None reason)
1497 | 							  mv1)))
1498 | 			  :zero (None)))
1499 | 
1500 | (defun shadchen:kw->symbol (k)
1501 |   (assert (keywordp k))
1502 |   (intern (substring (symbol-name k) 1)))
1503 | 
1504 | (eval-when (compile load eval) (defpattern keys (&rest kp-pairs)
1505 |   (let ((db-expr '(&key))
1506 | 		(bound-symbols nil)
1507 | 		(patterns nil)
1508 | 		(datum (gensym "datum"))) 
1509 | 	(loop for (k p . rest) on kp-pairs by #'cddr
1510 | 		  do
1511 | 		  (let ((temp (gensym "temp"))
1512 | 				(key-as-sym (shadchen:kw->symbol k)))
1513 | 			(setq bound-symbols (append bound-symbols (list key-as-sym)))
1514 | 			(setq db-expr (append db-expr (list key-as-sym)))
1515 | 			(setq patterns (append patterns (list p)))))
1516 | 	`(maybe-funcall 
1517 | 	  (lambda (,datum)
1518 | 		(condition-case nil 
1519 | 			(destructuring-bind ,db-expr ,datum
1520 | 			  (list ,@bound-symbols))
1521 | 		  (error *match-fail*)))
1522 | 	  (list ,@patterns)))))
1523 | 
1524 | 
1525 | ;; A few obvious EmacsLisp extras
1526 | 
1527 | (defun shadchen/extract (key type)
1528 |   "Return a func to extract KEY from TYPE. 
1529 | 
1530 | TYPE is either `:alist' or `:plist'."
1531 |   (lexical-let ((typ type)
1532 |                 (k key))
1533 |     (lambda (kvlist)
1534 |       (case typ
1535 |         (:struct (apply (symbol-function k) (list kvlist)))
1536 |         (:plist (plist-get kvlist k))
1537 |         (:alist (cdr-safe (assoc k kvlist)))))))
1538 | 
1539 | (defpattern plist (&rest kv-pairs) 
1540 |   `(and ,@(loop for (k v . rest) on kv-pairs by #'cddr
1541 |              collect
1542 |                `(funcall (shadchen/extract ,k :plist) ,v))))
1543 | 
1544 | (defpattern alist (&rest kv-pairs)
1545 |   `(and ,@(loop for (k v . rest) on kv-pairs by #'cddr
1546 |              collect
1547 |                `(funcall (shadchen/extract ,k :alist) ,v))))
1548 | 
1549 | 
1550 | (defun shadchen/struct-field (struct field)
1551 |   "Helper to access FIELD in STRUCT."
1552 |   (concat (symbol-name struct) "-" (symbol-name field)))
1553 | 
1554 | (defpattern struct (name &rest accessor-pairs)
1555 |   `(and (? (lambda (v)
1556 |              (eq (aref v 0)
1557 |                  (intern (concat "cl-struct-" ,(symbol-name name))))) _)
1558 |         ,@(loop for (k v . rest) on accessor-pairs by #'cddr
1559 |              collect
1560 |                `(funcall (shadchen/extract
1561 |                           ,(shadchen/struct-field name k) :struct)
1562 |                          ,v))))
1563 | 
1564 | (provide 'shadchen)
1565 | 
1566 | ;;; shadchen.el ends here
1567 | 


--------------------------------------------------------------------------------
/tests.el:
--------------------------------------------------------------------------------
  1 | ;;; tests.el --- tests for shadchen.el
  2 | 
  3 | (require 'shadchen)
  4 | (require 'ert)
  5 | 
  6 | 
  7 | (ert-deftest shadchen-symbol-match-failed ()
  8 |   "Test symbol matching."
  9 |   (assert 
 10 |    (equal 
 11 |     10
 12 |     (match 10
 13 |            (x x)))
 14 |    ()
 15 |    "symbol match failed."))
 16 | 
 17 | (ert-deftest shadchen-match-string ()
 18 |   "Match a string."
 19 |   (should
 20 |    (equal "test"
 21 |           (match "test"
 22 |                  ("test" "test")))))
 23 | 
 24 | (ert-deftest shadchen-match-string-failed ()
 25 |   "Match a string fails."
 26 |   (assert 
 27 |    (equal :fail
 28 |           (match "test"
 29 |                  ("dog" :pass)
 30 |                  (_ :fail)))))
 31 | 
 32 | (ert-deftest shadchen-match-list ()
 33 |   "Matching a list."
 34 |   (assert 
 35 |    (equal 
 36 |     (list 1 2 3)
 37 |     (match (list 1 2 3)
 38 |            ((list x y z)
 39 |             (list x y z))))))
 40 | 
 41 | 
 42 | ;; lexical
 43 | 
 44 | (ert-deftest shadchen-match-lexically ()
 45 |   "lexical-match symbol"
 46 |   (should
 47 |    (equal 10
 48 |           (let 
 49 |               ((f 
 50 |                 (lexical-match 10 
 51 |                                (x 
 52 |                                 (lambda ()
 53 |                                   x)))))
 54 |             (funcall f)))))
 55 | 
 56 | 
 57 | (defun-match- test-product (nil acc)
 58 |   "Return the accumulator."
 59 |   acc)
 60 | 
 61 | (defun-match test-product ((list-rest hd tl) acc)
 62 |   "Recur, mult. the acc by the hd."
 63 |   (recur tl (* hd acc)))
 64 | 
 65 | (defun-match test-product (lst)
 66 |   "Entry-point: find the product of the numbers in LST."
 67 |   (recur lst 1))
 68 | 
 69 | (make-defun-match-unbound 'test-product)
 70 | (fmakunbound 'test-product)
 71 | (setf (symbol-function 'test-product) nil)
 72 | 
 73 | (test-product (list 1 2 3))
 74 | (eq (get-recur-sigil-for 'x) (get-recur-sigil-for 'x))
 75 | 
 76 | 
 77 | ;; Alists and Plists
 78 | 
 79 | (ert-deftest shadchen-match-plist ()
 80 |   "Show plist matching working."
 81 |   (assert
 82 |    (equal
 83 |     (match '(:one 1 :two 2 :three 3)
 84 |      ((plist :two a) a))
 85 |     2))) ; because that's the value of :two in the plist
 86 | 
 87 | (ert-deftest shadchen-match-alist ()
 88 |   "Show alist matching working."
 89 |   (assert
 90 |    (equal
 91 |     (match '((a . 1)(b . 2)(c . 3))
 92 |       ((alist 'c a) a))
 93 |     3))) ; because that's the value of 'c in the alist
 94 | 
 95 | (ert-deftest shadchen-match-struct ()
 96 |   ;; First define a struct
 97 |   (defstruct shadchen-testpat name version address)
 98 |   ;; Now let's test a struct object match with shadchen
 99 |   (equal 
100 |    (let ((struct-obj (make-shadchen-testpat
101 |                       :name "test1"
102 |                       :version "0.0.1"
103 |                       :address "test1.example.com")))
104 |      (match struct-obj
105 |        ((struct shadchen-testpat
106 |                 name name
107 |                 version v) (list name v))))
108 |    (list "test1" "0.0.1")))
109 | 
110 | 
111 | 
112 | ;;; Example tests
113 | 
114 | (ert-deftest shadchen-funcall-find-if-example ()
115 |   "A good example of using `find-if' with funcall."
116 |   ;; We want to match only the first string element from the list...
117 |   (should
118 |    (equal
119 |     (match
120 |      `(1 2 sym "a string" 2 3 4)
121 |      ((funcall (lambda (l) (find-if 'stringp l)) a) a))
122 |     "a string")))
123 | 
124 | ;;; tests.el ends here
125 | 


--------------------------------------------------------------------------------