From 3c73865c134159de8d2919007b59941852998ed4 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Wed, 5 Sep 2007 19:25:34 +0200 Subject: Add MATCHING-DEFUN, a convenience wrapper around DEFUN and UNIFY:MATCH-CASE. darcs-hash:80b9a6a905d26026f39a8a656a351acaf02dcc79 --- lambda.lisp | 5 +- mulkutils.asd | 8 +-- package.lisp | 5 ++ unification.lisp | 160 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 171 insertions(+), 7 deletions(-) create mode 100644 package.lisp create mode 100644 unification.lisp diff --git a/lambda.lisp b/lambda.lisp index 2f90aa2..dd02f73 100644 --- a/lambda.lisp +++ b/lambda.lisp @@ -45,10 +45,7 @@ |# -(defpackage #:mulk.lambda - (:use #:cl) - (:export #:efn #:fn #:efn1 #:fn1 #:fn*)) -(in-package #:mulk.lambda) +(in-package #:mulk.utils) (defun collect-lambda-args (form) diff --git a/mulkutils.asd b/mulkutils.asd index 1f80267..4eda9b2 100644 --- a/mulkutils.asd +++ b/mulkutils.asd @@ -1,8 +1,10 @@ (defsystem "mulkutils" :description "Random utilities by Matthias Benkard." - :version "0.2.0" + :version "0.3pre1" :author "Matthias Benkard " :licence "GNU General Public License, version 2 or higher" - :depends-on (:arnesi) - :components ((:file "lambda")) + :depends-on (:arnesi :unification) + :components ((:file "package") + (:file "lambda") + (:file "unification")) :serial t) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..9bbca5a --- /dev/null +++ b/package.lisp @@ -0,0 +1,5 @@ +(defpackage #:mulkutils + (:nicknames #:mulk.lambda #:mulk #:mulk-utils #:mulk.utils) + (:use #:cl) + (:export #:efn #:fn #:efn1 #:fn1 #:fn* + #:matching-defun #:matching-flet #:matching-labels)) diff --git a/unification.lisp b/unification.lisp new file mode 100644 index 0000000..1d9bc36 --- /dev/null +++ b/unification.lisp @@ -0,0 +1,160 @@ +(in-package #:mulk.utils) + + +(defun split-off-declarations (clauses) + (let* ((docstring-found-p nil) + (decl-end (mismatch clauses clauses + :test #'(lambda (x y) + (declare (ignore y)) + (if (stringp x) + (and (not docstring-found-p) + (setq docstring-found-p t)) + (and (listp x) + (eq 'declare (car x)))))))) + (if (null decl-end) + (values clauses nil) + (values (subseq clauses 0 decl-end) + (subseq clauses decl-end))))) + + + +(defmacro matching-defun (function-name lambda-list &body clauses) + "Define a pattern-matching function. + +clauses ::= [[declaration\\* | documentation]] pattern-clause\\* + +pattern-clause ::= (pattern forms\\*) + + +## Arguments and Values: + +*function-name* --- a **function name**. + +*lambda-list* --- an **ordinary lambda list**. + +*declaration* --- a __declare__ **expression**; not evaluated. + +*documentation* --- a **string**; not evaluated. + +*pattern* --- a **list**; not evaluated. + +*form\\** --- an **implicit progn**. + +Returns: *function-name* --- a **function name**. + + +## Description: + +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 +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: + +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*. + +__*__ may appear anywhere after `&optional`, but not after any other +**lambda-list keyword**. + +The results of supplying the **symbol** __*__ in a position not +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). + +Note that the following definitions are all equivalent: + + (defun f ()) + (defun f (*)) + (defun f (&optional *)) + + +## Examples: + + (matching-defun fac () + ((0) 1) + ((?n) (* n (fac (1- n))))) + ;=> FAC + + (matching-defun fac-iter (* &optional (accumulator 1)) + \"An iterative version of FAC.\" + ((0) accumulator) + ((?n) (fac-iter (1- n) (* accumulator n)))) + ;=> FAC-ITER + + (matching-defun direction (* &key numericp) + ((:up) (if numericp 0 \"Up!\")) + ((:down) (if numericp 1 \"Down!\")) + ((:left) (if numericp 2 \"Left!\")) + ((:right) (if numericp 3 \"Right!\"))) + ;=> DIRECTION + + (fac 10) ;=> 3628800 + (fac-iter 10) ;=> 3628800 + (fac-iter 10 11) ;=> 39916800 + (direction :left) ;=> \"Left!\" + (direction :left :numericp t) ;=> 2 + + +## See Also: + + __defun__, __matching-labels__, __matching-flet__" + + (when (null lambda-list) + (setq lambda-list '(*))) + + (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)))))))) -- cgit v1.2.3