From 6ddf67679735379135dbb85042a65257571fce0b Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 23 Sep 2010 18:22:28 +0300
Subject: [PATCH] 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,
---
 macros.lisp  | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 package.lisp |  3 +++
 2 files changed, 77 insertions(+)

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)
+                             ,@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
    ))
-- 
GitLab