lib/keyword.c (kw_parseempty): Use correct variable scanning `kwval' list.

[sod] / src / optparse.lisp

diff --git a/src/optparse.lisp b/src/optparse.lisp
index 88f5bd7..a258699 100644 (file)
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -23,32 +23,16 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 

-(cl:defpackage #:optparse
-  (:use #:common-lisp #:cl-launch #:sod-utilities))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (handler-bind ((warning #'muffle-warning))
+    (cl:defpackage #:optparse
+      (:use #:common-lisp #:sod-utilities))))

 
 (cl:in-package #:optparse)
 
 ;;;--------------------------------------------------------------------------
 ;;; Program environment things.
 
 
 (cl:in-package #:optparse)
 
 ;;;--------------------------------------------------------------------------
 ;;; Program environment things.
 

-(export 'exit)
-(defun exit (&optional (code 0) &key abrupt)
-  "End program, returning CODE to the caller."
-  (declare (type (unsigned-byte 32) code))
-  #+sbcl (sb-ext:exit :code code :abort abrupt)
-  #+cmu (if abrupt
-           (unix::void-syscall ("_exit" c-call:int) code)
-           (ext:quit code))
-  #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
-  #+ecl (ext:quit code)
-
-  #-(or sbcl cmu clisp ecl)
-  (progn
-    (unless (zerop code)
-      (format *error-output*
-             "~&Exiting unsuccessfully with code ~D.~%" code))
-    (abort)))
-

 (export '(*program-name* *command-line*))
 (defvar *program-name* "<unknown>"
   "Program name, as retrieved from the command line.")
 (export '(*program-name* *command-line*))
 (defvar *program-name* "<unknown>"
   "Program name, as retrieved from the command line.")


@@ -60,16 +44,7 @@
   "Retrieve command-line arguments.
 
    Set `*command-line*' and `*program-name*'."
   "Retrieve command-line arguments.
 
    Set `*command-line*' and `*program-name*'."

-
-  (setf *command-line*
-       (cons (or (getenv "CL_LAUNCH_FILE")
-                 #+sbcl (car sb-ext:*posix-argv*)
-                 #+cmu (car ext:*command-line-strings*)
-                 #+clisp (aref (ext:argv) 0)
-                 #+ecl (ext:argv 0)
-                 #-(or sbcl cmu clisp ecl) "sod")
-             *arguments*)
-
+  (setf *command-line* (cons (uiop:argv0) uiop:*command-line-arguments*)

        *program-name* (pathname-name (car *command-line*))))
 
 ;;;--------------------------------------------------------------------------
        *program-name* (pathname-name (car *command-line*))))
 
 ;;;--------------------------------------------------------------------------


@@ -124,7 +99,7 @@
 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)
 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)

-  (exit 1))
+  (uiop:quit 1))

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


@@ -136,48 +111,62 @@
 (export '(option optionp make-option
          opt-short-name opt-long-name opt-tag opt-negated-tag
          opt-arg-name opt-arg-optional-p opt-documentation))
 (export '(option optionp make-option
          opt-short-name opt-long-name opt-tag opt-negated-tag
          opt-arg-name opt-arg-optional-p opt-documentation))

-(defstruct (option
-            (:predicate optionp)
-            (:conc-name opt-)
-            (:print-function
-             (lambda (o s k)
-               (declare (ignore k))
-               (print-unreadable-object (o s :type t)
-                 (format s "~@[-~C, ~]~@[--~A~]~
-                            ~*~@[~2:*~:[=~A~;[=~A]~]~]~
-                            ~@[ ~S~]"
-                         (opt-short-name o)
-                         (opt-long-name o)
-                         (opt-arg-optional-p o)
-                         (opt-arg-name o)
-                         (opt-documentation o)))))
-            (:constructor %make-option)
-            (:constructor make-option
-                (long-name short-name
-                 &optional arg-name
-                 &key (tag (intern (string-upcase long-name) :keyword))
-                      negated-tag
-                      arg-optional-p
-                      doc (documentation doc))))
-  "Describes a command-line option.  Slots:
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
+  (defstruct (option
+              (:predicate optionp)
+              (:conc-name opt-)
+              (:print-function
+               (lambda (o s k)
+                 (declare (ignore k))
+                 (print-unreadable-object (o s :type t)
+                   (format s "~*~:[~2:*~:[~3*~@[~S~]~
+                                          ~;~
+                                          ~:*-~C~
+                                          ~2*~@[~:*~:[ ~A~;[~A]~]~]~
+                                          ~@[ ~S~]~]~
+                                   ~;~
+                                   ~2:*~@[-~C, ~]--~A~
+                                   ~*~@[~:*~:[=~A~;[=~A]~]~]~
+                                   ~@[ ~S~]~]"
+                           (opt-short-name o)
+                           (opt-long-name o)
+                           (opt-arg-optional-p o)
+                           (opt-arg-name o)
+                           (opt-%documentation o)))))
+              (:constructor %make-option
+                            (&key long-name tag negated-tag short-name
+                                  arg-name arg-optional-p documentation
+                                  &aux (%documentation documentation)))
+              (:constructor make-option
+                            (long-name short-name
+                                       &optional arg-name
+                                       &key (tag (intern (string-upcase
+                                                          long-name)
+                                                         :keyword))
+                                       negated-tag
+                                       arg-optional-p
+                                       doc (documentation doc)
+                                       &aux (%documentation
+                                             documentation))))
+    "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.
 
    TAG          The value to be returned if this option is encountered.  If
                this is a function, instead, the function is called with the
 
    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.
+               option's argument or `nil'.

 
    NEGATED-TAG  As for TAG, but used if the negated form of the option is
 
    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
+               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.
 
                negated.
 
    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
 
    ARG-OPTIONAL-P
                If non-nil, the option's argument is optional.  This is


@@ -185,31 +174,34 @@
 
    DOCUMENTATION
                The help text for this option.  It is automatically line-
 
    DOCUMENTATION
                The help text for this option.  It is automatically line-

-               wrapped.  If nil, the option is omitted from the help
+               wrapped.  If `nil', the option is omitted from the help

                text.
 
                text.
 

-   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)
-  (short-name nil :type (or null character))
-  (arg-name nil :type (or null string))
-  (arg-optional-p nil :type t)
-  (documentation nil :type (or null string)))
+   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)
+    (short-name nil :type (or null character))
+    (arg-name nil :type (or null string))
+    (arg-optional-p nil :type t)
+    (%documentation nil :type (or null string))))
+(define-access-wrapper opt-documentation opt-%documentation)

 
 (export '(option-parser option-parser-p make-option-parser
 
 (export '(option-parser option-parser-p make-option-parser

-         op-options op-non-option op-long-only-p op-numeric-p
-         op-negated-numeric-p op-negated-p))
+         op-options op-non-option op-long-only-p
+         op-numeric-p op-negated-numeric-p op-negated-p))

 (defstruct (option-parser
             (:conc-name op-)
             (:constructor make-option-parser
                 (&key ((:args argstmp) (cdr *command-line*))
                       (options *options*)
 (defstruct (option-parser
             (:conc-name op-)
             (:constructor make-option-parser
                 (&key ((:args argstmp) (cdr *command-line*))
                       (options *options*)

-                      (non-option :skip)
+                      (non-option (if (uiop:getenv "POSIXLY_CORRECT") :stop
+                                      :skip))

                       ((:numericp numeric-p))
                       negated-numeric-p
                       long-only-p
                  &aux (args (cons nil argstmp))
                       ((:numericp numeric-p))
                       negated-numeric-p
                       long-only-p
                  &aux (args (cons nil argstmp))

+                      (%options options)

                       (next args)
                       (negated-p (or negated-numeric-p
                                      (some #'opt-negated-tag
                       (next args)
                       (negated-p (or negated-numeric-p
                                      (some #'opt-negated-tag


@@ -223,27 +215,27 @@
 
    NON-OPTION   Behaviour when encountering a non-option argument.  The
                default is :skip.  Allowable values are:
 
    NON-OPTION   Behaviour when encountering a non-option argument.  The
                default is :skip.  Allowable values are:

-                 :skip -- pretend that it appeared after the option
+                 `:skip' -- pretend that it appeared after the option

                    arguments; this is the default behaviour of GNU getopt
                    arguments; this is the default behaviour of GNU getopt

-                 :stop -- stop parsing options, leaving the remaining
+                 `:stop' -- stop parsing options, leaving the remaining

                    command line unparsed
                    command line unparsed

-                 :return -- return :non-option and the argument word
+                 `:return' -- return :non-option and the argument word

 
    NUMERIC-P    Non-nil tag (as for options) if numeric options (e.g., -43)
 
    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.)
+               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-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
                long options to begin with a single dash.  Short options are
                still allowed, and may be cuddled as usual.  The default is

-               nil."
+               `nil'."

   (args nil :type list)
   (args nil :type list)

-  (options nil :type list)
+  (%options nil :type list)

   (non-option :skip :type (or function (member :skip :stop :return)))
   (next nil :type list)
   (short-opt nil :type (or null string))
   (non-option :skip :type (or function (member :skip :stop :return)))
   (next nil :type list)
   (short-opt nil :type (or null string))


@@ -253,6 +245,7 @@
   (numeric-p nil :type t)
   (negated-numeric-p nil :type t)
   (negated-p nil :type t))
   (numeric-p nil :type t)
   (negated-numeric-p nil :type t)
   (negated-p nil :type t))

+(define-access-wrapper op-options op-%options)

 
 (export 'option-parse-error)
 (define-condition option-parse-error (error simple-condition)
 
 (export 'option-parse-error)
 (define-condition option-parse-error (error simple-condition)


@@ -263,7 +256,7 @@
    Probably not that useful."))
 
 (defun option-parse-error (msg &rest args)
    Probably not that useful."))
 
 (defun option-parse-error (msg &rest args)

-  "Signal an option-parse-error with the given message and arguments."
+  "Signal an `option-parse-error' with the given message and arguments."

   (error (make-condition 'option-parse-error
                         :format-control msg
                         :format-arguments args)))
   (error (make-condition 'option-parse-error
                         :format-control msg
                         :format-arguments args)))


@@ -287,10 +280,10 @@
    This is 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
    This is 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
+   `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.  See `option-parse-return' for a way of doing
    `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.  See `option-parse-return' for a way of doing


@@ -380,7 +373,7 @@
       (loop
        (with-simple-restart (skip-option "Skip this bogus option.")
          (cond
       (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)))
            ;; We're embroiled in short options: handle them.
            ((op-short-opt op)
             (if (>= (op-short-opt-index op) (length (op-short-opt op)))


@@ -406,16 +399,16 @@
                                              (subseq str i)
                                            (setf (op-short-opt op)
                                                  nil))))))))
                                              (subseq str i)
                                            (setf (op-short-opt op)
                                                  nil))))))))

-           ;;
+

            ;; End of the list.  Say we've finished.
            ((not (more-args-p))
             (finished))
            ;; End of the list.  Say we've finished.
            ((not (more-args-p))
             (finished))

-           ;;
+

            ;; Process the next option.
            (t
             (let ((arg (peek-arg)))
               (cond
            ;; 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) #\-)
                 ;; Non-option.  Decide what to do.
                 ((or (<= (length arg) 1)
                      (and (char/= (char arg 0) #\-)


@@ -428,12 +421,12 @@
                             (ret :non-option arg))
                    (t (eat-arg)
                       (funcall (op-non-option op) arg))))
                             (ret :non-option arg))
                    (t (eat-arg)
                       (funcall (op-non-option op) arg))))

-                ;;
+

                 ;; Double-hyphen.  Stop right now.
                 ((string= arg "--")
                  (eat-arg)
                  (finished))
                 ;; 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)
                 ;; Numbers.  Check these before long options, since `--43'
                 ;; is not a long option.
                 ((and (op-numeric-p op)


@@ -458,14 +451,14 @@
                      (if (functionp how)
                          (funcall how num)
                          (ret (if negp :negated-numeric :numeric) num)))))
                      (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))
                 ;; 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)
                 ;; Short options.  All that's left.
                 (t
                  (eat-arg)


@@ -484,8 +477,8 @@
 (defmacro option-parse-try (&body body)
   "Report errors encountered while parsing options, and try to continue.
 
 (defmacro option-parse-try (&body body)
   "Report errors encountered while parsing options, and try to continue.
 

-   Also establishes a restart `stop-parsing'.  Returns t if parsing completed
-   successfully, or nil if errors occurred."
+   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


@@ -531,7 +524,7 @@
   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
     (multiple-value-bind (docs decls body) (parse-body body)
       `(progn
   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
     (multiple-value-bind (docs decls body) (parse-body body)
       `(progn

-        (setf (get ',name 'opthandler) ',func)
+        (setf (get ',name 'opthandler-function) ',func)

         (defun ,func (,var ,arg ,@args)
           ,@docs ,@decls
           (declare (ignorable ,arg))
         (defun ,func (,var ,arg ,@args)
           ,@docs ,@decls
           (declare (ignorable ,arg))


@@ -539,14 +532,25 @@
             (block ,name ,@body)))
         ',name))))
 
             (block ,name ,@body)))
         ',name))))
 

+(export 'opthandler)
+(defmethod documentation ((symbol symbol) (doc-type (eql 'opthandler)))
+  (let ((func (get symbol 'opthandler-function)))
+    (and func (documentation func 'function))))
+(defmethod (setf documentation)
+    (string (symbol symbol) (doc-type (eql 'opthandler)))
+  (let ((func (get symbol 'optmacro-function)))
+    (unless func (error "No option handler defined with name `~S'." symbol))
+    (setf (documentation func 'function) string)))
+

 (defun parse-c-integer (string &key radix (start 0) end)
   "Parse (a substring of) STRING according to the standard C rules.
 
 (defun parse-c-integer (string &key radix (start 0) end)
   "Parse (a substring of) STRING 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."
+   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


@@ -592,10 +596,12 @@
 
 (export 'invoke-option-handler)
 (defun invoke-option-handler (handler loc arg args)
 
 (export 'invoke-option-handler)
 (defun invoke-option-handler (handler loc arg args)

-  "Call HANDLER, giving it LOC to update, the option-argument ARG, and the
-   remaining ARGS."
+  "Call an option HANDLER.
+
+   The handler is invoked to update the locative LOC, given an
+   option-argument ARG, and the remaining ARGS."

   (apply (if (functionp handler) handler
   (apply (if (functionp handler) handler

-            (fdefinition (get handler 'opthandler)))
+            (fdefinition (get handler 'opthandler-function)))

         loc arg args))
 
 ;;;--------------------------------------------------------------------------
         loc arg args))
 
 ;;;--------------------------------------------------------------------------


@@ -603,26 +609,30 @@
 
 (export 'set)
 (defopthandler set (var) (&optional (value t))
 
 (export 'set)
 (defopthandler set (var) (&optional (value t))

-  "Sets VAR to VALUE; defaults to t."
+  "Sets VAR to VALUE; defaults to `t'."

   (setf var value))
 
 (export 'clear)
 (defopthandler clear (var) (&optional (value nil))
   (setf var value))
 
 (export 'clear)
 (defopthandler clear (var) (&optional (value nil))

-  "Sets VAR to VALUE; defaults to nil."
+  "Sets VAR to VALUE; defaults to `nil'."

   (setf var value))
 
 (export 'inc)
 (defopthandler inc (var) (&optional max (step 1))
   (setf var value))
 
 (export 'inc)
 (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."
+  "Increments VAR by STEP (defaults to 1).
+
+   If MAX is not `nil' then VAR will not be made larger than MAX.  No errors
+   are signalled."

   (incf var step)
   (when (and max (>= var max))
     (setf var max)))
 
 (export 'dec)
 (defopthandler dec (var) (&optional min (step 1))
   (incf var step)
   (when (and max (>= var max))
     (setf var max)))
 
 (export 'dec)
 (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."
+  "Decrements VAR by STEP (defaults to 1).
+
+   If MIN is not `nil', then VAR will not be made smaller than MIN.  No
+   errors are signalled."

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


@@ -632,7 +642,7 @@
   "Stores in VAR the Lisp object found by reading the ARG.
 
    Evaluation is forbidden while reading ARG.  If there is an error during
   "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."
+   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)


@@ -647,10 +657,10 @@
   "Stores in VAR the integer read from the ARG.
 
    Integers are parsed according to C rules, which is normal in Unix; the
   "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)."
+   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 or 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))


@@ -672,7 +682,7 @@
 (defopthandler keyword (var arg) (&optional (valid t))
   "Converts ARG into a keyword.
 
 (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
+   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."
    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."


@@ -725,94 +735,107 @@
 (defmacro defoptmacro (name args &body body)
   "Defines an option macro NAME.
 
 (defmacro defoptmacro (name args &body body)
   "Defines an option macro NAME.
 

-   Option macros should produce a list of expressions producing one option
+   Option macros should produce a list of expressions producing one `option'

    structure each."
   (multiple-value-bind (docs decls body) (parse-body body)
     `(progn
    structure each."
   (multiple-value-bind (docs decls body) (parse-body body)
     `(progn

-       (setf (get ',name 'optmacro) (lambda ,args
-                                     ,@docs ,@decls
-                                     (block ,name ,@body)))
+       (setf (get ',name 'optmacro-function)
+              (lambda ,args
+                ,@docs ,@decls
+                (block ,name ,@body)))

        ',name)))
 
        ',name)))
 

+(export 'optmacro)
+(defmethod documentation ((symbol symbol) (doc-type (eql 'optmacro)))
+  (let ((func (get symbol 'optmacro-function)))
+    (and func (documentation func t))))
+(defmethod (setf documentation)
+    (string (symbol symbol) (doc-type (eql 'optmacro)))
+  (let ((func (get symbol 'optmacro-function)))
+    (unless func (error "No option macro defined with name `~S'." symbol))
+    (setf (documentation func t) string)))
+

 (export 'parse-option-form)
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (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."
 (export 'parse-option-form)
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (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."

-  (flet ((doc (form)
-          (cond ((stringp form) form)
-                ((null (cdr form)) (car form))
-                (t `(format nil ,@form))))
-        (docp (form)
-          (or (stringp form)
-              (and (consp form)
-                   (stringp (car form))))))
-    (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)
-                       (: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))
-                       (: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)))))))))
+    (flet ((doc (form)
+            (cond ((stringp form) form)
+                  ((null (cdr form)) (car form))
+                  (t `(format nil ,@form))))
+          (docp (form)
+            (or (stringp form)
+                (and (consp form)
+                     (stringp (car form))))))
+      (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)
+                         (: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))
+                         (:doc (setf doc (doc (cdr f))))
+                         (t (let ((handler (get (car f)
+                                                'opthandler-function)))
+                              (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)))))))))

 
 (export 'options)
 (defmacro options (&rest optlist)
 
 (export 'options)
 (defmacro options (&rest optlist)

-  "More convenient way of initializing options.  The OPTLIST is a list of
-   OPTFORMS.  Each OPTFORM is one of the following:
+  "A more convenient way of initializing options.
+
+   The OPTLIST is a list of OPTFORMS.  Each OPTFORM is one of the following:

 
    STRING      A banner to print.
 
 
    STRING      A banner to print.
 


@@ -864,7 +887,7 @@
                               ((and (consp form) (symbolp (car form)))
                                (values (car form) (cdr form)))
                               (t (values nil nil)))
                               ((and (consp form) (symbolp (car form)))
                                (values (car form) (cdr form)))
                               (t (values nil nil)))

-                      (let ((macro (and sym (get sym 'optmacro))))
+                      (let ((macro (and sym (get sym 'optmacro-function))))

                         (if macro
                             (apply macro args)
                             (list (parse-option-form form))))))
                         (if macro
                             (apply macro args)
                             (list (parse-option-form form))))))


@@ -873,48 +896,51 @@
 ;;;--------------------------------------------------------------------------
 ;;; Support stuff for help and usage messages.
 
 ;;;--------------------------------------------------------------------------
 ;;; Support stuff for help and usage messages.
 

-(defun print-text (string
-                  &optional
-                  (stream *standard-output*)
-                  &key
-                  (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."
-  (let ((i start)
-       (nest 0)
-       (splitp nil))
-    (flet ((emit ()
-            (write-string string stream :start start :end i)
-            (setf start i)))
-      (unless end (setf end (length string)))
-      (loop
-        (unless (< i end)
-          (emit)
-          (return))
-        (let ((ch (char string i)))
-          (cond ((char= ch #\newline)
-                 (emit)
-                 (incf start)
-                 (pprint-newline :mandatory stream))
-                ((whitespace-char-p ch)
-                 (when (zerop nest)
-                   (setf splitp t)))
-                (t
-                 (when splitp
-                   (emit)
-                   (pprint-newline :fill stream))
-                 (setf splitp nil)
-                 (case ch
-                   (#\[ (incf nest))
-                   (#\] (when (plusp nest) (decf nest))))))
-          (incf i))))))
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
+  (defun print-text (string
+                    &optional (stream *standard-output*)
+                    &key (start 0) (end nil))
+    "Print and line-break STRING to a pretty-printed STREAM.
+
+   The string is broken at whitespace and 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))
+      (flet ((emit ()
+              (write-string string stream :start start :end i)
+              (setf start i)))
+       (unless end (setf end (length string)))
+       (loop
+         (unless (< i end)
+           (emit)
+           (return))
+         (let ((ch (char string i)))
+           (cond ((char= ch #\newline)
+                  (emit)
+                  (incf start)
+                  (pprint-newline :mandatory stream))
+                 ((whitespace-char-p ch)
+                  (when (zerop nest)
+                    (setf splitp t)))
+                 (t
+                  (when splitp
+                    (emit)
+                    (pprint-newline :fill stream))
+                  (setf splitp nil)
+                  (case ch
+                    (#\[ (incf nest))
+                    (#\] (when (plusp nest) (decf nest))))))
+           (incf i)))))))

 
 (export 'simple-usage)
 (defun simple-usage (opts &optional mandatory-args)
 
 (export 'simple-usage)
 (defun simple-usage (opts &optional mandatory-args)

-  "Build a simple usage list from a list of options, and (optionally)
-   mandatory argument names."
+  "Build a simple usage list.
+
+   The usage list is constructed from a list OPTS of `option' values, and
+   a list MANDATORY-ARGS of mandatory argument names; the latter defaults to
+   `nil' if omitted."

   (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)


@@ -978,22 +1004,25 @@
     (dolist (o opts)
       (let ((doc (opt-documentation o)))
        (cond ((not o))
     (dolist (o opts)
       (let ((doc (opt-documentation o)))
        (cond ((not o))

-             ((not (opt-long-name o))
+             ((not (or (opt-short-name o)
+                       (opt-long-name o)))

               (when newlinep
                 (terpri stream)
                 (setf newlinep nil))
               (pprint-logical-block (stream nil)
                 (print-text doc stream))
               (terpri stream))
               (when newlinep
                 (terpri stream)
                 (setf newlinep nil))
               (pprint-logical-block (stream nil)
                 (print-text doc stream))
               (terpri stream))

-             (t
+             (doc

               (setf newlinep t)
               (pprint-logical-block (stream nil :prefix "  ")
               (setf newlinep t)
               (pprint-logical-block (stream nil :prefix "  ")

-                (format stream "~:[   ~;-~:*~C,~] --~A"
+                (format stream "~:[   ~;-~:*~C~:[~;,~]~:*~]~@[ --~A~]"

                         (opt-short-name o)
                         (opt-long-name o))
                 (when (opt-arg-name o)
                         (opt-short-name o)
                         (opt-long-name o))
                 (when (opt-arg-name o)

-                  (format stream "~:[=~A~;[=~A]~]"
+                  (format stream
+                          "~:[~;[~]~:[~0@*~:[ ~;~]~*~;=~]~A~0@*~:[~;]~]"

                           (opt-arg-optional-p o)
                           (opt-arg-optional-p o)

+                          (opt-long-name o)

                           (opt-arg-name o)))
                 (write-string "  " stream)
                 (pprint-tab :line 30 1 stream)
                           (opt-arg-name o)))
                 (write-string "  " stream)
                 (pprint-tab :line 30 1 stream)


@@ -1017,9 +1046,10 @@
 
 (export 'sanity-check-option-list)
 (defun sanity-check-option-list (opts)
 
 (export 'sanity-check-option-list)
 (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."
+  "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."

   (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)))


@@ -1053,7 +1083,7 @@
 (export 'die-usage)
 (defun die-usage ()
   (do-usage *error-output*)
 (export 'die-usage)
 (defun die-usage ()
   (do-usage *error-output*)

-  (exit 1))
+  (uiop:quit 1))

 
 (defun opt-help (arg)
   (declare (ignore arg))
 
 (defun opt-help (arg)
   (declare (ignore arg))


@@ -1063,15 +1093,15 @@
     (null nil)
     ((or function symbol) (terpri) (funcall *help*)))
   (format t "~&")
     (null nil)
     ((or function symbol) (terpri) (funcall *help*)))
   (format t "~&")

-  (exit 0))
+  (uiop:quit 0))

 (defun opt-version (arg)
   (declare (ignore arg))
   (format t "~A, version ~A~%" *program-name* *version*)
 (defun opt-version (arg)
   (declare (ignore arg))
   (format t "~A, version ~A~%" *program-name* *version*)

-  (exit 0))
+  (uiop:quit 0))

 (defun opt-usage (arg)
   (declare (ignore arg))
   (do-usage)
 (defun opt-usage (arg)
   (declare (ignore arg))
   (do-usage)

-  (exit 0))
+  (uiop:quit 0))

 
 (export 'help-options)
 (defoptmacro help-options (&key (short-help #\h)
 
 (export 'help-options)
 (defoptmacro help-options (&key (short-help #\h)


@@ -1098,8 +1128,15 @@
                       (usage nil usagep)
                       (full-usage nil fullp)
                       (options nil optsp))
                       (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."
+  "Sets up all the required things a program needs to have to parse options.
+
+   This is a simple shorthand for setting `*program-name*', `*help*',
+   `*version*', `*options*', and `*usage*' from the corresponding arguments.
+   If an argument is not given then the corresponding variable is left alone.
+
+   The USAGE argument should be a list of mandatory argument names to pass to
+   `simple-usage'; FULL-USAGE should be a complete usage-token list.  An
+   error will be signalled if both USAGE and FULL-USAGE are provided."

   (when progp (setf *program-name* program-name))
   (when helpp (setf *help* help))
   (when versionp (setf *version* version))
   (when progp (setf *program-name* program-name))
   (when helpp (setf *help* help))
   (when versionp (setf *version* version))