mdw-base.lisp: Rewrite `setf-default' using `with-places/gensyms'.

Now that we have `with-places' and friends, there's no reason to write a
`setf'-like macro out longhand ever again.

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 4bed97d..2bad2c2 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -353,30 +353,21 @@
   (do-case2-like 'ecase vform clauses))
 
 (export 'setf-default)
   (do-case2-like 'ecase vform clauses))
 
 (export 'setf-default)

-(defmacro setf-default (&rest specs &environment env)
+(defmacro setf-default (&rest specs)

   "Like setf, but only sets places which are currently nil.
 
    The arguments are an alternating list of PLACEs and DEFAULTs.  If a PLACE
    is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the
    default is /not/ stored.  The result is the (new) value of the last
    PLACE."
   "Like setf, but only sets places which are currently nil.
 
    The arguments are an alternating list of PLACEs and DEFAULTs.  If a PLACE
    is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the
    default is /not/ stored.  The result is the (new) value of the last
    PLACE."

-  (labels ((doit (specs)
-            (cond ((null specs) nil)
-                  ((null (cdr specs))
-                   (error "Odd number of arguments for SETF-DEFAULT."))
-                  (t
-                   (let ((place (car specs))
-                         (default (cadr specs))
-                         (rest (cddr specs)))
-                     (multiple-value-bind
-                         (vars vals store-vals writer reader)
-                         (get-setf-expansion place env)
-                       `(let* ,(mapcar #'list vars vals)
-                          (or ,reader
-                              (multiple-value-bind ,store-vals ,default
-                                ,writer))
-                          ,@(and rest (list (doit rest))))))))))
-    (doit specs)))
+  `(progn ,@(do ((list nil)
+                (specs specs (cddr specs)))
+               ((endp specs) (nreverse list))
+             (unless (cdr specs)
+               (error "Odd number of arguments for `setf-default'."))
+             (push (with-places/gensyms ((place (car specs)))
+                     `(or ,place (setf ,place ,(cadr specs))))
+                   list))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Update-in-place macros built using with-places.
 
 ;;;--------------------------------------------------------------------------
 ;;; Update-in-place macros built using with-places.