;;; 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.
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.
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,
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.
(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.
(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))