Import guile-1.8 as multiple upstream tarball component

[lilypond.git] / guile18 / test-suite / tests / srfi-37.test

diff --git a/guile18/test-suite/tests/srfi-37.test b/guile18/test-suite/tests/srfi-37.test
new file mode 100644 (file)
index 0000000..d774587
--- /dev/null
+++ b/guile18/test-suite/tests/srfi-37.test
@@ -0,0 +1,109 @@
+;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*-
+;;;;
+;;;;   Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-37)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-37))
+
+(with-test-prefix "SRFI-37"
+
+  (pass-if "empty calls with count-modified seeds"
+    (equal? (list 21 42)
+           (call-with-values
+               (lambda ()
+                 (args-fold '("1" "3" "4") '()
+                            (lambda (opt name arg seed seed2)
+                              (values 1 2))
+                            (lambda (op seed seed2)
+                              (values (1+ seed) (+ 2 seed2)))
+                            18 36))
+             list)))
+
+  (pass-if "short opt params"
+    (let ((a-set #f) (b-set #f) (c-val #f) (d-val #f) (no-fail #t) (no-operands #t))
+      (args-fold '("-abcdoit" "-ad" "whatev")
+                (list (option '(#\a) #f #f (lambda (opt name arg)
+                                             (set! a-set #t)
+                                             (values)))
+                      (option '(#\b) #f #f (lambda (opt name arg)
+                                             (set! b-set #t)
+                                             (values)))
+                      (option '("cdoit" #\c) #f #t
+                              (lambda (opt name arg)
+                                (set! c-val arg)
+                                (values)))
+                      (option '(#\d) #f #t
+                              (lambda (opt name arg)
+                                (set! d-val arg)
+                                (values))))
+                (lambda (opt name arg) (set! no-fail #f) (values))
+                (lambda (oper) (set! no-operands #f) (values)))
+      (equal? '(#t #t "doit" "whatev" #t #t)
+             (list a-set b-set c-val d-val no-fail no-operands))))
+
+  (pass-if "single unrecognized long-opt"
+    (equal? "fake"
+           (args-fold '("--fake" "-i2")
+                      (list (option '(#\i) #t #f
+                                    (lambda (opt name arg k) k)))
+                      (lambda (opt name arg k) name)
+                      (lambda (operand k) #f)
+                      #f)))
+
+  (pass-if "long req'd/optional"
+    (equal? '(#f "bsquare" "apple")
+           (args-fold '("--x=pple" "--y=square" "--y")
+                      (list (option '("x") #t #f
+                                    (lambda (opt name arg k)
+                                      (cons (string-append "a" arg) k)))
+                            (option '("y") #f #t
+                                    (lambda (opt name arg k)
+                                      (cons (if arg
+                                                (string-append "b" arg)
+                                                #f) k))))
+                      (lambda (opt name arg k) #f)
+                      (lambda (opt name arg k) #f)
+                      '())))
+
+  ;; this matches behavior of getopt_long in libc 2.4
+  (pass-if "short options absorb special markers in the next arg"
+    (let ((arg-proc (lambda (opt name arg k)
+                     (acons name arg k))))
+      (equal? '((#\y . "-z") (#\x . "--") (#\z . #f))
+             (args-fold '("-zx" "--" "-y" "-z" "--")
+                        (list (option '(#\x) #f #t arg-proc)
+                              (option '(#\z) #f #f arg-proc)
+                              (option '(#\y) #t #f arg-proc))
+                        (lambda (opt name arg k) #f)
+                        (lambda (opt name arg k) #f)
+                        '()))))
+
+  (pass-if "short options without arguments"
+    ;; In Guile 1.8.4 and earlier, using short names of argument-less options
+    ;; would lead to a stack overflow.
+    (let ((arg-proc (lambda (opt name arg k)
+                     (acons name arg k))))
+      (equal? '((#\x . #f))
+             (args-fold '("-x")
+                        (list (option '(#\x) #f #f arg-proc))
+                        (lambda (opt name arg k) #f)
+                        (lambda (opt name arg k) #f)
+                        '()))))
+
+)