X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/blobdiff_plain/fe0f07ea19b36ce1abc1ec305d0203323cbf2316..2af61873236491d221b3cbd8bbab4320a2beb7f4:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 73f85e7..2c463e9 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -34,7 +34,7 @@ (defpackage #:mdw.base
 	   #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
 	   #:whitespace-char-p
 	   #:slot-uninitialized
-	   #:nlet #:while #:until #:case2 #:ecase2
+	   #:nlet #:while #:until #:case2 #:ecase2 #:setf-default
 	   #:with-gensyms #:let*/gensyms #:with-places
 	   #:locp #:locf #:ref #:with-locatives
 	   #:update-place #:update-place-after
@@ -239,6 +239,31 @@ (defmacro ecase2 (vform &body clauses)
   "Like `case2', but signals an error if no clause matches the SCRUTINEE."
   (do-case2-like 'ecase vform clauses))
 
+(defmacro setf-default (&rest specs &environment env)
+  "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)))
+
 ;;;--------------------------------------------------------------------------
 ;;; with-places