I once did it for fun to have sort of a "poor man's struct".
Here
(destructuring-bind tree . body)
is equivalent to
(with-cons-places (tree) . body)
.
In other words: (tree) is a forest which consists of one tree.
----%<-------------------------------------------------------%<----
(defmacro with-cons-places (forest &body body)
"Locally defines accessors via flet to the leafs of each car/cdr tree defined in the
specified forest - a list of lists. Each list in the specified forest defines one tree.
So it is possible to define a hierarchy of accessors to non-leaf-nodes.
Each non-nil symbol acc which occurs in one tree lst denotes an accessor acc
such that
(eq (acc lst) 'acc) is true.
Keyword symbols will be ignored. So if one specifies ((a b) . :ignore) as a tree
only the accessors a (with #'a = #'caar and #(setf a) = #'(setf caar))
and b (with #'b = #'cadar and #'(setf b) = #'(setf cadar)) will be defined.
Examples:
(with-cons-places ((search-key . attached-value))
(let ((data '((:a-key . :a-value)
(:another-key . :another-value)
(:some-key . :old-value))))
(setf (attached-value (find :some-key data :key #'search-key))
:new-value )
(attached-value (find :some-key data :key #'search-key))))
==>
:new-value
(with-cons-places (( row-col . attached-value)
((row col) . :dont-ignore)) ; will be ignored anyway
(let ((matrix '( ((1 1) . :a11) ((1 2) . :a12) ((1 3) . :a13)
((2 2) . :a22)
((3 1) . :a31) ((3 3) . :a33))))
(flet ((row-n (mat n) (remove n mat
:key #'row
:test (complement #'eql)))
(col-m (mat m) (remove m mat
:key #'col
:test (complement #'eql))))
(col-m matrix 2))))
==>
(((1 2) . :A12) ((2 2) . :A22))
(with-cons-places ((() () () () () () () () () () eleventh twelvth thirteenth))
(eleventh '(1 2 3 4 5 6 7 8 9 10 12)))
==> 12
(let ((lst (list 1 2 3 4 5 6 7 8 9 10 12)))
(with-cons-places ((() () () () () () () () () () eleventh twelvth thirteenth))
(setf (eleventh lst) 11)
lst ))
==> (1 2 3 4 5 6 7 8 9 10 11)
"
(labels ((cons-places (tree &optional (result ()))
(cond ((null tree) ())
((keywordp tree) ()) ; ignore keywords
((symbolp tree) (list (cons tree ; well, actually, its leaf.
(reverse result))))
((atom tree) ()) ; this is an error.
(T
(append
(cons-places (car tree) (cons 'car result))
(cons-places (cdr tree) (cons 'cdr result))))))
;; concatenates sequences (cxr cyr czr) into czyxr or fourth, ..., tenth
;; note the inversion in order from (.x. .y. .z.) to .zyx.
(pack-cons-place (lst &aux (pos 0))
(cond ((null lst) nil)
((null (cdr lst)) lst)
((null (cddr lst))
(cond ((equal lst '(car car)) '(caar))
((equal lst '(cdr car)) '(cadr))
((equal lst '(car cdr)) '(cdar))
((equal lst '(cdr cdr)) '(cddr))
(T lst))) ; be safe
((null (cdddr lst))
(cond ((equal lst '(car car car)) '(caaar))
((equal lst '(car cdr car)) '(cadar))
((equal lst '(car car cdr)) '(cdaar))
((equal lst '(car cdr cdr)) '(cddar))
((equal lst '(cdr car car)) '(caadr))
((equal lst '(cdr cdr car)) '(caddr))
((equal lst '(cdr car cdr)) '(cdadr))
((equal lst '(cdr cdr cdr)) '(cdddr))
( T lst))) ; be safe
((null (cddddr lst))
(cond ((equal lst '(car car car car)) '(caaaar))
((equal lst '(car car cdr car)) '(cadaar))
((equal lst '(car car car cdr)) '(cdaaar))
((equal lst '(car car cdr cdr)) '(cddaar))
((equal lst '(car cdr car car)) '(caadar))
((equal lst '(car cdr cdr car)) '(caddar))
((equal lst '(car cdr car cdr)) '(cdadar))
((equal lst '(car cdr cdr cdr)) '(cdddar))
((equal lst '(cdr car car car)) '(caaadr))
((equal lst '(cdr car cdr car)) '(cadadr))
((equal lst '(cdr car car cdr)) '(cdaadr))
((equal lst '(cdr car cdr cdr)) '(cddadr))
((equal lst '(cdr cdr car car)) '(caaddr))
((equal lst '(cdr cdr cdr car)) '(cadddr))
((equal lst '(cdr cdr car cdr)) '(cdaddr))
((equal lst '(cdr cdr cdr cdr)) '(cddddr))
( T lst))) ; be safe
;; first to tenth are applicable.
;; Note: first to fourth are already handled by the previous cases:
;; car, cadr, caddr, or cadddr.
((< (setf pos (position 'car lst)) ; relies on the fact, that only car and cdr exists in lst
9)
(cons (nth pos '(first second third fourth fifth sixth seventh eighth ninth tenth))
(pack-cons-place (nthcdr pos (cdr lst)))))
;; split up the sequence into subsequences of length at most 4.
(T (append (pack-cons-place (list (car lst) (cadr lst) (caddr lst) (cadddr lst)))
(pack-cons-place (cddddr lst)))))))
(let* ((accessors (mapcan #'cons-places forest))
(names (mapcar #'car accessors))
(functions (mapcan #'(lambda (name-acc)
(let ((name (car name-acc))
(accessor
(pack-cons-place
(cdr name-acc)))
(result 'X))
(dolist (acc accessor)
(setf result `(,acc ,result)))
`((,name (X) ,result) ; the reader
((setf ,name) (Y X) (setf ,result Y))))) ; the writer
accessors)))
`(flet ,functions
(declare (ignorable ,@(mapcan #'(lambda (name)
`((function ,name) (function (setf ,name))))
names)))
. ,body))))
----%<-------------------------------------------------------%<----
Norbert
WJ wrote:
> Matthew Danish wrote:
>> (destructuring-bind (a b (c d)) (list 1 2 (list 3 4))
>> (list b c d a))
> Clojure:
> (let [[a b [c d]] (list 1 2 (list 3 4))]
> (list b c d a))
> ==> (2 3 4 1)
