X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/blobdiff_plain/02866e072a8ac99b5e639fe79b4a7c6df5f11fdc..9d3ccec7414eecee223bf9aa045924f2416ff609:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 4d67b7a..1f5a3eb 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -30,9 +30,10 @@ (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
 	   #:update-place #:update-place-after
@@ -98,30 +99,30 @@ (defun whitespace-char-p (ch)
     ((#\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.
 
@@ -148,6 +149,56 @@ (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))
+     ,@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