[cl-unification-cvs] CVS cl-unification
mantoniotti
mantoniotti at common-lisp.net
Fri Nov 9 13:43:20 UTC 2007
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))))
, at 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 , at 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 --
More information about the Cl-unification-cvs
mailing list