[alexandria.git] updated branch master: 6ddf676 new: DESTRUCTURING-CASE, -CCASE, and -ECASE

[Nikodemus Siivola]

The branch master has been updated:
       via  6ddf67679735379135dbb85042a65257571fce0b (commit)
       via  0c6f41f5cdf5bb33111d3b21c7daae50fc636456 (commit)
      from  f5df120eff98c753d238a64c2db19c9665bc50c5 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 6ddf67679735379135dbb85042a65257571fce0b
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Thu Sep 23 18:22:28 2010 +0300

    new: DESTRUCTURING-CASE, -CCASE, and -ECASE
    
      I've been wondering about adding these for a fair while
      now, but they _are_ nice when writing eg. certain kinds
      of macros,

commit 0c6f41f5cdf5bb33111d3b21c7daae50fc636456
Author: Nikodemus Siivola <nikodemus at random-state.net>
Date:   Thu Sep 23 18:20:35 2010 +0300

    added .gitignore -files

-----------------------------------------------------------------------

Summary of changes:
 .gitignore     |    4 +++
 doc/.gitignore |    3 ++
 macros.lisp    |   74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 package.lisp   |    3 ++
 4 files changed, 84 insertions(+), 0 deletions(-)
 create mode 100644 .gitignore
 create mode 100644 doc/.gitignore

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..e832e94
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+*.fasl
+*~
+\#*
+*.patch
diff --git a/doc/.gitignore b/doc/.gitignore
new file mode 100644
index 0000000..f22577b
--- /dev/null
+++ b/doc/.gitignore
@@ -0,0 +1,3 @@
+alexandria
+include
+
diff --git a/macros.lisp b/macros.lisp
index 75ff3f4..4450435 100644
--- a/macros.lisp
+++ b/macros.lisp
@@ -230,3 +230,77 @@ Signals a PROGRAM-ERROR is the lambda-list is malformed."
               (simple-program-error "Invalid ordinary lambda-list:~%  ~S" lambda-list)))))))
     (values (nreverse required) (nreverse optional) rest (nreverse keys)
             allow-other-keys (nreverse aux))))
+
+;;;; DESTRUCTURING-*CASE
+
+(defun expand-destructuring-case (key clauses case)
+  (once-only (key)
+    `(if (typep ,key 'cons)
+         (,case (car ,key)
+           ,@(mapcar (lambda (clause)
+                       (destructuring-bind ((keys . lambda-list) &body body) clause
+                         `(,keys
+                           (destructuring-bind ,lambda-list (cdr ,key)
+                             , at body))))
+                     clauses))
+         (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
+
+(defmacro destructuring-case (keyform &body clauses)
+  "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
+KEYFORM must evaluate to a CONS.
+
+Clauses are of the form:
+
+  ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
+
+The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
+is selected, and FORMs are then executed with CDR of KEY is destructured and
+bound by the DESTRUCTURING-LAMBDA-LIST.
+
+Example:
+
+ (defun dcase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar, ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))
+     ((t &rest rest)
+      (format nil \"unknown: ~S\" rest))))
+
+  (dcase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (dcase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (dcase (list :alt1 1))         ; => \"alt: 1\"
+  (dcase (list :alt2 2))         ; => \"alt: 2\"
+  (dcase (list :quux 1 2 3))     ; => \"unknown: 1, 2, 3\"
+
+ (defun decase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar, ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))))
+
+  (decase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (decase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (decase (list :alt1 1))         ; => \"alt: 1\"
+  (decase (list :alt2 2))         ; => \"alt: 2\"
+  (decase (list :quux 1 2 3))     ; =| error
+"
+  (expand-destructuring-case keyform clauses 'case))
+
+(defmacro destructuring-ccase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ccase))
+
+(defmacro destructuring-ecase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ecase))
+
+(dolist (name '(destructuring-ccase destructuring-ecase))
+  (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
+
+
+
diff --git a/package.lisp b/package.lisp
index b5ce17b..57c3526 100644
--- a/package.lisp
+++ b/package.lisp
@@ -233,4 +233,7 @@
    #:symbolicate
    #:assoc-value
    #:rassoc-value
+   #:destructuring-case
+   #:destructuring-ccase
+   #:destructuring-ecase
    ))
-- 
Alexandria hooks/post-receive