dep: Major overhaul.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 23bb4ef..a41b685 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.
-;;; 
+;;;
 ;;; 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,7 +31,8 @@
   (:export #:unsigned-fixnum
           #:compile-time-defun
           #:show
-          #:stringify #:mappend #:listify #:fix-pair #:pairify
+          #:stringify #:functionify #:mappend
+          #:listify #:fix-pair #:pairify
           #:parse-body #:with-parsed-body
           #:whitespace-char-p
           #:slot-uninitialized
@@ -81,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
@@ -120,11 +127,25 @@
 (defun whitespace-char-p (ch)
   "Return whether CH is a whitespace character or not."
   (case ch
-    ((#\space #\tab #\newline #\return #\vt
-             #+cmu #\formfeed
-             #+clisp #\page) 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