General tidying and prettifying.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 21948fa0311a5aa5a273621c172b03ff2445e36f..4d67b7ae2498241a4299985090665254d99d1edb 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -23,6 +23,9 @@
 ;;; along with this program; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 ;;; 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
 (defpackage #:mdw.base
   (:use #:common-lisp)
   (:export #:compile-time-defun


@@ -36,6 +39,9 @@ (defpackage #:mdw.base
           #:incf-after #:decf-after))
 (in-package #:mdw.base)
 
           #:incf-after #:decf-after))
 (in-package #:mdw.base)
 

+;;;--------------------------------------------------------------------------
+;;; 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."
 (defmacro compile-time-defun (name args &body body)
   "Define a function which can be used by macros during the compilation
 process."


@@ -58,9 +64,11 @@ (defun stringify (str)
     (symbol (symbol-name str))
     (t (with-output-to-string (s)
         (princ str s)))))
     (symbol (symbol-name str))
     (t (with-output-to-string (s)
         (princ str s)))))

+

 (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 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))))
 (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))))


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


@@ -78,6 +87,7 @@ (compile-time-defun fix-pair (x &optional (y nil defaultp))
   A -> A, Y
 where Y defaults to A if not specified."
   (do-fix-pair x y defaultp))
   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)))
 (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)))


@@ -112,6 +122,9 @@ (defun slot-uninitialized ()
 structure definitions without doom ensuing."
   (error "No initializer for slot."))
 
 structure definitions without doom ensuing."
   (error "No initializer for slot."))
 

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

 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."
   `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."
   `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))


@@ -135,13 +148,18 @@ (defmacro let*/gensyms (binds &body body)
         `(progn ,@body)
         (car (more (mapcar #'pairify (listify binds)))))))
 
         `(progn ,@body)
         (car (more (mapcar #'pairify (listify binds)))))))
 

+;;;--------------------------------------------------------------------------
+;;; with-places
+

 (defmacro %place-ref (getform setform newtmp)
   "Grim helper macro for with-places."
   (declare (ignore setform newtmp))
   getform)
 (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))
 (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
 (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


@@ -175,29 +193,38 @@ (defmacro with-places ((&key environment) places &body body)
                                          body))))))))))
           (car (more (mapcar #'pairify (listify places))))))))
 
                                          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 (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))
 (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))))
+        (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 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))
 
 (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))
 
 (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
 (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


@@ -210,13 +237,17 @@ (defmacro locf (place &environment env)
     `(let* (,@(mapcar #'list valtmps valforms))
        (make-loc (lambda () ,getform)
                  (lambda (,@newtmps) ,setform)))))
     `(let* (,@(mapcar #'list valtmps valforms))
        (make-loc (lambda () ,getform)
                  (lambda (,@newtmps) ,setform)))))

+

 (declaim (inline loc (setf loc)))
 (declaim (inline loc (setf loc)))

+

 (defun ref (loc)
   "Fetch the value referred to by a locative."
   (funcall (loc-reader 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))
 (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
 (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