diff options
| -rw-r--r-- | mulkutils.asd | 2 | ||||
| -rw-r--r-- | package.lisp | 4 | ||||
| -rw-r--r-- | unification.lisp | 305 |
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)) |