X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/23f32e98a31fa5df4390d28817f851a9984f6fee..af33e77c00654c222a8a04a5e69a5eb1f56c1e8c:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index c4c3e17..a41b685 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -13,12 +13,12 @@
 ;;; it under the terms of the GNU General Public License as published by
 ;;; the Free Software Foundation; either version 2 of the License, or
 ;;; (at your option) any later version.
-;;; 
+;;;
 ;;; This program is distributed in the hope that it will be useful,
 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU General Public License for more details.
-;;; 
+;;;
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
@@ -31,10 +31,12 @@
   (:export #:unsigned-fixnum
 	   #:compile-time-defun
 	   #:show
-	   #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
+	   #:stringify #:functionify #: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 +59,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)
@@ -80,8 +82,14 @@
   (typecase str
     (string str)
     (symbol (symbol-name str))
-    (t (with-output-to-string (s)
-	 (princ str s)))))
+    (t (princ-to-string str))))
+
+(defun functionify (func)
+  "Convert the function-designator FUNC to a function."
+  (declare (type (or function symbol) func))
+  (etypecase func
+    (function func)
+    (symbol (symbol-function func))))
 
 (defun mappend (function list &rest more-lists)
   "Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding
@@ -119,9 +127,25 @@
 (defun whitespace-char-p (ch)
   "Return whether CH is a whitespace character or not."
   (case ch
-    ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
+    (#.(loop for i below char-code-limit
+	     for ch = (code-char i)
+	     unless (with-input-from-string (in (string ch))
+		      (peek-char t in nil))
+	     collect ch)
+       t)
     (t nil)))
 
+(defmacro defconstant* (name value &key doc test)
+  "Define a constant, like `defconstant'.  The TEST is an equality test used
+   to decide whether to override the current definition, if any."
+  (let ((temp (gensym)))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (let ((,temp ,value))
+	 (unless (and (boundp ',name)
+		      (funcall ,(or test ''eql) (symbol-value ',name) ,temp))
+	   (defconstant ,name ,value ,@(and doc (list doc))))
+	 ',name))))
+
 (declaim (ftype (function nil ()) slot-unitialized))
 (defun slot-uninitialized ()
   "A function which signals an error.  Can be used as an initializer form in
@@ -147,6 +171,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))
@@ -237,6 +272,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