base: New macro setf-default.

I've thought about adding this for a while, and it just became worth it.
Deployed where sensible.

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 73f85e7..2c463e9 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -34,7 +34,7 @@
           #: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 @@
   "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
 

diff --git a/optparse.lisp b/optparse.lisp
index ff301ee..08192d0 100644 (file)
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -464,7 +464,7 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
    if RADIX is nil.  Returns two values: the integer parsed (or nil if there
    wasn't enough for a sensible parse), and the index following the
    characters of the integer."
-  (unless end (setf end (length string)))
+  (setf-default end (length string))
   (labels ((simple (i r goodp sgn)
             (multiple-value-bind
                 (a i)
@@ -773,8 +773,7 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
     (flet ((emit ()
             (write-string string stream :start start :end i)
             (setf start i)))
-      (unless end
-       (setf end (length string)))
+      (setf-default end (length string))
       (loop
         (unless (< i end)
           (emit)

diff --git a/str.lisp b/str.lisp
index 1cb0cc7..104c85a 100644 (file)
--- a/str.lisp
+++ b/str.lisp
@@ -47,8 +47,7 @@
    If QUOTEDP, then allow quoting and backslashifying; otherwise don't.  The
    START and END arguments limit the portion of the string to be processed;
    the default to 0 and nil (end of string), as usual."
-  (unless start (setf start 0))
-  (unless end (setf end (length string)))
+  (setf-default start 0 end (length string))
   (let ((i start)
        (q nil)
        (e nil)