From 171bb403b78e6868ee77250681b7c5adb0c85bd9 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 22 Oct 2015 00:46:28 +0100
Subject: [PATCH] mdw-base.lisp: Refactor `with-places' incompatibly.

Now there are two macros.

  * `with-places' is a simple macro which does the hard work of
    capturing places with symbol-macros.

  * `with-places/gensyms' is a hairy nested-backquote macro helper which
    does the job of the old `with-places'.

Because of this split of responsibilities, no callers of these macros
have to mess with environments explicitly, which simplifies
`update-place' and `update-place-after' slightly.
---
 mdw-base.lisp | 97 +++++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 61 insertions(+), 36 deletions(-)

diff --git a/mdw-base.lisp b/mdw-base.lisp
index ec86987..a5b154b 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -309,50 +309,75 @@
   "Grim helper macro for with-places."
   (values nil nil newtmp setform getform))
 
-(defmacro with-places ((&key environment) places &body body)
-  "A hairy helper, for writing setf-like macros.  PLACES is a list of binding
-   pairs (VAR PLACE), where PLACE defaults to VAR.  The result is that BODY
-   is evaluated in a context where each VAR is bound to a gensym, and in the
-   final expansion, each of those gensyms will be bound to a symbol-macro
-   capable of reading or setting the value of the corresponding PLACE."
-  (if (null places)
-      `(progn ,@body)
-      (let*/gensyms (environment)
-	(labels
-	    ((more (places)
-	       (let ((place (car places)))
-		 (with-gensyms (tmp valtmps valforms
-				    newtmps setform getform)
-		   `((let ((,tmp ,(cadr place))
-			   (,(car place)
-			    (gensym ,(symbol-name (car place)))))
-		       (multiple-value-bind
-			   (,valtmps ,valforms
-			    ,newtmps ,setform ,getform)
-			   (get-setf-expansion ,tmp
-					       ,environment)
-			 (list 'let*
-			       (mapcar #'list ,valtmps ,valforms)
-			       `(symbol-macrolet ((,,(car place)
-						   (%place-ref ,,getform
-							       ,,setform
-							       ,,newtmps)))
-				  ,,@(if (cdr places)
-					 (more (cdr places))
-					 body))))))))))
-	  (car (more (mapcar #'pairify (listify places))))))))
+(defmacro with-places (clauses &body body &environment env)
+  "Define symbols which refer to `setf'-able places.
+
+   The syntax is similar to `let'.  The CLAUSES are a list of (NAME PLACE)
+   pairs.  Each NAME is defined as a symbol-macro referring to the
+   corresponding PLACE: a mention of the NAME within the BODY forms extracts
+   the current value(s) of the PLACE, while a `setf' (or `setq', because
+   symbol macros are strange like that) of a NAME updates the value(s) in the
+   PLACE.  The returned values are those of the BODY, evaluated as an
+   implicit `progn'."
+
+  (let ((temp-binds nil)
+	(macro-binds nil))
+    (dolist (clause clauses)
+      (destructuring-bind (name place) clause
+	(multiple-value-bind (valtmps valforms newtmps setform getform)
+	    (get-setf-expansion place env)
+	  (setf temp-binds
+		(nconc (nreverse (mapcar #'list valtmps valforms))
+		       temp-binds))
+	  (push `(,name (%place-ref ,getform ,setform ,newtmps))
+		macro-binds))))
+    `(let (,@(nreverse temp-binds))
+       (symbol-macrolet (,@(nreverse macro-binds))
+	 ,@body))))
+
+(defmacro with-places/gensyms (clauses &body body)
+  "A kind of a cross between `with-places' and `let*/gensyms'.
+
+   This is a hairy helper for writing `setf'-like macros.  The CLAUSES are a
+   list of (NAME [PLACE]) pairs, where the PLACE defaults to NAME, and a
+   bare NAME may be written in place of the singleton list (NAME).  The
+   PLACEs are evaluated.
+
+   The BODY forms are evaluated as an implicit `progn', with each NAME bound
+   to a gensym, to produce a Lisp form, called the `kernel'.  The result of
+   the `with-places/gensyms' macro is then itself a Lisp form, called the
+   `result'.
+
+   The effect of evaluating the `result' form is to evaluate the `kernel'
+   form with each of the gensyms stands for the value(s) stored in the
+   corresponding PLACE; a `setf' (or `setq') of one of the gensyms updates
+   the value(s) in the corresponding PLACE.  The values returned by the
+   `result' form are the values returned by the `kernel'."
+
+  (let* ((clauses (mapcar #'pairify clauses))
+	 (names (mapcar #'car clauses))
+	 (places (mapcar #'cadr clauses))
+	 (gensyms (mapcar (lambda (name) (gensym (symbol-name name)))
+			  names)))
+    ``(with-places (,,@(mapcar (lambda (gensym place)
+				 ``(,',gensym ,,place))
+			       gensyms places))
+	,(let (,@(mapcar (lambda (name gensym)
+			   `(,name ',gensym))
+			 names gensyms))
+	   ,@body))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Update-in-place macros built using with-places.
 
-(defmacro update-place (op place &rest args &environment env)
+(defmacro update-place (op place &rest args)
   "Update PLACE with (OP PLACE . ARGS), returning the new value."
-  (with-places (:environment env) (place)
+  (with-places/gensyms (place)
     `(setf ,place (,op ,place ,@args))))
 
-(defmacro update-place-after (op place &rest args &environment env)
+(defmacro update-place-after (op place &rest args)
   "Update PLACE with (OP PLACE . ARGS), returning the old value."
-  (with-places (:environment env) (place)
+  (with-places/gensyms (place)
     (with-gensyms (x)
       `(let ((,x ,place))
 	 (setf ,place (,op ,x ,@args))
-- 
2.11.0