From: Mark Wooding <mdw@distorted.org.uk>
Date: Sat, 22 Apr 2006 23:58:11 +0000 (+0100)
Subject: base, optparse: Introduce `case2' macros.
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/commitdiff_plain/560e118666d0a7c41a43e2d86e2f38e3b931ef14

base, optparse: Introduce `case2' macros.

  * base: Add new `case2' macro, for fetching two values, switching on
    one and binding the other.  Also add `ecase2' to do the obvious
    thing.

  * optparse: Rewrite `do-options' to use `ecase2' (or `case2').
---

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 72b5b06..bbe7662 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -33,7 +33,7 @@ (defpackage #:mdw.base
 	   #:stringify #:listify #:fix-pair #:pairify
 	   #:whitespace-char-p
 	   #:slot-uninitialized
-	   #:nlet #:while
+	   #:nlet #:while #:case2 #:ecase2
 	   #:with-gensyms #:let*/gensyms #:with-places
 	   #:locp #:locf #:ref #:with-locatives
 	   #:update-place #:update-place-after
@@ -152,6 +152,35 @@ (defmacro while (cond &body body)
      (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
 
diff --git a/optparse.lisp b/optparse.lisp
index e337fc0..d5e2f10 100644
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -941,31 +941,19 @@ (defun define-program (&key
 	(full-usage (setf *usage* full-usage))))
 
 (defmacro do-options ((&key (parser '(make-option-parser))) &body clauses)
-  (with-gensyms (topt targ tparser)
-    (flet ((frob (clause)
-	     (destructuring-bind
-		 (case (&optional arg) &rest forms)
-		 clause
-	       (and case 
-		    (list `(,case ,@(if arg
-					`(let ((,arg ,targ)) ,@forms)
-					forms)))))))
-      `(let ((,tparser ,parser))
-	 (loop
-	   (multiple-value-bind (,topt ,targ) (option-parse-next ,tparser)
-	     (declare (ignorable ,targ))
-	     (unless ,topt (return))
-	     (case ,topt
-	       ,@(mapcan #'frob clauses))))
-	 ,@(let ((tail (find nil clauses :key #'car)))
-	     (and tail
-		  (destructuring-bind
-		      ((&optional arg) &rest forms)
-		      (cdr tail)
-		    (list (if arg
-			      `(let ((,arg (option-parse-remainder
-					    ,tparser)))
-				 ,@forms)
-			      forms)))))))))
+  (with-gensyms (tparser)
+    `(let ((,tparser ,parser))
+       (loop
+	 (,(if (find t clauses :key #'car) 'case2 'ecase2)
+	     (option-parse-next ,tparser)
+	   ((nil) () (return))
+	   ,@(remove-if #'null clauses :key #'car)))
+       ,@(let ((tail (find nil clauses :key #'car)))
+	   (and tail
+		(destructuring-bind ((&optional arg) &rest forms) (cdr tail)
+		  (if arg
+		      (list `(let ((,arg (option-parse-remainder ,tparser)))
+			       ,@forms))
+		      forms)))))))
 
 ;;;----- That's all, folks --------------------------------------------------