;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:kmr)
+(in-package #:kmrcl)
(defun is-short-option (arg)
(char= #\- (schar arg 1))))
(defun is-long-option (arg)
- (and (> (length arg 2))
- (char= #- (schar 0))
- (char= #- (schar 1))
- (char/= #- (schar 3))))
+ (and (> (length arg) 2)
+ (char= #\- (schar arg 0))
+ (char= #\- (schar arg 1))
+ (char/= #\- (schar arg 3))))
+(defun arg->base-name (arg)
+ (cond
+ ((is-long-option arg)
+ (subseq arg 2))
+ ((is-short-option arg)
+ (subseq arg 1))
+ (t
+ arg)))
+
(defun match-option (arg options)
"Matches an argument to an option. Returns match,is-long"
(cond
(t
(values nil nil))))
-(defun getopt (args opts)
+(defun getopt (args options)
"Processes a list of arguments and options. Returns filtered argument
list and alist of options.
opts is a list of option lists. The fields of the list are
- HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL
- VAL value to return for a option with no arguments
"
- (do ((pos args)
+ (do ((pos args (cdr pos))
+ (finished-options)
(out-opts)
(out-args)
(errors))
- ((null pos) (values out-args out-opts errors))
- (multiple-value-bind (match is-long) (match-option (car pos) options))
- (if match
- (progn
- (push (cons (car pos) (second pos)) out-opts)
- (setq pos (cddr pos))))))
+ ((null pos) (values (nreverse out-args) (nreverse out-opts) errors))
+ (cond
+ (finished-options
+ (push (car pos) out-args))
+ ((is-option-terminator (car pos))
+ (setq finished-options t))
+ (t
+ (multiple-value-bind (match is-long) (match-option (car pos) options)
+ (if match
+ (cond
+ ((and (eq :required (second match)) (null (cdr pos)))
+ (push (arg->base-name (car pos)) errors))
+ (t
+ (push (cons (arg->base-name (car pos)) (second pos)) out-opts)
+ (setq pos (cdr pos))))
+ (push (car pos) out-args)))))))