dep: Major overhaul.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index cde1d7a..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.
 ;;; 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)))
+       (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;
 
 (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'."


@@ -179,27 +246,57 @@
        (,kind ,scrutinee
         ,@(mapcar (lambda (clause)
                     (destructuring-bind
        (,kind ,scrutinee
         ,@(mapcar (lambda (clause)
                     (destructuring-bind

-                        (cases (&optional var) &rest forms)
+                        (cases (&optional varx vary) &rest forms)

                         clause
                       `(,cases
                         clause
                       `(,cases

-                        ,@(if var
-                              (list `(let ((,var ,argument)) ,@forms))
+                        ,@(if varx
+                              (list `(let ((,(or vary varx) ,argument)
+                                           ,@(and vary
+                                                  `((,varx ,scrutinee))))
+                                       ,@forms))

                               forms))))
                   clauses)))))
 
 (defmacro case2 (vform &body clauses)
   "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
                               forms))))
                   clauses)))))
 
 (defmacro case2 (vform &body clauses)
   "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.

-   The CLAUSES have the form (CASES ([VAR]) FORMS...), where a standard
-   `case' clause has the form (CASES FORMS...).  The `case2' form evaluates
-   the VFORM, and compares the SCRUTINEE to the various CASES, in order, just
-   like `case'.  If there is a match, then the corresponding FORMs are
-   evaluated with VAR (if specified) bound to the value of ARGUMENT."
+   The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
+   standard `case' clause has the form (CASES FORMS...).  The `case2' form
+   evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
+   order, just like `case'.  If there is a match, then the corresponding
+   FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
+   the SCRUTINEE (where specified).  Note the bizarre defaulting behaviour:
+   ARGVAR is less optional than SCRUVAR."

   (do-case2-like 'case vform clauses))
 
 (defmacro ecase2 (vform &body clauses)
   "Like `case2', but signals an error if no clause matches the SCRUTINEE."
   (do-case2-like 'ecase vform clauses))
 
   (do-case2-like 'case vform clauses))
 
 (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
 
 ;;;--------------------------------------------------------------------------
 ;;; with-places