From 5cf4440bffb13480dd47911ac1afd3e4c150b34c Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 18 May 2006 09:43:29 +0100
Subject: [PATCH] mop: New macro with-slot-variables.

The docstring describes it pretty well: the idea is to cache slots in
correctly-typed lexical variables and then write them back after
processing the body forms.
---
 mdw-mop.lisp | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 73 insertions(+)

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index 160eff9..e7ea27c 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -29,6 +29,7 @@
 (defpackage #:mdw.mop
   (:use #:common-lisp #:mdw.base #+cmu #:mop)
   (:export #:copy-instance #:copy-instance-using-class
+	   #:with-slot-variables
 	   #:compatible-class
 	   #:initargs-for-effective-slot #:make-effective-slot
 	   #:filtered-slot-class-mixin
@@ -64,6 +65,78 @@
   (apply #'copy-instance-using-class (class-of object) object initargs))
 
 ;;;--------------------------------------------------------------------------
+;;; Handy macros.
+
+(defmacro with-slot-variables (slots instance &body body)
+  "A copy-out-and-write-back variant of with-slots.
+
+   The SLOTS argument is a list of slot specifications, each of which has the
+   form (NAME &key :update :variable).  VARIABLE defaults to NAME, and
+   :update defaults to nil.
+
+   The INSTANCE argument has the form (INSTANCE &key :class), but an atom may
+   be used in place of a singleton list.  If the CLASS is specified, then two
+   good things happen: firstly the INSTANCE is declared to be a member of the
+   CLASS, and secondly all the slot variables are declared to have the
+   appropriate types, as dredged up from the class's effective slot
+   definitions.
+
+   The effect of all this is to return the result of evaluating BODY in an
+   environment where the VARIABLEs are bound to the values of the NAMEd slots
+   of the given INSTANCE.  If BODY completes successfully (rather than
+   throwing out, restarting, or anything like that) then the final values of
+   VARIABLEs for which UPDATE was set non-nil are written back to their
+   corresponding slots.
+
+   This stands a good chance of being rather faster than with-slots.  It
+   does, however, run the risk of leaving things in an inconsistent state if
+   BODY escapes half-way through.  Also, this requires recompilation if a
+   class's slots change type."
+  (multiple-value-bind (instance class)
+      (destructuring-bind
+	  (instance &key class)
+	  (listify instance)
+	(values instance (and class (find-class class))))
+    (let ((slots (mapcar (lambda (slot)
+			   (destructuring-bind
+			       (name &key update (variable name))
+			       (listify slot)
+			     (list name variable update)))
+			 (if slots
+			     (listify slots)
+			     (mapcar #'slot-definition-name
+				     (class-slots class))))))
+      (multiple-value-bind
+	  (docs decls body)
+	  (parse-body body :allow-docstring-p nil)
+	(declare (ignore docs))
+	(with-gensyms (instvar)
+	  `(let ((,instvar ,instance))
+	     ,@(and class `((declare (type ,(class-name class) ,instvar))))
+	     (let ,(loop for (name var update) in slots
+			 collect `(,var (slot-value ,instvar ',name)))
+	       ,@(and class
+		      `((declare
+			 ,@(loop
+			    for (name var update) in slots
+			    for slot = (or (find name
+						 (class-slots class)
+						 :key #'slot-definition-name)
+					   (error
+					    "Slot ~S not found in class ~S."
+					    name (class-name class)))
+			    collect `(type
+				      ,(slot-definition-type slot)
+				      ,name)))))
+	       ,@decls
+	       (multiple-value-prog1
+		   (progn ,@body)
+		 ,@(loop for (name var update) in slots
+			 when update
+			 collect `(setf (slot-value ,instvar ',name)
+				   ,var))))))))))
+
+;;;--------------------------------------------------------------------------
 ;;; Basic stuff.
 
 (defclass compatible-class (standard-class)
-- 
2.11.0