X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/ec18c92a0624f298b1b316163578dc5b88c02067..9d3ccec7414eecee223bf9aa045924f2416ff609:/mdw-base.lisp?ds=sidebyside

diff --git a/mdw-base.lisp b/mdw-base.lisp
index edebebb..1f5a3eb 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -23,17 +23,26 @@
 ;;; 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
 	   #:show
-	   #:stringify #:listify #:fix-pair #:pairify
+	   #:stringify #:listify #:fix-pair #:pairify #:parse-body
 	   #:whitespace-char-p
 	   #:slot-uninitialized
+	   #:nlet #:while #:case2 #:ecase2
 	   #: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))
 (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."
@@ -56,9 +65,11 @@ converted to their print representations."
     (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 do-fix-pair (x y defaultp)
   "Helper function for fix-pair and pairify."
   (flet ((singleton (x) (values x (if defaultp y x))))
@@ -67,6 +78,7 @@ converted to their print representations."
 	  ((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
@@ -76,6 +88,7 @@ converted to their print representations."
   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)))
@@ -86,30 +99,33 @@ where Y defaults to A if not specified."
     ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
     (t nil)))
 
-(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))
-     ,@body))
-
 (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)
+  "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)))))
+
+;;;--------------------------------------------------------------------------
+;;; Generating symbols.
+
 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."
   `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
@@ -133,13 +149,68 @@ gensyms will be bound to the corresponding VALUE."
         `(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))
+     ,@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 var) &rest forms)
+			 clause
+		       `(,cases
+			 ,@(if var
+			       (list `(let ((,var ,argument)) ,@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."
+  (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))
+
+;;;--------------------------------------------------------------------------
+;;; 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
@@ -173,10 +244,38 @@ reading or setting the value of the corresponding PLACE."
                                          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
@@ -189,13 +288,17 @@ work."
     `(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