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