Update of /project/cl-unification/cvsroot/cl-unification In directory clnet:/tmp/cvs-serv328

Modified Files: match-block.lisp Log Message: Made several changes to improve MATCH-CASE (following a note from Ivan Boldyrev from a long time ago), MATCHING and MATCH.

Else-clauses are now handled correctly (AFAICT).

Single variable templates in MATCH, MATCH-CASE and MATCHING clauses do not need to be quoted.

MATCHING was generating one gensym'ed variable per clause without creating an appropriate enclosing LET. This is now fixed.

--- /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2007/05/21 12:33:07 1.7 +++ /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2007/11/09 13:43:20 1.8 @@ -1,4 +1,7 @@ -;;; -*- Mode: Lisp -*- +;;;; -*- Mode: Lisp -*- + +;;;; match-block.lisp -- +;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.

(in-package "UNIFY")

@@ -14,7 +17,8 @@ (errorp t) (error-value nil)) &body forms) - "Sets up a lexical environment to evaluate FORMS after a unification operation. + "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 @@ -31,10 +35,14 @@ " (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)) + nconc (list `(,v (find-variable-value ',v + ,env-var)) `(,(clean-unify-var-name v) ,v)))) ) `(block nil @@ -42,7 +50,8 @@ (let* ((,env-var (unify ,template ,object ,substitution)) ,@(generate-var-bindings) ) - (declare (ignorable ,@(mapcar #'first (generate-var-bindings)))) + (declare (ignorable ,@(mapcar #'first + (generate-var-bindings)))) ,@forms)

;; Yes. The above is sligthly wasteful. @@ -60,9 +69,11 @@

(defmacro matching ((&key errorp - (default-substitution (make-empty-environment))) + (default-substitution + (make-empty-environment))) &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> @@ -90,7 +101,12 @@ " (declare (ignore default-substitution)) ; For the time being. (labels ((%%match%% (clause-var template object forms substitution) - (let ((template-vars (collect-template-vars template))) + (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 @@ -99,7 +115,7 @@ `(,(clean-unify-var-name v) ,v)))) ) `((setf ,clause-var - (ignore-errors (unify ',template + (ignore-errors (unify ,template ,object ,substitution))) (let* (,@(generate-var-bindings)) @@ -120,32 +136,49 @@ (> (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. + (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 - (cond ,@(mapcar (lambda (match-clause match-clause-env-var) - (build-match-clause match-clause match-clause-env-var)) - match-clauses - (mapcar (lambda (mc) - (declare (ignore mc)) - (gensym "UNIFICATION-ENV-") - ) - match-clauses)) - (,errorp - (error 'unification-non-exhaustive - :format-control "Non exhaustive matching.")) - ,@(when default-clause (list default-clause))))) - ))

+ `(block matching + (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] +;;; When 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) &rest clauses) +(defmacro match-case ((object &key errorp default-substitution) + &rest 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> @@ -183,8 +216,8 @@ (if otherwise-clause-present-p (first (last clauses)) (when errorp - `(error 'unification-non-exhaustive - :format-control "Non exhaustive matching.")))) + `(t (error 'unification-non-exhaustive + :format-control "Non exhaustive matching."))))) ) (labels ((generate-matchers (clauses) (if (null clauses) @@ -198,5 +231,34 @@ `(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 -- +;;;; end of file -- math-blocks.lisp --