[PATCH 4/5] Implement #:stop-at-first-non-option option for getopt-long

[Neil Jerram]

(For use by guile-tools)

* module/ice-9/getopt-long.scm: Use (ice-9 optargs) so we can use
  define*.

  (process-options): Add stop-at-first-non-option parameter.  When
  this is true, stop processing when we hit a non-option (so long as
  that non-option isn't something that resulted from the unclumping of
  a short option group).

  (getopt-long): Add #:stop-at-first-non-option keyword; pass it on to
  process-options.

* test-suite/tests/getopt-long.test ("stop-at-first-non-option"): New
  test (for the above).
---
 module/ice-9/getopt-long.scm      |   12 +++++++++---
 test-suite/tests/getopt-long.test |   11 +++++++++++
 2 files changed, 20 insertions(+), 3 deletions(-)

diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 0c2d835..12f8c94 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -161,6 +161,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 optargs)
   #:export (getopt-long option-ref))
 
 (define %program-name (make-fluid))
@@ -231,7 +232,7 @@
       (regexp-exec long-opt-with-value-rx string)
       (regexp-exec long-opt-no-value-rx string)))
 
-(define (process-options specs argument-ls)
+(define (process-options specs argument-ls stop-at-first-non-option)
   ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
   ;; FOUND is an unordered list of option specs for found options, while ETC
   ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
@@ -300,10 +301,14 @@
                       (eat! spec (cons (match:substring match 2) rest))
                       (fatal-error "option does not support argument: --~a"
                                    opt)))))
+          ((and stop-at-first-non-option
+                (<= unclumped 0))
+           (cons found (append (reverse etc) argument-ls)))
           (else
            (loop (- unclumped 1) rest found (cons opt etc)))))))))
 
-(define (getopt-long program-arguments option-desc-list)
+(define* (getopt-long program-arguments option-desc-list
+                      #:key stop-at-first-non-option)
   "Process options, handling both long and short options, similar to
 the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
 similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
@@ -339,7 +344,8 @@ to add a `single-char' clause to the option description."
            (pair (split-arg-list (cdr program-arguments)))
            (split-ls (car pair))
            (non-split-ls (cdr pair))
-           (found/etc (process-options specifications split-ls))
+           (found/etc (process-options specifications split-ls
+                                       stop-at-first-non-option))
            (found (car found/etc))
            (rest-ls (append (cdr found/etc) non-split-ls)))
       (for-each (lambda (spec)
diff --git a/test-suite/tests/getopt-long.test 
b/test-suite/tests/getopt-long.test
index 682763c..4ae6048 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -288,4 +288,15 @@
 
   )
 
+(with-test-prefix "stop-at-first-non-option"
+
+  (pass-if "guile-tools compile example"
+    (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o" 
"eval.go")
+                         '((help (single-char #\h))
+                           (version (single-char #\v)))
+                         #:stop-at-first-non-option #t)
+            '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go"))))
+
+  )
+
 ;;; getopt-long.test ends here
-- 
1.7.4.1