[alexandria-devel] DESTRUCTURE-CLAUSES - alexandria_destruct#9CF676.diff (1/1)

[Tobias C Rittweiler]

I was pleased to discover that DESTRUCTURING-CASE made it into
Alexandria meanwhile. Very nice! This allows me to share the
little gem that I'm attaching with this posting. It's a handy
macro to make writing macros like DEFPACKAGE, DEFGENERIC of
DEFREADTABLE easy like a breeze.

Happy to be giving back again! :-)

T
diff --git a/macros.lisp b/macros.lisp
index 4450435..0d4b9e9 100644
--- a/macros.lisp
+++ b/macros.lisp
@@ -303,4 +303,76 @@ Example:
   (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
 
 
+;;; DESTRUCTURE-CLAUSES
 
+(defmacro destructure-clauses (clauses patterns &body body)
+  "Utility macro to conveniently destructure DEFPACKAGE like clauses.
+
+     clauses  ::= clause*
+     clause   ::= (keyword . list)                  ; e.g. (:FOO 1 :K 2)
+
+     patterns ::= pattern*
+     pattern  ::= (keyword . ordinary-lambda-list)  ; e.g. (:FOO N &KEY K)
+
+The CAR of each clause in CLAUSES will be tried to be matched against
+the CAR of each pattern in PATTERNS. If a match is found, the CDR of
+the matched pattern is interpreted as an ordinary lambda list and its
+parameters are bound to the values provided by the CDR of the clause.
+
+When all CLAUSES are processed, BODY will be executed with all the
+parameters of the matched patterns bound appropriately. Notice that
+parameters must hence be named distinctively in each pattern.
+
+Example:
+
+  (defmacro defpackage (name &body clauses)
+    (destructure-clauses clauses
+        ((:use &rest uses)
+         (:nicknames &rest nicknames)
+         (:export &rest exports)
+         ...)
+      (expand-defpackage name uses nicknames exports ...))
+
+Implementation note:
+
+  That a pattern consists of ordinary lambda list and not of
+  destructuring lambda lists is a /shortcoming/ of the current
+  implementation. Patches are welcome.
+"
+  (multiple-value-bind (pattern-table vars n-vars)
+      (loop for pattern in patterns
+            for vars   = (ordinary-lambda-list-parameters (cdr pattern))
+            for n-vars = (mapcar #'make-gensym vars)
+            collect (cons pattern (list vars n-vars)) into pattern-mappings
+            append vars   into all-vars
+            append n-vars into all-n-vars
+            finally
+            (return (values (alist-hash-table pattern-mappings)
+                            all-vars
+                            all-n-vars)))
+    (with-unique-names (clause)
+      `(let ,n-vars
+         (dolist (,clause ,clauses)
+           (destructuring-ecase ,clause
+             ,@(loop for p in patterns
+                     for (pattern-vars pattern-n-vars) = (gethash p pattern-table)
+                     collect `(,p ,@(loop for var   in pattern-vars
+                                          for n-var in pattern-n-vars
+                                          collect `(setq ,n-var ,var))))))
+         (let ,(mapcar #'list vars n-vars)
+           , at body)))))
+
+(defun ordinary-lambda-list-parameters (ordinary-lambda-list)
+  "Return a list of all parameter names in ORDINARY-LAMBDA-LIST."
+  (flet ((optional-parameter-name (spec)
+           (car spec))
+         (key-parameter-name (spec)
+           (second (first spec))))
+    (multiple-value-bind (reqs opts rest keys aok auxs)
+        (parse-ordinary-lambda-list ordinary-lambda-list)
+      (assert (null aok)  () "&ALLOW-OTHER-KEYS not supported.")
+      (assert (null auxs) () "&AUX not supported.")
+      (append reqs
+              (mapcar #'optional-parameter-name opts)
+              (ensure-list rest)
+              (mapcar #'key-parameter-name keys)))))
\ No newline at end of file
diff --git a/package.lisp b/package.lisp
index babeb95..a025cc7 100644
--- a/package.lisp
+++ b/package.lisp
@@ -240,4 +240,5 @@
    #:destructuring-case
    #:destructuring-ccase
    #:destructuring-ecase
+   #:destructure-clauses
    ))
diff --git a/tests.lisp b/tests.lisp
index e218113..51ea8ca 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -1856,3 +1856,47 @@
             (when err
               (incf n))))))
   13)
+
+(deftest destructure-clauses.1
+    (let ((+clauses+ '((:required-1 :R1)
+                       (:required-n :R2 :R3 :R4)
+                       (:optional-0)
+                       (:optional-1 :O2)
+                       (:key-0)
+                       (:key-1 :KEY2 :K2)
+                       (:key-n :KEY3 :K3 :KEY4 :K4)
+                       (:required+optional-0 :R5)
+                       (:required+optional-1 :R6 :O4)
+                       (:required+key :R7 :R8 :KEY5 :K5))))
+      (destructure-clauses +clauses+
+          ((:required-1 req1)
+           (:required-n req2 req3 req4)
+           (:optional-0 &optional (opt1 :O1))
+           (:optional-1 &optional opt2)
+           (:key-0 &key (key1 :K1))
+           (:key-1 &key key2)
+           (:key-n &key key3 key4)
+           (:required+optional-0 req5 &optional (opt3 :O3))
+           (:required+optional-1 req6 &optional opt4)
+           (:required+key req7 req8 &key key5))
+        (values
+         (list req1)
+         (list req2 req3 req4)
+         (list opt1)
+         (list opt2)
+         (list key1)
+         (list key2)
+         (list key3 key4)
+         (list req5 opt3)
+         (list req6 opt4)
+         (list req7 req8 key5))))
+  (:R1)
+  (:R2 :R3 :R4)
+  (:O1)
+  (:O2)
+  (:K1)
+  (:K2)
+  (:K3 :K4)
+  (:R5 :O3)
+  (:R6 :O4)
+  (:R7 :R8 :K5))
\ No newline at end of file