;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
-;;;
+;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
-;;;
+;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#:op-negated-numeric-p #:op-negated-p
#:option-parse-error
#:option-parse-remainder #:option-parse-next #:option-parse-try
- #:with-unix-error-reporting
+ #:with-unix-error-reporting #:option-parse-return
#:defopthandler #:invoke-option-handler
#:set #:clear #:inc #:dec #:read #:int #:string
#:keyword #:list
#:simple-usage #:show-usage #:show-version #:show-help
#:sanity-check-option-list
#:*help* #:*version* #:*usage* #:*options*
- #:do-options #:help-opts #:define-program #:do-usage #:die-usage))
+ #:do-options #:help-options
+ #:define-program #:do-usage #:die-usage))
(in-package #:optparse)
;;;--------------------------------------------------------------------------
;;; The main option parser.
-(defvar *options*)
+(defvar *options* nil)
(defstruct (option (:predicate optionp)
(:conc-name opt-)
NEGATED-TAG As for TAG, but used if the negated form of the option is
found. If this is nil (the default), the option cannot be
- negated.
+ negated.
SHORT-NAME The option's short name. This must be a single character, or
nil if the option has no short name.
"Returns the unparsed remainder of the command line."
(cdr (op-args op)))
+(defun option-parse-return (tag &optional argument)
+ "Should be called from an option handler: forces a return from the
+ immediately enclosing `option-parse-next' with the given TAG and
+ ARGUMENT."
+ (throw 'option-parse-return (values tag argument)))
+
(defun option-parse-next (op)
"The main option-parsing function. OP is an option-parser object,
initialized appropriately. Returns two values, OPT and ARG: OPT is the
argument. It is safe for tag functions to throw out of option-parse-next,
if they desparately need to. (This is the only way to actually get
option-parse-next to return a function value, should that be what you
- want.)
+ want. See `option-parse-return' for a way of doing this.)
While option-parse-next is running, there is a restart `skip-option' which
moves on to the next option. Error handlers should use this to resume
after parsing errors."
- (loop
- (labels ((ret (opt &optional arg)
- (return-from option-parse-next (values opt arg)))
- (finished ()
- (setf (op-next op) nil)
- (ret nil nil))
- (peek-arg ()
- (cadr (op-next op)))
- (more-args-p ()
- (and (op-next op)
- (cdr (op-next op))))
- (skip-arg ()
- (setf (op-next op) (cdr (op-next op))))
- (eat-arg ()
- (setf (cdr (op-next op)) (cddr (op-next op))))
- (get-arg ()
- (prog1 (peek-arg) (eat-arg)))
- (process-option (o name negp &key arg argfunc)
- (cond ((not (opt-arg-name o))
- (when arg
- (option-parse-error
- "Option `~A' does not accept arguments"
- name)))
- (arg)
- (argfunc
- (setf arg (funcall argfunc)))
- ((opt-arg-optional-p o))
- ((more-args-p)
- (setf arg (get-arg)))
- (t
- (option-parse-error "Option `~A' requires an argument"
- name)))
- (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
- (if (functionp how)
- (funcall how arg)
- (ret how arg))))
- (process-long-option (arg start negp)
- (when (and (not negp)
- (op-negated-p op)
- (> (length arg) (+ start 3))
- (string= arg "no-"
- :start1 start :end1 (+ start 3)))
- (incf start 3)
- (setf negp t))
- (let* ((matches nil)
- (eqpos (position #\= arg :start start))
- (len (or eqpos (length arg)))
- (optname (subseq arg 0 len))
- (len-2 (- len start)))
- (dolist (o (op-options op))
- (cond ((or (not (stringp (opt-long-name o)))
- (and negp (not (opt-negated-tag o)))
- (< (length (opt-long-name o)) len-2)
- (string/= optname (opt-long-name o)
- :start1 start :end2 len-2)))
- ((= (length (opt-long-name o)) len-2)
- (setf matches (list o))
- (return))
- (t
- (push o matches))))
- (cond ((null matches)
- (option-parse-error "Unknown option `~A'" optname))
- ((cdr matches)
- (option-parse-error
- "~
+ (labels ((ret (opt &optional arg)
+ (return-from option-parse-next (values opt arg)))
+ (finished ()
+ (setf (op-next op) nil)
+ (ret nil nil))
+ (peek-arg ()
+ (cadr (op-next op)))
+ (more-args-p ()
+ (and (op-next op)
+ (cdr (op-next op))))
+ (skip-arg ()
+ (setf (op-next op) (cdr (op-next op))))
+ (eat-arg ()
+ (setf (cdr (op-next op)) (cddr (op-next op))))
+ (get-arg ()
+ (prog1 (peek-arg) (eat-arg)))
+ (process-option (o name negp &key arg argfunc)
+ (cond ((not (opt-arg-name o))
+ (when arg
+ (option-parse-error
+ "Option `~A' does not accept arguments"
+ name)))
+ (arg)
+ (argfunc
+ (setf arg (funcall argfunc)))
+ ((opt-arg-optional-p o))
+ ((more-args-p)
+ (setf arg (get-arg)))
+ (t
+ (option-parse-error "Option `~A' requires an argument"
+ name)))
+ (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
+ (if (functionp how)
+ (funcall how arg)
+ (ret how arg))))
+ (process-long-option (arg start negp)
+ (when (and (not negp)
+ (op-negated-p op)
+ (> (length arg) (+ start 3))
+ (string= arg "no-"
+ :start1 start :end1 (+ start 3)))
+ (incf start 3)
+ (setf negp t))
+ (let* ((matches nil)
+ (eqpos (position #\= arg :start start))
+ (len (or eqpos (length arg)))
+ (optname (subseq arg 0 len))
+ (len-2 (- len start)))
+ (dolist (o (op-options op))
+ (cond ((or (not (stringp (opt-long-name o)))
+ (and negp (not (opt-negated-tag o)))
+ (< (length (opt-long-name o)) len-2)
+ (string/= optname (opt-long-name o)
+ :start1 start :end2 len-2)))
+ ((= (length (opt-long-name o)) len-2)
+ (setf matches (list o))
+ (return))
+ (t
+ (push o matches))))
+ (cond ((null matches)
+ (option-parse-error "Unknown option `~A'" optname))
+ ((cdr matches)
+ (option-parse-error
+ "~
Ambiguous long option `~A' -- could be any of:~{~% --~A~}"
- optname
- (mapcar #'opt-long-name matches))))
- (process-option (car matches)
- optname
- negp
- :arg (and eqpos
- (subseq arg (1+ eqpos)))))))
- (with-simple-restart (skip-option "Skip this bogus option.")
- (cond
- ;;
- ;; We're embroiled in short options: handle them.
- ((op-short-opt op)
- (if (>= (op-short-opt-index op) (length (op-short-opt op)))
- (setf (op-short-opt op) nil)
- (let* ((str (op-short-opt op))
- (i (op-short-opt-index op))
- (ch (char str i))
- (negp (op-short-opt-neg-p op))
- (name (format nil "~C~A" (if negp #\+ #\-) ch))
- (o (find ch (op-options op) :key #'opt-short-name)))
- (incf i)
- (setf (op-short-opt-index op) i)
- (when (or (not o)
- (and negp (not (opt-negated-tag o))))
- (option-parse-error "Unknown option `~A'" name))
- (process-option o
- name
- negp
- :argfunc
- (and (< i (length str))
- (lambda ()
- (prog1
- (subseq str i)
- (setf (op-short-opt op)
- nil))))))))
- ;;
- ;; End of the list. Say we've finished.
- ((not (more-args-p))
- (finished))
- ;;
- ;; Process the next option.
- (t
- (let ((arg (peek-arg)))
- (cond
- ;;
- ;; Non-option. Decide what to do.
- ((or (<= (length arg) 1)
- (and (char/= (char arg 0) #\-)
- (or (char/= (char arg 0) #\+)
- (not (op-negated-p op)))))
- (case (op-non-option op)
- (:skip (skip-arg))
- (:stop (finished))
- (:return (eat-arg)
- (ret :non-option arg))
- (t (eat-arg)
- (funcall (op-non-option op) arg))))
- ;;
- ;; Double-hyphen. Stop right now.
- ((string= arg "--")
- (eat-arg)
- (finished))
- ;;
- ;; Numbers. Check these before long options, since `--43' is
- ;; not a long option.
- ((and (op-numeric-p op)
- (or (char= (char arg 0) #\-)
- (op-negated-numeric-p op))
- (or (and (digit-char-p (char arg 1))
- (every #'digit-char-p (subseq arg 2)))
- (and (or (char= (char arg 1) #\-)
- (char= (char arg 1) #\+))
- (>= (length arg) 3)
- (digit-char-p (char arg 2))
- (every #'digit-char-p (subseq arg 3)))))
- (eat-arg)
- (let ((negp (char= (char arg 0) #\+))
- (num (parse-integer arg :start 1)))
- (when (and negp (eq (op-negated-numeric-p op) :-))
- (setf num (- num))
- (setf negp nil))
- (let ((how (if negp
- (op-negated-numeric-p op)
- (op-numeric-p op))))
- (if (functionp how)
- (funcall how num)
- (ret (if negp :negated-numeric :numeric) num)))))
- ;;
- ;; Long option. Find the matching option-spec and process
- ;; it.
- ((and (char= (char arg 0) #\-)
- (char= (char arg 1) #\-))
- (eat-arg)
- (process-long-option arg 2 nil))
- ;;
- ;; Short options. All that's left.
- (t
- (eat-arg)
- (let ((negp (char= (char arg 0) #\+))
- (ch (char arg 1)))
- (cond ((and (op-long-only-p op)
- (not (member ch (op-options op)
- :key #'opt-short-name)))
- (process-long-option arg 1 negp))
- (t
- (setf (op-short-opt op) arg
- (op-short-opt-index op) 1
- (op-short-opt-neg-p op) negp)))))))))))))
+ optname
+ (mapcar #'opt-long-name matches))))
+ (process-option (car matches)
+ optname
+ negp
+ :arg (and eqpos
+ (subseq arg (1+ eqpos)))))))
+ (catch 'option-parse-return
+ (loop
+ (with-simple-restart (skip-option "Skip this bogus option.")
+ (cond
+ ;;
+ ;; We're embroiled in short options: handle them.
+ ((op-short-opt op)
+ (if (>= (op-short-opt-index op) (length (op-short-opt op)))
+ (setf (op-short-opt op) nil)
+ (let* ((str (op-short-opt op))
+ (i (op-short-opt-index op))
+ (ch (char str i))
+ (negp (op-short-opt-neg-p op))
+ (name (format nil "~C~A" (if negp #\+ #\-) ch))
+ (o (find ch (op-options op) :key #'opt-short-name)))
+ (incf i)
+ (setf (op-short-opt-index op) i)
+ (when (or (not o)
+ (and negp (not (opt-negated-tag o))))
+ (option-parse-error "Unknown option `~A'" name))
+ (process-option o
+ name
+ negp
+ :argfunc
+ (and (< i (length str))
+ (lambda ()
+ (prog1
+ (subseq str i)
+ (setf (op-short-opt op)
+ nil))))))))
+ ;;
+ ;; End of the list. Say we've finished.
+ ((not (more-args-p))
+ (finished))
+ ;;
+ ;; Process the next option.
+ (t
+ (let ((arg (peek-arg)))
+ (cond
+ ;;
+ ;; Non-option. Decide what to do.
+ ((or (<= (length arg) 1)
+ (and (char/= (char arg 0) #\-)
+ (or (char/= (char arg 0) #\+)
+ (not (op-negated-p op)))))
+ (case (op-non-option op)
+ (:skip (skip-arg))
+ (:stop (finished))
+ (:return (eat-arg)
+ (ret :non-option arg))
+ (t (eat-arg)
+ (funcall (op-non-option op) arg))))
+ ;;
+ ;; Double-hyphen. Stop right now.
+ ((string= arg "--")
+ (eat-arg)
+ (finished))
+ ;;
+ ;; Numbers. Check these before long options, since `--43'
+ ;; is not a long option.
+ ((and (op-numeric-p op)
+ (or (char= (char arg 0) #\-)
+ (op-negated-numeric-p op))
+ (or (and (digit-char-p (char arg 1))
+ (every #'digit-char-p (subseq arg 2)))
+ (and (or (char= (char arg 1) #\-)
+ (char= (char arg 1) #\+))
+ (>= (length arg) 3)
+ (digit-char-p (char arg 2))
+ (every #'digit-char-p (subseq arg 3)))))
+ (eat-arg)
+ (let ((negp (char= (char arg 0) #\+))
+ (num (parse-integer arg :start 1)))
+ (when (and negp (eq (op-negated-numeric-p op) :-))
+ (setf num (- num))
+ (setf negp nil))
+ (let ((how (if negp
+ (op-negated-numeric-p op)
+ (op-numeric-p op))))
+ (if (functionp how)
+ (funcall how num)
+ (ret (if negp :negated-numeric :numeric) num)))))
+ ;;
+ ;; Long option. Find the matching option-spec and process
+ ;; it.
+ ((and (char= (char arg 0) #\-)
+ (char= (char arg 1) #\-))
+ (eat-arg)
+ (process-long-option arg 2 nil))
+ ;;
+ ;; Short options. All that's left.
+ (t
+ (eat-arg)
+ (let ((negp (char= (char arg 0) #\+))
+ (ch (char arg 1)))
+ (cond ((and (op-long-only-p op)
+ (not (member ch (op-options op)
+ :key #'opt-short-name)))
+ (process-long-option arg 1 negp))
+ (t
+ (setf (op-short-opt op) arg
+ (op-short-opt-index op) 1
+ (op-short-opt-neg-p op) negp))))))))))))))
(defmacro option-parse-try (&body body)
"Report errors encountered while parsing options, and continue struggling
on some parameters (the ARGS) and the value of an option-argument named
ARG."
(let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
- `(progn
- (setf (get ',name 'opthandler) ',func)
- (defun ,func (,var ,arg ,@args)
- (with-locatives ,var
- (declare (ignorable ,arg))
- ,@body))
- ',name)))
+ (with-parsed-body (body decls docs) body
+ `(progn
+ (setf (get ',name 'opthandler) ',func)
+ (defun ,func (,var ,arg ,@args)
+ ,@docs ,@decls
+ (with-locatives ,var
+ (declare (ignorable ,arg))
+ ,@body))
+ ',name))))
(defun parse-c-integer (string &key radix (start 0) end)
"Parse STRING, or at least the parts of it between START and END, according
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)))
+ (setf-default end (length string))
(labels ((simple (i r goodp sgn)
(multiple-value-bind
(a i)
"Stores ARG in VAR, just as it is."
(setf var arg))
-(defopthandler keyword (var arg) (&rest valid)
- (if (null valid)
- (setf var (intern (string-upcase arg) :keyword))
- (let ((matches nil)
- (guess (string-upcase arg))
- (len (length arg)))
- (dolist (k valid)
- (let* ((kn (symbol-name k))
- (klen (length kn)))
- (cond ((string= kn guess)
- (setf matches (list k))
- (return))
- ((and (< len klen)
- (string= guess kn :end2 len))
- (push k matches)))))
- (case (length matches)
- (0 (option-parse-error "Argument `~A' invalid: must be one of:~
- ~{~%~8T~(~A~)~}"
- arg valid))
- (1 (setf var (car matches)))
- (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
- ~{~%~8T~(~A~)~}"
- arg matches))))))
+(defopthandler keyword (var arg) (&optional (valid t))
+ "Converts ARG into a keyword. If VALID is t, then any ARG string is
+ acceptable: the argument is uppercased and interned in the keyword
+ package. If VALID is a list, then we ensure that ARG matches one of the
+ elements of the list; unambigious abbreviations are allowed."
+ (etypecase valid
+ ((member t)
+ (setf var (intern (string-upcase arg) :keyword)))
+ (list
+ (let ((matches nil)
+ (guess (string-upcase arg))
+ (len (length arg)))
+ (dolist (k valid)
+ (let* ((kn (symbol-name k))
+ (klen (length kn)))
+ (cond ((string= kn guess)
+ (setf matches (list k))
+ (return))
+ ((and (< len klen)
+ (string= guess kn :end2 len))
+ (push k matches)))))
+ (cond
+ ((null matches)
+ (option-parse-error "Argument `~A' invalid: must be one of:~
+ ~{~%~8T~(~A~)~}"
+ arg valid))
+ ((null (cdr matches))
+ (setf var (car matches)))
+ (t
+ (option-parse-error "Argument `~A' ambiguous: may be any of:~
+ ~{~%~8T~(~A~)~}"
+ arg matches)))))))
(defopthandler list (var arg) (&optional handler &rest handler-args)
"Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first,
(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))
STRING A banner to print.
SYMBOL or (SYMBOL STUFF...)
- If SYMBOL is an optform macro, the result of invoking it.
+ If SYMBOL is an optform macro, the result of invoking it.
(...) A full option-form. See below.
- Full option-forms are as follows.
+ Full option-forms are a list of the following kinds of items.
+
+ (:short-name CHAR)
+ (:long-name STRING)
+ (:arg STRING)
+ (:tag TAG)
+ (:negated-tag TAG)
+ (:doc STRING)
+ Set the appropriate slot of the option to the given value.
+ The argument is evaluated.
+
+ (:doc FORMAT-CONTROL ARGUMENTS...)
+ As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
- KEYWORD or FUNCTION
+ KEYWORD, (function ...), (lambda ...)
If no TAG is set yet, then as a TAG; otherwise as the
NEGATED-TAG.
and rationals, the item is converted to a string and squashed
to lower-case.
- CHARACTER The SHORT-NAME.
+ CHARACTER If no SHORT-NAME, then the SHORT-NAME.
STRING or (STRING STUFF...)
If no DOCUMENTATION set yet, then the DOCUMENTATION string,
- as for (:DOC STRING STUFF...)
+ as for (:doc STRING STUFF...)
- (:DOC STRING STUFF...)
- The DOCUMENATION string. With no STUFF, STRING is used as
- is;otherwise the documentation string is computed by (format
- nil STRING STUFF...).
-
- (:ARG NAME) Set the ARG-NAME.
-
- (:OPT-ARG NAME)
+ (:opt-arg NAME)
Set the ARG-NAME, and also set ARG-OPTIONAL-P.
(HANDLER VAR ARGS...)
If no TAG is set yet, attach the HANDLER to this option,
giving it ARGS. Otherwise, set the NEGATED-TAG."
+
`(list ,@(mapcan (lambda (form)
(multiple-value-bind
(sym args)
(flet ((emit ()
(write-string string stream :start start :end i)
(setf start i)))
- (unless end
- (setf end (length string)))
+ (setf-default end (length string))
(loop
(unless (< i end)
(emit)
(format stream "~{~A ~:_~}" (listify u)))
(pprint-newline :mandatory stream))))
-(defun show-help (prog ver usage opts &optional (stream *standard-output*))
- "Basic help-showing function. PROG is the program name, probably from
- *command-line-strings*. VER is the program's version number. USAGE is a
- list of the possible usages of the program, each of which may be a list of
- items to be supplied. OPTS is the list of supported options, as provided
- to the options parser. STREAM is the stream to write on."
- (format stream "~A, version ~A~2%" prog ver)
- (show-usage prog usage stream)
- (terpri stream)
+(defun show-options-help (opts &optional (stream *standard-output*))
+ "Write help for OPTS to the STREAM. This is the core of the `show-help'
+ function."
(let (newlinep)
(dolist (o opts)
(let ((doc (opt-documentation o)))
(print-text doc stream))
(terpri stream)))))))
+(defun show-help (prog ver usage opts &optional (stream *standard-output*))
+ "Basic help-showing function. PROG is the program name, probably from
+ *command-line-strings*. VER is the program's version number. USAGE is a
+ list of the possible usages of the program, each of which may be a list of
+ items to be supplied. OPTS is the list of supported options, as provided
+ to the options parser. STREAM is the stream to write on."
+ (format stream "~A, version ~A~2%" prog ver)
+ (show-usage prog usage stream)
+ (terpri stream)
+ (show-options-help opts stream))
+
(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.
;;;--------------------------------------------------------------------------
;;; Full program descriptions.
-(defvar *help*)
-(defvar *version*)
-(defvar *usage*)
+(defvar *help* nil)
+(defvar *version* "<unreleased>")
+(defvar *usage* nil)
+
+(defun do-usage (&optional (stream *standard-output*))
+ (show-usage *program-name* *usage* stream))
+
+(defun die-usage ()
+ (do-usage *error-output*)
+ (exit 1))
(defun opt-help (arg)
(declare (ignore arg))
(show-help *program-name* *version* *usage* *options*)
(typecase *help*
(string (terpri) (write-string *help*))
+ (null nil)
((or function symbol) (terpri) (funcall *help*)))
(format t "~&")
(exit 0))
-
(defun opt-version (arg)
(declare (ignore arg))
(format t "~A, version ~A~%" *program-name* *version*)
(exit 0))
-
-(defun do-usage (&optional (stream *standard-output*))
- (show-usage *program-name* *usage* stream))
-
-(defun die-usage ()
- (do-usage *error-output*)
- (exit 1))
-
(defun opt-usage (arg)
(declare (ignore arg))
(do-usage)
(exit 0))
-(defoptmacro help-opts (&key (short-help #\h)
- (short-version #\v)
- (short-usage #\u))
- (mapcar #'parse-option-form
- `("Help options"
- (,@(and short-help (list short-help))
- "help"
- #'opt-help
- "Show this help message.")
- (,@(and short-version (list short-version))
- "version"
- #'opt-version
- ("Show ~A's version number." *program-name*))
- (,@(and short-usage (list short-usage))
- "usage"
- #'opt-usage
- ("Show a very brief usage summary for ~A." *program-name*)))))
+(defoptmacro help-options (&key (short-help #\h)
+ (short-version #\v)
+ (short-usage #\u))
+ "Inserts a standard help options collection in an options list."
+ (flet ((shortform (char)
+ (and char (list char))))
+ (mapcar
+ #'parse-option-form
+ `("Help options"
+ (,@(shortform short-help) "help" #'opt-help
+ "Show this help message.")
+ (,@(shortform short-version) "version" #'opt-version
+ ("Show ~A's version number." *program-name*))
+ (,@(shortform short-usage) "usage" #'opt-usage
+ ("Show a very brief usage summary for ~A." *program-name*))))))
(defun define-program (&key
- program-name
- help
- version
- usage full-usage
- options)
+ (program-name nil progp)
+ (help nil helpp)
+ (version nil versionp)
+ (usage nil usagep)
+ (full-usage nil fullp)
+ (options nil optsp))
"Sets up all the required things a program needs to have to parse options
and respond to them properly."
- (when program-name (setf *program-name* program-name))
- (when help (setf *help* help))
- (when version (setf *version* version))
- (when options (setf *options* options))
- (cond ((and usage full-usage) (error "conflicting options"))
- (usage (setf *usage* (simple-usage *options* usage)))
- (full-usage (setf *usage* full-usage))))
-
-(defmacro do-options ((&key (parser '(make-option-parser))) &body clauses)
+ (when progp (setf *program-name* program-name))
+ (when helpp (setf *help* help))
+ (when versionp (setf *version* version))
+ (when optsp (setf *options* options))
+ (cond ((and usagep fullp) (error "conflicting options"))
+ (usagep (setf *usage* (simple-usage *options* usage)))
+ (fullp (setf *usage* full-usage))))
+
+(defmacro do-options ((&key (parser '(make-option-parser)))
+ &body clauses)
"Handy all-in-one options parser macro. PARSER defaults to a new options
parser using the preset default options structure. The CLAUSES are
`case2'-like clauses to match options, and must be exhaustive. If there
is a clause (nil (REST) FORMS...) then the FORMS are evaluated after
parsing is done with REST bound to the remaining command-line arguments."
- (with-gensyms (tparser)
- `(let ((,tparser ,parser))
+ (let*/gensyms (parser)
+ `(progn
(loop
(,(if (find t clauses :key #'car) 'case2 'ecase2)
- (option-parse-next ,tparser)
+ (option-parse-next ,parser)
((nil) () (return))
,@(remove-if #'null clauses :key #'car)))
,@(let ((tail (find nil clauses :key #'car)))
(and tail
(destructuring-bind ((&optional arg) &rest forms) (cdr tail)
(if arg
- (list `(let ((,arg (option-parse-remainder ,tparser)))
- ,@forms))
+ (list `(let ((,arg (option-parse-remainder ,parser)))
+ ,@forms))
forms)))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff