├── .gitignore
├── README.md
├── license.txt
├── package.lisp
├── scratch.lisp
├── shadchen.asd
├── shadchen.asd~
├── shadchen.lisp
└── tests.lisp


/.gitignore:
--------------------------------------------------------------------------------
1 | *.fasl
2 | 


--------------------------------------------------------------------------------
/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 |     _
 57 | 
 58 | Matches anything, but no bindings are made.
 59 | 
 60 |     <SYMBOL>
 61 | 
 62 | Matches anything, binding <SYMBOL> to that value in the body
 63 | expressions.
 64 | 
 65 |     <KEYwORD-LITERAL> 
 66 | 
 67 | Matches only when the value is the same keyword.
 68 | 
 69 |     <NUMBER-LITERAL>
 70 | 
 71 | Matches only when the value is the same number.
 72 | 
 73 |     <STRING-LITERAL>
 74 | 
 75 | Matches only when the value is `string=` is the same string.	
 76 | 
 77 |     (CONS <PATTERN1> <PATTERN2>)
 78 | 
 79 | Matches any `CONS` cell, or `NIL`, then matches `<PATTERN1>` and
 80 | `<PATTERN2>`, executing the body in a context where their matches are
 81 | bound.  If the match value is NIL, then each `PATTERN` matches against
 82 | NIL.
 83 | 
 84 |     (LIST <P1> ... <PN>)
 85 | 
 86 | Matches a list of length N, then matches each pattern `<PN>` to the
 87 | elements of that list.
 88 | 
 89 |     (LIST-REST <P1> ... <PN> <REST-PATTERN)
 90 | 
 91 | Matches <P1> - <PN> to elements in at list, as in the `LIST` pattern.
 92 | The final `<REST-PATTERN>` is matched against the rest of the list.
 93 | 
 94 |     (QUOTE DATUM)
 95 | 
 96 | Only succeeds when `DATUM` is `EQUALP` to the match-value.  Binds no
 97 | values.
 98 | 
 99 |      (AND <P1> .. <PN>)
100 | 
101 | Tests all `<PN>` against the same value, succeeding only when all
102 | patterns match, and binding all variables in all patterns.
103 | 
104 |      (OR <P1> .. <PN>)
105 | 
106 | Tries each `<PN>` in turn, and succeeds if any `<PN>` succeeds.  The
107 | body of the matched expression is then executed with that `<PN>'s`
108 | bindings.  Each sub-pattern in an OR must bind an identical set of
109 | symbols or an error will be raised at compile time.
110 | 
111 |      (? PREDICATE <PATTERN>)
112 | 
113 | Succeeds when `(FUNCALL PREDICATE MATCH-VALUE)` is true and when
114 | `<PATTERN>` matches the value.  Body has the bindings of `<PATTERN>`.  
115 | 
116 |      (FUNCALL FUN <PATTERN>)
117 | 
118 | Applies `FUN` to the match value, then matches `<PATTERN>` against _the
119 | result_.
120 | 
121 |      (BQ EXPR)
122 | 
123 | Matches as if by `BACKQUOTE`.  If `EXPR` is an atom, then this is
124 | equivalent to `QUOTE`.  If `EXPR` is a list, each element is matches
125 | as in `QUOTE`, unless it is an `(UQ <PATTERN>)` form, in which case it
126 | is matched as a pattern.  Eg:
127 | 
128 |     (match (list 1 2 3)
129 |       ((BQ (1 (UQ x) 2)) x)) 
130 | 
131 | Will succeed, binding `X` to 2.  
132 | 
133 |     (match (list 10 2 20)
134 |        ((BQ (1 (UQ x) 2)) x))
135 | 
136 | Will fail, since `10` and `1` don't match.
137 | 
138 |     (values <P1> ... <PN>)
139 | 
140 | Will match multiple values produced by a `(values ...)` form.
141 | 
142 |     (let (n1 v1) (n2 v2) ... (nn vn))
143 | 
144 | Not a pattern matching pattern, per se.  `let` always succeeds and
145 | produces a context where the bindings are active.  This can be used to
146 | provide default alternatives, as in:
147 | 
148 |     (defun non-nil (x) x)
149 | 
150 |     (match (list 1) 
151 |      ((cons hd (or (? #'non-nil tl)
152 |                    (let (tl '(2 3)))))
153 |       (list hd tl)))
154 | 
155 | Will result in `(1 (2 3))` but 
156 | 
157 |     (match (list 1 4) 
158 |      ((cons hd (or (? #'non-nil tl)
159 |                    (let (tl '(2 3)))))
160 |       (list hd tl)))
161 | 
162 | Will produce `(1 (4))`.  Note that a similar functionality can be
163 | provided with `funcall`.
164 | 
165 | 
166 | Extending shadchen
167 | ------------------
168 | 
169 | Users can define their own patterns using the `defpattern` form.  For
170 | instance, the behavior of `CONS`, which matches the empty list, may
171 | not be desired.  We can define a match which doesn't have this
172 | behavior as:
173 | 
174 |     (defun non-nil (x) x)
175 |     (defpattern cons* (car cdr)
176 |      `(? #'non-nil (cons ,car ,cdr)))
177 | 
178 | A pattern is a function which takes the arguments passed into the
179 | custom pattern, and expands them into a new pattern in the language of
180 | the built-in pattern-matching.  
181 | 
182 | We can now say:
183 | 
184 |     (match (cons 10 11)
185 |      ((cons* a b) a)) 
186 | 
187 | Which will produce 10, but:
188 | 
189 |     (match nil
190 |      ((cons* a b) a))
191 | 
192 | Will raise a no-match error.  
193 | 
194 | Judicious application of the matchers `AND`, `FUNCALL`, and `?` allow
195 | the definition of arbitrary matchers without exposing the guts of the
196 | matching system.
197 | 
198 | * * *
199 | 
200 |     Copyright 2012, Vincent Toups
201 |     This program is distributed under the terms of the GNU Lesser 
202 |     General Public License (see license.txt).
203 | 
204 | [shadchen-el]:https://github.com/VincentToups/emacs-utils/blob/master/shadchen.el
205 | 
206 | 


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


--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; package.lisp
 2 | 
 3 | (defpackage #:shadchen
 4 |   (:nicknames :s?)
 5 |   (:export :? :bq :p :list-rest :hash-table :struct :let1 
 6 | 		   :must-match :! :defun-match :defun-match-
 7 | 		   :match :match-lambda :defpattern
 8 | 		   :match-let :match-let* :match-loop
 9 | 		   :tail :number :symbol :string :keyword
10 | 		   :_ :-ignore- :ignore :list*)
11 |   (:use #:cl))
12 | 
13 | 
14 | 
15 | 
16 | 


--------------------------------------------------------------------------------
/scratch.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; shadchen.lisp
 2 | 
 3 | ;;; Copyright 2012, Vincent Toups
 4 | ;;; This program is distributed under the terms of the GNU Lesser 
 5 | ;;; General Public License (see license.txt).
 6 | 
 7 | (in-package #:shadchen)
 8 | 
 9 | 
10 | (defun non-nil (x) x)
11 | 
12 | (eval-when (:compile-toplevel :load-toplevel :execute)
13 |   (defpattern cons* (car cdr)
14 | 	`(? #'non-nil (cons ,car ,cdr))))
15 | 
16 | (match (cons 10 11)
17 |  ((cons* a b) a))
18 | 
19 | 


--------------------------------------------------------------------------------
/shadchen.asd:
--------------------------------------------------------------------------------
 1 | ;;;; shadchen.asd
 2 | ;;; Copyright 2012, Vincent Toups
 3 | ;;; This program is distributed under the terms of the GNU Lesser 
 4 | ;;; General Public License (see license.txt).
 5 | 
 6 | (asdf:defsystem #:shadchen
 7 | 	:serial t
 8 | 	:author "Vincent Toups"
 9 | 	:maintainer "Vincent Toups"
10 | 	:description "A pattern matching library."
11 | 	:long-description "Shadchen (matchmaker) is a Racket-inspired pattern matching library."
12 | 	:components ((:file "package")
13 | 				 (:file "shadchen")))
14 | 
15 | 


--------------------------------------------------------------------------------
/shadchen.asd~:
--------------------------------------------------------------------------------
 1 | ;;;; shadchen.asd
 2 | 
 3 | ;;; Copyright 2012, Vincent Toups
 4 | ;;; This program is distributed under the terms of the GNU Lesser 
 5 | ;;; General Public License (see license.txt).
 6 | 
 7 | (asdf:defsystem #:shadchen
 8 | 	:serial t
 9 | 	:depends-on (#:lisp-unit)
10 | 	:author "Vincent Toups"
11 | 	:maintainer "Vincent Toups"
12 | 	:description "A pattern matching library."
13 | 	:long-description "Shadchen (matchmaker) is a Racket-inspired pattern matching library."
14 | 	:components ((:file "package")
15 | 		     (:file "shadchen")))
16 | 
17 | 


--------------------------------------------------------------------------------
/shadchen.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; shadchen.lisp
  2 | 
  3 | ;;; Copyright 2012, Vincent Toups
  4 | ;;; This program is distributed under the terms of the GNU Lesser 
  5 | ;;; General Public License (see license.txt).
  6 | 
  7 | (in-package #:shadchen)
  8 | 
  9 | (defstruct match-fail-struct)
 10 | 
 11 | (defvar *match-fail* (make-match-fail-struct))
 12 | 
 13 | (eval-when (:compile-toplevel :load-toplevel :execute)
 14 | 
 15 |   (defun non-keyword-symbol (o)
 16 | 	(and o
 17 | 		 (symbolp o)
 18 | 		 (not (keywordp o))))
 19 | 
 20 |   (defun match-list-expander* (sub-expressions match-value body)
 21 | 	(cond 
 22 | 	  ((not sub-expressions) `(if (not ,match-value) (progn ,@body) *match-fail*))
 23 | 	  ((and (listp sub-expressions)
 24 | 			(= 1 (length sub-expressions))
 25 | 			(listp (car sub-expressions))
 26 | 			(= 2 (length (car sub-expressions)))
 27 | 			(eq 'tail (car (car sub-expressions))))
 28 | 	   (let ((pattern (cadr (car sub-expressions))))
 29 | 		 `(match1 ,pattern ,match-value ,@body)))
 30 | 	  (:otherwise
 31 | 	   (let ((first-expression (car sub-expressions))
 32 | 			 (list-name (gensym "MATCH-LIST-EXPANDER*-")))
 33 | 		 `(let ((,list-name ,match-value))
 34 | 			(if (and (listp ,list-name)
 35 | 					 ,list-name)
 36 | 				(match1 ,first-expression (car ,list-name)
 37 | 				  (match1 (list ,@(cdr sub-expressions)) (cdr ,list-name) 
 38 | 					,@body))
 39 | 				*match-fail*))))))
 40 | 
 41 |   (defun match-list-expander (match-expression match-value body)
 42 | 	(match-list-expander* (cdr match-expression) match-value body))
 43 | 
 44 | 
 45 |   (defun match-cons-expander (match-expression match-value body)
 46 | 	(let ((car-match (elt match-expression 1))
 47 | 		  (cdr-match (elt match-expression 2))
 48 | 		  (name (gensym "MATCH-CONS-EXPANDER-")))
 49 | 	  `(let ((,name ,match-value))
 50 | 		 (if (listp ,name)
 51 | 			 (match1 ,car-match (car ,name)
 52 | 			   (match1 ,cdr-match (cdr ,name)
 53 | 				 ,@body))
 54 | 			 *match-fail*))))
 55 | 
 56 |   (defun match-quote-expander (match-expression match-value body)
 57 | 	`(if (equalp ,match-expression ,match-value) (progn ,@body) *match-fail*))
 58 | 
 59 |   (defun uq? (e)
 60 | 	(and (listp e)
 61 | 		 (eq (car e) 'uq)))
 62 | 
 63 |   (defun bq->regular-match (bq-expression)
 64 | 	(let ((sub-expr (cadr bq-expression)))
 65 | 	  (cond 
 66 | 		((uq? sub-expr)
 67 | 		 `(quote ,(cadr sub-expr)))
 68 | 		((listp sub-expr)
 69 | 		 `(list ,@(mapcar 
 70 | 				   (lambda (expr)
 71 | 					 (cond ((uq? expr)
 72 | 							(cadr expr))
 73 | 						   (t `(quote ,expr))))
 74 | 				   sub-expr)))
 75 | 		(t
 76 | 		 sub-expr))))
 77 | 
 78 |   (defun match-backquote-expander (match-expression match-value body)
 79 | 	`(match1 ,(bq->regular-match match-expression) ,match-value ,@body))
 80 | 
 81 |   (defun match-and-expander* (sub-expressions match-name body)
 82 | 	(cond 
 83 | 	  ((equal sub-expressions '(and*)) `(progn ,@body))
 84 | 	  (:otherwise 
 85 | 	   (let ((s1 (cadr sub-expressions)))
 86 | 		 `(match1 ,s1 ,match-name 
 87 | 			(match1 (and* ,@(cddr sub-expressions)) ,match-name ,@body))))))
 88 | 
 89 |   (defun match-and-expander (match-expression match-value body)
 90 | 	(let ((name (gensym "MATCH-AND-EXPANDER-")))
 91 | 	  `(let ((,name ,match-value))
 92 | 		 (match1 (and* ,@(cdr match-expression)) ,name ,@body))))
 93 | 
 94 |   (defun match-?-expander (match-expression match-value body)
 95 | 	(let ((name (gensym "MATCH-?-EXPANDER-NAME-"))
 96 | 		  (f-name (gensym "MATCH-?-EXPANDER-FUNCTION-")))
 97 | 	  (case (length (cdr match-expression))
 98 | 		(0 (error "MATCH1: MATCH-?-EXPANDER: zero arguments to MATCH-?-EXPANDER.  Needs 1 or 2."))
 99 | 		(1 `(let ((,name ,match-value)
100 | 				  (,f-name ,(cadr match-expression)))
101 | 			  (if (funcall ,f-name ,name) (progn ,@body) *match-fail*)))
102 | 		(2 `(let ((,name ,match-value)
103 | 				  (,f-name ,(cadr match-expression)))
104 | 			  (if (funcall ,f-name ,name) (match1 ,(elt match-expression 2) ,name ,@body)
105 | 				  *match-fail*)))
106 | 		(otherwise
107 | 		 (error "MATCH-?-EXPANDER: MATCH-?-EXPANDER takes only 1 or 2 arguments.")))))
108 | 
109 |   (defun match-values-expander (match-expression match-value body)
110 | 	(let ((name (gensym "MATCH-VALUES-EXPANDER-")))
111 | 	  `(let ((,name (multiple-value-list ,match-value)))
112 | 		 (match1 (list ,@(cdr match-expression)) ,name ,@body))))
113 | 
114 |   (defun match-funcall-expander (match-expression match-value body)
115 | 	(assert (and (listp match-expression) (= 3 (length match-expression)))
116 | 			(match-expression)
117 | 			"MATCH-FUNCALL-EXPANDER: FUNCALL match expression must have
118 | two terms, a function and a match against the result.  Got
119 | ~a." match-expression)
120 | 	(let ((name (gensym "MATCH-FUNCALL-EXPANDER-NAME-"))
121 | 		  (fun-name (gensym "MATCH-FUNCALL-EXPANDER-FUN-NAME-"))
122 | 		  (result-name (gensym "MATCH-FUNCALL-EXPANDER-RESULT-NAME-")))
123 | 	  `(let* ((,name ,match-value)
124 | 			  (,fun-name ,(cadr match-expression))
125 | 			  (,result-name (funcall ,fun-name ,name)))
126 | 		 (match1 ,(caddr match-expression) ,result-name ,@body))))
127 | 
128 |   (defvar *extended-patterns* (make-hash-table) "Holds user declared patterns.")
129 |   (defun extended-patternp (pattern-head) 
130 | 	"Return T if PATTERN-HEAD indicates a user provided pattern."
131 | 	(multiple-value-bind (val in) (gethash pattern-head *extended-patterns*)
132 | 	  (declare (ignore val))
133 | 	  in))
134 | 
135 |   (defun match-extended-pattern-expander (match-expression match-value body)
136 | 	(let* ((pattern-args (cdr match-expression))
137 | 		   (pattern-fun (gethash (car match-expression) *extended-patterns*))
138 | 		   (expansion (apply pattern-fun pattern-args)))
139 | 	  `(match1 ,expansion ,match-value ,@body)))
140 | 
141 |   (defmacro defpattern (name args &body body)
142 | 	`(setf (gethash ',name *extended-patterns*)
143 | 		   #'(lambda ,args ,@body)))
144 | 
145 |   (defun match-literal-string (match-expression match-value body)
146 | 	`(if (equalp ,match-expression ,match-value) 
147 | 		 (progn ,@body)
148 | 		 *match-fail*))
149 | 
150 |   (defun match-literal-number (match-expression match-value body)
151 | 	`(if (equalp ,match-expression ,match-value)
152 | 		 (progn ,@body)
153 | 		 *match-fail*))
154 | 
155 |   (defun match-literal-character (match-expression match-value body)
156 | 	`(if (equalp ,match-expression ,match-value)
157 | 		 (progn ,@body)
158 | 		 *match-fail*))
159 | 
160 |   (defun match-literal-keyword (match-expression match-value body)
161 | 	`(if (equalp ,match-expression ,match-value)
162 | 		 (progn ,@body)
163 | 		 *match-fail*))
164 | 
165 |   (defun match-let-expander (match-expression match-value body)
166 | 	(declare (ignore match-value))
167 | 	`(let ,(cdr match-expression) ,@body))
168 | 
169 |   (defun match-or-expander-unsafe (match-expression match-value body)
170 | 	(cond 
171 | 	  ((length=1 (cdr match-expression))
172 | 	   `(match1 ,(cadr match-expression) ,match-value ,@body))
173 | 	  (:otherwise
174 | 	   (let* ((forms (cdr match-expression))
175 | 			  (form (car forms))
176 | 			  (rest (cdr forms))
177 | 			  (nm (gensym "MATCH-OR-EXPANDER-NM-"))
178 | 			  (result-values-list (gensym "result-values-list-"))
179 | 			  (result (gensym "result")))
180 | 		 `(let* ((,nm ,match-value))
181 | 			(let* ((,result-values-list (multiple-value-list (match1 ,form ,nm ,@body)))
182 | 				   (,result (car ,result-values-list))) 
183 | 			  (if (not (eq *match-fail* ,result))
184 | 				  (apply #'values ,result-values-list)
185 | 				  (match1 (or ,@rest) ,nm ,@body))))))))
186 | 
187 |   (defun match-or-expander (match-expression match-value body)
188 | 	(assert (apply #'equal-by-binding (cdr match-expression))
189 | 			(match-expression)
190 | 			"Or sub-expressions ~S contains sub-forms which do not bind identical sets of symbols." match-expression)
191 | 	(match-or-expander-unsafe match-expression match-value body))
192 | 
193 | ;;;
194 | 
195 |   (defun mapcat (f lst)
196 | 	(loop for item in lst append (funcall f item)))
197 | 
198 | 
199 |   (defun calc-pattern-bindings-extended (expr)
200 | 	"Calculate the bound symbols of a user defined pattern."
201 | 	(let* ((pattern-args (cdr expr))
202 | 		   (pattern-fun (gethash (car expr) *extended-patterns*))
203 | 		   (expansion (apply pattern-fun pattern-args)))
204 | 	  (calc-pattern-bindings expansion)))
205 | 
206 |   (defun calc-backquote-bindings (expr)
207 | 	"Calculate the bindings for a backquote expression."
208 | 	(loop for sub in (cdr expr) 
209 | 	   when (and (listp sub)
210 | 				 (eq (car sub) 'uq))
211 | 	   append 
212 | 		 (calc-pattern-bindings (cadr sub))))
213 | 
214 |   (defun calc-pattern-bindings-list (expr &optional acc)
215 | 	(cond ((null expr)
216 | 		   acc)
217 | 		  ((and (listp expr)
218 | 				(listp (car expr))
219 | 				(eq 'tail (car (car expr))))
220 | 		   (append acc (calc-pattern-bindings (cadr (car expr)))))
221 | 		  (t
222 | 		   (calc-pattern-bindings-list (cdr expr)
223 | 									   (append (calc-pattern-bindings (car expr)) acc)))))
224 |   (defun calc-pattern-bindings (expr)
225 | 	"Given a shadchen pattern EXPR return a list of symbols bound
226 | by that expression."
227 | 	(cond 
228 | 	  ((non-keyword-symbol expr)
229 | 	   (list expr))
230 | 	  ((vectorp expr)
231 | 	   (calc-pattern-bindings `(list ,@(coerce expr 'list))))
232 | 	  ((or (not expr)
233 | 		   (symbolp expr)
234 | 		   (numberp expr)
235 | 		   (stringp expr)
236 | 		   (characterp expr)) nil)
237 | 	  ((extended-patternp (car expr))
238 | 	   (calc-pattern-bindings-extended expr))
239 | 	  ((listp expr)
240 | 	   (case (car expr)
241 | 		 (quote nil)
242 | 		 ((and values) 
243 | 		  (mapcat #'calc-pattern-bindings (cdr expr)))
244 | 		 (list (calc-pattern-bindings-list (cdr expr)))
245 | 		 (cons (append (calc-pattern-bindings (car expr))
246 | 					   (calc-pattern-bindings (cdr expr))))
247 | 		 ((? p funcall) (if (= 2 (length expr)) nil
248 | 							(calc-pattern-bindings (elt expr 2))))
249 | 		 (or (calc-pattern-bindings (cadr expr)))
250 | 		 (bq (calc-backquote-bindings expr))
251 | 		 ((! must-match string number keyword non-keyword-symbol) (calc-pattern-bindings (cadr expr)))
252 | 		 (one-of (calc-pattern-bindings (cadr expr)))
253 | 		 (let (mapcar #'car (cdr expr)))
254 | 		 (ignore (list))
255 | 		 (t (error "calc-pattern-bindings: unrecognized pattern ~S." expr))))))
256 | 
257 |   (defun package-name* (p)
258 | 	(if p (package-name p) "no-package-66b73c7f8e8bfa094fa23b4264978ed1"))
259 | 
260 | 	(defun symbol< (s1 s2)
261 | 	  (let ((p1 (package-name* (symbol-package s1)))
262 | 			(n1 (symbol-name s1))
263 | 			(p2 (package-name* (symbol-package s2)))
264 | 			(n2 (symbol-name s2)))
265 | 		(if (equal p1 p2)
266 | 			(string< n1 n2)
267 | 			(string< p1 p2))))
268 | 
269 | 	(defun canonical-binding-list (l)
270 | 	  (sort l #'symbol<))
271 | 
272 | 	(defun equal-by-binding2 (p1 p2)
273 | 	  (equal (canonical-binding-list 
274 | 			  (calc-pattern-bindings p1))
275 | 			 (canonical-binding-list 
276 | 			  (calc-pattern-bindings p2))))
277 | 
278 | 	(defun equal-by-binding (&rest patterns)
279 | 	  (cond 
280 | 		((= 1 (length patterns)) t)
281 | 		((= 2 (length patterns))
282 | 		 (equal-by-binding2 (car patterns) (cadr patterns)))
283 | 		(t
284 | 		 (and (equal-by-binding2 (car patterns) (cadr patterns))
285 | 			  (apply #'equal-by-binding (cdr patterns))))))
286 | 
287 | 
288 | ;;;
289 | 
290 | 	(defun must-match-case (match-expr)
291 | 	  (cond 
292 | 		((and (listp match-expr)
293 | 			  (= 2 (length match-expr)))
294 | 		 :pattern-only)
295 | 		((and (listp match-expr)
296 | 			  (= 4 (length match-expr)))
297 | 		 :pattern+)
298 | 		(t :unrecognized)))
299 | 
300 | 	(defun match-must-match-expander (match-expr val-expr body)
301 | 	  (case (must-match-case match-expr)
302 | 		(:pattern-only 
303 | 		 (destructuring-bind (_ pattern) match-expr
304 | 		   (declare (ignore _))
305 | 		   (let ((sym (gensym "must-match-failed-value-"))) 
306 | 			 (match-must-match-expander 
307 | 			  `(must-match 
308 | 				,pattern 
309 | 				,sym 
310 | 				(format nil ,(format nil "must-match pattern (~S) failed to match ~~S" pattern) 
311 | 						,sym))
312 | 			  val-expr body))))
313 | 		(:pattern+
314 | 		 (destructuring-bind (_ pattern fail-pattern message-expression) match-expr
315 | 		   (declare (ignore _))
316 | 		   (let ((bound-symbols (calc-pattern-bindings pattern))
317 | 				 (value (gensym "must-match-value-"))
318 | 				 (result (gensym "must-match-result-")))
319 | 			 `(match1 (funcall 
320 | 					   (lambda (,value)
321 | 						 (let ((,result (match1 ,pattern ,value
322 | 										  (list ,@bound-symbols))))
323 | 						   (if (eq *match-fail* ,result)
324 | 							   (match ,value 
325 | 								 (,fail-pattern (let ((,value ,message-expression))
326 | 												  (if (stringp ,value)
327 | 													  (error ,value)
328 | 													  (error "~S" ,value))))
329 | 								 (_
330 | 								  (error 
331 | 								   (format nil
332 | 										   ,(format nil "must-match pattern (~S) failed and then the failed-value pattern (~S) also failed on value ~~S" 
333 | 													pattern fail-pattern) 
334 | 										   ,value))))
335 | 							   ,result)))
336 | 					   (list ,@bound-symbols))
337 | 				  ,val-expr
338 | 				,@body))))
339 | 		(t (error "Unrecognized must-match pattern form ~S" match-expr))))
340 | 
341 | ;;;
342 | 
343 | 
344 | 	(defmacro match1 (match-expression match-value &body body)
345 | 	  (cond 
346 | 		((not match-expression) `(if (not ,match-value) (progn ,@body) *match-fail*))
347 | 		((or (non-keyword-symbol match-expression)
348 | 			 (and (listp match-expression)
349 | 				  (eq (car match-expression) 'ignore)))
350 | 		 (if (or (eq match-expression '_)
351 | 				 (eq match-expression '-ignore-)
352 | 				 (and (listp match-expression)
353 | 					  (eq (car match-expression) 'ignore)))
354 | 			 `(progn ,match-value ,@body)
355 | 			 `(let ((,match-expression ,match-value))
356 | 				,@body)))
357 | 		((keywordp match-expression) 
358 | 		 (match-literal-keyword match-expression match-value body))
359 | 		((stringp match-expression) 
360 | 		 (match-literal-string match-expression match-value body))
361 | 		((numberp match-expression)
362 | 		 (match-literal-number match-expression match-value body))
363 | 		((characterp match-expression)
364 | 		 (match-literal-character match-expression match-value body))
365 | 		((extended-patternp (car match-expression)) 
366 | 		 (match-extended-pattern-expander match-expression match-value body))
367 | 		((listp match-expression)
368 | 		 (case (car match-expression)
369 | 		   ((! must-match) (match-must-match-expander match-expression match-value body))
370 | 		   (list (match-list-expander match-expression match-value body))
371 | 		   (cons (match-cons-expander match-expression match-value body))
372 | 		   (quote (match-quote-expander match-expression match-value body))
373 | 		   (and (match-and-expander match-expression match-value body))
374 | 		   (and* (match-and-expander* match-expression match-value body))
375 | 		   ((? p) (match-?-expander match-expression match-value body))
376 | 		   (funcall (match-funcall-expander match-expression match-value body))
377 | 		   (or (match-or-expander match-expression match-value body))
378 | 		   (bq (match-backquote-expander match-expression match-value body))
379 | 		   (values (match-values-expander match-expression match-value body))
380 | 		   (let (match-let-expander match-expression match-value body))
381 | 		   (otherwise (error "MATCH1: Unrecognized match-expression ~a" match-expression))))
382 | 		(:otherwise
383 | 		 (error "MATCH1: Unrecognized match-expression ~a" match-expression))))
384 | 
385 | 	(defmacro match-helper (value &body forms)
386 | 	  (assert (symbolp value)
387 | 			  (value)
388 | 			  "MATCH-HELPER: VALUE must be a symbol.  Got ~a." value)
389 | 	  (cond 
390 | 		((not forms) `(error "No Match for ~s." ,value))
391 | 		((listp forms)
392 | 		 (let ((first-form (car forms)))
393 | 		   (assert (and (listp first-form)
394 | 						(> (length first-form) 1))
395 | 				   (first-form)
396 | 				   "Each MATCH SUB-FORM must be at least two elements long, a matcher
397 | and an expression to evaluate on match. Got ~a instead." first-form)
398 | 		   (let ((match-expression (car first-form))
399 | 				 (match-body-exprs (cdr first-form))
400 | 				 (result-name (gensym "MATCH-HELPER-RESULT-NAME-"))
401 | 				 (result-values-name (gensym "MATCH-HELPER-RESULT-VALUES-NAME-")))
402 | 			 `(let* ((,result-values-name (multiple-value-list (match1 ,match-expression ,value ,@match-body-exprs)))
403 | 					 (,result-name (car ,result-values-name)))
404 | 				(if (not (eq *match-fail* ,result-name)) (apply #'values ,result-values-name)
405 | 					(match-helper ,value ,@(cdr forms)))))))))
406 | 
407 | 
408 | 	(defmacro match (value &body forms)
409 | 	  "Attempt to match VALUE against each of the patterns in the CAR of
410 | FORMS.  When a match is detected, its subsequent forms are executed as
411 | in a PROGN where the bindings implied by the match are in effect.  
412 | 
413 | An error is thrown when no matches are found."
414 | 	  (let ((name (gensym "MATCH-VALUE-NAME-")))
415 | 		`(let ((,name ,value)) 
416 | 		   (match-helper ,name ,@forms))))
417 | 
418 | 
419 | 	(defmacro match-lambda (&body forms) 
420 | 	  "Like MATCH except the VALUE is curried."
421 | 	  (let ((name (gensym "MATCH-LAMBDA-NAME-")))
422 | 		`(function (lambda (,name) (match ,name ,@forms)))))
423 | 
424 | 	(defun length=1 (lst)
425 | 	  "Returns T when LST has one element."
426 | 	  (and (consp lst)
427 | 		   (not (cdr lst)))))
428 | 
429 |   (defpattern list-rest (&rest patterns)
430 | 	(let ((n (length patterns)))
431 | 	  (cond ((= n 0) '(list))
432 | 			((= n 1) `(list (tail ,(car patterns))))
433 | 			(:otherwise
434 | 			 `(list ,@(reverse (cdr (reverse (copy-list patterns))))
435 | 					(tail ,(car (reverse patterns))))))))
436 | 
437 |   (defpattern list* (&rest patterns)
438 | 	`(list-rest ,@patterns))
439 | 
440 |   (defpattern number (&optional (pattern '_))
441 | 	`(p #'numberp ,pattern))
442 | 
443 |   (defpattern symbol (&optional (pattern '_))
444 | 	`(p #'symbolp ,pattern))
445 | 
446 |   (defpattern string (&optional (pattern '_))
447 | 	`(p #'stringp ,pattern))
448 | 
449 |   (defpattern non-kw-symbol (&optional (pattern '_))
450 | 	(let ((val (gensym)))
451 | 	  `(p #'(lambda (,val)
452 | 			  (and (symbolp ,val)
453 | 				   (not (keywordp ,val))))
454 | 		  ,pattern)))
455 | 
456 |   (defpattern keyword (&optional (pattern '_))
457 | 	`(p #'keywordp ,pattern))
458 | 
459 | 
460 |   (defun htbl-fetcher (key)
461 | 	#'(lambda (htbl) (gethash key htbl)))
462 | 
463 |   (defmacro named-let (name binders &body body)
464 | 	`(labels ((,name ,(mapcar #'car binders) ,@body))
465 | 	   (,name ,@(mapcar #'cadr binders))))
466 | 
467 | (defpattern struct (struct-name &rest fields)
468 |   `(and
469 | 	(? #'(lambda (o)
470 | 		   (typep o ',struct-name)))
471 | 	,@(loop for f in fields collect
472 | 		   `(funcall 
473 | 			 #'(lambda (o)
474 | 				 (slot-value o ',(car f)))
475 | 			 ,(cadr f)))))
476 | 
477 | (defpattern hash-table (&rest key/pat-pairs)
478 |   `(and (? #'hash-table-p)
479 | 		,@(named-let recur 
480 | 					 ((pairs key/pat-pairs)
481 | 					  (acc nil))
482 | 					 (match pairs
483 | 					   (nil (reverse acc))
484 | 					   ((cons key (cons pat rest))
485 | 						(recur rest
486 | 							   (cons `(funcall (htbl-fetcher ,key) ,pat) acc)))))))
487 | 
488 | (defpattern let1 (name value)
489 |   `(let (,name ,value)))
490 | 
491 | (defmacro match-let* (bindings &body body)
492 |   "Just like let* but each symbol part of each binding can be a match
493 | expression of arbitrary complexity."
494 |   (match bindings 
495 | 	((list) `(progn ,@body))
496 | 	((cons (list pattern value) rest-bindings)
497 | 	 `(match ,value 
498 | 		(,pattern 
499 | 		 (match-let* ,rest-bindings ,@body))))))
500 | 
501 | (defmacro match-let (bindings &body body)
502 |   "Just like let* but each symbol part of each binding can be a match
503 | expression of arbitrary complexity."
504 |   (let ((patterns (mapcar #'car bindings))
505 | 		(values (mapcar #'cadr bindings)))
506 | 	`(match (list ,@values)
507 | 	   ((list ,@patterns) ,@body))))
508 | 
509 | (defmacro match-loop (recur-point bindings &body body)
510 |   "Like match-let but the binding form can be re-entered by calling
511 | a local function indicated by `recur-point` with the same number of arguments
512 | as bindings expressions in BINDINGS."
513 |   (let ((args 
514 | 		 (loop for i from 1 to (length bindings)
515 | 			collect (gensym "match-loop-arg-")))
516 | 		(patterns (mapcar #'car bindings))
517 | 		(initial-values 
518 | 		 (mapcar #'cadr bindings)))
519 | 	`(labels ((,recur-point ,args
520 | 				(match (list ,@args)
521 | 				  ((list ,@patterns) ,@body))))
522 | 	   (,recur-point ,@initial-values))))
523 | 
524 | (defvar *match-function-table* (make-hash-table))
525 | (defun extend-defun-match-table (name lexpr)
526 |   (let ((c (reverse (gethash name *match-function-table*))))
527 | 	(setf (gethash name *match-function-table*)
528 | 		  (reverse (cons lexpr c)))))
529 | 
530 | (defmacro defun-match- (name patterns &body body)
531 |   (let ((args (gensym))
532 | 		(funs (gensym))
533 | 		(fun (gensym))
534 | 		(rval (gensym))
535 | 		(loopf (gensym))
536 | 		(compound-name (intern (format nil "~S (~S)" name patterns)))
537 | 		(doc-string (if (stringp (car body)) (car body) "")))
538 | 	`(progn 
539 | 	   (defun ,name (&rest ,args)
540 | 		 (named-let ,loopf ((,funs (gethash ',name *match-function-table*)))
541 | 		   (if (null ,funs)
542 | 			   (error "~S: match fail for ~S." ',name ,args)
543 | 			   (let* ((,fun (car ,funs))
544 | 					  (,funs (cdr ,funs))
545 | 					  (,rval (apply ,fun ,args)))
546 | 				 (if (eq *match-fail* ,rval)
547 | 					 (,loopf ,funs)
548 | 					 ,rval)))))
549 | 	   (defun ,compound-name (&rest ,args)
550 | 		 ,doc-string
551 | 		 (match1 (list ,@patterns) ,args ,@body))
552 | 	   (setf (gethash ',name *match-function-table*)
553 | 			 (list #',compound-name)))))
554 | 
555 | (defmacro defun-match (name patterns &body body)
556 |   (let ((compound-name (intern (format nil "~S (~S)" name patterns)))
557 | 		(args (gensym))
558 | 		(doc-string (if (stringp (car body)) (car body) "")))
559 | 	`(progn 
560 | 	   (defun ,compound-name (&rest ,args)
561 | 		 ,doc-string
562 | 		 (match1 (list ,@patterns) ,args
563 | 		   ,@body))
564 | 	   (extend-defun-match-table ',name #',compound-name))))
565 | 
566 | #|
567 | 
568 | (match 'y 
569 |   ((and (symbol x) 
570 | 		(must-match 'z a (format nil "Failed, but got ~S" a)))
571 |    :hey))
572 | 
573 | (defun-match- my-prod (anything)
574 |   (my-prod anything 1))
575 | (defun-match my-prod (nil acc)
576 |   acc)
577 | (defun-match my-prod ((list (must-match x f (format nil "failed on ~s" f)) (tail rest)) acc)
578 |   (my-prod rest (* acc x)))
579 | (my-prod '(1 2 3 4))
580 | 
581 | 
582 | 
583 | (match1 (list (must-match (number x)) (tail tl)) '(1 2 3) tl)
584 | 
585 | (match-loop rec 
586 | 	(((list x y) (list 0 0)))
587 |   (if (< (+ x y) 100) 
588 | 	  (rec (list (+ x 1) (+ y x)))
589 | 	  (list x y)))
590 | 
591 | (match 10
592 | 	((or (number val)
593 | 		 (string s))
594 | 	 val))
595 | 
596 | (match (list 1 2) (x x))
597 | 
598 | (match (list 1 2 3 4)
599 |   ((list a b (tail c)) c))
600 | 
601 | (calc-pattern-bindings 
602 | 					   '(and a b c))
603 | 
604 | |#
605 | 
606 | ;; (let ((ht (make-hash-table :test #'equal)))
607 | ;;   (labels ((add (key val) (setf (gethash key ht) val)))
608 | ;; 	(add :x 10)
609 | ;; 	(add :y (list 1 2))
610 | ;; 	(add :z 'a-value)
611 | ;; 	(match ht
612 | ;; 	  ((hash-table 
613 | ;; 		:x x
614 | ;; 		:y (list y z))
615 | ;; 	   (list x y z)))))
616 | 
617 | 
618 | ;;; "shadchen" goes here. Hacks and glory await!
619 | 
620 | 


--------------------------------------------------------------------------------
/tests.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; tests.lisp
  2 | 
  3 | (in-package #:shadchen)
  4 | 
  5 | (eos:test list1 
  6 |   (eos:is (equal (list :q :r :s)
  7 | 				 (match (list :s :r :q)
  8 | 				   ((list x y z)
  9 | 					(list z y x))))))
 10 | (eos:test list2
 11 |   (eos:is (equal 
 12 | 		   (* 1 2 3)
 13 | 		   (match (list 1 2 3)
 14 | 			 ((list x y z)
 15 | 			  (* x y z))))))
 16 | 
 17 | (eos:test list-tail 
 18 |   (eos:is (equal '(x y z)
 19 | 				 (match '(q r s t u v w x y z)
 20 | 				   ((list _ _ _ _ _ _ _ (tail the-tail))
 21 | 					the-tail)))))
 22 | 
 23 | (eos:test numeric-literal
 24 |   (eos:is (equal 
 25 | 		   :matched (match 10
 26 | 					  (11 :did-not-match)
 27 | 					  (10 :matched)))))
 28 | 
 29 | (eos:test string-literal
 30 |   (eos:is (equal 
 31 | 		   :matched (match "cat"
 32 | 					  (15 :did-not-match)
 33 | 					  ("cat" :matched)))))
 34 | 
 35 | (eos:test keyword-literal
 36 |   (eos:is (equal 
 37 | 		   :matched
 38 | 		   (match :x
 39 | 			 (15 :did-not-match)
 40 | 			 (:x :matched)))))
 41 | 
 42 | (eos:test cons
 43 |   (eos:is 
 44 |    (equal '(b c)
 45 | 		  (match '(a b c)
 46 | 			(15 :did-not-match)
 47 | 			((cons -ignore- tail)
 48 | 			 tail)))))
 49 | 
 50 | (eos:test quote
 51 |   (eos:is 
 52 |    (equal :matched
 53 | 		  (match 'x
 54 | 			((cons _ _)
 55 | 			 :did-not-match)
 56 | 			('x :matched)))))
 57 | 
 58 | (eos:test number1
 59 |   (eos:is 
 60 |    (equal :matched 
 61 | 		  (match 10
 62 | 			((symbol) :did-not-match)
 63 | 			((number) :matched)))))
 64 | 
 65 | (eos:test number2
 66 |   (eos:is
 67 |    (equal :matched
 68 | 		  (match 10
 69 | 			((number (p #'(lambda (x)
 70 | 							(< x 9))))
 71 | 			 :did-not-match)
 72 | 			((number (p #'(lambda (x)
 73 | 							(> x 9))))
 74 | 			 :matched)))))
 75 | 
 76 | (eos:test string1
 77 |   (eos:is 
 78 |    (equal :matched 
 79 | 		  (match "x"
 80 | 			((symbol) :did-not-match)
 81 | 			((string) :matched)))))
 82 | 
 83 | (eos:test string2
 84 |   (eos:is
 85 |    (equal :matched
 86 | 		  (match "cat"
 87 | 			((string (p #'(lambda (x)
 88 | 							(= 7 (length x)))))
 89 | 			 :did-not-match)
 90 | 			((string (p #'(lambda (x)
 91 | 							(= (length x) 3))))
 92 | 			 :matched)))))
 93 | 
 94 | (eos:test keyword1
 95 |   (eos:is 
 96 |    (equal :matched 
 97 | 		  (match :x
 98 | 			((non-kw-symbol) :did-not-match)
 99 | 			((keyword) :matched)))))
100 | 
101 | (eos:test keyword2
102 |   (eos:is
103 |    (equal :matched
104 | 		  (match :cat
105 | 			((keyword (p #'(lambda (x)
106 | 							 (= 7 (length (symbol-name x))))))
107 | 			 :did-not-match)
108 | 			((keyword (p #'(lambda (x)
109 | 							 (= (length (symbol-name x)) 3))))
110 | 			 :matched)))))
111 | 
112 | (eos:test p
113 |   (eos:is 
114 |    (equal 10
115 | 		  (match 10
116 | 			((p #'numberp n)
117 | 			 n)))))
118 | 
119 | (eos:test funcall
120 |   (eos:is
121 |    (equal 11
122 | 		  (match 10
123 | 			(:x :did-not-match)
124 | 			((funcall #'(lambda (x)
125 | 						  (+ x 1)) r)
126 | 			 r)))))
127 | 
128 | (eos:test or
129 |   (eos:is 
130 |    (equal :matched
131 | 		  (match 10
132 | 			((or 14 :x)
133 | 			 :did-not-match)
134 | 			((or 10
135 | 				 11)
136 | 			 :matched)))))
137 | 
138 | (eos:test bq
139 |   (eos:is
140 |    (equal 
141 | 	'b
142 | 	(match '(a b c)
143 | 	  ((bq (a (uq x) c))
144 | 	   x)))))
145 | 
146 | (eos:test let
147 |   (eos:is 
148 |    (equal '(a b c)
149 | 		  (match (list)
150 | 			((let 
151 | 				 (x 'a)
152 |   			   (y 'b)
153 |   			   (z 'c))
154 | 			 (list x y z))))))
155 | 
156 | (eos:test must-match-succeed-case
157 |   (eos:is 
158 |    (equal 10
159 | 		  (match 10
160 | 			((must-match (number x))
161 | 			 x)))))
162 | 
163 | (eos:test must-match-fail-case
164 |   (eos:signals (simple-error)
165 | 	(equal :x 
166 | 		   (match :x
167 | 			 ((must-match (number x))
168 | 			  x)))))
169 | 
170 | (defpackage shadchen-tests)
171 | (defun-match- shadchen-tests::product (nil acc)
172 |   acc)
173 | (defun-match shadchen-tests::product ((list (! (number x))
174 | 											(tail rest))
175 | 									  acc)
176 |   (shadchen-tests::product rest (* x acc)))
177 | (defun-match shadchen-tests::product (anything)
178 |   (shadchen-tests::product anything 1))
179 | 
180 | (eos:test defun-match 
181 |   (eos:is (equal 24 
182 | 				 (shadchen-tests::product '(1 2 3 4)))))
183 | 
184 | (eos:test defun-match-with-fail
185 |   (eos:signals (simple-error)
186 | 	  (shadchen-tests::product '(1 a 3 4))))
187 | 
188 | (eos:run!)
189 | 


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