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 3b4b263..a258699 100644 (file)
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -155,18 +155,18 @@
 
    TAG          The value to be returned if this option is encountered.  If
                this is a function, instead, the function is called with the
 
    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


@@ -174,7 +174,7 @@
 
    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.
 
    Usually, one won't use `make-option', but use the `option' macro instead."
                text.
 
    Usually, one won't use `make-option', but use the `option' macro instead."


@@ -188,14 +188,15 @@
 (define-access-wrapper opt-documentation opt-%documentation)
 
 (export '(option-parser option-parser-p make-option-parser
 (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*)
 (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
                       ((:numericp numeric-p))
                       negated-numeric-p
                       long-only-p


@@ -214,25 +215,25 @@
 
    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)
   (%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)))


@@ -255,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)))


@@ -279,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


@@ -372,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)))


@@ -398,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) #\-)


@@ -420,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)


@@ -450,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)


@@ -476,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


@@ -544,11 +545,12 @@
 (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


@@ -612,14 +614,14 @@
 
 (export 'clear)
 (defopthandler clear (var) (&optional (value nil))
 
 (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).
 
   (setf var value))
 
 (export 'inc)
 (defopthandler inc (var) (&optional max (step 1))
   "Increments VAR by STEP (defaults to 1).
 

-   If MAX is not nil then VAR will not be made larger than MAX.  No errors
+   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))
    are signalled."
   (incf var step)
   (when (and max (>= var max))


@@ -629,8 +631,8 @@
 (defopthandler dec (var) (&optional min (step 1))
   "Decrements VAR by STEP (defaults to 1).
 
 (defopthandler dec (var) (&optional min (step 1))
   "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."
+   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)))


@@ -640,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)


@@ -655,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
-   or 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))


@@ -680,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."


@@ -733,7 +735,7 @@
 (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


@@ -759,80 +761,81 @@
     "Does the heavy lifting for parsing an option form.
 
    See the docstring for the `option' macro for details of the syntax."
     "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-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)))))))))
+    (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.
 


@@ -897,7 +900,7 @@
   (defun print-text (string
                     &optional (stream *standard-output*)
                     &key (start 0) (end nil))
   (defun print-text (string
                     &optional (stream *standard-output*)
                     &key (start 0) (end nil))

-    "Prints and line-breaks STRING to a pretty-printed STREAM.
+    "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
 
    The string is broken at whitespace and newlines in the obvious way.
    Stuff between square brackets is not broken: this makes usage messages


@@ -937,7 +940,7 @@
 
    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
 
    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."
+   `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)


@@ -1125,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))