- cl-unification-cvs@lists.common-lisp.net

[cl-unification-cvs] CVS cl-unification
by mantoniotti 13 Jul '08

13 Jul '08

Update of /project/cl-unification/cvsroot/cl-unification In directory clnet:/tmp/cvs-serv29979 Modified Files: INSTALLATION Log Message: Instructions updated. --- /project/cl-unification/cvsroot/cl-unification/INSTALLATION 2007/05/21 17:11:47 1.2 +++ /project/cl-unification/cvsroot/cl-unification/INSTALLATION 2008/07/13 13:20:01 1.3 @@ -5,20 +5,26 @@ Issuing - (mk:load-system "unification") + (mk:load-system "CL-UNIFICATION") or - (mk:compile-system "unification") + (mk:compile-system "CL-UNIFICATION") will make the UNIFY package available. There is also an ASDF system definition for those who use this system. +Issuing + + (asdf:oos 'asdf:load-op "CL-UNIFICATION") + +should make the library available in your environment. + If your CL implementation is ASDF-INSTALL aware, you should also be able to just say - (asdf-install:install "unification") + (asdf-install:install "CL-UNIFICATION") provided that the package is unpacked in an ASDF-INSTALL known directory.

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 13 Jul '08

13 Jul '08

Update of /project/cl-unification/cvsroot/cl-unification In directory clnet:/tmp/cvs-serv29515 Modified Files: COPYING Log Message: Copyright dates updated. --- /project/cl-unification/cvsroot/cl-unification/COPYING 2007/05/21 17:11:45 1.3 +++ /project/cl-unification/cvsroot/cl-unification/COPYING 2008/07/13 13:17:29 1.4 @@ -1,4 +1,4 @@ -Copyright (c) 2004-2007 Marco Antoniotti +Copyright (c) 2004-2008 Marco Antoniotti All rights reserved. Permission is hereby granted, without written agreement and without

1 0

[cl-unification-cvs] CVS cl-unification/test
by mantoniotti 13 Jul '08

13 Jul '08

Update of /project/cl-unification/cvsroot/cl-unification/test In directory clnet:/tmp/cvs-serv28935 Added Files: unification-tests.lisp Log Message: Added file. --- /project/cl-unification/cvsroot/cl-unification/test/unification-tests.lisp 2008/07/13 13:14:56 NONE +++ /project/cl-unification/cvsroot/cl-unification/test/unification-tests.lisp 2008/07/13 13:14:56 1.1 ;;;; -*- Mode: Lisp -*- ;;;; unification-tests.lisp -- ;;;; CL-UNIFICATION test suite. Requires Franz's util.test package. (use-package "UNIFY") (use-package "UTIL.TEST") (with-tests (:name "basic constant unification") (test t (unify:environment-p (unify 42 42))) (test-error (unify 42 12) :condition-type 'unification-failure) (test-error (unify 42 'a) :condition-type 'unification-failure) (test t (unify:environment-p (unify 'a 'a))) (test t (unify:environment-p (unify '(a s d) '(a s d)))) (test t (unify:environment-p (unify '(a (s 42) d) '(a (s 42) d)))) (test-error (unify '(a (s forty-two) d) '(a (s 42) z)) :condition-type 'unification-failure) (test t (unify:environment-p (unify #(a s d) #(a s d)))) (test t (unify:environment-p (unify #2a((a s d) (a s d)) #2a((a s d) (a s d))))) (test-error (unify #2a((a s d) (a s d)) #2a((a s d) (a 42 d))) :condition-type 'unification-failure) (test t (unify:environment-p (unify "I am a string" "I am a string"))) (test-error (unify "I am a string" "I am A string") :condition-type 'unification-failure) (test t (let ((*unify-string-case-insensitive-p* t)) (unify:environment-p (unify "I am a string" "I am A string")))) ) (with-tests (:name "variables unification") (test '(42 T) (find-variable-value '?x (unify 42 '?x)) :multiple-values t) (test '(NIL NIL) (find-variable-value '?y (unify 42 '?x)) :multiple-values t) (test '(42 T) (find-variable-value '?x (unify '?x 42)) :multiple-values t) (test '(s T) (v? '?x (unify '(a (?x 42) d) '(a (s 42) d))) :multiple-values t) (test '(s T) (v? '?x (unify '(a (?x 42) d) '(a (s 42) d))) :multiple-values t) (test '((?x 42) T) (v? '?z (unify '(a (?x 42) d) '(a ?z d))) :multiple-values t :test 'equal) (test '(NIL T) (v? '?x (unify '(a (?x 42) d) '(a (() 42) d))) :multiple-values t) (test '(NIL NIL) (v? '?variable (unify '(a (() 42) d) '(a (?x 42) d))) :multiple-values t) (test t (unify:environment-p (unify '_ '(1 2 3)))) (test t (unify:environment-p (unify '_ '(1 _ 3)))) (test t (unify:environment-p (unify '(1 2 _) '(1 _ 3)))) (test t (unify:environment-p (unify '(1 2 _) '(1 _ 3)))) (test '(2 T) (v? '?x (unify #(1 2 _) #(1 ?x 3))) :multiple-values t) (test-error (unify '(1 2 _) #(1 _ 3)) :condition-type 'unification-failure :known-failure t :fail-info "Unification on SEQUENCEs does not discriminate type.") ) (with-tests (:name "basic templates unification") (with-tests (:name "number templates unification") (test t (unify:environment-p (unify #T(number 42) 42))) (test t (unify:environment-p (unify 42 #T(number 42)))) (test t (unify:environment-p (unify 42 #T(integer 42)))) (test t (unify:environment-p (unify 42 #T(fixnum 42)))) (test t (unify:environment-p (unify 42.0 #T(real 42)))) (test t (unify:environment-p (unify #C(0 1) #T(complex #C(0 1))))) (test '(42 T) (v? '?x (unify #T(number ?x) 42)) :multiple-values t) (test-error (unify 42 #T(float 42.0)) :condition-type 'unification-failure :known-failure t :fail-info "Check rules for unification on numeric tower.") ) ) (defclass test1 () ((a :initarg :a :accessor a) (b :initarg :b :accessor b))) (with-tests (:name "advanced templates unification") (test '(a T) (v? '?x (unify #2A((1 #T(symbol ?x) 3) (_ _ _)) #2A((1 a 3) (q w e)))) :multiple-values t) (test '(#\f T) (ignore-errors (v? '?x (unify "asdfasdfasdf" #T(elt 3 ?x)))) :multiple-values t :known-failure t :fail-info "ELT templates must be fixed.") (test '(42 T) (ignore-errors (v? 'x (unify '(0 1 42 3 4 5) #T(nth 2 ?x)))) :multiple-values t :known-failure t :fail-info "NTH templates must be fixed.") (test '(2 T) (v? '?x (unify #T(test1 a #T(list 1 ?x 3 &rest) b "woot") (make-instance 'test1 :a '(1 2 3) :b "woot"))) :multiple-values t) ) (defun nested-match-cases (input) (match-case (input) ('(:a ?a :b #T(list &rest ?bs)) (loop for b in ?bs collect (match-case (b) ('(:c ?c) ?c) ('(:d ?d) ?d) (otherwise (error "error-inner"))))) (otherwise "error-outer"))) (with-tests (:name "control flow") (test "error-outer" (nested-match-cases '(:a 42 :b 33)) :test 'string=) ) ;;;; end of file -- unification-tests.lisp --

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 13 Jul '08

13 Jul '08

Update of /project/cl-unification/cvsroot/cl-unification In directory clnet:/tmp/cvs-serv27424 Modified Files: substitutions.lisp templates-hierarchy.lisp unification-package.lisp variables.lisp Log Message: Some modification added. Exported symbols and reverted reader macro #T to construct template instances at read time. Added MAKE-LOAD-FORM method for templates which should fix problem with SBCL. Committing in . Modified Files: substitutions.lisp templates-hierarchy.lisp unification-package.lisp variables.lisp --- /project/cl-unification/cvsroot/cl-unification/substitutions.lisp 2007/11/09 13:35:55 1.3 +++ /project/cl-unification/cvsroot/cl-unification/substitutions.lisp 2008/07/13 13:10:48 1.4 @@ -138,4 +138,12 @@ env)) +(defun v? (s env &optional (plain-symbol-p nil)) + (find-variable-value (if plain-symbol-p + (make-var-name s) + s) + env)) + + + ;;;; end of file -- substitutions.lisp -- --- /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2006/07/19 21:52:34 1.3 +++ /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2008/07/13 13:10:48 1.4 @@ -219,9 +219,13 @@ (defgeneric make-template (kind spec)) + ;;; Setting up the reader macro. -#|| +;;; 20080711 MA: +;;; Reverted to the old version with MAKE-LOAD-FORM added. Template +;;; objects are created at read-time. + (defun |sharp-T-reader| (stream subchar arg) (declare (ignore subchar arg)) (let ((spec (read stream t nil t))) @@ -229,12 +233,19 @@ (null (make-template nil spec)) (cons (make-template (first spec) spec)) (t (make-template spec spec))))) -||# +(defmethod make-load-form ((x template) &optional env) + (make-load-form-saving-slots x :environment env)) -;;; New version with more 'macro-like' behavior. The previous version + +#|| +;;; Version with more 'macro-like' behavior. The previous version ;;; created an object at read-time, which may cause problems with ;;; MAKE-LOAD-FORMs, constant-ness etc etc. +;;; +;;; 20080713 MA +;;; Removed because it was not working well with nested templates. +;;; Reverted to the original one plus MAKE-LOAD-FORM. (defun |sharp-T-reader| (stream subchar arg) (declare (ignore subchar arg)) @@ -244,10 +255,34 @@ (cons `(make-template ',(first spec) ',spec)) (t `(make-template ',spec ',spec))) )) - +||# (eval-when (:load-toplevel :execute) - (set-dispatch-macro-character #\# #\T #'|sharp-T-reader|)) + (set-dispatch-macro-character #\# #\T '|sharp-T-reader|)) + + +#|| Useless with the read time templates and MAKE-LOAD-FORM. + +(defun rewrite-template-spec (spec) + "Rewrites a template specification. +The rewriting simply makes sure that sub-templates are created as needed. +The result is either the SPEC itself or an appropriate call to LIST." + + (typecase spec + (atom `',spec) + (cons (destructuring-bind (head &rest tail) + spec + (case head + (quote spec) + (make-template `(make-template ,(first tail) + ,(rewrite-template-spec (second (second tail))))) + (t `(list ',head ,@(mapcar #'rewrite-template-spec tail))) + ))) + (t `',spec))) + +||# + + (defmethod make-template ((kind null) (spec symbol)) (assert (null spec) (spec) "MAKE-TEMPLATE called erroneously with ~S and ~S." kind spec) @@ -324,8 +359,8 @@ - -;;; Implementation. +;;;;=========================================================================== +;;;; Implementation. ;;; Symbol Templates. ;;; Specification is --- /project/cl-unification/cvsroot/cl-unification/unification-package.lisp 2007/05/21 12:33:15 1.3 +++ /project/cl-unification/cvsroot/cl-unification/unification-package.lisp 2008/07/13 13:10:48 1.4 @@ -6,16 +6,29 @@ This package contains all the definitions necessary for the general Common Lisp unifier to work. The package also has the \"UNIFY\" nickname.") + (:export "MAKE-TEMPLATE" "TEMPLATEP" "TEMPLATE-SPEC") + (:export "*UNIFY-STRING-CASE-INSENSITIVE-P*" "UNIFY" "FIND-VARIABLE-VALUE" + "V?" + "MAKE-EMPTY-ENVIRONMENT" - "APPLY-SUBSTITUTION") + "APPLY-SUBSTITUTION" + + "UNIFICATION-FAILURE" + "UNIFICATION-VARIABLE-UNBOUND" + ) + + (:export + "ENVIRONMENT" + "ENVIRONMENT-P") + (:export "MATCH" "MATCHING" --- /project/cl-unification/cvsroot/cl-unification/variables.lisp 2004/11/17 22:19:55 1.1.1.1 +++ /project/cl-unification/cvsroot/cl-unification/variables.lisp 2008/07/13 13:10:48 1.2 @@ -2,6 +2,11 @@ (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow. + +(defun make-var-name (&optional (s (gensym)) (package *package*)) + (intern (concatenate 'string "?" (symbol-name s)) package)) + + (defun variablep (x) (and (symbolp x) (or (char= (char (symbol-name x) 0) #\?)

1 0

[cl-unification-cvs] CVS cl-unification/test
by mantoniotti 13 Jul '08

13 Jul '08

Update of /project/cl-unification/cvsroot/cl-unification/test In directory clnet:/tmp/cvs-serv27166/test Log Message: Directory /project/cl-unification/cvsroot/cl-unification/test added to the repository

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 13 Jul '08

13 Jul '08

Update of /project/cl-unification/cvsroot/cl-unification In directory clnet:/tmp/cvs-serv20645 Modified Files: cl-unification.system Log Message: Added explicit :source-extension to accomodate Allegro CL. --- /project/cl-unification/cvsroot/cl-unification/cl-unification.system 2007/11/09 13:34:21 1.1 +++ /project/cl-unification/cvsroot/cl-unification/cl-unification.system 2008/07/13 12:51:14 1.2 @@ -4,13 +4,14 @@ ;;;; MK:DEFSYSTEM system file. (mk:defsystem "CL-UNIFICATION" - :components ("unification-package" - "variables" - "substitutions" - "lambda-list-parsing" - "templates-hierarchy" - "unifier" - "match-block" - "apply-substitution")) + :source-extension "lisp" + :components ("unification-package" + "variables" + "substitutions" + "lambda-list-parsing" + "templates-hierarchy" + "unifier" + "match-block" + "apply-substitution")) ;;; end of file -- cl-unification.system --

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 10 Jul '08

10 Jul '08

Update of /project/cl-unification/cvsroot/cl-unification In directory clnet:/tmp/cvs-serv1437 Modified Files: apply-substitution.lisp Log Message: Removed EXPORT of APPLY-SUBSTITUTION as it is already in the DEFPACKAGE. --- /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp 2007/05/21 12:33:05 1.1 +++ /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp 2008/07/10 17:39:16 1.2 @@ -18,7 +18,8 @@ (multiple-value-bind (val foundp) (find-variable-value s substitution) (cond (foundp val) - (t (warn "~S is a free variable in the current environment." s) + (t (warn "~S is a free variable in the current environment." + s) s)))) (t s))) @@ -30,9 +31,6 @@ (defmethod apply-substitution ((substitution environment) (l null)) '()) -(export '(apply-substitution)) - - (defun ground-term (term &optional (substitution (make-empty-environment))) (apply-substitution substitution term))

1 0

[cl-unification-cvs] CVS cl-unification/docs/html
by mantoniotti 09 Nov '07

09 Nov '07

Update of /project/cl-unification/cvsroot/cl-unification/docs/html In directory clnet:/tmp/cvs-serv1902 Modified Files: index.html Log Message: Changed the position of the disclaimer. --- /project/cl-unification/cvsroot/cl-unification/docs/html/index.html 2007/05/21 17:10:26 1.5 +++ /project/cl-unification/cvsroot/cl-unification/docs/html/index.html 2007/11/09 13:56:40 1.6 @@ -34,23 +34,6 @@ <h1>Common Lisp Extensions: UNIFICATION</h1> - - <hr> - - - DISCLAIMER: The code associated to these documents is not - completely tested and it is bound to contain errors and omissions. - This documentation may contain errors and omissions as well. - - The file <tt>COPYING</tt> contains a Berkeley-style license. You - are advised to use the code at your own risk. No warranty - whatsoever is provided, the author will not be held responsible for - any effect generated by your use of the library, and you can put - here the scarier extra disclaimer you can think of. - - - <hr> - The notion of unification originated in the field of formal logic (e.g. <a href="#R65">[R65]</a>,) and has been used extensively in Computer Science and Programming Languages. Most @@ -303,6 +286,25 @@ <a name="R65">[R56]</a> J. A. Robinson, A machine-oriented logic based on the resolution principle, Journal of the ACM, Vol. 12, No. 1, January 1965, Pages 23--49. + + + <h1></h1> + <hr> + + + DISCLAIMER: The code associated to these documents is not + completely tested and it is bound to contain errors and omissions. + This documentation may contain errors and omissions as well. + + The file <tt>COPYING</tt> contains a Berkeley-style license. You + are advised to use the code at your own risk. No warranty + whatsoever is provided, the author will not be held responsible for + any effect generated by your use of the library, and you can put + here the scarier extra disclaimer you can think of. + + + <hr> + <!-- @@ -347,6 +349,8 @@ <ul> + <li>2007-11-09 + Updated. <li>2004-11-04 Updated. <li>2004-05-05

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 09 Nov '07

09 Nov '07

Update of /project/cl-unification/cvsroot/cl-unification In directory clnet:/tmp/cvs-serv789 Modified Files: ChangeLog Log Message: ChangeLog updated. --- /project/cl-unification/cvsroot/cl-unification/ChangeLog 2007/05/21 17:12:58 1.3 +++ /project/cl-unification/cvsroot/cl-unification/ChangeLog 2007/11/09 13:47:00 1.4 @@ -1,3 +1,55 @@ +2007-11-09 author <author(a)papadopoulou-2.ydras.offices.aueb.gr> + + * match-block.lisp: + 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. + + * substitutions.lisp: + Changed the top comment and added a (:copier nil) option to the + ENVIRONMENT defstruct, as COPY-ENVIRONMENT is defined later in the + file. + + * cl-unification.system, cl-unification.asd: + Added the new system building files with more meaningful names + w.r.t. the name of the library. + + * unification.asd, unification.system: + Marked the two system building files as 'obsolete', before removing + them from the repository. The new files are prefixed by 'cl-'. + +2007-05-21 author <author(a)papadopoulou-2.ydras.offices.aueb.gr> + + * ChangeLog: ChangeLog updated. + + * README, ACKNOWLEDGEMENTS, COPYING, INSTALLATION: + Updated copyrights dates and changed a few instructions in the + INSTALLATION file. + + * docs/html/index.html: Updated copyrights dates. + + * ChangeLog: ChangeLog updated. + + * unification-package.lisp, unification.asd, apply-substitution.lisp, match-block.lisp, substitutions.lisp: + See previous message. + + * unification.system: + Added file 'apply-substitition.lisp' with a few new functions that are + a start for the variable substitition operation. + + New fixes to the MATCH and MATCH-CASE macros. They should now work as + advertised. + + Minor changes to other files: added exports to package file, fixed + .system and .asd files. + 2007-05-21 author <author(a)Paniscia-di-Marco-Antoniotti.local> * README, ACKNOWLEDGEMENTS, COPYING, INSTALLATION:

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 09 Nov '07

09 Nov '07

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 --

1 0