lib/keyword.c (kw_parseempty): Use correct variable scanning `kwval' list.
[sod] / src / optparse.lisp
index 88f5bd7..a258699 100644 (file)
 ;;; 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.
 
-(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.")
   "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*))))
 
 ;;;--------------------------------------------------------------------------
 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)
-  (exit 1))
+  (uiop:quit 1))
 
 ;;;--------------------------------------------------------------------------
 ;;; The main option parser.
 (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
-               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
-               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.
 
-   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
 
    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.
 
-   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
-         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*)
-                      (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))
+                      (%options options)
                       (next args)
                       (negated-p (or negated-numeric-p
                                      (some #'opt-negated-tag
 
    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
-                 :stop -- stop parsing options, leaving the remaining
+                 `:stop' -- stop parsing options, leaving the remaining
                    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)
-               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!
 
-   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
-               nil."
+               `nil'."
   (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))
   (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)
    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)))
    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
       (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)))
                                              (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) #\-)
                             (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)
                      (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)
 (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
   (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))
             (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.
 
-   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
 
 (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
-            (fdefinition (get handler 'opthandler)))
+            (fdefinition (get handler 'opthandler-function)))
         loc arg args))
 
 ;;;--------------------------------------------------------------------------
 
 (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))
-  "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))
-  "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))
-  "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)))
   "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)
   "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))
 (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."
 (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
-       (setf (get ',name 'optmacro) (lambda ,args
-                                     ,@docs ,@decls
-                                     (block ,name ,@body)))
+       (setf (get ',name 'optmacro-function)
+              (lambda ,args
+                ,@docs ,@decls
+                (block ,name ,@body)))
        ',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."
-  (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)
-  "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.
 
                               ((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))))))
 ;;;--------------------------------------------------------------------------
 ;;; 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)
-  "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)
     (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))
-             (t
+             (doc
               (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)
-                  (format stream "~:[=~A~;[=~A]~]"
+                  (format stream
+                          "~:[~;[~]~:[~0@*~:[ ~;~]~*~;=~]~A~0@*~:[~;]~]"
                           (opt-arg-optional-p o)
+                          (opt-long-name o)
                           (opt-arg-name o)))
                 (write-string "  " stream)
                 (pprint-tab :line 30 1 stream)
 
 (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)))
 (export 'die-usage)
 (defun die-usage ()
   (do-usage *error-output*)
-  (exit 1))
+  (uiop:quit 1))
 
 (defun opt-help (arg)
   (declare (ignore arg))
     (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*)
-  (exit 0))
+  (uiop:quit 0))
 (defun opt-usage (arg)
   (declare (ignore arg))
   (do-usage)
-  (exit 0))
+  (uiop:quit 0))
 
 (export 'help-options)
 (defoptmacro help-options (&key (short-help #\h)
                       (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))