X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/0ff9df03bb54ba792cefa551face51748ae34259..2c13c1cd713e033763786de1ce9fc66565abb5df:/optparse.lisp

diff --git a/optparse.lisp b/optparse.lisp
index acbe11f..ff301ee 100644
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -38,7 +38,7 @@
 	     #:op-negated-numeric-p #:op-negated-p
 	   #:option-parse-error
 	   #:option-parse-remainder #:option-parse-next #:option-parse-try
-	     #:with-unix-error-reporting 
+	     #:with-unix-error-reporting #:option-parse-return
 	   #:defopthandler #:invoke-option-handler
 	     #:set #:clear #:inc #:dec #:read #:int #:string
 	     #:keyword #:list
@@ -46,7 +46,8 @@
 	   #:simple-usage #:show-usage #:show-version #:show-help
 	   #:sanity-check-option-list
 	   #:*help* #:*version* #:*usage* #:*options*
-	   #:do-options #:help-opts #:define-program #:do-usage #:die-usage))
+	   #:do-options #:help-options
+	   #:define-program #:do-usage #:die-usage))
 
 (in-package #:optparse)
 
@@ -65,7 +66,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; The main option parser.
 
-(defvar *options*)
+(defvar *options* nil)
 
 (defstruct (option (:predicate optionp)
 		   (:conc-name opt-)
@@ -204,6 +205,12 @@
   "Returns the unparsed remainder of the command line."
   (cdr (op-args op)))
 
+(defun option-parse-return (tag &optional argument)
+  "Should be called from an option handler: forces a return from the
+   immediately enclosing `option-parse-next' with the given TAG and
+   ARGUMENT."
+  (throw 'option-parse-return (values tag argument)))
+
 (defun option-parse-next (op)
   "The main option-parsing function.  OP is an option-parser object,
    initialized appropriately.  Returns two values, OPT and ARG: OPT is the
@@ -214,185 +221,186 @@
    argument.  It is safe for tag functions to throw out of option-parse-next,
    if they desparately need to.  (This is the only way to actually get
    option-parse-next to return a function value, should that be what you
-   want.)
+   want.  See `option-parse-return' for a way of doing this.)
 
    While option-parse-next is running, there is a restart `skip-option' which
    moves on to the next option.  Error handlers should use this to resume
    after parsing errors."
-  (loop
-     (labels ((ret (opt &optional arg)
-		(return-from option-parse-next (values opt arg)))
-	      (finished ()
-		(setf (op-next op) nil)
-		(ret nil nil))
-	      (peek-arg ()
-		(cadr (op-next op)))
-	      (more-args-p ()
-		(and (op-next op)
-		     (cdr (op-next op))))
-	      (skip-arg ()
-		(setf (op-next op) (cdr (op-next op))))
-	      (eat-arg ()
-		(setf (cdr (op-next op)) (cddr (op-next op))))
-	      (get-arg ()
-		(prog1 (peek-arg) (eat-arg)))
-	      (process-option (o name negp &key arg argfunc)
-		(cond ((not (opt-arg-name o))
-		       (when arg
-			 (option-parse-error
-			  "Option `~A' does not accept arguments"
-			  name)))
-		      (arg)
-		      (argfunc
-		       (setf arg (funcall argfunc)))
-		      ((opt-arg-optional-p o))
-		      ((more-args-p)
-		       (setf arg (get-arg)))
-		      (t
-		       (option-parse-error "Option `~A' requires an argument"
-					   name)))
-		(let ((how (if negp (opt-negated-tag o) (opt-tag o))))
-		  (if (functionp how)
-		      (funcall how arg)
-		      (ret how arg))))
-	      (process-long-option (arg start negp)
-		(when (and (not negp)
-			   (op-negated-p op)
-			   (> (length arg) (+ start 3))
-			   (string= arg "no-"
-				    :start1 start :end1 (+ start 3)))
-		  (incf start 3)
-		  (setf negp t))
-		(let* ((matches nil)
-		       (eqpos (position #\= arg :start start))
-		       (len (or eqpos (length arg)))
-		       (optname (subseq arg 0 len))
-		       (len-2 (- len start)))
-		  (dolist (o (op-options op))
-		    (cond ((or (not (stringp (opt-long-name o)))
-			       (and negp (not (opt-negated-tag o)))
-			       (< (length (opt-long-name o)) len-2)
-			       (string/= optname (opt-long-name o)
-					 :start1 start :end2 len-2)))
-			  ((= (length (opt-long-name o)) len-2)
-			   (setf matches (list o))
-			   (return))
-			  (t
-			   (push o matches))))
-		  (cond ((null matches)
-			 (option-parse-error "Unknown option `~A'" optname))
-			((cdr matches)
-			 (option-parse-error
-			  "~
+  (labels ((ret (opt &optional arg)
+	     (return-from option-parse-next (values opt arg)))
+	   (finished ()
+	     (setf (op-next op) nil)
+	     (ret nil nil))
+	   (peek-arg ()
+	     (cadr (op-next op)))
+	   (more-args-p ()
+	     (and (op-next op)
+		  (cdr (op-next op))))
+	   (skip-arg ()
+	     (setf (op-next op) (cdr (op-next op))))
+	   (eat-arg ()
+	     (setf (cdr (op-next op)) (cddr (op-next op))))
+	   (get-arg ()
+	     (prog1 (peek-arg) (eat-arg)))
+	   (process-option (o name negp &key arg argfunc)
+	     (cond ((not (opt-arg-name o))
+		    (when arg
+		      (option-parse-error
+		       "Option `~A' does not accept arguments"
+		       name)))
+		   (arg)
+		   (argfunc
+		    (setf arg (funcall argfunc)))
+		   ((opt-arg-optional-p o))
+		   ((more-args-p)
+		    (setf arg (get-arg)))
+		   (t
+		    (option-parse-error "Option `~A' requires an argument"
+		     name)))
+	     (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
+	       (if (functionp how)
+		   (funcall how arg)
+		   (ret how arg))))
+	   (process-long-option (arg start negp)
+	     (when (and (not negp)
+			(op-negated-p op)
+			(> (length arg) (+ start 3))
+			(string= arg "no-"
+				 :start1 start :end1 (+ start 3)))
+	       (incf start 3)
+	       (setf negp t))
+	     (let* ((matches nil)
+		    (eqpos (position #\= arg :start start))
+		    (len (or eqpos (length arg)))
+		    (optname (subseq arg 0 len))
+		    (len-2 (- len start)))
+	       (dolist (o (op-options op))
+		 (cond ((or (not (stringp (opt-long-name o)))
+			    (and negp (not (opt-negated-tag o)))
+			    (< (length (opt-long-name o)) len-2)
+			    (string/= optname (opt-long-name o)
+				      :start1 start :end2 len-2)))
+		       ((= (length (opt-long-name o)) len-2)
+			(setf matches (list o))
+			(return))
+		       (t
+			(push o matches))))
+	       (cond ((null matches)
+		      (option-parse-error "Unknown option `~A'" optname))
+		     ((cdr matches)
+		      (option-parse-error
+		       "~
 Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
-			  optname
-			  (mapcar #'opt-long-name matches))))
-		  (process-option (car matches)
-				  optname
-				  negp
-				  :arg (and eqpos
-					    (subseq arg (1+ eqpos)))))))
-       (with-simple-restart (skip-option "Skip this bogus option.")
-	 (cond
-	   ;;
-	   ;; We're embroiled in short options: handle them.
-	   ((op-short-opt op)
-	    (if (>= (op-short-opt-index op) (length (op-short-opt op)))
-		(setf (op-short-opt op) nil)
-		(let* ((str (op-short-opt op))
-		       (i (op-short-opt-index op))
-		       (ch (char str i))
-		       (negp (op-short-opt-neg-p op))
-		       (name (format nil "~C~A" (if negp #\+ #\-) ch))
-		       (o (find ch (op-options op) :key #'opt-short-name)))
-		  (incf i)
-		  (setf (op-short-opt-index op) i)
-		  (when (or (not o)
-			    (and negp (not (opt-negated-tag o))))
-		    (option-parse-error "Unknown option `~A'" name))
-		  (process-option o
-				  name
-				  negp
-				  :argfunc
-				  (and (< i (length str))
-				       (lambda ()
-					 (prog1
-					     (subseq str i)
-					   (setf (op-short-opt op)
-						 nil))))))))
-	   ;;
-	   ;; End of the list.  Say we've finished.
-	   ((not (more-args-p))
-	    (finished))
-	   ;;
-	   ;; Process the next option.
-	   (t
-	    (let ((arg (peek-arg)))
-	      (cond
-		;;
-		;; Non-option.  Decide what to do.
-		((or (<= (length arg) 1)
-		     (and (char/= (char arg 0) #\-)
-			  (or (char/= (char arg 0) #\+)
-			      (not (op-negated-p op)))))
-		 (case (op-non-option op)
-		   (:skip (skip-arg))
-		   (:stop (finished))
-		   (:return (eat-arg)
-			    (ret :non-option arg))
-		   (t (eat-arg)
-		      (funcall (op-non-option op) arg))))
-		;;
-		;; Double-hyphen.  Stop right now.
-		((string= arg "--")
-		 (eat-arg)
-		 (finished))
-		;;
-		;; Numbers.  Check these before long options, since `--43' is
-		;; not a long option.
-		((and (op-numeric-p op)
-		      (or (char= (char arg 0) #\-)
-			  (op-negated-numeric-p op))
-		      (or (and (digit-char-p (char arg 1))
-			       (every #'digit-char-p (subseq arg 2)))
-			  (and (or (char= (char arg 1) #\-)
-				   (char= (char arg 1) #\+))
-			       (>= (length arg) 3)
-			       (digit-char-p (char arg 2))
-			       (every #'digit-char-p (subseq arg 3)))))
-		 (eat-arg)
-		 (let ((negp (char= (char arg 0) #\+))
-		       (num (parse-integer arg :start 1)))
-		   (when (and negp (eq (op-negated-numeric-p op) :-))
-		     (setf num (- num))
-		     (setf negp nil))
-		   (let ((how (if negp
-				  (op-negated-numeric-p op)
-				  (op-numeric-p op))))
-		     (if (functionp how)
-			 (funcall how num)
-			 (ret (if negp :negated-numeric :numeric) num)))))
-		;;
-		;; Long option.  Find the matching option-spec and process
-		;; it.
-		((and (char= (char arg 0) #\-)
-		      (char= (char arg 1) #\-))
-		 (eat-arg)
-		 (process-long-option arg 2 nil))
-		;;
-		;; Short options.  All that's left.
-		(t
-		 (eat-arg)
-		 (let ((negp (char= (char arg 0) #\+))
-		       (ch (char arg 1)))
-		   (cond ((and (op-long-only-p op)
-			       (not (member ch (op-options op)
-					    :key #'opt-short-name)))
-			  (process-long-option arg 1 negp))
-			 (t
-			  (setf (op-short-opt op) arg
-				(op-short-opt-index op) 1
-				(op-short-opt-neg-p op) negp)))))))))))))
+		       optname
+		       (mapcar #'opt-long-name matches))))
+	       (process-option (car matches)
+			       optname
+			       negp
+			       :arg (and eqpos
+					 (subseq arg (1+ eqpos)))))))
+    (catch 'option-parse-return
+      (loop
+	(with-simple-restart (skip-option "Skip this bogus option.")
+	  (cond
+	    ;;
+	    ;; We're embroiled in short options: handle them.
+	    ((op-short-opt op)
+	     (if (>= (op-short-opt-index op) (length (op-short-opt op)))
+		 (setf (op-short-opt op) nil)
+		 (let* ((str (op-short-opt op))
+			(i (op-short-opt-index op))
+			(ch (char str i))
+			(negp (op-short-opt-neg-p op))
+			(name (format nil "~C~A" (if negp #\+ #\-) ch))
+			(o (find ch (op-options op) :key #'opt-short-name)))
+		   (incf i)
+		   (setf (op-short-opt-index op) i)
+		   (when (or (not o)
+			     (and negp (not (opt-negated-tag o))))
+		     (option-parse-error "Unknown option `~A'" name))
+		   (process-option o
+				   name
+				   negp
+				   :argfunc
+				   (and (< i (length str))
+					(lambda ()
+					  (prog1
+					      (subseq str i)
+					    (setf (op-short-opt op)
+						  nil))))))))
+	    ;;
+	    ;; End of the list.  Say we've finished.
+	    ((not (more-args-p))
+	     (finished))
+	    ;;
+	    ;; Process the next option.
+	    (t
+	     (let ((arg (peek-arg)))
+	       (cond
+		 ;;
+		 ;; Non-option.  Decide what to do.
+		 ((or (<= (length arg) 1)
+		      (and (char/= (char arg 0) #\-)
+			   (or (char/= (char arg 0) #\+)
+			       (not (op-negated-p op)))))
+		  (case (op-non-option op)
+		    (:skip (skip-arg))
+		    (:stop (finished))
+		    (:return (eat-arg)
+			     (ret :non-option arg))
+		    (t (eat-arg)
+		       (funcall (op-non-option op) arg))))
+		 ;;
+		 ;; Double-hyphen.  Stop right now.
+		 ((string= arg "--")
+		  (eat-arg)
+		  (finished))
+		 ;;
+		 ;; Numbers.  Check these before long options, since `--43'
+		 ;; is not a long option.
+		 ((and (op-numeric-p op)
+		       (or (char= (char arg 0) #\-)
+			   (op-negated-numeric-p op))
+		       (or (and (digit-char-p (char arg 1))
+				(every #'digit-char-p (subseq arg 2)))
+			   (and (or (char= (char arg 1) #\-)
+				    (char= (char arg 1) #\+))
+				(>= (length arg) 3)
+				(digit-char-p (char arg 2))
+				(every #'digit-char-p (subseq arg 3)))))
+		  (eat-arg)
+		  (let ((negp (char= (char arg 0) #\+))
+			(num (parse-integer arg :start 1)))
+		    (when (and negp (eq (op-negated-numeric-p op) :-))
+		      (setf num (- num))
+		      (setf negp nil))
+		    (let ((how (if negp
+				   (op-negated-numeric-p op)
+				   (op-numeric-p op))))
+		      (if (functionp how)
+			  (funcall how num)
+			  (ret (if negp :negated-numeric :numeric) num)))))
+		 ;;
+		 ;; Long option.  Find the matching option-spec and process
+		 ;; it.
+		 ((and (char= (char arg 0) #\-)
+		       (char= (char arg 1) #\-))
+		  (eat-arg)
+		  (process-long-option arg 2 nil))
+		 ;;
+		 ;; Short options.  All that's left.
+		 (t
+		  (eat-arg)
+		  (let ((negp (char= (char arg 0) #\+))
+			(ch (char arg 1)))
+		    (cond ((and (op-long-only-p op)
+				(not (member ch (op-options op)
+					     :key #'opt-short-name)))
+			   (process-long-option arg 1 negp))
+			  (t
+			   (setf (op-short-opt op) arg
+				 (op-short-opt-index op) 1
+				 (op-short-opt-neg-p op) negp))))))))))))))
 
 (defmacro option-parse-try (&body body)
   "Report errors encountered while parsing options, and continue struggling
@@ -438,13 +446,15 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
    on some parameters (the ARGS) and the value of an option-argument named
    ARG."
   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
-    `(progn
-       (setf (get ',name 'opthandler) ',func)
-       (defun ,func (,var ,arg ,@args)
-	 (with-locatives ,var
-	   (declare (ignorable ,arg))
-	   ,@body))
-      ',name)))
+    (multiple-value-bind (docs decls body) (parse-body body)
+      `(progn
+	 (setf (get ',name 'opthandler) ',func)
+	 (defun ,func (,var ,arg ,@args)
+	   ,@docs ,@decls
+	   (with-locatives ,var
+	     (declare (ignorable ,arg))
+	     ,@body))
+	 ',name))))
 
 (defun parse-c-integer (string &key radix (start 0) end)
   "Parse STRING, or at least the parts of it between START and END, according
@@ -563,29 +573,38 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
   "Stores ARG in VAR, just as it is."
   (setf var arg))
 
-(defopthandler keyword (var arg) (&rest valid)
-  (if (null valid)
-      (setf var (intern (string-upcase arg) :keyword))
-      (let ((matches nil)
-	    (guess (string-upcase arg))
-	    (len (length arg)))
-	(dolist (k valid)
-	  (let* ((kn (symbol-name k))
-		 (klen (length kn)))
-	    (cond ((string= kn guess)
-		   (setf matches (list k))
-		   (return))
-		  ((and (< len klen)
-			(string= guess kn :end2 len))
-		   (push k matches)))))
-	(case (length matches)
-	  (0 (option-parse-error "Argument `~A' invalid: must be one of:~
-                                   ~{~%~8T~(~A~)~}"
-				 arg valid))
-	  (1 (setf var (car matches)))
-	  (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
-                                   ~{~%~8T~(~A~)~}"
-				 arg matches))))))
+(defopthandler keyword (var arg) (&optional (valid t))
+  "Converts ARG into a keyword.  If VALID is t, then any ARG string is
+   acceptable: the argument is uppercased and interned in the keyword
+   package.  If VALID is a list, then we ensure that ARG matches one of the
+   elements of the list; unambigious abbreviations are allowed."
+  (etypecase valid
+    ((member t)
+     (setf var (intern (string-upcase arg) :keyword)))
+    (list
+     (let ((matches nil)
+	   (guess (string-upcase arg))
+	   (len (length arg)))
+       (dolist (k valid)
+	 (let* ((kn (symbol-name k))
+		(klen (length kn)))
+	   (cond ((string= kn guess)
+		  (setf matches (list k))
+		  (return))
+		 ((and (< len klen)
+		       (string= guess kn :end2 len))
+		  (push k matches)))))
+       (cond
+	 ((null matches)
+	  (option-parse-error "Argument `~A' invalid: must be one of:~
+			       ~{~%~8T~(~A~)~}"
+			      arg valid))
+	 ((null (cdr matches))
+	  (setf var (car matches)))
+	 (t
+	  (option-parse-error "Argument `~A' ambiguous: may be any of:~
+			       ~{~%~8T~(~A~)~}"
+			      arg matches)))))))
 
 (defopthandler list (var arg) (&optional handler &rest handler-args)
   "Collect ARGs in a list at VAR.  ARGs are translated by the HANDLER first,
@@ -648,6 +667,10 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
 		      (setf doc (doc f)))
 		     ((and (consp f) (symbolp (car f)))
 		      (case (car f)
+			(:short-name (setf short-name (cadr f)))
+			(:long-name (setf long-name (cadr f)))
+			(:tag (setf tag (cadr f)))
+			(:negated-tag (setf negated-tag (cadr f)))
 			(:arg (setf arg-name (cadr f)))
 			(:opt-arg (setf arg-name (cadr f))
 				  (setf arg-optional-p t))
@@ -683,9 +706,21 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
 
    (...)	A full option-form.  See below.
 
-   Full option-forms are as follows.
+   Full option-forms are a list of the following kinds of items.
+
+   (:short-name CHAR)
+   (:long-name STRING)
+   (:arg STRING)
+   (:tag TAG)
+   (:negated-tag TAG)
+   (:doc STRING)
+		Set the appropriate slot of the option to the given value.
+		The argument is evaluated.
 
-   KEYWORD or FUNCTION
+   (:doc FORMAT-CONTROL ARGUMENTS...)
+		As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
+
+   KEYWORD, (function ...), (lambda ...)
 		If no TAG is set yet, then as a TAG; otherwise as the
 		NEGATED-TAG.
 
@@ -694,25 +729,19 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
 		and rationals, the item is converted to a string and squashed
 		to lower-case.
 
-   CHARACTER	The SHORT-NAME.
+   CHARACTER	If no SHORT-NAME, then the SHORT-NAME.
 
    STRING or (STRING STUFF...)
 		If no DOCUMENTATION set yet, then the DOCUMENTATION string,
-		as for (:DOC STRING STUFF...)
-
-   (:DOC STRING STUFF...)
-		The DOCUMENATION string.  With no STUFF, STRING is used as
-		is;otherwise the documentation string is computed by (format
-		nil STRING STUFF...).
+		as for (:doc STRING STUFF...)
 
-   (:ARG NAME)	Set the ARG-NAME.
-
-   (:OPT-ARG NAME)
+   (:opt-arg NAME)
 		Set the ARG-NAME, and also set ARG-OPTIONAL-P.
 
    (HANDLER VAR ARGS...)
 		If no TAG is set yet, attach the HANDLER to this option,
 		giving it ARGS.  Otherwise, set the NEGATED-TAG."
+
   `(list ,@(mapcan (lambda (form)
 		     (multiple-value-bind
 			 (sym args)
@@ -882,9 +911,16 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
 ;;;--------------------------------------------------------------------------
 ;;; Full program descriptions.
 
-(defvar *help*)
-(defvar *version*)
-(defvar *usage*)
+(defvar *help* nil)
+(defvar *version* "<unreleased>")
+(defvar *usage* nil)
+
+(defun do-usage (&optional (stream *standard-output*))
+  (show-usage *program-name* *usage* stream))
+
+(defun die-usage ()
+  (do-usage *error-output*)
+  (exit 1))
 
 (defun opt-help (arg)
   (declare (ignore arg))
@@ -894,77 +930,68 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
     ((or function symbol) (terpri) (funcall *help*)))
   (format t "~&")
   (exit 0))
-
 (defun opt-version (arg)
   (declare (ignore arg))
   (format t "~A, version ~A~%" *program-name* *version*)
   (exit 0))
-
-(defun do-usage (&optional (stream *standard-output*))
-  (show-usage *program-name* *usage* stream))
-
-(defun die-usage ()
-  (do-usage *error-output*)
-  (exit 1))
-
 (defun opt-usage (arg)
   (declare (ignore arg))
   (do-usage)
   (exit 0))
 
-(defoptmacro help-opts (&key (short-help #\h)
-			     (short-version #\v)
-			     (short-usage #\u))
-  (mapcar #'parse-option-form
-	  `("Help options"
-	    (,@(and short-help (list short-help))
-	     "help"
-	     #'opt-help
-	     "Show this help message.")
-	    (,@(and short-version (list short-version))
-	     "version"
-	     #'opt-version
-	     ("Show ~A's version number." *program-name*))
-	    (,@(and short-usage (list short-usage))
-	     "usage"
-	     #'opt-usage
-	     ("Show a very brief usage summary for ~A." *program-name*)))))
+(defoptmacro help-options (&key (short-help #\h)
+				(short-version #\v)
+				(short-usage #\u))
+  "Inserts a standard help options collection in an options list."
+  (flet ((shortform (char)
+	   (and char (list char))))
+    (mapcar
+     #'parse-option-form
+     `("Help options"
+       (,@(shortform short-help) "help" #'opt-help
+	"Show this help message.")
+       (,@(shortform short-version) "version" #'opt-version
+	("Show ~A's version number." *program-name*))
+       (,@(shortform short-usage) "usage" #'opt-usage
+	("Show a very brief usage summary for ~A." *program-name*))))))
 
 (defun define-program (&key
-		       program-name
-		       help
-		       version
-		       usage full-usage
-		       options)
+		       (program-name nil progp)
+		       (help nil helpp)
+		       (version nil versionp)
+		       (usage nil usagep)
+		       (full-usage nil fullp)
+		       (options nil optsp))
   "Sets up all the required things a program needs to have to parse options
    and respond to them properly."
-  (when program-name (setf *program-name* program-name))
-  (when help (setf *help* help))
-  (when version (setf *version* version))
-  (when options (setf *options* options))
-  (cond ((and usage full-usage) (error "conflicting options"))
-	(usage (setf *usage* (simple-usage *options* usage)))
-	(full-usage (setf *usage* full-usage))))
-
-(defmacro do-options ((&key (parser '(make-option-parser))) &body clauses)
+  (when progp (setf *program-name* program-name))
+  (when helpp (setf *help* help))
+  (when versionp (setf *version* version))
+  (when optsp (setf *options* options))
+  (cond ((and usagep fullp) (error "conflicting options"))
+	(usagep (setf *usage* (simple-usage *options* usage)))
+	(fullp (setf *usage* full-usage))))
+
+(defmacro do-options ((&key (parser '(make-option-parser)))
+		      &body clauses)
   "Handy all-in-one options parser macro.  PARSER defaults to a new options
    parser using the preset default options structure.  The CLAUSES are
    `case2'-like clauses to match options, and must be exhaustive.  If there
    is a clause (nil (REST) FORMS...) then the FORMS are evaluated after
    parsing is done with REST bound to the remaining command-line arguments."
-  (with-gensyms (tparser)
-    `(let ((,tparser ,parser))
+  (let*/gensyms (parser)
+    `(progn
        (loop
 	 (,(if (find t clauses :key #'car) 'case2 'ecase2)
-	     (option-parse-next ,tparser)
+	     (option-parse-next ,parser)
 	   ((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))
+		      (list `(let ((,arg (option-parse-remainder ,parser)))
+			      ,@forms))
 		      forms)))))))
 
 ;;;----- That's all, folks --------------------------------------------------