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

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

(define exception:syntax-error
  (cons 'syntax-error "failed to match"))
(define exception:duplicate-binding
  (cons 'syntax-error "duplicate"))

(define a (make-fluid))
(define b (make-fluid))
(define c #f)

(with-test-prefix "syntax"
  (pass-if-exception "with-fluids missing expression"
    exception:syntax-error
    (eval '(with-fluids ((a 1)))
	  (interaction-environment)))

  (pass-if-exception "with-fluids bad bindings"
    exception:syntax-error
    (eval '(with-fluids (a) #f)
	  (interaction-environment)))

  (pass-if-exception "with-fluids bad bindings"
    exception:syntax-error
    (eval '(with-fluids ((a)) #f)
	  (interaction-environment))))

(with-test-prefix "initial fluid values"
  (pass-if "fluid-ref uninitialized fluid is #f"
    (not (fluid-ref a)))

  (pass-if "initial value is inherited from parent thread"
    (if (provided? 'threads)
        (let ((f (make-fluid)))
          (fluid-set! f 'initial)
          (let ((child (call-with-new-thread
                        (lambda ()
                          (let ((init (fluid-ref f)))
                            (fluid-set! f 'new)
                            (list init (fluid-ref f)))))))
            (equal? '(initial new) (join-thread child))))
        (throw 'unresolved))))

(with-test-prefix "with-fluids with non-fluid"
  (pass-if-exception "exception raised if nonfluid passed to with-fluids"
                     exception:wrong-type-arg
    (with-fluids ((c #t))
      c))

  (pass-if "fluids not modified if nonfluid passed to with-fluids"
    (catch 'wrong-type-arg
      (lambda ()
        (with-fluids ((a #t)
                      (c #t))
          #f))
      (lambda _
        (not (fluid-ref a))))))

(with-test-prefix "with-fluids with duplicate fluid"
  (pass-if "last value wins"
    (with-fluids ((a 1)
                  (a 2))
      (eqv? (fluid-ref a) 2)))

  (pass-if "original value restored"
    (and (with-fluids ((a 1)
                       (a 2))
           (eqv? (fluid-ref a) 2))
         (eqv? (fluid-ref a) #f))))

(pass-if "fluid values are thread-local"
  (if (provided? 'threads)
      (let ((f (make-fluid)))
        (fluid-set! f 'parent)
        (let ((child (call-with-new-thread
                      (lambda ()
                        (fluid-set! f 'child)
                        (fluid-ref f)))))
          (and (eq? (join-thread child) 'child)
               (eq? (fluid-ref f) 'parent))))
      (throw 'unresolved)))

(pass-if "fluids are GC'd"

  (let ((g (make-guardian)))
    (g (make-fluid))
    (let loop ((i 1000))
      (and (> i 0)
           (begin
             (make-fluid)
             (loop (1- i)))))
    (gc)
    (fluid? (g))))

(with-test-prefix "with-fluids"

  (pass-if "with-fluids binds"
    (= (with-fluids ((a 1)) (fluid-ref a)) 1))

  (pass-if "with-fluids unbinds"
    (begin
      (fluid-set! a 0)
      (with-fluids ((a 1)) (fluid-ref a))
      (= (fluid-ref a) 0)))

  (pass-if "with-fluids and dynamic-wind"
    (letrec ((co-routine #f)
	     (spawn (lambda (proc)
		      (set! co-routine proc)))
	     (yield (lambda (val)
		      (call-with-current-continuation
		       (lambda (k)
			 (let ((next co-routine))
			   (set! co-routine k)
			   (next val)))))))

      (spawn (lambda (val)
	       (with-fluids ((a 'inside))
	         (yield (fluid-ref a))
		 (yield (fluid-ref a)))))

      (fluid-set! a 'outside)
      (let ((inside-a (yield #f)))
	(let ((outside-a (fluid-ref a)))
	  (let ((inside-a2 (yield #f)))
	    (and (eq? inside-a 'inside)
		 (eq? outside-a 'outside)
		 (eq? inside-a2 'inside))))))))

(with-test-prefix "unbound fluids"
  (pass-if "fluid-ref of unbound fluid"
    (catch #t
           (lambda () (fluid-ref (make-undefined-fluid)))
           (lambda (key . args) #t)))
  (pass-if "fluid-bound? of bound fluid"
    (fluid-bound? (make-fluid)))
  (pass-if "fluid-bound? of unbound fluid"
    (not (fluid-bound? (make-undefined-fluid))))
  (pass-if "unbound fluids can be set"
    (let ((fluid (make-undefined-fluid)))
      (fluid-set! fluid #t)
      (fluid-ref fluid)))
  (pass-if "bound fluids can be unset"
    (let ((fluid (make-fluid)))
      (fluid-unset! fluid)
      (catch #t
             (lambda () (fluid-ref fluid))
             (lambda (key . args) #t)))))


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

;;;
;;; See also ../standalone/test-ffi for FFI tests.
;;;

(define-module (test-foreign)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (test-suite lib))

(with-test-prefix "null pointer"

  (pass-if "zero"
    (= 0 (pointer-address %null-pointer)))

  (pass-if "null pointer identity"
    (eq? %null-pointer (make-pointer 0)))

  (pass-if "null-pointer? %null-pointer"
    (null-pointer? %null-pointer))

  (pass-if-exception "pointer->bytevector %null-pointer"
    exception:null-pointer-error
    (pointer->bytevector %null-pointer 7)))

(with-test-prefix "make-pointer"

  (pass-if "address preserved"
    (= 123 (pointer-address (make-pointer 123)))))

(with-test-prefix "pointer<->bytevector"

  (pass-if "bijection"
    (let ((bv #vu8(0 1 2 3 4 5 6 7)))
      (equal? (pointer->bytevector (bytevector->pointer bv)
                                   (bytevector-length bv))
              bv)))

  (pass-if "pointer from bits"
    (let* ((bytes (iota (sizeof '*)))
           (bv    (u8-list->bytevector bytes)))
      (= (pointer-address
          (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
                                             (sizeof '*))))
         (fold-right (lambda (byte address)
                       (+ byte (* 256 address)))
                     0
                     bytes))))

  (pass-if "dereference-pointer"
    (let* ((bytes (iota (sizeof '*)))
           (bv    (u8-list->bytevector bytes)))
      (= (pointer-address
          (dereference-pointer (bytevector->pointer bv)))
         (fold-right (lambda (byte address)
                       (+ byte (* 256 address)))
                     0
                     bytes)))))

(with-test-prefix "structs"

  (pass-if "parse-c-struct"
    (let ((layout (list int64 uint8))
          (data   (list -300 43)))
      (equal? (parse-c-struct (make-c-struct layout data)
                              layout)
              data))))

license: mit


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

(define-module (test-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)))

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

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

;;;; 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 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-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)

(define (stat:dev! st dev)
  (vector-set! st 0 dev))
(define (stat:ino! st ino)
  (vector-set! st 1 ino))

(let* ((s (stat "/"))
       (i (stat:ino s))
       (d (stat:dev s)))
  (stat:ino! s (1+ i))
  (stat:dev! s (1+ d))
  (if (not (and (= (stat:ino s) (1+ i))
                (= (stat:dev s) (1+ d))))
      (error "unexpected definitions of stat:dev and stat: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, 2007, 2008, 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 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(use-modules (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* ((guard (make-guardian))
           (total 1000))

      (for-each (lambda (x) (guard (make-module))) (iota total))

      ;; Avoid false references to the modules on the stack.
      (let cleanup ((i 20))
        (and (> i 0)
             (begin (cleanup (1- i)) i)))

      (gc)
      (gc) ;; twice: have to kill the weak vectors.
      (gc) ;; thrice: because the test doesn't succeed with only
           ;; one gc round. not sure why.

      (= (let lp ((i 0))
           (if (guard)
               (lp (1+ i))
               i))
         total))))


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

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

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

(define exception:no-applicable-method
  '(goops-error . "^No applicable method"))

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

     (pass-if "with accessors"
              (eval '(define-class <qux> ()
                       (x #:accessor x #:init-value 123)
                       (z #:accessor z #:init-value 789))
                    (current-module))
              (eval '(equal? (x (make <qux>)) 123) (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 "the method cache"
  (pass-if "defining a method with a rest arg"
    (let ((m (current-module)))
      (eval '(define-method (foo bar . baz)
               (cons bar baz))
            m)
      (eval '(foo 1)
            m)
      (eval '(foo 1 2)
            m)
      (eval '(equal? (foo 1 2) '(1 2))
            m))))

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

(with-test-prefix "no-applicable-method"
  (pass-if-exception "calling generic, no methods"
                     exception:no-applicable-method
    (eval '(begin
	     (define-class <qux> ())
             (define-generic quxy)
	     (quxy 1))
	  (current-module)))
  (pass-if "calling generic, one method, applicable"
    (eval '(begin
	     (define-method (quxy (q <qux>))
               #t)
	     (define q (make <qux>))
	     (quxy q))
	  (current-module)))
  (pass-if-exception "calling generic, one method, not applicable"
                     exception:no-applicable-method
    (eval '(quxy 1)
	  (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 library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; 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.
;;;
;;; - More generally, when a weakly referenced object doesn't disappear as
;;;   expected, it's hard to tell whether that's because of a guardian bug of
;;;   because a reference to it is being held somewhere, e.g., one some part
;;;   of the stack that hasn't been overwritten.  Thus, most tests cannot
;;;   fail, they can just throw `unresolved'.  We try hard to clear
;;;   references that may have been left on the stacks (see "clear refs left
;;;   on the stack" lines).
;;;
;;; - 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?

;;; Note: We use strings rather than symbols because symbols are usually
;;; ``interned'', i.e., kept in a weakly-keyed hash table, thus making them
;;; inappropriate for the tests below.  Furthermore, we use `string-copy' in
;;; order to make sure that no string is kept around in the interpreter
;;; unwillingly (e.g., in the source-property weak hash table).

(gc)
(define g2 (make-guardian))
(g2 (list (string-copy "g2-garbage")))
(define g3 (make-guardian))
(g3 (list (string-copy "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 (list (string-copy "g3-garbage")))
	      (set! seen-g3-garbage #t))
	     ((procedure? saved) (set! seen-g2 saved))
	     (else (pk 'junk 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))

  ;; FIXME: The following test fails because the guardian for `g2-garbage'
  ;; disappared from the weak-car guardian list of `g2-garbage' right before
  ;; `g2-garbage' was finalized (in `finalize_guarded ()').  Sample session
  ;; (compiled with `-DDEBUG_GUARDIANS'):
  ;;
  ;; guile> (define g (make-guardian))
  ;; guile> (let ((g2 (make-guardian)))
  ;;          (format #t "g2 = ~x~%" (object-address g2))
  ;;          (g2 (string-copy "foo"))
  ;;          (g g2))
  ;; g2 = 81fde18
  ;; guile> (gc)
  ;; finalizing guarded 0x827f6a0 (1 guardians)
  ;;   guardian for 0x827f6a0 vanished
  ;; end of finalize (0x827f6a0)
  ;; finalizing guarded 0x81fde18 (1 guardians)
  ;; end of finalize (0x81fde18)

  (pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
				       (equal? (seen-g2)
					       (list (string-copy
						      "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))
        (cons 'clear 'stack)  ;; clear refs left on the stack
	(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))
        (cons 'clear 'stack)  ;; clear refs left on the stack
	(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))
        (cons 'clear 'stack)  ;; clear refs left on the stack
	(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)
          (set! p #f))           ;; clear refs left on the stack
	(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)
          (set! p #f))        ;; clear refs left on the stack
	(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 #f)))
        ;; Note: We don't pass `(cons #f #f)' as an argument to `weak-vector'
        ;; otherwise references to it are likely to be left on the stack.
        (vector-set! v 0 (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)
           (set! p #f))       ;; clear refs left on the stack
	 (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)
           (set! p #f))         ;; clear refs left on the stack
	 (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 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-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))
  )


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

(define-module (test-suite test-hooks)
  #:use-module (test-suite lib))

;;;
;;; miscellaneous
;;;

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

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

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

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

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

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

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