1 ;;;; -*- Mode: Lisp -*- 2 3 ;;;; match-block.lisp -- 4 ;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE. 5 6 ;;;; See file COPYING for copyright licensing information. 7 8 (in-package "UNIFY") 9 10 (defun clean-unify-var-name (v) 11 (assert (variablep v)) 12 (intern (subseq (symbol-name v) 1) 13 (symbol-package v))) 14 15 (defmacro with-unification-variables ((&rest variables) environment &body body) 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 24 (defun %match-expander (template-munger clause-munger clauses 25 &key default named environment errorp error-form keyform) 26 "A rather hairy internal function which handles expansion for all the MATCH* macros. 27 28 template-munger should be either 'match or 'matchf, and will massage the 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) 97 (munge-clause clause) 98 (let* ((template (ensure-template template)) 99 (variables (collect-template-vars template))) 100 `((setf (values ,match-environment ,match-error) 101 (unify* ,template ,object (make-expanded-environment ,base-environment))) 102 (with-unification-variables ,variables ,match-environment 103 ,@body))))) 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 122 ,@(mapcar #'expand-clause match-clauses) 123 ,@(when errorp `((,errorp ,(or error-form `(error ,match-error))))) 124 ,@(when default-clauses `((t ,@(cdar default-clauses)))) 125 ,@(when default `((t ,default)))))))))) 126 127 (defmacro %set-documentation ((&rest symbols) docstring) 128 `(eval-when (:load-toplevel :execute) 129 (mapcar (lambda (fn) (setf (documentation fn 'function) ,docstring)) 130 ',symbols))) 131 132 (defmacro match ((template object 133 &key 134 (named nil) 135 (match-named nil match-named-p) 136 (substitution nil) 137 (errorp t) 138 (error-value nil)) 139 &body forms) 140 (when match-named-p 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)) 149 150 (defmacro matchf ((template object 151 &key 152 (named nil) 153 (match-named nil match-named-p) 154 (substitution nil) 155 (errorp t) 156 (error-value nil)) 157 &body forms) 158 (when match-named-p 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. 171 172 MATCH and MATCHF unify a TEMPLATE and an OBJECT and then set up a lexical 173 environment where the variables present in the template are bound 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 180 MATCH and MATCHF forms return the values returned by the evaluation of the 181 last of the FORMS. 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 186 raising from the evaluation of FORMS will /not/ be caught and handled 187 according to ERRORP settings.) 188 189 A surrounding BLOCK named NAMED is set up around the matching code.") 190 191 192 193 (define-condition unification-non-exhaustive (unification-failure) 194 () 195 (:default-initargs 196 :format-control "Non exhaustive matching.")) 197 198 199 (defmacro match-cond (&body clauses) 200 (%match-expander 'match 'cond clauses)) 201 202 (defmacro matchf-cond (&body clauses) 203 (%match-expander 'matchf 'cond clauses)) 204 205 (defmacro matching ((&key errorp 206 default-substitution 207 (named nil) 208 (matching-named nil matching-named-p)) 209 &body match-clauses) 210 (when matching-named-p 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)) 217 218 (%set-documentation 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. 222 223 Their syntax comprises a number of clauses of the form 224 <clause> ::= <regular-clause> | <default-clause> 225 <regular-clause> ::= ((<template> <form>) &body <forms>) 226 <default-clause> ::= (t &body <forms>) 227 | (otherwise &body <forms>) 228 <form> and <forms> are regular Common Lisp forms. 229 <template> is a unification template. 230 231 The full syntax is 232 match-cond <clauses> 233 matchf-cond <clauses> 234 matching (&key errorp default-substitution named) <clauses> 235 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 240 The values returned by the macros are those of the last form in 241 the first clause that satisfies the match test. 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 246 standard COND default clause. The default value of ERRORP is NIL. 247 ") 248 249 250 (defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p)) 251 &body clauses) 252 (when match-case-named-p 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)) 260 261 (defmacro match-ecase ((object &key default-substitution named) 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)) 268 269 (defmacro matchf-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p)) 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 288 (%set-documentation 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 319 320 ;;;;--------------------------------------------------------------------------- 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 |# 349 350 ;;;; end of file -- math-blocks.lisp --