Improve documentation for MATCHING-DEFUN, add the macros MATCHING-LABELS and MATCHING-FLET.HEADmaster

darcs-hash:300c4c44287e6f624f607473bcaa807c83bc7b4c

3 files changed, 250 insertions, 61 deletions

diff --git a/mulkutils.asd b/mulkutils.asd
index 4eda9b2..e957009 100644
--- a/mulkutils.asd
+++ b/mulkutils.asd
@@ -1,6 +1,6 @@
 (defsystem "mulkutils"
   :description "Random utilities by Matthias Benkard."
-  :version "0.3pre1"
+  :version "0.3"
   :author "Matthias Benkard <matthias@benkard.de>"
   :licence "GNU General Public License, version 2 or higher"
   :depends-on (:arnesi :unification)
diff --git a/package.lisp b/package.lisp
index 9bbca5a..984d1cf 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,5 +1,5 @@
-(defpackage #:mulkutils
-  (:nicknames #:mulk.lambda #:mulk #:mulk-utils #:mulk.utils)
+(defpackage #:mulk.utils
+  (:nicknames #:mulk.lambda #:mulk #:mulk-utils #:mulkutils)
   (:use #:cl)
   (:export #:efn #:fn #:efn1 #:fn1 #:fn*
            #:matching-defun #:matching-flet #:matching-labels))
diff --git a/unification.lisp b/unification.lisp
index 1d9bc36..2190566 100644
--- a/unification.lisp
+++ b/unification.lisp
@@ -17,13 +17,64 @@
                 (subseq clauses decl-end)))))
 
 
+(defun make-matching-fdefinition (fdefinition-prologue lambda-list clauses)
+  "MATCHING-DEFUN without the DEFUN."
+  (when (null lambda-list)
+    (setq lambda-list '(*)))
+
+  (if (not (member '* lambda-list))
+      `(,@fdefinition-prologue ,lambda-list
+         (unify:match-case (list ,@(mapcar #'(lambda (arg)
+                                               (if (atom arg)
+                                                   arg
+                                                   (first arg)))
+                                           lambda-list))
+           ,@clauses))
+      (let* ((star-position (position '* lambda-list))
+             (star-wildp (and (or (endp (nthcdr (1+ star-position) lambda-list))
+                                  (member (nth (1+ star-position) lambda-list)
+                                          '(&aux)))
+                              (null (intersection '(&key &rest &allow-other-keys)
+                                                  lambda-list)))))
+          (multiple-value-bind (declarations pattern-clauses)
+              (split-off-declarations clauses)
+            (let* ((star-args-num (if (or star-wildp (null pattern-clauses))
+                                      0
+                                      (length (first (first pattern-clauses)))))
+                   (star-args-syms
+                    (mapcar #'gensym (make-list star-args-num
+                                                :initial-element "PATTERN-ARG")))
+                   (wild-star-sym (gensym)))
+              (assert (or star-wildp
+                          (every #'(lambda (c)
+                                     (= (length (first c)) star-args-num))
+                                 pattern-clauses))
+                      (clauses lambda-list)
+                      "Patterns must be congruent if * is non-wild")
+              `(,@fdefinition-prologue ,(mapcan #'(lambda (x)
+                                                    (if (eq x '*)
+                                                        (if star-wildp
+                                                            (list '&rest
+                                                                  wild-star-sym)
+                                                            (copy-list star-args-syms))
+                                                        (list x)))
+                                                lambda-list)
+                 ,@declarations
+                 (unify:match-case (,(if star-wildp
+                                         wild-star-sym
+                                         `(list ,@star-args-syms)))
+                   ,@(mapcar #'(lambda (clause)
+                                 (cons (list 'quote (car clause))
+                                       (cdr clause)))
+                             pattern-clauses))))))))
+
 
 (defmacro matching-defun (function-name lambda-list &body clauses)
   "Define a pattern-matching function.
 
-clauses ::= [[declaration\\* | documentation]] pattern-clause\\*
+clauses ::= [[*declaration\\** | *documentation*]] *pattern-clause\\**
 
-pattern-clause ::= (pattern forms\\*)
+pattern-clause ::= (*pattern* *form\\**)
 
 
 ## Arguments and Values:
@@ -45,31 +96,43 @@ Returns: *function-name* --- a **function name**.
 
 ## Description:
 
+__matching-defun__ establishes a global function binding of
+*function-name* as if by a call to __defun__.  In contrast to __defun__,
+it uses a pattern matching language in its body with a syntax equivalent
+to the one defined by the _match-case_ macro in the
+[CL-Unification](http://common-lisp.net/project/cl-unification/) system.
+
+Please refer to the documentation of the
+[CL-Unification](http://common-lisp.net/project/cl-unification/) system
+for the syntax of *patterns*.
+
 If *lambda-list* is __nil__, all arguments are used for matching.
 Otherwise, it is expected to contain the **symbol** __*__ as if it were
-the name of a **positional argument**.  In this case, the appropriate
+the name of a positional **argument**.  In this case, the appropriate
 number of pattern arguments are inserted at the position of __*__ in
 *lambda-list*.
 
-All patterns must be congruent -- that is, they must match a fixed
-number of arguments, unless all of the following conditions are met:
+All patterns must be congruent, that is, they must all match the exact
+same number of arguments, unless all of the following conditions are
+met:
 
-1. __*__ appears as the very last **positional argument** (including
+1. __*__ appears as the very last positional **argument** (including
 `&optional` **argument**s) in *lambda-list*.
 
 2. None of `&key`, `&rest` or `&allow-other-keys` is found in
 *lambda-list*.
 
 In this case, __*__ is treated as a `&rest` **argument** to be matched
-by *clauses*.
+by *clauses*, which makes it possible to match a variable number of
+**arguments**.
 
 __*__ may appear anywhere after `&optional`, but not after any other
-**lambda-list keyword**.
+**lambda list keyword**.
 
 The results of supplying the **symbol** __*__ in a position not
-indicating a **positional argument** or supplying the same **symbol**
+indicating a positional **argument** or supplying the same **symbol**
 more than once are undefined, even if the second occurrence is in a
-position not indicating a **positional argument** (that is, an invalid
+position not indicating a positional **argument** (that is, an invalid
 position).
 
 Note that the following definitions are all equivalent:
@@ -108,53 +171,179 @@ Note that the following definitions are all equivalent:
 
 ## See Also:
 
-  __defun__, __matching-labels__, __matching-flet__"
+  __defun__, __matching-labels__, __matching-flet__
 
-  (when (null lambda-list)
-    (setq lambda-list '(*)))
+[CL-Unification]: http://common-lisp.net/project/cl-unification/"
 
-  (if (not (member '* lambda-list))
-      `(defun ,function-name ,lambda-list
-         (unify:match-case (list ,@(mapcar #'(lambda (arg)
-                                               (if (atom arg)
-                                                   arg
-                                                   (first arg)))
-                                           lambda-list))
-           ,@clauses))
-      (let* ((star-position (position '* lambda-list))
-             (star-wildp (and (or (endp (nthcdr (1+ star-position) lambda-list))
-                                  (member (nth (1+ star-position) lambda-list)
-                                          '(&aux)))
-                              (null (intersection '(&key &rest &allow-other-keys)
-                                                  lambda-list)))))
-          (multiple-value-bind (declarations pattern-clauses)
-              (split-off-declarations clauses)
-            (let* ((star-args-num (if (or star-wildp (null pattern-clauses))
-                                      0
-                                      (length (first (first pattern-clauses)))))
-                   (star-args-syms
-                    (mapcar #'gensym (make-list star-args-num
-                                                :initial-element "PATTERN-ARG")))
-                   (wild-star-sym (gensym)))
-              (assert (or star-wildp
-                          (every #'(lambda (c)
-                                     (= (length (first c)) star-args-num))
-                                 pattern-clauses))
-                      (clauses lambda-list)
-                      "Patterns must be congruent if * is non-wild")
-              `(defun ,function-name ,(mapcan #'(lambda (x)
-                                                  (if (eq x '*)
-                                                      (if star-wildp
-                                                          (list '&rest
-                                                                wild-star-sym)
-                                                          (copy-list star-args-syms))
-                                                      (list x)))
-                                              lambda-list)
-                 ,@declarations
-                 (unify:match-case (,(if star-wildp
-                                         wild-star-sym
-                                         `(list ,@star-args-syms)))
-                   ,@(mapcar #'(lambda (clause)
-                                 (cons (list 'quote (car clause))
-                                       (cdr clause)))
-                             pattern-clauses))))))))
+  (make-matching-fdefinition (list 'defun function-name)
+                             lambda-list
+                             clauses))
+
+
+(defmacro matching-labels (function-bindings &body body)
+  "Locally define mutually-recursive pattern-matching functions.
+
+function-bindings ::= ((*function-name* *lambda-list* *local-clause\\**)\\*)
+
+body ::= *declaration\\** *form\\**
+
+local-clause ::= [[*local-declaration\\** | *local-documentation*]] *pattern-clause\\**
+
+pattern-clause ::= (*local-pattern* *local-form\\**)
+
+
+## Arguments and Values:
+
+*function-name* --- a **function name**.
+
+*lambda-list* --- an **ordinary lambda list**.
+
+*local-declaration* --- a __declare__ **expression**; not evaluated.
+
+*local-documentation* --- a **string**; not evaluated.
+
+*local-pattern* --- a **list**.
+
+*local-form\\** --- an **implicit progn**.
+
+*declaration* --- a __declare__ **expression**; not evaluated.
+
+*form\\** --- an **implicit progn**.
+
+Returns: *values* --- the return **values** of the *forms*.
+
+
+## Description:
+
+__matching-labels__ evaluates *forms* in a **lexical environment** which
+includes the locally defined *function-bindings*.  Like __labels__, it
+does so in such a way that locally defined functions may lexically
+reference themselves as well as other simultaneously defined functions
+by their respective names.
+
+All definitions made by __matching-labels__ are done as if by
+__matching-defun__, syntactically as well as semantically, except that
+they are local.
+
+
+## Examples:
+
+    (matching-labels
+        ((fac-iter (* &optional (accumulator 1))
+           \"An iterative version of the factorial function.\"
+           ((0) accumulator)
+           ((?n) (fac-iter (1- n) (* accumulator n)))))  ;function calls itself
+      (fac-iter 10))
+     ;=> 3628800
+
+    (matching-labels
+        ((car (*)
+           ((nil (error \"NIL not allowed\")))
+           ((?x) (car x))))  ;function calls itself
+      (car (cons 1 2)))
+     ;=> non-termination
+
+    (matching-flet
+        ((car (*)
+           ((nil (error \"NIL not allowed\")))
+           ((?x) (car x))))  ;function calls globally-defined CAR
+      (car (cons 1 2)))
+     ;=> 1
+
+
+## See Also:
+
+  __labels__, __matching-defun__, __matching-flet__"
+
+  `(labels ,(mapcar #'(lambda (fdefinition)
+                        (destructuring-bind (function-name lambda-list . body)
+                            fdefinition
+                          (make-matching-fdefinition (list function-name)
+                                                     lambda-list
+                                                     body)))
+                    function-bindings)
+     ,@body))
+
+
+(defmacro matching-flet (function-bindings &body body)
+  "Locally define pattern-matching functions.
+
+function-bindings ::= ((*function-name* *lambda-list* *local-clause\\**)\\*)
+
+body ::= *declaration\\** *form\\**
+
+local-clause ::= [[*local-declaration\\** | *local-documentation*]] *pattern-clause\\**
+
+pattern-clause ::= (*local-pattern* *local-form\\**)
+
+
+## Arguments and Values:
+
+*function-name* --- a **function name**.
+
+*lambda-list* --- an **ordinary lambda list**.
+
+*local-declaration* --- a __declare__ **expression**; not evaluated.
+
+*local-documentation* --- a **string**; not evaluated.
+
+*local-pattern* --- a **list**.
+
+*local-form\\** --- an **implicit progn**.
+
+*declaration* --- a __declare__ **expression**; not evaluated.
+
+*form\\** --- an **implicit progn**.
+
+Returns: *values* --- the return **values** of the *forms*.
+
+
+## Description:
+
+__matching-flet__ evaluates *forms* in a **lexical environment** which
+includes the locally defined *function-bindings*.  Like __flet__, it
+does so in such a way that the **scope** of the new definitions does not
+include the definitions themselves.
+
+All definitions made by __matching-flet__ are done as if by
+__matching-defun__, syntactically as well as semantically, except that
+they are local.
+
+
+## Examples:
+
+    (matching-labels
+        ((fac-iter (* &optional (accumulator 1))
+           \"An iterative version of the factorial function.\"
+           ((0) accumulator)
+           ((?n) (fac-iter (1- n) (* accumulator n)))))  ;function calls itself
+      (fac-iter 10))
+     ;=> 3628800
+
+    (matching-labels
+        ((car (*)
+           ((nil (error \"NIL not allowed\")))
+           ((?x) (car x))))  ;function calls itself
+      (car (cons 1 2)))
+     ;=> non-termination
+
+    (matching-flet
+        ((car (*)
+           ((nil (error \"NIL not allowed\")))
+           ((?x) (car x))))  ;function calls globally-defined CAR
+      (car (cons 1 2)))
+     ;=> 1
+
+
+## See Also:
+
+  __flet__, __matching-defun__, __matching-labels__"
+
+  `(flet ,(mapcar #'(lambda (fdefinition)
+                        (destructuring-bind (function-name lambda-list . body)
+                            fdefinition
+                          (make-matching-fdefinition (list function-name)
+                                                     lambda-list
+                                                     body)))
+                    function-bindings)
+     ,@body))