mop: Implement a class which automatically defines a predicate.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 1f5a3eb17cf90925a2fff62d5c7c2ceb286472e4..269b398d22a8a34c34e838f2332f4ad3dfba0e12 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -45,7 +45,7 @@ (in-package #:mdw.base)
 
 (defmacro compile-time-defun (name args &body body)
   "Define a function which can be used by macros during the compilation
 
 (defmacro compile-time-defun (name args &body body)
   "Define a function which can be used by macros during the compilation

-process."
+   process."

   `(eval-when (:compile-toplevel :load-toplevel)
      (defun ,name ,args ,@body)))
 
   `(eval-when (:compile-toplevel :load-toplevel)
      (defun ,name ,args ,@body)))
 


@@ -58,8 +58,8 @@ (defmacro show (x)
 
 (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;

-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))
   (typecase str
     (string str)
     (symbol (symbol-name str))


@@ -81,12 +81,12 @@ (compile-time-defun do-fix-pair (x y defaultp)
 
 (compile-time-defun fix-pair (x &optional (y nil defaultp))
   "Return two values extracted from X.  It works as follows:
 
 (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))
   (do-fix-pair x y defaultp))
 
 (compile-time-defun pairify (x &optional (y nil defaultp))


@@ -102,26 +102,27 @@ (defun whitespace-char-p (ch)
 (declaim (ftype (function nil ()) slot-unitialized))
 (defun slot-uninitialized ()
   "A function which signals an error.  Can be used as an initializer form in
 (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."))
 
   (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
   "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)))))
+   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))))))))

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


@@ -134,9 +135,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
 
 (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))
   (labels ((more (binds)
              (let ((tmp (gensym "TMP")) (bind (car binds)))
                `((let ((,tmp ,(cadr bind))


@@ -178,21 +179,26 @@ (compile-time-defun do-case2-like (kind vform clauses)
        (,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)
   (do-case2-like 'case vform clauses))
 
 (defmacro ecase2 (vform &body clauses)


@@ -213,10 +219,10 @@ (define-setf-expander %place-ref (getform setform newtmp)
 
 (defmacro with-places ((&key environment) places &body body)
   "A hairy helper, for writing setf-like macros.  PLACES is a list of binding
 
 (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)
   (if (null places)
       `(progn ,@body)
       (let*/gensyms (environment)


@@ -278,10 +284,10 @@ (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
 
 (defmacro locf (place &environment env)
   "Slightly cheesy locatives.  (locf PLACE) returns an object which, using
 
 (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)
   (multiple-value-bind
       (valtmps valforms newtmps setform getform)
       (get-setf-expansion place env)


@@ -301,13 +307,14 @@ (defun (setf ref) (new loc)
 
 (defmacro with-locatives (locs &body body)
   "LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
 
 (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))
   (setf locs (mapcar #'pairify (listify locs)))
   (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
        (ll (mapcar #'cadr locs))