Path: utzoo!attcan!uunet!munnari.oz.au!uokmax!apple!bionet!uwm.edu!rpi!turing.cs.rpi.edu!harrisr
From: harrisr@turing.cs.rpi.edu (Richard Harris)
Newsgroups: comp.lang.lisp
Subject: Re: scope/extent interaction with flet and load
Message-ID: <C*#^5*%@rpi.edu>
Date: 5 Nov 90 21:53:08 GMT
References: <60375@bbn.BBN.COM> <1990Oct26.133156@cs.yale.edu> <GUMBY.90Nov3185409@Cygnus.COM> <1990Nov4.135540.10584@hellgate.utah.edu>
Reply-To: harrisr@turing.cs.rpi.edu (Richard Harris)
Distribution: comp
Organization: RPI CS Dept.
Lines: 53

Here is a definition for letf.

(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))))