chiark / gitweb /
str: Handy functions for testing prefixes/suffixes.
[lisp] / mdw-base.lisp
index 3111832bc5b5c31fafad68573be2ab1872d9cc74..95b79de744d3b6f9968f3b94808010608c2f794d 100644 (file)
 ;;; 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.
 
+;;;--------------------------------------------------------------------------
+;;; Package things.
+
 (defpackage #:mdw.base
   (:use #:common-lisp)
-  (:export #:compile-time-defun
+  (:export #:unsigned-fixnum
+          #:compile-time-defun
           #:show
-          #:stringify #:listify #:fix-pair #:pairify
+          #:stringify #:functionify #:mappend
+          #:listify #:fix-pair #:pairify
+          #:parse-body #:with-parsed-body
           #:whitespace-char-p
           #:slot-uninitialized
+          #:nlet #:while #:until #:case2 #:ecase2 #:setf-default
           #:with-gensyms #:let*/gensyms #:with-places
-          #:locp #:locf #:ref #:with-locatives))
+          #:locp #:locf #:ref #:with-locatives
+          #:update-place #:update-place-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.
+
 (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)
+   process."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
      (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)))
+       (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;
-symbols are converted to their names (unqualified!).  Other objects are
-converted to their print representations."
+   symbols are converted to their names (unqualified!).  Other objects are
+   converted to their print representations."
   (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)."
   (if (listp x) x (list x)))
+
 (compile-time-defun do-fix-pair (x y defaultp)
   "Helper function for fix-pair and pairify."
   (flet ((singleton (x) (values x (if defaultp y x))))
@@ -67,15 +109,17 @@ (compile-time-defun do-fix-pair (x y defaultp)
          ((atom (cdr x)) (values (car x) (cdr x)))
          ((cddr x) (error "Too many elements for a pair."))
          (t (values (car x) (cadr x))))))
+
 (compile-time-defun fix-pair (x &optional (y nil defaultp))
   "Return two values extracted from X.  It works as follows:
-  (A) -> A, Y
-  (A B) -> A, B
-  (A B . C) -> error
-  (A . B) -> A, B
-  A -> A, Y
-where Y defaults to A if not specified."
+     (A) -> A, Y
+     (A B) -> A, B
+     (A B . C) -> error
+     (A . B) -> A, B
+     A -> A, Y
+   where Y defaults to A if not specified."
   (do-fix-pair x y defaultp))
+
 (compile-time-defun pairify (x &optional (y nil defaultp))
   "As for fix-pair, but returns a list instead of two values."
   (multiple-value-call #'list (do-fix-pair x y defaultp)))
@@ -83,15 +127,71 @@ (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)
+    (#.(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
-structure definitions without doom ensuing."
+   structure definitions without doom ensuing."
   (error "No initializer for slot."))
 
+(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 `@,'.  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.
+
 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."
   `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
@@ -100,9 +200,9 @@ (defmacro with-gensyms (syms &body body)
 
 (defmacro let*/gensyms (binds &body body)
   "A macro helper.  BINDS is a list of binding pairs (VAR VALUE), where VALUE
-defaults to VAR.  The result is that BODY is evaluated in a context where
-each VAR is bound to a gensym, and in the final expansion, each of those
-gensyms will be bound to the corresponding VALUE."
+   defaults to VAR.  The result is that BODY is evaluated in a context where
+   each VAR is bound to a gensym, and in the final expansion, each of those
+   gensyms will be bound to the corresponding VALUE."
   (labels ((more (binds)
              (let ((tmp (gensym "TMP")) (bind (car binds)))
                `((let ((,tmp ,(cadr bind))
@@ -115,19 +215,106 @@ (defmacro let*/gensyms (binds &body body)
         `(progn ,@body)
         (car (more (mapcar #'pairify (listify binds)))))))
 
+;;;--------------------------------------------------------------------------
+;;; Some simple yet useful control structures.
+
+(defmacro nlet (name binds &body body)
+  "Scheme's named let."
+  (multiple-value-bind (vars vals)
+      (loop for bind in binds
+           for (var val) = (pairify bind nil)
+           collect var into vars
+           collect val into vals
+           finally (return (values vars vals)))
+    `(labels ((,name ,vars
+               ,@body))
+       (,name ,@vals))))
+
+(defmacro while (cond &body body)
+  "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
+  `(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'."
+  (with-gensyms (scrutinee argument)
+    `(multiple-value-bind (,scrutinee ,argument) ,vform
+       (declare (ignorable ,argument))
+       (,kind ,scrutinee
+        ,@(mapcar (lambda (clause)
+                    (destructuring-bind
+                        (cases (&optional varx vary) &rest forms)
+                        clause
+                      `(,cases
+                        ,@(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 ([[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))
+
+(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
+
 (defmacro %place-ref (getform setform newtmp)
   "Grim helper macro for with-places."
   (declare (ignore setform newtmp))
   getform)
+
 (define-setf-expander %place-ref (getform setform newtmp)
   "Grim helper macro for with-places."
   (values nil nil newtmp setform getform))
+
 (defmacro with-places ((&key environment) places &body body)
   "A hairy helper, for writing setf-like macros.  PLACES is a list of binding
-pairs (VAR PLACE), where PLACE defaults to VAR.  The result is that BODY is
-evaluated in a context where each VAR is bound to a gensym, and in the final
-expansion, each of those gensyms will be bound to a symbol-macro capable of
-reading or setting the value of the corresponding PLACE."
+   pairs (VAR PLACE), where PLACE defaults to VAR.  The result is that BODY
+   is evaluated in a context where each VAR is bound to a gensym, and in the
+   final expansion, each of those gensyms will be bound to a symbol-macro
+   capable of reading or setting the value of the corresponding PLACE."
   (if (null places)
       `(progn ,@body)
       (let*/gensyms (environment)
@@ -155,38 +342,71 @@ (defmacro with-places ((&key environment) places &body body)
                                          body))))))))))
           (car (more (mapcar #'pairify (listify places))))))))
 
+;;;--------------------------------------------------------------------------
+;;; Update-in-place macros built using with-places.
+
+(defmacro update-place (op place arg &environment env)
+  "Update PLACE with the value of OP PLACE ARG, returning the new value."
+  (with-places (:environment env) (place)
+    `(setf ,place (,op ,place ,arg))))
+
+(defmacro update-place-after (op place arg &environment env)
+  "Update PLACE with the value of OP PLACE ARG, returning the old value."
+  (with-places (:environment env) (place)
+    (with-gensyms (x)
+      `(let ((,x ,place))
+        (setf ,place (,op ,x ,arg))
+        ,x))))
+
+(defmacro incf-after (place &optional (by 1))
+  "Increment PLACE by BY, returning the old value."
+  `(update-place-after + ,place ,by))
+
+(defmacro decf-after (place &optional (by 1))
+  "Decrement PLACE by BY, returning the old value."
+  `(update-place-after - ,place ,by))
+
+;;;--------------------------------------------------------------------------
+;;; Locatives.
+
 (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
   "Locative data type.  See `locf' and `ref'."
   (reader (slot-uninitialized) :type function)
   (writer (slot-uninitialized) :type function))
+
 (defmacro locf (place &environment env)
   "Slightly cheesy locatives.  (locf PLACE) returns an object which, using
-the `ref' function, can be used to read or set the value of PLACE.  It's
-cheesy because it uses closures rather than actually taking the address of
-something.  Also, unlike Zetalisp, we don't overload `car' to do our dirty
-work."
+   the `ref' function, can be used to read or set the value of PLACE.  It's
+   cheesy because it uses closures rather than actually taking the address of
+   something.  Also, unlike Zetalisp, we don't overload `car' to do our dirty
+   work."
   (multiple-value-bind
       (valtmps valforms newtmps setform getform)
       (get-setf-expansion place env)
     `(let* (,@(mapcar #'list valtmps valforms))
        (make-loc (lambda () ,getform)
                  (lambda (,@newtmps) ,setform)))))
+
 (declaim (inline loc (setf loc)))
+
 (defun ref (loc)
   "Fetch the value referred to by a locative."
   (funcall (loc-reader loc)))
+
 (defun (setf ref) (new loc)
   "Store a new value in the place referred to by a locative."
   (funcall (loc-writer loc) new))
+
 (defmacro with-locatives (locs &body body)
   "LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
-symbol and LOC-EXPR evaluates to a locative.  If LOC-EXPR is omitted, it
-defaults to SYM.  As an abbreviation for a common case, LOCS may be a symbol
-instead of a list.  The BODY is evaluated in an environment where each SYM is
-a symbol macro which expands to (ref LOC-EXPR) -- or, in fact, something
-similar which doesn't break if LOC-EXPR has side-effects.  Thus, references,
-including `setf' forms, fetch or modify the thing referred to by the
-LOC-EXPR.  Useful for covering over where something uses a locative."
+   symbol and LOC-EXPR evaluates to a locative.  If LOC-EXPR is omitted, it
+   defaults to SYM.  As an abbreviation for a common case, LOCS may be a
+   symbol instead of a list.  The BODY is evaluated in an environment where
+   each SYM is a symbol macro which expands to (ref LOC-EXPR) -- or, in fact,
+   something similar which doesn't break if LOC-EXPR has side-effects.  Thus,
+   references, including `setf' forms, fetch or modify the thing referred to
+   by the LOC-EXPR.  Useful for covering over where something uses a
+   locative."
   (setf locs (mapcar #'pairify (listify locs)))
   (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
        (ll (mapcar #'cadr locs))