Here's one implementation, at the end of this message. As Tim Moore
suggests, you'd ideally do it with symbol macros and augmentating
environments, but I think you can do the same thing by establishing
the appropriate environment around the relevant subforms with a number
of LETs.
One complication is that the temporary variables returned from a SETF
method are bound in a LET*, but a LET's bindings have to be done in
parallel. This makes the SETF method for LET* simpler, so I've
included that first, as a build-up to the LET method. Another thing
common to both is that the body of the LET (minus the last subform)
has to be evaluated in the context of the LET bindings, but before the
access and store forms for the last subform are evaluated. I've done
that here with a bogus variable binding.
I have to agree with Tim in that I wouldn't find this to be very
useful. Most macro definitions I write require rather idiosyncratic
SETF methods.
Anyway, this definition gives this example:
(setf (let ((x (foo 1 2))
(y (bar 3 4)))
(do-stuff x y)
(car x))
z)
the following expansion, modulo some renamed variables:
(let* ((temp-x nil)
(temp-y nil)
(bogus (progn
(psetf temp-x (foo 1 2)
temp-y (bar 3 4))
(let ((x temp-x)
(y temp-y))
x y
(do-stuff x y))))
(temp-cons (let ((x temp-x)
(y temp-y))
x y
x))
(new-car z))
(let ((x temp-x)
(y temp-y))
x y
(locally
(declare (ignore bogus))
(rplaca temp-cons new-car)
new-car)))
------------------------- Lisp Code Follows -------------------------
(define-setf-method let* (clauses &rest body)
(let ((setf-subform (first (last body)))
(other-subforms (butlast body))
(let-vars '())
(let-forms '())
(temp-let-vars '())
(bogus-var (make-symbol "BOGUS")))
;; Process LET* clauses
(dolist (clause clauses)
(let ((let-var nil)
(let-form nil)
(temp-let-var (gensym)))
(cond ((listp clause)
(setf let-var (first clause)
let-form (second clause)))
(t (setf let-var clause)))
(push let-var let-vars)
(push let-form let-forms)
(push temp-let-var temp-let-vars)))
(setf let-vars (nreverse let-vars)
let-forms (nreverse let-forms)
temp-let-vars (nreverse temp-let-vars))
(flet ((wrap-it (body-forms)
"Establish the right variable bindings around some subforms"
`(let ,(mapcar #'(lambda (let-var temp-let-var)
`(,let-var ,temp-let-var))
let-vars temp-let-vars)
,@let-vars ; Make sure each var gets used
. ,body-forms)))
;; Get SETF method for subform to be SETFed
(multiple-value-bind (subform-temp-vars subform-temp-forms
subform-store-vars subform-store-form
subform-access-form)
(get-setf-method setf-subform)
;; Do it
(values `(,@temp-let-vars
,bogus-var
. ,subform-temp-vars)
`(,@let-forms
,(wrap-it other-subforms)
. ,(mapcar #'(lambda (form)
(wrap-it (list form)))
subform-temp-forms))
subform-store-vars
(wrap-it `((locally
(declare (ignore ,bogus-var))
,subform-store-form)))
(wrap-it `((locally
(declare (ignore ,bogus-var))
,subform-access-form))))))))
(define-setf-method let (clauses &rest body)
(let ((setf-subform (first (last body)))
(other-subforms (butlast body))
(let-vars '())
(temp-let-vars '())
(psetf-args '())
(list-o-nils (make-list (length clauses) :initial-element nil))
(bogus-var (make-symbol "BOGUS")))
;; Process LET clauses
(dolist (clause clauses)
(let ((let-var nil)
(let-form nil)
(temp-let-var (gensym "TEMP")))
(cond ((listp clause)
(setf let-var (first clause)
let-form (second clause)))
(t (setf let-var clause)))
(push let-var let-vars)
(push temp-let-var temp-let-vars)
;; We're going to PSETF each temporary LET var
;; to the appropriate LET form
(push temp-let-var psetf-args)
(push let-form psetf-args)))
(setf let-vars (nreverse let-vars)
temp-let-vars (nreverse temp-let-vars)
psetf-args (nreverse psetf-args))
(flet ((wrap-it (body-forms)
"Establish the right variable bindings around some subforms"
`(let ,(mapcar #'(lambda (let-var temp-let-var)
`(,let-var ,temp-let-var))
let-vars temp-let-vars)
,@let-vars ; Make sure each var gets used
. ,body-forms)))
;; Get SETF method for subform to be SETFed
(multiple-value-bind (subform-temp-vars subform-temp-forms
subform-store-vars subform-store-form
subform-access-form)
(get-setf-method setf-subform)
;; Do it
(values `(,@temp-let-vars
,bogus-var
. ,subform-temp-vars)
`(,@list-o-nils
(progn (psetf . ,psetf-args)
,(wrap-it other-subforms))
. ,(mapcar #'(lambda (form)
(wrap-it (list form)))
subform-temp-forms))
subform-store-vars
(wrap-it `((locally
(declare (ignore ,bogus-var))
,subform-store-form)))
(wrap-it `((locally
(declare (ignore ,bogus-var))
,subform-access-form))))))))
--
John Burger ยทยทยทยท@mitre.org
"You ever think about .signature files? I mean, do we really need them?"
- alt.andy.rooney