summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/srfi/srfi-37.scm5
-rw-r--r--test-suite/tests/srfi-37.test24
2 files changed, 27 insertions, 2 deletions
diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm
index 565b44cb9..3f654af2c 100644
--- a/module/srfi/srfi-37.scm
+++ b/module/srfi/srfi-37.scm
@@ -1,6 +1,6 @@
;;; srfi-37.scm --- args-fold
-;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -145,6 +145,9 @@ program-arguments in ARGS, as decided by the OPTIONS'
(let ((result (cadr args)))
(set! args (cddr args))
result))
+ ((pair? args)
+ (set! args (cdr args))
+ #f)
(else #f)))
;; Interpret the short-option at index POSITION in (car ARGS),
diff --git a/test-suite/tests/srfi-37.test b/test-suite/tests/srfi-37.test
index 1f739c5c5..5a3975070 100644
--- a/test-suite/tests/srfi-37.test
+++ b/test-suite/tests/srfi-37.test
@@ -1,6 +1,6 @@
;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*-
;;;;
-;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -105,4 +105,26 @@
(lambda (opt name arg k) #f)
'()))))
+ (pass-if-equal "short option with optional argument omitted" 'good
+ ;; This would trigger an infinite loop in Guile up to 2.0.7.
+ ;; See <http://bugs.gnu.org/13176>.
+ (args-fold '("-I")
+ (list (option '(#\I) #f #t
+ (lambda (opt name arg value)
+ (and (eqv? name #\I) (not arg)
+ 'good))))
+ (lambda _ (error "unrecognized"))
+ (const #f)
+ #f))
+
+ (pass-if-equal "short option with optional argument provided"
+ "the-argument"
+ (args-fold '("-I" "the-argument")
+ (list (option '(#\I) #f #t
+ (lambda (opt name arg result)
+ (and (eqv? name #\I) arg))))
+ (lambda _ (error "unrecognized"))
+ (const #f)
+ #f))
+
)