base: with-parsed-body, different interface.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 8ba9a24..23bb4ef 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -31,10 +31,11 @@
   (:export #:unsigned-fixnum
           #:compile-time-defun
           #:show
-          #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
+          #:stringify #:mappend #:listify #:fix-pair #:pairify
+          #:parse-body #:with-parsed-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
@@ -57,7 +58,7 @@
 (defmacro compile-time-defun (name args &body body)
   "Define a function which can be used by macros during the compilation
    process."
-  `(eval-when (:compile-toplevel :load-toplevel)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
      (defun ,name ,args ,@body)))
 
 (defmacro show (x)
@@ -149,6 +150,17 @@
                                 (and decls (list (cons 'declare decls)))
                                 forms))))))))
 
+(defmacro with-parsed-body
+    ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body)
+  "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR
+   to the body, DECLVAR to the declarations, and DOCVAR to (a list
+   containing) the docstring, and evaluate BODY."
+  `(multiple-value-bind
+       (,docvar ,declvar ,bodyvar)
+       (parse-body ,form :allow-docstring-p ,docp)
+     ,@(if docp nil `((declare (ignore ,docvar))))
+     ,@body))
+
 #-cmu
 (progn
   (declaim (inline fixnump))
@@ -239,6 +251,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