As first example, we provide an implementation of
that CLHS 3.3.4 specifies that the
result-forms of a
expression must be evaluated in the scope of the local declarations given.
(defmacro do ((&rest bindings) (end-test-form &body result-forms) &body decls-and-body &environment macro-env) (let ((loop-tag (gensym "DO-LOOP+"))) (multiple-value-bind (statements decls) (parse-declarations::parse-body decls-and-body :documentation nil) `(prog ,(loop for binding in bindings collect (destructuring-bind (var &optional init step) binding (declare (ignore step)) `(,var ,init))) ,@(build-declarations 'declare (parse-declarations decls macro-env)) ,loop-tag (when ,end-test-form (return (progn ,@result-forms))) ,@statements (psetq ,@(loop for binding in bindings appending (destructuring-bind (var &optional init step) binding (declare (ignore init)) (when step `(,var ,step))))) (go ,loop-tag)))))
In this example, all we had to do is to split a
&BODY argument up into the real body forms
and the declarations, because, conceptually, we only had to splice in a few new forms before the
actual body forms. The declarations as such aren't touched.
Notice that the expression
,@(build-declarations 'declare (parse-declarations
decls macro-env)) could (and should!) have been written much easier as a simple
wanted this to be a first and very simple introduction to the basic operators of the
Parse-Declarations library, though.
Next we implement
LET* which is a more interesting example
as it's an example of a non-trivial binding construct. A naive implementor would just go off making
LET* form expand into nested
LET forms. That would, however, be broken with respect to
declarations which must be nested alongside the bindings they affect.
:affecting parameter of filter-declaration-env, we can easily extract only
those declarations which affect a given binding. Thus:
(defmacro let* (bindings &body body &environment macro-env) (flet ((normalize-binding (binding) (cond ((symbolp binding) `(,binding nil)) ((null (cdr binding)) `(,(car binding) nil)) (t binding)))) (multiple-value-bind (real-body decls) (parse-declarations::parse-body body :documentation nil) (let ((decl-env (parse-declarations decls macro-env))) (check-declaration-env decl-env :unknown-allowed nil :warn-only t) (labels ((generate-nested-lets (bindings &optional used-binding-names) (if (null bindings) `(locally ,@(build-declarations 'declare (filter-declaration-env decl-env :include :free) (filter-declaration-env decl-env :include :bound :not-affecting used-binding-names)) ,@real-body) (destructuring-bind ((var value) . more-bindings) bindings `(let ((,var ,value)) ,@(build-declarations 'declare (filter-declaration-env decl-env :affecting `(,var))) ,(generate-nested-lets more-bindings (cons var used-binding-names))))))) (generate-nested-lets (mapcar #'normalize-binding bindings)))))))
We warn about unknown declaration specifiers, as we don't know which binding such a specifier affects. Hence, we can't know where it is supposed to be located. We could move these into the base case—which may sometimes be exactly the right decision—, but we feel that a user looking at the macroexpansion might be tricked thinking that the right thing is done even though it isn't.
For the base case, we splice in all free declaration specifiers and all bound declaration specifiers which affect bindings not established by the
LET* form. These, plus the ignored unknown declaration specifiers and the bound declaration specifiers affecting bindings established by the
LET* form, constitute all possible specifiers. So we haven't forgot any.
As last example, we show how to change the treatment of standard declaration specifiers.
We want to write a function which takes a list of optimize qualities and which adapts a given declaration-env to these qualities. Existing qualities in that declaration-env are changed, and if no qualities are given, the qualities are added. I.e.:
(defun optimize-declaration-env (declaration-env qualities &aux result-env) (flet ((ensure-car (thing) (if (consp thing) (car thing) thing))) (setq result-env (map-declaration-env #'(lambda (id args ctx) ;
OPTIMIZEare the qualities. (if (eq id 'optimize) (values id args `(,@qualities ,@(set-difference ctx qualities :key #'ensure-car))) (values id args ctx))) declaration-env)) (if (declaration-env.policy result-env) result-env (merge-declaration-envs result-env (parse-declarations `((optimize ,@qualities)) nil :nostrip t)))))