Documentation
Evaluate BODY with the values in LIST bound according to ATTRIBUTE-SPEC.
ATTRIBUTE-SPEC has the following form:
( required-args* [ &attribute attributes* ]
[ &allow-other-attributes others ]
[ &allow-custom-attributes customs ]
[ &body body ] )
The symbols in REQUIRED-ARGS will be positionaly bound to the
values in LIST. After the required args have been consumed any
keyword value pairs will be consumed and bound to the
corresponding attributes (binding form is just like &key in
regular lambda lists, but only keyword symbols are allowed).
If &allow-other-attributes is present then OTHERS will be bound
to a list containing all the attributes in LIST which don't have
a corresponding &attribute variable. &allow-other-attributes implies
&allow-custom-attributes and OTHERS will contain also the custom
attributes.
If &allow-custom-attributes is present then CUSTOMS will be bound
to a list containing all the custom attributes provided in (@ ...)
sections.
if &body is present then BODY will be bound to anything remaining
in LIST after attribute parsing is complete.
Source
(defmacro attribute-bind (attribute-spec attribute-values &body body)
"Evaluate BODY with the values in LIST bound according to ATTRIBUTE-SPEC.
ATTRIBUTE-SPEC has the following form:
( required-args* [ &attribute attributes* ]
[ &allow-other-attributes others ]
[ &allow-custom-attributes customs ]
[ &body body ] )
The symbols in REQUIRED-ARGS will be positionaly bound to the
values in LIST. After the required args have been consumed any
keyword value pairs will be consumed and bound to the
corresponding attributes (binding form is just like &key in
regular lambda lists, but only keyword symbols are allowed).
If &allow-other-attributes is present then OTHERS will be bound
to a list containing all the attributes in LIST which don't have
a corresponding &attribute variable. &allow-other-attributes implies
&allow-custom-attributes and OTHERS will contain also the custom
attributes.
If &allow-custom-attributes is present then CUSTOMS will be bound
to a list containing all the custom attributes provided in (@ ...)
sections.
if &body is present then BODY will be bound to anything remaining
in LIST after attribute parsing is complete."
(destructuring-bind (locals attrs flags other-attributes
custom-attributes body-var)
(parse-attribute-spec attribute-spec)
(when (and other-attributes
(not custom-attributes))
(setf custom-attributes (gensym "CUSTOM-ATTRIBUTES")))
(with-unique-names (element)
(rebinding (attribute-values)
`(let ,(remove-if #'null (append locals
attrs
flags
(list other-attributes)
(list custom-attributes)
(list body-var)))
,@(when body-var
`((declare (ignorable ,body-var))))
,@(loop
for local in locals
collect `(setf ,local (pop ,attribute-values)))
(setf ,attribute-values
(iter (for el :in ,attribute-values)
(cond ((and (listp el)
(symbolp (first el))
(string= "@" (first el)))
,(if custom-attributes
`(setf ,custom-attributes
(append ,custom-attributes
(if (cddr el)
(rest el)
(list (make-runtime-attribute-list-reference
:form (second el))))))
`(error 'illegal-attribute-use :attribute-type "custom")))
(t (collect el)))))
(iterate
(while (and (consp ,attribute-values)
(keywordp (car ,attribute-values))))
(let ((,element (pop ,attribute-values)))
(case ,element
,@(loop
for attr in attrs
;; NB: ATTR is (symbol-to-bind-to default-value),
;; we want to match against the keyword whose
;; string name is (symbol-name symbol-to-bind-to),
;; hence the intern.
collect `(,(intern (string (car attr)) :keyword) (setf ,(car attr) (pop ,attribute-values))))
,@(loop
for flag in flags
collect `(,(intern (string flag) :keyword) (setf ,flag t)))
(t
,(if other-attributes
`(progn
(push ,element ,other-attributes)
(push (pop ,attribute-values) ,other-attributes))
`(error 'unrecognized-attribute :attribute ,element))))))
,(when (null body-var)
`(when ,attribute-values
(warn "Ignoring extra elements in body: ~S" ,attribute-values)))
,(when body-var
`(setf ,body-var ,attribute-values))
,(when other-attributes
`(setf ,other-attributes (append (nreverse ,other-attributes) ,custom-attributes)))
,@(if (and (consp body)
(consp (car body))
(eql 'declare (car (car body))))
`((locally ,@body))
body))))))Source Context