#: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
(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
(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 --------------------------------------------------