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.

diff --git a/mdw-base.lisp b/mdw-base.lisp
index ec86987..a5b154b 100644 (file)
--- 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))