r7817: first working version, add getopt to test suite

[kmrcl.git] / getopt.lisp

diff --git a/getopt.lisp b/getopt.lisp
index ba4cd945c47a579ff0329c9775d2160ccdedf2c9..93f65b645e4cdf8023c5a43efcd13aff92692b76 100644 (file)
--- a/getopt.lisp
+++ b/getopt.lisp
@@ -16,7 +16,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package #:kmr)
+(in-package #:kmrcl)
 
 
 (defun is-short-option (arg)
@@ -30,11 +30,20 @@
        (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
@@ -45,7 +54,7 @@
     (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
@@ -53,14 +62,25 @@ 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)))))))