code:
;;;; srfi-13.test --- Test suite for Guile's SRFI-13 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-07
;;;;
;;;; Copyright (C) 2001, 2004, 2005, 2006 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-strings)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-13)
  #:use-module (srfi srfi-14))

(define exception:strict-infix-grammar
  (cons 'misc-error "^strict-infix"))

;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
  (apply string (map integer->char args)))

;;;
;;; string-any
;;;

(with-test-prefix "string-any"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-any 123 "abcde"))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-any "zzz" "abcde")))

  (with-test-prefix "char"

    (pass-if "no match"
      (not (string-any #\C "abcde")))

    (pass-if "one match"
      (string-any #\C "abCde"))

    (pass-if "more than one match"
      (string-any #\X "abXXX"))

    (pass-if "no match, start index"
      (not (string-any #\A "Abcde" 1)))

    (pass-if "one match, start index"
      (string-any #\C "abCde" 1))

    (pass-if "more than one match, start index"
      (string-any #\X "abXXX" 1))

    (pass-if "no match, start and end index"
      (not (string-any #\X "XbcdX" 1 4)))

    (pass-if "one match, start and end index"
      (string-any #\C "abCde" 1 4))

    (pass-if "more than one match, start and end index"
      (string-any #\X "abXXX" 1 4)))

  (with-test-prefix "charset"

    (pass-if "no match"
      (not (string-any char-set:upper-case "abcde")))

    (pass-if "one match"
      (string-any char-set:upper-case "abCde"))

    (pass-if "more than one match"
      (string-any char-set:upper-case "abCDE"))

    (pass-if "no match, start index"
      (not (string-any char-set:upper-case "Abcde" 1)))

    (pass-if "one match, start index"
      (string-any char-set:upper-case "abCde" 1))

    (pass-if "more than one match, start index"
      (string-any char-set:upper-case "abCDE" 1))

    (pass-if "no match, start and end index"
      (not (string-any char-set:upper-case "AbcdE" 1 4)))

    (pass-if "one match, start and end index"
      (string-any char-set:upper-case "abCde" 1 4))

    (pass-if "more than one match, start and end index"
      (string-any char-set:upper-case "abCDE" 1 4)))

  (with-test-prefix "pred"

    (pass-if "no match"
      (not (string-any char-upper-case? "abcde")))

    (pass-if "one match"
      (string-any char-upper-case? "abCde"))

    (pass-if "more than one match"
      (string-any char-upper-case? "abCDE"))

    (pass-if "no match, start index"
      (not (string-any char-upper-case? "Abcde" 1)))

    (pass-if "one match, start index"
      (string-any char-upper-case? "abCde" 1))

    (pass-if "more than one match, start index"
      (string-any char-upper-case? "abCDE" 1))

    (pass-if "no match, start and end index"
      (not (string-any char-upper-case? "AbcdE" 1 4)))

    (pass-if "one match, start and end index"
      (string-any char-upper-case? "abCde" 1 4))

    (pass-if "more than one match, start and end index"
      (string-any char-upper-case? "abCDE" 1 4))))

;;;
;;; string-append/shared
;;;

(with-test-prefix "string-append/shared"

  (pass-if "no args"
    (string=? "" (string-append/shared)))

  (with-test-prefix "one arg"
    (pass-if "empty"
      (string=? "" (string-append/shared "")))
    (pass-if "non-empty"
      (string=? "xyz" (string-append/shared "xyz"))))

  (with-test-prefix "two args"
    (pass-if (string=? ""       (string-append/shared ""    "")))
    (pass-if (string=? "xyz"    (string-append/shared "xyz" "")))
    (pass-if (string=? "xyz"    (string-append/shared ""    "xyz")))
    (pass-if (string=? "abcxyz" (string-append/shared "abc" "xyz"))))

  (with-test-prefix "three args"
    (pass-if (string=? ""   	(string-append/shared ""   ""   "")))
    (pass-if (string=? "xy" 	(string-append/shared "xy" ""   "")))
    (pass-if (string=? "xy" 	(string-append/shared ""   "xy" "")))
    (pass-if (string=? "abxy"   (string-append/shared "ab" "xy" "")))
    (pass-if (string=? "ab"     (string-append/shared ""   ""   "ab")))
    (pass-if (string=? "xyab"   (string-append/shared "xy" ""   "ab")))
    (pass-if (string=? "xyab"   (string-append/shared ""   "xy" "ab")))
    (pass-if (string=? "ghxyab" (string-append/shared "gh" "xy" "ab"))))

  (with-test-prefix "four args"
    (pass-if (string=? ""   	(string-append/shared ""   ""   ""   "")))
    (pass-if (string=? "xy" 	(string-append/shared "xy" ""   ""   "")))
    (pass-if (string=? "xy" 	(string-append/shared ""   "xy" ""   "")))
    (pass-if (string=? "xy" 	(string-append/shared ""   ""   "xy" "")))
    (pass-if (string=? "xy" 	(string-append/shared ""   ""   ""   "xy")))

    (pass-if (string=? "abxy"   (string-append/shared "ab" "xy" ""   "")))
    (pass-if (string=? "abxy"   (string-append/shared "ab" ""   "xy" "")))
    (pass-if (string=? "abxy"   (string-append/shared "ab" ""   ""   "xy")))
    (pass-if (string=? "abxy"   (string-append/shared ""   "ab" ""   "xy")))
    (pass-if (string=? "abxy"   (string-append/shared ""   ""   "ab" "xy")))))

;;;
;;; string-concatenate
;;;

(with-test-prefix "string-concatenate"

  (pass-if-exception "inum" exception:wrong-type-arg
    (string-concatenate 123))

  (pass-if-exception "symbol" exception:wrong-type-arg
    (string-concatenate 'x))

  (pass-if-exception "improper 1" exception:wrong-type-arg
    (string-concatenate '("a" . "b")))

  (pass-if (equal? "abc" (string-concatenate '("a" "b" "c")))))

;;
;; string-compare
;;

(with-test-prefix "string-compare"

  (pass-if "same as char<?"
    (eq? (char<? (integer->char 0) (integer->char 255))
	 (string-compare (string-ints 0) (string-ints 255)
			 (lambda (pos) #t)     ;; lt
			 (lambda (pos) #f)     ;; eq
			 (lambda (pos) #f))))) ;; gt

;;
;; string-compare-ci
;;

(with-test-prefix "string-compare-ci"

  (pass-if "same as char-ci<?"
    (eq? (char-ci<? (integer->char 0) (integer->char 255))
	 (string-compare-ci (string-ints 0) (string-ints 255)
			 (lambda (pos) #t)     ;; lt
			 (lambda (pos) #f)     ;; eq
			 (lambda (pos) #f))))) ;; gt

;;;
;;; string-concatenate/shared
;;;

(with-test-prefix "string-concatenate/shared"

  (pass-if-exception "inum" exception:wrong-type-arg
    (string-concatenate/shared 123))

  (pass-if-exception "symbol" exception:wrong-type-arg
    (string-concatenate/shared 'x))

  (pass-if-exception "improper 1" exception:wrong-type-arg
    (string-concatenate/shared '("a" . "b")))

  (pass-if (equal? "abc" (string-concatenate/shared '("a" "b" "c")))))

;;;
;;; string-every
;;;

(with-test-prefix "string-every"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-every 123 "abcde"))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-every "zzz" "abcde")))

  (with-test-prefix "char"

    (pass-if "empty string"
      (string-every #\X ""))

    (pass-if "empty substring"
      (string-every #\X "abc" 1 1))

    (pass-if "no match at all"
      (not (string-every #\X "abcde")))

    (pass-if "not all match"
      (not (string-every #\X "abXXX")))

    (pass-if "all match"
      (string-every #\X "XXXXX"))

    (pass-if "no match at all, start index"
      (not (string-every #\X "Xbcde" 1)))

    (pass-if "not all match, start index"
      (not (string-every #\X "XXcde" 1)))

    (pass-if "all match, start index"
      (string-every #\X "aXXXX" 1))

    (pass-if "no match at all, start and end index"
      (not (string-every #\X "XbcdX" 1 4)))

    (pass-if "not all match, start and end index"
      (not (string-every #\X "XXcde" 1 4)))

    (pass-if "all match, start and end index"
      (string-every #\X "aXXXe" 1 4)))

  (with-test-prefix "charset"

    (pass-if "empty string"
      (string-every char-set:upper-case ""))

    (pass-if "empty substring"
      (string-every char-set:upper-case "abc" 1 1))

    (pass-if "no match at all"
      (not (string-every char-set:upper-case "abcde")))

    (pass-if "not all match"
      (not (string-every char-set:upper-case "abCDE")))

    (pass-if "all match"
      (string-every char-set:upper-case "ABCDE"))

    (pass-if "no match at all, start index"
      (not (string-every char-set:upper-case "Abcde" 1)))

    (pass-if "not all match, start index"
      (not (string-every char-set:upper-case "ABcde" 1)))

    (pass-if "all match, start index"
      (string-every char-set:upper-case "aBCDE" 1))

    (pass-if "no match at all, start and end index"
      (not (string-every char-set:upper-case "AbcdE" 1 4)))

    (pass-if "not all match, start and end index"
      (not (string-every char-set:upper-case "ABcde" 1 4)))

    (pass-if "all match, start and end index"
      (string-every char-set:upper-case "aBCDe" 1 4)))

  (with-test-prefix "pred"

    ;; in guile 1.6.4 and earlier string-every incorrectly returned #f on an
    ;; empty string
    (pass-if "empty string"
      (string-every char-upper-case? ""))
    (pass-if "empty substring"
      (string-every char-upper-case? "abc" 1 1))

    (pass-if "no match at all"
      (not (string-every char-upper-case? "abcde")))

    (pass-if "not all match"
      (not (string-every char-upper-case? "abCDE")))

    (pass-if "all match"
      (string-every char-upper-case? "ABCDE"))

    (pass-if "no match at all, start index"
      (not (string-every char-upper-case? "Abcde" 1)))

    (pass-if "not all match, start index"
      (not (string-every char-upper-case? "ABcde" 1)))

    (pass-if "all match, start index"
      (string-every char-upper-case? "aBCDE" 1))

    (pass-if "no match at all, start and end index"
      (not (string-every char-upper-case? "AbcdE" 1 4)))

    (pass-if "not all match, start and end index"
      (not (string-every char-upper-case? "ABcde" 1 4)))

    (pass-if "all match, start and end index"
      (string-every char-upper-case? "aBCDe" 1 4))))

(with-test-prefix "string-tabulate"

  (with-test-prefix "bad proc"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-tabulate 123 10))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-tabulate "zzz" 10)))

  (pass-if "static fill-char"
    (string=? (string-tabulate (lambda (idx) #\!) 10) "!!!!!!!!!!"))

  (pass-if "variable fill-char"
    (string=? (string-tabulate
	       (lambda (idx) (integer->char (+ idx 32))) 10) " !\"#$%&'()")))

(with-test-prefix "string->list"

  (pass-if "empty"
     (zero? (length (string->list ""))))

  (pass-if "nonempty"
     (= (length (string->list "foo")) 3))

  (pass-if "empty, start index"
     (zero? (length (string->list "foo" 3 3))))

   (pass-if "nonempty, start index"
     (= (length (string->list "foo" 1 3)) 2))
  )

(with-test-prefix "reverse-list->string"

  (pass-if "empty"
     (string-null? (reverse-list->string '())))

  (pass-if "nonempty"
     (string=? "foo" (reverse-list->string '(#\o #\o #\f)))))

(with-test-prefix "string-join"

  (pass-if "empty list, no delimiter, implicit infix, empty 1"
     (string=? "" (string-join '())))

  (pass-if "empty string, no delimiter, implicit infix, empty 2"
     (string=? "" (string-join '(""))))

  (pass-if "non-empty, no delimiter, implicit infix"
     (string=? "bla" (string-join '("bla"))))

  (pass-if "empty list, implicit infix, empty 1"
     (string=? "" (string-join '() "|delim|")))

  (pass-if "empty string, implicit infix, empty 2"
     (string=? "" (string-join '("") "|delim|")))

  (pass-if "non-empty, implicit infix"
     (string=? "bla" (string-join '("bla") "|delim|")))

  (pass-if "non-empty, implicit infix"
     (string=? "bla" (string-join '("bla") "|delim|")))

  (pass-if "two strings, implicit infix"
     (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|")))

  (pass-if "empty, explicit infix"
     (string=? "" (string-join '("") "|delim|" 'infix)))

  (pass-if "empty list, explicit infix"
     (string=? "" (string-join '() "|delim|" 'infix)))

  (pass-if "non-empty, explicit infix"
     (string=? "bla" (string-join '("bla") "|delim|" 'infix)))

  (pass-if "two strings, explicit infix"
     (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|"
					      'infix)))

  (pass-if-exception "empty list, strict infix"
     exception:strict-infix-grammar
     (string-join '() "|delim|" 'strict-infix))

  (pass-if "empty, strict infix"
     (string=? "" (string-join '("") "|delim|" 'strict-infix)))

  (pass-if "non-empty, strict infix"
     (string=? "foo" (string-join '("foo") "|delim|" 'strict-infix)))

  (pass-if "two strings, strict infix"
     (string=? "foo|delim|bar" (string-join '("foo" "bar") "|delim|"
					    'strict-infix)))

  (pass-if "empty list, prefix"
     (string=? "" (string-join '() "|delim|" 'prefix)))

  (pass-if "empty, prefix"
     (string=? "|delim|" (string-join '("") "|delim|" 'prefix)))

  (pass-if "non-empty, prefix"
     (string=? "|delim|foo" (string-join '("foo") "|delim|" 'prefix)))

  (pass-if "two strings, prefix"
     (string=? "|delim|foo|delim|bar" (string-join '("foo" "bar") "|delim|"
						   'prefix)))

  (pass-if "empty list, suffix"
     (string=? "" (string-join '() "|delim|" 'suffix)))

  (pass-if "empty, suffix"
     (string=? "|delim|" (string-join '("") "|delim|" 'suffix)))

  (pass-if "non-empty, suffix"
     (string=? "foo|delim|" (string-join '("foo") "|delim|" 'suffix)))

  (pass-if "two strings, suffix"
     (string=? "foo|delim|bar|delim|" (string-join '("foo" "bar") "|delim|"
						   'suffix))))

(with-test-prefix "string-copy"

  (pass-if "empty string"
    (string=? "" (string-copy "")))

  (pass-if "full string"
    (string=? "foo-bar" (string-copy "foo-bar")))

  (pass-if "start index"
    (string=? "o-bar" (string-copy "foo-bar" 2)))

  (pass-if "start and end index"
    (string=? "o-ba" (string-copy "foo-bar" 2 6)))
)

(with-test-prefix "substring/shared"

  (pass-if "empty string"
    (eq? "" (substring/shared "" 0)))

  (pass-if "non-empty string"
    (string=? "foo" (substring/shared "foo-bar" 0 3)))

  (pass-if "non-empty string, not eq?"
    (string=? "foo-bar" (substring/shared "foo-bar" 0 7))))

(with-test-prefix "string-copy!"

  (pass-if "non-empty string"
    (string=? "welld, oh yeah!"
	      (let* ((s "hello")
		     (t (string-copy "world, oh yeah!")))
		(string-copy! t 1 s 1 3)
		t))))

(with-test-prefix "string-take"

  (pass-if "empty string"
    (string=? "" (string-take "foo bar braz" 0)))

  (pass-if "non-empty string"
    (string=? "foo " (string-take "foo bar braz" 4)))

  (pass-if "full string"
    (string=? "foo bar braz" (string-take "foo bar braz" 12))))

(with-test-prefix "string-take-right"

  (pass-if "empty string"
    (string=? "" (string-take-right "foo bar braz" 0)))

  (pass-if "non-empty string"
    (string=? "braz" (string-take-right "foo bar braz" 4)))

  (pass-if "full string"
    (string=? "foo bar braz" (string-take-right "foo bar braz" 12))))

(with-test-prefix "string-drop"

  (pass-if "empty string"
    (string=? "" (string-drop "foo bar braz" 12)))

  (pass-if "non-empty string"
    (string=? "braz" (string-drop "foo bar braz" 8)))

  (pass-if "full string"
    (string=? "foo bar braz" (string-drop "foo bar braz" 0))))

(with-test-prefix "string-drop-right"

  (pass-if "empty string"
    (string=? "" (string-drop-right "foo bar braz" 12)))

  (pass-if "non-empty string"
    (string=? "foo " (string-drop-right "foo bar braz" 8)))

  (pass-if "full string"
    (string=? "foo bar braz" (string-drop-right "foo bar braz" 0))))

(with-test-prefix "string-pad"

  (pass-if "empty string, zero pad"
    (string=? "" (string-pad "" 0)))

  (pass-if "empty string, zero pad, pad char"
    (string=? "" (string-pad "" 0)))

  (pass-if "empty pad string, 2 pad "
    (string=? "  " (string-pad "" 2)))

  (pass-if "empty pad string, 2 pad, pad char"
    (string=? "!!" (string-pad "" 2 #\!)))

  (pass-if "empty pad string, 2 pad, pad char, start index"
    (string=? "!c" (string-pad "abc" 2 #\! 2)))

  (pass-if "empty pad string, 2 pad, pad char, start and end index"
    (string=? "!c" (string-pad "abcd" 2 #\! 2 3)))

  (pass-if "freestyle 1"
    (string=? "32" (string-pad (number->string 532) 2 #\!)))

  (pass-if "freestyle 2"
    (string=? "!532" (string-pad (number->string 532) 4 #\!))))

(with-test-prefix "string-pad-right"

  (pass-if "empty string, zero pad"
    (string=? "" (string-pad-right "" 0)))

  (pass-if "empty string, zero pad, pad char"
    (string=? "" (string-pad-right "" 0)))

  (pass-if "empty pad string, 2 pad "
    (string=? "  " (string-pad-right "" 2)))

  (pass-if "empty pad string, 2 pad, pad char"
    (string=? "!!" (string-pad-right "" 2 #\!)))

  (pass-if "empty pad string, 2 pad, pad char, start index"
    (string=? "c!" (string-pad-right "abc" 2 #\! 2)))

  (pass-if "empty pad string, 2 pad, pad char, start and end index"
    (string=? "c!" (string-pad-right "abcd" 2 #\! 2 3)))

  (pass-if "freestyle 1"
    (string=? "53" (string-pad-right (number->string 532) 2 #\!)))

  (pass-if "freestyle 2"
    (string=? "532!" (string-pad-right (number->string 532) 4 #\!))))

(with-test-prefix "string-trim"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-trim "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-trim "abcde" "zzz")))

  (pass-if "empty string"
    (string=? "" (string-trim "")))

  (pass-if "no char/pred"
    (string=? "foo " (string-trim " \tfoo ")))

  (pass-if "start index, pred"
    (string=? "foo " (string-trim " \tfoo " char-whitespace? 1)))

  (pass-if "start and end index, pred"
    (string=? "f" (string-trim " \tfoo " char-whitespace? 1 3)))

  (pass-if "start index, char"
    (string=? "\tfoo " (string-trim " \tfoo " #\space 1)))

  (pass-if "start and end index, char"
    (string=? "\tf" (string-trim " \tfoo " #\space 1 3)))

  (pass-if "start index, charset"
    (string=? "foo " (string-trim " \tfoo " char-set:whitespace 1)))

  (pass-if "start and end index, charset"
    (string=? "f" (string-trim " \tfoo " char-set:whitespace 1 3))))

(with-test-prefix "string-trim-right"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-trim-right "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-trim-right "abcde" "zzz")))

  (pass-if "empty string"
    (string=? "" (string-trim-right "")))

  (pass-if "no char/pred"
    (string=? " \tfoo" (string-trim-right " \tfoo ")))

  (pass-if "start index, pred"
    (string=? "\tfoo" (string-trim-right " \tfoo " char-whitespace? 1)))

  (pass-if "start and end index, pred"
    (string=? "\tf" (string-trim-right " \tfoo " char-whitespace? 1 3)))

  (pass-if "start index, char"
    (string=? "\tfoo" (string-trim-right " \tfoo " #\space 1)))

  (pass-if "start and end index, char"
    (string=? "\tf" (string-trim-right " \tfoo " #\space 1 3)))

  (pass-if "start index, charset"
    (string=? "\tfoo" (string-trim-right " \tfoo " char-set:whitespace 1)))

  (pass-if "start and end index, charset"
    (string=? "\tf" (string-trim-right " \tfoo " char-set:whitespace 1 3))))

(with-test-prefix "string-trim-both"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-trim-both "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-trim-both "abcde" "zzz")))

  (pass-if "empty string"
    (string=? "" (string-trim-both "")))

  (pass-if "no char/pred"
    (string=? "foo" (string-trim-both " \tfoo ")))

  (pass-if "start index, pred"
    (string=? "foo" (string-trim-both " \tfoo " char-whitespace? 1)))

  (pass-if "start and end index, pred"
    (string=? "f" (string-trim-both " \tfoo " char-whitespace? 1 3)))

  (pass-if "start index, char"
    (string=? "\tfoo" (string-trim-both " \tfoo " #\space 1)))

  (pass-if "start and end index, char"
    (string=? "\tf" (string-trim-both " \tfoo " #\space 1 3)))

  (pass-if "start index, charset"
    (string=? "foo" (string-trim-both " \tfoo " char-set:whitespace 1)))

  (pass-if "start and end index, charset"
    (string=? "f" (string-trim-both " \tfoo " char-set:whitespace 1 3))))

(define s0 (make-string 200 #\!))
(define s1 (make-string 0 #\!))

(with-test-prefix "string-fill!"

  (pass-if "empty string, no indices"
    (string-fill! s1 #\*)
    (= (string-length s1) 0))

  (pass-if "empty string, start index"
    (string-fill! s1 #\* 0)
    (= (string-length s1) 0))

  (pass-if "empty string, start and end index"
    (string-fill! s1 #\* 0 0)
    (= (string-length s1) 0))

  (pass-if "no indices"
    (string-fill! s0 #\*)
    (char=? (string-ref s0 0) #\*))

  (pass-if "start index"
    (string-fill! s0 #\+ 10)
    (char=? (string-ref s0 11) #\+))

  (pass-if "start and end index"
    (string-fill! s0 #\| 12 20)
    (char=? (string-ref s0 13) #\|)))

(with-test-prefix "string-prefix-length"

  (pass-if "empty prefix"
    (= 0 (string-prefix-length "" "foo bar")))

  (pass-if "non-empty prefix - match"
    (= 3 (string-prefix-length "foo" "foo bar")))

  (pass-if "non-empty prefix - no match"
    (= 0 (string-prefix-length "bar" "foo bar"))))

(with-test-prefix "string-prefix-length-ci"

  (pass-if "empty prefix"
    (= 0 (string-prefix-length-ci "" "foo bar")))

  (pass-if "non-empty prefix - match"
    (= 3 (string-prefix-length-ci "fOo" "foo bar")))

  (pass-if "non-empty prefix - no match"
    (= 0 (string-prefix-length-ci "bAr" "foo bar"))))

(with-test-prefix "string-suffix-length"

  (pass-if "empty suffix"
    (= 0 (string-suffix-length "" "foo bar")))

  (pass-if "non-empty suffix - match"
    (= 3 (string-suffix-length "bar" "foo bar")))

  (pass-if "non-empty suffix - no match"
    (= 0 (string-suffix-length "foo" "foo bar"))))

(with-test-prefix "string-suffix-length-ci"

  (pass-if "empty suffix"
    (= 0 (string-suffix-length-ci "" "foo bar")))

  (pass-if "non-empty suffix - match"
    (= 3 (string-suffix-length-ci "bAr" "foo bar")))

  (pass-if "non-empty suffix - no match"
    (= 0 (string-suffix-length-ci "fOo" "foo bar"))))

(with-test-prefix "string-prefix?"

  (pass-if "empty prefix"
    (string-prefix? "" "foo bar"))

  (pass-if "non-empty prefix - match"
    (string-prefix? "foo" "foo bar"))

  (pass-if "non-empty prefix - no match"
    (not (string-prefix? "bar" "foo bar"))))

(with-test-prefix "string-prefix-ci?"

  (pass-if "empty prefix"
    (string-prefix-ci? "" "foo bar"))

  (pass-if "non-empty prefix - match"
    (string-prefix-ci? "fOo" "foo bar"))

  (pass-if "non-empty prefix - no match"
    (not (string-prefix-ci? "bAr" "foo bar"))))

(with-test-prefix "string-suffix?"

  (pass-if "empty suffix"
    (string-suffix? "" "foo bar"))

  (pass-if "non-empty suffix - match"
    (string-suffix? "bar" "foo bar"))

  (pass-if "non-empty suffix - no match"
    (not (string-suffix? "foo" "foo bar"))))

(with-test-prefix "string-suffix-ci?"

  (pass-if "empty suffix"
    (string-suffix-ci? "" "foo bar"))

  (pass-if "non-empty suffix - match"
    (string-suffix-ci? "bAr" "foo bar"))

  (pass-if "non-empty suffix - no match"
    (not (string-suffix-ci? "fOo" "foo bar"))))

(with-test-prefix "string-index"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-index "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-index "abcde" "zzz")))

  (pass-if "empty string - char"
    (not (string-index "" #\a)))

  (pass-if "non-empty - char - match"
    (= 5 (string-index "foo bar" #\a)))

  (pass-if "non-empty - char - no match"
    (not (string-index "frobnicate" #\x)))

  (pass-if "empty string - char - start index"
    (not (string-index "" #\a 0)))

  (pass-if "non-empty - char - match - start index"
    (= 5 (string-index "foo bar" #\a 1)))

  (pass-if "non-empty - char - no match - start index"
    (not (string-index "frobnicate" #\x 2)))

  (pass-if "empty string - char - start and end index"
    (not (string-index "" #\a 0 0)))

  (pass-if "non-empty - char - match - start and end index"
    (= 5 (string-index "foo bar" #\a 1 6)))

  (pass-if "non-empty - char - no match - start and end index"
    (not (string-index "frobnicate" #\a 2 5)))

  (pass-if "empty string - charset"
    (not (string-index "" char-set:letter)))

  (pass-if "non-empty - charset - match"
    (= 0 (string-index "foo bar" char-set:letter)))

  (pass-if "non-empty - charset - no match"
    (not (string-index "frobnicate" char-set:digit)))

  (pass-if "empty string - charset - start index"
    (not (string-index "" char-set:letter 0)))

  (pass-if "non-empty - charset - match - start index"
    (= 1 (string-index "foo bar" char-set:letter 1)))

  (pass-if "non-empty - charset - no match - start index"
    (not (string-index "frobnicate" char-set:digit 2)))

  (pass-if "empty string - charset - start and end index"
    (not (string-index "" char-set:letter 0 0)))

  (pass-if "non-empty - charset - match - start and end index"
    (= 1 (string-index "foo bar" char-set:letter 1 6)))

  (pass-if "non-empty - charset - no match - start and end index"
    (not (string-index "frobnicate" char-set:digit 2 5)))

  (pass-if "empty string - pred"
    (not (string-index "" char-alphabetic?)))

  (pass-if "non-empty - pred - match"
    (= 0 (string-index "foo bar" char-alphabetic?)))

  (pass-if "non-empty - pred - no match"
    (not (string-index "frobnicate" char-numeric?)))

  (pass-if "empty string - pred - start index"
    (not (string-index "" char-alphabetic? 0)))

  (pass-if "non-empty - pred - match - start index"
    (= 1 (string-index "foo bar" char-alphabetic? 1)))

  (pass-if "non-empty - pred - no match - start index"
    (not (string-index "frobnicate" char-numeric? 2)))

  (pass-if "empty string - pred - start and end index"
    (not (string-index "" char-alphabetic? 0 0)))

  (pass-if "non-empty - pred - match - start and end index"
    (= 1 (string-index "foo bar" char-alphabetic? 1 6)))

  (pass-if "non-empty - pred - no match - start and end index"
    (not (string-index "frobnicate" char-numeric? 2 5)))

  ;; in guile 1.6.7 and earlier this resulted in a segv, because
  ;; SCM_MAKE_CHAR didn't cope with "signed char" arguments containing an
  ;; 8-bit value
  (pass-if "8-bit char in string"
    (begin
      (string-index (string (integer->char 200)) char-numeric?)
      #t)))

(with-test-prefix "string-index-right"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-index-right "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-index-right "abcde" "zzz")))

  (pass-if "empty string - char"
    (not (string-index-right "" #\a)))

  (pass-if "non-empty - char - match"
    (= 5 (string-index-right "foo bar" #\a)))

  (pass-if "non-empty - char - no match"
    (not (string-index-right "frobnicate" #\x)))

  (pass-if "empty string - char - start index-right"
    (not (string-index-right "" #\a 0)))

  (pass-if "non-empty - char - match - start index"
    (= 5 (string-index-right "foo bar" #\a 1)))

  (pass-if "non-empty - char - no match - start index"
    (not (string-index-right "frobnicate" #\x 2)))

  (pass-if "empty string - char - start and end index"
    (not (string-index-right "" #\a 0 0)))

  (pass-if "non-empty - char - match - start and end index"
    (= 5 (string-index-right "foo bar" #\a 1 6)))

  (pass-if "non-empty - char - no match - start and end index"
    (not (string-index-right "frobnicate" #\a 2 5)))

  (pass-if "empty string - charset"
    (not (string-index-right "" char-set:letter)))

  (pass-if "non-empty - charset - match"
    (= 6 (string-index-right "foo bar" char-set:letter)))

  (pass-if "non-empty - charset - no match"
    (not (string-index-right "frobnicate" char-set:digit)))

  (pass-if "empty string - charset - start index"
    (not (string-index-right "" char-set:letter 0)))

  (pass-if "non-empty - charset - match - start index"
    (= 6 (string-index-right "foo bar" char-set:letter 1)))

  (pass-if "non-empty - charset - no match - start index"
    (not (string-index-right "frobnicate" char-set:digit 2)))

  (pass-if "empty string - charset - start and end index"
    (not (string-index-right "" char-set:letter 0 0)))

  (pass-if "non-empty - charset - match - start and end index"
    (= 5 (string-index-right "foo bar" char-set:letter 1 6)))

  (pass-if "non-empty - charset - no match - start and end index"
    (not (string-index-right "frobnicate" char-set:digit 2 5)))

  (pass-if "empty string - pred"
    (not (string-index-right "" char-alphabetic?)))

  (pass-if "non-empty - pred - match"
    (= 6 (string-index-right "foo bar" char-alphabetic?)))

  (pass-if "non-empty - pred - no match"
    (not (string-index-right "frobnicate" char-numeric?)))

  (pass-if "empty string - pred - start index"
    (not (string-index-right "" char-alphabetic? 0)))

  (pass-if "non-empty - pred - match - start index"
    (= 6 (string-index-right "foo bar" char-alphabetic? 1)))

  (pass-if "non-empty - pred - no match - start index"
    (not (string-index-right "frobnicate" char-numeric? 2)))

  (pass-if "empty string - pred - start and end index"
    (not (string-index-right "" char-alphabetic? 0 0)))

  (pass-if "non-empty - pred - match - start and end index"
    (= 5 (string-index-right "foo bar" char-alphabetic? 1 6)))

  (pass-if "non-empty - pred - no match - start and end index"
    (not (string-index-right "frobnicate" char-numeric? 2 5))))

(with-test-prefix "string-skip"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-skip "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-skip "abcde" "zzz")))

  (pass-if "empty string - char"
    (not (string-skip "" #\a)))

  (pass-if "non-empty - char - match"
    (= 0 (string-skip "foo bar" #\a)))

  (pass-if "non-empty - char - no match"
    (= 0 (string-skip "frobnicate" #\x)))

  (pass-if "empty string - char - start index"
    (not (string-skip "" #\a 0)))

  (pass-if "non-empty - char - match - start index"
    (= 1 (string-skip "foo bar" #\a 1)))

  (pass-if "non-empty - char - no match - start index"
    (= 2 (string-skip "frobnicate" #\x 2)))

  (pass-if "empty string - char - start and end index"
    (not (string-skip "" #\a 0 0)))

  (pass-if "non-empty - char - match - start and end index"
    (= 1 (string-skip "foo bar" #\a 1 6)))

  (pass-if "non-empty - char - no match - start and end index"
    (= 2 (string-skip "frobnicate" #\a 2 5)))

  (pass-if "empty string - charset"
    (not (string-skip "" char-set:letter)))

  (pass-if "non-empty - charset - match"
    (= 3 (string-skip "foo bar" char-set:letter)))

  (pass-if "non-empty - charset - no match"
    (= 0 (string-skip "frobnicate" char-set:digit)))

  (pass-if "empty string - charset - start index"
    (not (string-skip "" char-set:letter 0)))

  (pass-if "non-empty - charset - match - start index"
    (= 3 (string-skip "foo bar" char-set:letter 1)))

  (pass-if "non-empty - charset - no match - start index"
    (= 2 (string-skip "frobnicate" char-set:digit 2)))

  (pass-if "empty string - charset - start and end index"
    (not (string-skip "" char-set:letter 0 0)))

  (pass-if "non-empty - charset - match - start and end index"
    (= 3 (string-skip "foo bar" char-set:letter 1 6)))

  (pass-if "non-empty - charset - no match - start and end index"
    (= 2 (string-skip "frobnicate" char-set:digit 2 5)))

  (pass-if "empty string - pred"
    (not (string-skip "" char-alphabetic?)))

  (pass-if "non-empty - pred - match"
    (= 3 (string-skip "foo bar" char-alphabetic?)))

  (pass-if "non-empty - pred - no match"
    (= 0 (string-skip "frobnicate" char-numeric?)))

  (pass-if "empty string - pred - start index"
    (not (string-skip "" char-alphabetic? 0)))

  (pass-if "non-empty - pred - match - start index"
    (= 3 (string-skip "foo bar" char-alphabetic? 1)))

  (pass-if "non-empty - pred - no match - start index"
    (= 2 (string-skip "frobnicate" char-numeric? 2)))

  (pass-if "empty string - pred - start and end index"
    (not (string-skip "" char-alphabetic? 0 0)))

  (pass-if "non-empty - pred - match - start and end index"
    (= 3 (string-skip "foo bar" char-alphabetic? 1 6)))

  (pass-if "non-empty - pred - no match - start and end index"
    (= 2 (string-skip "frobnicate" char-numeric? 2 5))))

(with-test-prefix "string-skip-right"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-skip-right "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-skip-right "abcde" "zzz")))

  (pass-if "empty string - char"
    (not (string-skip-right "" #\a)))

  (pass-if "non-empty - char - match"
    (= 6 (string-skip-right "foo bar" #\a)))

  (pass-if "non-empty - char - no match"
    (= 9 (string-skip-right "frobnicate" #\x)))

  (pass-if "empty string - char - start index-right"
    (not (string-skip-right "" #\a 0)))

  (pass-if "non-empty - char - match - start index"
    (= 6 (string-skip-right "foo bar" #\a 1)))

  (pass-if "non-empty - char - no match - start index"
    (= 9 (string-skip-right "frobnicate" #\x 2)))

  (pass-if "empty string - char - start and end index"
    (not (string-skip-right "" #\a 0 0)))

  (pass-if "non-empty - char - match - start and end index"
    (= 4 (string-skip-right "foo bar" #\a 1 6)))

  (pass-if "non-empty - char - no match - start and end index"
    (= 4 (string-skip-right "frobnicate" #\a 2 5)))

  (pass-if "empty string - charset"
    (not (string-skip-right "" char-set:letter)))

  (pass-if "non-empty - charset - match"
    (= 3 (string-skip-right "foo bar" char-set:letter)))

  (pass-if "non-empty - charset - no match"
    (= 9 (string-skip-right "frobnicate" char-set:digit)))

  (pass-if "empty string - charset - start index"
    (not (string-skip-right "" char-set:letter 0)))

  (pass-if "non-empty - charset - match - start index"
    (= 3 (string-skip-right "foo bar" char-set:letter 1)))

  (pass-if "non-empty - charset - no match - start index"
    (= 9 (string-skip-right "frobnicate" char-set:digit 2)))

  (pass-if "empty string - charset - start and end index"
    (not (string-skip-right "" char-set:letter 0 0)))

  (pass-if "non-empty - charset - match - start and end index"
    (= 3 (string-skip-right "foo bar" char-set:letter 1 6)))

  (pass-if "non-empty - charset - no match - start and end index"
    (= 4 (string-skip-right "frobnicate" char-set:digit 2 5)))

  (pass-if "empty string - pred"
    (not (string-skip-right "" char-alphabetic?)))

  (pass-if "non-empty - pred - match"
    (= 3 (string-skip-right "foo bar" char-alphabetic?)))

  (pass-if "non-empty - pred - no match"
    (= 9 (string-skip-right "frobnicate" char-numeric?)))

  (pass-if "empty string - pred - start index"
    (not (string-skip-right "" char-alphabetic? 0)))

  (pass-if "non-empty - pred - match - start index"
    (= 3 (string-skip-right "foo bar" char-alphabetic? 1)))

  (pass-if "non-empty - pred - no match - start index"
    (= 9 (string-skip-right "frobnicate" char-numeric? 2)))

  (pass-if "empty string - pred - start and end index"
    (not (string-skip-right "" char-alphabetic? 0 0)))

  (pass-if "non-empty - pred - match - start and end index"
    (= 3 (string-skip-right "foo bar" char-alphabetic? 1 6)))

  (pass-if "non-empty - pred - no match - start and end index"
    (= 4 (string-skip-right "frobnicate" char-numeric? 2 5))))

;;
;; string-count
;;

(with-test-prefix "string-count"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-count "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-count "abcde" "zzz")))

  (with-test-prefix "char"

    (pass-if (eqv? 0 (string-count "" #\a)))
    (pass-if (eqv? 0 (string-count "-" #\a)))
    (pass-if (eqv? 1 (string-count "a" #\a)))
    (pass-if (eqv? 0 (string-count "--" #\a)))
    (pass-if (eqv? 1 (string-count "a-" #\a)))
    (pass-if (eqv? 1 (string-count "-a" #\a)))
    (pass-if (eqv? 2 (string-count "aa" #\a)))
    (pass-if (eqv? 0 (string-count "---" #\a)))
    (pass-if (eqv? 1 (string-count "-a-" #\a)))
    (pass-if (eqv? 1 (string-count "a--" #\a)))
    (pass-if (eqv? 2 (string-count "aa-" #\a)))
    (pass-if (eqv? 2 (string-count "a-a" #\a)))
    (pass-if (eqv? 3 (string-count "aaa" #\a)))
    (pass-if (eqv? 1 (string-count "--a" #\a)))
    (pass-if (eqv? 2 (string-count "-aa" #\a))))

  (with-test-prefix "charset"

    (pass-if (eqv? 0 (string-count "" char-set:letter)))
    (pass-if (eqv? 0 (string-count "-" char-set:letter)))
    (pass-if (eqv? 1 (string-count "a" char-set:letter)))
    (pass-if (eqv? 0 (string-count "--" char-set:letter)))
    (pass-if (eqv? 1 (string-count "a-" char-set:letter)))
    (pass-if (eqv? 1 (string-count "-a" char-set:letter)))
    (pass-if (eqv? 2 (string-count "aa" char-set:letter)))
    (pass-if (eqv? 0 (string-count "---" char-set:letter)))
    (pass-if (eqv? 1 (string-count "-a-" char-set:letter)))
    (pass-if (eqv? 1 (string-count "a--" char-set:letter)))
    (pass-if (eqv? 2 (string-count "aa-" char-set:letter)))
    (pass-if (eqv? 2 (string-count "a-a" char-set:letter)))
    (pass-if (eqv? 3 (string-count "aaa" char-set:letter)))
    (pass-if (eqv? 1 (string-count "--a" char-set:letter)))
    (pass-if (eqv? 2 (string-count "-aa" char-set:letter))))

  (with-test-prefix "proc"

    (pass-if (eqv? 0 (string-count "" char-alphabetic?)))
    (pass-if (eqv? 0 (string-count "-" char-alphabetic?)))
    (pass-if (eqv? 1 (string-count "a" char-alphabetic?)))
    (pass-if (eqv? 0 (string-count "--" char-alphabetic?)))
    (pass-if (eqv? 1 (string-count "a-" char-alphabetic?)))
    (pass-if (eqv? 1 (string-count "-a" char-alphabetic?)))
    (pass-if (eqv? 2 (string-count "aa" char-alphabetic?)))
    (pass-if (eqv? 0 (string-count "---" char-alphabetic?)))
    (pass-if (eqv? 1 (string-count "-a-" char-alphabetic?)))
    (pass-if (eqv? 1 (string-count "a--" char-alphabetic?)))
    (pass-if (eqv? 2 (string-count "aa-" char-alphabetic?)))
    (pass-if (eqv? 2 (string-count "a-a" char-alphabetic?)))
    (pass-if (eqv? 3 (string-count "aaa" char-alphabetic?)))
    (pass-if (eqv? 1 (string-count "--a" char-alphabetic?)))
    (pass-if (eqv? 2 (string-count "-aa" char-alphabetic?)))))

(with-test-prefix "string-replace"

  (pass-if "empty string(s), no indices"
    (string=? "" (string-replace "" "")))

  (pass-if "empty string(s), 1 index"
    (string=? "" (string-replace "" "" 0)))

  (pass-if "empty string(s), 2 indices"
    (string=? "" (string-replace "" "" 0 0)))

  (pass-if "empty string(s), 3 indices"
    (string=? "" (string-replace "" "" 0 0 0)))

  (pass-if "empty string(s), 4 indices"
    (string=? "" (string-replace "" "" 0 0 0 0)))

  (pass-if "no indices"
    (string=? "uu" (string-replace "foo bar" "uu")))

  (pass-if "one index"
    (string=? "fuu" (string-replace "foo bar" "uu" 1)))

  (pass-if "two indices"
    (string=? "fuuar" (string-replace "foo bar" "uu" 1 5)))

  (pass-if "three indices"
    (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1)))

  (pass-if "four indices"
    (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1 2))))

(with-test-prefix "string-tokenize"

  (pass-if "empty string, no char/pred"
    (zero? (length (string-tokenize ""))))

  (pass-if "empty string, charset"
    (zero? (length (string-tokenize "" char-set:punctuation))))

  (pass-if "no char/pred"
    (equal? '("foo" "bar" "!a") (string-tokenize "foo\tbar !a")))

  (pass-if "charset"
    (equal? '("foo" "bar" "!a") (string-tokenize "foo\tbar !a"
						char-set:graphic)))

  (pass-if "charset, start index"
    (equal? '("oo" "bar" "!a") (string-tokenize "foo\tbar !a"
						char-set:graphic 1)))

  (pass-if "charset, start and end index"
    (equal? '("oo" "bar" "!") (string-tokenize "foo\tbar !a"
					       char-set:graphic 1 9))))
;;;
;;; string-filter
;;;

(with-test-prefix "string-filter"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-filter "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-filter "abcde" "zzz")))

  (pass-if "empty string, char"
    (string=? "" (string-filter "" #\.)))

  (pass-if "empty string, charset"
    (string=? "" (string-filter "" char-set:punctuation)))

  (pass-if "empty string, pred"
    (string=? "" (string-filter "" char-alphabetic?)))

  (pass-if "char"
    (string=? "..." (string-filter ".foo.bar." #\.)))

  (pass-if "charset"
    (string=? "..." (string-filter ".foo.bar." char-set:punctuation)))

  (pass-if "pred"
    (string=? "foobar" (string-filter ".foo.bar." char-alphabetic?)))

  (pass-if "char, start index"
    (string=? ".." (string-filter ".foo.bar." #\. 2)))

  (pass-if "charset, start index"
    (string=? ".." (string-filter ".foo.bar." char-set:punctuation 2)))

  (pass-if "pred, start index"
    (string=? "oobar" (string-filter ".foo.bar." char-alphabetic? 2)))

  (pass-if "char, start and end index"
    (string=? "" (string-filter ".foo.bar." #\. 2 4)))

  (pass-if "charset, start and end index"
    (string=? "" (string-filter ".foo.bar." char-set:punctuation 2 4)))

  (pass-if "pred, start and end index"
    (string=? "oo" (string-filter ".foo.bar." char-alphabetic? 2 4)))

  (with-test-prefix "char"

    (pass-if (equal? "x" (string-filter "x" #\x)))
    (pass-if (equal? "xx" (string-filter "xx" #\x)))
    (pass-if (equal? "xx" (string-filter "xyx" #\x)))
    (pass-if (equal? "x" (string-filter "xyyy" #\x)))
    (pass-if (equal? "x" (string-filter "yyyx" #\x)))

    (pass-if (equal? "xx" (string-filter "xxx" #\x 1)))
    (pass-if (equal? "xx" (string-filter "xxx" #\x 0 2)))
    (pass-if (equal? "x" (string-filter "xyx" #\x 1)))
    (pass-if (equal? "x" (string-filter "yxx" #\x 0 2)))

    ;; leading and trailing removals
    (pass-if (string=? "" (string-filter "." #\x)))
    (pass-if (string=? "" (string-filter ".." #\x)))
    (pass-if (string=? "" (string-filter "..." #\x)))
    (pass-if (string=? "x" (string-filter ".x" #\x)))
    (pass-if (string=? "x" (string-filter "..x" #\x)))
    (pass-if (string=? "x" (string-filter "...x" #\x)))
    (pass-if (string=? "x" (string-filter "x." #\x)))
    (pass-if (string=? "x" (string-filter "x.." #\x)))
    (pass-if (string=? "x" (string-filter "x..." #\x)))
    (pass-if (string=? "x" (string-filter "...x..." #\x))))

  (with-test-prefix "charset"

    (let ((charset (char-set #\x #\y)))
      (pass-if (equal? "x" (string-filter "x" charset)))
      (pass-if (equal? "xx" (string-filter "xx" charset)))
      (pass-if (equal? "xy" (string-filter "xy" charset)))
      (pass-if (equal? "x" (string-filter "xaaa" charset)))
      (pass-if (equal? "y" (string-filter "aaay" charset)))

      (pass-if (equal? "yx" (string-filter "xyx" charset 1)))
      (pass-if (equal? "xy" (string-filter "xyx" charset 0 2)))
      (pass-if (equal? "x" (string-filter "xax" charset 1)))
      (pass-if (equal? "x" (string-filter "axx" charset 0 2))))

    ;; leading and trailing removals
    (pass-if (string=? "" (string-filter "." char-set:letter)))
    (pass-if (string=? "" (string-filter ".." char-set:letter)))
    (pass-if (string=? "" (string-filter "..." char-set:letter)))
    (pass-if (string=? "x" (string-filter ".x" char-set:letter)))
    (pass-if (string=? "x" (string-filter "..x" char-set:letter)))
    (pass-if (string=? "x" (string-filter "...x" char-set:letter)))
    (pass-if (string=? "x" (string-filter "x." char-set:letter)))
    (pass-if (string=? "x" (string-filter "x.." char-set:letter)))
    (pass-if (string=? "x" (string-filter "x..." char-set:letter)))
    (pass-if (string=? "x" (string-filter "...x..." char-set:letter)))))

;;;
;;; string-delete
;;;

(with-test-prefix "string-delete"

  (with-test-prefix "bad char_pred"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-delete "abcde" 123))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-delete "abcde" "zzz")))

  (pass-if "empty string, char"
    (string=? "" (string-delete "" #\.)))

  (pass-if "empty string, charset"
    (string=? "" (string-delete "" char-set:punctuation)))

  (pass-if "empty string, pred"
    (string=? "" (string-delete "" char-alphabetic?)))

  (pass-if "char"
    (string=? "foobar" (string-delete ".foo.bar." #\.)))

  (pass-if "charset"
    (string=? "foobar" (string-delete ".foo.bar." char-set:punctuation)))

  (pass-if "pred"
    (string=? "..." (string-delete ".foo.bar." char-alphabetic?)))

  (pass-if "char, start index"
    (string=? "oobar" (string-delete ".foo.bar." #\. 2)))

  (pass-if "charset, start index"
    (string=? "oobar" (string-delete ".foo.bar." char-set:punctuation 2)))

  (pass-if "pred, start index"
    (string=? ".." (string-delete ".foo.bar." char-alphabetic? 2)))

  (pass-if "char, start and end index"
    (string=? "oo" (string-delete ".foo.bar." #\. 2 4)))

  (pass-if "charset, start and end index"
    (string=? "oo" (string-delete ".foo.bar." char-set:punctuation 2 4)))

  (pass-if "pred, start and end index"
    (string=? "" (string-delete ".foo.bar." char-alphabetic? 2 4)))

  ;; leading and trailing removals
  (pass-if (string=? "" (string-delete "." #\.)))
  (pass-if (string=? "" (string-delete ".." #\.)))
  (pass-if (string=? "" (string-delete "..." #\.)))
  (pass-if (string=? "x" (string-delete ".x" #\.)))
  (pass-if (string=? "x" (string-delete "..x" #\.)))
  (pass-if (string=? "x" (string-delete "...x" #\.)))
  (pass-if (string=? "x" (string-delete "x." #\.)))
  (pass-if (string=? "x" (string-delete "x.." #\.)))
  (pass-if (string=? "x" (string-delete "x..." #\.)))
  (pass-if (string=? "x" (string-delete "...x..." #\.)))

  ;; leading and trailing removals
  (pass-if (string=? "" (string-delete "." char-set:punctuation)))
  (pass-if (string=? "" (string-delete ".." char-set:punctuation)))
  (pass-if (string=? "" (string-delete "..." char-set:punctuation)))
  (pass-if (string=? "x" (string-delete ".x" char-set:punctuation)))
  (pass-if (string=? "x" (string-delete "..x" char-set:punctuation)))
  (pass-if (string=? "x" (string-delete "...x" char-set:punctuation)))
  (pass-if (string=? "x" (string-delete "x." char-set:punctuation)))
  (pass-if (string=? "x" (string-delete "x.." char-set:punctuation)))
  (pass-if (string=? "x" (string-delete "x..." char-set:punctuation)))
  (pass-if (string=? "x" (string-delete "...x..." char-set:punctuation))))

(with-test-prefix "string-map"

  (with-test-prefix "bad proc"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-map 123 "abcde"))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-map "zzz" "abcde")))

  (pass-if "constant"
    (string=? "xxx" (string-map (lambda (c) #\x) "foo")))

  (pass-if "identity"
    (string=? "foo" (string-map identity "foo")))

  (pass-if "upcase"
    (string=? "FOO" (string-map char-upcase "foo"))))

(with-test-prefix "string-map!"

  (with-test-prefix "bad proc"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-map 123 "abcde"))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-map "zzz" "abcde")))

  (pass-if "constant"
    (let ((str (string-copy "foo")))
      (string-map! (lambda (c) #\x) str)
      (string=? str "xxx")))

  (pass-if "identity"
    (let ((str (string-copy "foo")))
      (string-map! identity str)
      (string=? str "foo")))

  (pass-if "upcase"
    (let ((str (string-copy "foo")))
      (string-map! char-upcase str)
      (string=? str "FOO"))))

(with-test-prefix "string-for-each"

  (with-test-prefix "bad proc"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-for-each 123 "abcde"))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-for-each "zzz" "abcde")))

  (pass-if "copy"
     (let* ((foo "foo")
            (bar (make-string (string-length foo)))
            (i 0))
       (string-for-each
        (lambda (c) (string-set! bar i c) (set! i (1+ i))) foo)
       (string=? foo bar))))

(with-test-prefix "string-for-each-index"

  (with-test-prefix "bad proc"

    (pass-if-exception "integer" exception:wrong-type-arg
      (string-for-each-index 123 "abcde"))

    (pass-if-exception "string" exception:wrong-type-arg
      (string-for-each-index "zzz" "abcde")))

  (pass-if "index"
     (let* ((foo "foo")
            (bar (make-string (string-length foo))))
       (string-for-each-index
        (lambda (i) (string-set! bar i (string-ref foo i))) foo)
       (string=? foo bar))))


code:
;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions.
;;;; Martin Grabmueller, 2001-07-16
;;;;
;;;; Copyright (C) 2001, 2006 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-suite test-srfi-14)
  :use-module (srfi srfi-14)
  :use-module (srfi srfi-1) ;; `every'
  :use-module (test-suite lib))

(define exception:invalid-char-set-cursor
  (cons 'misc-error "^invalid character set cursor"))

(define exception:non-char-return
  (cons 'misc-error "returned non-char"))

(with-test-prefix "char-set?"

  (pass-if "success on empty set"
    (char-set? (char-set)))

  (pass-if "success on non-empty set"
    (char-set? char-set:printing))

  (pass-if "failure on empty set"
    (not (char-set? #t))))

(with-test-prefix "char-set="
  (pass-if "success, no arg"
    (char-set=))

  (pass-if "success, one arg"
    (char-set= char-set:lower-case))

  (pass-if "success, two args"
    (char-set= char-set:upper-case char-set:upper-case))

  (pass-if "failure, first empty"
    (not (char-set= (char-set) (char-set #\a))))

  (pass-if "failure, second empty"
    (not (char-set= (char-set #\a) (char-set))))

  (pass-if "success, more args"
    (char-set= char-set:blank char-set:blank char-set:blank)))

(with-test-prefix "char-set<="
  (pass-if "success, no arg"
    (char-set<=))

  (pass-if "success, one arg"
    (char-set<= char-set:lower-case))

  (pass-if "success, two args"
    (char-set<= char-set:upper-case char-set:upper-case))

  (pass-if "success, first empty"
    (char-set<= (char-set) (char-set #\a)))

  (pass-if "failure, second empty"
    (not (char-set<= (char-set #\a) (char-set))))

  (pass-if "success, more args, equal"
    (char-set<= char-set:blank char-set:blank char-set:blank))

  (pass-if "success, more args, not equal"
    (char-set<= char-set:blank
		(char-set-adjoin char-set:blank #\F)
		(char-set-adjoin char-set:blank #\F #\o))))

(with-test-prefix "char-set-hash"
   (pass-if "empty set, bound"
      (let ((h (char-set-hash char-set:empty 31)))
	(and h (number? h) (exact? h) (>= h 0) (< h 31))))

   (pass-if "empty set, no bound"
      (let ((h (char-set-hash char-set:empty)))
	(and h (number? h) (exact? h) (>= h 0))))

   (pass-if "full set, bound"
      (let ((h (char-set-hash char-set:full 31)))
	(and h (number? h) (exact? h) (>= h 0) (< h 31))))

   (pass-if "full set, no bound"
      (let ((h (char-set-hash char-set:full)))
	(and h (number? h) (exact? h) (>= h 0))))

   (pass-if "other set, bound"
      (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
	(and h (number? h) (exact? h) (>= h 0) (< h 31))))

   (pass-if "other set, no bound"
      (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
	(and h (number? h) (exact? h) (>= h 0)))))

(with-test-prefix "char-set cursor"

  (pass-if-exception "invalid character cursor"
     exception:invalid-char-set-cursor
     (let* ((cs (char-set #\B #\r #\a #\z))
	    (cc (char-set-cursor cs)))
       (char-set-ref cs 1000)))

  (pass-if "success"
     (let* ((cs (char-set #\B #\r #\a #\z))
	    (cc (char-set-cursor cs)))
       (char? (char-set-ref cs cc))))

  (pass-if "end of set fails"
     (let* ((cs (char-set #\a))
	    (cc (char-set-cursor cs)))
       (not (end-of-char-set? cc))))

  (pass-if "end of set succeeds, empty set"
     (let* ((cs (char-set))
	    (cc (char-set-cursor cs)))
       (end-of-char-set? cc)))

  (pass-if "end of set succeeds, non-empty set"
     (let* ((cs (char-set #\a))
	    (cc (char-set-cursor cs))
	    (cc (char-set-cursor-next cs cc)))
       (end-of-char-set? cc))))

(with-test-prefix "char-set-fold"

  (pass-if "count members"
     (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))

  (pass-if "copy set"
     (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
				      (char-set) (char-set #\a #\b))) 2)))

(with-test-prefix "char-set-unfold"

  (pass-if "create char set"
     (char-set= char-set:full
		(char-set-unfold (lambda (s) (= s 256)) integer->char
				 (lambda (s) (+ s 1)) 0)))
  (pass-if "create char set (base set)"
     (char-set= char-set:full
		(char-set-unfold (lambda (s) (= s 256)) integer->char
				 (lambda (s) (+ s 1)) 0 char-set:empty))))

(with-test-prefix "char-set-unfold!"

  (pass-if "create char set"
     (char-set= char-set:full
		(char-set-unfold! (lambda (s) (= s 256)) integer->char
				 (lambda (s) (+ s 1)) 0
				 (char-set-copy char-set:empty))))

  (pass-if "create char set"
     (char-set= char-set:full
		(char-set-unfold! (lambda (s) (= s 32)) integer->char
				 (lambda (s) (+ s 1)) 0
				 (char-set-copy char-set:full)))))

(with-test-prefix "char-set-for-each"

  (pass-if "copy char set"
     (= (char-set-size (let ((cs (char-set)))
			 (char-set-for-each
			  (lambda (c) (char-set-adjoin! cs c))
			  (char-set #\a #\b))
			 cs))
	2)))

(with-test-prefix "char-set-map"

  (pass-if "upper case char set"
     (char-set= (char-set-map char-upcase char-set:lower-case)
		char-set:upper-case)))

(with-test-prefix "string->char-set"

  (pass-if "some char set"
     (let ((chars '(#\g #\u #\i #\l #\e)))
       (char-set= (list->char-set chars)
		  (string->char-set (apply string chars))))))

;; Make sure we get an ASCII charset and character classification.
(if (defined? 'setlocale) (setlocale LC_CTYPE "C"))

(with-test-prefix "standard char sets (ASCII)"

  (pass-if "char-set:letter"
     (char-set= (string->char-set
		 (string-append "abcdefghijklmnopqrstuvwxyz"
				"ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
		char-set:letter))

  (pass-if "char-set:punctuation"
     (char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
		char-set:punctuation))

  (pass-if "char-set:symbol"
     (char-set= (string->char-set "$+<=>^`|~")
		char-set:symbol))

  (pass-if "char-set:letter+digit"
     (char-set= char-set:letter+digit
                (char-set-union char-set:letter char-set:digit)))

  (pass-if "char-set:graphic"
     (char-set= char-set:graphic
                (char-set-union char-set:letter char-set:digit
                                char-set:punctuation char-set:symbol)))

  (pass-if "char-set:printing"
      (char-set= char-set:printing
                 (char-set-union char-set:whitespace char-set:graphic))))

;;;
;;; 8-bit charsets.
;;;
;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
;;; SRFI-14 for implementations supporting this charset is well-defined.
;;;

(define (every? pred lst)
  (not (not (every pred lst))))

(define (find-latin1-locale)
  ;; Try to find and install an ISO-8859-1 locale.  Return `#f' on failure.
  (if (defined? 'setlocale)
      (let loop ((locales (map (lambda (lang)
				 (string-append lang ".iso88591"))
			       '("de_DE" "en_GB" "en_US" "es_ES"
				 "fr_FR" "it_IT"))))
	(if (null? locales)
	    #f
	    (if (false-if-exception (setlocale LC_CTYPE (car locales)))
		(car locales)
		(loop (cdr locales)))))
      #f))

(define %latin1 (find-latin1-locale))

(with-test-prefix "Latin-1 (8-bit charset)"

  ;; Note: the membership tests below are not exhaustive.

  (pass-if "char-set:letter (membership)"
     (if (not %latin1)
	 (throw 'unresolved)
	 (let ((letters (char-set->list char-set:letter)))
	   (every? (lambda (8-bit-char)
		     (memq 8-bit-char letters))
		   (append '(#\a #\b #\c)             ;; ASCII
			   (string->list "���������") ;; French
			   (string->list "���������"))))))

  (pass-if "char-set:letter (size)"
     (if (not %latin1)
	 (throw 'unresolved)
	 (= (char-set-size char-set:letter) 117)))

  (pass-if "char-set:lower-case (size)"
     (if (not %latin1)
	 (throw 'unresolved)
	 (= (char-set-size char-set:lower-case) (+ 26 33))))

  (pass-if "char-set:upper-case (size)"
     (if (not %latin1)
	 (throw 'unresolved)
	 (= (char-set-size char-set:upper-case) (+ 26 30))))

  (pass-if "char-set:punctuation (membership)"
     (if (not %latin1)
	 (throw 'unresolved)
	 (let ((punctuation (char-set->list char-set:punctuation)))
	   (every? (lambda (8-bit-char)
		     (memq 8-bit-char punctuation))
		   (append '(#\! #\. #\?)            ;; ASCII
			   (string->list "��")       ;; Castellano
			   (string->list "��"))))))  ;; French

  (pass-if "char-set:letter+digit"
     (char-set= char-set:letter+digit
                (char-set-union char-set:letter char-set:digit)))

  (pass-if "char-set:graphic"
     (char-set= char-set:graphic
                (char-set-union char-set:letter char-set:digit
                                char-set:punctuation char-set:symbol)))

  (pass-if "char-set:printing"
     (char-set= char-set:printing
                (char-set-union char-set:whitespace char-set:graphic))))

;; Local Variables:
;; mode: scheme
;; coding: latin-1
;; End:

license: unknown


code:
;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*-
;;;;
;;;; Copyright (C) 2001, 2003, 2005, 2006 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-suite test-srfi-17)
  :use-module (test-suite lib)
  :use-module (srfi srfi-17))

(pass-if "cond-expand srfi-17"
  (cond-expand (srfi-17 #t)
	       (else    #f)))

;;
;; car
;;

(with-test-prefix "car"

  ;; this test failed in guile 1.8.1 and 1.6.8 and earlier, since `define'
  ;; didn't set a name on a procedure-with-setter
  (pass-if "procedure-name"
    (if (memq 'procnames (debug-options)) ;; enabled by default
	(eq? 'car (procedure-name car))
	(throw 'unsupported)))

  (pass-if "set! (car x)"
    (let ((lst (list 1)))
      (set! (car lst) 2)
      (eqv? 2 (car lst)))))

;;
;; set!
;;

(define %some-variable #f)

(with-test-prefix "set!"

  (with-test-prefix "target is not procedure with setter"

    (pass-if-exception "(set! (symbol->string 'x) 1)"
      exception:wrong-type-arg
      (set! (symbol->string 'x) 1))

    (pass-if-exception "(set! '#f 1)"
      exception:bad-variable
      (eval '(set! '#f 1) (interaction-environment))))

  (with-test-prefix "target uses macro"

    (pass-if "(set! (@@ ...) 1)"
      (eval '(set! (@@ (test-suite test-srfi-17) %some-variable) 1)
            (interaction-environment))
      (equal? %some-variable 1))

    ;; The `(quote x)' below used to be memoized as an infinite list before
    ;; Guile 1.8.3.
    (pass-if-exception "(set! 'x 1)"
      exception:bad-variable
      (eval '(set! 'x 1) (interaction-environment)))))

;;
;; setter
;;

(with-test-prefix "setter"

  (pass-if-exception "set! (setter x)" (cons 'misc-error ".*")
    (set! (setter car) noop))

  (pass-if "car"
    (eq? set-car! (setter car))))


code:
;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
;;;; 	Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007 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

;; SRFI-19 overrides current-date, so we have to do the test in a
;; separate module, or later tests will fail.

(define-module (test-suite test-srfi-19)
  :duplicates (last)  ;; avoid warning about srfi-19 replacing `current-time'
  :use-module (test-suite lib)
  :use-module (srfi srfi-19)
  :use-module (ice-9 format))

(define (with-tz* tz thunk)
  "Temporarily set the TZ environment variable to the passed string
value and call THUNK."
  (let ((old-tz #f))
    (dynamic-wind
	(lambda ()
	  (set! old-tz (getenv "TZ"))
	  (putenv (format "TZ=~A" tz)))
	thunk
	(lambda ()
	  (if old-tz
	      (putenv (format "TZ=~A" old-tz))
	      (putenv "TZ"))))))

(defmacro with-tz (tz . body)
  `(with-tz* ,tz (lambda () ,@body)))

(define (test-integral-time-structure date->time)
  "Test whether the given DATE->TIME procedure creates a time
structure with integral seconds.  (The seconds shall be maintained as
integers, or precision may go away silently.  The SRFI-19 reference
implementation was not OK for Guile in this respect because of Guile's
incomplete numerical tower implementation.)"
  (pass-if (format "~A makes integer seconds"
		   date->time)
	   (exact? (time-second
		    (date->time (make-date 0 0 0 12 1 6 2001 0))))))

(define (test-time->date time->date date->time)
  (pass-if (format "~A works"
		   time->date)
	   (begin
	     (time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
	     #t)))

(define (test-dst time->date date->time)
  (pass-if (format "~A respects local DST if no TZ-OFFSET given"
		   time->date)
	   (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
	     ;; on 2001-06-01, there should be 4 hours zone offset
	     ;; between EST (EDT) and GMT
	     (= (date-zone-offset
		 (with-tz "EST5EDT"
		   (time->date time)))
		-14400))))

(define-macro (test-time-conversion a b)
  (let* ((a->b-sym (symbol-append a '-> b))
	 (b->a-sym (symbol-append b '-> a)))
    `(pass-if (format "~A and ~A work and are inverses of each other"
		      ',a->b-sym ',b->a-sym)
	      (let ((time (make-time ,a 12345 67890123)))
		(time=? time (,b->a-sym (,a->b-sym time)))))))

(define (test-time-comparison cmp a b)
  (pass-if (format #f "~A works" cmp)
           (cmp a b)))

(define (test-time-arithmetic op a b res)
  (pass-if (format #f "~A works" op)
           (time=? (op a b) res)))

;; return true if time objects X and Y are equal
(define (time-equal? x y)
  (and (eq?  (time-type x)       (time-type y))
       (eqv? (time-second x)     (time-second y))
       (eqv? (time-nanosecond x) (time-nanosecond y))))

(with-test-prefix "SRFI date/time library"
  ;; check for typos and silly errors
  (pass-if "date-zone-offset is defined"
	   (and (defined? 'date-zone-offset)
		date-zone-offset
		#t))
  (pass-if "add-duration is defined"
	   (and (defined? 'add-duration)
		add-duration
		#t))
  (pass-if "(current-time time-tai) works"
	   (time? (current-time time-tai)))
  (pass-if "(current-time time-process) works"
           (time? (current-time time-process)))
  (test-time-conversion time-utc time-tai)
  (test-time-conversion time-utc time-monotonic)
  (test-time-conversion time-tai time-monotonic)
  (pass-if "string->date works"
	   (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
		  #t))
  ;; check for code paths where reals were passed to quotient, which
  ;; doesn't work in Guile (and is unspecified in R5RS)
  (test-time->date time-utc->date date->time-utc)
  (test-time->date time-tai->date date->time-tai)
  (test-time->date time-monotonic->date date->time-monotonic)
  (pass-if "Fractional nanoseconds are handled"
	   (begin (make-time time-duration 1000000000.5 0) #t))
  ;; the seconds in a time shall be maintained as integers, or
  ;; precision may silently go away
  (test-integral-time-structure date->time-utc)
  (test-integral-time-structure date->time-tai)
  (test-integral-time-structure date->time-monotonic)
  ;; check for DST and zone related problems
  (pass-if "date->time-utc is the inverse of time-utc->date"
	   (let ((time (date->time-utc
			(make-date 0 0 0 14 1 6 2001 7200))))
	     (time=? time
		     (date->time-utc (time-utc->date time 7200)))))
  (test-dst time-utc->date date->time-utc)
  (test-dst time-tai->date date->time-tai)
  (test-dst time-monotonic->date date->time-monotonic)
  (test-dst julian-day->date date->julian-day)
  (test-dst modified-julian-day->date date->modified-julian-day)

  (pass-if "`date->julian-day' honors timezone"
    (let ((now (current-date -14400)))
      (time=? (date->time-utc (julian-day->date (date->julian-day now)))
              (date->time-utc now))))

  (pass-if "string->date respects local DST if no time zone is read"
	   (time=? (date->time-utc
		    (with-tz "EST5EDT"
		      (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
		   (date->time-utc
		    (make-date 0 0 0 12 1 6 2001 0))))
  ;; check time comparison procedures
  (let* ((time1 (make-time time-monotonic 0 0))
         (time2 (make-time time-monotonic 0 0))
         (time3 (make-time time-monotonic 385907 998360432))
         (time4 (make-time time-monotonic 385907 998360432)))
    (test-time-comparison time<=? time1 time3)
    (test-time-comparison time<?  time1 time3)
    (test-time-comparison time=?  time1 time2)
    (test-time-comparison time>=? time3 time3)
    (test-time-comparison time>?  time3 time2))
  ;; check time arithmetic procedures
  (let* ((time1 (make-time time-monotonic 0 0))
         (time2 (make-time time-monotonic 385907 998360432))
         (diff (time-difference time2 time1)))
    (test-time-arithmetic add-duration time1 diff time2)
    (test-time-arithmetic subtract-duration time2 diff time1))

  (with-test-prefix "date->time-tai"
    ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
    ;; seconds of TAI in date->time-tai
    (pass-if "31dec98 23:59:59"
      (time-equal? (make-time time-tai 0 915148830)
		   (date->time-tai (make-date 0 59 59 23 31 12 1998 0))))
    (pass-if "1jan99 0:00:00"
      (time-equal? (make-time time-tai 0 915148832)
		   (date->time-tai (make-date 0 0  0  0   1  1 1999 0))))

    ;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2
    ;; seconds of TAI in date->time-tai
    (pass-if "31dec05 23:59:59"
      (time-equal? (make-time time-tai 0 1136073631)
		   (date->time-tai (make-date 0 59 59 23 31 12 2005 0))))
    (pass-if "1jan06 0:00:00"
      (time-equal? (make-time time-tai 0 1136073633)
		   (date->time-tai (make-date 0 0  0  0   1  1 2006 0)))))

  (with-test-prefix "date-week-number"
    (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
    (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))
    (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))))

;; Local Variables:
;; eval: (put 'with-tz 'scheme-indent-function 1)
;; End:


code:
; CONFIDENCE TEST FOR IMPLEMENTATION OF SRFI-26
; =============================================
;
; Sebastian.Egner@philips.com, 3-Jun-2002.
;
; This file checks a few assertions about the implementation.
; If you run it and no error message is issued, the implementation
; is correct on the cases that have been tested.
;
; compliance:
;   Scheme R5RS with
;     SRFI-23: error
;
; loading this file into Scheme 48 0.57 after 'cut.scm' has been loaded:
;   ,open srfi-23
;   ,load check.scm

; (check expr)
;    evals expr and issues an error if it is not #t.

(define-module (test-srfi-26)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-26))

(define (check expr)
  (pass-if "cut/cute" (eval expr (interaction-environment))))

; (check-all)
;    runs several tests on cut and reports.

(define (check-all)
  (for-each
   check
   '( ; cuts
     (equal? ((cut list)) '())
     (equal? ((cut list <...>)) '())
     (equal? ((cut list 1)) '(1))
     (equal? ((cut list <>) 1) '(1))
     (equal? ((cut list <...>) 1) '(1))
     (equal? ((cut list 1 2)) '(1 2))
     (equal? ((cut list 1 <>) 2) '(1 2))
     (equal? ((cut list 1 <...>) 2) '(1 2))
     (equal? ((cut list 1 <...>) 2 3 4) '(1 2 3 4))
     (equal? ((cut list 1 <> 3 <>) 2 4) '(1 2 3 4))
     (equal? ((cut list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
     (equal? (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y)) '(ok))
     (equal?
      (let ((a 0))
	(map (cut + (begin (set! a (+ a 1)) a) <>)
	     '(1 2))
	a)
      2)
      ; cutes
     (equal? ((cute list)) '())
     (equal? ((cute list <...>)) '())
     (equal? ((cute list 1)) '(1))
     (equal? ((cute list <>) 1) '(1))
     (equal? ((cute list <...>) 1) '(1))
     (equal? ((cute list 1 2)) '(1 2))
     (equal? ((cute list 1 <>) 2) '(1 2))
     (equal? ((cute list 1 <...>) 2) '(1 2))
     (equal? ((cute list 1 <...>) 2 3 4) '(1 2 3 4))
     (equal? ((cute list 1 <> 3 <>) 2 4) '(1 2 3 4))
     (equal? ((cute list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
     (equal?
      (let ((a 0))
	(map (cute + (begin (set! a (+ a 1)) a) <>)
	     '(1 2))
	a)
      1))))

; run the checks when loading
(with-test-prefix "SRFI-26"
  (check-all))


code:
;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2006 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
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-srfi-31)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-31))

(with-test-prefix "rec special form"

  (pass-if-exception "bogus variable" '(misc-error . ".*")
    (rec #:foo))

  (pass-if "rec expressions"
    (let ((ones-list (rec ones (cons 1 (delay ones)))))
      (and (= 1 (car ones-list))
           (= 1 (car (force (cdr ones-list)))))))

  (pass-if "rec functions"
    (let ((test-func (rec (add-upto n)
                       (if (positive? n)
                           (+ n (add-upto (- n 1)))
                           0))))
      (= 15 (test-func 5)))))


code:
;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
;;;;
;;;; 	Copyright (C) 2003, 2004, 2006, 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-suite test-srfi-34)
  :duplicates (last)  ;; avoid warning about srfi-34 replacing `raise'
  :use-module (test-suite lib)
  :use-module (srfi srfi-13)
  :use-module (srfi srfi-34))

(define (expr-prints-and-evals-to? expr printout result)
  (let ((actual-result *unspecified*))
    (let ((actual-printout
	   (string-trim-both
	    (with-output-to-string
	      (lambda ()
		(set! actual-result
		      (eval expr (current-module))))))))
      ;;(write (list actual-printout printout actual-result result))
      ;;(newline)
      (and (equal? actual-printout printout)
	   (equal? actual-result result)))))

(with-test-prefix "SRFI 34"

  (pass-if "cond-expand"
    (cond-expand (srfi-34 #t)
		 (else    #f)))

  (pass-if "example 1"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "condition: ")
					  (write x)
					  (newline)
					  (k 'exception))
					(lambda ()
					  (+ 1 (raise 'an-error))))))
	    "condition: an-error"
	    'exception))

  ;; SRFI 34 specifies that the behaviour of the call/cc expression
  ;; after printing "something went wrong" is unspecified, which is
  ;; tricky to test for in a positive way ...  Guile behaviour at time
  ;; of writing is to signal a "lazy-catch handler did return" error,
  ;; which feels about right to me.
  (pass-if "example 2"
	   (expr-prints-and-evals-to?
	    '(false-if-exception
	      (call-with-current-continuation
	       (lambda (k)
		 (with-exception-handler (lambda (x)
					   (display "something went wrong")
					   (newline)
					   'dont-care)
					 (lambda ()
					   (+ 1 (raise 'an-error)))))))
	    "something went wrong"
	    #f))

  (pass-if "example 3"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     (else
		      (display "condition: ")
		      (write condition)
		      (newline)
		      'exception))
		    (+ 1 (raise 'an-error)))
	    "condition: an-error"
	    'exception))

  (pass-if "example 4"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     (else
		      (display "something went wrong")
		      (newline)
		      'dont-care))
		    (+ 1 (raise 'an-error)))
	    "something went wrong"
	    'dont-care))

  (pass-if "example 5"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "reraised ") (write x) (newline)
					  (k 'zero))
					(lambda ()
					  (guard (condition
						  ((positive? condition) 'positive)
						  ((negative? condition) 'negative))
						 (raise 1))))))
	    ""
	    'positive))

  (pass-if "example 6"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "reraised ") (write x) (newline)
					  (k 'zero))
					(lambda ()
					  (guard (condition
						  ((positive? condition) 'positive)
						  ((negative? condition) 'negative))
						 (raise -1))))))
	    ""
	    'negative))

  (pass-if "example 7"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "reraised ") (write x) (newline)
					  (k 'zero))
					(lambda ()
					  (guard (condition
						  ((positive? condition) 'positive)
						  ((negative? condition) 'negative))
						 (raise 0))))))
	    "reraised 0"
	    'zero))

  (pass-if "example 8"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     ((assq 'a condition) => cdr)
		     ((assq 'b condition)))
		    (raise (list (cons 'a 42))))
	    ""
	    42))

  (pass-if "example 9"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     ((assq 'a condition) => cdr)
		     ((assq 'b condition)))
		    (raise (list (cons 'b 23))))
	    ""
	    '(b . 23)))

  (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
           ;; In Guile 1.8.5 and earlier, unwinders would be called before
           ;; the exception handler, which reads "The handler is called in
           ;; the dynamic environment of the call to `raise'".
           (call/cc
            (lambda (return)
              (let ((inside? #f))
                (with-exception-handler
                 (lambda (c)
                   ;; This handler must be called before the unwinder below.
                   (return inside?))
                 (lambda ()
                   (dynamic-wind
                     (lambda ()
                       (set! inside? #t))
                     (lambda ()
                       (raise 'some-exception))
                     (lambda ()
                       ;; This unwinder should not be executed before the
                       ;; handler is called.
                       (set! inside? #f))))))))))


code:
;;;; srfi-35.test --- Test suite for SRFI-35               -*- Scheme -*-
;;;; Ludovic Court�s <ludo@gnu.org>
;;;;
;;;; 	Copyright (C) 2007, 2008, 2009 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-35)
  :use-module (test-suite lib)
  :use-module (srfi srfi-35))

(with-test-prefix "cond-expand"
  (pass-if "srfi-35"
    (cond-expand (srfi-35 #t)
                 (else    #f))))

(with-test-prefix "condition types"
  (pass-if "&condition"
    (condition-type? &condition))

  (pass-if "make-condition-type"
    (condition-type? (make-condition-type 'foo &condition '(a b))))

  (pass-if "struct-vtable-name"
    (let ((ct  (make-condition-type 'chbouib &condition '(a b))))
      (eq? 'chbouib (struct-vtable-name ct)))))

(with-test-prefix "conditions"

  (pass-if "&condition"
    (let ((c (make-condition &condition)))
      (and (condition? c)
           (condition-has-type? c &condition))))

  (pass-if "simple condition"
    (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
           (c  (make-condition ct 'b 1 'a 0)))
      (and (condition? c)
           (condition-has-type? c ct))))

  (pass-if "simple condition with inheritance"
    (let* ((top (make-condition-type 'foo &condition '(a b)))
           (ct  (make-condition-type 'bar top '(c d)))
           (c   (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
      (and (condition? c)
           (condition-has-type? c ct)
           (condition-has-type? c top))))

  (pass-if "condition-ref"
    (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
           (c  (make-condition ct 'b 1 'a 0)))
      (and (eq? (condition-ref c 'a) 0)
           (eq? (condition-ref c 'b) 1))))

  (pass-if "condition-ref with inheritance"
    (let* ((top (make-condition-type 'foo &condition '(a b)))
           (ct  (make-condition-type 'bar top '(c d)))
           (c   (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
      (and (eq? (condition-ref c 'a) 0)
           (eq? (condition-ref c 'b) 1)
           (eq? (condition-ref c 'c) 2)
           (eq? (condition-ref c 'd) 3))))

  (pass-if "extract-condition"
    (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
           (c  (make-condition ct 'b 1 'a 0)))
      (equal? c (extract-condition c ct)))))

(with-test-prefix "compound conditions"
  (pass-if "condition-has-type?"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (and (condition? c)
           (condition-has-type? c t1)
           (condition-has-type? c t2))))

  (pass-if "condition-ref"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (equal? (map (lambda (field)
                     (condition-ref c field))
                   '(a b c d))
              '(0 1 2 3))))

  (pass-if "condition-ref with same-named fields"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(a c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'a -1 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (equal? (map (lambda (field)
                     (condition-ref c field))
                   '(a b c d))
              '(0 1 2 3))))

  (pass-if "extract-condition"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (and (equal? c1 (extract-condition c t1))
           (equal? c2 (extract-condition c t2)))))

  (pass-if "extract-condition with same-named fields"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(a c)))
           (c1 (make-condition t1 'a 0  'b 1))
           (c2 (make-condition t2 'a -1 'c 2))
           (c  (make-compound-condition c1 c2)))
      (and (equal? c1 (extract-condition c t1))
           (equal? c2 (extract-condition c t2))))))

(with-test-prefix "syntax"
  (pass-if "define-condition-type"
    (let ((m (current-module)))
      (eval '(define-condition-type &chbouib &condition
               chbouib?
               (one   chbouib-one)
               (two   chbouib-two))
            m)
      (eval '(and (condition-type? &chbouib)
                  (procedure? chbouib?)
                  (let ((c (make-condition &chbouib 'one 1 'two 2)))
                    (and (condition? c)
                         (chbouib? c)
                         (eq? (chbouib-one c) 1)
                         (eq? (chbouib-two c) 2))))
            m)))

  (pass-if "condition"
    (let* ((t (make-condition-type 'chbouib &condition '(a b)))
           (c (condition (t (b 2) (a 1)))))
      (and (condition? c)
           (condition-has-type? c t)
           (equal? (map (lambda (f)
                          (condition-ref c f))
                        '(a b))
                   '(1 2)))))

  (pass-if-exception "condition with missing fields"
    exception:miscellaneous-error
    (let ((t (make-condition-type 'chbouib &condition '(a b c))))
      (condition (t (a 1) (b 2)))))

  (pass-if "compound condition"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (condition (t1 (a 0) (b 1))
                          (t2 (c 2) (d 3)))))
      (and (equal? c1 (extract-condition c t1))
           (equal? c2 (extract-condition c t2))))))

;;;
;;; Examples from the SRFI.
;;;

(define-condition-type &c &condition
  c?
  (x c-x))

(define-condition-type &c1 &c
  c1?
  (a c1-a))

(define-condition-type &c2 &c
  c2?
  (b c2-b))

(define v1
  (make-condition &c1 'x "V1" 'a "a1"))

(define v2
  (condition (&c2 (x "V2") (b "b2"))))

(define v3
  (condition (&c1 (x "V3/1") (a "a3"))
             (&c2 (b "b3"))))

(define v4
  (make-compound-condition v1 v2))

(define v5
  (make-compound-condition v2 v3))

(with-test-prefix "examples"

  (pass-if "v1"
    (condition? v1))

  (pass-if "(c? v1)"
    (c? v1))

  (pass-if "(c1? v1)"
    (c1? v1))

  (pass-if "(not (c2? v1))"
    (not (c2? v1)))

  (pass-if "(c-x v1)"
    (equal? (c-x v1) "V1"))

  (pass-if "(c1-a v1)"
    (equal? (c1-a v1) "a1"))

  (pass-if "v2"
    (condition? v2))

  (pass-if "(c? v2)"
    (c? v2))

  (pass-if "(c2? v2)"
    (c2? v2))

  (pass-if "(not (c1? v2))"
    (not (c1? v2)))

  (pass-if "(c-x v2)"
    (equal? (c-x v2) "V2"))

  (pass-if "(c2-b v2)"
    (equal? (c2-b v2) "b2"))

  (pass-if "v3"
    (condition? v3))

  (pass-if "(c? v3)"
    (c? v3))

  (pass-if "(c1? v3)"
    (c1? v3))

  (pass-if "(c2? v3)"
    (c2? v3))

  (pass-if "(c-x v3)"
    (equal? (c-x v3) "V3/1"))

  (pass-if "(c1-a v3)"
    (equal? (c1-a v3) "a3"))

  (pass-if "(c2-b v3)"
    (equal? (c2-b v3) "b3"))

  (pass-if "v4"
    (condition? v4))

  (pass-if "(c? v4)"
    (c? v4))

  (pass-if "(c1? v4)"
    (c1? v4))

  (pass-if "(c2? v4)"
    (c2? v4))

  (pass-if "(c-x v4)"
    (equal? (c-x v4) "V1"))

  (pass-if "(c1-a v4)"
    (equal? (c1-a v4) "a1"))

  (pass-if "(c2-b v4)"
    (equal? (c2-b v4) "b2"))

  (pass-if "v5"
    (condition? v5))

  (pass-if "(c? v5)"
    (c? v5))

  (pass-if "(c1? v5)"
    (c1? v5))

  (pass-if "(c2? v5)"
    (c2? v5))

  (pass-if "(c-x v5)"
    (equal? (c-x v5) "V2"))

  (pass-if "(c1-a v5)"
    (equal? (c1-a v5) "a3"))

  (pass-if "(c2-b v5)"
    (equal? (c2-b v5) "b2")))

;;; Local Variables:
;;; coding: latin-1
;;; End:


code:
;;;; 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)
			 '()))))

)


code:
;;;; srfi-39.test --- -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 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-39)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-39)
  #:duplicates (last) ;; avoid warning about srfi-34 replacing `raise'
  )

(define a (make-parameter 3))
(define b (make-parameter 4))

(define (check a b a-val b-val)
  (and (eqv? (a) a-val)) (eqv? (b) b-val))

(define c (make-parameter 2 (lambda (x) (if (< x 10) x 10))))
(define d (make-parameter 15 (lambda (x) (if (< x 10) x 10))))

(with-test-prefix "SRFI-39"

  (pass-if "test 1"
    (check a b 3 4))

  (pass-if "test 2"
    (parameterize ((a 2) (b 1))
      (and (check a b 2 1)
	   (parameterize ((b 8))
	     (check a b 2 8)))))

  (pass-if "test 3"
    (check a b 3 4))

  (pass-if "test 4"
    (check c d 2 10))

  (pass-if "test 5"
    (parameterize ((a 0) (b 1) (c 98) (d 9))
      (and (check a b 0 1)
           (check c d 10 9)
           (parameterize ((c (a)) (d (b)))
	     (and (check a b 0 1)
		  (check c d 0 1))))))

  (pass-if "SRFI-34"
    (let ((inside? (make-parameter #f)))
      (call/cc (lambda (return)
                 (with-exception-handler
                  (lambda (c)
                    ;; This handler should be called in the dynamic
                    ;; environment installed by `parameterize'.
                    (return (inside?)))
                  (lambda ()
                    (parameterize ((inside? #t))
                      (raise 'some-exception)))))))))

(let ()
  (define (test-ports param new-port new-port-2)
    (let ((old-port (param)))

      (pass-if "new value"
	(parameterize ((param new-port))
	  (eq? (param) new-port)))

      (pass-if "set value"
	(parameterize ((param old-port))
	  (param new-port)
	  (eq? (param) new-port)))

      (pass-if "old restored"
	(parameterize ((param new-port))
	  #f)
	(eq? (param) old-port))

      (pass-if "throw exit"
	(catch 'bail
	  (lambda ()
	    (parameterize ((param new-port))
	      (throw 'bail)))
	  (lambda args #f))
	(eq? (param) old-port))

      (pass-if "call/cc re-enter"
	(let ((cont  #f)
	      (count 0)
	      (port  #f)
	      (good  #t))
	  (parameterize ((param new-port))
	    (call/cc (lambda (k) (set! cont k)))
	    (set! count (1+ count))
	    (set! port (param))
	    (if (= 1 count) (param new-port-2)))
	  (set! good (and good (eq? (param) old-port)))
	  (case count
	    ((1)
	     (set! good (and good (eq? port new-port)))
	     ;; re-entering should give new-port-2 left there last time
	     (cont))
	    ((2)
	     (set! good (and good (eq? port new-port-2)))))
	  good))

      (pass-if "original unchanged"
	(eq? (param) old-port))))

  (with-test-prefix "current-input-port"
    (test-ports current-input-port
		(open-input-string "xyz") (open-input-string "xyz")))

  (with-test-prefix "current-output-port"
    (test-ports current-output-port
		(open-output-string) (open-output-string)))

  (with-test-prefix "current-error-port"
    (test-ports current-error-port
		(open-output-string) (open-output-string))))