match-block.lisp 15.2 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
;;;; -*- Mode: Lisp -*-

;;;; match-block.lisp --
;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.

;;;; See file COPYING for copyright licensing information.

(in-package "UNIFY")

(defun clean-unify-var-name (v)
  (assert (variablep v))
  (intern (subseq (symbol-name v) 1)
          (symbol-package v)))


(defmacro match ((template object
                           &key
                           (match-named nil)
                           (substitution '(make-empty-environment))
                           (errorp t)
                           (error-value nil))
                 &body forms)
  "Sets up a lexical environment to evaluate FORMS after an unification.

MATCH unifies a TEMPLATE and an OBJECT and then sets up a lexical
environment where the variables present in the template are bound
lexically.  Note that both variable names '?FOO' and 'FOO' are bound
for convenience.

The MATCH form returns the values returned by the evaluation of the
last of the FORMS.

If ERRORP is non-NIL (the default) then the form raises a
UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
raising from the evaluation of FORMS will also be caught and handled
according to ERRORP settings.)

If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
is set up around the matching code.
"
  (let ((template-vars (collect-template-vars template))
        (env-var (gensym "UNIFICATION-ENV-"))
        (template (if (variablep template)
                      `',template ; Logical variables are special-cased.
                      template))
        )
    (flet ((generate-var-bindings ()
             (loop for v in template-vars
                   nconc (list `(,v (find-variable-value ',v
                                                         ,env-var))
                               `(,(clean-unify-var-name v) ,v))))
           )
      `(block ,match-named
         (handler-case
             (let* ((,env-var (unify ,template ,object ,substitution))
                    ,@(generate-var-bindings)
                    )
	       (declare (ignorable ,@(mapcar #'first
                                             (generate-var-bindings))))
               ,@forms)

           ;; Yes.  The above is sligthly wasteful.

           (unification-failure (uf)
                                (if ,errorp
                                    (error uf)
                                    ,error-value))
           )))))


(defmacro matchf ((template object
                            &key
                            (match-named nil)
                            (substitution '(make-empty-environment))
                            (errorp t)
                            (error-value nil))
                  &body forms)
  "Sets up a lexical environment to evaluate FORMS after an unification.

MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical
environment where the variables present in the template are bound
lexically.  Note that both variable names '?FOO' and 'FOO' are bound
for convenience.

MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
generate a template at read-time).

The MATCHF form returns the values returned by the evaluation of the
last of the FORMS.

If ERRORP is non-NIL (the default) then the form raises a
UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
raising from the evaluation of FORMS will also be caught and handled
according to ERRORP settings.)

If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
is set up around the matching code.
"
  (let ((template-vars (collect-template-vars template))
        (env-var (gensym "UNIFICATION-ENV-"))
        (template (cond ((variablep template)
                         `',template) ; Logical variables are special-cased.
                        ((listp template) ; Same for lists.
                         (make-instance 'list-template
                                        :spec (cons 'list template)))
                        ;`',template)
                        (t
                         template)))
        )
    ;; Logical variables and lists are special cased for convenience.
    ;; Lists are especially inteded as abbreviation for destructuring.
    (flet ((generate-var-bindings ()
             (loop for v in template-vars
                   nconc (list `(,v (find-variable-value ',v
                                                         ,env-var))
                               `(,(clean-unify-var-name v) ,v))))
           )
      `(block ,match-named
         (handler-case
             (let* ((,env-var (unify ,template ,object ,substitution))
                    ,@(generate-var-bindings)
                    )
	       (declare (ignorable ,@(mapcar #'first
                                             (generate-var-bindings))))
               ,@forms)

           ;; Yes.  The above is sligthly wasteful.

           (unification-failure (uf)
                                (if ,errorp
                                    (error uf)
                                    ,error-value))
           )))))



(define-condition unification-non-exhaustive (unification-failure)
  ())


(defmacro matching ((&key errorp
                          (default-substitution
                           (make-empty-environment))
                          (matching-named nil))
                    &rest match-clauses)
  "MATCHING sets up a COND-like environment for multiple template matching clauses.

The syntax of MATCHING comprises a number of clauses of the form

  <clause> ::= <regular-clause> | <default-clause>
  <regular-clause> ::= ((<template> <form>) &body <forms>)
  <default-clause> ::= (t &body <forms>)
                   |   (otherwise &body <forms>)
<form> and <forms> are regular Common Lisp forms.
<template> is a unification template.

The full syntax of MATCHING is

  matching (&key errorp default-substitution) <clauses>

Each clause evaluates its forms in an environment where the variables
present in the template are bound lexically.  Note that both variable
names '?FOO' and 'FOO' are bound for convenience.

The values returned by the MATCHING form are those of the last form in
the first clause that satisfies the match test.

If ERRORP is non-NIL then if none of the regular clauses matches, then
an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
any default clause.  Otherwise, the default clause behaves as a
standard COND default clause.  The default value of ERRORP is NIL.
"
  (declare (ignore default-substitution)) ; For the time being.
  (labels ((%%match%% (clause-var template object forms substitution)
             (let ((template-vars (collect-template-vars template))
                   (template (if (variablep template)
                                 `',template ; Logical variables are
                                             ; special-cased.
                                 template))
                   )
               (flet ((generate-var-bindings ()
                        (loop for v in template-vars
                              nconc (list `(,v (find-variable-value
						',v
						,clause-var))
                                          `(,(clean-unify-var-name v) ,v))))
                      )
                 `((setf ,clause-var
                         (ignore-errors (unify ,template
					       ,object
					       ,substitution)))
                   (let* (,@(generate-var-bindings))
                     ,@forms))
                 )))

           (build-match-clause (match-clause match-env-var)
             (destructuring-bind ((template object) &body forms)
                 match-clause
               (%%match%% match-env-var
			  template
			  object
			  forms
			  '(make-empty-environment))))
           )
    (when (or (and (find t match-clauses :key #'first)
		   (find 'otherwise match-clauses :key #'first))
	      (> (count t match-clauses :key #'first) 1)
              (> (count 'otherwise match-clauses :key #'first) 1))
      (error 'program-error))
    (let* ((default-clause (or (find t match-clauses
                                     :key #'first)
                               (find 'otherwise match-clauses
                                     :key #'first)))
           (match-clauses (delete default-clause match-clauses)) ; EQL
                                                                 ; test
                                                                 ; suffices.
           (match-clauses-env-vars (mapcar (lambda (mc)
                                             (declare (ignore mc))
                                             (gensym "UNIFICATION-ENV-")
                                             )
                                           match-clauses))
           )

      `(block ,matching-named
         (let ,match-clauses-env-vars
	   (declare (dynamic-extent ,@match-clauses-env-vars))
           (cond ,@(mapcar (lambda (match-clause match-clause-env-var)
                             (build-match-clause match-clause
                                                 match-clause-env-var))
                           match-clauses
                           match-clauses-env-vars)
                 (,errorp
                  (error 'unification-non-exhaustive
                         :format-control "Non exhaustive matching."))
                 ,@(when default-clause (list default-clause))))))
    ))


;;; match-case --
;;; Implementation provided by Peter Scott.
;;;
;;; Notes:
;;;
;;; [MA 20071109]
;;; The construction of the inner MATCH clauses could be done
;;; more intelligently by supplying :ERRORP NIL, thus avoiding the
;;; HANDLER-CASEs, which are quite expensive.  Any takers?

(defmacro match-case ((object &key errorp default-substitution match-case-named)
                      &body clauses)
  "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.

The syntax of MATCH-CASE comprises a number of clauses of the form

  <clause> ::= <regular-clause> | <default-clause>
  <regular-clause> ::= (<template> &body <forms>)
  <default-clause> ::= (t &body <forms>)
                   |   (otherwise &body <forms>)
<form> and <forms> are regular Common Lisp forms.
<template> is a unification template.

The full syntax of MATCH-CASE is

  match-case (<object> &key errorp default-substitution) <clauses>

Each clause evaluates its forms in an environment where the variables
present in the template are bound lexically.  Note that both variable
names '?FOO' and 'FOO' are bound for convenience.

The values returned by the MATCH-CASE form are those of the last form in
the first clause that satisfies the match test.

If ERRORP is non-NIL then if none of the regular clauses matches, then
an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
any default clause.  Otherwise, the default clause behaves as a
standard CASE default clause.  The default value of ERRORP is NIL.
"
  (declare (ignore default-substitution)) ; For the time being.
  (let* ((object-var (gensym "OBJECT-VAR-"))
         (otherwise-clause-present-p
          (member (caar (last clauses)) '(t otherwise)))
	 (non-otherwise-clauses
          (if otherwise-clause-present-p
              (butlast clauses)
              clauses))
	 (otherwise-clause
          (if otherwise-clause-present-p
              (first (last clauses))
              (when errorp
                `(t (error 'unification-non-exhaustive
                           :format-control "Non exhaustive matching.")))))
         )
    (labels ((generate-matchers (clauses)
	       (if (null clauses)
		   `(progn ,@(rest otherwise-clause))
		   (destructuring-bind (pattern &rest body)
		       (car clauses)
		     `(handler-case (match (,pattern ,object-var)
				      ,@body)
		        (unification-failure ()
			  ,(generate-matchers (cdr clauses))))))))
      `(block ,match-case-named
         (let ((,object-var ,object))
           ,(generate-matchers non-otherwise-clauses))))))


(defmacro matchf-case ((object &key errorp default-substitution match-case-named)
                      &body clauses)
  "MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses.

The syntax of MATCHF-CASE comprises a number of clauses of the form

  <clause> ::= <regular-clause> | <default-clause>
  <regular-clause> ::= (<template> &body <forms>)
  <default-clause> ::= (t &body <forms>)
                   |   (otherwise &body <forms>)
<form> and <forms> are regular Common Lisp forms.
<template> is a unification template.

The full syntax of MATCHF-CASE is

  matchf-case (<object> &key errorp default-substitution) <clauses>

Each clause evaluates its forms in an environment where the variables
present in the template are bound lexically.  Note that both variable
names '?FOO' and 'FOO' are bound for convenience.

The values returned by the MATCH-CASE form are those of the last form in
the first clause that satisfies the match test.

If ERRORP is non-NIL then if none of the regular clauses matches, then
an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
any default clause.  Otherwise, the default clause behaves as a
standard CASE default clause.  The default value of ERRORP is NIL.

MATCHF-CASE behaves like MATCH-CASE, but the patterns are not
evaluated (i.e., it relies on MATCHF instead of MATCH to construct the
macro expansion.
"
  (declare (ignore default-substitution)) ; For the time being.
  (let* ((object-var (gensym "OBJECT-VAR-"))
         (otherwise-clause-present-p
          (member (caar (last clauses)) '(t otherwise)))
	 (non-otherwise-clauses
          (if otherwise-clause-present-p
              (butlast clauses)
              clauses))
	 (otherwise-clause
          (if otherwise-clause-present-p
              (first (last clauses))
              (when errorp
                `(t (error 'unification-non-exhaustive
                           :format-control "Non exhaustive matching.")))))
         )
    (labels ((generate-matchers (clauses)
	       (if (null clauses)
		   `(progn ,@(rest otherwise-clause))
		   (destructuring-bind (pattern &rest body)
		       (car clauses)
		     `(handler-case (matchf (,pattern ,object-var)
				      ,@body)
		        (unification-failure ()
			  ,(generate-matchers (cdr clauses))))))))
      `(block ,match-case-named
         (let ((,object-var ,object))
           ,(generate-matchers non-otherwise-clauses))))))

;;;;---------------------------------------------------------------------------
;;;; Testing.

#| Tests

(let ((n 42))
  (matching ()
            ((0 n) 1)
            ((?x n) (* x (1- x)))))


(let ((n 42))
  (match-case (n)
              (0 1)
              (?x (* x (1- x)))))


(let ((n 42))
  (match-case (n)
              (0 1)
              (otherwise (* n (1- n)))))

(defun fatt (x)
  (match-case (x :errorp t)
              (0 1)
              (#T(number ?n) (* ?n (fatt (1- n))))
              ))

|#

;;;; end of file -- math-blocks.lisp --