Minor changes (added COPYING information and other minutiae).
Annotate for file match-block.lisp
2007-11-09 mantoniotti 1 ;;;; -*- Mode: Lisp -*-
13:43:20 ' 2
' 3 ;;;; match-block.lisp --
' 4 ;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.
2004-11-17 mantoniotti 5
2011-04-02 mantoniotti 6 ;;;; See file COPYING for copyright licensing information.
04:05:18 ' 7
2004-11-17 mantoniotti 8 (in-package "UNIFY")
22:19:54 ' 9
' 10 (defun clean-unify-var-name (v)
' 11 (assert (variablep v))
' 12 (intern (subseq (symbol-name v) 1)
' 13 (symbol-package v)))
' 14
2010-06-15 pix 15 (defmacro with-unification-variables ((&rest variables) environment &body body)
03:21:37 ' 16 "Execute body with variables bound to their values in environment."
' 17 (flet ((variable-bindings (v)
' 18 `((,v (find-variable-value ',v ,environment))
' 19 (,(clean-unify-var-name v) ,v))))
' 20 `(let* ,(mapcan #'variable-bindings variables)
' 21 (declare (ignorable ,@(mapcar #'clean-unify-var-name variables)))
' 22 ,@body)))
' 23
2010-02-04 pix 24 (defun %match-expander (template-munger clause-munger clauses
07:32:18 ' 25 &key default named environment errorp error-form keyform)
' 26 "A rather hairy internal function which handles expansion for all the MATCH* macros.
2004-11-17 mantoniotti 27
2010-02-04 pix 28 template-munger should be either 'match or 'matchf, and will massage the
07:32:18 ' 29 template into the proper form for that macro set.
' 30
' 31 clause-munger should be either 'cond, 'case, or 'nil. This affects the expected
' 32 syntax of items in clauses as follows:
' 33 'cond: { ((<template> <object>) &body) }+ default-clause
' 34 'case: { (<template> &body) }+ default-clause
' 35 'nil: { (<template> <object> &body) }+ default-clause
' 36 default-clause: [ (t &body) ]
' 37
' 38 clauses is a list of forms conforming to the syntax just described.
' 39
' 40 default is a single form to be executed if no other forms match.
' 41 named is the name for a surrounding block.
' 42
' 43 environment is a base environment object which template matches should extend.
' 44 The new environments created will share frames with this environment, though any
' 45 additional bindings will be in a new, unshared frame. environment defaults to
' 46 '(make-empty-environment).
' 47
' 48 errorp is a single form which will be evaluated to determine if error-form is
' 49 executed.
' 50
' 51 error-form is a form which is expected to generate an error (e.g., `(error
' 52 'unification-non-exhaustive)). It defaults to providing the error returned by
' 53 the last form which failed unification.
' 54
' 55 keyform should be used only for a clause-munger of 'case. It provides the form
' 56 to evaluate to produce the object for unification in -case macros.
' 57
' 58 *Interaction between default-clause, :errorp + :error-form, and :default
' 59
' 60 This function produces a giant COND form which ends one or more of these
' 61 assorted \"default\" clauses. They are produced in a very specific order:
' 62 1. errorp + error-form are tried first. Thus, if errorp is 't, neither the
' 63 default-clause in clauses will be reached, nor the :default clause. This is
' 64 essentially a hook to produce a pre-user default clause. (e.g., for
' 65 MATCH's :errorp)
' 66 2. The default-clause in clauses, if it exists, will be tried next. Because
' 67 clauses is expected to contain user-specified clauses, this is expected to be
' 68 the user-specified default clause.
' 69 3. Finally, the :default clause, if specified, will be tried. This is
' 70 essentially a hook to produce a post-user default clause. (e.g., for
' 71 -ECASE's error form)
' 72 "
' 73 (flet ((default-clause-p (clause) (member (first clause) '(t otherwise))))
' 74 (let ((match-environment (gensym "MATCH-ENV-"))
' 75 (base-environment (gensym "BASE-ENV-"))
' 76 (match-error (gensym "MATCH-ERR-"))
' 77 (case-keyform (gensym "KEYFORM-"))
' 78 (match-clauses (remove-if #'default-clause-p clauses))
' 79 (default-clauses (remove-if-not #'default-clause-p clauses)))
' 80 (when (or (and (< 1 (length default-clauses))
' 81 ;; whether the default clause is the last one
' 82 (every #'eq clauses (append match-clauses default-clauses)))
' 83 ;; :keyform only applies for 'case
' 84 (and keyform (not (eq clause-munger 'case))))
' 85 (error 'program-error))
' 86 (labels ((ensure-template (template)
' 87 (cond (;; Logical variables are special-cased.
' 88 (variablep template) `',template)
' 89 ;; Same for lists (under matchf)
' 90 ((and (eq 'matchf template-munger)
' 91 (listp template))
' 92 (make-instance 'list-template
' 93 :spec (cons 'list template)))
' 94 (t template)))
' 95 (expand-clause (clause)
' 96 (destructuring-bind (template object &rest body)
2010-02-07 pix 97 (munge-clause clause)
2010-02-04 pix 98 (let* ((template (ensure-template template))
07:32:18 ' 99 (variables (collect-template-vars template)))
' 100 `((setf (values ,match-environment ,match-error)
' 101 (unify* ,template ,object (make-expanded-environment ,base-environment)))
2010-06-15 pix 102 (with-unification-variables ,variables ,match-environment
2010-02-04 pix 103 ,@body)))))
07:32:18 ' 104 (munge-clause (clause)
' 105 (ecase clause-munger
' 106 (cond (destructuring-bind (head . tail) clause
' 107 (if (consp head)
' 108 (list* (car head) (cadr head) tail)
' 109 clause)))
' 110 (case (list* (car clause) case-keyform (cdr clause)))
' 111 ((nil) clause))))
' 112 `(block ,named
' 113 (let ((,match-environment nil)
' 114 (,match-error nil)
' 115 (,case-keyform ,keyform)
' 116 (,base-environment ,(if environment
' 117 `(make-shared-environment ,environment)
' 118 '(make-empty-environment))))
' 119 (declare (dynamic-extent ,match-environment ,base-environment)
' 120 (ignorable ,case-keyform))
' 121 (cond
2010-02-07 pix 122 ,@(mapcar #'expand-clause match-clauses)
2010-02-04 pix 123 ,@(when errorp `((,errorp ,(or error-form `(error ,match-error)))))
07:32:18 ' 124 ,@(when default-clauses `((t ,@(cdar default-clauses))))
' 125 ,@(when default `((t ,default))))))))))
2010-01-12 pix 126
2010-02-05 pix 127 (defmacro %set-documentation ((&rest symbols) docstring)
03:21:40 ' 128 `(eval-when (:load-toplevel :execute)
' 129 (mapcar (lambda (fn) (setf (documentation fn 'function) ,docstring))
' 130 ',symbols)))
' 131
2004-11-17 mantoniotti 132 (defmacro match ((template object
22:19:54 ' 133 &key
2010-02-04 pix 134 (named nil)
07:32:18 ' 135 (match-named nil match-named-p)
' 136 (substitution nil)
2004-11-17 mantoniotti 137 (errorp t)
22:19:54 ' 138 (error-value nil))
' 139 &body forms)
2010-02-04 pix 140 (when match-named-p
07:32:18 ' 141 (warn ":match-named is deprecated. Use :named instead."))
' 142 (%match-expander 'match
' 143 'nil
' 144 `((,template ,object ,@forms))
' 145 :default error-value
' 146 :named (or named match-named)
' 147 :environment substitution
' 148 :errorp errorp))
2009-04-15 mantoniotti 149
10:16:24 ' 150 (defmacro matchf ((template object
' 151 &key
2010-02-04 pix 152 (named nil)
07:32:18 ' 153 (match-named nil match-named-p)
' 154 (substitution nil)
2009-04-15 mantoniotti 155 (errorp t)
10:16:24 ' 156 (error-value nil))
' 157 &body forms)
2010-02-05 pix 158 (when match-named-p
03:21:40 ' 159 (warn ":match-named is deprecated. Use :named instead."))
' 160 (%match-expander 'matchf
' 161 'nil
' 162 `((,template ,object ,@forms))
' 163 :default error-value
' 164 :named (or named match-named)
' 165 :environment substitution
' 166 :errorp errorp))
' 167
' 168 (%set-documentation
' 169 (match matchf)
' 170 "Sets up a lexical environment to evaluate FORMS after an unification.
2009-04-15 mantoniotti 171
2010-02-05 pix 172 MATCH and MATCHF unify a TEMPLATE and an OBJECT and then set up a lexical
2009-04-15 mantoniotti 173 environment where the variables present in the template are bound
10:16:24 ' 174 lexically. Note that both variable names '?FOO' and 'FOO' are bound
' 175 for convenience.
' 176
' 177 MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
' 178 generate a template at read-time).
' 179
2010-02-05 pix 180 MATCH and MATCHF forms return the values returned by the evaluation of the
2009-04-15 mantoniotti 181 last of the FORMS.
10:16:24 ' 182
' 183 If ERRORP is non-NIL (the default) then the form raises a
' 184 UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
' 185 whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
2010-02-05 pix 186 raising from the evaluation of FORMS will /not/ be caught and handled
2009-04-15 mantoniotti 187 according to ERRORP settings.)
10:16:24 ' 188
2010-02-05 pix 189 A surrounding BLOCK named NAMED is set up around the matching code.")
2004-11-17 mantoniotti 190
22:19:54 ' 191
' 192
' 193 (define-condition unification-non-exhaustive (unification-failure)
2010-02-04 pix 194 ()
07:32:18 ' 195 (:default-initargs
' 196 :format-control "Non exhaustive matching."))
' 197
2004-11-17 mantoniotti 198
2010-02-04 pix 199 (defmacro match-cond (&body clauses)
07:32:18 ' 200 (%match-expander 'match 'cond clauses))
' 201
' 202 (defmacro matchf-cond (&body clauses)
' 203 (%match-expander 'matchf 'cond clauses))
2004-11-17 mantoniotti 204
22:19:54 ' 205 (defmacro matching ((&key errorp
2010-02-04 pix 206 default-substitution
07:32:18 ' 207 (named nil)
' 208 (matching-named nil matching-named-p))
2010-01-15 pix 209 &body match-clauses)
2010-02-04 pix 210 (when matching-named-p
07:32:18 ' 211 (warn ":matching-named is deprecated. Use :named instead."))
' 212 (%match-expander 'match 'cond match-clauses
' 213 :errorp errorp
' 214 :error-form `(error 'unification-non-exhaustive)
' 215 :named (or named matching-named)
' 216 :environment default-substitution))
2004-11-17 mantoniotti 217
2010-02-05 pix 218 (%set-documentation
03:21:40 ' 219 (match-cond matchf-cond matching)
' 220 "MATCH-COND, MATCHF-COND, and MATCHING set up a COND-like environment for
' 221 multiple template matching clauses.
2005-04-27 mantoniotti 222
2010-02-05 pix 223 Their syntax comprises a number of clauses of the form
2005-04-27 mantoniotti 224 <clause> ::= <regular-clause> | <default-clause>
2010-02-05 pix 225 <regular-clause> ::= ((<template> <form>) &body <forms>)
2005-04-27 mantoniotti 226 <default-clause> ::= (t &body <forms>)
20:41:56 ' 227 | (otherwise &body <forms>)
' 228 <form> and <forms> are regular Common Lisp forms.
' 229 <template> is a unification template.
' 230
2010-02-05 pix 231 The full syntax is
03:21:40 ' 232 match-cond <clauses>
' 233 matchf-cond <clauses>
' 234 matching (&key errorp default-substitution named) <clauses>
2005-04-27 mantoniotti 235
20:41:56 ' 236 Each clause evaluates its forms in an environment where the variables
' 237 present in the template are bound lexically. Note that both variable
' 238 names '?FOO' and 'FOO' are bound for convenience.
' 239
2010-02-05 pix 240 The values returned by the macros are those of the last form in
2005-04-27 mantoniotti 241 the first clause that satisfies the match test.
20:41:56 ' 242
' 243 If ERRORP is non-NIL then if none of the regular clauses matches, then
' 244 an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
' 245 any default clause. Otherwise, the default clause behaves as a
2010-02-05 pix 246 standard COND default clause. The default value of ERRORP is NIL.
03:21:40 ' 247 ")
' 248
' 249
' 250 (defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
' 251 &body clauses)
2010-02-04 pix 252 (when match-case-named-p
07:32:18 ' 253 (warn ":match-case-named is deprecated. Use :named instead."))
' 254 (%match-expander 'match 'case clauses
' 255 :named (or named match-case-named)
' 256 :environment default-substitution
' 257 :errorp errorp
' 258 :error-form `(error 'unification-non-exhaustive)
' 259 :keyform object))
2005-04-27 mantoniotti 260
2010-02-04 pix 261 (defmacro match-ecase ((object &key default-substitution named)
07:32:18 ' 262 &body clauses)
' 263 (%match-expander 'match 'case clauses
' 264 :named named
' 265 :environment default-substitution
' 266 :default `(error 'unification-non-exhaustive)
' 267 :keyform object))
2009-12-17 mantoniotti 268
2010-02-04 pix 269 (defmacro matchf-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
07:32:18 ' 270 &body clauses)
' 271 (when match-case-named-p
' 272 (warn ":match-case-named is deprecated. Use :named instead."))
' 273 (%match-expander 'matchf 'case clauses
' 274 :named (or named match-case-named)
' 275 :environment default-substitution
' 276 :errorp errorp
' 277 :error-form `(error 'unification-non-exhaustive)
' 278 :keyform object))
' 279
' 280 (defmacro matchf-ecase ((object &key default-substitution named)
' 281 &body clauses)
' 282 (%match-expander 'matchf 'case clauses
' 283 :named named
' 284 :environment default-substitution
' 285 :default `(error 'unification-non-exhaustive)
' 286 :keyform object))
' 287
2010-02-05 pix 288 (%set-documentation
03:21:40 ' 289 (match-case match-ecase matchf-case matchf-ecase)
' 290 "MATCH-CASE, MATCH-ECASE, MATCHF-CASE, and MATCHF-ECASE set up a CASE-like
' 291 environment for multiple template matching clauses.
' 292
' 293 Their syntax comprises a number of clauses of the form
' 294 <clause> ::= <regular-clause> | <default-clause>
' 295 <regular-clause> ::= (<template> &body <forms>)
' 296 <default-clause> ::= (t &body <forms>)
' 297 | (otherwise &body <forms>)
' 298 <form> and <forms> are regular Common Lisp forms.
' 299 <template> is a unification template.
' 300
' 301 The full syntax is
' 302 match-case (<object> &key default-substitution named errorp) <clauses>
' 303 match-ecase (<object> &key default-substitution named) <clauses>
' 304 matchf-case (<object> &key default-substitution named errorp) <clauses>
' 305 matchf-ecase (<object> &key default-substitution named) <clauses>
' 306
' 307 Each clause evaluates its forms in an environment where the variables
' 308 present in the template are bound lexically. Note that both variable
' 309 names '?FOO' and 'FOO' are bound for convenience.
' 310
' 311 The values returned by the macros are those of the last form in
' 312 the first clause that satisfies the match test.
' 313
' 314 MATCHF-ECASE and MATCHF-CASE behave like MATCH-ECASE and MATCH-CASE, but the
' 315 patterns are not evaluated (i.e., they rely on MATCHF instead of MATCH to
' 316 construct the macro expansion).
' 317 ")
' 318
2009-12-17 mantoniotti 319
2007-11-09 mantoniotti 320 ;;;;---------------------------------------------------------------------------
13:43:20 ' 321 ;;;; Testing.
' 322
' 323 #| Tests
' 324
' 325 (let ((n 42))
' 326 (matching ()
' 327 ((0 n) 1)
' 328 ((?x n) (* x (1- x)))))
' 329
' 330
' 331 (let ((n 42))
' 332 (match-case (n)
' 333 (0 1)
' 334 (?x (* x (1- x)))))
' 335
' 336
' 337 (let ((n 42))
' 338 (match-case (n)
' 339 (0 1)
' 340 (otherwise (* n (1- n)))))
' 341
' 342 (defun fatt (x)
' 343 (match-case (x :errorp t)
' 344 (0 1)
' 345 (#T(number ?n) (* ?n (fatt (1- n))))
' 346 ))
' 347
' 348 |#
2005-04-27 mantoniotti 349
2007-11-09 mantoniotti 350 ;;;; end of file -- math-blocks.lisp --