code:
;;;; i18n.test --- Exercise the i18n API.  -*- coding: utf-8; mode: scheme; -*-
;;;;
;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; 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 3 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 i18n)
  :use-module (ice-9 i18n)
  :use-module (srfi srfi-1)
  :use-module (test-suite lib))

;; Start from a pristine locale state.
(setlocale LC_ALL "C")

(define exception:locale-error
  (cons 'system-error "Failed to install locale"))

(with-test-prefix "locale objects"

  (pass-if "make-locale (2 args)"
    (not (not (make-locale LC_ALL "C"))))

  (pass-if "make-locale (2 args, list)"
    (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C"))))

  (pass-if "make-locale (3 args)"
    (not (not (make-locale (list LC_COLLATE) "C"
                           (make-locale (list LC_MESSAGES) "C")))))

  (pass-if-exception "make-locale with unknown locale" exception:locale-error
    (make-locale LC_ALL "does-not-exist"))

  (pass-if "locale?"
    (and (locale? (make-locale (list LC_ALL) "C"))
         (locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C"
                               (make-locale (list LC_CTYPE) "C")))))

  (pass-if "%global-locale"
    (and (locale? %global-locale))
         (locale? (make-locale (list LC_MONETARY) "C"
                               %global-locale))))

(with-test-prefix "text collation (English)"

  (pass-if "string-locale<?"
    (and (string-locale<? "hello" "world")
         (string-locale<? "hello" "world"
                          (make-locale (list LC_COLLATE) "C"))))

  (pass-if "char-locale<?"
    (and (char-locale<? #\a #\b)
         (char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C"))))

  (pass-if "string-locale-ci=?"
    (and (string-locale-ci=? "Hello" "HELLO")
         (string-locale-ci=? "Hello" "HELLO"
                             (make-locale (list LC_COLLATE) "C"))))

  (pass-if "string-locale-ci<?"
    (and (string-locale-ci<? "hello" "WORLD")
         (string-locale-ci<? "hello" "WORLD"
                             (make-locale (list LC_COLLATE) "C")))))

(define %french-locale-name
  "fr_FR.ISO-8859-1")

(define %french-utf8-locale-name
  "fr_FR.UTF-8")

(define %turkish-utf8-locale-name
  "tr_TR.UTF-8")

(define %french-locale
  (false-if-exception
   (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
                %french-locale-name)))

(define %french-utf8-locale
  (false-if-exception
   (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
                %french-utf8-locale-name)))

(define %turkish-utf8-locale
  (false-if-exception
   (make-locale LC_ALL
                %turkish-utf8-locale-name)))

(define (under-locale-or-unresolved locale thunk)
  ;; On non-GNU systems, an exception may be raised only when the locale is
  ;; actually used rather than at `make-locale'-time.  Thus, we must guard
  ;; against both.
  (if locale
      (if (string-contains %host-type "-gnu")
          (thunk)
          (catch 'system-error thunk
                 (lambda (key . args)
                   (throw 'unresolved))))
      (throw 'unresolved)))

(define (under-french-locale-or-unresolved thunk)
  (under-locale-or-unresolved %french-locale thunk))

(define (under-french-utf8-locale-or-unresolved thunk)
  (under-locale-or-unresolved %french-utf8-locale thunk))

(define (under-turkish-utf8-locale-or-unresolved thunk)
  (under-locale-or-unresolved %turkish-utf8-locale thunk))

(with-test-prefix "text collation (French)"

  (pass-if "string-locale<?"
    (under-french-locale-or-unresolved
      (lambda ()
        (string-locale<? "été" "hiver" %french-locale))))

  (pass-if "char-locale<?"
    (under-french-locale-or-unresolved
      (lambda ()
        (char-locale<? #\é #\h %french-locale))))

  (pass-if "string-locale-ci=?"
    (under-french-locale-or-unresolved
      (lambda ()
        (string-locale-ci=? "ÉTÉ" "été" %french-locale))))

  (pass-if "string-locale-ci=? (2 args, wide strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        ;; Note: Character `œ' is not part of Latin-1, so these are wide
        ;; strings.
        (dynamic-wind
          (lambda ()
            (setlocale LC_ALL "fr_FR.UTF-8"))
          (lambda ()
            (string-locale-ci=? "œuf" "ŒUF"))
          (lambda ()
            (setlocale LC_ALL "C"))))))

  (pass-if "string-locale-ci=? (3 args, wide strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))

  (pass-if "string-locale-ci<>?"
    (under-french-locale-or-unresolved
      (lambda ()
        (and (string-locale-ci<? "été" "Hiver" %french-locale)
             (string-locale-ci>? "HiVeR" "été" %french-locale)))))

  (pass-if "string-locale-ci<>? (wide strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        ;; One of the strings is UCS-4, the other is Latin-1.
        (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
             (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))

  (pass-if "string-locale-ci<>? (wide and narrow strings)"
    (under-french-utf8-locale-or-unresolved
      (lambda ()
        ;; One of the strings is UCS-4, the other is Latin-1.
        (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
             (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))

  (pass-if "char-locale-ci<>?"
     (under-french-locale-or-unresolved
       (lambda ()
         (and (char-locale-ci<? #\é #\H %french-locale)
              (char-locale-ci>? #\h #\É %french-locale)))))

  (pass-if "char-locale-ci<>? (wide)"
     (under-french-utf8-locale-or-unresolved
       (lambda ()
         (and (char-locale-ci<? #\o #\œ %french-utf8-locale)
              (char-locale-ci>? #\Œ #\e %french-utf8-locale))))))

(with-test-prefix "character mapping"

  (pass-if "char-locale-downcase"
    (and (eq? #\a (char-locale-downcase #\A))
         (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C")))))

  (pass-if "char-locale-upcase"
    (and (eq? #\Z (char-locale-upcase #\z))
         (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))

  (pass-if "char-locale-titlecase"
    (and (eq? #\T (char-locale-titlecase #\t))
	 (eq? #\T (char-locale-titlecase #\t (make-locale LC_ALL "C")))))

  (pass-if "char-locale-titlecase Dž"
    (and (eq? #\762 (char-locale-titlecase #\763))
	 (eq? #\762 (char-locale-titlecase #\763 (make-locale LC_ALL "C")))))

  (pass-if "char-locale-upcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       ;; This test is disabled for now, because char-locale-upcase is
       ;; incomplete.
       (throw 'untested)
       (eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))

  (pass-if "char-locale-downcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       ;; This test is disabled for now, because char-locale-downcase
       ;; is incomplete.
       (throw 'untested)
       (eq? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))

(with-test-prefix "string mapping"

  (pass-if "string-locale-downcase"
    (and (string=? "a" (string-locale-downcase "A"))
         (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))

  (pass-if "string-locale-upcase"
    (and (string=? "Z" (string-locale-upcase "z"))
         (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))

  (pass-if "string-locale-titlecase"
    (and (string=? "Hello, World" (string-locale-titlecase "hello, world"))
	 (string=? "Hello, World" (string-locale-titlecase
				   "hello, world" (make-locale LC_ALL "C")))))

  (pass-if "string-locale-upcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       ;; This test is disabled for now, because string-locale-upcase
       ;; is incomplete.
       (throw 'untested)
       (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))

  (pass-if "string-locale-downcase Turkish"
    (under-turkish-utf8-locale-or-unresolved
     (lambda ()
       ;; This test is disabled for now, because
       ;; string-locale-downcase is incomplete.
       (throw 'untested)
       (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))

(with-test-prefix "number parsing"

  (pass-if "locale-string->integer"
    (call-with-values (lambda () (locale-string->integer "123"))
      (lambda (result char-count)
        (and (equal? result 123)
             (equal? char-count 3)))))

  (pass-if "locale-string->inexact"
    (call-with-values
        (lambda ()
          (locale-string->inexact "123.456"
                                  (make-locale (list LC_NUMERIC) "C")))
      (lambda (result char-count)
        (and (equal? result 123.456)
             (equal? char-count 7)))))

  (pass-if "locale-string->inexact (French)"
    (under-french-locale-or-unresolved
     (lambda ()
       (call-with-values
           (lambda ()
             (locale-string->inexact "123,456" %french-locale))
         (lambda (result char-count)
           (and (equal? result 123.456)
                (equal? char-count 7))))))))

;;;
;;; `nl-langinfo'
;;;

(setlocale LC_ALL "C")
(define %c-locale (make-locale LC_ALL "C"))

(define %english-days
  '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))

(define (every? . args)
  (not (not (apply every args))))

(with-test-prefix "nl-langinfo et al."

  (pass-if "locale-day (1 arg)"
    (every? equal?
            %english-days
            (map locale-day (map 1+ (iota 7)))))

  (pass-if "locale-day (2 args)"
    (every? equal?
            %english-days
            (map (lambda (day)
                   (locale-day day %c-locale))
                 (map 1+ (iota 7)))))

  (pass-if "locale-day (2 args, using `%global-locale')"
    (every? equal?
            %english-days
            (map (lambda (day)
                   (locale-day day %global-locale))
                 (map 1+ (iota 7)))))

  (pass-if "locale-day (French)"
    (under-french-locale-or-unresolved
     (lambda ()
       (let ((result (locale-day 3 %french-locale)))
         (and (string? result)
              (string-ci=? result "mardi"))))))

  (pass-if "locale-day (French, using `%global-locale')"
    ;; Make sure `%global-locale' captures the current locale settings as
    ;; installed using `setlocale'.
    (under-french-locale-or-unresolved
     (lambda ()
       (dynamic-wind
           (lambda ()
             (setlocale LC_TIME %french-locale-name))
           (lambda ()
             (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale))
                    (result (locale-day 3 fr)))
               (setlocale LC_ALL "C")
               (and (string? result)
                    (string-ci=? result "mardi"))))
           (lambda ()
             (setlocale LC_ALL "C"))))))

  (pass-if "default locale"
    ;; Make sure the default locale does not capture the current locale
    ;; settings as installed using `setlocale'.  The default locale should be
    ;; "C".
    (under-french-locale-or-unresolved
     (lambda ()
       (dynamic-wind
           (lambda ()
             (setlocale LC_ALL %french-locale-name))
           (lambda ()
             (let* ((locale (make-locale (list LC_MONETARY) "C"))
                    (result (locale-day 3 locale)))
               (setlocale LC_ALL "C")
               (and (string? result)
                    (string-ci=? result "Tuesday"))))
           (lambda ()
             (setlocale LC_ALL "C")))))))


code:
;;;; import.test --- test selective and renaming imports    -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 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 3 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 (exporter)
  :export (foo bar))

(define foo 1)
(define bar 2)

(define-module (importer)
  :use-module (test-suite lib))

(use-modules ((exporter)
	      :select (foo (bar . baz))))

(pass-if-exception "selective non-import" (cons 'unbound-variable
						"^Unbound variable")
  (= bar 2))

(pass-if "selective import"
  (= foo 1))

(pass-if "renaming import"
  (= baz 2))

(use-modules ((exporter) :renamer (symbol-prefix-proc 'external:)))

(pass-if "symbol-prefic-proc import"
  (and (= external:foo 1)
       (= external:bar 2)))

(use-modules ((exporter) :renamer (lambda (sym)
				    (symbol-append sym ':external))))

(pass-if "renamer import"
  (and (= foo:external 1)
       (= bar:external 2)))

license: mit


code:
;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*-
;;;;
;;;; 	Copyright (C) 1999, 2001, 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 3 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

(pass-if "Internal defines 1"
	 (letrec ((foo (lambda (arg)
			 (or arg (and (procedure? foo)
				      (foo 99))))))
	   (define bar (foo #f))
	   (= (foo #f) 99)))

(pass-if "Internal defines 2"
	 (letrec ((foo 77)
		  (bar #f)
		  (retfoo (lambda () foo)))
	   (define baz (retfoo))
	   (= (retfoo) 77)))

;; Test that evaluation of closure bodies works as it should

(with-test-prefix "closure bodies"
  (with-test-prefix "eval"
    (pass-if "expansion"
	     ;; we really want exactly #f back from the closure
	     (not ((lambda () (define ret #f) ret))))
    (pass-if "iloc escape"
	     (not (let* ((x #f)
			 (foo (lambda () x)))
		    (foo) ; causes memoization of x
		    (foo)))))
  (with-test-prefix "apply"
    (pass-if "expansion"
	     (not (catch #t (lambda () (define ret #f) ret) (lambda a #t))))
    (pass-if "iloc escape"
	     (not (let* ((x #f)
			 (foo (lambda () x)))
		    (foo)
		    (catch #t foo (lambda a #t)))))))


code:
;;;; keywords.test --- Keywords.           -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2009, 2010 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 3 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-keywords)
  :use-module (test-suite lib))

(with-test-prefix "keywords"
  (pass-if "printing"
    (string=? (with-output-to-string (lambda () (write #:this)))
	      "#:this")))


code:
;;;; list.test --- tests guile's lists     -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 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 3 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

(use-modules (test-suite lib)
	     (ice-9 documentation))

;;;
;;; miscellaneous
;;;

(define (documented? object)
  (not (not (object-documentation object))))

;;
;; This unique tag is reserved for the unroll and diff-unrolled functions.
;;

(define circle-indicator
  (cons 'circle 'indicator))

;;
;; Extract every single scheme object that is contained within OBJ into a new
;; data structure.  That means, if OBJ somewhere contains a pair, the newly
;; created structure holds a reference to the pair as well as references to
;; the car and cdr of that pair.  For vectors, the newly created structure
;; holds a reference to that vector as well as references to every element of
;; that vector.  Since this is done recursively, the original data structure
;; is deeply unrolled.  If there are circles within the original data
;; structures, every reference that points backwards into the data structure
;; is denoted by storing the circle-indicator tag as well as the object the
;; circular reference points to.
;;

(define (unroll obj)
  (let unroll* ((objct obj)
                (hist '()))
    (reverse!
     (let loop ((object objct)
                (histry hist)
                (result '()))
       (if (memq object histry)
           (cons (cons circle-indicator object) result)
           (let ((history (cons object histry)))
             (cond ((pair? object)
                    (loop (cdr object) history
                          (cons (cons object (unroll* (car object) history))
                                result)))
                   ((vector? object)
                    (cons (cons object
                                (map (lambda (x)
                                       (unroll* x history))
                                     (vector->list object)))
                          result))
                   (else (cons object result)))))))))

;;
;; Compare two data-structures that were generated with unroll.  If any of the
;; elements found not to be eq?, return a pair that holds the position of the
;; first found differences of the two data structures.  If all elements are
;; found to be eq?, #f is returned.
;;

(define (diff-unrolled a b)
  (cond ;; has everything been compared already?
        ((and (null? a) (null? b))
	 #f)
	;; do both structures still contain elements?
	((and (pair? a) (pair? b))
	 (cond ;; are the next elements both plain objects?
	       ((and (not (pair? (car a))) (not (pair? (car b))))
		(if (eq? (car a) (car b))
		    (diff-unrolled (cdr a) (cdr b))
		    (cons a b)))
	       ;; are the next elements both container objects?
	       ((and (pair? (car a)) (pair? (car b)))
		(if (eq? (caar a) (caar b))
		    (cond ;; do both objects close a circular structure?
			  ((eq? circle-indicator (caar a))
			   (if (eq? (cdar a) (cdar b))
			       (diff-unrolled (cdr a) (cdr b))
			       (cons a b)))
			  ;; do both objects hold a vector?
		          ((vector? (caar a))
			   (or (let loop ((a1 (cdar a)) (b1 (cdar b)))
				 (cond
				  ((and (null? a1) (null? b1))
				   #f)
				  ((and (pair? a1) (pair? b1))
				   (or (diff-unrolled (car a1) (car b1))
				       (loop (cdr a1) (cdr b1))))
				  (else
				   (cons a1 b1))))
			       (diff-unrolled (cdr a) (cdr b))))
			  ;; do both objects hold a pair?
			  (else
			   (or (diff-unrolled (cdar a) (cdar b))
			       (diff-unrolled (cdr a) (cdr b)))))
		    (cons a b)))
	       (else
		(cons a b))))
	(else
	 (cons a b))))

;;; list

(with-test-prefix "list"

  (pass-if "documented?"
    (documented? list))

  ;; in guile 1.6.7 and earlier `list' called using `apply' didn't make a
  ;; new list, it just returned the given list
  (pass-if "apply gets fresh list"
    (let* ((x '(1 2 3))
	   (y (apply list x)))
      (not (eq? x y)))))

;;; make-list

(with-test-prefix "make-list"

  (pass-if "documented?"
    (documented? make-list))

  (with-test-prefix "no init"
    (pass-if "0"
      (equal? '() (make-list 0)))
    (pass-if "1"
      (equal? '(()) (make-list 1)))
    (pass-if "2"
      (equal? '(() ()) (make-list 2)))
    (pass-if "3"
      (equal? '(() () ()) (make-list 3))))

  (with-test-prefix "with init"
    (pass-if "0"
      (equal? '() (make-list 0 'foo)))
    (pass-if "1"
      (equal? '(foo) (make-list 1 'foo)))
    (pass-if "2"
      (equal? '(foo foo) (make-list 2 'foo)))
    (pass-if "3"
      (equal? '(foo foo foo) (make-list 3 'foo)))))

;;; cons*

(with-test-prefix "cons*"

  (pass-if "documented?"
    (documented? list))

  (with-test-prefix "one arg"
    (pass-if "empty list"
      (eq? '() (cons* '())))
    (pass-if "one elem list"
      (let* ((lst '(1)))
	(eq? lst (cons* lst))))
    (pass-if "two elem list"
      (let* ((lst '(1 2)))
	(eq? lst (cons* lst)))))

  (with-test-prefix "two args"
    (pass-if "empty list"
      (equal? '(1) (cons* 1 '())))
    (pass-if "one elem list"
      (let* ((lst '(1))
	     (ret (cons* 2 lst)))
	(and (equal? '(2 1) ret)
	     (eq? lst (cdr ret)))))
    (pass-if "two elem list"
      (let* ((lst '(1 2))
	     (ret (cons* 3 lst)))
	(and (equal? '(3 1 2) ret)
	     (eq? lst (cdr ret))))))

  (with-test-prefix "three args"
    (pass-if "empty list"
      (equal? '(1 2) (cons* 1 2 '())))
    (pass-if "one elem list"
      (let* ((lst '(1))
	     (ret (cons* 2 3 lst)))
	(and (equal? '(2 3 1) ret)
	     (eq? lst (cddr ret)))))
    (pass-if "two elem list"
      (let* ((lst '(1 2))
	     (ret (cons* 3 4 lst)))
	(and (equal? '(3 4 1 2) ret)
	     (eq? lst (cddr ret))))))

  ;; in guile 1.6.7 and earlier `cons*' called using `apply' modified its
  ;; list argument
  (pass-if "apply list unchanged"
    (let* ((lst '(1 2 (3 4)))
	   (ret (apply cons* lst)))
      (and (equal? lst '(1 2 (3 4)))
	   (equal? ret '(1 2 3 4))))))

;;; null?

;;; list?

;;; length

;;; append

;;;
;;; append!
;;;

(with-test-prefix "append!"

  (pass-if "documented?"
    (documented? append!))

  ;; Is the handling of empty lists as arguments correct?

  (pass-if "no arguments"
    (eq? (append!)
	 '()))

  (pass-if "empty list argument"
    (eq? (append! '())
	 '()))

  (pass-if "some empty list arguments"
    (eq? (append! '() '() '())
	 '()))

  ;; Does the last non-empty-list argument remain unchanged?

  (pass-if "some empty lists with non-empty list"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (tst (append! '() '() '() foo))
	   (tst-unrolled (unroll tst)))
      (and (eq? tst foo)
	   (not (diff-unrolled foo-unrolled tst-unrolled)))))

  (pass-if "some empty lists with improper list"
    (let* ((foo (cons 1 2))
	   (foo-unrolled (unroll foo))
	   (tst (append! '() '() '() foo))
	   (tst-unrolled (unroll tst)))
      (and (eq? tst foo)
	   (not (diff-unrolled foo-unrolled tst-unrolled)))))

  (pass-if "some empty lists with circular list"
    (let ((foo (list 1 2)))
      (set-cdr! (cdr foo) (cdr foo))
      (let* ((foo-unrolled (unroll foo))
	     (tst (append! '() '() '() foo))
	     (tst-unrolled (unroll tst)))
	(and (eq? tst foo)
	     (not (diff-unrolled foo-unrolled tst-unrolled))))))

  (pass-if "some empty lists with non list object"
    (let* ((foo (vector 1 2 3))
	   (foo-unrolled (unroll foo))
	   (tst (append! '() '() '() foo))
	   (tst-unrolled (unroll tst)))
      (and (eq? tst foo)
	   (not (diff-unrolled foo-unrolled tst-unrolled)))))

  (pass-if "non-empty list between empty lists"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (tst (append! '() '() '() foo '() '() '()))
	   (tst-unrolled (unroll tst)))
      (and (eq? tst foo)
	   (not (diff-unrolled foo-unrolled tst-unrolled)))))

  ;; Are arbitrary lists append!ed correctly?

  (pass-if "two one-element lists"
    (let* ((foo (list 1))
	   (foo-unrolled (unroll foo))
	   (bar (list 2))
	   (bar-unrolled (unroll bar))
	   (tst (append! foo bar))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? tst '(1 2))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))

  (pass-if "three one-element lists"
    (let* ((foo (list 1))
	   (foo-unrolled (unroll foo))
	   (bar (list 2))
	   (bar-unrolled (unroll bar))
	   (baz (list 3))
	   (baz-unrolled (unroll baz))
	   (tst (append! foo bar baz))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? tst '(1 2 3))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (let* ((tst-unrolled-2 (cdr diff-foo-tst))
		  (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
	     (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
		  (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))

  (pass-if "two two-element lists"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (bar (list 3 4))
	   (bar-unrolled (unroll bar))
	   (tst (append! foo bar))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? tst '(1 2 3 4))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))

  (pass-if "three two-element lists"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (bar (list 3 4))
	   (bar-unrolled (unroll bar))
	   (baz (list 5 6))
	   (baz-unrolled (unroll baz))
	   (tst (append! foo bar baz))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? tst '(1 2 3 4 5 6))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (let* ((tst-unrolled-2 (cdr diff-foo-tst))
		  (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
	     (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
		  (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))

  (pass-if "empty list between non-empty lists"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (bar (list 3 4))
	   (bar-unrolled (unroll bar))
	   (baz (list 5 6))
	   (baz-unrolled (unroll baz))
	   (tst (append! foo '() bar '() '() baz '() '() '()))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? tst '(1 2 3 4 5 6))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (let* ((tst-unrolled-2 (cdr diff-foo-tst))
		  (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
	     (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
		  (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))

  (pass-if "list and improper list"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (bar (cons 3 4))
	   (bar-unrolled (unroll bar))
	   (tst (append! foo bar))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? tst '(1 2 3 . 4))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))

  (pass-if "list and circular list"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (bar (list 3 4 5)))
      (set-cdr! (cddr bar) (cdr bar))
      (let* ((bar-unrolled (unroll bar))
	     (tst (append! foo bar))
	     (tst-unrolled (unroll tst))
	     (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
	(and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x))
			  (iota 9)
			  '(1 2 3 4 5 4 5 4 5))
		     '(#t #t #t #t #t #t #t #t #t))
	     (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	     (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))))

  (pass-if "list and non list object"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (bar (vector 3 4))
	   (bar-unrolled (unroll bar))
	   (tst (append! foo bar))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? tst '(1 2 . #(3 4)))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))

  (pass-if "several arbitrary lists"
    (equal? (append! (list 1 2)
		     (list (list 3) 4)
		     (list (list 5) (list 6))
		     (list 7 (cons 8 9))
		     (list 10 11)
		     (list (cons 12 13) 14)
		     (list (list)))
	    (list 1 2
		  (list 3) 4
		  (list 5) (list 6)
		  7 (cons 8 9)
		  10 11
		  (cons 12 13)
		  14 (list))))

  (pass-if "list to itself"
    (let* ((foo (list 1 2))
	   (foo-unrolled (unroll foo))
	   (tst (append! foo foo))
	   (tst-unrolled (unroll tst))
	   (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
      (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x))
			(iota 6)
			'(1 2 1 2 1 2))
		   '(#t #t #t #t #t #t))
	   (not (diff-unrolled (car diff-foo-tst) (unroll '())))
	   (eq? (caar (cdr diff-foo-tst)) circle-indicator)
	   (eq? (cdar (cdr diff-foo-tst)) foo))))

  ;; Are wrong type arguments detected correctly?

  (with-test-prefix "wrong argument"

    (expect-fail-exception "improper list and empty list"
      exception:wrong-type-arg
      (append! (cons 1 2) '()))

    (expect-fail-exception "improper list and list"
      exception:wrong-type-arg
      (append! (cons 1 2) (list 3 4)))

    (expect-fail-exception "list, improper list and list"
      exception:wrong-type-arg
      (append! (list 1 2) (cons 3 4) (list 5 6)))

    (expect-fail "circular list and empty list"
      (let ((foo (list 1 2 3)))
	(set-cdr! (cddr foo) (cdr foo))
	(catch #t
	  (lambda ()
	    (catch 'wrong-type-arg
	      (lambda ()
		(append! foo '())
		#f)
	      (lambda (key . args)
		#t)))
	  (lambda (key . args)
	    #f))))

    (expect-fail "circular list and list"
      (let ((foo (list 1 2 3)))
	(set-cdr! (cddr foo) (cdr foo))
	(catch #t
	  (lambda ()
	    (catch 'wrong-type-arg
	      (lambda ()
		(append! foo (list 4 5))
		#f)
	      (lambda (key . args)
		#t)))
	  (lambda (key . args)
	    #f))))

    (expect-fail "list, circular list and list"
      (let ((foo (list 3 4 5)))
	(set-cdr! (cddr foo) (cdr foo))
	(catch #t
	  (lambda ()
	    (catch 'wrong-type-arg
	      (lambda ()
		(append! (list 1 2) foo (list 6 7))
		#f)
	      (lambda (key . args)
		#t)))
	  (lambda (key . args)
	    #f))))))

;;; last-pair

;;; reverse

;;; reverse!

;;; list-ref

(with-test-prefix "list-ref"

  (pass-if "documented?"
    (documented? list-ref))

  (with-test-prefix "argument error"

    (with-test-prefix "non list argument"
      #t)

    (with-test-prefix "improper list argument"
      #t)

    (with-test-prefix "non integer index"
      #t)

    (with-test-prefix "index out of range"

      (with-test-prefix "empty list"

	(pass-if-exception "index 0"
	  exception:out-of-range
	  (list-ref '() 0))

	(pass-if-exception "index > 0"
	  exception:out-of-range
	  (list-ref '() 1))

	(pass-if-exception "index < 0"
	  exception:out-of-range
	  (list-ref '() -1)))

      (with-test-prefix "non-empty list"

	(pass-if-exception "index > length"
	  exception:out-of-range
	  (list-ref '(1) 1))

	(pass-if-exception "index < 0"
	  exception:out-of-range
	  (list-ref '(1) -1))))))

;;; list-set!

(with-test-prefix "list-set!"

  (pass-if "documented?"
    (documented? list-set!))

  (with-test-prefix "argument error"

    (with-test-prefix "non list argument"
      #t)

    (with-test-prefix "improper list argument"
      #t)

    (with-test-prefix "read-only list argument"
      #t)

    (with-test-prefix "non integer index"
      #t)

    (with-test-prefix "index out of range"

      (with-test-prefix "empty list"

	(pass-if-exception "index 0"
	  exception:out-of-range
	  (list-set! (list) 0 #t))

	(pass-if-exception "index > 0"
	  exception:out-of-range
	  (list-set! (list) 1 #t))

	(pass-if-exception "index < 0"
	  exception:out-of-range
	  (list-set! (list) -1 #t)))

      (with-test-prefix "non-empty list"

	(pass-if-exception "index > length"
	  exception:out-of-range
	  (list-set! (list 1) 1 #t))

	(pass-if-exception "index < 0"
	  exception:out-of-range
	  (list-set! (list 1) -1 #t))))))

;;; list-cdr-ref

;;; list-tail

;;; list-cdr-set!

(with-test-prefix "list-cdr-set!"

  (pass-if "documented?"
    (documented? list-cdr-set!))

  (with-test-prefix "argument error"

    (with-test-prefix "non list argument"
      #t)

    (with-test-prefix "improper list argument"
      #t)

    (with-test-prefix "read-only list argument"
      #t)

    (with-test-prefix "non integer index"
      #t)

    (with-test-prefix "index out of range"

      (with-test-prefix "empty list"

	(pass-if-exception "index 0"
	  exception:out-of-range
	  (list-cdr-set! (list) 0 #t))

	(pass-if-exception "index > 0"
	  exception:out-of-range
	  (list-cdr-set! (list) 1 #t))

	(pass-if-exception "index < 0"
	  exception:out-of-range
	  (list-cdr-set! (list) -1 #t)))

      (with-test-prefix "non-empty list"

	(pass-if-exception "index > length"
	  exception:out-of-range
	  (list-cdr-set! (list 1) 1 #t))

	(pass-if-exception "index < 0"
	  exception:out-of-range
	  (list-cdr-set! (list 1) -1 #t))))))

;;; list-head

;;; list-copy

;;; memq

;;; memv

;;; member

;;; delq!

;;; delv!

;;; delete!

;;; delq

;;; delv

;;; delete

;;; delq1!

;;; delv1!

;;; delete1!


code:
;;;; load.test --- test LOAD and path searching functions  -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;;
;;;; 	Copyright (C) 1999, 2001, 2006, 2010 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 3 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-load)
  :use-module (test-suite lib)
  :use-module (test-suite guile-test))

(define temp-dir (data-file-name "load-test.dir"))

(define (create-tree parent tree)
  (let loop ((parent parent)
	     (tree tree))
    (if (pair? tree)
	(let ((elt (car tree)))
	  (cond

	   ;; A string means to create an empty file with that name.
	   ((string? elt)
	    (close-port (open-file (string-append parent "/" elt) "w")))

	   ;; A list means to create a directory, and then create files
	   ;; within it.
	   ((pair? elt)
	    (let ((dirname (string-append parent "/" (car elt))))
	      (mkdir dirname)
	      (loop dirname (cdr elt))))

	   (else
	    (error "create-tree: bad tree structure")))

	  (loop parent (cdr tree))))))

(define (delete-tree tree)
  (cond
   ((file-is-directory? tree)
    (let ((dir (opendir tree)))
      (let loop ()
	(let ((entry (readdir dir)))
	  (cond
	   ((member entry '("." ".."))
	    (loop))
	   ((not (eof-object? entry))
	    (let ((name (string-append tree "/" entry)))
	      (delete-tree name)
	      (loop))))))
      (closedir dir)
      (rmdir tree)))
   ((file-exists? tree)
    (delete-file tree))
   (else
    (error "delete-tree: can't delete " tree))))

(define (try-search-with-extensions path input extensions expected)
  (let ((test-name (call-with-output-string
		    (lambda (port)
		      (display "search-path for " port)
		      (write input port)
		      (if (pair? extensions)
			  (begin
			    (display " with extensions " port)
			    (write extensions port)))
		      (display " yields " port)
		      (write expected port)))))
    (let ((result (search-path path input extensions)))
      (pass-if test-name
	       (equal? (if (string? expected)
			   (string-append temp-dir "/" expected)
			   expected)
		       result)))))

(define (try-search path input expected)
  (try-search-with-extensions path input '() expected))

;; Create a bunch of files for use in testing.
(mkdir temp-dir)
(create-tree temp-dir
	     '(("dir1" "foo.scm" "bar.scm" "ugly.scm.scm"
		("subdir1"))
	       ("dir2" "foo.scm" "baz.scm" "baz.ss" "ugly.scm.ss")
	       ("dir3" "ugly.scm" "ugly.ss.scm")))

;; Try some searches without extensions.
(define path (list
	      (string-append temp-dir "/dir1")
	      (string-append temp-dir "/dir2")
	      (string-append temp-dir "/dir3")))

(try-search path "foo.scm"  "dir1/foo.scm")
(try-search path "bar.scm"  "dir1/bar.scm")
(try-search path "baz.scm"  "dir2/baz.scm")
(try-search path "baz.ss"   "dir2/baz.ss")
(try-search path "ugly.scm" "dir3/ugly.scm")
(try-search path "subdir1"  #f)

(define extensions '(".ss" ".scm" ""))
(try-search-with-extensions path "foo" 	    extensions "dir1/foo.scm")
(try-search-with-extensions path "bar" 	    extensions "dir1/bar.scm")
(try-search-with-extensions path "baz" 	    extensions "dir2/baz.ss")
(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
(try-search-with-extensions path "ugly.ss"  extensions #f)

;; Check that search-path accepts Elisp nil-terminated lists for
;; PATH and EXTENSIONS.
(with-test-prefix "elisp-nil"
  (set-cdr! (last-pair path)
#nil)
  (set-cdr! (last-pair extensions) #nil)
  (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
  (try-search-with-extensions path "ugly.ss"  extensions #f))

(delete-tree temp-dir)


code:
;;;; match.test --- (ice-9 match)  -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010 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 3 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-match)
  #:use-module (ice-9 match)
  #:use-module (test-suite lib))

(define exception:match-error
  (cons 'match-error "^.*$"))

(with-test-prefix "matches"

  (pass-if "wildcard"
    (match "hello" (_ #t)))

  (pass-if "symbol"
    (match 'foo ('foo #t)))

  (pass-if "string"
    (match "bar" ("bar" #t)))

  (pass-if "number"
    (match 777 (777 #t)))

  (pass-if "char"
    (match #\g (#\g #t)))

  (pass-if "sexp"
    (match '(a b c) ('(a b c) #t)))

  (pass-if "predicate"
    (match '(a 1 2)
      (('a (and (? odd?) one) (? even?))
       (= one 1))))

  (pass-if "list"
    (let ((lst '(a b c)))
      (match lst
        ((x y z)
         (equal? (list x y z) lst)))))

  (pass-if "list rest..."
    (let ((lst '(a b c)))
      (match lst
        ((x rest ...)
         (and (eq? x 'a) (equal? rest '(b c)))))))

  (pass-if "list . rest"
    (let ((lst '(a b c)))
      (match lst
        ((x . rest)
         (and (eq? x 'a) (equal? rest '(b c)))))))

  (pass-if "tree"
    (let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
      (match tree
        (('one ('two x) ('three y ('and z '(and 5))))
         (equal? (list x y z) '(2 3 4)))))))

(with-test-prefix "doesn't match"

  (pass-if-exception "tree"
    exception:match-error
    (match '(a (b c))
      ((foo (bar)) #t))))


code:
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-

;;;; Copyright (C) 2006, 2007, 2009, 2010 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 3 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-modules)
  :use-module (srfi srfi-1)
  :use-module ((ice-9 streams)  ;; for test purposes
               #:renamer (symbol-prefix-proc 's:))
  :use-module (test-suite lib))

(define (every? . args)
  (not (not (apply every args))))

;;;
;;; Foundations.
;;;

(with-test-prefix "foundations"

  (pass-if "modules don't remain anonymous"
    ;; This is a requirement for `psyntax': it stores module names and relies
    ;; on being able to `resolve-module' them.
    (let ((m (make-module)))
      (and (module-name m)
           (eq? m (resolve-module (module-name m))))))

  (pass-if "module-add!"
    (let ((m (make-module))
          (value (cons 'x 'y)))
      (module-add! m 'something (make-variable value))
      (eq? (module-ref m 'something) value)))

  (pass-if "module-define!"
    (let ((m (make-module))
          (value (cons 'x 'y)))
      (module-define! m 'something value)
      (eq? (module-ref m 'something) value)))

  (pass-if "module-use!"
    (let ((m (make-module))
          (import (make-module)))
      (module-define! m 'something 'something)
      (module-define! import 'imported 'imported)
      (module-use! m import)
      (and (eq? (module-ref m 'something) 'something)
           (eq? (module-ref m 'imported)  'imported)
           (module-local-variable m 'something)
           (not (module-local-variable m 'imported))
           #t)))

  (pass-if "module-use! (duplicates local binding)"
    ;; Imported bindings can't override locale bindings.
    (let ((m (make-module))
          (import (make-module)))
      (module-define! m 'something 'something)
      (module-define! import 'something 'imported)
      (module-use! m import)
      (eq? (module-ref m 'something) 'something)))

  (pass-if "module-locally-bound?"
     (let ((m (make-module))
           (import (make-module)))
       (module-define! m 'something #t)
       (module-define! import 'imported #t)
       (module-use! m import)
       (and (module-locally-bound? m 'something)
            (not (module-locally-bound? m 'imported)))))

  (pass-if "module-{local-,}variable"
     (let ((m (make-module))
           (import (make-module)))
       (module-define! m 'local #t)
       (module-define! import 'imported #t)
       (module-use! m import)
       (and (module-local-variable m 'local)
            (not (module-local-variable m 'imported))
            (eq? (module-variable m 'local)
                 (module-local-variable m 'local))
            (eq? (module-local-variable import 'imported)
                 (module-variable m 'imported)))))

  (pass-if "module-import-interface"
    (and (every? (lambda (sym iface)
                   (eq? (module-import-interface (current-module) sym)
                        iface))
                 '(current-module exception:bad-variable every)
                 (cons the-scm-module
                       (map resolve-interface
                            '((test-suite lib) (srfi srfi-1)))))

         ;; For renamed bindings, a custom interface is used so we can't
         ;; check for equality with `eq?'.
         (every? (lambda (sym iface)
                   (let ((import
                          (module-import-interface (current-module) sym)))
                     (equal? (module-name import)
                             (module-name iface))))
                 '(s:make-stream s:stream-car s:stream-cdr)
                 (make-list 3 (resolve-interface '(ice-9 streams))))))

  (pass-if "module-reverse-lookup"
    (let ((mods   '((srfi srfi-1) (test-suite lib)      (ice-9 streams)))
          (syms   '(every         exception:bad-variable make-stream))
          (locals '(every         exception:bad-variable s:make-stream)))
      (every? (lambda (var sym)
                (eq? (module-reverse-lookup (current-module) var)
                     sym))
              (map module-variable
                   (map resolve-interface mods)
                   syms)
              locals)))

  (pass-if "module-reverse-lookup [pre-module-obarray]"
    (let ((var (module-variable (current-module) 'string?)))
      (eq? 'string? (module-reverse-lookup #f var))))

  (pass-if-exception "module-reverse-lookup [wrong-type-arg]"
    exception:wrong-type-arg
    (module-reverse-lookup (current-module) 'foo)))

;;;
;;; Resolve-module.
;;;

(with-test-prefix "resolve-module"

  (pass-if "#:ensure #t by default"
    (module? (resolve-module (list (gensym)))))

  (pass-if "#:ensure #t explicitly"
    (module? (resolve-module (list (gensym)) #:ensure #t)))

  (pass-if "#:ensure #f"
    (not (resolve-module (list (gensym)) #:ensure #f))))

;;;
;;; Observers.
;;;

(with-test-prefix "observers"

  (pass-if "weak observer invoked"
    (let* ((m (make-module))
           (invoked 0))
      (module-observe-weak m (lambda (mod)
                               (if (eq? mod m)
                                   (set! invoked (+ invoked 1)))))
      (module-define! m 'something 2)
      (module-define! m 'something-else 1)
      (= invoked 2)))

  (pass-if "all weak observers invoked"
    ;; With the two-argument `module-observe-weak' available in previous
    ;; versions, the observer would get unregistered as soon as the observing
    ;; closure gets GC'd, making it impossible to use an anonymous lambda as
    ;; the observing procedure.

    (let* ((m (make-module))
           (observer-count 500)
           (observer-ids (let loop ((i observer-count)
                                    (ids '()))
                           (if (= i 0)
                               ids
                               (loop (- i 1) (cons (make-module) ids)))))
           (observers-invoked (make-hash-table observer-count)))

      ;; register weak observers
      (for-each (lambda (id)
                  (module-observe-weak m id
                                       (lambda (m)
                                         (hashq-set! observers-invoked
                                                     id #t))))
                observer-ids)

      (gc)

      ;; invoke them
      (module-call-observers m)

      ;; make sure all of them were invoked
      (->bool (every (lambda (id)
                       (hashq-ref observers-invoked id))
                     observer-ids))))

  (pass-if "imported bindings updated"
    (let ((m (make-module))
          (imported (make-module)))
      ;; Beautify them, notably adding them a public interface.
      (beautify-user-module! m)
      (beautify-user-module! imported)

      (module-use! m (module-public-interface imported))
      (module-define! imported 'imported-binding #t)

      ;; At this point, `imported-binding' is local to IMPORTED.
      (and (not (module-variable m 'imported-binding))
           (begin
             ;; Export `imported-binding' from IMPORTED.
             (module-export! imported '(imported-binding))

             ;; Make sure it is now visible from M.
             (module-ref m 'imported-binding))))))

;;;
;;; Duplicate bindings handling.
;;;

(with-test-prefix "duplicate bindings"

  (pass-if "simple duplicate handler"
    ;; Import the same binding twice.
    (let* ((m (make-module))
           (import1 (make-module))
           (import2 (make-module))
           (handler-invoked? #f)
           (handler (lambda (module name int1 val1 int2 val2 var val)
                      (set! handler-invoked? #t)
                      ;; Keep the first binding.
                      (or var (module-local-variable int1 name)))))

      (set-module-duplicates-handlers! m (list handler))
      (module-define! m 'something 'something)
      (set-module-name! import1 'imported-module-1)
      (set-module-name! import2 'imported-module-2)
      (module-define! import1 'imported 'imported-1)
      (module-define! import2 'imported 'imported-2)
      (module-use! m import1)
      (module-use! m import2)
      (and (eq? (module-ref m 'imported) 'imported-1)
           handler-invoked?))))

;;;
;;; Lazy binder.
;;;

(with-test-prefix "lazy binder"

  (pass-if "not invoked"
    (let ((m (make-module))
          (invoked? #f))
      (module-define! m 'something 2)
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (and (module-ref m 'something)
           (not invoked?))))

  (pass-if "not invoked (module-add!)"
    (let ((m (make-module))
          (invoked? #f))
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (module-add! m 'something (make-variable 2))
      (and (module-ref m 'something)
           (not invoked?))))

  (pass-if "invoked (module-ref)"
    (let ((m (make-module))
          (invoked? #f))
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (false-if-exception (module-ref m 'something))
      invoked?))

  (pass-if "invoked (module-define!)"
    (let ((m (make-module))
          (invoked? #f))
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (module-define! m 'something 2)
      (and invoked?
           (eq? (module-ref m 'something) 2))))

  (pass-if "honored (ref)"
    (let ((m (make-module))
          (invoked? #f)
          (value (cons 'x 'y)))
      (set-module-binder! m
                          (lambda (mod sym define?)
                            (set! invoked? #t)
                            (cond ((not (eq? m mod))
                                   (error "invalid module" mod))
                                  (define?
                                   (error "DEFINE? shouldn't be set"))
                                  (else
                                   (make-variable value)))))
      (and (eq? (module-ref m 'something) value)
           invoked?))))

;;;
;;; Higher-level features.
;;;

(with-test-prefix "autoload"

  (pass-if "module-autoload!"
     (let ((m (make-module)))
       (module-autoload! m '(ice-9 q) '(make-q))
       (not (not (module-ref m 'make-q)))))

  (pass-if "autoloaded"
     (catch #t
       (lambda ()
	 ;; Simple autoloading.
	 (eval '(begin
		  (define-module (test-autoload-one)
		    :autoload (ice-9 q) (make-q))
		  (not (not make-q)))
	       (current-module)))
	(lambda (key . args)
	  #f)))

  ;; In Guile 1.8.0 this failed because the binder in
  ;; `make-autoload-interface' would try to remove the autoload interface
  ;; from the module's "uses" without making sure it is still part of these
  ;; "uses".
  ;;
  (pass-if "autoloaded+used"
     (catch #t
       (lambda ()
	 (eval '(begin
		  (define-module (test-autoload-two)
		    :autoload (ice-9 q) (make-q)
		    :use-module (ice-9 q))
		  (not (not make-q)))
	       (current-module)))
	(lambda (key . args)
	  #f))))

;;;
;;; R6RS compatibility
;;;

(with-test-prefix "module versions"

  (pass-if "version-matches? for matching versions"
    (version-matches? '(1 2 3) '(1 2 3)))

  (pass-if "version-matches? for non-matching versions"
    (not (version-matches? '(3 2 1) '(1 2 3))))

  (pass-if "version-matches? against more specified version"
    (version-matches? '(1 2) '(1 2 3)))

  (pass-if "version-matches? against less specified version"
    (not (version-matches? '(1 2 3) '(1 2)))))


code:
;;;; multilingual.nottest --- tests of multilingual support    -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;; This isn't a test yet, because we don't have multilingual support yet.
;;;;
;;;; 	Copyright (C) 1999, 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 3 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

(use-modules (test-suite lib))

;;; Tests of Emacs 20.4 character encoding.

;;; Check that characters are being encoded correctly.

;;; These tests are specific to the Emacs 20.4 encoding; they'll need
;;; to be replaced when Guile switches to UTF-8.  See mb.c for a
;;; description of this encoding.

(define (check-encoding char-number encoding)
  (let ((singleton (string (integer->char char-number))))
    (pass-if (string-append "encoding character "
			    (number->string char-number))
	     (equal? (string->bytes singleton) encoding))
    (pass-if (string-append "decoding character "
			    (number->string char-number))
	     (catch #t
		    (lambda ()
		      (equal? (bytes->string encoding) singleton))
		    (lambda dummy #f)))))

;; Check some ASCII characters.
(check-encoding 0 #y(0))
(check-encoding 127 #y(127))
(check-encoding 31 #y(31))
(check-encoding 32 #y(32))
(check-encoding 42 #y(42))

;;; Sometimes we mark something as an "end of range", when it's not
;;; actually the last character that would use that encoding form.
;;; This is because not all character set numbers are assigned, and we
;;; can't use unassigned character set numbers.  So the value given is
;;; the last value which actually corresponds to something in a real
;;; character set.

;; Check some characters encoded in two bytes.
(check-encoding 2208 #y(#x81 #xA0)) ; beginning of range
(check-encoding 3839 #y(#x8d #xFF)) ; end of range
(check-encoding 2273 #y(#x81 #xE1))

;; Check some big characters encoded in three bytes.
(check-encoding 20512  #y(#x90 #xA0 #xA0)) ; beginning of range
(check-encoding 180223 #y(#x99 #xFF #xFF)) ; end of range
(check-encoding 53931  #y(#x92 #xA5 #xAB))

;; Check some small characters encoded in three bytes --- some from
;; the #x9A prefix range, and some from the #x9B prefix range.
(check-encoding 6176   #y(#x9A #xA0 #xA0))  ; start of the #9A prefix range
(check-encoding 7167   #y(#x9A #xA7 #xFF))  ; end   of the #9A prefix range
(check-encoding 14368  #y(#x9B #xE0 #xA0))  ; start of the #9B prefix range
(check-encoding 14591  #y(#x9B #xE1 #xFF))  ; end   of the #9B prefix range

;; Check some characters encoded in four bytes.
(check-encoding 266272 #y(#x9C #xF0 #xA0 #xA0)) ; start of the #9C prefix range
(check-encoding 294911 #y(#x9C #xF1 #xFF #xFF)) ; end   of the #9C prefix range
(check-encoding 348192 #y(#x9D #xF5 #xA0 #xA0)) ; start of the #9D prefix range
(check-encoding 475135 #y(#x9D #xFC #xFF #xFF)) ; start of the #9D prefix range


code:
;;;; net-db.test --- Test suite for `net-db' -*- mode: scheme; coding: utf-8; -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; 	Copyright (C) 2010 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 3 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-net-db)
  #:use-module (srfi srfi-1)
  #:use-module (test-suite lib))

(if (provided? 'net-db)
    (with-test-prefix "getaddrinfo"

      (pass-if "127.0.0.1, any service"
        (let ((ai (getaddrinfo "127.0.0.1" #f AI_NUMERICHOST)))
          (and (> (length ai) 0)
               (fold (lambda (sa ok?)
                       (and ok?
                            (= (sockaddr:addr sa) INADDR_LOOPBACK)))
                     #t
                     (map addrinfo:addr ai)))))

      (pass-if "127.0.0.1:80"
        (let ((ai (getaddrinfo "127.0.0.1" "80"
                               (logior AI_NUMERICHOST AI_NUMERICSERV))))
          (and (> (length ai) 0)
               (fold (lambda (sa ok?)
                       (and ok?
                            (= (sockaddr:addr sa) INADDR_LOOPBACK)
                            (= (sockaddr:port sa) 80)))
                     #t
                     (map addrinfo:addr ai)))))

      (pass-if "port 80"
        (let ((ai (getaddrinfo #f "80" (logior AI_ADDRCONFIG AI_NUMERICSERV))))
          (and (> (length ai) 0)
               (fold (lambda (ai ok?)
                       (let ((sa (addrinfo:addr ai)))
                         (and ok?
                              (= (sockaddr:port sa) 80))))
                     #t
                     ai))))

      (pass-if "port 80 with family and socket type"
        (let ((ai (getaddrinfo #f "80" (logior AI_ADDRCONFIG AI_NUMERICSERV)
                               AF_UNSPEC SOCK_STREAM)))
          (and (> (length ai) 0)
               (fold (lambda (ai ok?)
                       (let ((sa (addrinfo:addr ai)))
                         (and ok?
                              (= (sockaddr:port sa) 80))))
                     #t
                     ai))))

      (pass-if "no name"
        (catch 'getaddrinfo-error
          (lambda ()
            (getaddrinfo "does-not-exist")
            #f)
          (lambda (key errcode)
            ;; In some cases (e.g., in a chroot without
            ;; /etc/{hosts,resolv.conf}), this can result in `EAI_EAGAIN'.
            (and (or (= errcode EAI_NONAME)
                     (= errcode EAI_AGAIN))
                 (string? (gai-strerror errcode))))))

      (pass-if "wrong service name"
        (catch 'getaddrinfo-error
          (lambda ()
            (getaddrinfo "127.0.0.1" "does-not-exist" AI_NUMERICHOST)

            ;; XXX: The call above unexpectedly suceeds on
            ;; `i386-apple-darwin9.2.2', but not on `i386-apple-darwin9.6.0'.
            ;; For now we just skip it until a better solution is found.  See
            ;; http://lists.gnu.org/archive/html/bug-gnulib/2010-02/msg00061.html
            ;; for details.
            (if (string-contains %host-type "darwin9.2")
                (throw 'unresolved)
                #f))
          (lambda (key errcode)
            ;; According to POSIX, both error codes are valid (glibc 2.11
            ;; chooses `EAI_SERVICE'; Darwin chooses `EAI_NONAME'.)
            (and (or (= errcode EAI_SERVICE)
                     (= errcode EAI_NONAME))
                 (string? (gai-strerror errcode))))))))