base: with-parsed-body, different interface.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 0b68b8d69be12b4476f62c82ceb43c6e6217ef51..23bb4efc8207c7700fba0242258039e3d534971d 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -28,12 +28,14 @@
 
 (defpackage #:mdw.base
   (:use #:common-lisp)
-  (:export #:compile-time-defun
+  (:export #:unsigned-fixnum
+          #:compile-time-defun
           #:show
-          #:stringify #:listify #:fix-pair #:pairify #:parse-body
+          #:stringify #:mappend #:listify #:fix-pair #:pairify
+          #:parse-body #:with-parsed-body
           #:whitespace-char-p
           #:slot-uninitialized
-          #:nlet #:while #: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
@@ -43,21 +45,34 @@ (defpackage #:mdw.base
 
 (in-package #:mdw.base)
 
+;;;--------------------------------------------------------------------------
+;;; Useful types.
+
+(deftype unsigned-fixnum ()
+  "Unsigned fixnums; useful as array indices and suchlike."
+  `(mod ,most-positive-fixnum))
+
 ;;;--------------------------------------------------------------------------
 ;;; Some simple macros to get things going.
 
 (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)
-  "Debugging tool: print the expression X and its value."
+  "Debugging tool: print the expression X and its values."
   (let ((tmp (gensym)))
-    `(let ((,tmp ,x))
-       (format t "~&~S: ~S~%" ',x ,tmp)
-       ,tmp)))
+    `(let ((,tmp (multiple-value-list ,x)))
+       (format t "~&")
+       (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
+        (format t
+                "~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
+                ',x
+                ,tmp))
+       (terpri)
+       (values-list ,tmp))))
 
 (defun stringify (str)
   "Return a string representation of STR.  Strings are returned unchanged;
@@ -69,6 +84,12 @@ (defun stringify (str)
     (t (with-output-to-string (s)
         (princ str s)))))
 
+(defun mappend (function list &rest more-lists)
+  "Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding
+   a list.  Return the concatenation of all the resulting lists.  Like
+   mapcan, but nondestructive."
+  (apply #'append (apply #'mapcar function list more-lists)))
+
 (compile-time-defun listify (x)
   "If X is a (possibly empty) list, return X; otherwise return (list X)."
   (if (listp x) x (list x)))
@@ -99,7 +120,9 @@ (compile-time-defun pairify (x &optional (y nil defaultp))
 (defun whitespace-char-p (ch)
   "Return whether CH is a whitespace character or not."
   (case ch
-    ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
+    ((#\space #\tab #\newline #\return #\vt
+             #+cmu #\formfeed
+             #+clisp #\page) t)
     (t nil)))
 
 (declaim (ftype (function nil ()) slot-unitialized))
@@ -127,6 +150,17 @@ (compile-time-defun parse-body (body &key (allow-docstring-p t))
                                 (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))
@@ -177,9 +211,11 @@ (defmacro nlet (name binds &body body)
 
 (defmacro while (cond &body body)
   "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
-  `(loop
-     (unless ,cond (return))
-     ,@body))
+  `(loop (unless ,cond (return)) (progn ,@body)))
+
+(defmacro until (cond &body body)
+  "If COND is true, evaluate to nil; otherwise evaluate BODY and try again."
+  `(loop (when ,cond (return)) (progn ,@body)))
 
 (compile-time-defun do-case2-like (kind vform clauses)
   "Helper function for `case2' and `ecase2'."
@@ -215,6 +251,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