chiark / gitweb /
Merge branch 'master' of /home/mdw/public-git/lisp
[lisp] / mdw-base.lisp
index cde1d7a16b7b3c6e9d4abf2b33bef416f2b259fd..8ba9a24bf7130c6f71bd04570d9f9e57eb42701b 100644 (file)
 
 (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
           #:whitespace-char-p
           #:slot-uninitialized
-          #:nlet #:while #:case2 #:ecase2
+          #:nlet #:while #:until #:case2 #:ecase2
           #: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)
 
+;;;--------------------------------------------------------------------------
+;;; Useful types.
+
+(deftype unsigned-fixnum ()
+  "Unsigned fixnums; useful as array indices and suchlike."
+  `(mod ,most-positive-fixnum))
+
 ;;;--------------------------------------------------------------------------
 ;;; Some simple macros to get things going.
 
@@ -50,11 +61,17 @@ (defmacro compile-time-defun (name args &body body)
      (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;
@@ -66,6 +83,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)))
@@ -96,7 +119,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))
@@ -105,24 +130,31 @@ (defun slot-uninitialized ()
    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
-   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))))))))
+
+#-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.
@@ -167,9 +199,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'."
@@ -179,21 +213,26 @@ (compile-time-defun do-case2-like (kind vform clauses)
        (,kind ,scrutinee
         ,@(mapcar (lambda (clause)
                     (destructuring-bind
-                        (cases (&optional var) &rest forms)
+                        (cases (&optional varx vary) &rest forms)
                         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.
-   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)