base, optparse: Introduce `case2' macros.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 72b5b06..bbe7662 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -33,7 +33,7 @@
           #: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 @@ gensyms will be bound to the corresponding VALUE."
      (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