Path: utzoo!attcan!uunet!cs.utexas.edu!rutgers!uwvax!dogie.macc.wisc.edu!csd4.milw.wisc.edu!leah!rpi!joplin.cs.rpi.edu!harrisr
From: harrisr@cs.rpi.edu (Richard Harris)
Newsgroups: comp.lang.lisp
Subject: Re: Use of backquote & macro question
Message-ID: <2137@rpi.edu>
Date: 27 Apr 89 20:09:39 GMT
References: <2277@perseus.sw.mcc.com>
Sender: usenet@rpi.edu
Organization: Rensselaer Polytechnic Institute, Troy, NY
Lines: 102

In article <2277@perseus.sw.mcc.com> rcp@perseus.sw.mcc.com (Rob Pettengill) writes:
 ...
>In any case I was able to write a nice general
>purpose macro for temporarily overriding state in a defstruct or CLOS
>instance.  However, I was only able to do this by using an explicit
>eval at macro expansion time.  Normally the explicit use of eval is
>red flag so I am curious to see if anyone can propose a better
>solution to this problem:
>
>(defmacro with-context
>  ((state-holder state-binding-list) &body body)
>  "This macro overrides the state in the STATE-HOLDER with the values in 
>   the STATE-BINDING-LIST for the scope of the BODY.  The STATE-HOLDER
>   typically a defstruct or CLOS instance although it may be any lisp
>   object with  SETFable accessors.  An unwind-protect ensures that the
>   original STATE-HOLDER state is restored when the body is exited.  The
>   STATE-BINDING-LIST is a list of alternate state accessors and new bindings.
>   The STATE-HOLDER and the bindings are evaluated.  The symbols which name
>   the stare accessors are not.  All of the accessors must be symbols which
>   name valid SETF-able accessors for the given STATE-HOLDER.
>   Example:
>   <cl> (defstruct bar a b)
>   BAR 
>   <cl> (setq bar1 (make-bar :a 1 :b 2))
>   #s(BAR :A 1 :B 2) 
>   <cl> (with-context (bar1 (bar-a 'a bar-b (+ 1 2)))
>          (format t \"~%~S\" bar1) bar1)
>   #s(BAR :A A :B 3)
>   #s(BAR :A 1 :B 2) 
>  "

Here is a definition of with-context that does not use EVAL.
Instead, this definition uses a macro called LETF (defined below).

(defmacro with-context ((state-holder-form state-binding-list) &body body)
  (let ((state-holder (gensym))
	(state-binding-functions nil)
	(state-binding-forms nil))
    (do ((functions nil (cons (car sbl-tail) functions))
	 (forms nil (cons (car sbl-tail) functions))
	 (sbl-tail state-binding-list (cddr sbl-tail)))
	((null sbl-tail)
	 (setq state-binding-functions (nreverse functions))
	 (setq state-binding-forms (nreverse forms))))
    `(let ((,state-holder ,state-holder-form))
       (letf ,(mapcar #'(lambda (function form)
			  `((,function ,state-holder) ,form))
	              state-binding-functions
	              state-binding-forms)
	 ,@body))))

(export '(LETF LETF*))

;The function LETF (defined below) is really a cross between the (Symbolics) functions
;LETF and LET-GLOBALLY, and should really be called LETF-GLOBALLY.

;"letf plaves-and-values body...              Special form
;      Just like let, except that it can bind any storage cells rather than just variables."
;"let-globally ((var value)...) body...       Special form
;      Similar in form to let.  The difference is that let-globally does not bind the
;      variables; instead, it saves the old values and sets the variables, and sets up
;      an unwind-protect to set them back."
;      The difference between let and let-globally is important (only)
;      in a multiple-process Lisp system.

(defmacro letf (bindings &body forms)
  (let ((tvars nil)
	(tvals nil)
	(store-vars nil)
	(store-forms nil)
	(access-forms nil)
	(value-forms nil)
	(save-vars nil))
    (dolist (binding bindings)
      (let ((setf-form (if (atom binding) binding (car binding)))
	    (value-form (if (atom binding) nil (cadr binding))))
	(multiple-value-bind (vars vals stores store-form access-form)
	    (get-setf-method setf-form)
	  (setq tvars (nconc tvars vars))
	  (setq tvals (nconc tvals vals))
	  (setq store-vars (nconc store-vars stores))
	  (setq store-forms (nconc store-forms (list store-form)))
	  (setq access-forms (nconc access-forms (list access-form)))
	  (setq value-forms (nconc value-forms (list value-form)))
	  (setq save-vars (nconc save-vars (list (gensym)))))))
    `(let ,(mapcar #'list tvars tvals)
       (let ,(mapcar #'list save-vars access-forms)
	 (unwind-protect
	      (progn
		(let ,(mapcar #'list store-vars value-forms)
		  ,@store-forms)
		,@forms)
	   (let ,(mapcar #'list store-vars save-vars)
	     ,@store-forms))))))

(defmacro letf* (bindings &body forms)
  (if (null (cdr bindings))
      `(letf ,bindings
	  ,@forms)
      `(letf (,(car bindings))
	  (letf* ,(cdr bindings)
	     ,@forms))))