safely.lisp: SAFE-COPY shouldn't make two copies under CLisp.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 6b235f5..95b79de 100644 (file)
--- 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.
 ;;; 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.
 ;;; 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.
 ;;; 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.


@@ -28,33 +28,52 @@
 
 (defpackage #:mdw.base
   (:use #:common-lisp)
 
 (defpackage #:mdw.base
   (:use #:common-lisp)

-  (:export #:compile-time-defun
+  (:export #:unsigned-fixnum
+          #:compile-time-defun

           #:show
           #:show

-          #:stringify #:listify #:fix-pair #:pairify #:parse-body
+          #:stringify #:functionify #:mappend
+          #:listify #:fix-pair #:pairify
+          #:parse-body #:with-parsed-body

           #:whitespace-char-p
           #:slot-uninitialized
           #: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
           #:with-gensyms #:let*/gensyms #:with-places
           #:locp #:locf #:ref #:with-locatives
           #:update-place #:update-place-after

-          #:incf-after #:decf-after))
+          #:incf-after #:decf-after
+          #:fixnump)
+  #+cmu (:import-from #:extensions #:fixnump))
+

 (in-package #: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."
 ;;; 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)
      (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 (gensym)))

-    `(let ((,tmp ,x))
-       (format t "~&~S: ~S~%" ',x ,tmp)
-       ,tmp)))
+    `(let ((,tmp (multiple-value-list ,x)))
+       (fresh-line)
+       (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;
 
 (defun stringify (str)
   "Return a string representation of STR.  Strings are returned unchanged;


@@ -63,8 +82,20 @@
   (typecase str
     (string str)
     (symbol (symbol-name str))
   (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
+   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)."
 
 (compile-time-defun listify (x)
   "If X is a (possibly empty) list, return X; otherwise return (list X)."


@@ -96,33 +127,67 @@
 (defun whitespace-char-p (ch)
   "Return whether CH is a whitespace character or not."
   (case ch
 (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)))
 
     (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
    structure definitions without doom ensuing."
   (error "No initializer for slot."))
 
 (declaim (ftype (function nil ()) slot-unitialized))
 (defun slot-uninitialized ()
   "A function which signals an error.  Can be used as an initializer form in
    structure definitions without doom ensuing."
   (error "No initializer for slot."))
 

-(compile-time-defun parse-body (body)
+(compile-time-defun parse-body (body &key (allow-docstring-p t))

   "Given a BODY (a list of forms), parses it into three sections: a
    docstring, a list of declarations (forms beginning with the symbol
    `declare') and the body forms.  The result is returned as three lists
    (even the docstring), suitable for interpolation into a backquoted list
   "Given a BODY (a list of forms), parses it into three sections: a
    docstring, a list of declarations (forms beginning with the symbol
    `declare') and the body forms.  The result is returned as three lists
    (even the docstring), suitable for interpolation into a backquoted list

-   using `@,'."
-  (multiple-value-bind
-      (doc body)
-      (if (and (consp body)
-              (stringp (car body)))
-         (values (list (car body)) (cdr body))
-         (values nil body))
-    (loop for forms on body
-         for form = (car forms)
-         while (and (consp form)
-                    (eq (car form) 'declare))
-         collect form into decls
-         finally (return (values doc decls forms)))))
+   using `@,'.  If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at
+   all."
+  (let ((doc nil) (decls nil))
+    (do ((forms body (cdr forms))) (nil)
+      (let ((form (and forms (car forms))))
+       (cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms))
+              (setf doc form))
+             ((and (consp form)
+                   (eq (car form) 'declare))
+              (setf decls (append decls (cdr form))))
+             (t (return (values (and doc (list doc))
+                                (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))
+  (defun fixnump (object)
+    "Answer non-nil if OBJECT is a fixnum, or nil if it isn't."
+    (typep object 'fixnum)))

 
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.
 
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.


@@ -167,9 +232,11 @@
 
 (defmacro while (cond &body body)
   "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
 
 (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'."
 
 (compile-time-defun do-case2-like (kind vform clauses)
   "Helper function for `case2' and `ecase2'."


@@ -205,6 +272,31 @@
   "Like `case2', but signals an error if no clause matches the SCRUTINEE."
   (do-case2-like 'ecase vform 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
 
 ;;;--------------------------------------------------------------------------
 ;;; with-places