code:
;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-eval)
  :use-module (test-suite lib)
  :use-module ((srfi srfi-1) :select (unfold count))
  :use-module (ice-9 documentation))

(define exception:bad-expression
  (cons 'syntax-error "Bad expression"))

;;;
;;; miscellaneous
;;;

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

;;;
;;; memoization
;;;

(with-test-prefix "memoization"

  (with-test-prefix "copy-tree"

    (pass-if "(#t . #(#t))"
      (let* ((foo (cons #t (vector #t)))
             (bar (copy-tree foo)))
        (vector-set! (cdr foo) 0 #f)
        (equal? bar '(#t . #(#t)))))

    (pass-if-exception "circular lists in forms"
      exception:bad-expression
      (let ((foo (list #f)))
        (set-cdr! foo foo)
        (copy-tree foo))))

  (pass-if "transparency"
    (let ((x '(begin 1)))
      (eval x (current-module))
      (equal? '(begin 1) x))))

;;;
;;; eval
;;;

(with-test-prefix "evaluator"

  (with-test-prefix "symbol lookup"

    (with-test-prefix "top level"

      (with-test-prefix "unbound"

	(pass-if-exception "variable reference"
	  exception:unbound-var
	  x)

	(pass-if-exception "procedure"
	  exception:unbound-var
	  (x)))))

  (with-test-prefix "parameter error"

    ;; This is currently a bug in guile:
    ;; Macros are accepted as function parameters.
    ;; Functions that 'apply' macros are rewritten!!!

    (expect-fail-exception "macro as argument"
      exception:wrong-type-arg
      (let ((f (lambda (p a b) (p a b))))
	(f and #t #t)))

    (expect-fail-exception "passing macro as parameter"
      exception:wrong-type-arg
      (let* ((f (lambda (p a b) (p a b)))
	     (foo (procedure-source f)))
	(f and #t #t)
	(equal? (procedure-source f) foo)))

    ))

;;;
;;; call
;;;

(with-test-prefix "call"

  (with-test-prefix "wrong number of arguments"

    (pass-if-exception "((lambda () #f) 1)"
      exception:wrong-num-args
      ((lambda () #f) 1))

    (pass-if-exception "((lambda (x) #f))"
      exception:wrong-num-args
      ((lambda (x) #f)))

    (pass-if-exception "((lambda (x) #f) 1 2)"
      exception:wrong-num-args
      ((lambda (x) #f) 1 2))

    (pass-if-exception "((lambda (x y) #f))"
      exception:wrong-num-args
      ((lambda (x y) #f)))

    (pass-if-exception "((lambda (x y) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1))

    (pass-if-exception "((lambda (x y) #f) 1 2 3)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1 2 3))

    (pass-if-exception "((lambda (x . rest) #f))"
      exception:wrong-num-args
      ((lambda (x . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f))"
      exception:wrong-num-args
      ((lambda (x y . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y . rest) #f) 1))))

;;;
;;; apply
;;;

(with-test-prefix "apply"

  (with-test-prefix "scm_tc7_subr_2o"

    ;; prior to guile 1.6.9 and 1.8.1 this called the function with
    ;; SCM_UNDEFIEND, which in the case of make-vector resulted in
    ;; wrong-type-arg, instead of the intended wrong-num-args
    (pass-if-exception "0 args" exception:wrong-num-args
      (apply make-vector '()))

    (pass-if "1 arg"
      (vector? (apply make-vector '(1))))

    (pass-if "2 args"
      (vector? (apply make-vector '(1 2))))

    ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
    (pass-if-exception "3 args" exception:wrong-num-args
      (apply make-vector '(1 2 3)))))

;;;
;;; map
;;;

(with-test-prefix "map"

  ;; Is documentation available?

  (expect-fail "documented?"
    (documented? map))

  (with-test-prefix "argument error"

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

    (with-test-prefix "different length lists"

      (pass-if-exception "first list empty"
	exception:out-of-range
	(map + '() '(1)))

      (pass-if-exception "second list empty"
	exception:out-of-range
	(map + '(1) '()))

      (pass-if-exception "first list shorter"
	exception:out-of-range
	(map + '(1) '(2 3)))

      (pass-if-exception "second list shorter"
	exception:out-of-range
	(map + '(1 2) '(3)))
    )))

;;;
;;; define with procedure-name
;;;

(define old-procnames-flag (memq 'procnames (debug-options)))
(debug-enable 'procnames)

;; names are only set on top-level procedures (currently), so these can't be
;; hidden in a let
;;
(define foo-closure (lambda () "hello"))
(define bar-closure foo-closure)
(define foo-pws (make-procedure-with-setter car set-car!))
(define bar-pws foo-pws)

(with-test-prefix "define set procedure-name"

  (pass-if "closure"
    (eq? 'foo-closure (procedure-name bar-closure)))

  (pass-if "procedure-with-setter"
    (eq? 'foo-pws (pk (procedure-name bar-pws)))))

(if old-procnames-flag
    (debug-enable 'procnames)
    (debug-disable 'procnames))

;;;
;;; promises
;;;

(with-test-prefix "promises"

  (with-test-prefix "basic promise behaviour"

    (pass-if "delay gives a promise"
      (promise? (delay 1)))

    (pass-if "force evaluates a promise"
      (eqv? (force (delay (+ 1 2))) 3))

    (pass-if "a forced promise is a promise"
      (let ((p (delay (+ 1 2))))
	(force p)
	(promise? p)))

    (pass-if "forcing a forced promise works"
      (let ((p (delay (+ 1 2))))
	(force p)
	(eqv? (force p) 3)))

    (pass-if "a promise is evaluated once"
      (let* ((x 1)
	     (p (delay (+ x 1))))
	(force p)
	(set! x (+ x 1))
	(eqv? (force p) 2)))

    (pass-if "a promise may call itself"
      (define p
	(let ((x 0))
	  (delay
	    (begin
	      (set! x (+ x 1))
	      (if (> x 1) x (force p))))))
      (eqv? (force p) 2))

    (pass-if "a promise carries its environment"
      (let* ((x 1) (p #f))
	(let* ((x 2))
	  (set! p (delay (+ x 1))))
	(eqv? (force p) 3)))

    (pass-if "a forced promise does not reference its environment"
      (let* ((g (make-guardian))
	     (p #f))
	(let* ((x (cons #f #f)))
	  (g x)
	  (set! p (delay (car x))))
	(force p)
	(gc)
	(if (not (equal? (g) (cons #f #f)))
	    (throw 'unresolved)
	    #t))))

  (with-test-prefix "extended promise behaviour"

    (pass-if-exception "forcing a non-promise object is not supported"
      exception:wrong-type-arg
      (force 1))

    (pass-if-exception "implicit forcing is not supported"
      exception:wrong-type-arg
      (+ (delay (* 3 7)) 13))

    ;; Tests that require the debugging evaluator...
    (with-debugging-evaluator

      (pass-if "unmemoizing a promise"
        (display-backtrace
	 (let ((stack #f))
	   (false-if-exception (lazy-catch #t
					   (lambda ()
					     (let ((f (lambda (g) (delay (g)))))
					       (force (f error))))
					   (lambda _
					     (set! stack (make-stack #t)))))
	   stack)
	 (%make-void-port "w"))
	#t))))

;;;
;;; stacks
;;;

(define (stack->frames stack)
  ;; Return the list of frames comprising STACK.
  (unfold (lambda (i)
            (>= i (stack-length stack)))
          (lambda (i)
            (stack-ref stack i))
          1+
          0))

(with-test-prefix "stacks"
  (with-debugging-evaluator

    (pass-if "stack involving a subr"
      ;; The subr involving the error must appear exactly once on the stack.
      (catch 'result
        (lambda ()
          (start-stack 'foo
            (lazy-catch 'wrong-type-arg
              (lambda ()
                ;; Trigger a `wrong-type-arg' exception.
                (fluid-ref 'not-a-fluid))
              (lambda _
                (let* ((stack  (make-stack #t))
                       (frames (stack->frames stack)))
                  (throw 'result
                         (count (lambda (frame)
                                  (and (frame-procedure? frame)
                                       (eq? (frame-procedure frame)
                                            fluid-ref)))
                                frames)))))))
        (lambda (key result)
          (= 1 result))))

    (pass-if "stack involving a gsubr"
      ;; The gsubr involving the error must appear exactly once on the stack.
      ;; This is less obvious since gsubr application may require an
      ;; additional `SCM_APPLY ()' call, which should not be visible to the
      ;; application.
      (catch 'result
        (lambda ()
          (start-stack 'foo
            (lazy-catch 'wrong-type-arg
              (lambda ()
                ;; Trigger a `wrong-type-arg' exception.
                (hashq-ref 'wrong 'type 'arg))
              (lambda _
                (let* ((stack  (make-stack #t))
                       (frames (stack->frames stack)))
                  (throw 'result
                         (count (lambda (frame)
                                  (and (frame-procedure? frame)
                                       (eq? (frame-procedure frame)
                                            hashq-ref)))
                                frames)))))))
        (lambda (key result)
          (= 1 result))))))

;;;
;;; letrec init evaluation
;;;

(with-test-prefix "letrec init evaluation"

  (pass-if "lots of inits calculated in correct order"
    (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
		     (e 'e) (f 'f) (g 'g) (h 'h)
		     (i 'i) (j 'j) (k 'k) (l 'l)
		     (m 'm) (n 'n) (o 'o) (p 'p)
		     (q 'q) (r 'r) (s 's) (t 't)
		     (u 'u) (v 'v) (w 'w) (x 'x)
		     (y 'y) (z 'z))
	      (list a b c d e f g h i j k l m
		    n o p q r s t u v w x y z))
	    '(a b c d e f g h i j k l m
	      n o p q r s t u v w x y z))))

;;;
;;; values
;;;

(with-test-prefix "values"

  (pass-if "single value"
    (equal? 1 (values 1)))

  (pass-if "call-with-values"
    (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
            '(1 2 3 4)))

  (pass-if "equal?"
    (equal? (values 1 2 3 4) (values 1 2 3 4))))

;;; eval.test ends here


code:
;;;; exceptions.test --- tests for Guile's exception handling  -*- scheme -*-
;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(use-modules (test-suite lib))

(define-macro (throw-test title result . exprs)
  `(pass-if ,title
     (equal? ,result
	     (letrec ((stack '())
		      (push (lambda (val)
			      (set! stack (cons val stack)))))
	       (begin ,@exprs)
	       ;;(display ,title)
	       ;;(display ": ")
	       ;;(write (reverse stack))
	       ;;(newline)
	       (reverse stack)))))

(with-test-prefix "throw/catch"

  (with-test-prefix "wrong type argument"

    (pass-if-exception "(throw 1)"
      exception:wrong-type-arg
      (throw 1)))

  (with-test-prefix "wrong number of arguments"

    (pass-if-exception "(throw)"
      exception:wrong-num-args
      (throw))

    (pass-if-exception "throw 1 / catch 0"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda () #f)))

    (pass-if-exception "throw 2 / catch 1"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a 2))
	(lambda (x) #f)))

    (pass-if-exception "throw 1 / catch 2"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda (x y) #f)))

    (pass-if-exception "throw 3 / catch 2"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a 2 3))
	(lambda (y x) #f)))

    (pass-if-exception "throw 1 / catch 2+"
      exception:wrong-num-args
      (catch 'a
	(lambda () (throw 'a))
	(lambda (x y . rest) #f))))

  (with-test-prefix "with lazy handler"

    (pass-if "lazy fluid state"
      (equal? '(inner outer arg)
       (let ((fluid-parm (make-fluid))
	     (inner-val #f))
	 (fluid-set! fluid-parm 'outer)
	 (catch 'misc-exc
	   (lambda ()
	     (with-fluids ((fluid-parm 'inner))
	       (throw 'misc-exc 'arg)))
	   (lambda (key . args)
	     (list inner-val
		   (fluid-ref fluid-parm)
		   (car args)))
	   (lambda (key . args)
	     (set! inner-val (fluid-ref fluid-parm))))))))

  (throw-test "normal catch"
	      '(1 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))))

  (throw-test "catch and lazy catch"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (lazy-catch 'a
				   (lambda ()
				     (push 2)
				     (throw 'a))
				   (lambda (key . args)
				     (push 3))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with rethrowing lazy catch handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (lazy-catch 'a
				   (lambda ()
				     (push 2)
				     (throw 'a))
				   (lambda (key . args)
				     (push 3)
				     (apply throw key args))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with pre-unwind handler"
	      '(1 3 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))
		     (lambda (key . args)
		       (push 3))))

  (throw-test "catch with rethrowing pre-unwind handler"
	      '(1 3 2)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (throw 'a))
		     (lambda (key . args)
		       (push 2))
		     (lambda (key . args)
		       (push 3)
		       (apply throw key args))))

  (throw-test "catch with throw handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'a
					   (lambda ()
					     (push 2)
					     (throw 'a))
					   (lambda (key . args)
					     (push 3))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "catch with rethrowing throw handler"
	      '(1 2 3 4)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'a
					   (lambda ()
					     (push 2)
					     (throw 'a))
					   (lambda (key . args)
					     (push 3)
					     (apply throw key args))))
		     (lambda (key . args)
		       (push 4))))

  (throw-test "effect of lazy-catch unwinding on throw to another key"
	      '(1 2 3 5 7)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (lazy-catch 'b
				   (lambda ()
				     (push 2)
				     (catch 'a
					    (lambda ()
					      (push 3)
					      (throw 'b))
					    (lambda (key . args)
					      (push 4))))
				   (lambda (key . args)
				     (push 5)
				     (throw 'a)))
		       (push 6))
		     (lambda (key . args)
		       (push 7))))

  (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
	      '(1 2 3 5 4 6)
	      (catch 'a
		     (lambda ()
		       (push 1)
		       (with-throw-handler 'b
				   (lambda ()
				     (push 2)
				     (catch 'a
					    (lambda ()
					      (push 3)
					      (throw 'b))
					    (lambda (key . args)
					      (push 4))))
				   (lambda (key . args)
				     (push 5)
				     (throw 'a)))
		       (push 6))
		     (lambda (key . args)
		       (push 7))))

  (throw-test "lazy-catch chaining"
	      '(1 2 3 4 6 8)
	      (catch 'a
	        (lambda ()
		  (push 1)
		  (lazy-catch 'a
		    (lambda ()
		      (push 2)
		      (lazy-catch 'a
                        (lambda ()
			  (push 3)
			  (throw 'a))
			(lambda (key . args)
			  (push 4)))
		      (push 5))
		    (lambda (key . args)
		      (push 6)))
		  (push 7))
		(lambda (key . args)
		  (push 8))))

  (throw-test "with-throw-handler chaining"
	      '(1 2 3 4 6 8)
	      (catch 'a
	        (lambda ()
		  (push 1)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 2)
		      (with-throw-handler 'a
                        (lambda ()
			  (push 3)
			  (throw 'a))
			(lambda (key . args)
			  (push 4)))
		      (push 5))
		    (lambda (key . args)
		      (push 6)))
		  (push 7))
		(lambda (key . args)
		  (push 8))))

  (throw-test "with-throw-handler inside lazy-catch"
	      '(1 2 3 4 6 8)
	      (catch 'a
	        (lambda ()
		  (push 1)
		  (lazy-catch 'a
		    (lambda ()
		      (push 2)
		      (with-throw-handler 'a
                        (lambda ()
			  (push 3)
			  (throw 'a))
			(lambda (key . args)
			  (push 4)))
		      (push 5))
		    (lambda (key . args)
		      (push 6)))
		  (push 7))
		(lambda (key . args)
		  (push 8))))

  (throw-test "lazy-catch inside with-throw-handler"
	      '(1 2 3 4 6 8)
	      (catch 'a
	        (lambda ()
		  (push 1)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 2)
		      (lazy-catch 'a
                        (lambda ()
			  (push 3)
			  (throw 'a))
			(lambda (key . args)
			  (push 4)))
		      (push 5))
		    (lambda (key . args)
		      (push 6)))
		  (push 7))
		(lambda (key . args)
		  (push 8))))

  (throw-test "throw handlers throwing to each other recursively"
	      '(1 2 3 4 8 6 10 12)
	      (catch #t
                (lambda ()
		  (push 1)
		  (with-throw-handler 'a
                    (lambda ()
		      (push 2)
		      (with-throw-handler 'b
		        (lambda ()
			  (push 3)
			  (with-throw-handler 'c
			    (lambda ()
			      (push 4)
			      (throw 'b)
			      (push 5))
			    (lambda (key . args)
			      (push 6)
			      (throw 'a)))
			  (push 7))
			(lambda (key . args)
			  (push 8)
			  (throw 'c)))
		      (push 9))
		    (lambda (key . args)
		      (push 10)
		      (throw 'b)))
		  (push 11))
		(lambda (key . args)
		  (push 12))))

  (throw-test "repeat of previous test but with lazy-catch"
	      '(1 2 3 4 8 12)
	      (catch #t
                (lambda ()
		  (push 1)
		  (lazy-catch 'a
                    (lambda ()
		      (push 2)
		      (lazy-catch 'b
		        (lambda ()
			  (push 3)
			  (lazy-catch 'c
			    (lambda ()
			      (push 4)
			      (throw 'b)
			      (push 5))
			    (lambda (key . args)
			      (push 6)
			      (throw 'a)))
			  (push 7))
			(lambda (key . args)
			  (push 8)
			  (throw 'c)))
		      (push 9))
		    (lambda (key . args)
		      (push 10)
		      (throw 'b)))
		  (push 11))
		(lambda (key . args)
		  (push 12))))

  (throw-test "throw handler throwing to lexically inside catch"
	      '(1 2 7 5 4 6 9)
	      (with-throw-handler 'a
				  (lambda ()
				    (push 1)
				    (catch 'b
					   (lambda ()
					     (push 2)
					     (throw 'a)
					     (push 3))
					   (lambda (key . args)
					     (push 4))
					   (lambda (key . args)
					     (push 5)))
				    (push 6))
				  (lambda (key . args)
				    (push 7)
				    (throw 'b)
				    (push 8)))
	      (push 9))

  (throw-test "reuse of same throw handler after lexically inside catch"
	      '(0 1 2 7 5 4 6 7 10)
	      (catch 'b
	        (lambda ()
		  (push 0)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 1)
		      (catch 'b
		        (lambda ()
			  (push 2)
			  (throw 'a)
			  (push 3))
			(lambda (key . args)
			  (push 4))
			(lambda (key . args)
			  (push 5)))
		      (push 6)
		      (throw 'a))
		    (lambda (key . args)
		      (push 7)
		      (throw 'b)
		      (push 8)))
		  (push 9))
		(lambda (key . args)
		  (push 10))))

  (throw-test "again but with two chained throw handlers"
	      '(0 1 11 2 13 7 5 4 12 13 7 10)
	      (catch 'b
	        (lambda ()
		  (push 0)
		  (with-throw-handler 'a
		    (lambda ()
		      (push 1)
		      (with-throw-handler 'a
		        (lambda ()
			  (push 11)
			  (catch 'b
			    (lambda ()
			      (push 2)
			      (throw 'a)
			      (push 3))
			    (lambda (key . args)
			      (push 4))
			    (lambda (key . args)
			      (push 5)))
			  (push 12)
			  (throw 'a))
			(lambda (key . args)
			  (push 13)))
		      (push 6))
		    (lambda (key . args)
		      (push 7)
		      (throw 'b)))
		  (push 9))
		(lambda (key . args)
		  (push 10))))

  )

(with-test-prefix "false-if-exception"

  (pass-if (false-if-exception #t))
  (pass-if (not (false-if-exception #f)))
  (pass-if (not (false-if-exception (error "xxx"))))

  ;; Not yet working.
  ;;
  ;; (with-test-prefix "in empty environment"
  ;;   ;; an environment with no bindings at all
  ;;   (define empty-environment
  ;;     (make-module 1))
  ;;
  ;;   (pass-if "#t"
  ;;     (eval `(,false-if-exception #t)
  ;; 	    empty-environment))
  ;;   (pass-if "#f"
  ;;     (not (eval `(,false-if-exception #f)
  ;; 		 empty-environment)))
  ;;   (pass-if "exception"
  ;;     (not (eval `(,false-if-exception (,error "xxx"))
  ;;                empty-environment))))
  )

license: unknown


code:
;;;; filesys.test --- test file system functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-filesys)
  #:use-module (test-suite lib)
  #:use-module (test-suite guile-test))

(define (test-file)
  (data-file-name "filesys-test.tmp"))
(define (test-symlink)
  (data-file-name "filesys-test-link.tmp"))

;;;
;;; copy-file
;;;

(with-test-prefix "copy-file"

  ;; return next prospective file descriptor number
  (define (next-fd)
    (let ((fd (dup 0)))
      (close fd)
      fd))

  ;; in guile 1.6.4 and earlier, copy-file didn't close the input fd when
  ;; the output could not be opened
  (pass-if "fd leak when dest unwritable"
    (let ((old-next (next-fd)))
      (false-if-exception (copy-file "/dev/null" "no/such/dir/foo"))
      (= old-next (next-fd)))))

;;;
;;; lstat
;;;

(with-test-prefix "lstat"

  (pass-if "normal file"
    (call-with-output-file (test-file)
      (lambda (port)
	(display "hello" port)))
    (eqv? 5 (stat:size (lstat (test-file)))))

  (call-with-output-file (test-file)
    (lambda (port)
      (display "hello" port)))
  (false-if-exception (delete-file (test-symlink)))
  (if (not (false-if-exception
	    (begin (symlink (test-file) (test-symlink)) #t)))
      (display "cannot create symlink, lstat test skipped\n")
      (pass-if "symlink"
	;; not much to test, except that it works
	(->bool (lstat (test-symlink))))))

;;;
;;; opendir and friends
;;;

(with-test-prefix "opendir"

  (with-test-prefix "root directory"
    (let ((d (opendir "/")))
      (pass-if "not empty"
	(string? (readdir d)))
      (pass-if "all entries are strings"
	(let more ()
	  (let ((f (readdir d)))
	    (cond ((string? f)
		   (more))
		  ((eof-object? f)
		   #t)
		  (else
		   #f)))))
      (closedir d))))

;;;
;;; stat
;;;

(with-test-prefix "stat"

  (with-test-prefix "filename"

    (pass-if "size"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (eqv? 5 (stat:size (stat (test-file))))))

  (with-test-prefix "file descriptor"

    (pass-if "size"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let* ((fd (open-fdes (test-file) O_RDONLY))
	     (st (stat fd)))
	(close-fdes fd)
	(eqv? 5 (stat:size st)))))

  (with-test-prefix "port"

    (pass-if "size"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let* ((port (open-file (test-file) "r+"))
	     (st   (stat port)))
	(close-port port)
	(eqv? 5 (stat:size st))))))

(delete-file (test-file))
(delete-file (test-symlink))


code:
;;;; format.test --- test suite for Guile's CL-ish format  -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
;;;; 	Copyright (C) 2001, 2003, 2004, 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-format)
  #:use-module (test-suite lib)
  #:use-module (ice-9 format))

;;; FORMAT Basic Output

(with-test-prefix "format basic output"
  (pass-if "format ~% produces a new line"
	   (string=? (format "~%") "\n"))
  (pass-if "format ~& starts a fresh line"
	   (string=? (format "~&abc~&~&") "abc\n"))
  (pass-if "format ~& is stateless but works properly across outputs via port-column"
	   (string=?
	    (with-output-to-string
	      (lambda ()
		(display "xyz")
		(format #t "~&abc")
		(format #f "~&")	; shall have no effect
		(format #t "~&~&")))
	    "xyz\nabc\n"))
  (pass-if "format ~F (format-out-substr) maintains the column correctly"
	   (= (string-length (format "~@F~20T" 1)) 20)))

;;;
;;; misc
;;;

(with-test-prefix "format"

  ;; in guile 1.6.4 and earlier, excess arguments were an error, but this
  ;; changed to follow the common lisp spec
  (pass-if "excess arguments ignored A"
    (string=? (format #f "" 1 2 3 4) ""))
  (pass-if "excess arguments ignored B"
    (string=? (format #f "~a ~a" 1 2 3 4) "1 2")))

;;;
;;; ~d
;;;

(with-test-prefix "~d decimal integer"

  (with-test-prefix "~@d"

    (pass-if "-1"
      (string=? (format #f "~@d" -1) "-1"))

    ;; in guile 1.6.4 and earlier, ~@d gave "0" but we think "+0" is what the
    ;; common lisp spec intendes
    (pass-if "+0"
      (string=? (format #f "~@d" 0) "+0"))

    (pass-if "+1"
      (string=? (format #f "~@d" 1) "+1"))))

;;;
;;; ~f
;;;

(with-test-prefix "~f fixed-point"

  (pass-if "1.5"
    (string=? "1.5" (format #f "~f" 1.5)))

  ;; in guile prior to 1.6.9 and 1.8.1, leading zeros were incorrectly
  ;; stripped, moving the decimal point and giving "25.0" here
  (pass-if "string 02.5"
    (string=? "2.5" (format #f "~f" "02.5"))))

;;;
;;; ~{
;;;

(with-test-prefix "~{ iteration"

  ;; In Guile 1.6.4 and earlier, the maximum iterations parameter defaulted
  ;; to 100, but it's now like Common Lisp where the default is no limit
  (pass-if "no arbitrary iteration limit"
    (= (string-length (format "~{~a~}" (make-list 200 #\b))) 200)))


code:
;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License version 2 as
;;;; published by the Free Software Foundation; see file GNU-GPL.
;;;;
;;;; 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 program; if not, write to the Free Software Foundation,
;;;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.

;;;; Based in part on code from GNU CLISP, Copyright (C) 1993 Michael Stoll

(define-module (test-suite test-fractions)
  #:use-module (test-suite lib)
  #:use-module (ice-9 documentation)
  #:use-module (oop goops))

(defmacro test= (a b)
  `(pass-if ,(format #f "(= ~A ~A)" a b) (= ,a ,b)))

(defmacro testeqv (a b)
  `(pass-if ,(format #f "(eqv? ~A ~A)" a b) (eqv? ,a ,b)))

(defmacro testeq (a b)
  `(pass-if ,(format #f "(eq? ~A ~A)" a b) (eq? ,a ,b)))

(defmacro teststr= (a b)
  `(pass-if ,(format #f "(string=? ~A ~A)" a b) (string=? ,a ,b)))

(with-test-prefix "fractions"

  (test= 3/4 .75)
  (test= 3000000000000/4000000000000 .75)
  (test= .75 3/4)
  (test= .75 3000000000000/4000000000000)
  (testeqv 3/4 6/8)
  (testeqv 3/4 3000000000000/4000000000000)
  (testeqv 3 3/1)

  (test= -1 (/ most-negative-fixnum (- most-negative-fixnum)))
  (testeq #t (integer? (/ most-negative-fixnum (- most-negative-fixnum))))

  (testeqv (+ 1/4 1/2) 3/4)
  (testeqv (* 1/4 2/3) 1/6)
  (testeqv (/ 1/4 2/3) 3/8)
  (testeqv (+ 1/4 2/3) 11/12)
  (testeqv (- 1/4 2/3) -5/12)
  (test= -3/4 -.75)
  (testeqv -3/4 -6/8)
  (testeqv -3/4 (/ 1/2 -2/3))
  (testeqv (* 3/4 2) 3/2)
  (testeqv (* 2 3/4) 3/2)
  (testeqv (* 3/4 0.5) .375)
  (testeqv (* 0.5 3/4) .375)
  (testeqv (* 1/2 2-4i) 1-2i)
  (testeqv (* 2-4i 1/2) 1-2i)
  (testeqv (* 1/2 2+3i) 1+1.5i)
  (testeqv (/ 2+4i 1/2) 4+8i)
  (test= 1/2 0.5+0i)
  (testeqv (- 1/2 0.5+i) -i)
  (testeqv (- 0.5+i 1/2) +i)
  (testeqv (+ 1/2 0.5+i) 1+i)
  (testeqv (+ 0.5+i 1/2) 1+i)
  (testeq (> 1 2/3) #t)
  (testeq (> 2/3 1) #f)
  (testeq (> 1.5 2/3) #t)
  (testeq (> 2/3 1.5) #f)
  (testeq (> 3/4 2/3) #t)
  (testeq (> 2/3 3/4) #f)
  (testeqv (max 1 2/3) 1)
  (testeqv (max 2/3 1) 1)
  (testeqv (max 1 4/3) 4/3)
  (testeqv (max 4/3 1) 4/3)
  (testeqv (max 1.5 4/3) 1.5)
  (testeqv (max 4/3 1.5) 1.5)
  (testeqv (max 4/3 2/3) 4/3)
  (testeqv (max 2/3 4/3) 4/3)
  (testeqv (min 1 2/3) 2/3)
  (testeqv (min 2/3 1) 2/3)
  (testeqv (min 1 4/3) 1)
  (testeqv (min 4/3 1) 1)
  (testeqv (min 1.5 1/2) 0.5)
  (testeqv (min 1/2 1.5) 0.5)
  (testeqv (min 4/3 2/3) 2/3)
  (testeqv (min 2/3 4/3) 2/3)
  (testeq (> 3/4 12345678912345678) #f)
  (testeq (> 12345678912345678 3/4) #t)
  (testeq (< 3/4 12345678912345678) #t)
  (testeq (< 12345678912345678 3/4) #f)
  (testeqv (max 12345678912345678 3/4) 12345678912345678)
  (testeqv (max 3/4 12345678912345678) 12345678912345678)
  (testeqv (min 12345678912345678 3/4) 3/4)
  (testeqv (min 3/4 12345678912345678) 3/4)
  (testeqv (max 3/4 10197734562406803221/17452826108659293487) 3/4)
  (testeqv (max 1/2 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (min 3/4 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (min 1/2 10197734562406803221/17452826108659293487) 1/2)
  (testeqv (max 10197734562406803221/17452826108659293487 10197734562406803221/17) 10197734562406803221/17)
  (testeqv (max 10197734562406803221/174 10197734562406803221/17452826108659293487) 10197734562406803221/174)
  (testeqv (max 10/17452826108659293487 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (max 10197734562406803221/17452826108659293487 10/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (min 10197734562406803221/17452826108659293487 10197734562406803221/17) 10197734562406803221/17452826108659293487)
  (testeqv (min 10197734562406803221/174 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (min 10/17452826108659293487 10197734562406803221/17452826108659293487) 10/17452826108659293487)
  (testeqv (min 10197734562406803221/17452826108659293487 10/17452826108659293487) 10/17452826108659293487)
  (testeqv (expt 2 1/2) (sqrt 2))
  (testeqv (expt 1/2 2) 1/4)
  (testeqv (expt 2.0 1/2) (sqrt 2))
  (testeqv (expt 1/2 2) 1/4)
  (testeqv (real-part 3/4) 3/4)
  (testeqv (imag-part 3/4) 0)
  (testeqv (numerator 3/4) 3)
  (testeqv (denominator 3/4) 4)
  (testeqv (numerator -3/4) -3)
  (testeqv (denominator -3/4) 4)
  (testeqv (numerator 10197734562406803221/17452826108659293487) 10197734562406803221)
  (testeqv (denominator 10197734562406803221/17452826108659293487) 17452826108659293487)
  (testeqv (numerator 1/17452826108659293487) 1)
  (testeqv (denominator 10197734562406803221/17) 17)
  (testeq (rational? 3/4) #t)
  (testeq (rational? 1.5) #t)
  (testeq (rational? 1) #t)
  (testeq (rational? 10197734562406803221/17452826108659293487) #t)
  (testeq (integer? 8/4) #t)
  (testeq (rational? 6/3) #t)
  (testeqv (angle 3/4) 0.0)
  (testeqv (angle -3/4) (atan 0.0 -1.0))
  (testeqv (angle 10197734562406803221/17452826108659293487) 0.0)
  (testeqv (magnitude 3/4) 3/4)
  (testeqv (magnitude -3/4) 3/4)
  (testeqv (magnitude 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (magnitude -10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (abs 3/4) 3/4)
  (testeqv (abs -3/4) 3/4)
  (testeqv (abs 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (abs -10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
  (testeqv (abs 10197734562406803221/174) 10197734562406803221/174)
  (testeqv (abs -10197734562406803221/174) 10197734562406803221/174)
  (testeqv (abs 101/17452826108659293487) 101/17452826108659293487)
  (testeqv (abs -101/17452826108659293487) 101/17452826108659293487)
  (testeqv (exact->inexact 3/4) .75)
  (testeqv (inexact->exact .5) 1/2)
  (testeqv (inexact->exact -.5) -1/2)
  (testeqv (inexact->exact (exact->inexact 2135445/16777216)) 2135445/16777216)
  (testeq (< (- (exact->inexact 10197734562406803221/17452826108659293487)
		.584302765576009) .0000001) #t)
  (testeqv (rationalize #e0.76 1/10) 3/4)
  (testeqv (rationalize #e0.723 1/10) 2/3)
  (testeqv (rationalize #e0.723 1/100) 5/7)
  (testeqv (rationalize #e-0.723 1/100) -5/7)
  (testeqv (rationalize #e10.2 1/100) 51/5)
  (testeqv (rationalize #e-10.2 1/100) -51/5)
  (testeqv (rationalize 10197734562406803221/17452826108659293487 1/10) 1/2)
  (testeqv (rationalize 10197734562406803221/17452826108659293487 1/100) 7/12)
  (testeqv (rationalize 10197734562406803221/17452826108659293487 1/1000) 7/12)
  (testeqv (rationalize 10197734562406803221/17452826108659293487 1/10000) 52/89)
  (testeqv (rationalize 3/10 1/10) 1/3)
  (testeqv (rationalize 3/10 -1/10) 1/3)
  (testeqv (rationalize -3/10 1/10) -1/3)
  (testeqv (rationalize -3/10 -1/10) -1/3)
  (testeqv (rationalize 3/10 4/10) 0)
  (testeq (exact? #i2/3) #f)
  (testeq (exact? -15/16) #t)
  (testeq (exact? (/ 2 3)) #t)
  (testeq (exact? (/ 3000000000000 4000000000000)) #t)
  (testeq (exact? (/ 3 4000000000)) #t)
  (testeq (exact? (/ 4000000000 3)) #t)
  (testeq (exact? (/ 10197734562406803221 17452826108659293487)) #t)
  (testeq (exact? (/ 10197734562406803221 17)) #t)
  (testeq (inexact? #i2/3) #t)
  (testeq (inexact? -15/16) #f)
  (testeq (inexact? (/ 2 3)) #f)
  (testeq (inexact? (/ 3000000000000 4000000000000)) #f)
  (testeq (inexact? (/ 3 4000000000)) #f)
  (testeq (inexact? (/ 4000000000 3)) #f)
  (testeq (inexact? (/ 10197734562406803221 17452826108659293487)) #f)
  (testeq (inexact? (/ 10197734562406803221 17)) #f)
  (testeq (= 2/3 .667) #f)
  (testeq (< 1/2 2/3 3/4) #t)
  (testeqv (+ 1/2 2/3) 7/6)
  (testeqv (* 4 1/2) 2)
  (testeqv (- -2/3) 2/3)
  (testeqv (- 2/3) -2/3)
  (testeqv (+ 2/3) 2/3)
  (testeqv (* 2/3) 2/3)
  (testeqv (/ 2/3) 3/2)
  (testeqv (/ 3 4 5) 3/20)
  (testeqv (* 1 1/2) 1/2)
  (testeqv (+ 1 1/4 1/3) 19/12)
  (testeqv (* 3/5 1/6 3) 3/10)
  (testeqv 0/3 0)
  (testeqv (1- 1/2) -1/2)
  (testeqv (1+ 1/2) 3/2)
  (testeq (zero? 3/4) #f)
  (testeq (zero? 0/4) #t)
  (testeq (positive? 3/4) #t)
  (testeq (negative? 3/4) #f)
  (testeq (positive? 10197734562406803221/17452826108659293487) #t)
  (testeq (negative? 10197734562406803221/17452826108659293487) #f)
  (testeqv (/ 17) 1/17)
  (testeqv (/ 17452826108659293487) 1/17452826108659293487)
  (testeqv (/ -17) -1/17)
  (testeqv (/ -17452826108659293487) -1/17452826108659293487)
  (testeqv (/ 1/2) 2)
  (testeqv (/ 2 3) 2/3)
  (testeqv (/ 2 -3) -2/3)
  (testeq (zero? (+ 1/2 1/2)) #f)
  (testeq (zero? (+ 1/2 -1/2)) #t)
  (testeq (zero? (- 1/2 1/2)) #t)
  (testeqv (/ 60 5 4 3 2) 1/2)
  (test= (truncate 5/4) 1.0)
  (test= (truncate 4/5) 0.0)
  (test= (truncate -2/3) 0.0)
  (test= (truncate 10197734562406803221/17452826108659293487) 0.0)
  (test= (truncate 17452826108659293487/10197734562406803221) 1.0)
  (test= (/ (log 1/2) (log 2)) -1.0)
  (test= (floor 2/3) 0)
  (test= (floor -2/3) -1)
  (test= (floor 10197734562406803221/17452826108659293487) 0)
  (test= (ceiling 2/3) 1)
  (test= (ceiling -2/3) 0)
  (test= (ceiling 10197734562406803221/17452826108659293487) 1)
  (test= (round 2/3) 1.0)
  (test= (round -2/3) -1.0)
  (test= (round 1/3) 0.0)
  (test= (round 10197734562406803221/17452826108659293487) 1.0)
  (testeqv (max 1/2 3/4 4/5 5/6 6/7) 6/7)
  (testeqv (min 1/2 3/4 4/5 5/6 6/7) 1/2)
  (testeqv (expt -1/2 5) -1/32)
  (testeqv (expt 1/2 -10) 1024)
  (testeqv (rationalize #e.3 1/10) 1/3)
  (test= (make-rectangular 1/2 -1/2) 0.5-0.5i)
  (test= (sqrt 1/4) 0.5)
  (testeqv (string->number "3/4") 3/4)
  (testeqv (string->number "-3/4") -3/4)
  (testeqv (string->number "10197734562406803221/17452826108659293487") 10197734562406803221/17452826108659293487)
  (testeqv (string->number "-10197734562406803221/17452826108659293487") -10197734562406803221/17452826108659293487)
  (testeqv (string->number "10/17452826108659293487") 10/17452826108659293487)
  (testeqv (string->number "10197734562406803221/174") 10197734562406803221/174)
  (teststr= (number->string 3/4) "3/4")
  (teststr= (number->string 10197734562406803221/17452826108659293487) "10197734562406803221/17452826108659293487")
  (testeq (eq? 3/4 .75) #f)
  (testeq (eqv? 3/4 .75) #f)
  (testeq (eqv? 3/4 3/4) #t)
  (testeq (eqv? 10197734562406803221/17452826108659293487 10197734562406803221/17452826108659293487) #t)
  (testeq (equal? 3/4 .75) #f)
  (testeq (number? 3/4) #t)
  (testeq (real? 3/4) #t)
  (testeq (integer? 3/4) #f)
  (test= (* 1/2 2.0e40) 1.0e40)
  (test= (* 2.0e40 1/2) 1.0e40)
  (test= (/ 3.0e40 3/2) 2.0e40)
  (testeqv (case 1/2 ((1/2) 1) ((3/4) 2)) 1)
  (testeqv (/ 1 -2) -1/2)
  (testeqv (numerator (/ 1 -2)) -1)
  (testeqv (denominator (/ 1 -2)) 2)
  (testeq (negative? (/ 1 -2)) #t)
  (testeq (positive? (/ 1 -2)) #f)
  (testeqv (/ -1/2 -1/3) 3/2)
  (testeqv (numerator (/ -1/2 -1/3)) 3)
  (testeqv (denominator (/ -1/2 -1/3)) 2)
  (testeq (negative? (/ -1/2 -1/3)) #f)
  (testeq (positive? (/ -1/2 -1/3)) #t)
  (testeqv (numerator 12) 12)
  (testeqv (numerator -12) -12)
  (testeqv (denominator 12) 1)
  (testeqv (denominator -12) 1)
  (testeqv (- 1/2 1/2) 0)
  (testeqv (+ 1/2 1/2) 1)
  (testeqv (/ 1/2 1/2) 1)
  (testeqv (* 2/1 1/2) 1)
  (testeq (complex? 1/2) #t)
  (testeqv (+ (exact->inexact 3/10) (exact->inexact -3/10)) 0.0)
  (testeqv (/ 1/2 1/4) 2)
  (testeqv (/ 2 1/4) 8)
  (testeqv (/ 1/4 2) 1/8)

  (testeqv (floor 5/2) 2)
  (testeqv (ceiling 5/2) 3)
  (testeqv (round 5/2) 2)
  (testeqv (truncate 5/2) 2)
  (testeqv (floor -5/2) -3)
  (testeqv (ceiling -5/2) -2)
  (testeqv (round -5/2) -2)
  (testeqv (truncate -5/2) -2)
  (testeqv (floor 4/3) 1)
  (testeqv (ceiling 4/3) 2)
  (testeqv (round 4/3) 1)
  (testeqv (truncate 4/3) 1)
  (testeqv (floor -4/3) -2)
  (testeqv (ceiling -4/3) -1)
  (testeqv (round -4/3) -1)
  (testeqv (truncate -4/3) -1)
  (testeqv (floor 5/3) 1)
  (testeqv (ceiling 5/3) 2)
  (testeqv (round 5/3) 2)
  (testeqv (truncate 5/3) 1)
  (testeqv (floor -5/3) -2)
  (testeqv (ceiling -5/3) -1)
  (testeqv (round -5/3) -2)
  (testeqv (truncate -5/3) -1)
  (testeqv (floor 11/4) 2)
  (testeqv (ceiling 11/4) 3)
  (testeqv (round 11/4) 3)
  (testeqv (truncate 11/4) 2)
  (testeqv (floor -11/4) -3)
  (testeqv (ceiling -11/4) -2)
  (testeqv (round -11/4) -3)
  (testeqv (truncate -11/4) -2)
  (testeqv (floor 9/4) 2)
  (testeqv (ceiling 9/4) 3)
  (testeqv (round 9/4) 2)
  (testeqv (truncate 9/4) 2)
  (testeqv (floor -9/4) -3)
  (testeqv (ceiling -9/4) -2)
  (testeqv (round -9/4) -2)
  (testeqv (truncate -9/4) -2)

  ;; from Dybvig
  (testeqv (numerator 9.0) 9.0)
  (testeqv (numerator 9) 9)
  (testeqv (numerator -9/4) -9)
  (testeqv (numerator -2.25) -9.0) ; -9/4!
  (testeqv (denominator 0) 1)
  (testeqv (denominator 9) 1)
  (testeqv (denominator 2/3) 3)
  (testeqv (denominator -9/4) 4)
  (testeqv (denominator -2.25) 4.0)
  (testeqv (denominator 9.0) 1.0)
  (testeqv (expt 2 -2) 1/4)
  (testeqv (expt 1/2 2) 1/4)
  (testeqv (expt 1/2 -2) 4)
  (testeqv (expt -1/2 3) -1/8)

  ;; from (GPL'd) Clisp tests
  (test= (+ 1 1/2 0.5 3.0+5.5i) 5.0+5.5i)
  (testeq (let ((error (catch #t (lambda () (/ 1 0)) (lambda args (car args))))) error) 'numerical-overflow)
  (testeq (let ((error (catch #t (lambda () (/ 0)) (lambda args (car args))))) error) 'numerical-overflow)
  (testeq (let ((error (catch #t (lambda () (modulo 1/2 1)) (lambda args (car args))))) error) 'wrong-type-arg)
  (testeq (let ((error (catch #t (lambda () (logand 1/2 1)) (lambda args (car args))))) error) 'wrong-type-arg)
  (testeq (let ((error (catch #t (lambda () (gcd 1/2 3)) (lambda args (car args))))) error) 'wrong-type-arg)
  (testeq (let ((error (catch #t (lambda () (numerator 1+i)) (lambda args (car args))))) error) 'wrong-type-arg)
  (test= (- 0+6i 1/4 0.5 7) -7.75+6.0i)
  (testeqv (rationalize #e2.5 1/1000) 5/2)
  (testeqv (rationalize 7/3 1/1000) 7/3)
  (testeqv (rationalize #e3.14159265 1/10) 22/7)
  (testeqv (numerator (/ 8 -6)) -4)
  (testeqv (denominator (/ 8 -6)) 3)
  (testeqv (gcd (numerator 7/9) (denominator 7/9)) 1)
  (testeqv (/ 10105597264942543888 14352488138967388642) 5052798632471271944/7176244069483694321)
  (testeqv (/ -17631701977702695093 3931860028646338313) -17631701977702695093/3931860028646338313)
  (testeqv (/ -1606495881715082381 16324360910828438638) -1606495881715082381/16324360910828438638)
  (testeqv (/ -7960193178071300653 -10280747961248435844) 7960193178071300653/10280747961248435844)
  (testeqv (+ -6069217517368004039/4076344942716985944 -399587800008780737/578697755310708616) -321318766345655960630110128852941297/147435729263904928853096856396980844)
  (testeqv (+ -41285036778370718/305793940074617155 -1396094619926552183/15846027887642356854) -1081121118676718273499338028514700537/4845619302294419132297197085940230370)
  (testeqv (+ 15975644088444536091/18063939613598316583 17501188199168431305/2979264551795273683) 363736076920798535449296038324193823968/53817254956563877935003279344562385189)
  (testeqv (+ 10197734562406803221/17452826108659293487 14639450560606090654/236781760961536951) 257914422508077920978698094723491089669/4132510899763835955061848877304138137)
  (testeqv (+ 2479135971595944301/28169711053558469409458629766960029324030958129245230797895768033968717159836 3427244662960653095/28446538857424788738244844756675951434179713170118835630969510829753715142438) 83533664807147783700314944003289704497366290621039272787320536148072960487262393639109696219129/400665390043739792096386856839000624247597803909916773326187593475005945995926511155915226239317839405221783416485999405286913042389632370302962776360084)
  (testeqv (+ 14865500635281371370/56222262470894935247131881777606182311286871927285650835673424014252462156319 6436092572090050725/19282524131572095520593158313261757267758159099923763177708581262473988426947) 648496060602737474174747620183913927791943082591316359990137585798909535115053578637078811588665/1084107132826611778585714784136700465449309125114745313342842325649687943726086785657821763235618936882528385000712567133180567926723616940173290425928093)
  (testeqv (+ 340196811925805824067049620503247332111/14422464039094716975 51285507111580975533385007190438537498/3230944134273302873) 1838820276033673324738967436225477772648372110186756083453/46598175588880723338390245118389369175)
  (testeqv (+ -210449319160504160992731982827917332322/5436857856220342451 251628249079137248539965770847855056283/4323109210037952829) 458271632943884346915405609513071881239303671882386130695/23504130271893362375786510953364243879)
  (testeqv (- 8229768172162771789/4094631553683915058 14916542302144281688/9648520391570031013) 18327341244785642013243791303754634353/39507136041685332578233153660317693754)
  (testeqv (- 13554976081719376860/5850035209629724601 -6813034992928443315/16012083383654426278) 256899901877002811987490932642058619395/93671251573905451634945335611797465078)
  (testeqv (- -221798849980968127/896588178875000428 -10118632981534633697/16809799818197706916) 333990778095757160537366868413422249/941966737890699707694484674257410003)
  (testeqv (- -10398409463665680242/10672871071680021919 908300169382593227/1663860017749090135) -2076589873614048366639515256135965791/1366012573135328609279238070700513005)
  (testeqv (- -2198518713248421187/494031967775171833 162489257999262168/3608560229859558061) -8013762081101965644053022173225152351/1782744111192743850497670941715295813)
  (testeqv (- 4025149216228566945/640594137312937394 5467380276809034025/15813352732084653151) 60148732603712157399679443099667862845/10129941051434949990590527231467828494)
  (testeqv (- 1543899448831604569141696144740105016328586790221799945430718394112623114412/1094690716976737526626281319975432667416762320123576900412499904933271786567 -101835025746074730017715423582062511397387458863000475669454309217160145993/55116548932808468782187525862059393507883043749327746382569396580129398962) 196572266866178229534134252625134989714563665559807019513454337864363053729628560611312158082929567528955985669620113192156991984486011150099776316375/60335574468539540262844259780498204139853746803235564167348945699931512713417761400790104247218084745081610815218855896912895393599203789305655343454)
  (testeqv (- -37581128364300495505521143552535972339959603365602244668159915869829949338997/42947503543372015019662104425995959382231280059683481488692141811517675950053 -64888994735350842409379226446854438865448614840503930577860382883594178287934/83188698741706753136718468601650233481619465918167616089202536622553688681087) -339504834548876267781536981106771553482515399809961247195394672491113984585270709765073243997043174508213253440272888923497173265137136111635177948889237/3572746933977957867604303713153220827104741303667912510494658617478381525690274918494624922428110123336345510454960178899375325287131764283538305257747611)
  (testeqv (* -6520062188352981842/3213004995534018829 -3812444292971845716/15284944374811818089) 24857373879807849010516976362973488872/49110602632729971801355498746248797781)
  (testeqv (* -844583948128454879/4750740551331102615 -1309778567130405125/4885884698278749707) 221243590680205607733892613510570975/4642314113048197066962569716783636761)
  (testeqv (* -4579815856418431271/16947444571374397297 7990245706938186906/12540719430158043191) -36593853985314806270746820601513137526/212533147427761354206383017714519654727)
  (testeqv (* -3587966953201943536/3194797554208122281 975954052071387816/2707062718507963111) -3501690886675668292903668827990357376/8648517352177231144330968693325176191)
  (testeqv (* 710265334225408429/567023629756400552 -5578988760400430103/4131535930210536898) -3962562316545608552741467762441538187/2342678499616965424161446427863567696)
  (testeqv (* 18305319006789031727/4480148641441744463 -1641093267260986094/16028097657311023719) -30040735777106040963634910981471804338/71808259944297590021537032075729917897)
  (testeqv (* 522499067029593907/142530390958606446621834761330018829110 1567459634764499377/31663510497342378306792964160850079086) 818996196770998943862055820464495939/4513012530308148429025282037949729145117603192483641232823845248212618993460)
  (testeqv (* -280037880297253633994139513185953058494/23798550327416056573646642830182072429 13967268482262630670960486883264178489/7947215947745048068401387767511847243) -434596028812829556627014314125713048434599389957141408329542154357763726174/21014690966139335562014814134594464675233042588696546668504776333756662583)
  (testeqv (* 87160410649223805266866345018804635271/204719779683096591635231158476535039583 91197762560765392928084914476898132964/277206223024759381433146631560580134513) 7948834435086720002947247338196997812861466884983039250681993725808882173244/56749596904412078223459353928850191672356004665473536520452927516595919428079)
  (testeqv (/ 7013212896988366906/12397903473277899947 818833870013215068/2125577647443895255) 7453564285301859120853045020886215515/5075911640537211768265804260348400698)
  (testeqv (/ -15781329068048599432/14942574238341613337 4388772934226358350/2640112802717985697) -20832244458230302534551181278529162052/32789782692450857054331267544650656975)
  (testeqv (/ -9015230453321124271/17425619133302730035 -10422000746814766599/14972344381173680534) 134979135022768387806775446187867640714/181609815620990738305316999098032100965)
  (testeqv (/ -14741075237791868512/12448692140900938227 -1090381863721238817/1060836378253796023) 15637868866825840780217685066084527776/13573828137487503515304766902031557459)
  (testeqv (/ -7371815071140740177/4722722556038701367 3872455829192658988/994203944294825175) -7329087620340161131469364260313555975/18288534491791723206480607737200436596)
  (testeqv (/ -9856364379969390509/7988230468709836259 -7208901117187058135/7430860779232874136) 1093153305924514768551484985555671272/859497963436269188803272225817371895)
  (testeqv (/ -4420263280205408439/38682162086456801604593696710774835436326970692840048042132553053971380151628 -758651402628235427/1755534012040040367913026343944696058732638465867705260088080517539506722166) 3879961265286134914514096239640695384126081133972137242327715997675029567458817030555062379437/14673138261791601182714628661554161812345431143865809776872034934342213839184709418896670662578)
  (testeqv (/ -54987418627898620923060954379316763081930842855917193391807940070173620336071/17370345837184638879794373707261631548922174314274224219546763452439685451597 107349939397731511365417710412808670916754334908520065561311453951414109180973/7800708635318451621630266369706695626474649690647985662113853436261704078874) -428940831324519456770429889832838610542119304716244392653623661175655561457214418178921042544524225772650432309479656622489393939407340321261255371264054/1864705572939408818246392762570376592749103793151936455808919833872532407312841098160841844995663367019074328670998871082130543124576872890789577304863881))
;; end clisp borrowings

(define-generic G)
(define-method (G (a <integer>)) 'integer)
(define-method (G (a <fraction>)) 'fraction)

(with-test-prefix "fraction generics"
  (testeq (G 1) 'integer)
  (testeq (G 2/3) 'fraction))


code:
;;;; ftw.test --- exercise ice-9/ftw.scm      -*- scheme -*-
;;;;
;;;; Copyright 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-ice-9-ftw)
  #:use-module (test-suite lib)
  #:use-module (ice-9 ftw))

;; the procedure-source checks here ensure the vector indexes we write match
;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match
;; libguile/filesys.c of course)

(or (equal? (procedure-source stat:dev)
	    '(lambda (f) (vector-ref f 0)))
    (error "oops, unexpected stat:dev definition"))
(define (stat:dev! st dev)
  (vector-set! st 0 dev))

(or (equal? (procedure-source stat:ino)
	    '(lambda (f) (vector-ref f 1)))
    (error "oops, unexpected stat:ino definition"))
(define (stat:ino! st ino)
  (vector-set! st 1 ino))

;;
;; visited?-proc
;;

(with-test-prefix "visited?-proc"

  ;; normally internal-only
  (let* ((visited?-proc (@@ (ice-9 ftw) visited?-proc))
	 (visited? (visited?-proc 97))
	 (s (stat "/")))

    (define (try-visited? dev ino)
      (stat:dev! s dev)
      (stat:ino! s ino)
      (visited? s))

    (pass-if "0 0 - 1st" (eq? #f (try-visited? 0 0)))
    (pass-if "0 0 - 2nd" (eq? #t (try-visited? 0 0)))
    (pass-if "0 0 - 3rd" (eq? #t (try-visited? 0 0)))

    (pass-if "0 1" (eq? #f (try-visited? 0 1)))
    (pass-if "0 2" (eq? #f (try-visited? 0 2)))
    (pass-if "0 3" (eq? #f (try-visited? 0 3)))

    (pass-if "5 5" (eq? #f (try-visited? 5 5)))
    (pass-if "5 7" (eq? #f (try-visited? 5 7)))
    (pass-if "7 5" (eq? #f (try-visited? 7 5)))
    (pass-if "7 7" (eq? #f (try-visited? 7 7)))

    (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5)))
    (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7)))
    (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5)))
    (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7)))))


code:
;;;; gc.test --- test guile's garbage collection    -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2008 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 (ice-9 documentation)
	     (test-suite lib))

;;;
;;; miscellaneous
;;;

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

;; In guile 1.6.4 this test bombed, due to the record in h being collected
;; by the gc, but not removed from h, leaving "x" as a freed cell.
;; The usual correct result here is for x to be #f, but there's always a
;; chance gc will mark something used when it isn't, so we allow x to be a
;; record too.
(pass-if "weak-values versus records"
  (let ((rec-type (make-record-type "foo" '()))
	(h        (make-weak-value-hash-table 61)))
    (hash-set! h "foo" ((record-constructor rec-type)))
    (gc)
    (let ((x (hash-ref h "foo")))
      (or (not x)
	  ((record-predicate rec-type) x)))))

;;;
;;;
;;;

(with-test-prefix "gc"

  (pass-if "after-gc-hook gets called"
    (let* ((foo #f)
	   (thunk (lambda () (set! foo #t))))
      (add-hook! after-gc-hook thunk)
      (gc)
      (remove-hook! after-gc-hook thunk)
      foo)))

(with-test-prefix "gc"
  (pass-if "Unused modules are removed"
	   (let*
	       ((dummy (gc))
	        (last-count (cdr (assoc
				  "eval-closure" (gc-live-object-stats)))))

	     (for-each (lambda (x) (make-module)) (iota 1000))

	     ;; XXX: This hack aims to clean up the stack to make sure we
	     ;; don't leave a reference to one of the modules we created.  It
	     ;; proved to be useful on SPARC:
	     ;; http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00006.html .
             (let cleanup ((i 10))
               (and (> i 0)
                    (begin (cleanup (1- i)) i)))

	     (gc)
	     (gc) ;; twice: have to kill the weak vectors.
	     (= last-count (cdr (assoc "eval-closure" (gc-live-object-stats)))))
	   ))


code:
;;;; getopt-long.test --- long options processing -*- scheme -*-
;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
;;;;
;;;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(use-modules (test-suite lib)
             (ice-9 getopt-long)
             (ice-9 regex))

(defmacro deferr (name-frag re)
  (let ((name (symbol-append 'exception: name-frag)))
    `(define ,name (cons 'misc-error ,re))))

(deferr no-such-option              "^no such option")
(deferr option-predicate-failed     "^option predicate failed")
(deferr option-does-not-support-arg "^option does not support argument")
(deferr option-must-be-specified    "^option must be specified")
(deferr option-must-have-arg        "^option must be specified with argument")

(with-test-prefix "exported procs"
  (pass-if "`option-ref' defined"  (defined? 'option-ref))
  (pass-if "`getopt-long' defined" (defined? 'getopt-long)))

(with-test-prefix "specifying predicate"

  (define (test1 . args)
    (getopt-long args
                 `((test (value #t)
                         (predicate ,(lambda (x)
                                       (string-match "^[0-9]+$" x)))))))

  (pass-if "valid arg"
           (equal? (test1 "foo" "bar" "--test=123")
                   '((() "bar") (test . "123"))))

  (pass-if-exception "invalid arg"
                     exception:option-predicate-failed
                     (test1 "foo" "bar" "--test=foo"))

  (pass-if-exception "option has no arg"
                     exception:option-must-have-arg
                     (test1 "foo" "bar" "--test"))

  )

(with-test-prefix "not specifying predicate"

  (define (test2 . args)
    (getopt-long args `((test (value #t)))))

  (pass-if "option has arg"
           (equal? (test2 "foo" "bar" "--test=foo")
                   '((() "bar") (test . "foo"))))

  (pass-if "option has no arg"
           (equal? (test2 "foo" "bar")
                   '((() "bar"))))

  )

(with-test-prefix "value optional"

  (define (test3 . args)
    (getopt-long args '((foo (value optional) (single-char #\f))
                        (bar))))

  (pass-if "long option `foo' w/ arg, long option `bar'"
           (equal? (test3 "prg" "--foo" "fooval" "--bar")
                   '((()) (bar . #t) (foo . "fooval"))))

  (pass-if "short option `foo' w/ arg, long option `bar'"
           (equal? (test3 "prg" "-f" "fooval" "--bar")
                   '((()) (bar . #t) (foo . "fooval"))))

  (pass-if "short option `foo', long option `bar', no args"
           (equal? (test3 "prg" "-f" "--bar")
                   '((()) (bar . #t) (foo . #t))))

  (pass-if "long option `foo', long option `bar', no args"
           (equal? (test3 "prg" "--foo" "--bar")
                   '((()) (bar . #t) (foo . #t))))

  (pass-if "long option `bar', short option `foo', no args"
           (equal? (test3 "prg" "--bar" "-f")
                   '((()) (foo . #t) (bar . #t))))

  (pass-if "long option `bar', long option `foo', no args"
           (equal? (test3 "prg" "--bar" "--foo")
                   '((()) (foo . #t) (bar . #t))))

  )

(with-test-prefix "option-ref"

  (define (test4 option-arg . args)
    (equal? option-arg (option-ref (getopt-long
                                    (cons "prog" args)
                                    '((foo
                                       (value optional)
                                       (single-char #\f))
                                      (bar)))
                                   'foo #f)))

  (pass-if "option-ref `--foo 4'"
           (test4 "4" "--foo" "4"))

  (pass-if "option-ref `-f 4'"
           (test4 "4" "-f" "4"))

  (pass-if "option-ref `-f4'"
           (test4 "4" "-f4"))

  (pass-if "option-ref `--foo=4'"
           (test4 "4" "--foo=4"))

  )

(with-test-prefix "required"

  (define (test5 args specs)
    (getopt-long (cons "foo" args) specs))

  (pass-if "not mentioned, not given"
           (equal? (test5 '() '())
                   '((()))))

  (pass-if-exception "not mentioned, given"
                     exception:no-such-option
                     (test5 '("--req") '((something))))

  (pass-if "not specified required, not given"
           (equal? (test5 '() '((req (required? #f))))
                   '((()))))

  (pass-if "not specified required, given anyway"
           (equal? (test5 '("--req") '((req (required? #f))))
                   '((()) (req . #t))))

  (pass-if "not specified required, but w/ value, given anyway w/ \"=\" val"
           (equal? (test5 '("--req=7") '((req (required? #f) (value #t))))
                   '((()) (req . "7"))))

  (pass-if "not specified required, but w/ value, given anyway w/ non-\"=\" val"
           (equal? (test5 '("--req" "7") '((req (required? #f) (value #t))))
                   '((()) (req . "7"))))

  (pass-if-exception "specified required, not given"
                     exception:option-must-be-specified
                     (test5 '() '((req (required? #t)))))

  )

(with-test-prefix "specified no-value, given anyway"

  (define (test6 args specs)
    (getopt-long (cons "foo" args) specs))

  (pass-if-exception "using \"=\" syntax"
                     exception:option-does-not-support-arg
                     (test6 '("--maybe=yes") '((maybe))))

  )

(with-test-prefix "specified arg required"

  (define (test7 args)
    (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H))
                                     (ignore))))

  (pass-if "short opt, arg given"
           (equal? (test7 '("-H" "99"))
                   '((()) (hmm . "99"))))

  (pass-if "long non-\"=\" opt, arg given"
           (equal? (test7 '("--hmm" "100"))
                   '((()) (hmm . "100"))))

  (pass-if "long \"=\" opt, arg given"
           (equal? (test7 '("--hmm=101"))
                   '((()) (hmm . "101"))))

  (pass-if-exception "short opt, arg not given"
                     exception:option-must-have-arg
                     (test7 '("-H")))

  (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)"
                     exception:option-must-have-arg
                     (test7 '("--hmm" "--ignore")))

  (pass-if-exception "long \"=\" opt, arg not given"
                     exception:option-must-have-arg
                     (test7 '("--hmm")))

  )

(with-test-prefix "apples-blimps-catalexis example"

  (define (test8 . args)
    (equal? (sort (getopt-long (cons "foo" args)
                               '((apples    (single-char #\a))
                                 (blimps    (single-char #\b) (value #t))
                                 (catalexis (single-char #\c) (value #t))))
                  (lambda (a b)
                    (cond ((null? (car a)) #t)
                          ((null? (car b)) #f)
                          (else (string<? (symbol->string (car a))
                                          (symbol->string (car b)))))))
            '((())
              (apples . #t)
              (blimps . "bang")
              (catalexis . "couth"))))

  (pass-if "normal 1" (test8 "-a" "-b" "bang" "-c" "couth"))
  (pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth"))
  (pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang"))

  (pass-if-exception "bad ordering causes missing option"
                     exception:option-must-have-arg
                     (test8 "-abc" "couth" "bang"))

  )

(with-test-prefix "multiple occurrances"

  (define (test9 . args)
    (equal? (getopt-long (cons "foo" args)
                         '((inc (single-char #\I) (value #t))
                           (foo (single-char #\f))))
            '((()) (inc . "2") (foo . #t) (inc . "1"))))

  ;; terminology:
  ;; sf -- single-char free
  ;; sa -- single-char abutted
  ;; lf -- long free
  ;; la -- long abutted (using "=")

  (pass-if "sf/sf" (test9 "-I" "1" "-f" "-I" "2"))
  (pass-if "sa/sa" (test9 "-I1" "-f" "-I2"))
  (pass-if "sf/sa" (test9 "-I" "1" "-f" "-I2"))
  (pass-if "sa/sf" (test9 "-I1" "-f" "-I" "2"))

  (pass-if "lf/lf" (test9 "--inc" "1" "-f" "--inc" "2"))
  (pass-if "la/la" (test9 "--inc=1" "-f" "--inc=2"))
  (pass-if "lf/la" (test9 "--inc" "1" "-f" "--inc=2"))
  (pass-if "la/lf" (test9 "--inc=1" "-f" "--inc" "2"))

  (pass-if "sf/lf" (test9 "-I" "1" "-f" "--inc" "2"))
  (pass-if "lf/sf" (test9 "--inc" "1" "-f" "-I" "2"))
  (pass-if "sf/la" (test9 "-I" "1" "-f" "--inc=2"))
  (pass-if "la/sf" (test9 "--inc=1" "-f" "-I" "2"))

  (pass-if "sa/lf" (test9 "-I1" "-f" "--inc" "2"))
  (pass-if "lf/sa" (test9 "--inc" "1" "-f" "-I2"))
  (pass-if "sa/la" (test9 "-I1" "-f" "--inc=2"))
  (pass-if "la/sa" (test9 "--inc=1" "-f" "-I2"))

  )

;;; getopt-long.test ends here


code:
;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
;;;;
;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-suite test-goops)
  #:use-module (test-suite lib)
  #:autoload   (srfi srfi-1)    (unfold))

(pass-if "GOOPS loads"
	 (false-if-exception
	  (begin (resolve-module '(oop goops))
		 #t)))

(use-modules (oop goops))

;;; more tests here...

(with-test-prefix "basic classes"

  (with-test-prefix "<top>"

    (pass-if "instance?"
      (instance? <top>))

    (pass-if "class-of"
      (eq? (class-of <top>) <class>))

    (pass-if "is a class?"
      (is-a? <top> <class>))

    (pass-if "class-name"
      (eq? (class-name <top>) '<top>))

    (pass-if "direct superclasses"
      (equal? (class-direct-supers <top>) '()))

    (pass-if "superclasses"
      (equal? (class-precedence-list <top>) (list <top>)))

    (pass-if "direct slots"
      (equal? (class-direct-slots <top>) '()))

    (pass-if "slots"
      (equal? (class-slots <top>) '())))

  (with-test-prefix "<object>"

    (pass-if "instance?"
      (instance? <object>))

    (pass-if "class-of"
      (eq? (class-of <object>) <class>))

    (pass-if "is a class?"
      (is-a? <object> <class>))

    (pass-if "class-name"
      (eq? (class-name <object>) '<object>))

    (pass-if "direct superclasses"
      (equal? (class-direct-supers <object>) (list <top>)))

    (pass-if "superclasses"
      (equal? (class-precedence-list <object>) (list <object> <top>)))

    (pass-if "direct slots"
      (equal? (class-direct-slots <object>) '()))

    (pass-if "slots"
      (equal? (class-slots <object>) '())))

  (with-test-prefix "<class>"

    (pass-if "instance?"
      (instance? <class>))

    (pass-if "class-of"
      (eq? (class-of <class>) <class>))

    (pass-if "is a class?"
      (is-a? <class> <class>))

    (pass-if "class-name"
      (eq? (class-name <class>) '<class>))

    (pass-if "direct superclass"
      (equal? (class-direct-supers <class>) (list <object>))))

  (with-test-prefix "class-precedence-list"
    (for-each (lambda (class)
		(run-test (if (slot-bound? class 'name)
			      (class-name class)
			      (with-output-to-string
				(lambda ()
				  (display class))))
			  #t
			  (lambda ()
			    (catch #t
				   (lambda ()
				     (equal? (class-precedence-list class)
					     (compute-cpl class)))
				   (lambda args #t)))))
	      (let ((table (make-hash-table)))
		(let rec ((class <top>))
		  (hash-create-handle! table class #f)
		  (for-each rec (class-direct-subclasses class)))
		(hash-fold (lambda (class ignore classes)
			     (cons class classes))
			   '()
			   table))))
  )

(with-test-prefix "classes for built-in types"

  (pass-if "subr"
    (eq? (class-of fluid-ref) <procedure>))

  (pass-if "gsubr"
    (eq? (class-of hashq-ref) <procedure>))

  (pass-if "car"
    (eq? (class-of car) <procedure>))

  (pass-if "string"
    (eq? (class-of "foo") <string>))

  (pass-if "port"
    (is-a? (%make-void-port "w") <port>))

  (pass-if "struct vtable"
    ;; Previously, `class-of' would fail for nameless structs, i.e., structs
    ;; for which `struct-vtable-name' is #f.
    (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))

(with-test-prefix "defining classes"

  (with-test-prefix "define-class"

    (pass-if "creating a new binding"
      (if (eval '(defined? '<foo-0>) (current-module))
          (throw 'unresolved))
      (eval '(define-class <foo-0> ()) (current-module))
      (eval '(is-a? <foo-0> <class>) (current-module)))

    (pass-if "overwriting a binding to a non-class"
      (eval '(define <foo> #f) (current-module))
      (eval '(define-class <foo> ()) (current-module))
      (eval '(is-a? <foo> <class>) (current-module)))

    (expect-fail "bad init-thunk"
		 (catch #t
			(lambda ()
			  (eval '(define-class <foo> ()
				   (x #:init-thunk (lambda (x) 1)))
				(current-module))
			  #t)
			(lambda args
			  #f)))

    (pass-if "interaction with `struct-ref'"
       (eval '(define-class <class-struct> ()
                (foo #:init-keyword #:foo)
                (bar #:init-keyword #:bar))
             (current-module))
       (eval '(let ((x (make <class-struct>
                         #:foo 'hello
                         #:bar 'world)))
                (and (struct? x)
                     (eq? (struct-ref x 0) 'hello)
                     (eq? (struct-ref x 1) 'world)))
             (current-module)))

     (pass-if "interaction with `struct-set!'"
       (eval '(define-class <class-struct-2> ()
                (foo) (bar))
             (current-module))
       (eval '(let ((x (make <class-struct-2>)))
                (struct-set! x 0 'hello)
                (struct-set! x 1 'world)
                (and (struct? x)
                     (eq? (struct-ref x 0) 'hello)
                     (eq? (struct-ref x 1) 'world)))
             (current-module)))))

(with-test-prefix "defining generics"

  (with-test-prefix "define-generic"

    (pass-if "creating a new top-level binding"
      (if (eval '(defined? 'foo-0) (current-module))
          (throw 'unresolved))
      (eval '(define-generic foo-0) (current-module))
      (eval '(and (is-a? foo-0 <generic>)
		  (null? (generic-function-methods foo-0)))
	    (current-module)))

    (pass-if "overwriting a top-level binding to a non-generic"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-generic foo) (current-module))
      (eval '(and (is-a? foo <generic>)
		  (= 1 (length (generic-function-methods foo))))
	    (current-module)))

    (pass-if "overwriting a top-level binding to a generic"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-generic foo) (current-module))
      (eval '(define-generic foo) (current-module))
      (eval '(and (is-a? foo <generic>)
		  (null? (generic-function-methods foo)))
	    (current-module)))))

(with-test-prefix "defining methods"

  (pass-if "define-method"
    (let ((m (current-module)))
      (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
               (string-append s1 s2))
            m)
      (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
               (+ i1 i2))
            m)
      (eval '(and (is-a? my-plus <generic>)
                  (= (length (generic-function-methods my-plus))
                     2))
            m)))

  (pass-if "method-more-specific?"
    (eval '(let* ((m+        (generic-function-methods my-plus))
                  (m1        (car m+))
                  (m2        (cadr m+))
                  (arg-types (list <string> <string>)))
             (if (memq <string> (method-specializers m1))
                 (method-more-specific? m1 m2 arg-types)
                 (method-more-specific? m2 m1 arg-types)))
          (current-module)))

  (pass-if-exception "method-more-specific? (failure)"
                     exception:wrong-type-arg
    (eval '(let* ((m+ (generic-function-methods my-plus))
                  (m1 (car m+))
                  (m2 (cadr m+)))
             (method-more-specific? m1 m2 '()))
          (current-module))))

(with-test-prefix "defining accessors"

  (with-test-prefix "define-accessor"

    (pass-if "creating a new top-level binding"
      (if (eval '(defined? 'foo-1) (current-module))
          (throw 'unresolved))
      (eval '(define-accessor foo-1) (current-module))
      (eval '(and (is-a? foo-1 <generic-with-setter>)
		  (null? (generic-function-methods foo-1)))
	    (current-module)))

    (pass-if "overwriting a top-level binding to a non-accessor"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-accessor foo) (current-module))
      (eval '(and (is-a? foo <generic-with-setter>)
		  (= 1 (length (generic-function-methods foo))))
	    (current-module)))

    (pass-if "overwriting a top-level binding to an accessor"
      (eval '(define (foo) #f) (current-module))
      (eval '(define-accessor foo) (current-module))
      (eval '(define-accessor foo) (current-module))
      (eval '(and (is-a? foo <generic-with-setter>)
		  (null? (generic-function-methods foo)))
	    (current-module)))))

(with-test-prefix "object update"
  (pass-if "defining class"
    (eval '(define-class <foo> ()
	     (x #:accessor x #:init-value 123)
	     (z #:accessor z #:init-value 789))
	  (current-module))
    (eval '(is-a? <foo> <class>) (current-module)))
  (pass-if "making instance"
    (eval '(define foo (make <foo>)) (current-module))
    (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
  (pass-if "redefining class"
    (eval '(define-class <foo> ()
	     (x #:accessor x #:init-value 123)
	     (y #:accessor y #:init-value 456)
	     (z #:accessor z #:init-value 789))
	  (current-module))
    (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))

  (pass-if "changing class"
    (let* ((c1 (class () (the-slot #:init-keyword #:value)))
           (c2 (class () (the-slot #:init-keyword #:value)
                         (the-other-slot #:init-value 888)))
           (o1 (make c1 #:value 777)))
      (and (is-a? o1 c1)
           (not (is-a? o1 c2))
           (equal? (slot-ref o1 'the-slot) 777)
           (let ((o2 (change-class o1 c2)))
             (and (eq? o1 o2)
                  (is-a? o2 c2)
                  (not (is-a? o2 c1))
                  (equal? (slot-ref o2 'the-slot) 777))))))

  (pass-if "`hell' in `goops.c' grows as expected"
    ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
    ;; fix (i.e., Guile 1.8.5 and earlier).  The root of the problem was
    ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
    ;; array, leading to out-of-bounds accesses.

    (let* ((parent-class (class ()
                           #:name '<class-that-will-be-redefined>))
           (classes
            (unfold (lambda (i) (>= i 20))
                    (lambda (i)
                      (make-class (list parent-class)
                                  '((the-slot #:init-value #:value)
                                    (the-other-slot))
                                  #:name (string->symbol
                                          (string-append "<foo-to-redefine-"
                                                         (number->string i)
                                                         ">"))))
                    (lambda (i)
                      (+ 1 i))
                    0))
           (objects
            (map (lambda (class)
                   (make class #:value 777))
                 classes)))

      (define-method (change-class (foo parent-class)
                                   (new <class>))
        ;; Called by `scm_change_object_class ()', via `purgatory ()'.
        (if (null? classes)
            (next-method)
            (let ((class  (car classes))
                  (object (car objects)))
              (set! classes (cdr classes))
              (set! objects (cdr objects))

              ;; Redefine the class so that its instances are eventually
              ;; passed to `scm_change_object_class ()'.  This leads to
              ;; nested `scm_change_object_class ()' calls, which increases
              ;; the size of HELL and increments N_HELL.
              (class-redefinition class
                                  (make-class '() (class-slots class)
                                              #:name (class-name class)))

              ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
              ;; and `go_to_hell ()' calls.
              (slot-ref object 'the-slot)

              (next-method))))

      ;; Initiate the whole `change-class' chain.
      (let* ((class  (car classes))
             (object (change-class (car objects) class)))
        (is-a? object class)))))

(with-test-prefix "object comparison"
  (pass-if "default method"
	   (eval '(begin
		    (define-class <c> ()
		      (x #:accessor x #:init-keyword #:x)
		      (y #:accessor y #:init-keyword #:y))
		    (define o1 (make <c> #:x '(1) #:y '(2)))
		    (define o2 (make <c> #:x '(1) #:y '(3)))
		    (define o3 (make <c> #:x '(4) #:y '(3)))
		    (define o4 (make <c> #:x '(4) #:y '(3)))
		    (not (eqv? o1 o2)))
		 (current-module)))
  (pass-if "eqv?"
	   (eval '(begin
		    (define-method (eqv? (a <c>) (b <c>))
		      (equal? (x a) (x b)))
		    (eqv? o1 o2))
		 (current-module)))
  (pass-if "not eqv?"
	   (eval '(not (eqv? o2 o3))
		 (current-module)))
  (pass-if "transfer eqv? => equal?"
	   (eval '(equal? o1 o2)
		 (current-module)))
  (pass-if "equal?"
	   (eval '(begin
		    (define-method (equal? (a <c>) (b <c>))
		      (equal? (y a) (y b)))
		    (equal? o2 o3))
		 (current-module)))
  (pass-if "not equal?"
	   (eval '(not (equal? o1 o2))
		 (current-module)))
  (pass-if "="
	   (eval '(begin
		    (define-method (= (a <c>) (b <c>))
		      (and (equal? (x a) (x b))
			   (equal? (y a) (y b))))
		    (= o3 o4))
		 (current-module)))
  (pass-if "not ="
	   (eval '(not (= o1 o2))
		 (current-module)))
  )

(use-modules (oop goops active-slot))

(with-test-prefix "active-slot"
  (pass-if "defining class with active slot"
    (eval '(begin
	     (define z '())
	     (define-class <bar> ()
	       (x #:accessor x
		  #:init-value 1
		  #:allocation #:active
		  #:before-slot-ref
		  (lambda (o)
		    (set! z (cons 'before-ref z))
		    #t)
		  #:after-slot-ref
		  (lambda (o)
		    (set! z (cons 'after-ref z)))
		  #:before-slot-set!
		  (lambda (o v)
		    (set! z (cons* v 'before-set! z)))
		  #:after-slot-set!
		  (lambda (o v)
		    (set! z (cons* v (x o) 'after-set! z))))
	       #:metaclass <active-class>)
	     (define bar (make <bar>))
	     (x bar)
	     (set! (x bar) 2)
	     (equal? (reverse z)
		     '(before-ref before-set! 1 before-ref after-ref
		       after-set! 1 1 before-ref after-ref
		       before-set! 2 before-ref after-ref after-set! 2 2)))
	  (current-module))))

(use-modules (oop goops composite-slot))

(with-test-prefix "composite-slot"
  (pass-if "creating instance with propagated slot"
    (eval '(begin
	     (define-class <a> ()
	       (x #:accessor x #:init-keyword #:x)
	       (y #:accessor y #:init-keyword #:y))
	     (define-class <c> ()
	       (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
	       (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
	       (x #:accessor x
		  #:allocation #:propagated
		  #:propagate-to '(o1 (o2 y)))
	       #:metaclass <composite-class>)
	     (define o (make <c>))
	     (is-a? o <c>))
	  (current-module)))
  (pass-if "reading propagated slot"
	   (eval '(= (x o) 1) (current-module)))
  (pass-if "writing propagated slot"
	   (eval '(begin
		    (set! (x o) 5)
		    (and (= (x (o1 o)) 5)
			 (= (y (o1 o)) 2)
			 (= (x (o2 o)) 3)
			 (= (y (o2 o)) 5)))
		 (current-module))))


code:
;;;; guardians.test --- test suite for Guile Guardians     -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- July 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

;;; These tests make some questionable assumptions.
;;; - They assume that a GC will find all dead objects, so they
;;;   will become flaky if we have a generational GC.
;;; - They assume that objects won't be saved by the guardian until
;;;   they explicitly invoke GC --- in other words, they assume that GC
;;;   won't happen too often.

(define-module (test-guardians)
  :use-module (test-suite lib)
  :use-module (ice-9 documentation)
  :use-module (ice-9 weak-vector))

;;;
;;; miscellaneous
;;;

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

(gc)

;;; Who guards the guardian?
(gc)
(define g2 (make-guardian))
(g2 (list 'g2-garbage))
(define g3 (make-guardian))
(g3 (list 'g3-garbage))
(g3 g2)
(pass-if "g2-garbage not collected yet" (equal? (g2) #f))
(pass-if "g3-garbage not collected yet" (equal? (g3) #f))
(set! g2 #f)
(gc)
(let ((seen-g3-garbage #f)
      (seen-g2 #f)
      (seen-something-else #f))
  (let loop ()
    (let ((saved (g3)))
      (if saved
	  (begin
	    (cond
	     ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t))
	     ((procedure? saved) (set! seen-g2 saved))
	     (else (pk saved) (set! seen-something-else #t)))
	    (loop)))))
  (pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
  (pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
  (pass-if "nothing else saved" (not seen-something-else))
  (pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
				       (equal? (seen-g2) '(g2-garbage)))
				  (throw 'unresolved))))

(with-test-prefix "standard guardian functionality"

  (with-test-prefix "make-guardian"

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

    (pass-if "returns procedure"
      (procedure? (make-guardian)))

    (pass-if "returns new procedure each time"
      (not (equal? (make-guardian) (make-guardian)))))

  (with-test-prefix "empty guardian"

    (pass-if "returns #f"
      (eq? ((make-guardian)) #f))

    (pass-if "returns always #f"
      (let ((g (make-guardian)))
	(and (eq? (g) #f)
	     (begin (gc) (eq? (g) #f))
	     (begin (gc) (eq? (g) #f))))))

  (with-test-prefix "guarding independent objects"

    (pass-if "guarding immediate"
      (let ((g (make-guardian)))
	(g #f)
	(and (eq? (g) #f)
	     (begin (gc) (eq? (g) #f))
	     (begin (gc) (eq? (g) #f)))))

    (pass-if "guarding non-immediate"
      (let ((g (make-guardian)))
	(gc)
	(g (cons #f #f))
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (if (not (equal? (g) (cons #f #f)))
		  (throw 'unresolved)
		  (eq? (g) #f))))))

    (pass-if "guarding two non-immediates"
      (let ((g (make-guardian)))
	(gc)
	(g (cons #f #f))
	(g (cons #t #t))
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (let ((l (list (g) (g))))
		(if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
			     (equal? l (list (cons #t #t) (cons #f #f)))))
		    (throw 'unresolved)
		    (eq? (g) #f)))))))

    (pass-if "re-guarding non-immediates"
      (let ((g (make-guardian)))
	(gc)
	(g (cons #f #f))
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (let ((p (g)))
		(if (not (equal? p (cons #f #f)))
		    (throw 'unresolved)
		    (begin
		      (g p)
		      (set! p #f)
		      (gc)
		      (if (not (equal? (g) (cons #f #f)))
			  (throw 'unresolved)
			  (eq? (g) #f)))))))))

    (pass-if "guarding living non-immediate"
      (let ((g (make-guardian))
	    (p (cons #f #f)))
	(g p)
	(if (not (eq? (g) #f))
	    (throw 'fail)
	    (begin
	      (gc)
	      (not (eq? (g) p)))))))

  (with-test-prefix "guarding weakly referenced objects"

    (pass-if "guarded weak vector element gets returned from guardian"
      (let ((g (make-guardian))
	    (v (weak-vector #f)))
	(gc)
	(let ((p (cons #f #f)))
	  (g p)
	  (vector-set! v 0 p))
	(if (not (eq? (g) #f))
	    (throw 'unresolved)
	    (begin
	      (gc)
	      (if (not (equal? (g) (cons #f #f)))
		  (throw 'unresolved)
		  (eq? (g) #f))))))

    (pass-if "guarded element of weak vector gets eventually removed from weak vector"
      (let ((g (make-guardian))
	    (v (weak-vector #f)))
	(gc)
	(let ((p (cons #f #f)))
	  (g p)
	  (vector-set! v 0 p))
	(begin
	  (gc)
	  (if (not (equal? (g) (cons #f #f)))
	      (throw 'unresolved)
	      (begin
		(gc)
		(or (not (vector-ref v 0))
		    (throw 'unresolved))))))))

  (with-test-prefix "guarding weak containers"

    (pass-if "element of guarded weak vector gets collected"
      (let ((g (make-guardian))
	    (v (weak-vector (cons #f #f))))
	(g v)
	(gc)
	(if (equal? (vector-ref v 0) (cons #f #f))
	    (throw 'unresolved)
	    #t))))

  (with-test-prefix "guarding guardians"
    #t)

  (with-test-prefix "guarding dependent objects"

    ;; We don't make any guarantees about the order objects are
    ;; returned from guardians and therefore we skip the following
    ;; test.

    (if #f
	(pass-if "guarding vector and element"
          (let ((g (make-guardian)))
	    (gc)
	    (let ((p (cons #f #f)))
	      (g p)
	      (g (vector p)))
	    (if (not (eq? (g) #f))
		(throw 'unresolved)
		(begin
		  (gc)
		  (if (not (equal? (g) (vector (cons #f #f))))
		      (throw 'unresolved)
		      (if (not (eq? (g) #f))
			  (throw 'unresolved)
			  (begin
			    (gc)
			    (if (not (equal? (g) (cons #f #f)))
				(throw 'unresolved)
				(eq? (g) #f)))))))))))

  (with-test-prefix "guarding objects more than once"

    (pass-if "guarding twice in one guardian"
       (let ((g (make-guardian)))
	 (gc)
	 (let ((p (cons #f #f)))
	   (g p)
	   (g p))
	 (if (not (eq? (g) #f))
	     (throw 'unresolved)
	     (begin
	       (gc)
	       (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
			(and=> (g) (lambda (o) (equal? o (cons #f #f)))))
		   (throw 'unresolved))))))

    (pass-if "guarding twice in two guardians"
       (let ((g (make-guardian))
	     (h (make-guardian)))
	 (gc)
	 (let ((p (cons #f #f)))
	   (g p)
	   (h p))
	 (if (not (eq? (g) #f))
	     (throw 'unresolved)
	     (begin
	       (gc)
	       (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
			(and=> (h) (lambda (o) (equal? o (cons #f #f)))))
		   (throw 'unresolved)))))))

  (with-test-prefix "guarding cyclic dependencies"
    #t)

  )


code:
;;;; hash.test --- test guile hashing     -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-numbers)
  #:use-module (test-suite lib)
  #:use-module (ice-9 documentation))

;;;
;;; hash
;;;

(with-test-prefix "hash"
  (pass-if (->bool (object-documentation hash)))
  (pass-if-exception "hash #t -1" exception:out-of-range
    (hash #t -1))
  (pass-if-exception "hash #t 0" exception:out-of-range
    (hash #t 0))
  (pass-if (= 0 (hash #t 1)))
  (pass-if (= 0 (hash #f 1)))
  (pass-if (= 0 (hash noop 1))))

;;;
;;; hashv
;;;

(with-test-prefix "hashv"
  (pass-if (->bool (object-documentation hashv)))
  (pass-if-exception "hashv #t -1" exception:out-of-range
    (hashv #t -1))
  (pass-if-exception "hashv #t 0" exception:out-of-range
    (hashv #t 0))
  (pass-if (= 0 (hashv #t 1)))
  (pass-if (= 0 (hashv #f 1)))
  (pass-if (= 0 (hashv noop 1))))

;;;
;;; hashq
;;;

(with-test-prefix "hashq"
  (pass-if (->bool (object-documentation hashq)))
  (pass-if-exception "hashq #t -1" exception:out-of-range
    (hashq #t -1))
  (pass-if-exception "hashq #t 0" exception:out-of-range
    (hashq #t 0))
  (pass-if (= 0 (hashq #t 1)))
  (pass-if (= 0 (hashq #f 1)))
  (pass-if (= 0 (hashq noop 1))))

;;;
;;; make-hash-table
;;;

(with-test-prefix
 "make-hash-table, hash-table?"
 (pass-if-exception "make-hash-table -1" exception:out-of-range
		    (make-hash-table -1))
 (pass-if (hash-table? (make-hash-table 0))) ;; default
 (pass-if (not (hash-table? 'not-a-hash-table)))
 (pass-if (equal? "#<hash-table 0/113>"
		  (with-output-to-string
		    (lambda () (write (make-hash-table 100)))))))

;;;
;;; usual set and reference
;;;

(with-test-prefix
 "hash-set and hash-ref"

 ;; auto-resizing
 (pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31
	    (hash-set! table 'one 1)
	    (hash-set! table 'two #t)
	    (hash-set! table 'three #t)
	    (hash-set! table 'four #t)
	    (hash-set! table 'five #t)
	    (hash-set! table 'six #t)
	    (hash-set! table 'seven #t)
	    (hash-set! table 'eight #t)
	    (hash-set! table 'nine 9)
	    (hash-set! table 'ten #t)
	    (hash-set! table 'eleven #t)
	    (hash-set! table 'twelve #t)
	    (hash-set! table 'thirteen #t)
	    (hash-set! table 'fourteen #t)
	    (hash-set! table 'fifteen #t)
	    (hash-set! table 'sixteen #t)
	    (hash-set! table 'seventeen #t)
	    (hash-set! table 18 #t)
	    (hash-set! table 19 #t)
	    (hash-set! table 20 #t)
	    (hash-set! table 21 #t)
	    (hash-set! table 22 #t)
	    (hash-set! table 23 #t)
	    (hash-set! table 24 #t)
	    (hash-set! table 25 #t)
	    (hash-set! table 26 #t)
	    (hash-set! table 27 #t)
	    (hash-set! table 28 #t)
	    (hash-set! table 29 #t)
	    (hash-set! table 30 'thirty)
	    (hash-set! table 31 #t)
	    (hash-set! table 32 #t)
	    (hash-set! table 33 'thirty-three)
	    (hash-set! table 34 #t)
	    (hash-set! table 35 #t)
	    (hash-set! table 'foo 'bar)
	    (and (equal? 1 (hash-ref table 'one))
		 (equal? 9 (hash-ref table 'nine))
		 (equal? 'thirty (hash-ref table 30))
		 (equal? 'thirty-three (hash-ref table 33))
		 (equal? 'bar (hash-ref table 'foo))
		 (equal? "#<hash-table 36/61>"
			 (with-output-to-string (lambda () (write table)))))))

 ;; 1 and 1 are equal? and eqv? and eq?
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hash-set! table 1 'foo)
		    (hash-ref table 1))))
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hashv-set! table 1 'foo)
		    (hashv-ref table 1))))
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hashq-set! table 1 'foo)
		    (hashq-ref table 1))))

 ;; 1/2 and 2/4 are equal? and eqv? but not eq?
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hash-set! table 1/2 'foo)
		    (hash-ref table 2/4))))
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hashv-set! table 1/2 'foo)
		    (hashv-ref table 2/4))))
 (pass-if (equal? #f
		  (let ((table (make-hash-table)))
		    (hashq-set! table 1/2 'foo)
		    (hashq-ref table 2/4))))

 ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hash-set! table (list 1 2) 'foo)
		    (hash-ref table (list 1 2)))))
 (pass-if (equal? #f
		  (let ((table (make-hash-table)))
		    (hashv-set! table (list 1 2) 'foo)
		    (hashv-ref table (list 1 2)))))
 (pass-if (equal? #f
		  (let ((table (make-hash-table)))
		    (hashq-set! table (list 1 2) 'foo)
		    (hashq-ref table (list 1 2)))))

 ;; ref default argument
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hash-ref table 'foo 'bar))))
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hashv-ref table 'foo 'bar))))
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hashq-ref table 'foo 'bar))))
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hashx-ref hash equal? table 'foo 'bar))))

 ;; wrong type argument
 (pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg
		    (hash-ref 'not-a-table 'key))
 )

;;;
;;; hashx
;;;

(with-test-prefix
 "auto-resizing hashx"
 ;; auto-resizing
 (let ((table (make-hash-table 1))) ;;actually makes size 31
   (hashx-set! hash assoc table 1/2 'equal)
   (hashx-set! hash assoc table 1/3 'equal)
   (hashx-set! hash assoc table 4 'equal)
   (hashx-set! hash assoc table 1/5 'equal)
   (hashx-set! hash assoc table 1/6 'equal)
   (hashx-set! hash assoc table 7 'equal)
   (hashx-set! hash assoc table 1/8 'equal)
   (hashx-set! hash assoc table 1/9 'equal)
   (hashx-set! hash assoc table 10 'equal)
   (hashx-set! hash assoc table 1/11 'equal)
   (hashx-set! hash assoc table 1/12 'equal)
   (hashx-set! hash assoc table 13 'equal)
   (hashx-set! hash assoc table 1/14 'equal)
   (hashx-set! hash assoc table 1/15 'equal)
   (hashx-set! hash assoc table 16 'equal)
   (hashx-set! hash assoc table 1/17 'equal)
   (hashx-set! hash assoc table 1/18 'equal)
   (hashx-set! hash assoc table 19 'equal)
   (hashx-set! hash assoc table 1/20 'equal)
   (hashx-set! hash assoc table 1/21 'equal)
   (hashx-set! hash assoc table 22 'equal)
   (hashx-set! hash assoc table 1/23 'equal)
   (hashx-set! hash assoc table 1/24 'equal)
   (hashx-set! hash assoc table 25 'equal)
   (hashx-set! hash assoc table 1/26 'equal)
   (hashx-set! hash assoc table 1/27 'equal)
   (hashx-set! hash assoc table 28 'equal)
   (hashx-set! hash assoc table 1/29 'equal)
   (hashx-set! hash assoc table 1/30 'equal)
   (hashx-set! hash assoc table 31 'equal)
   (hashx-set! hash assoc table 1/32 'equal)
   (hashx-set! hash assoc table 1/33 'equal)
   (hashx-set! hash assoc table 34 'equal)
   (pass-if (equal? 'equal (hash-ref table 2/4)))
   (pass-if (equal? 'equal (hash-ref table 2/6)))
   (pass-if (equal? 'equal (hash-ref table 4)))
   (pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
   (pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
   (pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
   (pass-if (equal? "#<hash-table 33/61>"
		    (with-output-to-string (lambda () (write table)))))))

(with-test-prefix
 "hashx"
 (pass-if (let ((table (make-hash-table)))
	    (hashx-set! (lambda (k v) 1)
			(lambda (k al) (assoc 'foo al))
			table 'foo 'bar)
	    (equal?
	     'bar (hashx-ref (lambda (k v) 1)
			     (lambda (k al) (assoc 'foo al))
			     table 'baz))))
 (pass-if (let ((table (make-hash-table 31)))
	    (hashx-set! (lambda (k v) 1) assoc table 'foo 'bar)
	    (equal? #f
		    (hashx-ref (lambda (k v) 2) assoc table 'foo))))
 (pass-if (let ((table (make-hash-table)))
	    (hashx-set! hash assoc table 'foo 'bar)
	    (equal? #f
		    (hashx-ref hash (lambda (k al) #f) table 'foo))))
 (pass-if-exception
  "hashx-set! (lambda (k s) 1) equal? table 'foo 'bar"
  exception:wrong-type-arg ;; there must be a better exception than that...
  (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
 )

;;;
;;; hashx-remove!
;;;
(with-test-prefix "hashx-remove!"
  (pass-if (->bool (object-documentation hashx-remove!)))

  (pass-if (let ((table (make-hash-table)))
	     (hashx-set! hashq assq table 'x 123)
	     (hashx-remove! hashq assq table 'x)
	     (null? (hash-map->list noop table)))))

;;;
;;; hashx
;;;

(with-test-prefix "hashx"
  (pass-if-exception
   "hashx-set! (lambda (k s) 1) (lambda (k al) #t) table 'foo 'bar"
   exception:wrong-type-arg
   (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
  )