code:
;;;; hooks.test --- tests guile's hooks implementation  -*- 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 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

;;;
;;; miscellaneous
;;;

;; FIXME:  Maybe a standard wrong-num-arg exception should be thrown instead
;; of a misc-error?  If so, the tests should be changed to expect failure.
(define exception:wrong-num-hook-args
  (cons 'misc-error "Hook .* requires .* arguments"))

;;;
;;; {The tests}
;;;

(let  ((proc1 (lambda (x) (+ x 1)))
       (proc2 (lambda (x) (- x 1)))
       (bad-proc (lambda (x y) #t)))
  (with-test-prefix "hooks"
   (pass-if "make-hook"
     (make-hook 1)
     #t)

   (pass-if "add-hook!"
     (let ((x (make-hook 1)))
       (add-hook! x proc1)
       (add-hook! x proc2)
       #t))

   (with-test-prefix "add-hook!"
		     (pass-if "append"
			      (let ((x (make-hook 1)))
				(add-hook! x proc1)
				(add-hook! x proc2 #t)
				(eq? (cadr (hook->list x))
				     proc2)))
		     (pass-if-exception "illegal proc"
		       exception:wrong-type-arg
		       (let ((x (make-hook 1)))
			 (add-hook! x bad-proc)))
		     (pass-if-exception "illegal hook"
		       exception:wrong-type-arg
		       (add-hook! '(foo) proc1)))
   (pass-if "run-hook"
	    (let ((x (make-hook 1)))
	      (add-hook! x proc1)
	      (add-hook! x proc2)
	      (run-hook x 1)
	      #t))
  (with-test-prefix "run-hook"
		    (pass-if-exception "bad hook"
		      exception:wrong-type-arg
		      (let ((x (cons 'a 'b)))
			(run-hook x 1)))
		    (pass-if-exception "too many args"
		      exception:wrong-num-hook-args
		      (let ((x (make-hook 1)))
			(add-hook! x proc1)
			(add-hook! x proc2)
			(run-hook x 1 2)))

		    (pass-if
		     "destructive procs"
		     (let ((x (make-hook 1))
			   (dest-proc1 (lambda (x)
					 (set-car! x
						   'i-sunk-your-battleship)))
			   (dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
			   (val '(a-game-of battleship)))
		       (add-hook! x dest-proc1)
		       (add-hook! x dest-proc2 #t)
		       (run-hook x val)
		       (and (eq? (car val) 'i-sunk-your-battleship)
			    (eq? (cdr val) 'no-way!)))))

  (with-test-prefix "remove-hook!"
		    (pass-if ""
			     (let ((x (make-hook 1)))
			       (add-hook! x proc1)
			       (add-hook! x proc2)
			       (remove-hook! x proc1)
			       (not (memq proc1 (hook->list x)))))
		    ; Maybe it should error, but this is probably
		    ; more convienient
		    (pass-if "empty hook"
		      (let ((x (make-hook 1)))
			(remove-hook! x proc1)
			#t)))
  (pass-if "hook->list"
	   (let ((x (make-hook 1)))
	     (add-hook! x proc1)
	     (add-hook! x proc2)
	     (and (memq proc1 (hook->list x))
		  (memq proc2 (hook->list x))
		  #t)))
  (pass-if "reset-hook!"
	   (let ((x (make-hook 1)))
	     (add-hook! x proc1)
	     (add-hook! x proc2)
	     (reset-hook! x)
	     (null? (hook->list x))))
  (with-test-prefix "reset-hook!"
		    (pass-if "empty hook"
			     (let ((x (make-hook 1)))
			       (reset-hook! x)
			       #t))
		    (pass-if-exception "bad hook"
                      exception:wrong-type-arg
		      (reset-hook! '(a b))))))


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 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 (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: unknown


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

(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:
;;;; 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 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

(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 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-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)

(if (defined? '%nil)
    ;; 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:
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-

;;;; Copyright (C) 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

(use-modules (test-suite lib))

(with-test-prefix "autoload"

  (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))))


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 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

(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