Reformat all the docstrings.

[lisp] / optparse.lisp

diff --git a/optparse.lisp b/optparse.lisp
index 7819b70a51687dbd2ed865da19de8731e5155452..acbe11ff2aa05f814d07fdae7b0bfef58b8a2c56 100644 (file)
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -23,7 +23,10 @@
 ;;; along with this program; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 ;;; along with this program; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 

-(defpackage #:mdw.optparse
+;;;--------------------------------------------------------------------------
+;;; Packages.
+
+(defpackage #:optparse

   (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
   (:export #:exit #:*program-name* #:*command-line-strings*
           #:moan #:die
   (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
   (:export #:exit #:*program-name* #:*command-line-strings*
           #:moan #:die


@@ -41,22 +44,29 @@ (defpackage #:mdw.optparse
             #:keyword #:list
           #:parse-option-form #:options
           #:simple-usage #:show-usage #:show-version #:show-help
             #:keyword #:list
           #:parse-option-form #:options
           #:simple-usage #:show-usage #:show-version #:show-help

-          #:sanity-check-option-list))
+          #:sanity-check-option-list
+          #:*help* #:*version* #:*usage* #:*options*
+          #:do-options #:help-opts #:define-program #:do-usage #:die-usage))

 
 

-(in-package #:mdw.optparse)
+(in-package #:optparse)

 
 

+;;;--------------------------------------------------------------------------

 ;;; Standard error-reporting functions.
 
 (defun moan (msg &rest args)
   "Report an error message in the usual way."
   (format *error-output* "~&~A: ~?~%" *program-name* msg args))
 ;;; Standard error-reporting functions.
 
 (defun moan (msg &rest args)
   "Report an error message in the usual way."
   (format *error-output* "~&~A: ~?~%" *program-name* msg args))

+

 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)
   (exit 1))
 
 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)
   (exit 1))
 

+;;;--------------------------------------------------------------------------

 ;;; The main option parser.
 
 ;;; The main option parser.
 

+(defvar *options*)
+

 (defstruct (option (:predicate optionp)
                   (:conc-name opt-)
                   (:print-function
 (defstruct (option (:predicate optionp)
                   (:conc-name opt-)
                   (:print-function


@@ -85,32 +95,34 @@ (defstruct (option (:predicate optionp)
                                  (documentation doc))))
   "Describes a command-line option.  Slots:
 
                                  (documentation doc))))
   "Describes a command-line option.  Slots:
 

-LONG-NAME       The option's long name.  If this is null, the `option' is
-                just a banner to be printed in the program's help text.
+   LONG-NAME   The option's long name.  If this is null, the `option' is
+               just a banner to be printed in the program's help text.

 
 

-TAG             The value to be returned if this option is encountered.  If
-                this is a function, instead, the function is called with the
-                option's argument or nil.
+   TAG          The value to be returned if this option is encountered.  If
+               this is a function, instead, the function is called with the
+               option's argument or nil.

 
 

-NEGATED-TAG     As for TAG, but used if the negated form of the option is
-                found.  If this is nil (the default), the option cannot be
-                negated. 
+   NEGATED-TAG  As for TAG, but used if the negated form of the option is
+               found.  If this is nil (the default), the option cannot be
+               negated. 

 
 

-SHORT-NAME      The option's short name.  This must be a single character, or
-                nil if the option has no short name.
+   SHORT-NAME   The option's short name.  This must be a single character, or
+               nil if the option has no short name.

 
 

-ARG-NAME        The name of the option's argument, a string.  If this is nil,
-                the option doesn't accept an argument.  The name is shown in
-                the help text.
+   ARG-NAME     The name of the option's argument, a string.  If this is nil,
+               the option doesn't accept an argument.  The name is shown in
+               the help text.

 
 

-ARG-OPTIONAL-P  If non-nil, the option's argument is optional.  This is
-                ignored unless ARG-NAME is non-null.
+   ARG-OPTIONAL-P
+               If non-nil, the option's argument is optional.  This is
+               ignored unless ARG-NAME is non-null.

 
 

-DOCUMENTATION   The help text for this option.  It is automatically
-                line-wrapped.  If nil, the option is omitted from the help
-                text.
+   DOCUMENTATION
+               The help text for this option.  It is automatically line-
+               wrapped.  If nil, the option is omitted from the help
+               text.

 
 

-Usually, one won't use make-option, but use the option macro instead."
+   Usually, one won't use make-option, but use the option macro instead."

   (long-name nil :type (or null string))
   (tag nil :type t)
   (negated-tag nil :type t)
   (long-name nil :type (or null string))
   (tag nil :type t)
   (negated-tag nil :type t)


@@ -121,9 +133,10 @@ (defstruct (option (:predicate optionp)
 
 (defstruct (option-parser (:conc-name op-)
                          (:constructor make-option-parser
 
 (defstruct (option-parser (:conc-name op-)
                          (:constructor make-option-parser

-                                       (argstmp
-                                        options
-                                        &key
+                                       (&key
+                                        ((:args argstmp)
+                                         (cdr *command-line-strings*))
+                                        (options *options*)

                                         (non-option :skip)
                                         ((:numericp numeric-p))
                                         negated-numeric-p
                                         (non-option :skip)
                                         ((:numericp numeric-p))
                                         negated-numeric-p


@@ -137,32 +150,32 @@ (defstruct (option-parser (:conc-name op-)
                                                         options))))))
   "An option parser object.  Slots:
 
                                                         options))))))
   "An option parser object.  Slots:
 

-ARGS            The arguments to be parsed.  Usually this will be
-                *command-line-strings*.
+   ARGS                The arguments to be parsed.  Usually this will be
+               *command-line-strings*.

 
 

-OPTIONS         List of option structures describing the acceptable options.
+   OPTIONS      List of option structures describing the acceptable options.

 
 

-NON-OPTION      Behaviour when encountering a non-option argument.  The
-                default is :skip.  Allowable values are:
-                  :skip -- pretend that it appeared after the option
-                    arguments; this is the default behaviour of GNU getopt
-                  :stop -- stop parsing options, leaving the remaining
-                    command line unparsed
-                  :return -- return :non-option and the argument word
+   NON-OPTION   Behaviour when encountering a non-option argument.  The
+               default is :skip.  Allowable values are:
+                 :skip -- pretend that it appeared after the option
+                   arguments; this is the default behaviour of GNU getopt
+                 :stop -- stop parsing options, leaving the remaining
+                   command line unparsed
+                 :return -- return :non-option and the argument word

 
 

-NUMERIC-P       Non-nil tag (as for options) if numeric options (e.g., -43)
-                are to be allowed.  The default is nil.  (Anomaly: the
-                keyword for this argument is :numericp.)
+   NUMERIC-P    Non-nil tag (as for options) if numeric options (e.g., -43)
+               are to be allowed.  The default is nil.  (Anomaly: the
+               keyword for this argument is :numericp.)

 
 

-NEGATED-NUMERIC-P
-                Non-nil tag (as for options) if numeric options (e.g., -43)
-                can be negated.  This is not the same thing as a negative
-                numeric option!
+   NEGATED-NUMERIC-P
+               Non-nil tag (as for options) if numeric options (e.g., -43)
+               can be negated.  This is not the same thing as a negative
+               numeric option!

 
 

-LONG-ONLY-P     A misnomer inherited from GNU getopt.  Whether to allow
-                long options to begin with a single dash.  Short options are
-                still allowed, and may be cuddled as usual.  The default is
-                nil."
+   LONG-ONLY-P  A misnomer inherited from GNU getopt.  Whether to allow
+               long options to begin with a single dash.  Short options are
+               still allowed, and may be cuddled as usual.  The default is
+               nil."

   (args nil :type list)
   (options nil :type list)
   (non-option :skip :type (or function (member :skip :stop :return)))
   (args nil :type list)
   (options nil :type list)
   (non-option :skip :type (or function (member :skip :stop :return)))


@@ -177,8 +190,9 @@ (defstruct (option-parser (:conc-name op-)
 
 (define-condition option-parse-error (error simple-condition)
   ()
 
 (define-condition option-parse-error (error simple-condition)
   ()

-  (:documentation "Indicates an error found while parsing options.  Probably
-not that useful."))
+  (:documentation
+   "Indicates an error found while parsing options.  Probably not that
+   useful."))

 
 (defun option-parse-error (msg &rest args)
   "Signal an option-parse-error with the given message and arguments."
 
 (defun option-parse-error (msg &rest args)
   "Signal an option-parse-error with the given message and arguments."


@@ -192,18 +206,19 @@ (defun option-parse-remainder (op)
 
 (defun option-parse-next (op)
   "The main option-parsing function.  OP is an option-parser object,
 
 (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 tag
-of the next option read, and ARG is the argument attached to it, or nil if
-there was no argument.  If there are no more options, returns nil twice.
-Options whose TAG is a function aren't returned; instead, the tag function is
-called, with the option argument (or nil) as the only 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.)
-
-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."
+   initialized appropriately.  Returns two values, OPT and ARG: OPT is the
+   tag of the next option read, and ARG is the argument attached to it, or
+   nil if there was no argument.  If there are no more options, returns nil
+   twice.  Options whose TAG is a function aren't returned; instead, the tag
+   function is called, with the option argument (or nil) as the only
+   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.)
+
+   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)))
   (loop
      (labels ((ret (opt &optional arg)
                (return-from option-parse-next (values opt arg)))


@@ -381,8 +396,8 @@ (defun option-parse-next (op)
 
 (defmacro option-parse-try (&body body)
   "Report errors encountered while parsing options, and continue struggling
 
 (defmacro option-parse-try (&body body)
   "Report errors encountered while parsing options, and continue struggling

-along.  Also establishes a restart `stop-parsing'.  Returns t if parsing
-completed successfully, or nil if errors occurred."
+   along.  Also establishes a restart `stop-parsing'.  Returns t if parsing
+   completed successfully, or nil if errors occurred."

   (with-gensyms (retcode)
     `(let ((,retcode t))
        (restart-case
   (with-gensyms (retcode)
     `(let ((,retcode t))
        (restart-case


@@ -406,19 +421,22 @@ (defmacro with-unix-error-reporting ((&key) &body body)
     `(handler-case
         (progn ,@body)
        (simple-condition (,cond)
     `(handler-case
         (progn ,@body)
        (simple-condition (,cond)

-        (die (simple-condition-format-control ,cond)
-             (simple-condition-format-arguments ,cond)))
+        (apply #'die
+               (simple-condition-format-control ,cond)
+               (simple-condition-format-arguments ,cond)))

        (error (,cond)
         (die "~A" ,cond)))))
 
        (error (,cond)
         (die "~A" ,cond)))))
 

+;;;--------------------------------------------------------------------------

 ;;; Standard option handlers.
 
 (defmacro defopthandler (name (var &optional (arg (gensym)))
                         (&rest args)
                         &body body)
   "Define an option handler function NAME.  Option handlers update a
 ;;; Standard option handlers.
 
 (defmacro defopthandler (name (var &optional (arg (gensym)))
                         (&rest args)
                         &body body)
   "Define an option handler function NAME.  Option handlers update a

-generalized variable, which may be referred to as VAR in the BODY, based on
-some parameters (the ARGS) and the value of an option-argument named ARG."
+   generalized variable, which may be referred to as VAR in the BODY, based
+   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)
   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
     `(progn
        (setf (get ',name 'opthandler) ',func)


@@ -426,15 +444,16 @@        (defun ,func (,var ,arg ,@args)
         (with-locatives ,var
           (declare (ignorable ,arg))
           ,@body))
         (with-locatives ,var
           (declare (ignorable ,arg))
           ,@body))

-       ',name)))
+      ',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
 
 (defun parse-c-integer (string &key radix (start 0) end)
   "Parse STRING, or at least the parts of it between START and END, according

-to the standard C rules.  Well, almost: the 0 and 0x prefixes are accepted,
-but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted,
-for any radix between 2 and 36.  Prefixes are only accepted if RADIX is nil.
-Returns two values: the integer parsed (or nil if there wasn't enough for a
-sensible parse), and the index following the characters of the integer."
+   to the standard C rules.  Well, almost: the 0 and 0x prefixes are
+   accepted, but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS
+   is accepted, for any radix between 2 and 36.  Prefixes are only accepted
+   if RADIX is nil.  Returns two values: the integer parsed (or nil if there
+   wasn't enough for a sensible parse), and the index following the
+   characters of the integer."

   (unless end (setf end (length string)))
   (labels ((simple (i r goodp sgn)
             (multiple-value-bind
   (unless end (setf end (length string)))
   (labels ((simple (i r goodp sgn)
             (multiple-value-bind


@@ -478,35 +497,42 @@ (defun parse-c-integer (string &key radix (start 0) end)
 
 (defun invoke-option-handler (handler loc arg args)
   "Call the HANDLER function, giving it LOC to update, the option-argument
 
 (defun invoke-option-handler (handler loc arg args)
   "Call the HANDLER function, giving it LOC to update, the option-argument

-ARG, and the remaining ARGS."
+   ARG, and the remaining ARGS."

   (apply (if (functionp handler) handler
             (fdefinition (get handler 'opthandler)))
         loc
         arg
         args))
 
   (apply (if (functionp handler) handler
             (fdefinition (get handler 'opthandler)))
         loc
         arg
         args))
 

+;;;--------------------------------------------------------------------------
+;;; Built-in option handlers.
+

 (defopthandler set (var) (&optional (value t))
   "Sets VAR to VALUE; defaults to t."
   (setf var value))
 (defopthandler set (var) (&optional (value t))
   "Sets VAR to VALUE; defaults to t."
   (setf var value))

+

 (defopthandler clear (var) (&optional (value nil))
   "Sets VAR to VALUE; defaults to nil."
   (setf var value))
 (defopthandler clear (var) (&optional (value nil))
   "Sets VAR to VALUE; defaults to nil."
   (setf var value))

+

 (defopthandler inc (var) (&optional max (step 1))
   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
 (defopthandler inc (var) (&optional max (step 1))
   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default

-nil for no maximum).  No errors are signalled."
+   nil for no maximum).  No errors are signalled."

   (incf var step)
   (when (>= var max)
     (setf var max)))
   (incf var step)
   (when (>= var max)
     (setf var max)))

+

 (defopthandler dec (var) (&optional min (step 1))
   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
 (defopthandler dec (var) (&optional min (step 1))
   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil

-for no maximum).  No errors are signalled."
+   for no maximum).  No errors are signalled."

   (decf var step)
   (when (<= var min)
     (setf var min)))
   (decf var step)
   (when (<= var min)
     (setf var min)))

+

 (defopthandler read (var arg) ()
   "Stores in VAR the Lisp object found by reading the ARG.  Evaluation is
 (defopthandler read (var arg) ()
   "Stores in VAR the Lisp object found by reading the ARG.  Evaluation is

-forbidden while reading ARG.  If there is an error during reading, an error
-of type option-parse-error is signalled."
+   forbidden while reading ARG.  If there is an error during reading, an
+   error of type option-parse-error is signalled."

   (handler-case
       (let ((*read-eval* nil))
        (multiple-value-bind (x end) (read-from-string arg t)
   (handler-case
       (let ((*read-eval* nil))
        (multiple-value-bind (x end) (read-from-string arg t)


@@ -515,12 +541,14 @@ (defopthandler read (var arg) ()
          (setf var x)))
     (error (cond)
       (option-parse-error (format nil "~A" cond)))))
          (setf var x)))
     (error (cond)
       (option-parse-error (format nil "~A" cond)))))

+

 (defopthandler int (var arg) (&key radix min max)
   "Stores in VAR the integer read from the ARG.  Integers are parsed
 (defopthandler int (var arg) (&key radix min max)
   "Stores in VAR the integer read from the ARG.  Integers are parsed

-according to C rules, which is normal in Unix; the RADIX may be nil to allow
-radix prefixes, or an integer between 2 and 36.  An option-parse-error is
-signalled if the ARG is not a valid integer, or if it is not between MIN and
-MAX (either of which may be nil if no lower resp. upper bound is wanted)."
+   according to C rules, which is normal in Unix; the RADIX may be nil to
+   allow radix prefixes, or an integer between 2 and 36.  An
+   option-parse-error is signalled if the ARG is not a valid integer, or if
+   it is not between MIN and MAX (either of which may be nil if no lower
+   resp. upper bound is wanted)."

   (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
     (unless (and v (>= end (length arg)))
       (option-parse-error "Bad integer `~A'" arg))
   (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
     (unless (and v (>= end (length arg)))
       (option-parse-error "Bad integer `~A'" arg))


@@ -530,9 +558,11 @@ (defopthandler int (var arg) (&key radix min max)
        "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
        arg min max))
     (setf var v)))
        "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
        arg min max))
     (setf var v)))

+

 (defopthandler string (var arg) ()
   "Stores ARG in VAR, just as it is."
   (setf var arg))
 (defopthandler string (var arg) ()
   "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))
 (defopthandler keyword (var arg) (&rest valid)
   (if (null valid)
       (setf var (intern (string-upcase arg) :keyword))


@@ -556,16 +586,27 @@ (defopthandler keyword (var arg) (&rest valid)
          (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
                                    ~{~%~8T~(~A~)~}"
                                 arg 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,
 (defopthandler list (var arg) (&optional handler &rest handler-args)
   "Collect ARGs in a list at VAR.  ARGs are translated by the HANDLER first,

-if specified.  If not, it's as if you asked for `string'."
+   if specified.  If not, it's as if you asked for `string'."

   (when handler
     (invoke-option-handler handler (locf arg) arg handler-args))
   (setf var (nconc var (list arg))))
 
   (when handler
     (invoke-option-handler handler (locf arg) arg handler-args))
   (setf var (nconc var (list arg))))
 

+;;;--------------------------------------------------------------------------
+;;; Option descriptions.
+
+(defmacro defoptmacro (name args &body body)
+  "Defines an option macro NAME.  Option macros should produce a list of
+   expressions producing one option structure each."
+  `(progn
+     (setf (get ',name 'optmacro) (lambda ,args ,@body))
+     ',name))
+

 (compile-time-defun parse-option-form (form)
   "Does the heavy lifting for parsing an option form.  See the docstring for
 (compile-time-defun parse-option-form (form)
   "Does the heavy lifting for parsing an option form.  See the docstring for

-the `option' macro for details of the syntax."
+   the `option' macro for details of the syntax."

   (flet ((doc (form)
           (cond ((stringp form) form)
                 ((null (cdr form)) (car form))
   (flet ((doc (form)
           (cond ((stringp form) form)
                 ((null (cdr form)) (car form))


@@ -574,96 +615,119 @@ (compile-time-defun parse-option-form (form)
           (or (stringp form)
               (and (consp form)
                    (stringp (car form))))))
           (or (stringp form)
               (and (consp form)
                    (stringp (car form))))))

-    (if (and (docp (car form))
-            (null (cdr form)))
-       `(%make-option :documentation ,(doc (car form)))
-       (let (long-name short-name
-                       arg-name arg-optional-p
-                       tag negated-tag
-                       doc)
-         (dolist (f form)
-           (cond ((and (or (not tag) (not negated-tag))
-                       (or (keywordp f)
-                           (and (consp f)
-                                (member (car f) '(lambda function)))))
-                  (if tag
-                      (setf negated-tag f)
-                      (setf tag f)))
-                 ((and (not long-name)
-                       (or (rationalp f)
-                           (symbolp f)
-                           (stringp f)))
-                  (setf long-name (if (stringp f) f
-                                      (format nil "~(~A~)" f))))
-                 ((and (not short-name)
-                       (characterp f))
-                  (setf short-name f))
-                 ((and (not doc)
-                       (docp f))
-                  (setf doc (doc f)))
-                 ((and (consp f) (symbolp (car f)))
-                  (case (car f)
-                    (:arg (setf arg-name (cadr f)))
-                    (:opt-arg (setf arg-name (cadr f))
-                              (setf arg-optional-p t))
-                    (:doc (setf doc (doc (cdr f))))
-                    (t (let ((handler (get (car f) 'opthandler)))
-                         (unless handler
-                           (error "No handler `~S' defined." (car f)))
-                         (let* ((var (cadr f))
-                                (arg (gensym))
-                                (thunk `#'(lambda (,arg)
-                                            (,handler (locf ,var)
-                                                       ,arg
-                                                       ,@(cddr f)))))
-                           (if tag
-                               (setf negated-tag thunk)
-                               (setf tag thunk)))))))
-                 (t
-                  (error "Unexpected thing ~S in option form." f))))
-         `(make-option ,long-name ,short-name ,arg-name
-                       ,@(and arg-optional-p `(:arg-optional-p t))
-                       ,@(and tag `(:tag ,tag))
-                       ,@(and negated-tag `(:negated-tag ,negated-tag))
-                       ,@(and doc `(:documentation ,doc)))))))
+    (cond ((stringp form)
+          `(%make-option :documentation ,form))
+         ((not (listp form))
+          (error "option form must be string or list"))
+         ((and (docp (car form)) (null (cdr form)))
+          `(%make-option :documentation ,(doc (car form))))
+         (t
+          (let (long-name short-name
+                arg-name arg-optional-p
+                tag negated-tag
+                doc)
+            (dolist (f form)
+              (cond ((and (or (not tag) (not negated-tag))
+                          (or (keywordp f)
+                              (and (consp f)
+                                   (member (car f) '(lambda function)))))
+                     (if tag
+                         (setf negated-tag f)
+                         (setf tag f)))
+                    ((and (not long-name)
+                          (or (rationalp f)
+                              (symbolp f)
+                              (stringp f)))
+                     (setf long-name (if (stringp f) f
+                                         (format nil "~(~A~)" f))))
+                    ((and (not short-name)
+                          (characterp f))
+                     (setf short-name f))
+                    ((and (not doc)
+                          (docp f))
+                     (setf doc (doc f)))
+                    ((and (consp f) (symbolp (car f)))
+                     (case (car f)
+                       (:arg (setf arg-name (cadr f)))
+                       (:opt-arg (setf arg-name (cadr f))
+                                 (setf arg-optional-p t))
+                       (:doc (setf doc (doc (cdr f))))
+                       (t (let ((handler (get (car f) 'opthandler)))
+                            (unless handler
+                              (error "No handler `~S' defined." (car f)))
+                            (let* ((var (cadr f))
+                                   (arg (gensym))
+                                   (thunk `#'(lambda (,arg)
+                                               (,handler (locf ,var)
+                                                         ,arg
+                                                         ,@(cddr f)))))
+                              (if tag
+                                  (setf negated-tag thunk)
+                                  (setf tag thunk)))))))
+                    (t
+                     (error "Unexpected thing ~S in option form." f))))
+            `(make-option ,long-name ,short-name ,arg-name
+              ,@(and arg-optional-p `(:arg-optional-p t))
+              ,@(and tag `(:tag ,tag))
+              ,@(and negated-tag `(:negated-tag ,negated-tag))
+              ,@(and doc `(:documentation ,doc))))))))

 
 (defmacro options (&rest optlist)
   "More convenient way of initializing options.  The OPTLIST is a list of
 
 (defmacro options (&rest optlist)
   "More convenient way of initializing options.  The OPTLIST is a list of

-OPTFORMS.  Each OPTFORM is either a banner string, or a list of
-items.  Acceptable items are interpreted as follows:
-
-  KEYWORD or FUNCTION
-    If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG.
-
-  STRING (or SYMBOL or RATIONAL)
-    If no LONG-NAME seen yet, then the LONG-NAME.  For symbols and rationals,
-    the item is converted to a string and squashed to lower-case.
-
-  CHARACTER
-     The SHORT-NAME.
-
-  STRING or (STRING STUFF...)
-    If no DOCUMENTATION set yet, then the DOCUMENTATION string.  A string is
-    used as-is; a list is considered to be a `format' string and its
-    arguments.  This is evaluated at standard evaluation time: the option
-    structure returned contains a simple documentation string.
-
-  (:ARG NAME)
-    Set the 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 ,@(mapcar (lambda (form)
-                    (if (stringp form)
-                        `(%make-option :documentation ,form)
-                        (parse-option-form form)))
+   OPTFORMS.  Each OPTFORM is one of the following:
+
+   STRING      A banner to print.
+
+   SYMBOL or (SYMBOL STUFF...)
+               If SYMBOL is an optform macro, the result of invoking it.
+
+   (...)       A full option-form.  See below.
+
+   Full option-forms are as follows.
+
+   KEYWORD or FUNCTION
+               If no TAG is set yet, then as a TAG; otherwise as the
+               NEGATED-TAG.
+
+   STRING (or SYMBOL or RATIONAL)
+               If no LONG-NAME seen yet, then the LONG-NAME.  For symbols
+               and rationals, the item is converted to a string and squashed
+               to lower-case.
+
+   CHARACTER   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...).
+
+   (:ARG NAME) Set the 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)
+                        (cond ((symbolp form) (values form nil))
+                              ((and (consp form) (symbolp (car form)))
+                               (values (car form) (cdr form)))
+                              (t (values nil nil)))
+                      (let ((macro (and sym (get sym 'optmacro))))
+                        (if macro
+                            (apply macro args)
+                            (list (parse-option-form form))))))

                   optlist)))
 
                   optlist)))
 

-;;; Support stuff for help and usage messages
+;;;--------------------------------------------------------------------------
+;;; Support stuff for help and usage messages.

 
 (defun print-text (string
                   &optional
 
 (defun print-text (string
                   &optional


@@ -672,8 +736,8 @@ (defun print-text (string
                   (start 0)
                   (end nil))
   "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
                   (start 0)
                   (end nil))
   "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and

-newlines in the obvious way.  Stuff between square brackets is not broken:
-this makes usage messages work better."
+   newlines in the obvious way.  Stuff between square brackets is not broken:
+   this makes usage messages work better."

   (let ((i start)
        (nest 0)
        (splitp nil))
   (let ((i start)
        (nest 0)
        (splitp nil))


@@ -706,7 +770,7 @@ (defun print-text (string
 
 (defun simple-usage (opts &optional mandatory-args)
   "Build a simple usage list from a list of options, and (optionally)
 
 (defun simple-usage (opts &optional mandatory-args)
   "Build a simple usage list from a list of options, and (optionally)

-mandatory argument names."
+   mandatory argument names."

   (let (short-simple long-simple short-arg long-arg)
     (dolist (o opts)
       (cond ((not (and (opt-documentation o)
   (let (short-simple long-simple short-arg long-arg)
     (dolist (o opts)
       (cond ((not (and (opt-documentation o)


@@ -747,10 +811,10 @@ (defun simple-usage (opts &optional mandatory-args)
            (listify mandatory-args)))))
 
 (defun show-usage (prog usage &optional (stream *standard-output*))
            (listify mandatory-args)))))
 
 (defun show-usage (prog usage &optional (stream *standard-output*))

-  "Basic usage-showing function.  PROG is the program name, probable from
-*command-line-strings*.  USAGE is a list of possible usages of the program,
-each of which is a list of items to be supplied by the user.  In simple
-cases, a single string is sufficient."
+  "Basic usage-showing function.  PROG is the program name, probably from
+   *command-line-strings*.  USAGE is a list of possible usages of the
+   program, each of which is a list of items to be supplied by the user.  In
+   simple cases, a single string is sufficient."

   (pprint-logical-block (stream nil :prefix "Usage: ")
     (dolist (u (listify usage))
       (pprint-logical-block (stream nil :prefix (format nil "~A " prog))
   (pprint-logical-block (stream nil :prefix "Usage: ")
     (dolist (u (listify usage))
       (pprint-logical-block (stream nil :prefix (format nil "~A " prog))


@@ -759,10 +823,10 @@ (defun show-usage (prog usage &optional (stream *standard-output*))
 
 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
   "Basic help-showing function.  PROG is the program name, probably from
 
 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
   "Basic help-showing function.  PROG is the program name, probably from

-*command-line-strings*.  VER is the program's version number.  USAGE is a
-list of the possible usages of the program, each of which may be a list of
-items to be supplied.  OPTS is the list of supported options, as provided to
-the options parser.  STREAM is the stream to write on."
+   *command-line-strings*.  VER is the program's version number.  USAGE is a
+   list of the possible usages of the program, each of which may be a list of
+   items to be supplied.  OPTS is the list of supported options, as provided
+   to the options parser.  STREAM is the stream to write on."

   (format stream "~A, version ~A~2%" prog ver)
   (show-usage prog usage stream)
   (terpri stream)
   (format stream "~A, version ~A~2%" prog ver)
   (show-usage prog usage stream)
   (terpri stream)


@@ -795,8 +859,8 @@ (defun show-help (prog ver usage opts &optional (stream *standard-output*))
 
 (defun sanity-check-option-list (opts)
   "Check the option list OPTS for basic sanity.  Reused short and long option
 
 (defun sanity-check-option-list (opts)
   "Check the option list OPTS for basic sanity.  Reused short and long option

-names are diagnosed.  Maybe other problems will be reported later.  Returns a
-list of warning strings."
+   names are diagnosed.  Maybe other problems will be reported later.
+   Returns a list of warning strings."

   (let ((problems nil)
        (longs (make-hash-table :test #'equal))
        (shorts (make-hash-table)))
   (let ((problems nil)
        (longs (make-hash-table :test #'equal))
        (shorts (make-hash-table)))


@@ -815,4 +879,92 @@ (defun sanity-check-option-list (opts)
               shorts)
       problems)))
 
               shorts)
       problems)))
 

+;;;--------------------------------------------------------------------------
+;;; Full program descriptions.
+
+(defvar *help*)
+(defvar *version*)
+(defvar *usage*)
+
+(defun opt-help (arg)
+  (declare (ignore arg))
+  (show-help *program-name* *version* *usage* *options*)
+  (typecase *help*
+    (string (terpri) (write-string *help*))
+    ((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*)))))
+
+(defun define-program (&key
+                      program-name
+                      help
+                      version
+                      usage full-usage
+                      options)
+  "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)
+  "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))
+       (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 --------------------------------------------------
 ;;;----- That's all, folks --------------------------------------------------