-(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 #.(concatenate 'string
+ "Argument `~A' invalid: "
+ "must be one of:"
+ "~{~%~8T~(~A~)~}")
+ arg valid))
+ ((null (cdr matches))
+ (setf var (car matches)))
+ (t
+ (option-parse-error #.(concatenate 'string
+ "Argument `~A' ambiguous: "
+ "may be any of:"
+ "~{~%~8T~(~A~)~}")
+ arg matches)))))))