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