code:
;;; arithmetic-flonums.test --- Test suite for R6RS (rnrs arithmetic flonums)

;;      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-r6rs-arithmetic-flonums)
  :use-module ((rnrs arithmetic flonums) :version (6))
  :use-module ((rnrs conditions) :version (6))
  :use-module ((rnrs exceptions) :version (6))
  :use-module (test-suite lib))

(define fake-pi 3.14159265)
(define (reasonably-close? x y) (< (abs (- x y)) 0.0000001))

(with-test-prefix "flonum?"
  (pass-if "flonum? is #t on flonum"
    (flonum? 1.5))

  (pass-if "flonum? is #f on non-flonum"
    (not (flonum? 3))))

(with-test-prefix "real->flonum"
  (pass-if "simple"
    (flonum? (real->flonum 3))))

(with-test-prefix "fl=?"
  (pass-if "fl=? is #t for eqv inputs"
    (fl=? 3.0 3.0 3.0))

  (pass-if "fl=? is #f for non-eqv inputs"
    (not (fl=? 1.5 0.0 3.0)))

  (pass-if "+inf.0 is fl= to itself"
    (fl=? +inf.0 +inf.0))

  (pass-if "0.0 and -0.0 are fl="
    (fl=? 0.0 -0.0)))

(with-test-prefix "fl<?"
  (pass-if "fl<? is #t for monotonically < inputs"
    (fl<? 1.0 2.0 3.0))

  (pass-if "fl<? is #f for non-monotonically < inputs"
    (not (fl<? 2.0 2.0 1.4))))

(with-test-prefix "fl<=?"
  (pass-if "fl<=? is #t for monotonically < or = inputs"
    (fl<=? 1.0 1.2 1.2))

  (pass-if "fl<=? is #f non-monotonically < or = inputs"
    (not (fl<=? 2.0 1.0 0.9))))

(with-test-prefix "fl>?"
  (pass-if "fl>? is #t for monotonically > inputs"
    (fl>? 3.0 2.0 1.0))

  (pass-if "fl>? is #f for non-monotonically > inputs"
    (not (fl>? 1.0 1.0 1.2))))

(with-test-prefix "fl>=?"
  (pass-if "fl>=? is #t for monotonically > or = inputs"
    (fl>=? 3.0 2.0 2.0))

  (pass-if "fl>=? is #f for non-monotonically > or = inputs"
    (not (fl>=? 1.0 1.2 1.2))))

(with-test-prefix "flinteger?"
  (pass-if "flinteger? is #t on integer flomnums"
    (flinteger? 1.0))

  (pass-if "flinteger? is #f on non-integer flonums"
    (not (flinteger? 1.5))))

(with-test-prefix "flzero?"
  (pass-if "flzero? is #t for 0.0 and -0.0"
    (and (flzero? 0.0) (flzero? -0.0)))

  (pass-if "flzero? is #f for non-zero flonums"
    (not (flzero? 1.0))))

(with-test-prefix "flpositive?"
  (pass-if "flpositive? is #t on positive flonum"
    (flpositive? 1.0))

  (pass-if "flpositive? is #f on negative flonum"
    (not (flpositive? -1.0)))

  (pass-if "0.0 and -0.0 are not flpositive"
    (and (not (flpositive? 0.0)) (not (flpositive? -0.0)))))

(with-test-prefix "flnegative?"
  (pass-if "flnegative? is #t on negative flonum"
    (flnegative? -1.0))

  (pass-if "flnegative? is #f on positive flonum"
    (not (flnegative? 1.0)))

  (pass-if "0.0 and -0.0 are not flnegative"
    (and (not (flnegative? 0.0)) (not (flnegative? -0.0)))))

(with-test-prefix "flodd?"
  (pass-if "&assertion raised on non-integer flonum"
    (guard (condition ((assertion-violation? condition) #t) (else #f))
	   (begin (flodd? 1.5) #f)))

  (pass-if "flodd? is #t on odd flonums"
    (flodd? 3.0))

  (pass-if "flodd? is #f on even flonums"
    (not (flodd? 2.0))))

(with-test-prefix "fleven?"
  (pass-if "&assertion raised on non-integer flonum"
    (guard (condition ((assertion-violation? condition) #t) (else #f))
	   (begin (fleven? 1.5) #f)))

  (pass-if "fleven? is #t on even flonums"
    (fleven? 2.0))

  (pass-if "fleven? is #f on odd flonums"
    (not (fleven? 3.0))))

(with-test-prefix "flfinite?"
  (pass-if "flfinite? is #t on non-infinite flonums"
    (flfinite? 2.0))

  (pass-if "flfinite? is #f on infinities"
    (and (not (flfinite? +inf.0)) (not (flfinite? -inf.0)))))

(with-test-prefix "flinfinite?"
  (pass-if "flinfinite? is #t on infinities"
    (and (flinfinite? +inf.0) (flinfinite? -inf.0)))

  (pass-if "flinfinite? is #f on non-infinite flonums"
    (not (flinfinite? 2.0))))

(with-test-prefix "flnan?"
  (pass-if "flnan? is #t on NaN and -NaN"
    (and (flnan? +nan.0) (flnan? -nan.0)))

  (pass-if "flnan? is #f on non-NaN values"
    (not (flnan? 1.5))))

(with-test-prefix "flmax"
  (pass-if "simple" (fl=? (flmax 1.0 3.0 2.0) 3.0)))

(with-test-prefix "flmin"
  (pass-if "simple" (fl=? (flmin -1.0 0.0 2.0) -1.0)))

(with-test-prefix "fl+"
  (pass-if "simple" (fl=? (fl+ 2.141 1.0 0.1) 3.241)))

(with-test-prefix "fl*"
  (pass-if "simple" (fl=? (fl* 1.0 2.0 3.0 1.5) 9.0)))

(with-test-prefix "fl-"
  (pass-if "unary fl- negates argument" (fl=? (fl- 2.0) -2.0))

  (pass-if "simple" (fl=? (fl- 10.5 6.0 0.5) 4.0)))

(with-test-prefix "fl/"
  (pass-if "unary fl/ returns multiplicative inverse" (fl=? (fl/ 10.0) 0.1))

  (pass-if "simple" (fl=? (fl/ 10.0 2.0 2.0) 2.5)))

(with-test-prefix "flabs"
  (pass-if "simple" (and (fl=? (flabs -1.0) 1.0) (fl=? (flabs 1.23) 1.23))))

(with-test-prefix "fldiv-and-mod"
  (pass-if "simple"
    (call-with-values (lambda () (fldiv-and-mod 5.0 2.0))
      (lambda (div mod) (fl=? div 2.0) (fl=? mod 1.0)))))

(with-test-prefix "fldiv"
  (pass-if "simple" (fl=? (fldiv 5.0 2.0) 2.0)))

(with-test-prefix "flmod"
  (pass-if "simple" (fl=? (flmod 5.0 2.0) 1.0)))

(with-test-prefix "fldiv0-and-mod0"
  (pass-if "simple"
    (call-with-values (lambda () (fldiv0-and-mod0 -123.0 10.0))
      (lambda (div mod)
	(or (and (fl=? div -12.0) (fl=? mod -3.0))
	    (throw 'unresolved))))))

(with-test-prefix "fldiv0"
  (pass-if "simple" (or (fl=? (fldiv0 -123.0 10.0) -12.0) (throw 'unresolved))))

(with-test-prefix "flmod0"
  (pass-if "simple" (or (fl=? (flmod0 -123.0 10.0) -3.0) (throw 'unresolved))))

(with-test-prefix "flnumerator"
  (pass-if "simple" (fl=? (flnumerator 0.5) 1.0))

  (pass-if "infinities"
    (and (fl=? (flnumerator +inf.0) +inf.0)
	 (fl=? (flnumerator -inf.0) -inf.0)))

  (pass-if "negative zero" (fl=? (flnumerator -0.0) -0.0)))

(with-test-prefix "fldenominator"
  (pass-if "simple" (fl=? (fldenominator 0.5) 2.0))

  (pass-if "infinities"
    (and (fl=? (fldenominator +inf.0) 1.0)
	 (fl=? (fldenominator -inf.0) 1.0)))

  (pass-if "zero" (fl=? (fldenominator 0.0) 1.0)))

(with-test-prefix "flfloor"
  (pass-if "simple"
    (and (fl=? (flfloor -4.3) -5.0)
	 (fl=? (flfloor 3.5) 3.0))))

(with-test-prefix "flceiling"
  (pass-if "simple"
    (and (fl=? (flceiling -4.3) -4.0)
	 (fl=? (flceiling 3.5) 4.0))))

(with-test-prefix "fltruncate"
  (pass-if "simple"
    (and (fl=? (fltruncate -4.3) -4.0)
	 (fl=? (fltruncate 3.5) 3.0))))

(with-test-prefix "flround"
  (pass-if "simple"
    (and (fl=? (flround -4.3) -4.0)
	 (fl=? (flround 3.5) 4.0))))

(with-test-prefix "flexp"
  (pass-if "infinities"
    (and (fl=? (flexp +inf.0) +inf.0)
	 (fl=? (flexp -inf.0) 0.0))))

(with-test-prefix "fllog"
  (pass-if "unary fllog returns natural log"
    (let ((l (fllog 2.718281828459045)))
      (and (fl<=? 0.9 l) (fl>=? 1.1 l))))

  (pass-if "infinities"
    (and (fl=? (fllog +inf.0) +inf.0)
	 (flnan? (fllog -inf.0))))

  (pass-if "zeroes" (fl=? (fllog 0.0) -inf.0))

  (pass-if "binary fllog returns log in specified base"
    (fl=? (fllog 8.0 2.0) 3.0)))

(with-test-prefix "flsin"
  (pass-if "simple"
    (and (reasonably-close? (flsin (/ fake-pi 2)) 1.0)
	 (reasonably-close? (flsin (/ fake-pi 6)) 0.5))))

(with-test-prefix "flcos"
  (pass-if "simple"
    (and (fl=? (flcos 0.0) 1.0) (reasonably-close? (flcos (/ fake-pi 3)) 0.5))))

(with-test-prefix "fltan"
  (pass-if "simple"
    (and (reasonably-close? (fltan (/ fake-pi 4)) 1.0)
	 (reasonably-close? (fltan (/ (* 3 fake-pi) 4)) -1.0))))

(with-test-prefix "flasin"
  (pass-if "simple"
    (and (reasonably-close? (flasin 1.0) (/ fake-pi 2))
	 (reasonably-close? (flasin 0.5) (/ fake-pi 6)))))

(with-test-prefix "flacos"
  (pass-if "simple"
    (and (fl=? (flacos 1.0) 0.0)
	 (reasonably-close? (flacos 0.5) (/ fake-pi 3)))))

(with-test-prefix "flatan"
  (pass-if "unary flatan"
    (and (reasonably-close? (flatan 1.0) (/ fake-pi 4))
	 (reasonably-close? (flatan -1.0) (/ fake-pi -4))))

  (pass-if "infinities"
    (and (reasonably-close? (flatan -inf.0) -1.5707963267949)
	 (reasonably-close? (flatan +inf.0) 1.5707963267949)))

  (pass-if "binary flatan"
    (and (reasonably-close? (flatan 3.5 3.5) (/ fake-pi 4)))))

(with-test-prefix "flsqrt"
  (pass-if "simple" (fl=? (flsqrt 4.0) 2.0))

  (pass-if "infinity" (fl=? (flsqrt +inf.0) +inf.0))

  (pass-if "negative zero" (fl=? (flsqrt -0.0) -0.0)))

(with-test-prefix "flexpt" (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0)))

(with-test-prefix "fixnum->flonum"
  (pass-if "simple" (fl=? (fixnum->flonum 100) 100.0)))


code:
;;; r6rs-base.test --- Test suite for R6RS (rnrs base)

;;      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-r6rs-base)
  :use-module ((rnrs base) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "vector-for-each"
  (pass-if "vector-for-each simple"
    (let ((sum 0))
      (vector-for-each (lambda (x) (set! sum (+ sum x))) '#(1 2 3))
      (eqv? sum 6))))

(with-test-prefix "vector-map"
  (pass-if "vector-map simple"
    (equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3)))))

license: mit


code:
;;; r6rs-conditions.test --- Test suite for R6RS (rnrs conditions)

;;      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-rnrs-conditions)
  :use-module ((rnrs conditions) :version (6))
  :use-module (test-suite lib))

(define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
(define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))

(with-test-prefix "condition?"
  (pass-if "condition? is #t for simple conditions"
    (condition? (make-error)))

  (pass-if "condition? is #t for compound conditions"
    (condition? (condition (make-error) (make-assertion-violation))))

  (pass-if "condition? is #f for non-conditions"
    (not (condition? 'foo))))

(with-test-prefix "simple-conditions"
  (pass-if "simple-conditions returns condition components"
    (let* ((error (make-error))
	   (assertion (make-assertion-violation))
	   (c (condition error assertion))
	   (scs (simple-conditions c)))
      (equal? scs (list error assertion))))

  (pass-if "simple-conditions flattens compound conditions"
    (let* ((implementation-restriction
	    (make-implementation-restriction-violation))
	   (error1 (make-error))
	   (c1 (condition implementation-restriction error1))
	   (error2 (make-error))
	   (assertion (make-assertion-violation))
	   (c2 (condition error2 assertion c1))
	   (scs (simple-conditions c2)))
      (equal? scs (list error2 assertion implementation-restriction error1)))))

(with-test-prefix "condition-predicate"
  (pass-if "returned procedure identifies matching simple conditions"
    (let ((mp (condition-predicate &message))
	  (mc (make-message-condition "test")))
      (mp mc)))

  (pass-if "returned procedure identifies matching compound conditions"
    (let* ((sp (condition-predicate &serious))
	   (vp (condition-predicate &violation))
	   (sc (make-serious-condition))
	   (vc (make-violation))
	   (c (condition sc vc)))
      (and (sp c) (vp c))))

  (pass-if "returned procedure is #f for non-matching simple"
    (let ((sp (condition-predicate &serious)))
      (not (sp 'foo))))

  (pass-if "returned procedure is #f for compound without match"
    (let* ((ip (condition-predicate &irritants))
	   (sc (make-serious-condition))
	   (vc (make-violation))
	   (c (condition sc vc)))
      (not (ip c)))))

(with-test-prefix "condition-accessor"
  (pass-if "accessor applies proc to field from simple condition"
    (let* ((proc (lambda (c) (condition-message c)))
	   (ma (condition-accessor &message proc))
	   (mc (make-message-condition "foo")))
      (equal? (ma mc) "foo")))

  (pass-if "accessor applies proc to field from compound condition"
    (let* ((proc (lambda (c) (condition-message c)))
	   (ma (condition-accessor &message proc))
	   (mc (make-message-condition "foo"))
	   (vc (make-violation))
	   (c (condition vc mc)))
      (equal? (ma c) "foo"))))

(with-test-prefix "define-condition-type"
  (pass-if "define-condition-type produces proper accessors"
    (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
      (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar)))))


code:
;;; r6rs-control.test --- Test suite for R6RS (rnrs control)

;;      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-rnrs-control)
  :use-module ((rnrs control) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "when"
  (pass-if "when true"
    (eq? (when (> 3 2) 'greater) 'greater))
  (pass-if "when false"
    (unspecified? (when (< 3 2) 'greater))))

(with-test-prefix "unless"
  (pass-if "unless true"
    (unspecified? (unless (> 3 2) 'less)))
  (pass-if "unless false"
    (eq? (unless (< 3 2) 'less) 'less)))


code:
;;; r6rs-enums.test --- Test suite for R6RS (rnrs enums)

;;      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-rnrs-enums)
  :use-module ((rnrs conditions) :version (6))
  :use-module ((rnrs enums) :version (6))
  :use-module ((rnrs exceptions) :version (6))
  :use-module (test-suite lib))

(define-enumeration foo-enumeration (foo bar baz) make-foo-set)

(with-test-prefix "enum-set-universe"
  (pass-if "universe of an enumeration is itself"
    (let ((et (make-enumeration '(a b c))))
      (eq? (enum-set-universe et) et)))

  (pass-if "enum-set-universe returns universe"
    (let* ((et (make-enumeration '(a b c)))
	   (es ((enum-set-constructor et) '(a b))))
      (eq? (enum-set-universe es) et))))

(with-test-prefix "enum-set-indexer"
  (pass-if "indexer returns index of symbol in universe"
    (let* ((universe (make-enumeration '(a b c)))
	   (set ((enum-set-constructor universe) '(a c)))
	   (indexer (enum-set-indexer set)))
      (and (eqv? (indexer 'a) 0) (eqv? (indexer 'c) 2))))

  (pass-if "indexer returns index of symbol in universe but not set"
    (let* ((universe (make-enumeration '(a b c)))
	   (set ((enum-set-constructor universe) '(a c)))
	   (indexer (enum-set-indexer set)))
      (eqv? (indexer 'b) 1)))

  (pass-if "indexer returns #f for symbol not in universe"
    (let* ((universe (make-enumeration '(a b c)))
	   (set ((enum-set-constructor universe) '(a b c)))
	   (indexer (enum-set-indexer set)))
      (eqv? (indexer 'd) #f))))

(with-test-prefix "enum-set->list"
  (pass-if "enum-set->list returns members in universe order"
    (let* ((universe (make-enumeration '(a b c d e)))
	   (set ((enum-set-constructor universe) '(d a e c))))
      (equal? (enum-set->list set) '(a c d e)))))

(with-test-prefix "enum-set-member?"
  (pass-if "enum-set-member? is #t for set members"
    (let* ((universe (make-enumeration '(a b c)))
	   (set ((enum-set-constructor universe) '(a b c))))
      (enum-set-member? 'a set)))

  (pass-if "enum-set-member? is #f for set non-members"
    (let* ((universe (make-enumeration '(a b c)))
	   (set ((enum-set-constructor universe) '(a b c))))
      (not (enum-set-member? 'd set))))

  (pass-if "enum-set-member? is #f for universe but not set members"
    (let* ((universe (make-enumeration '(a b c d)))
	   (set ((enum-set-constructor universe) '(a b c))))
      (not (enum-set-member? 'd set)))))

(with-test-prefix "enum-set-subset?"
  (pass-if "enum-set-subset? is #t when set1 subset of set2"
    (let* ((universe (make-enumeration '(a b c d e)))
	   (set1 ((enum-set-constructor universe) '(a b c)))
	   (set2 ((enum-set-constructor universe) '(a b c d))))
      (enum-set-subset? set1 set2)))

  (pass-if "enum-set-subset? is #t when universe and set are subsets"
    (let* ((universe1 (make-enumeration '(a b c d)))
	   (universe2 (make-enumeration '(a b c d e)))
	   (set1 ((enum-set-constructor universe1) '(a b c)))
	   (set2 ((enum-set-constructor universe2) '(a b c d))))
      (enum-set-subset? set1 set2)))

  (pass-if "enum-set-subset? is #f when set not subset"
    (let* ((universe (make-enumeration '(a b c d e)))
	   (set1 ((enum-set-constructor universe) '(a b c d)))
	   (set2 ((enum-set-constructor universe) '(a b c))))
      (not (enum-set-subset? set1 set2))))

  (pass-if "enum-set-subset? is #f when universe not subset"
    (let* ((universe1 (make-enumeration '(a b c d e)))
	   (universe2 (make-enumeration '(a b c d)))
	   (set1 ((enum-set-constructor universe1) '(a b c)))
	   (set2 ((enum-set-constructor universe2) '(a b c d))))
      (not (enum-set-subset? set1 set2)))))

(with-test-prefix "enum-set=?"
  (pass-if "enum-set=? is #t when sets are equal"
    (let* ((universe1 (make-enumeration '(a b c)))
	   (universe2 (make-enumeration '(a b c)))
	   (set1 ((enum-set-constructor universe1) '(a b c)))
	   (set2 ((enum-set-constructor universe2) '(a b c))))
      (enum-set=? set1 set2)))

  (pass-if "enum-set=? is #f when sets are not equal"
    (let* ((universe (make-enumeration '(a b c d)))
	   (set1 ((enum-set-constructor universe) '(a b)))
	   (set2 ((enum-set-constructor universe) '(c d))))
      (not (enum-set=? set1 set2))))

  (pass-if "enum-set=? is #f when universes are not equal"
    (let* ((universe1 (make-enumeration '(a b c d)))
	   (universe2 (make-enumeration '(a b c d e)))
	   (set1 ((enum-set-constructor universe1) '(a b c d)))
	   (set2 ((enum-set-constructor universe2) '(a b c d))))
      (not (enum-set=? set1 set2)))))

(with-test-prefix "enum-set-union"
  (pass-if "&assertion raised on different universes"
    (guard (condition ((assertion-violation? condition) #t))
	   (let* ((universe1 (make-enumeration '(a b c)))
		  (universe2 (make-enumeration '(d e f)))
		  (set1 ((enum-set-constructor universe1) '(a b c)))
		  (set2 ((enum-set-constructor universe2) '(d e f))))
	     (enum-set-union set1 set2)
	     #f)))

  (pass-if "enum-set-union creates union on overlapping sets"
    (let* ((universe (make-enumeration '(a b c d e)))
	   (set1 ((enum-set-constructor universe) '(a b c)))
	   (set2 ((enum-set-constructor universe) '(c d e)))
	   (union (enum-set-union set1 set2)))
      (equal? (enum-set->list union) '(a b c d e))))

  (pass-if "enum-set-union creates union on disjoint sets"
    (let* ((universe (make-enumeration '(a b c d e f)))
	   (set1 ((enum-set-constructor universe) '(a b c)))
	   (set2 ((enum-set-constructor universe) '(d e f)))
	   (union (enum-set-union set1 set2)))
      (equal? (enum-set->list union) '(a b c d e f)))))

(with-test-prefix "enum-set-intersection"
  (pass-if "&assertion raised on different universes"
    (guard (condition ((assertion-violation? condition) #t))
	   (let* ((universe1 (make-enumeration '(a b c)))
		  (universe2 (make-enumeration '(d e f)))
		  (set1 ((enum-set-constructor universe1) '(a b c)))
		  (set2 ((enum-set-constructor universe2) '(d e f))))
	     (enum-set-intersection set1 set2)
	     #f)))

  (pass-if "enum-set-intersection on overlapping sets"
    (let* ((universe (make-enumeration '(a b c d e)))
	   (set1 ((enum-set-constructor universe) '(a b c)))
	   (set2 ((enum-set-constructor universe) '(c d e)))
	   (intersection (enum-set-intersection set1 set2)))
      (equal? (enum-set->list intersection) '(c))))

  (pass-if "enum-set-intersection on disjoint sets"
    (let* ((universe (make-enumeration '(a b c d e f)))
	   (set1 ((enum-set-constructor universe) '(a b c)))
	   (set2 ((enum-set-constructor universe) '(d e f)))
	   (intersection (enum-set-intersection set1 set2)))
      (null? (enum-set->list intersection)))))

(with-test-prefix "enum-set-difference"
  (pass-if "&assertion raised on different universes"
    (guard (condition ((assertion-violation? condition) #t))
	   (let* ((universe1 (make-enumeration '(a b c)))
		  (universe2 (make-enumeration '(d e f)))
		  (set1 ((enum-set-constructor universe1) '(a b c)))
		  (set2 ((enum-set-constructor universe2) '(d e f))))
	     (enum-set-difference set1 set2)
	     #f)))

  (pass-if "enum-set-difference with subset"
    (let* ((universe (make-enumeration '(a b c)))
	   (set1 ((enum-set-constructor universe) '(a b c)))
	   (set2 ((enum-set-constructor universe) '(a)))
	   (difference (enum-set-difference set1 set2)))
      (equal? (enum-set->list difference) '(b c))))

  (pass-if "enum-set-difference with superset is empty"
    (let* ((universe (make-enumeration '(a b c d)))
	   (set1 ((enum-set-constructor universe) '(a b c)))
	   (set2 ((enum-set-constructor universe) '(a b c d)))
	   (difference (enum-set-difference set1 set2)))
      (null? (enum-set->list difference)))))

(with-test-prefix "enum-set-complement"
  (pass-if "complement of empty set is universe"
    (let* ((universe (make-enumeration '(a b c)))
	   (set ((enum-set-constructor universe) '()))
	   (complement (enum-set-complement set)))
      (equal? (enum-set->list complement) (enum-set->list universe))))

  (pass-if "simple complement"
    (let* ((universe (make-enumeration '(a b c d)))
	   (set ((enum-set-constructor universe) '(a c)))
	   (complement (enum-set-complement set)))
      (equal? (enum-set->list complement) '(b d)))))

(with-test-prefix "enum-set-projection"
  (pass-if "projection onto subset universe"
    (let* ((universe1 (make-enumeration '(a b c d)))
	   (universe2 (make-enumeration '(a b c)))
	   (set1 ((enum-set-constructor universe1) '(a d)))
	   (set2 ((enum-set-constructor universe2) '(b c)))
	   (projection (enum-set-projection set1 set2)))
      (equal? (enum-set->list projection) '(a))))

  (pass-if "projection onto superset universe"
    (let* ((universe1 (make-enumeration '(a b c)))
	   (universe2 (make-enumeration '(a b c d)))
	   (set1 ((enum-set-constructor universe1) '(a c)))
	   (set2 ((enum-set-constructor universe2) '(b d)))
	   (projection (enum-set-projection set1 set2)))
      (equal? (enum-set->list projection) '(a c))))

  (pass-if "projection onto disjoint universe"
    (let* ((universe1 (make-enumeration '(a b c)))
	   (universe2 (make-enumeration '(d e f)))
	   (set1 ((enum-set-constructor universe1) '(a c)))
	   (set2 ((enum-set-constructor universe2) '(d f)))
	   (projection (enum-set-projection set1 set2)))
      (equal? (enum-set->list projection) '()))))

(with-test-prefix "define-enumeration"
  (pass-if "define-enumeration creates bindings"
    (and (defined? 'foo-enumeration) (defined? 'make-foo-set)))

  (pass-if "type-name syntax raises &syntax on non-member"
    (guard (condition ((syntax-violation? condition) #t))
	   (begin (eval '(foo-enumeration a) (current-module)) #f)))

  (pass-if "type-name evaluates to quote on member"
    (guard (condition ((syntax-violation? condition) #f))
	   (eq? (eval '(foo-enumeration foo) (current-module)) 'foo)))

  (pass-if "constructor-syntax raises &syntax on non-members"
    (guard (condition ((syntax-violation? condition) #t))
	   (begin (eval '(make-foo-set foo bar not-baz) (current-module)) #f)))

  (pass-if "constructor-syntax evaluates to new set"
    (guard (condition ((syntax-violation? condition) #f))
	   (equal? (enum-set->list (eval '(make-foo-set foo bar)
					 (current-module)))
		   '(foo bar)))))


code:
;;; r6rs-eval.test --- Test suite for R6RS (rnrs eval)

;;      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-rnrs-eval)
  :use-module ((rnrs eval) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "environment"
  (pass-if "simple"
    (eqv? (eval '(eval:car (eval:cons 2 4))
		(environment '(prefix (only (rnrs base) car cons) eval:)))
	  2)))


code:
;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)

;;      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-rnrs-exceptions)
  :use-module ((rnrs conditions) :version (6))
  :use-module ((rnrs exceptions) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "with-exception-handler"
  (pass-if "handler invoked on raise"
    (let ((success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition) (set! success #t) (continuation))
	  (lambda () (raise (make-violation))))))
      success))

  (pass-if "handler not invoked unless raise"
    (let ((success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition) (continuation))
	  (lambda () (set! success #t)))))
      success)))

(with-test-prefix "raise"
  (pass-if "raise causes &non-continuable after handler"
    (let ((success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition)
	    (set! success (non-continuable-violation? condition))
	    (continuation))
	  (lambda ()
	    (with-exception-handler
	     (lambda (condition) #f)
	     (lambda () (raise (make-violation))))))))
      success)))

(with-test-prefix "raise-continuable"
  (pass-if "raise-continuable invokes continuation after handler"
    (let ((handled #f)
	  (continued #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition) (set! handled #t))
	  (lambda ()
	    (raise-continuable (make-violation))
	    (set! continued #t)))))
      (and handled continued))))

(with-test-prefix "guard"
  (pass-if "guard with matching cond without else"
    (let ((success #f))
      (guard (condition ((error? condition) (set! success #t)))
	     (raise (make-error)))
      success))

  (pass-if "guard without matching cond without else"
    (let ((success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition) (set! success (error? condition)) (continuation))
	  (lambda ()
	    (guard (condition ((irritants-condition? condition) #f))
		   (raise (make-error)))))))
      success))

  (pass-if "guard with else and without matching cond"
    (let ((success #f))
      (guard (condition ((irritants-condition? condition) #f)
			(else (set! success #t)))
	     (raise (make-error)))
      success))

  (pass-if "guard with cond => syntax"
    (guard (condition (condition => error?)) (raise (make-error)))))


code:
;;; r6rs-files.test --- Test suite for R6RS (rnrs unicode)

;;      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-rnrs-files)
  :use-module ((rnrs exceptions) :version (6))
  :use-module ((rnrs files) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "delete-file"
  (pass-if "delete-file deletes file"
    (let ((filename (port-filename (mkstemp! "T-XXXXXX"))))
      (delete-file filename)
      (not (file-exists? filename))))

  (pass-if "delete-file raises &i/o-filename on error"
    (let ((success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition)
	    (set! success (i/o-filename-error? condition))
	    (continuation))
	  (lambda () (delete-file "")))))
      success)))


code:
;;; r6rs-hashtables.test --- Test suite for R6RS (rnrs hashtables)

;;      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 Lice6nse, 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-rnrs-hashtable)
  :use-module (ice-9 receive)
  :use-module ((rnrs hashtables) :version (6))
  :use-module (srfi srfi-1)
  :use-module (test-suite lib))

(with-test-prefix "make-eq-hashtable"
  (pass-if "eq hashtable compares keys with eq?"
    (let ((eq-hashtable (make-eq-hashtable)))
      (hashtable-set! eq-hashtable (list 'foo) #t)
      (hashtable-set! eq-hashtable 'sym #t)
      (and (not (hashtable-contains? eq-hashtable (list 'foo)))
	   (hashtable-contains? eq-hashtable 'sym)))))

(with-test-prefix "make-eqv-hashtable"
  (pass-if "eqv hashtable compares keys with eqv?"
    (let ((eqv-hashtable (make-eqv-hashtable)))
      (hashtable-set! eqv-hashtable (list 'foo) #t)
      (hashtable-set! eqv-hashtable 4 #t)
      (and (not (hashtable-contains? eqv-hashtable (list 'foo)))
	   (hashtable-contains? eqv-hashtable 4)))))

(with-test-prefix "make-hashtable"
  (pass-if "hashtable compares keys with custom equality function"
    (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
	   (abs-hashtable (make-hashtable abs abs-eqv?)))
      (hashtable-set! abs-hashtable -4 #t)
      (and (not (hashtable-contains? abs-hashtable 6))
	   (hashtable-contains? abs-hashtable 4))))

  (pass-if "hash function value used modulo capacity"
    (let* ((constant-hash (lambda (x) most-positive-fixnum))
	   (constant-hashtable (make-hashtable constant-hash eq?)))
      (hashtable-set! constant-hashtable 'foo 'bar)
      (hashtable-contains? constant-hashtable 'foo))))

(with-test-prefix "hashtable?"
  (pass-if "hashtable? is #t on hashtables"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable? hashtable)))

  (pass-if "hashtable? is #f on non-hashtables"
    (let ((not-hashtable (list)))
      (not (hashtable? not-hashtable)))))

(with-test-prefix "hashtable-size"
  (pass-if "hashtable-size returns current size"
    (let ((hashtable (make-eq-hashtable)))
      (and (eqv? (hashtable-size hashtable) 0)
	   (hashtable-set! hashtable 'foo #t)
	   (eqv? (hashtable-size hashtable) 1)))))

(with-test-prefix "hashtable-ref"
  (pass-if "hashtable-ref returns value for bound key"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'sym 'foo)
      (eq? (hashtable-ref hashtable 'sym 'bar) 'foo)))

  (pass-if "hashtable-ref returns default for unbound key"
    (let ((hashtable (make-eq-hashtable)))
      (eq? (hashtable-ref hashtable 'sym 'bar) 'bar))))

(with-test-prefix "hashtable-set!"
  (pass-if "hashtable-set! returns unspecified"
    (let ((hashtable (make-eq-hashtable)))
      (unspecified? (hashtable-set! hashtable 'foo 'bar))))

  (pass-if "hashtable-set! allows storing #f"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo #f)
      (not (hashtable-ref hashtable 'foo 'bar)))))

(with-test-prefix "hashtable-delete!"
  (pass-if "hashtable-delete! removes association"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo 'bar)
      (and (unspecified? (hashtable-delete! hashtable 'foo))
	   (not (hashtable-ref hashtable 'foo #f))))))

(with-test-prefix "hashtable-contains?"
  (pass-if "hashtable-contains? returns #t when association present"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo 'bar)
      (let ((contains (hashtable-contains? hashtable 'foo)))
	(and (boolean? contains) contains))))

  (pass-if "hashtable-contains? returns #f when association not present"
    (let ((hashtable (make-eq-hashtable)))
      (not (hashtable-contains? hashtable 'foo)))))

(with-test-prefix "hashtable-update!"
  (pass-if "hashtable-update! adds return value of proc on bound key"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo 0)
      (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
      (eqv? (hashtable-ref hashtable 'foo #f) 1)))

  (pass-if "hashtable-update! adds default value on unbound key"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-update! hashtable 'foo (lambda (x) (+ x 1)) 100)
      (eqv? (hashtable-ref hashtable 'foo #f) 101))))

(with-test-prefix "hashtable-copy"
  (pass-if "hashtable-copy produces copy of hashtable"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo 1)
      (hashtable-set! hashtable 'bar 2)
      (let ((copied-table (hashtable-copy hashtable)))
	(and (eqv? (hashtable-ref hashtable 'foo #f) 1)
	     (eqv? (hashtable-ref hashtable 'bar #f) 2)))))

  (pass-if "hashtable-copy with mutability #f produces immutable copy"
    (let ((copied-table (hashtable-copy (make-eq-hashtable) #f)))
      (hashtable-set! copied-table 'foo 1)
      (not (hashtable-ref copied-table 'foo #f)))))

(with-test-prefix "hashtable-clear!"
  (pass-if "hashtable-clear! removes all values from hashtable"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo 1)
      (hashtable-set! hashtable 'bar 2)
      (and (unspecified? (hashtable-clear! hashtable))
	   (eqv? (hashtable-size hashtable) 0)))))

(with-test-prefix "hashtable-keys"
  (pass-if "hashtable-keys returns all keys"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo #t)
      (hashtable-set! hashtable 'bar #t)
      (let ((keys (vector->list (hashtable-keys hashtable))))
	(and (memq 'foo keys) (memq 'bar keys) #t)))))

(with-test-prefix "hashtable-entries"
  (pass-if "hashtable-entries returns all entries"
    (let ((hashtable (make-eq-hashtable)))
      (hashtable-set! hashtable 'foo 1)
      (hashtable-set! hashtable 'bar 2)
      (receive
        (keys values)
	(hashtable-entries hashtable)
	(let f ((counter 0) (success #t))
	  (if (or (not success) (= counter 2))
	      success
	      (case (vector-ref keys counter)
		((foo) (f (+ counter 1) (eqv? (vector-ref values counter) 1)))
		((bar) (f (+ counter 1) (eqv? (vector-ref values counter) 2)))
		(else f 0 #f))))))))

(with-test-prefix "hashtable-equivalence-function"
  (pass-if "hashtable-equivalence-function returns eqv function"
    (let* ((abs-eqv? (lambda (x y) (eqv? (abs x) (abs y))))
	   (abs-hashtable (make-hashtable abs abs-eqv?)))
      (eq? (hashtable-equivalence-function abs-hashtable) abs-eqv?))))

(with-test-prefix "hashtable-hash-function"
  (pass-if "hashtable-hash-function returns hash function"
    (let ((abs-hashtable (make-hashtable abs eqv?)))
      (eq? (hashtable-hash-function abs-hashtable) abs))))

(with-test-prefix "hashtable-mutable?"
  (pass-if "hashtable-mutable? is #t on mutable hashtables"
    (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #t)))

  (pass-if "hashtable-mutable? is #f on immutable hashtables"
    (not (hashtable-mutable? (hashtable-copy (make-eq-hashtable) #f)))))


code:
;;; r6rs-lists.test --- Test suite for R6RS (rnrs lists)

;;      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-r6rs-lists)
  :use-module ((rnrs lists) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "memp"
  (pass-if "memp simple"
    (equal? (memp even? '(3 1 4 1 5 9 2 6 5)) '(4 1 5 9 2 6 5))))

(with-test-prefix "assp"
  (pass-if "assp simple"
    (let ((d '((3 a) (1 b) (4 c))))
      (equal? (assp even? d) '(4 c)))))


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

(define-module (test-io-ports)
  :use-module (test-suite lib)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-11)
  :use-module (rnrs io ports)
  :use-module (rnrs bytevectors))

;;; All these tests assume Guile 1.8's port system, where characters are
;;; treated as octets.

;; Set the default encoding of future ports to be Latin-1.
(fluid-set! %default-port-encoding #f)

(with-test-prefix "7.2.5 End-of-File Object"

  (pass-if "eof-object"
    (and (eqv? (eof-object) (eof-object))
         (eq?  (eof-object) (eof-object)))))

(with-test-prefix "7.2.8 Binary Input"

  (pass-if "get-u8"
    (let ((port (open-input-string "A")))
      (and (= (char->integer #\A) (get-u8 port))
           (eof-object? (get-u8 port)))))

  (pass-if "lookahead-u8"
    (let ((port (open-input-string "A")))
      (and (= (char->integer #\A) (lookahead-u8 port))
           (not (eof-object? port))
           (= (char->integer #\A) (get-u8 port))
           (eof-object? (get-u8 port)))))

  (pass-if "get-bytevector-n [short]"
    (let* ((port (open-input-string "GNU Guile"))
           (bv (get-bytevector-n port 4)))
      (and (bytevector? bv)
           (equal? (bytevector->u8-list bv)
                   (map char->integer (string->list "GNU "))))))

  (pass-if "get-bytevector-n [long]"
    (let* ((port (open-input-string "GNU Guile"))
           (bv (get-bytevector-n port 256)))
      (and (bytevector? bv)
           (equal? (bytevector->u8-list bv)
                   (map char->integer (string->list "GNU Guile"))))))

  (pass-if-exception "get-bytevector-n with closed port"
    exception:wrong-type-arg

    (let ((port (%make-void-port "r")))

      (close-port port)
      (get-bytevector-n port 3)))

  (pass-if "get-bytevector-n! [short]"
    (let* ((port (open-input-string "GNU Guile"))
           (bv   (make-bytevector 4))
           (read (get-bytevector-n! port bv 0 4)))
      (and (equal? read 4)
           (equal? (bytevector->u8-list bv)
                   (map char->integer (string->list "GNU "))))))

  (pass-if "get-bytevector-n! [long]"
    (let* ((str  "GNU Guile")
           (port (open-input-string str))
           (bv   (make-bytevector 256))
           (read (get-bytevector-n! port bv 0 256)))
      (and (equal? read (string-length str))
           (equal? (map (lambda (i)
                          (bytevector-u8-ref bv i))
                        (iota read))
                   (map char->integer (string->list str))))))

  (pass-if "get-bytevector-some [simple]"
    (let* ((str  "GNU Guile")
           (port (open-input-string str))
           (bv   (get-bytevector-some port)))
      (and (bytevector? bv)
           (equal? (bytevector->u8-list bv)
                   (map char->integer (string->list str))))))

  (pass-if "get-bytevector-some [only-some]"
    (let* ((str   "GNU Guile")
           (index 0)
           (port  (make-soft-port
                   (vector #f #f #f
                           (lambda ()
                             (if (>= index (string-length str))
                                 (eof-object)
                                 (let ((c (string-ref str index)))
                                   (set! index (+ index 1))
                                   c)))
                           (lambda () #t)
                           (lambda ()
                             ;; Number of readily available octets: falls to
                             ;; zero after 4 octets have been read.
                             (- 4 (modulo index 5))))
                   "r"))
           (bv    (get-bytevector-some port)))
      (and (bytevector? bv)
           (= index 4)
           (= (bytevector-length bv) index)
           (equal? (bytevector->u8-list bv)
                   (map char->integer (string->list "GNU "))))))

  (pass-if "get-bytevector-all"
    (let* ((str   "GNU Guile")
           (index 0)
           (port  (make-soft-port
                   (vector #f #f #f
                           (lambda ()
                             (if (>= index (string-length str))
                                 (eof-object)
                                 (let ((c (string-ref str index)))
                                   (set! index (+ index 1))
                                   c)))
                           (lambda () #t)
                           (let ((cont? #f))
                             (lambda ()
                               ;; Number of readily available octets: falls to
                               ;; zero after 4 octets have been read and then
                               ;; starts again.
                               (let ((a (if cont?
                                            (- (string-length str) index)
                                            (- 4 (modulo index 5)))))
                                 (if (= 0 a) (set! cont? #t))
                                 a))))
                   "r"))
           (bv    (get-bytevector-all port)))
      (and (bytevector? bv)
           (= index (string-length str))
           (= (bytevector-length bv) (string-length str))
           (equal? (bytevector->u8-list bv)
                   (map char->integer (string->list str)))))))

(define (make-soft-output-port)
  (let* ((bv (make-bytevector 1024))
         (read-index  0)
         (write-index 0)
         (write-char (lambda (chr)
                       (bytevector-u8-set! bv write-index
                                           (char->integer chr))
                       (set! write-index (+ 1 write-index)))))
    (make-soft-port
     (vector write-char
             (lambda (str)   ;; write-string
               (for-each write-char (string->list str)))
             (lambda () #t)  ;; flush-output
             (lambda ()      ;; read-char
               (if (>= read-index (bytevector-length bv))
                   (eof-object)
                   (let ((c (bytevector-u8-ref bv read-index)))
                     (set! read-index (+ read-index 1))
                     (integer->char c))))
             (lambda () #t)) ;; close-port
     "rw")))

(with-test-prefix "7.2.11 Binary Output"

  (pass-if "put-u8"
    (let ((port (make-soft-output-port)))
      (put-u8 port 77)
      (equal? (get-u8 port) 77)))

  (pass-if "put-bytevector [2 args]"
    (let ((port (make-soft-output-port))
          (bv   (make-bytevector 256)))
      (put-bytevector port bv)
      (equal? (bytevector->u8-list bv)
              (bytevector->u8-list
               (get-bytevector-n port (bytevector-length bv))))))

  (pass-if "put-bytevector [3 args]"
    (let ((port  (make-soft-output-port))
          (bv    (make-bytevector 256))
          (start 10))
      (put-bytevector port bv start)
      (equal? (drop (bytevector->u8-list bv) start)
              (bytevector->u8-list
               (get-bytevector-n port (- (bytevector-length bv) start))))))

  (pass-if "put-bytevector [4 args]"
    (let ((port  (make-soft-output-port))
          (bv    (make-bytevector 256))
          (start 10)
          (count 77))
      (put-bytevector port bv start count)
      (equal? (take (drop (bytevector->u8-list bv) start) count)
              (bytevector->u8-list
               (get-bytevector-n port count)))))

  (pass-if-exception "put-bytevector with closed port"
    exception:wrong-type-arg

    (let* ((bv   (make-bytevector 4))
           (port (%make-void-port "w")))

      (close-port port)
      (put-bytevector port bv)))

  (pass-if "put-bytevector with UTF-16 string port"
    (let* ((str "hello, world")
           (bv  (string->utf16 str)))
      (equal? str
              (with-fluids ((%default-port-encoding "UTF-16BE"))
                (call-with-output-string
                  (lambda (port)
                    (put-bytevector port bv)))))))

  (pass-if "put-bytevector with wrong-encoding string port"
    (let* ((str "hello, world")
           (bv  (string->utf16 str)))
      (catch 'encoding-error
        (lambda ()
          (with-fluids ((%default-port-encoding "UTF-32"))
            (call-with-output-string
              (lambda (port)
                (put-bytevector port bv)))))
        (lambda (key subr message errno from to faulty-bv)
          (and (bytevector=? faulty-bv bv)
               (string=? to "UTF-32")
               (string? (strerror errno))))))))

(with-test-prefix "7.2.7 Input Ports"

  ;; This section appears here so that it can use the binary input
  ;; primitives.

  (pass-if "open-bytevector-input-port [1 arg]"
    (let* ((str "Hello Port!")
           (bv (u8-list->bytevector (map char->integer
                                         (string->list str))))
           (port (open-bytevector-input-port bv))
           (read-to-string
            (lambda (port)
              (let loop ((chr (read-char port))
                         (result '()))
                (if (eof-object? chr)
                    (apply string (reverse! result))
                    (loop (read-char port)
                          (cons chr result)))))))

      (equal? (read-to-string port) str)))

  (pass-if-exception "bytevector-input-port is read-only"
    exception:wrong-type-arg

    (let* ((str "Hello Port!")
           (bv (u8-list->bytevector (map char->integer
                                         (string->list str))))
           (port (open-bytevector-input-port bv #f)))

      (write "hello" port)))

  (pass-if "bytevector input port supports seeking"
    (let* ((str "Hello Port!")
           (bv (u8-list->bytevector (map char->integer
                                         (string->list str))))
           (port (open-bytevector-input-port bv #f)))

      (and (port-has-port-position? port)
           (= 0 (port-position port))
           (port-has-set-port-position!? port)
           (begin
             (set-port-position! port 6)
             (= 6 (port-position port)))
           (bytevector=? (get-bytevector-all port)
                         (u8-list->bytevector
                          (map char->integer (string->list "Port!")))))))

  (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
    exception:wrong-num-args

    ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
    ;; optional.
    (make-custom-binary-input-port "port" (lambda args #t)))

  (pass-if "make-custom-binary-input-port"
    (let* ((source (make-bytevector 7777))
           (read! (let ((pos 0)
                        (len (bytevector-length source)))
                    (lambda (bv start count)
                      (let ((amount (min count (- len pos))))
                        (if (> amount 0)
                            (bytevector-copy! source pos
                                              bv start amount))
                        (set! pos (+ pos amount))
                        amount))))
           (port (make-custom-binary-input-port "the port" read!
                                                #f #f #f)))

      (bytevector=? (get-bytevector-all port) source)))

  (pass-if "custom binary input port does not support `port-position'"
    (let* ((str "Hello Port!")
           (source (open-bytevector-input-port
                    (u8-list->bytevector
                     (map char->integer (string->list str)))))
           (read! (lambda (bv start count)
                    (let ((r (get-bytevector-n! source bv start count)))
                      (if (eof-object? r)
                          0
                          r))))
           (port (make-custom-binary-input-port "the port" read!
                                                #f #f #f)))
      (not (or (port-has-port-position? port)
               (port-has-set-port-position!? port)))))

  (pass-if "custom binary input port supports `port-position'"
    (let* ((str "Hello Port!")
           (source (open-bytevector-input-port
                    (u8-list->bytevector
                     (map char->integer (string->list str)))))
           (read! (lambda (bv start count)
                    (let ((r (get-bytevector-n! source bv start count)))
                      (if (eof-object? r)
                          0
                          r))))
           (get-pos (lambda ()
                      (port-position source)))
           (set-pos! (lambda (pos)
                       (set-port-position! source pos)))
           (port (make-custom-binary-input-port "the port" read!
                                                get-pos set-pos! #f)))

      (and (port-has-port-position? port)
           (= 0 (port-position port))
           (port-has-set-port-position!? port)
           (begin
             (set-port-position! port 6)
             (= 6 (port-position port)))
           (bytevector=? (get-bytevector-all port)
                         (u8-list->bytevector
                          (map char->integer (string->list "Port!")))))))

  (pass-if "custom binary input port `close-proc' is called"
    (let* ((closed?  #f)
           (read!    (lambda (bv start count) 0))
           (get-pos  (lambda () 0))
           (set-pos! (lambda (pos) #f))
           (close!   (lambda () (set! closed? #t)))
           (port     (make-custom-binary-input-port "the port" read!
                                                    get-pos set-pos!
                                                    close!)))

      (close-port port)
      (gc) ; Test for marking a closed port.
      closed?)))

(with-test-prefix "8.2.10 Output ports"

  (pass-if "open-bytevector-output-port"
    (let-values (((port get-content)
                  (open-bytevector-output-port #f)))
      (let ((source (make-bytevector 7777)))
        (put-bytevector port source)
        (and (bytevector=? (get-content) source)
             (bytevector=? (get-content) (make-bytevector 0))))))

  (pass-if "open-bytevector-output-port [put-u8]"
    (let-values (((port get-content)
                  (open-bytevector-output-port)))
      (put-u8 port 77)
      (and (bytevector=? (get-content) (make-bytevector 1 77))
           (bytevector=? (get-content) (make-bytevector 0)))))

  (pass-if "open-bytevector-output-port [display]"
    (let-values (((port get-content)
                  (open-bytevector-output-port)))
      (display "hello" port)
      (and (bytevector=? (get-content) (string->utf8 "hello"))
           (bytevector=? (get-content) (make-bytevector 0)))))

  (pass-if "bytevector output port supports `port-position'"
    (let-values (((port get-content)
                  (open-bytevector-output-port)))
      (let ((source (make-bytevector 7777))
            (overwrite (make-bytevector 33)))
        (and (port-has-port-position? port)
             (port-has-set-port-position!? port)
             (begin
               (put-bytevector port source)
               (= (bytevector-length source)
                  (port-position port)))
             (begin
               (set-port-position! port 10)
               (= 10 (port-position port)))
             (begin
               (put-bytevector port overwrite)
               (bytevector-copy! overwrite 0 source 10
                                 (bytevector-length overwrite))
               (= (port-position port)
                  (+ 10 (bytevector-length overwrite))))
             (bytevector=? (get-content) source)
             (bytevector=? (get-content) (make-bytevector 0))))))

  (pass-if "make-custom-binary-output"
    (let ((port (make-custom-binary-output-port "cbop"
                                                (lambda (x y z) 0)
                                                #f #f #f)))
      (and (output-port? port)
           (binary-port? port)
           (not (port-has-port-position? port))
           (not (port-has-set-port-position!? port)))))

  (pass-if "make-custom-binary-output-port [partial writes]"
    (let* ((source   (uint-list->bytevector (iota 333)
                                            (native-endianness) 2))
           (sink     (make-bytevector (bytevector-length source)))
           (sink-pos 0)
           (eof?     #f)
           (write!   (lambda (bv start count)
                       (if (= 0 count)
                           (begin
                             (set! eof? #t)
                             0)
                           (let ((u8 (bytevector-u8-ref bv start)))
                             ;; Get one byte at a time.
                             (bytevector-u8-set! sink sink-pos u8)
                             (set! sink-pos (+ 1 sink-pos))
                             1))))
           (port     (make-custom-binary-output-port "cbop" write!
                                                     #f #f #f)))
      (put-bytevector port source)
      (and (= sink-pos (bytevector-length source))
           (not eof?)
           (bytevector=? sink source))))

  (pass-if "make-custom-binary-output-port [full writes]"
    (let* ((source   (uint-list->bytevector (iota 333)
                                            (native-endianness) 2))
           (sink     (make-bytevector (bytevector-length source)))
           (sink-pos 0)
           (eof?     #f)
           (write!   (lambda (bv start count)
                       (if (= 0 count)
                           (begin
                             (set! eof? #t)
                             0)
                           (begin
                             (bytevector-copy! bv start
                                               sink sink-pos
                                               count)
                             (set! sink-pos (+ sink-pos count))
                             count))))
           (port     (make-custom-binary-output-port "cbop" write!
                                                     #f #f #f)))
      (put-bytevector port source)
      (and (= sink-pos (bytevector-length source))
           (not eof?)
           (bytevector=? sink source)))))

;;; Local Variables:
;;; mode: scheme
;;; End:


code:
;;; r6rs-control.test --- Test suite for R6RS (rnrs control)

;;      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-rnrs-records-procedural)
  :use-module ((rnrs conditions) :version (6))
  :use-module ((rnrs exceptions) :version (6))
  :use-module ((rnrs records inspection) :version (6))
  :use-module ((rnrs records procedural) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "record?"
  (pass-if "record? recognizes non-opaque records"
    (let* ((rec (make-record-type-descriptor 'rec #f #f #f #f '#()))
	   (make-rec (record-constructor
		      (make-record-constructor-descriptor rec #f #f))))
      (record? (make-rec))))

  (pass-if "record? doesn't recognize opaque records"
    (let* ((rec (make-record-type-descriptor 'rec #f #f #f #t '#()))
	   (make-rec (record-constructor
		      (make-record-constructor-descriptor rec #f #f))))
      (not (record? (make-rec)))))

  (pass-if "record? doesn't recognize non-records" (not (record? 'foo))))

(with-test-prefix "record-rtd"
  (pass-if "simple"
    (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #f '#()))
	   (make-rec (record-constructor
		      (make-record-constructor-descriptor rtd #f #f))))
      (eq? (record-rtd (make-rec)) rtd)))

  (pass-if "&assertion on opaque record"
    (let* ((rtd (make-record-type-descriptor 'rec #f #f #f #t '#()))
	   (make-rec (record-constructor
		      (make-record-constructor-descriptor rtd #f #f)))
	   (success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition)
	    (set! success (assertion-violation? condition))
	    (continuation))
	  (lambda () (record-rtd (make-rec))))))
      success)))

(with-test-prefix "record-type-name"
  (pass-if "simple"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
      (eq? (record-type-name rtd) 'foo))))

(with-test-prefix "record-type-parent"
  (pass-if "eq? to parent"
    (let* ((rtd-parent (make-record-type-descriptor 'foo #f #f #f #f '#()))
	   (rtd (make-record-type-descriptor 'bar rtd-parent #f #f #f '#())))
      (eq? (record-type-parent rtd) rtd-parent)))

  (pass-if "#f when parent not present"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
      (not (record-type-parent rtd)))))

(with-test-prefix "record-type-uid"
  (pass-if "eq? to uid"
    (let* ((uid (gensym))
	   (rtd (make-record-type-descriptor uid #f uid #f #f '#())))
      (eq? (record-type-uid rtd) uid)))

  (pass-if "#f when uid not present"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
      (not (record-type-uid rtd)))))

(with-test-prefix "record-type-generative?"
  (pass-if "#f when uid is not #f"
    (let* ((uid (gensym))
	   (rtd (make-record-type-descriptor uid #f uid #f #f '#())))
      (not (record-type-generative? rtd))))

  (pass-if "#t when uid is #f"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
      (record-type-generative? rtd))))

(with-test-prefix "record-type-sealed?"
  (pass-if "#t when sealed? is #t"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #t #f '#())))
      (record-type-sealed? rtd)))

  (pass-if "#f when sealed? is #f"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
      (not (record-type-sealed? rtd)))))

(with-test-prefix "record-type-opaque?"
  (pass-if "#t when opaque? is #t"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #t '#())))
      (record-type-opaque? rtd)))

  (pass-if "#f when opaque? is #f"
    (let* ((rtd (make-record-type-descriptor 'foo #f #f #f #f '#())))
      (not (record-type-opaque? rtd))))

  (pass-if "#t when parent is opaque"
    (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
	   (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f '#())))
      (record-type-opaque? rtd))))

(with-test-prefix "record-type-field-names"
  (pass-if "simple"
    (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
					     '#((immutable foo)
						(mutable bar)))))
      (equal? (record-type-field-names rtd) '#(foo bar))))

  (pass-if "parent fields not included"
    (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
						    '#((mutable foo))))
	   (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
					     '#((immutable bar)))))
      (equal? (record-type-field-names rtd) '#(bar))))

  (pass-if "subtype fields not included"
    (let* ((parent-rtd (make-record-type-descriptor 'foo #f #f #f #f
						    '#((mutable foo))))
	   (rtd (make-record-type-descriptor 'bar parent-rtd #f #f #f
					     '#((immutable bar)))))
      (equal? (record-type-field-names parent-rtd) '#(foo)))))

(with-test-prefix "record-field-mutable?"
  (pass-if "simple"
    (let* ((rtd (make-record-type-descriptor 'foobar #f #f #f #f
					     '#((mutable foo)
						(immutable bar)))))
      (and (record-field-mutable? rtd 0)
	   (not (record-field-mutable? rtd 1))))))


code:
;;; r6rs-records-procedural.test --- Test suite for R6RS
;;; (rnrs records procedural)

;;      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-rnrs-records-procedural)
  :use-module ((rnrs conditions) :version (6))
  :use-module ((rnrs exceptions) :version (6))
  :use-module ((rnrs records procedural) :version (6))
  :use-module (test-suite lib))

(define :point (make-record-type-descriptor
		'point #f #f #f #f '#((mutable x) (mutable y))))
(define :point-cd (make-record-constructor-descriptor :point #f #f))

(define :voxel (make-record-type-descriptor
		'voxel :point #f #f #f '#((mutable z))))
(define :voxel-cd (make-record-constructor-descriptor :voxel :point-cd #f))

(with-test-prefix "make-record-type-descriptor"
  (pass-if "simple"
    (let* ((:point-cd (make-record-constructor-descriptor :point #f #f))
	   (make-point (record-constructor :point-cd))
	   (point? (record-predicate :point))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1))
	   (point-x-set! (record-mutator :point 0))
	   (point-y-set! (record-mutator :point 1))
	   (p1 (make-point 1 2)))
      (point? p1)
      (eqv? (point-x p1) 1)
      (eqv? (point-y p1) 2)
      (unspecified? (point-x-set! p1 5))
      (eqv? (point-x p1) 5)))

  (pass-if "sealed records cannot be subtyped"
    (let* ((:sealed-point (make-record-type-descriptor
			   'sealed-point #f #f #t #f '#((mutable x)
							(mutable y))))
	   (success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition)
	    (set! success (assertion-violation? condition))
	    (continuation))
	  (lambda () (make-record-type-descriptor
		      'sealed-point-subtype :sealed-point #f #f #f
		      '#((mutable z)))))))
      success))

  (pass-if "non-generative records with same uid are eq"
    (let* ((:rtd-1 (make-record-type-descriptor
		    'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar))))
	   (:rtd-2 (make-record-type-descriptor
		    'rtd1 #f 'my-uid #f #f '#((mutable foo) (immutable bar)))))
       (eq? :rtd-1 :rtd-2)))

  (pass-if "&assertion raised on conflicting non-generative types"
    (let* ((:rtd-1 (make-record-type-descriptor
		    'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar))))
	   (success 0)
	   (check-definition
	    (lambda (thunk)
	      (call/cc
	       (lambda (continuation)
		 (with-exception-handler
		  (lambda (condition)
		    (if (assertion-violation? condition)
			(set! success (+ success 1)))
		    (continuation))
		  thunk))))))
      (check-definition
       (lambda ()
	 (make-record-type-descriptor
	  'rtd1a #f 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
      (check-definition
       (lambda ()
	 (make-record-type-descriptor
	  'rtd1 :point 'my-uid-2 #f #f '#((mutable foo) (immutable bar)))))
      (check-definition
       (lambda ()
	 (make-record-type-descriptor
	  'rtd1 #f 'my-uid-2 #t #f '#((mutable foo) (immutable bar)))))
      (check-definition
       (lambda ()
	 (make-record-type-descriptor
	  'rtd1 #f 'my-uid-2 #f #t '#((mutable foo) (immutable bar)))))
      (check-definition
       (lambda () (make-record-type-descriptor 'rtd1 #f 'my-uid-2 #f #f '#())))
      (check-definition
       (lambda ()
	 (make-record-type-descriptor
	  'rtd1 #f 'my-uid-2 #f #f '#((mutable foo) (immutable baz)))))
      (check-definition
       (lambda ()
	 (make-record-type-descriptor
	  'rtd1 #f 'my-uid-2 #f #f '#((immutable foo) (immutable bar)))))
      (eqv? success 7))))

(with-test-prefix "make-record-constructor-descriptor"
  (pass-if "simple protocol"
    (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
	   (:point-protocol-cd (make-record-constructor-descriptor
				:point #f :point-protocol))
	   (make-point (record-constructor :point-protocol-cd))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1))
	   (point (make-point 1 2)))
      (and (eqv? (point-x point) 2)
	   (eqv? (point-y point) 3))))

  (pass-if "protocol delegates to parent with protocol"
    (let* ((:point-protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1)))))
	   (:point-protocol-cd (make-record-constructor-descriptor
				:point #f :point-protocol))
	   (:voxel-protocol (lambda (n)
			      (lambda (x y z)
				(let ((p (n x y))) (p (+ z 100))))))
	   (:voxel-protocol-cd (make-record-constructor-descriptor
				:voxel :point-protocol-cd :voxel-protocol))
	   (make-voxel (record-constructor :voxel-protocol-cd))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1))
	   (voxel-z (record-accessor :voxel 0))
	   (voxel (make-voxel 1 2 3)))
      (and (eqv? (point-x voxel) 2)
	   (eqv? (point-y voxel) 3)
	   (eqv? (voxel-z voxel) 103)))))

(with-test-prefix "record-type-descriptor?"
  (pass-if "simple"
    (record-type-descriptor?
     (make-record-type-descriptor 'test #f #f #f #f '#()))))

(with-test-prefix "record-constructor"
  (pass-if "simple"
    (let* ((make-point (record-constructor :point-cd))
	   (point? (record-predicate :point))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1))
	   (point (make-point 1 2)))
      (and (point? point)
	   (eqv? (point-x point) 1)
	   (eqv? (point-y point) 2))))

  (pass-if "construct record subtype"
    (let* ((make-voxel (record-constructor :voxel-cd))
	   (voxel? (record-predicate :voxel))
	   (voxel-z (record-accessor :voxel 0))
	   (voxel (make-voxel 1 2 3)))
      (and (voxel? voxel)
	   (eqv? (voxel-z voxel) 3)))))

(with-test-prefix "record-predicate"
  (pass-if "simple"
    (let* ((make-point (record-constructor :point-cd))
	   (point (make-point 1 2))
	   (point? (record-predicate :point)))
      (point? point)))

  (pass-if "predicate returns true on subtype"
    (let* ((make-voxel (record-constructor :voxel-cd))
	   (voxel (make-voxel 1 2 3))
	   (point? (record-predicate :point)))
      (point? voxel)))

  (pass-if "predicate returns false on supertype"
    (let* ((make-point (record-constructor :point-cd))
	   (point (make-point 1 2))
	   (voxel? (record-predicate :voxel)))
      (not (voxel? point)))))

(with-test-prefix "record-accessor"
  (pass-if "simple"
    (let* ((make-point (record-constructor :point-cd))
	   (point (make-point 1 2))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1)))
      (and (eqv? (point-x point) 1)
	   (eqv? (point-y point) 2))))

  (pass-if "accessor for supertype applied to subtype"
    (let* ((make-voxel (record-constructor :voxel-cd))
	   (voxel (make-voxel 1 2 3))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1)))
      (and (eqv? (point-x voxel) 1)
	   (eqv? (point-y voxel) 2)))))

(with-test-prefix "record-mutator"
  (pass-if "simple"
    (let* ((make-point (record-constructor :point-cd))
	   (point (make-point 1 2))
	   (point-set-x! (record-mutator :point 0))
	   (point-set-y! (record-mutator :point 1))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1)))
      (point-set-x! point 3)
      (point-set-y! point 4)
      (and (eqv? (point-x point) 3)
	   (eqv? (point-y point) 4))))

  (pass-if "&assertion raised on request for immutable field"
    (let* ((:immutable-point (make-record-type-descriptor
			      'point #f #f #f #f '#((immutable x)
						    (immutable y))))
	   (success #f))
      (call/cc
       (lambda (continuation)
	 (with-exception-handler
	  (lambda (condition)
	    (set! success (assertion-violation? condition))
	    (continuation))
	  (lambda () (record-mutator :immutable-point 0)))))
      success))

  (pass-if "mutator for supertype applied to subtype"
    (let* ((make-voxel (record-constructor :voxel-cd))
	   (voxel (make-voxel 1 2 3))
	   (point-set-x! (record-mutator :point 0))
	   (point-set-y! (record-mutator :point 1))
	   (point-x (record-accessor :point 0))
	   (point-y (record-accessor :point 1)))
      (point-set-x! voxel 3)
      (point-set-y! voxel 4)
      (and (eqv? (point-x voxel) 3)
	   (eqv? (point-y voxel) 4)))))


code:
;;; -*- scheme -*-
;;; r6rs-records-syntactic.test --- Test suite for R6RS (rnrs records syntactic)

;;      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-rnrs-records-syntactic)
  :use-module ((rnrs records syntactic) :version (6))
  :use-module ((rnrs records procedural) :version (6))
  :use-module ((rnrs records inspection) :version (6))
  :use-module (test-suite lib))

(define-record-type simple-rtd)
(define-record-type
  (specified-rtd specified-rtd-constructor specified-rtd-predicate))
(define-record-type parent-rtd (fields x y))
(define-record-type child-parent-rtd-rtd
  (parent-rtd (record-type-descriptor parent-rtd)
	      (record-constructor-descriptor parent-rtd))
  (fields z))
(define-record-type child-parent-rtd (parent parent-rtd) (fields z))
(define-record-type mutable-fields-rtd
  (fields (mutable mutable-bar)
	  (mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
(define-record-type immutable-fields-rtd
  (fields immutable-foo
	  (immutable immutable-bar)
	  (immutable immutable-baz immutable-baz-accessor)))
(define-record-type protocol-rtd
  (fields (immutable x) (immutable y))
  (protocol (lambda (p) (lambda (x y) (p (+ x 1) (+ y 1))))))
(define-record-type sealed-rtd (sealed #t))
(define-record-type opaque-rtd (opaque #t))
(define-record-type nongenerative-rtd (nongenerative))
(define-record-type nongenerative-uid-rtd (nongenerative foo))

(with-test-prefix "simple record names"
  (pass-if "define-record-type defines record type"
    (defined? 'simple-rtd))

  (pass-if "define-record-type defines record predicate"
    (defined? 'simple-rtd?))

  (pass-if "define-record-type defines record-constructor"
    (defined? 'make-simple-rtd)))

(with-test-prefix "fully-specified record names"
  (pass-if "define-record-type defines named predicate"
    (defined? 'specified-rtd-predicate))

  (pass-if "define-record-type defines named constructor"
    (defined? 'specified-rtd-constructor)))

(pass-if "parent-rtd clause includes specified parent"
  (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd))

(pass-if "parent clause includes specified parent"
  (eq? (record-type-parent child-parent-rtd) parent-rtd))

(pass-if "protocol clause includes specified protocol"
  (let ((protocol-record (make-protocol-rtd 1 2)))
    (and (eqv? (protocol-rtd-x protocol-record) 2)
	 (eqv? (protocol-rtd-y protocol-record) 3))))

(pass-if "sealed clause produces sealed type"
  (record-type-sealed? sealed-rtd))

(pass-if "opaque clause produces opaque type"
  (record-type-opaque? opaque-rtd))

(with-test-prefix "nongenerative"
  (pass-if "nongenerative clause produces nongenerative type"
    (not (record-type-generative? nongenerative-rtd)))

  (pass-if "nongenerative clause preserves specified uid"
    (and (not (record-type-generative? nongenerative-uid-rtd))
	 (eq? (record-type-uid nongenerative-uid-rtd) 'foo))))

(with-test-prefix "fields"
  (pass-if "raw symbol produces accessor only"
    (and (defined? 'immutable-fields-rtd-immutable-foo)
	 (not (defined? 'immutable-fields-rtd-immutable-foo-set!))))

  (pass-if "(immutable x) form produces accessor only"
    (and (defined? 'immutable-fields-rtd-immutable-bar)
	 (not (defined? 'immutable-fields-rtd-immutable-bar-set!))))

  (pass-if "(immutable x y) form produces named accessor"
    (defined? 'immutable-baz-accessor))

  (pass-if "(mutable x) form produces accessor and mutator"
    (and (defined? 'mutable-fields-rtd-mutable-bar)
	 (defined? 'mutable-fields-rtd-mutable-bar-set!)))

  (pass-if "(mutable x y) form produces named accessor and mutator"
    (and (defined? 'mutable-baz-accessor)
	 (defined? 'mutable-baz-mutator))))

(pass-if "record-type-descriptor returns rtd"
  (eq? (record-type-descriptor simple-rtd) simple-rtd))

(pass-if "record-constructor-descriptor returns rcd"
  (procedure? (record-constructor (record-constructor-descriptor simple-rtd))))


code:
;;; r6rs-unicode.test --- Test suite for R6RS (rnrs unicode)

;;      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-rnrs-unicode)
  :use-module ((rnrs unicode) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "char-foldcase"
  (pass-if "basic case folding"
    (and (eqv? (char-foldcase #\i) #\i)
    	 (eqv? (char-foldcase #\337) #\337)
	 (eqv? (char-foldcase #\1643) #\1703)
	 (eqv? (char-foldcase #\1702) #\1703)))

  (pass-if "Turkic characters"
    (and (eqv? (char-foldcase #\460) #\460)
    	 (eqv? (char-foldcase #\461) #\461))))

(with-test-prefix "char-title-case?"
  (pass-if "simple"
    (and (not (char-title-case? #\I))
	 (char-title-case? #\705))))

(with-test-prefix "string-foldcase"
  (pass-if "basic case folding"
    (and (equal? (string-foldcase "Hi") "hi")
	 (equal? (string-foldcase
		  (list->string '(#\1647 #\1621 #\1637 #\1643 #\1643)))
		 (list->string '(#\1707 #\1661 #\1677 #\1703 #\1703)))))

  (pass-if "case folding expands string"
    (or (equal? (string-foldcase (list->string '(#\S #\t #\r #\a #\337 #\e)))
		"strasse")
	(throw 'unresolved))))


code:
;;;; ramap.test --- test array mapping functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 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-ramap)
  #:use-module (test-suite lib))

;;;
;;; array-index-map!
;;;

(with-test-prefix "array-index-map!"

  (pass-if (let ((nlst '()))
	     (array-index-map! (make-array #f '(1 1))
			       (lambda (n)
				 (set! nlst (cons n nlst))))
	     (equal? nlst '(1)))))

;;;
;;; array-map!
;;;

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

  (pass-if-exception "no args" exception:wrong-num-args
    (array-map!))

  (pass-if-exception "one arg" exception:wrong-num-args
    (array-map! (make-array #f 5)))

  (with-test-prefix "no sources"

    (pass-if "closure 0"
      (array-map! (make-array #f 5) (lambda () #f))
      #t)

    (pass-if-exception "closure 1" exception:wrong-num-args
      (array-map! (make-array #f 5) (lambda (x) #f)))

    (pass-if-exception "closure 2" exception:wrong-num-args
      (array-map! (make-array #f 5) (lambda (x y) #f)))

    (pass-if-exception "subr_1" exception:wrong-num-args
      (array-map! (make-array #f 5) length))

    (pass-if-exception "subr_2" exception:wrong-num-args
      (array-map! (make-array #f 5) logtest))

    (pass-if-exception "subr_2o" exception:wrong-num-args
      (array-map! (make-array #f 5) number->string))

    (pass-if-exception "dsubr" exception:wrong-num-args
      (array-map! (make-array #f 5) sqrt))

    (pass-if "rpsubr"
      (let ((a (make-array 'foo 5)))
	(array-map! a =)
	(equal? a (make-array #t 5))))

    (pass-if "asubr"
      (let ((a (make-array 'foo 5)))
	(array-map! a +)
	(equal? a (make-array 0 5))))

    ;; in Guile 1.6.4 and earlier this resulted in a segv
    (pass-if "noop"
      (array-map! (make-array #f 5) noop)
      #t))

  (with-test-prefix "one source"

    (pass-if-exception "closure 0" exception:wrong-num-args
      (array-map! (make-array #f 5) (lambda () #f)
		  (make-array #f 5)))

    (pass-if "closure 1"
      (let ((a (make-array #f 5)))
	(array-map! a (lambda (x) 'foo) (make-array #f 5))
	(equal? a (make-array 'foo 5))))

    (pass-if-exception "closure 2" exception:wrong-num-args
      (array-map! (make-array #f 5) (lambda (x y) #f)
		  (make-array #f 5)))

    (pass-if "subr_1"
      (let ((a (make-array #f 5)))
	(array-map! a length (make-array '(x y z) 5))
	(equal? a (make-array 3 5))))

    (pass-if-exception "subr_2" exception:wrong-num-args
      (array-map! (make-array #f 5) logtest
		  (make-array 999 5)))

    (pass-if "subr_2o"
      (let ((a (make-array #f 5)))
	(array-map! a number->string (make-array 99 5))
	(equal? a (make-array "99" 5))))

    (pass-if "dsubr"
      (let ((a (make-array #f 5)))
	(array-map! a sqrt (make-array 16.0 5))
	(equal? a (make-array 4.0 5))))

    (pass-if "rpsubr"
      (let ((a (make-array 'foo 5)))
	(array-map! a = (make-array 0 5))
	(equal? a (make-array #t 5))))

    (pass-if "asubr"
      (let ((a (make-array 'foo 5)))
	(array-map! a - (make-array 99 5))
	(equal? a (make-array -99 5))))

    ;; in Guile 1.6.5 and 1.6.6 this was an error
    (pass-if "1+"
      (let ((a (make-array #f 5)))
	(array-map! a 1+ (make-array 123 5))
	(equal? a (make-array 124 5)))))

  (with-test-prefix "two sources"

    (pass-if-exception "closure 0" exception:wrong-num-args
      (array-map! (make-array #f 5) (lambda () #f)
		  (make-array #f 5) (make-array #f 5)))

    (pass-if-exception "closure 1" exception:wrong-num-args
      (array-map! (make-array #f 5) (lambda (x) #f)
		  (make-array #f 5) (make-array #f 5)))

    (pass-if "closure 2"
      (let ((a (make-array #f 5)))
	(array-map! a (lambda (x y) 'foo)
		    (make-array #f 5) (make-array #f 5))
	(equal? a (make-array 'foo 5))))

    (pass-if-exception "subr_1" exception:wrong-num-args
      (array-map! (make-array #f 5) length
		  (make-array #f 5) (make-array #f 5)))

    (pass-if "subr_2"
      (let ((a (make-array 'foo 5)))
	(array-map! a logtest
		    (make-array 999 5) (make-array 999 5))
	(equal? a (make-array #t 5))))

    (pass-if "subr_2o"
      (let ((a (make-array #f 5)))
	(array-map! a number->string
		    (make-array 32 5) (make-array 16 5))
	(equal? a (make-array "20" 5))))

    (pass-if-exception "dsubr" exception:wrong-num-args
      (let ((a (make-array #f 5)))
	(array-map! a sqrt
		    (make-array 16.0 5) (make-array 16.0 5))
	(equal? a (make-array 4.0 5))))

    (pass-if "rpsubr"
      (let ((a (make-array 'foo 5)))
	(array-map! a = (make-array 99 5) (make-array 77 5))
	(equal? a (make-array #f 5))))

    (pass-if "asubr"
      (let ((a (make-array 'foo 5)))
	(array-map! a - (make-array 99 5) (make-array 11 5))
	(equal? a (make-array 88 5))))

    (pass-if "+"
      (let ((a (make-array #f 4)))
	(array-map! a + #(1 2 3 4) #(5 6 7 8))
	(equal? a #(6 8 10 12))))))