Path: utzoo!attcan!utgpu!jarvis.csri.toronto.edu!mailrus!tut.cis.ohio-state.edu!cs.utexas.edu!milano!perseus!rcp
From: rcp@perseus.sw.mcc.com (Rob Pettengill)
Newsgroups: comp.lang.lisp
Subject: Use of backquote & macro question
Message-ID: <2277@perseus.sw.mcc.com>
Date: 27 Apr 89 15:45:07 GMT
Organization: MCC Software Technology Program
Lines: 83

In the course of writing the following macro I ran into the limitation
that backquote appears to be valid only when used on an evaluated form
(eg not in the binding clause of a let).  This appears to be
reasonable although I can't find an explicit discussion of where it is
allowed in CLtL.  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) 
  "
;; (macroexpand-1 '(with-context (bar1 (bar-a 'a bar-b (+ 1 2)))
;; 			    (format t "~%~S" bar1) bar1))
;; returns:
;; (LET ((#:G88 (BAR-B BAR1))
;;       (#:G87 (BAR-A BAR1)))
;;      (SETF (BAR-B BAR1) (+ 1 2))
;;      (SETF (BAR-A BAR1) (QUOTE A))
;;      (UNWIND-PROTECT
;;       (PROGN
;;        (FORMAT T "~%~S" BAR1) BAR1)
;;       (SETF (BAR-B BAR1) #:G88)
;;       (SETF (BAR-A BAR1) #:G87)))
;; 
  (eval
  `(let				; first set up bindings to be useful later
       ,(do ((state-var (car state-binding-list) (car rest)) ;even members
	     (state-binding (cadr state-binding-list) (cadr rest)) ;odd
	     (rest (cddr state-binding-list) (cddr rest))
	     (state-vars ())	;setfable state accessors
	     (state-vals ())	;new temporary bindings
	     (state-temps ())	;temporary storage for previous bindings
	     )
	    ((null state-var) `((state-vars ',state-vars) ;format for let
				(state-vals ',state-vals)
				(state-temps ',state-temps)))
	  (push state-var state-vars) ; gather the lists
	  (push state-binding state-vals)
	  (push (gensym) state-temps)
	  )
     ;; 
     `(let			;save the old state in temp vars
	   ,(mapcar
	    #'(lambda (tmp-var var)
		(list tmp-var (list var ',state-holder)))
	    state-temps state-vars)
	 ;; set the new state in the state-holder
	 ,@(mapcar
	    #'(lambda (var val) (list 'setf (list var ',state-holder) val))
	    state-vars state-vals)
	 ;; run the body with unwind-protect
	 (unwind-protect
	     ,(cons 'progn ',body)
	   ;; restore the original state-holder state
	   ,@(mapcar
	      #'(lambda (var val) (list 'setf (list var ',state-holder) val))
	      state-vars state-temps)
	   )
	 )
    )))

;rob