X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/b3bc37457df55c92cabc8aeeb42bc67d3fb8af12..2c13c1cd713e033763786de1ce9fc66565abb5df:/optparse.lisp

diff --git a/optparse.lisp b/optparse.lisp
index 9f835fc..ff301ee 100644
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -446,13 +446,15 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
    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)))
+    (multiple-value-bind (docs decls body) (parse-body 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
@@ -571,29 +573,38 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
   "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,