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

(use-modules (srfi srfi-4)
	     (test-suite lib))

(with-test-prefix "u8 vectors"

  (pass-if "u8vector? success"
    (u8vector? (u8vector)))

  (pass-if "u8vector? failure"
    (not (u8vector? (s8vector))))

  (pass-if "u8vector-length success 1"
    (= (u8vector-length (u8vector)) 0))

  (pass-if "u8vector-length success 2"
    (= (u8vector-length (u8vector 3)) 1))

  (pass-if "u8vector-length failure"
    (not (= (u8vector-length (u8vector 3)) 3)))

  (pass-if "u8vector-ref"
    (= (u8vector-ref (u8vector 1 2 3) 1) 2))

  (pass-if "u8vector-set!/ref"
    (= (let ((s (make-u8vector 10 0)))
	 (u8vector-set! s 4 33)
	 (u8vector-ref s 4)) 33))

  (pass-if "u8vector->list/list->u8vector"
    (equal? (u8vector->list (u8vector 1 2 3 4))
	    (u8vector->list (list->u8vector '(1 2 3 4))))))

(with-test-prefix "s8 vectors"

  (pass-if "s8vector? success"
    (s8vector? (s8vector)))

  (pass-if "s8vector? failure"
    (not (s8vector? (u8vector))))

  (pass-if "s8vector-length success 1"
    (= (s8vector-length (s8vector)) 0))

  (pass-if "s8vector-length success 2"
    (= (s8vector-length (s8vector -3)) 1))

  (pass-if "s8vector-length failure"
    (not (= (s8vector-length (s8vector 3)) 3)))

  (pass-if "s8vector-ref"
    (= (s8vector-ref (s8vector 1 2 3) 1) 2))

  (pass-if "s8vector-set!/ref"
    (= (let ((s (make-s8vector 10 0)))
	 (s8vector-set! s 4 33)
	 (s8vector-ref s 4)) 33))

  (pass-if "s8vector->list/list->s8vector"
    (equal? (s8vector->list (s8vector 1 2 3 4))
	    (s8vector->list (list->s8vector '(1 2 3 4))))))

(with-test-prefix "u16 vectors"

  (pass-if "u16vector? success"
    (u16vector? (u16vector)))

  (pass-if "u16vector? failure"
    (not (u16vector? (s16vector))))

  (pass-if "u16vector-length success 1"
    (= (u16vector-length (u16vector)) 0))

  (pass-if "u16vector-length success 2"
    (= (u16vector-length (u16vector 3)) 1))

  (pass-if "u16vector-length failure"
    (not (= (u16vector-length (u16vector 3)) 3)))

  (pass-if "u16vector-ref"
    (= (u16vector-ref (u16vector 1 2 3) 1) 2))

  (pass-if "u16vector-set!/ref"
    (= (let ((s (make-u16vector 10 0)))
	 (u16vector-set! s 4 33)
	 (u16vector-ref s 4)) 33))

  (pass-if "u16vector->list/list->u16vector"
    (equal? (u16vector->list (u16vector 1 2 3 4))
	    (u16vector->list (list->u16vector '(1 2 3 4))))))

(with-test-prefix "s16 vectors"

  (pass-if "s16vector? success"
    (s16vector? (s16vector)))

  (pass-if "s16vector? failure"
    (not (s16vector? (u16vector))))

  (pass-if "s16vector-length success 1"
    (= (s16vector-length (s16vector)) 0))

  (pass-if "s16vector-length success 2"
    (= (s16vector-length (s16vector -3)) 1))

  (pass-if "s16vector-length failure"
    (not (= (s16vector-length (s16vector 3)) 3)))

  (pass-if "s16vector-ref"
    (= (s16vector-ref (s16vector 1 2 3) 1) 2))

  (pass-if "s16vector-set!/ref"
    (= (let ((s (make-s16vector 10 0)))
	 (s16vector-set! s 4 33)
	 (s16vector-ref s 4)) 33))

  (pass-if "s16vector->list/list->s16vector"
    (equal? (s16vector->list (s16vector 1 2 3 4))
	    (s16vector->list (list->s16vector '(1 2 3 4))))))

(with-test-prefix "u32 vectors"

  (pass-if "u32vector? success"
    (u32vector? (u32vector)))

  (pass-if "u32vector? failure"
    (not (u32vector? (s32vector))))

  (pass-if "u32vector-length success 1"
    (= (u32vector-length (u32vector)) 0))

  (pass-if "u32vector-length success 2"
    (= (u32vector-length (u32vector 3)) 1))

  (pass-if "u32vector-length failure"
    (not (= (u32vector-length (u32vector 3)) 3)))

  (pass-if "u32vector-ref"
    (= (u32vector-ref (u32vector 1 2 3) 1) 2))

  (pass-if "u32vector-set!/ref"
    (= (let ((s (make-u32vector 10 0)))
	 (u32vector-set! s 4 33)
	 (u32vector-ref s 4)) 33))

  (pass-if "u32vector->list/list->u32vector"
    (equal? (u32vector->list (u32vector 1 2 3 4))
	    (u32vector->list (list->u32vector '(1 2 3 4))))))

(with-test-prefix "s32 vectors"

  (pass-if "s32vector? success"
    (s32vector? (s32vector)))

  (pass-if "s32vector? failure"
    (not (s32vector? (u32vector))))

  (pass-if "s32vector-length success 1"
    (= (s32vector-length (s32vector)) 0))

  (pass-if "s32vector-length success 2"
    (= (s32vector-length (s32vector -3)) 1))

  (pass-if "s32vector-length failure"
    (not (= (s32vector-length (s32vector 3)) 3)))

  (pass-if "s32vector-ref"
    (= (s32vector-ref (s32vector 1 2 3) 1) 2))

  (pass-if "s32vector-set!/ref"
    (= (let ((s (make-s32vector 10 0)))
	 (s32vector-set! s 4 33)
	 (s32vector-ref s 4)) 33))

  (pass-if "s32vector->list/list->s32vector"
    (equal? (s32vector->list (s32vector 1 2 3 4))
	    (s32vector->list (list->s32vector '(1 2 3 4))))))

(with-test-prefix "u64 vectors"

  (pass-if "u64vector? success"
    (u64vector? (u64vector)))

  (pass-if "u64vector? failure"
    (not (u64vector? (s64vector))))

  (pass-if "u64vector-length success 1"
    (= (u64vector-length (u64vector)) 0))

  (pass-if "u64vector-length success 2"
    (= (u64vector-length (u64vector 3)) 1))

  (pass-if "u64vector-length failure"
    (not (= (u64vector-length (u64vector 3)) 3)))

  (pass-if "u64vector-ref"
    (= (u64vector-ref (u64vector 1 2 3) 1) 2))

  (pass-if "u64vector-set!/ref"
    (= (let ((s (make-u64vector 10 0)))
	 (u64vector-set! s 4 33)
	 (u64vector-ref s 4)) 33))

  (pass-if "u64vector->list/list->u64vector"
    (equal? (u64vector->list (u64vector 1 2 3 4))
	    (u64vector->list (list->u64vector '(1 2 3 4))))))

(with-test-prefix "s64 vectors"

  (pass-if "s64vector? success"
    (s64vector? (s64vector)))

  (pass-if "s64vector? failure"
    (not (s64vector? (u64vector))))

  (pass-if "s64vector-length success 1"
    (= (s64vector-length (s64vector)) 0))

  (pass-if "s64vector-length success 2"
    (= (s64vector-length (s64vector -3)) 1))

  (pass-if "s64vector-length failure"
    (not (= (s64vector-length (s64vector 3)) 3)))

  (pass-if "s64vector-ref"
    (= (s64vector-ref (s64vector 1 2 3) 1) 2))

  (pass-if "s64vector-set!/ref"
    (= (let ((s (make-s64vector 10 0)))
	 (s64vector-set! s 4 33)
	 (s64vector-ref s 4)) 33))

  (pass-if "s64vector->list/list->s64vector"
    (equal? (s64vector->list (s64vector 1 2 3 4))
	    (s64vector->list (list->s64vector '(1 2 3 4))))))

(with-test-prefix "f32 vectors"

  (pass-if "f32vector? success"
    (f32vector? (f32vector)))

  (pass-if "f32vector? failure"
    (not (f32vector? (s8vector))))

  (pass-if "f32vector-length success 1"
    (= (f32vector-length (f32vector)) 0))

  (pass-if "f32vector-length success 2"
    (= (f32vector-length (f32vector -3)) 1))

  (pass-if "f32vector-length failure"
    (not (= (f32vector-length (f32vector 3)) 3)))

  (pass-if "f32vector-ref"
    (= (f32vector-ref (f32vector 1 2 3) 1) 2))

  (pass-if "f32vector-set!/ref"
    (= (let ((s (make-f32vector 10 0)))
	 (f32vector-set! s 4 33)
	 (f32vector-ref s 4)) 33))

  (pass-if "f32vector->list/list->f32vector"
    (equal? (f32vector->list (f32vector 1 2 3 4))
	    (f32vector->list (list->f32vector '(1 2 3 4))))))

(with-test-prefix "f64 vectors"

  (pass-if "f64vector? success"
    (f64vector? (f64vector)))

  (pass-if "f64vector? failure"
    (not (f64vector? (f32vector))))

  (pass-if "f64vector-length success 1"
    (= (f64vector-length (f64vector)) 0))

  (pass-if "f64vector-length success 2"
    (= (f64vector-length (f64vector -3)) 1))

  (pass-if "f64vector-length failure"
    (not (= (f64vector-length (f64vector 3)) 3)))

  (pass-if "f64vector-ref"
    (= (f64vector-ref (f64vector 1 2 3) 1) 2))

  (pass-if "f64vector-set!/ref"
    (= (let ((s (make-f64vector 10 0)))
	 (f64vector-set! s 4 33)
	 (f64vector-ref s 4)) 33))

  (pass-if "f64vector->list/list->f64vector"
    (equal? (f64vector->list (f64vector 1 2 3 4))
	    (f64vector->list (list->f64vector '(1 2 3 4))))))


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

(use-modules (test-suite lib))

;; use #:select to see that the bindings we expect are indeed exported
(use-modules ((srfi srfi-6)
	      #:select ((open-input-string  . open-input-string)
			(open-output-string . open-output-string)
			(get-output-string  . get-output-string))))

(with-test-prefix "open-input-string"

  (pass-if "eof on empty"
    (let ((port (open-input-string "")))
      (eof-object? (read-char port))))

  (pass-if "read-char"
    (let ((port (open-input-string "xyz")))
      (and (char=? #\x (read-char port))
	   (char=? #\y (read-char port))
	   (char=? #\z (read-char port))
	   (eof-object? (read-char port)))))

  (with-test-prefix "unread-char"

    (pass-if "one char"
      (let ((port (open-input-string "")))
	(unread-char #\x port)
	(and (char=? #\x (read-char port))
	     (eof-object? (read-char port)))))

    (pass-if "after eof"
      (let ((port (open-input-string "")))
	(and (eof-object? (read-char port))
	     (begin
	       (unread-char #\x port)
	       (and (char=? #\x (read-char port))
		    (eof-object? (read-char port)))))))

    (pass-if "order"
      (let ((port (open-input-string "")))
	(unread-char #\x port)
	(unread-char #\y port)
	(unread-char #\z port)
	(and (char=? #\z (read-char port))
	     (char=? #\y (read-char port))
	     (char=? #\x (read-char port))
	     (eof-object? (read-char port)))))))

(with-test-prefix "open-output-string"

  (pass-if "empty"
    (let ((port (open-output-string)))
      (string=? "" (get-output-string port))))

  (pass-if "xyz"
    (let ((port (open-output-string)))
      (display "xyz" port)
      (string=? "xyz" (get-output-string port))))

  (pass-if "seek"
    (let ((port (open-output-string)))
      (display "abcdef" port)
      (seek port 2 SEEK_SET)
      (display "--" port)
      (string=? "ab--ef" (get-output-string port)))))

license: unknown


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

(define-module (test-srfi-60)
  #:duplicates (last)  ;; avoid warning about srfi-60 replacing `bit-count'
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-60))

(pass-if "cond-expand srfi-60"
  (cond-expand (srfi-60 #t)
	       (else    #f)))

;;
;; logand
;;

(with-test-prefix "logand"
  (pass-if (eqv? 6 (logand 14 6))))

;;
;; bitwise-and
;;

(with-test-prefix "bitwise-and"
  (pass-if (eqv? 6 (bitwise-and 14 6))))

;;
;; logior
;;

(with-test-prefix "logior"
  (pass-if (eqv? 14 (logior 10 12))))

;;
;; bitwise-ior
;;

(with-test-prefix "bitwise-ior"
  (pass-if (eqv? 14 (bitwise-ior 10 12))))

;;
;; logxor
;;

(with-test-prefix "logxor"
  (pass-if (eqv? 6 (logxor 10 12))))

;;
;; bitwise-xor
;;

(with-test-prefix "bitwise-xor"
  (pass-if (eqv? 6 (bitwise-xor 10 12))))

;;
;; lognot
;;

(with-test-prefix "lognot"
  (pass-if (eqv? -1 (lognot 0)))
  (pass-if (eqv? 0 (lognot -1))))

;;
;; bitwise-not
;;

(with-test-prefix "bitwise-not"
  (pass-if (eqv? -1 (bitwise-not 0)))
  (pass-if (eqv? 0 (bitwise-not -1))))

;;
;; bitwise-if
;;

(with-test-prefix "bitwise-if"
  (pass-if (eqv? 9 (bitwise-if 3 1 8)))
  (pass-if (eqv? 0 (bitwise-if 3 8 1))))

;;
;; bitwise-merge
;;

(with-test-prefix "bitwise-merge"
  (pass-if (eqv? 9 (bitwise-merge 3 1 8)))
  (pass-if (eqv? 0 (bitwise-merge 3 8 1))))

;;
;; logtest
;;

(with-test-prefix "logtest"
  (pass-if (eq? #t (logtest 3 6)))
  (pass-if (eq? #f (logtest 3 12))))

;;
;; any-bits-set?
;;

(with-test-prefix "any-bits-set?"
  (pass-if (eq? #t (any-bits-set? 3 6)))
  (pass-if (eq? #f (any-bits-set? 3 12))))

;;
;; logcount
;;

(with-test-prefix "logcount"
  (pass-if (eqv? 2 (logcount 12))))

;;
;; bit-count
;;

(with-test-prefix "bit-count"
  (pass-if (eqv? 2 (bit-count 12))))

;;
;; integer-length
;;

(with-test-prefix "integer-length"
  (pass-if (eqv? 0 (integer-length 0)))
  (pass-if (eqv? 8 (integer-length 128)))
  (pass-if (eqv? 8 (integer-length 255)))
  (pass-if (eqv? 9 (integer-length 256))))

;;
;; log2-binary-factors
;;

(with-test-prefix "log2-binary-factors"
  (pass-if (eqv? -1 (log2-binary-factors 0)))
  (pass-if (eqv? 0 (log2-binary-factors 1)))
  (pass-if (eqv? 0 (log2-binary-factors 3)))
  (pass-if (eqv? 2 (log2-binary-factors 4)))
  (pass-if (eqv? 1 (log2-binary-factors 6)))
  (pass-if (eqv? 0 (log2-binary-factors -1)))
  (pass-if (eqv? 1 (log2-binary-factors -2)))
  (pass-if (eqv? 0 (log2-binary-factors -3)))
  (pass-if (eqv? 2 (log2-binary-factors -4)))
  (pass-if (eqv? 128 (log2-binary-factors #x100000000000000000000000000000000))))

;;
;; first-set-bit
;;

(with-test-prefix "first-set-bit"
  (pass-if (eqv? -1 (first-set-bit 0)))
  (pass-if (eqv? 0 (first-set-bit 1)))
  (pass-if (eqv? 0 (first-set-bit 3)))
  (pass-if (eqv? 2 (first-set-bit 4)))
  (pass-if (eqv? 1 (first-set-bit 6)))
  (pass-if (eqv? 0 (first-set-bit -1)))
  (pass-if (eqv? 1 (first-set-bit -2)))
  (pass-if (eqv? 0 (first-set-bit -3)))
  (pass-if (eqv? 2 (first-set-bit -4))))

;;
;; logbit?
;;

(with-test-prefix "logbit?"
  (pass-if (eq? #t (logbit? 0 1)))
  (pass-if (eq? #f (logbit? 1 1)))
  (pass-if (eq? #f (logbit? 1 8)))
  (pass-if (eq? #t (logbit? 1000 -1))))

;;
;; bit-set?
;;

(with-test-prefix "bit-set?"
  (pass-if (eq? #t (bit-set? 0 1)))
  (pass-if (eq? #f (bit-set? 1 1)))
  (pass-if (eq? #f (bit-set? 1 8)))
  (pass-if (eq? #t (bit-set? 1000 -1))))

;;
;; copy-bit
;;

(with-test-prefix "copy-bit"
  (pass-if (eqv? 0 (copy-bit 0 0 #f)))
  (pass-if (eqv? 0 (copy-bit 30 0 #f)))
  (pass-if (eqv? 0 (copy-bit 31 0 #f)))
  (pass-if (eqv? 0 (copy-bit 62 0 #f)))
  (pass-if (eqv? 0 (copy-bit 63 0 #f)))
  (pass-if (eqv? 0 (copy-bit 128 0 #f)))

  (pass-if (eqv? -1 (copy-bit 0 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 30 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 31 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 62 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 63 -1 #t)))
  (pass-if (eqv? -1 (copy-bit 128 -1 #t)))

  (pass-if (eqv? 1 (copy-bit 0 0 #t)))
  (pass-if (eqv? #x106 (copy-bit 8 6 #t)))
  (pass-if (eqv? 6 (copy-bit 8 6 #f)))
  (pass-if (eqv? -2 (copy-bit 0 -1 #f)))

  (pass-if "bignum becomes inum"
    (eqv? 0 (copy-bit 128 #x100000000000000000000000000000000 #f)))

  ;; bignums unchanged
  (pass-if (eqv? #x100000000000000000000000000000000
		 (copy-bit 128 #x100000000000000000000000000000000 #t)))
  (pass-if (eqv? #x100000000000000000000000000000000
		 (copy-bit 64 #x100000000000000000000000000000000 #f)))
  (pass-if (eqv? #x-100000000000000000000000000000000
		 (copy-bit 64 #x-100000000000000000000000000000000 #f)))
  (pass-if (eqv? #x-100000000000000000000000000000000
		 (copy-bit 256 #x-100000000000000000000000000000000 #t))))

;;
;; bit-field
;;

(with-test-prefix "bit-field"
  (pass-if (eqv? 0 (bit-field 6 0 1)))
  (pass-if (eqv? 3 (bit-field 6 1 3)))
  (pass-if (eqv? 1 (bit-field 6 2 999)))
  (pass-if (eqv? 1 (bit-field #x100000000000000000000000000000000 128 129))))

;;
;; copy-bit-field
;;

(with-test-prefix "copy-bit-field"
  (pass-if (eqv? #b111 (copy-bit-field #b110 1 0 1)))
  (pass-if (eqv? #b110 (copy-bit-field #b110 1 1 2)))
  (pass-if (eqv? #b010 (copy-bit-field #b110 1 1 3))))

;;
;; ash
;;

(with-test-prefix "ash"
  (pass-if (eqv? 2 (ash 1 1)))
  (pass-if (eqv? 0 (ash 1 -1))))

;;
;; arithmetic-shift
;;

(with-test-prefix "arithmetic-shift"
  (pass-if (eqv? 2 (arithmetic-shift 1 1)))
  (pass-if (eqv? 0 (arithmetic-shift 1 -1))))

;;
;; rotate-bit-field
;;

(with-test-prefix "rotate-bit-field"
  (pass-if (eqv? #b110  (rotate-bit-field #b110 1 1 2)))
  (pass-if (eqv? #b1010 (rotate-bit-field #b110 1 2 4)))
  (pass-if (eqv? #b1011 (rotate-bit-field #b0111 -1 1 4)))

  (pass-if (eqv? #b0  (rotate-bit-field #b0 128 0 256)))
  (pass-if (eqv? #b1  (rotate-bit-field #b1 128 1 256)))
  (pass-if
      (eqv? #x100000000000000000000000000000000
	    (rotate-bit-field #x100000000000000000000000000000000 128 0 64)))
  (pass-if
      (eqv? #x100000000000000000000000000000008
	    (rotate-bit-field #x100000000000000000000000000000001 3 0 64)))
  (pass-if
      (eqv? #x100000000000000002000000000000000
	    (rotate-bit-field #x100000000000000000000000000000001 -3 0 64)))

  (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 10)))
  (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 256)))

  (pass-if "bignum becomes inum"
    (eqv? 1 (rotate-bit-field #x100000000000000000000000000000000 1 0 129))))

;;
;; reverse-bit-field
;;

(with-test-prefix "reverse-bit-field"
  (pass-if (eqv? 6 (reverse-bit-field 6 1 3)))
  (pass-if (eqv? 12 (reverse-bit-field 6 1 4)))

  (pass-if (eqv? #x80000000 (reverse-bit-field 1 0 32)))
  (pass-if (eqv? #x40000000 (reverse-bit-field 1 0 31)))
  (pass-if (eqv? #x20000000 (reverse-bit-field 1 0 30)))

  (pass-if (eqv? (logior (ash -1 32) #xFBFFFFFF)
		 (reverse-bit-field -2 0 27)))
  (pass-if (eqv? (logior (ash -1 32) #xF7FFFFFF)
		 (reverse-bit-field -2 0 28)))
  (pass-if (eqv? (logior (ash -1 32) #xEFFFFFFF)
		 (reverse-bit-field -2 0 29)))
  (pass-if (eqv? (logior (ash -1 32) #xDFFFFFFF)
		 (reverse-bit-field -2 0 30)))
  (pass-if (eqv? (logior (ash -1 32) #xBFFFFFFF)
		 (reverse-bit-field -2 0 31)))
  (pass-if (eqv? (logior (ash -1 32) #x7FFFFFFF)
		 (reverse-bit-field -2 0 32)))

  (pass-if "bignum becomes inum"
    (eqv? 5 (reverse-bit-field #x140000000000000000000000000000000 0 129))))

;;
;; integer->list
;;

(with-test-prefix "integer->list"
  (pass-if (equal? '(#t #t #f) (integer->list 6)))
  (pass-if (equal? '(#f #t #t #f) (integer->list 6 4)))
  (pass-if (equal? '(#t #f) (integer->list 6 2)))

  (pass-if "zeros above top of positive inum"
    (equal? '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
	    (integer->list 1 128)))

  (pass-if "ones above top of negative inum"
    (equal? '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
		 #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)
	    (integer->list -1 128)))

  (pass-if (equal? '(#t
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
		   (integer->list #x100000000000000000000000000000000))))

;;
;; list->integer
;;

(with-test-prefix "list->integer"
  (pass-if (eqv? 6 (list->integer '(#t #t #f))))
  (pass-if (eqv? 6 (list->integer '(#f #t #t #f))))
  (pass-if (eqv? 2 (list->integer '(#t #f))))

  (pass-if "leading #f's"
    (eqv? 1 (list->integer
	     '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		  #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t))))

  (pass-if (eqv? #x100000000000000000000000000000000
		 (list->integer
		  '(#t
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
		    #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))))

  (pass-if (eqv? #x03FFFFFF (list->integer '(#t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x07FFFFFF (list->integer '(#t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x0FFFFFFF (list->integer '(#t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x1FFFFFFF (list->integer '(#t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x3FFFFFFF (list->integer '(#t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x7FFFFFFF (list->integer '(#t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #xFFFFFFFF (list->integer '(#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t
						#t #t #t #t #t #t #t #t))))
  (pass-if (eqv? #x1FFFFFFFF (list->integer '(#t
					      #t #t #t #t #t #t #t #t
					      #t #t #t #t #t #t #t #t
					      #t #t #t #t #t #t #t #t
					      #t #t #t #t #t #t #t #t)))))

;;
;; list->integer
;;

(with-test-prefix "list->integer"
  (pass-if (eqv? 0 (booleans->integer)))
  (pass-if (eqv? 6 (booleans->integer #t #t #f))))


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

(define-module (test-srfi-69)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-69)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26))

(define (string-ci-assoc-equal? left right)
  "Answer whether LEFT and RIGHT are equal, being associations of
case-insensitive strings to `equal?'-tested values."
  (and (string-ci=? (car left) (car right))
       (equal? (cdr left) (cdr right))))

(with-test-prefix "SRFI-69"

  (pass-if "small alist<->hash tables round-trip"
    (let* ((start-alist '((a . 1) (b . 2) (c . 3) (a . 42)))
	   (ht (alist->hash-table start-alist eq?))
	   (end-alist (hash-table->alist ht)))
      (and (= 3 (hash-table-size ht))
	   (lset= equal? end-alist (take start-alist 3))
	   (= 1 (hash-table-ref ht 'a))
	   (= 2 (hash-table-ref ht 'b))
	   (= 3 (hash-table-ref ht 'c)))))

  (pass-if "string-ci=? tables work by default"
    (let ((ht (alist->hash-table '(("xY" . 2) ("abc" . 54)) string-ci=?)))
      (hash-table-set! ht "XY" 42)
      (hash-table-set! ht "qqq" 100)
      (and (= 54 (hash-table-ref ht "ABc"))
	   (= 42 (hash-table-ref ht "xy"))
	   (= 3 (hash-table-size ht))
	   (lset= string-ci-assoc-equal?
		  '(("xy" . 42) ("abc" . 54) ("qqq" . 100))
		  (hash-table->alist ht)))))

  (pass-if-exception "Bad weakness arg to mht signals an error"
		     '(misc-error . "^Invalid weak hash table type")
    (make-hash-table equal? hash #:weak 'key-and-value))

  (pass-if "empty hash tables are empty"
    (null? (hash-table->alist (make-hash-table eq?))))

  (pass-if "hash-table-ref uses default"
    (equal? '(4)
	    (hash-table-ref (alist->hash-table '((a . 1)) eq?)
			    'b (cut list (+ 2 2)))))

  (pass-if "hash-table-delete! deletes present assocs, ignores others"
    (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq?)))
      (hash-table-delete! ht 'c)
      (and (= 2 (hash-table-size ht))
	   (begin
	     (hash-table-delete! ht 'a)
	     (= 1 (hash-table-size ht)))
	   (lset= equal? '((b . 2)) (hash-table->alist ht)))))

  (pass-if "alist->hash-table does not require linear stack space"
    (eqv? 99999
	  (hash-table-ref (alist->hash-table
			   (unfold-right (cut >= <> 100000)
					 (lambda (s) `(x . ,s)) 1+ 0)
			   eq?)
			  'x)))

  (pass-if "hash-table-walk ignores return values"
    (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3)) eq?)))
      (for-each (cut hash-table-walk ht <>)
		(list (lambda (k v) (values))
		      (lambda (k v) (values 1 2 3))))
      #t))

  (pass-if "hash-table-update! modifies existing binding"
    (let ((ht (alist->hash-table '((a . 1)) eq?)))
      (hash-table-update! ht 'a 1+)
      (hash-table-update! ht 'a (cut + 4 <>) (lambda () 42))
      (and (= 1 (hash-table-size ht))
	   (lset= equal? '((a . 6)) (hash-table->alist ht)))))

  (pass-if "hash-table-update! creates new binding when appropriate"
    (let ((ht (make-hash-table eq?)))
      (hash-table-update! ht 'b 1+ (lambda () 42))
      (hash-table-update! ht 'b (cut + 10 <>))
      (and (= 1 (hash-table-size ht))
	   (lset= equal? '((b . 53)) (hash-table->alist ht)))))

  (pass-if "can use all arguments, including size"
    (hash-table? (make-hash-table equal? hash #:weak 'key 31)))

)


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

(define-module (test-srfi-88)
  :use-module (test-suite lib)
  :use-module (srfi srfi-88))

;; Most of the test cases are taken from SRFI-88.

(with-test-prefix "srfi-88"

  (pass-if "cond-expand"
    (cond-expand (srfi-88 #t)
                 (else    #f)))

  (pass-if "keyword?"
    (and (keyword? 'foo:)
         (keyword? foo:)
         (not (keyword? 'foo))
         (not (keyword? ':))
         (keyword? (car '(a: b:)))
         (not (keyword? "bar"))))

  (pass-if "keyword->string"
    (and (string=? (keyword->string foo:) "foo")
         (string=? "a b c"
                   (keyword->string (string->keyword "a b c")))))

  (pass-if "string->keyword"
    (eq? (string->keyword "foo") foo:))

  (pass-if "empty keyword"
    ;; XXX: We don't currently support syntax of the form
    ;; `#{extended symbol}#:'.
    (string=? ""
              (keyword->string (string->keyword "")))))

;;; Local Variables:
;;; coding: latin-1
;;; End:


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

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

(define-record-type :foo (make-foo x) foo?
  (x get-x) (y get-y set-y!))

(define-record-type :bar (make-bar i j) bar?
  (i get-i) (i get-j set-j!))

(define f (make-foo 1))
(set-y! f 2)

(define b (make-bar 123 456))

(with-test-prefix "constructor"

  (pass-if-exception "foo 0 args" exception:wrong-num-args
     (make-foo))
  (pass-if-exception "foo 2 args" exception:wrong-num-args
     (make-foo 1 2)))

(with-test-prefix "predicate"

  (pass-if "pass"
     (foo? f))
  (pass-if "fail wrong record type"
     (eq? #f (foo? b)))
  (pass-if "fail number"
     (eq? #f (foo? 123))))

(with-test-prefix "accessor"

  (pass-if "get-x"
     (= 1 (get-x f)))
  (pass-if "get-y"
     (= 2 (get-y f)))

  (pass-if-exception "get-x on number" exception:wrong-type-arg
     (get-x 999))
  (pass-if-exception "get-y on number" exception:wrong-type-arg
     (get-y 999))

  ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  (pass-if-exception "get-x on bar" exception:wrong-type-arg
     (get-x b))
  (pass-if-exception "get-y on bar" exception:wrong-type-arg
     (get-y b)))

(with-test-prefix "modifier"

  (pass-if "set-y!"
     (set-y! f #t)
     (eq? #t (get-y f)))

  (pass-if-exception "set-y! on number" exception:wrong-type-arg
     (set-y! 999 #t))

  ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  (pass-if-exception "set-y! on bar" exception:wrong-type-arg
     (set-y! b 99)))


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

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

;;;
;;; stream-for-each
;;;

(with-test-prefix "stream-for-each"

  (with-test-prefix "1 streams"

    (pass-if "empty"
      (let ((lst '()))
	(stream-for-each (lambda (x)
			   (set! lst (cons x lst)))
			 (list->stream '()))
	(equal? '() lst)))

    (pass-if "123"
      (let ((lst '()))
	(stream-for-each (lambda (x)
			   (set! lst (cons x lst)))
			 (list->stream '(1 2 3)))
	(equal? '(3 2 1) lst))))

  (with-test-prefix "2 streams"

    (pass-if "empty empty"
      (let ((lst '()))
	(stream-for-each (lambda (x y)
			   (set! lst (cons* x y lst)))
			 (list->stream '())
			 (list->stream '()))
	(equal? '() lst)))

    (pass-if "123 456"
      (let ((lst '()))
	(stream-for-each (lambda (x y)
			   (set! lst (cons* x y lst)))
			 (list->stream '(1 2 3))
			 (list->stream '(4 5 6)))
	(equal? '(3 6 2 5 1 4) lst)))

    (pass-if "12 456"
      (let ((lst '()))
	(stream-for-each (lambda (x y)
			   (set! lst (cons* x y lst)))
			 (list->stream '(1 2))
			 (list->stream '(4 5 6)))
	(equal? '(2 5 1 4) lst)))

    (pass-if "123 45"
      (let ((lst '()))
	(stream-for-each (lambda (x y)
			   (set! lst (cons* x y lst)))
			 (list->stream '(1 2 3))
			 (list->stream '(4 5)))
	(equal? '(2 5 1 4) lst)))))


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

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

(define exception:read-only-string
  (cons 'misc-error "^string is read-only"))

;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
  (apply string (map integer->char args)))

;;
;; string=?
;;

(with-test-prefix "string=?"

  (pass-if "respects 1st parameter's string length"
    (not (string=? "foo\0" "foo")))

  (pass-if "respects 2nd paramter's string length"
    (not (string=? "foo" "foo\0")))

  (with-test-prefix "wrong argument type"

    (pass-if-exception "1st argument symbol"
      exception:wrong-type-arg
      (string=? 'a "a"))

    (pass-if-exception "2nd argument symbol"
      exception:wrong-type-arg
      (string=? "a" 'b))))

;;
;; string<?
;;

(with-test-prefix "string<?"

  (pass-if "respects string length"
    (and (not (string<? "foo\0a" "foo\0a"))
	 (string<? "foo\0a" "foo\0b")))

  (with-test-prefix "wrong argument type"

    (pass-if-exception "1st argument symbol"
      exception:wrong-type-arg
      (string<? 'a "a"))

    (pass-if-exception "2nd argument symbol"
      exception:wrong-type-arg
      (string<? "a" 'b)))

  (pass-if "same as char<?"
    (eq? (char<? (integer->char 0) (integer->char 255))
	 (string<? (string-ints 0) (string-ints 255)))))

;;
;; string-ci<?
;;

(with-test-prefix "string-ci<?"

  (pass-if "respects string length"
    (and (not (string-ci<? "foo\0a" "foo\0a"))
	 (string-ci<? "foo\0a" "foo\0b")))

  (with-test-prefix "wrong argument type"

    (pass-if-exception "1st argument symbol"
      exception:wrong-type-arg
      (string-ci<? 'a "a"))

    (pass-if-exception "2nd argument symbol"
      exception:wrong-type-arg
      (string-ci<? "a" 'b)))

  (pass-if "same as char-ci<?"
    (eq? (char-ci<? (integer->char 0) (integer->char 255))
	 (string-ci<? (string-ints 0) (string-ints 255)))))

;;
;; string<=?
;;

(with-test-prefix "string<=?"

  (pass-if "same as char<=?"
    (eq? (char<=? (integer->char 0) (integer->char 255))
	 (string<=? (string-ints 0) (string-ints 255)))))

;;
;; string-ci<=?
;;

(with-test-prefix "string-ci<=?"

  (pass-if "same as char-ci<=?"
    (eq? (char-ci<=? (integer->char 0) (integer->char 255))
	 (string-ci<=? (string-ints 0) (string-ints 255)))))

;;
;; string>?
;;

(with-test-prefix "string>?"

  (pass-if "same as char>?"
    (eq? (char>? (integer->char 0) (integer->char 255))
	 (string>? (string-ints 0) (string-ints 255)))))

;;
;; string-ci>?
;;

(with-test-prefix "string-ci>?"

  (pass-if "same as char-ci>?"
    (eq? (char-ci>? (integer->char 0) (integer->char 255))
	 (string-ci>? (string-ints 0) (string-ints 255)))))

;;
;; string>=?
;;

(with-test-prefix "string>=?"

  (pass-if "same as char>=?"
    (eq? (char>=? (integer->char 0) (integer->char 255))
	 (string>=? (string-ints 0) (string-ints 255)))))

;;
;; string-ci>=?
;;

(with-test-prefix "string-ci>=?"

  (pass-if "same as char-ci>=?"
    (eq? (char-ci>=? (integer->char 0) (integer->char 255))
	 (string-ci>=? (string-ints 0) (string-ints 255)))))

;;
;; string-ref
;;

(with-test-prefix "string-ref"

  (pass-if-exception "empty string"
    exception:out-of-range
    (string-ref "" 0))

  (pass-if-exception "empty string and non-zero index"
    exception:out-of-range
    (string-ref "" 123))

  (pass-if-exception "out of range"
    exception:out-of-range
    (string-ref "hello" 123))

  (pass-if-exception "negative index"
    exception:out-of-range
    (string-ref "hello" -1))

  (pass-if "regular string"
    (char=? (string-ref "GNU Guile" 4) #\G)))

;;
;; string-set!
;;

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

  (pass-if-exception "empty string"
    exception:out-of-range
    (string-set! (string-copy "") 0 #\x))

  (pass-if-exception "empty string and non-zero index"
    exception:out-of-range
    (string-set! (string-copy "") 123 #\x))

  (pass-if-exception "out of range"
    exception:out-of-range
    (string-set! (string-copy "hello") 123 #\x))

  (pass-if-exception "negative index"
    exception:out-of-range
    (string-set! (string-copy "hello") -1 #\x))

  (pass-if-exception "read-only string"
    exception:read-only-string
    (string-set! (substring/read-only "abc" 0) 1 #\space))

  (pass-if "regular string"
    (let ((s (string-copy "GNU guile")))
      (string-set! s 4 #\G)
      (char=? (string-ref s 4) #\G))))

(with-test-prefix "string-split"

  ;; in guile 1.6.7 and earlier, character >=128 wasn't matched in the string
  (pass-if "char 255"
    (equal? '("a" "b")
	    (string-split (string #\a (integer->char 255) #\b)
			  (integer->char 255)))))

(with-test-prefix "substring-move!"

  (pass-if-exception "substring-move! checks start and end correctly"
    exception:out-of-range
    (substring-move! "sample" 3 0 "test" 3)))

(with-test-prefix "substring/shared"

  (pass-if "modify indirectly"
    (let ((str (string-copy "foofoofoo")))
      (string-upcase! (substring/shared str 3 6))
      (string=? str "fooFOOfoo")))

  (pass-if "modify cow indirectly"
    (let* ((str1 (string-copy "foofoofoo"))
	   (str2 (string-copy str1)))
      (string-upcase! (substring/shared str2 3 6))
      (and (string=? str1 "foofoofoo")
	   (string=? str2 "fooFOOfoo"))))

  (pass-if "modify double indirectly"
    (let* ((str1 (string-copy "foofoofoo"))
	   (str2 (substring/shared str1 2 7)))
      (string-upcase! (substring/shared str2 1 4))
      (string=? str1 "fooFOOfoo")))

  (pass-if "modify cow double indirectly"
    (let* ((str1 "foofoofoo")
	   (str2 (substring str1 2 7)))
      (string-upcase! (substring/shared str2 1 4))
      (and (string=? str1 "foofoofoo")
	   (string=? str2 "oFOOf")))))


code:
;;;; structs.test --- Test suite for Guile's structures.   -*- Scheme -*-
;;;; Ludovic Court�s <ludovic.courtes@laas.fr>, 2006-06-12.
;;;;
;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

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

;;;
;;; Struct example taken from the reference manual (by Tom Lord).
;;;

(define ball-root (make-vtable-vtable "pr" 0))

(define (make-ball-type ball-color)
  (make-struct ball-root 0
	       (make-struct-layout "pw")
	       (lambda (ball port)
		 (format port "#<a ~A ball owned by ~A>"
			 (color ball)
			 (owner ball)))
	       ball-color))

(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
(define (owner ball) (struct-ref ball 0))
(define (set-owner! ball owner) (struct-set! ball 0 owner))

(define red (make-ball-type 'red))
(define green (make-ball-type 'green))

(define (make-ball type owner) (make-struct type 0 owner))

;;;
;;; Test suite.
;;;

(with-test-prefix "low-level struct procedures"

  (pass-if "constructors"
     (and (struct-vtable? ball-root)
	  (struct-vtable? red)
	  (struct-vtable? green)))

  (pass-if "vtables"
     (and (eq? (struct-vtable red) ball-root)
	  (eq? (struct-vtable green) ball-root)
	  (eq? (struct-vtable (make-ball red "Bob")) red)

	  ;; end of the vtable tower
	  (eq? (struct-vtable ball-root) ball-root)))

  (pass-if-exception "write-access denied"
     exception:struct-set!-denied

     ;; The first field of instances of BALL-ROOT is read-only.
     (struct-set! red vtable-offset-user "blue"))

  (pass-if "write-access granted"
     (set-owner! (make-ball red "Bob") "Fred")
     #t)

  (pass-if "struct-set!"
     (let ((ball (make-ball green "Bob")))
       (set-owner! ball "Bill")
       (string=? (owner ball) "Bill"))))

(with-test-prefix "equal?"

  (pass-if "simple structs"
     (let* ((vtable (make-vtable-vtable "pr" 0))
            (s1     (make-struct vtable 0 "hello"))
            (s2     (make-struct vtable 0 "hello")))
       (equal? s1 s2)))

  (pass-if "more complex structs"
     (let ((first (make-ball red (string-copy "Bob")))
           (second (make-ball red (string-copy "Bob"))))
       (equal? first second)))

  (pass-if "not-equal?"
     (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
	      (equal? (make-ball red "Bob") (make-ball red "Bill"))))))

;;
;; make-struct
;;

(define exception:bad-tail
  (cons 'misc-error "tail array not allowed unless"))

(with-test-prefix "make-struct"

  ;; in guile 1.8.1 and earlier, this caused an error throw out of an
  ;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
  ;; the program
  ;;
  (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
    (let* ((vv (make-vtable-vtable "" 0))
	   (v  (make-struct vv 0 (make-struct-layout "uw"))))
      (make-struct v 0 'x)))

  ;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
  ;; on a tail array being created without an R/W/O type for it.  This left
  ;; it uninitialized by scm_struct_init(), resulting in garbage getting
  ;; into an SCM when struct-ref read it (and attempting to print a garbage
  ;; SCM can cause a segv).
  ;;
  (pass-if-exception "no R/W/O for tail array" exception:bad-tail
    (let* ((vv (make-vtable-vtable "" 0))
	   (v  (make-struct vv 0 (make-struct-layout "pw"))))
      (make-struct v 123 'x))))

;;
;; make-vtable
;;

(with-test-prefix "make-vtable"

  (pass-if "without printer"
    (let* ((vtable (make-vtable "pwpr"))
	   (struct (make-struct vtable 0 'x 'y)))
      (and (eq? 'x (struct-ref struct 0))
	   (eq? 'y (struct-ref struct 1)))))

  (pass-if "with printer"
    (let ()
      (define (print struct port)
	(display "hello" port))

      (let* ((vtable (make-vtable "pwpr" print))
	     (struct (make-struct vtable 0 'x 'y))
	     (str    (call-with-output-string
		      (lambda (port)
			(display struct port)))))
	 (equal? str "hello")))))

;;; Local Variables:
;;; coding: latin-1
;;; End:


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

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

;;;
;;; miscellaneous
;;;

(define exception:immutable-string
  (cons 'misc-error "^string is read-only"))

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

;;;
;;; symbol?
;;;

(with-test-prefix "symbol?"

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

  (pass-if "string"
    (not (symbol? "foo")))

  (pass-if "symbol"
    (symbol? 'foo)))

;;;
;;; symbol->string
;;;

(with-test-prefix "symbol->string"

  (pass-if-exception "result is an immutable string"
    exception:immutable-string
    (string-set! (symbol->string 'abc) 1 #\space)))

;;;
;;; gensym
;;;

(with-test-prefix "gensym"

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

  (pass-if "produces a symbol"
    (symbol? (gensym)))

  (pass-if "produces a fresh symbol"
    (not (eq? (gensym) (gensym))))

  (pass-if "accepts a string prefix"
    (symbol? (gensym "foo")))

  (pass-if-exception "does not accept a symbol prefix"
    exception:wrong-type-arg
    (gensym 'foo))

  (pass-if "accepts long prefices"
    (symbol? (gensym (make-string 4000 #\!))))

  (pass-if "accepts embedded NULs"
    (> (string-length (symbol->string (gensym "foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0"))) 6)))


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

;; These tests are in a module so that the syntax transformer does not
;; affect code outside of this file.
;;
(define-module (test-suite test-syncase)
  :use-module (test-suite lib))

(pass-if "(ice-9 syncase) loads"
  (false-if-exception
   (begin (eval '(use-syntax (ice-9 syncase)) (current-module))
          #t)))

(define-syntax plus
  (syntax-rules ()
    ((plus x ...) (+ x ...))))

(pass-if "basic syncase macro"
  (= (plus 1 2 3) (+ 1 2 3)))

(pass-if "@ works with syncase"
  (eq? run-test (@ (test-suite lib) run-test)))


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

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

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

(define exception:missing/extra-expr
  (cons 'syntax-error "Missing or extra expression"))
(define exception:missing-expr
  (cons 'syntax-error "Missing expression"))
(define exception:missing-body-expr
  (cons 'syntax-error "Missing body expression"))
(define exception:extra-expr
  (cons 'syntax-error "Extra expression"))
(define exception:illegal-empty-combination
  (cons 'syntax-error "Illegal empty combination"))

(define exception:bad-bindings
  (cons 'syntax-error "Bad bindings"))
(define exception:bad-binding
  (cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
  (cons 'syntax-error "Duplicate binding"))
(define exception:bad-body
  (cons 'misc-error "^bad body"))
(define exception:bad-formals
  (cons 'syntax-error "Bad formals"))
(define exception:bad-formal
  (cons 'syntax-error "Bad formal"))
(define exception:duplicate-formal
  (cons 'syntax-error "Duplicate formal"))

(define exception:missing-clauses
  (cons 'syntax-error "Missing clauses"))
(define exception:misplaced-else-clause
  (cons 'syntax-error "Misplaced else clause"))
(define exception:bad-case-clause
  (cons 'syntax-error "Bad case clause"))
(define exception:bad-case-labels
  (cons 'syntax-error "Bad case labels"))
(define exception:bad-cond-clause
  (cons 'syntax-error "Bad cond clause"))

(with-test-prefix "expressions"

  (with-test-prefix "Bad argument list"

    (pass-if-exception "improper argument list of length 1"
      exception:wrong-num-args
      (eval '(let ((foo (lambda (x y) #t)))
	       (foo . 1))
	    (interaction-environment)))

    (pass-if-exception "improper argument list of length 2"
      exception:wrong-num-args
      (eval '(let ((foo (lambda (x y) #t)))
	       (foo 1 . 2))
	    (interaction-environment))))

  (with-test-prefix "missing or extra expression"

    ;; R5RS says:
    ;; *Note:* In many dialects of Lisp, the empty combination, (),
    ;; is a legitimate expression.  In Scheme, combinations must
    ;; have at least one subexpression, so () is not a syntactically
    ;; valid expression.

    ;; Fixed on 2001-3-3
    (pass-if-exception "empty parentheses \"()\""
      exception:illegal-empty-combination
      (eval '()
	    (interaction-environment)))))

(with-test-prefix "quote"
  #t)

(with-test-prefix "quasiquote"

  (with-test-prefix "unquote"

    (pass-if "repeated execution"
      (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
	(and (equal? (foo) '(1)) (equal? (foo) '(2))))))

  (with-test-prefix "unquote-splicing"

    (pass-if-exception "extra arguments"
      exception:missing/extra-expr
      (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))

(with-test-prefix "begin"

  (pass-if "legal (begin)"
    (begin)
    #t)

  (with-test-prefix "unmemoization"

    (pass-if "normal begin"
      (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))

    (pass-if "redundant nested begin"
      (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))

    (pass-if "redundant begin at start of body"
      (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (begin (+ 1) (+ 2)))))))

  (expect-fail-exception "illegal (begin)"
    exception:bad-body
    (if #t (begin))
    #t))

(with-test-prefix "lambda"

  (with-test-prefix "unmemoization"

    (pass-if "normal lambda"
      (let ((foo (lambda () (lambda (x y) (+ x y)))))
        ((foo) 1 2) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (lambda (x y) (+ x y))))))

    (pass-if "lambda with documentation"
      (let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
        ((foo) 1 2) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (lambda (x y) "docstring" (+ x y)))))))

  (with-test-prefix "bad formals"

    (pass-if-exception "(lambda)"
      exception:missing-expr
      (eval '(lambda)
	    (interaction-environment)))

    (pass-if-exception "(lambda . \"foo\")"
      exception:bad-expression
      (eval '(lambda . "foo")
	    (interaction-environment)))

    (pass-if-exception "(lambda \"foo\")"
      exception:missing-expr
      (eval '(lambda "foo")
	    (interaction-environment)))

    (pass-if-exception "(lambda \"foo\" #f)"
      exception:bad-formals
      (eval '(lambda "foo" #f)
	    (interaction-environment)))

    (pass-if-exception "(lambda (x 1) 2)"
      exception:bad-formal
      (eval '(lambda (x 1) 2)
	    (interaction-environment)))

    (pass-if-exception "(lambda (1 x) 2)"
      exception:bad-formal
      (eval '(lambda (1 x) 2)
	    (interaction-environment)))

    (pass-if-exception "(lambda (x \"a\") 2)"
      exception:bad-formal
      (eval '(lambda (x "a") 2)
	    (interaction-environment)))

    (pass-if-exception "(lambda (\"a\" x) 2)"
      exception:bad-formal
      (eval '(lambda ("a" x) 2)
	    (interaction-environment))))

  (with-test-prefix "duplicate formals"

    ;; Fixed on 2001-3-3
    (pass-if-exception "(lambda (x x) 1)"
      exception:duplicate-formal
      (eval '(lambda (x x) 1)
	    (interaction-environment)))

    ;; Fixed on 2001-3-3
    (pass-if-exception "(lambda (x x x) 1)"
      exception:duplicate-formal
      (eval '(lambda (x x x) 1)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(lambda ())"
      exception:missing-expr
      (eval '(lambda ())
	    (interaction-environment)))))

(with-test-prefix "let"

  (with-test-prefix "unmemoization"

    (pass-if "normal let"
      (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (let ((i 1) (j 2)) (+ i j)))))))

  (with-test-prefix "bindings"

    (pass-if-exception "late binding"
      exception:unbound-var
      (let ((x 1) (y x)) y)))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let)"
      exception:missing-expr
      (eval '(let)
	    (interaction-environment)))

    (pass-if-exception "(let 1)"
      exception:missing-expr
      (eval '(let 1)
	    (interaction-environment)))

    (pass-if-exception "(let (x))"
      exception:missing-expr
      (eval '(let (x))
	    (interaction-environment)))

    (pass-if-exception "(let ((x)))"
      exception:missing-expr
      (eval '(let ((x)))
	    (interaction-environment)))

    (pass-if-exception "(let (x) 1)"
      exception:bad-binding
      (eval '(let (x) 1)
	    (interaction-environment)))

    (pass-if-exception "(let ((x)) 3)"
      exception:bad-binding
      (eval '(let ((x)) 3)
	    (interaction-environment)))

    (pass-if-exception "(let ((x 1) y) x)"
      exception:bad-binding
      (eval '(let ((x 1) y) x)
	    (interaction-environment)))

    (pass-if-exception "(let ((1 2)) 3)"
      exception:bad-variable
      (eval '(let ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "duplicate bindings"

    (pass-if-exception "(let ((x 1) (x 2)) x)"
      exception:duplicate-binding
      (eval '(let ((x 1) (x 2)) x)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let ())"
      exception:missing-expr
      (eval '(let ())
	    (interaction-environment)))

    (pass-if-exception "(let ((x 1)))"
      exception:missing-expr
      (eval '(let ((x 1)))
	    (interaction-environment)))))

(with-test-prefix "named let"

  (with-test-prefix "initializers"

    (pass-if "evaluated in outer environment"
      (let ((f -))
	(eqv? (let f ((n (f 1))) n) -1))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let x (y))"
      exception:missing-expr
      (eval '(let x (y))
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let x ())"
      exception:missing-expr
      (eval '(let x ())
	    (interaction-environment)))

    (pass-if-exception "(let x ((y 1)))"
      exception:missing-expr
      (eval '(let x ((y 1)))
	    (interaction-environment)))))

(with-test-prefix "let*"

  (with-test-prefix "unmemoization"

    (pass-if "normal let*"
      (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (let* ((x 1) (y 2)) (+ x y))))))

    (pass-if "let* without bindings"
      (let ((foo (lambda () (let ((x 1) (y 2))
                              (let* ()
                                (and (= x 1) (= y 2)))))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (let ((x 1) (y 2))
                              (let* ()
                                (and (= x 1) (= y 2)))))))))

  (with-test-prefix "bindings"

    (pass-if "(let* ((x 1) (x 2)) ...)"
      (let* ((x 1) (x 2))
	(= x 2)))

    (pass-if "(let* ((x 1) (x x)) ...)"
      (let* ((x 1) (x x))
	(= x 1)))

    (pass-if "(let ((x 1) (y 2)) (let* () ...))"
      (let ((x 1) (y 2))
        (let* ()
          (and (= x 1) (= y 2))))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let*)"
      exception:missing-expr
      (eval '(let*)
	    (interaction-environment)))

    (pass-if-exception "(let* 1)"
      exception:missing-expr
      (eval '(let* 1)
	    (interaction-environment)))

    (pass-if-exception "(let* (x))"
      exception:missing-expr
      (eval '(let* (x))
	    (interaction-environment)))

    (pass-if-exception "(let* (x) 1)"
      exception:bad-binding
      (eval '(let* (x) 1)
	    (interaction-environment)))

    (pass-if-exception "(let* ((x)) 3)"
      exception:bad-binding
      (eval '(let* ((x)) 3)
	    (interaction-environment)))

    (pass-if-exception "(let* ((x 1) y) x)"
      exception:bad-binding
      (eval '(let* ((x 1) y) x)
	    (interaction-environment)))

    (pass-if-exception "(let* x ())"
      exception:bad-bindings
      (eval '(let* x ())
	    (interaction-environment)))

    (pass-if-exception "(let* x (y))"
      exception:bad-bindings
      (eval '(let* x (y))
	    (interaction-environment)))

    (pass-if-exception "(let* ((1 2)) 3)"
      exception:bad-variable
      (eval '(let* ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let* ())"
      exception:missing-expr
      (eval '(let* ())
	    (interaction-environment)))

    (pass-if-exception "(let* ((x 1)))"
      exception:missing-expr
      (eval '(let* ((x 1)))
	    (interaction-environment)))))

(with-test-prefix "letrec"

  (with-test-prefix "unmemoization"

    (pass-if "normal letrec"
      (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))

  (with-test-prefix "bindings"

    (pass-if-exception "initial bindings are undefined"
      exception:used-before-defined
      (let ((x 1))
	(letrec ((x 1) (y x)) y))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(letrec)"
      exception:missing-expr
      (eval '(letrec)
	    (interaction-environment)))

    (pass-if-exception "(letrec 1)"
      exception:missing-expr
      (eval '(letrec 1)
	    (interaction-environment)))

    (pass-if-exception "(letrec (x))"
      exception:missing-expr
      (eval '(letrec (x))
	    (interaction-environment)))

    (pass-if-exception "(letrec (x) 1)"
      exception:bad-binding
      (eval '(letrec (x) 1)
	    (interaction-environment)))

    (pass-if-exception "(letrec ((x)) 3)"
      exception:bad-binding
      (eval '(letrec ((x)) 3)
	    (interaction-environment)))

    (pass-if-exception "(letrec ((x 1) y) x)"
      exception:bad-binding
      (eval '(letrec ((x 1) y) x)
	    (interaction-environment)))

    (pass-if-exception "(letrec x ())"
      exception:bad-bindings
      (eval '(letrec x ())
	    (interaction-environment)))

    (pass-if-exception "(letrec x (y))"
      exception:bad-bindings
      (eval '(letrec x (y))
	    (interaction-environment)))

    (pass-if-exception "(letrec ((1 2)) 3)"
      exception:bad-variable
      (eval '(letrec ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "duplicate bindings"

    (pass-if-exception "(letrec ((x 1) (x 2)) x)"
      exception:duplicate-binding
      (eval '(letrec ((x 1) (x 2)) x)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(letrec ())"
      exception:missing-expr
      (eval '(letrec ())
	    (interaction-environment)))

    (pass-if-exception "(letrec ((x 1)))"
      exception:missing-expr
      (eval '(letrec ((x 1)))
	    (interaction-environment)))))

(with-test-prefix "if"

  (with-test-prefix "unmemoization"

    (pass-if "normal if"
      (let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
        (foo #t) ; make sure, memoization has been performed
        (foo #f) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda (x) (if x (+ 1) (+ 2))))))

    (pass-if "if without else"
      (let ((foo (lambda (x) (if x (+ 1)))))
        (foo #t) ; make sure, memoization has been performed
        (foo #f) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda (x) (if x (+ 1))))))

    (pass-if "if #f without else"
      (let ((foo (lambda () (if #f #f))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                `(lambda () (if #f #f))))))

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(if)"
      exception:missing/extra-expr
      (eval '(if)
	    (interaction-environment)))

    (pass-if-exception "(if 1 2 3 4)"
      exception:missing/extra-expr
      (eval '(if 1 2 3 4)
	    (interaction-environment)))))

(with-test-prefix "cond"

  (with-test-prefix "cond is hygienic"

    (pass-if "bound 'else is handled correctly"
      (eq? (let ((else 'ok)) (cond (else))) 'ok))

    (with-test-prefix "bound '=> is handled correctly"

      (pass-if "#t => 'ok"
        (let ((=> 'foo))
          (eq? (cond (#t => 'ok)) 'ok)))

      (pass-if "else =>"
        (let ((=> 'foo))
          (eq? (cond (else =>)) 'foo)))

      (pass-if "else => identity"
        (let ((=> 'foo))
          (eq? (cond (else => identity)) identity)))))

  (with-test-prefix "SRFI-61"

    (pass-if "always available"
      (cond-expand (srfi-61 #t) (else #f)))

    (pass-if "single value consequent"
      (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))

    (pass-if "single value alternate"
      (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))

    (pass-if-exception "doesn't affect standard =>"
      exception:wrong-num-args
      (cond ((values 1 2) => (lambda (x y) #t))))

    (pass-if "multiple values consequent"
      (equal? '(2 1) (cond ((values 1 2)
			    (lambda (one two)
			      (and (= 1 one) (= 2 two))) =>
			    (lambda (one two) (list two one)))
			   (else #f))))

    (pass-if "multiple values alternate"
      (eq? 'ok (cond ((values 2 3 4)
		      (lambda args (equal? '(1 2 3) args)) =>
		      (lambda (x y z) #f))
		     (else 'ok))))

    (pass-if "zero values"
      (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
		     (else #f))))

    (pass-if "bound => is handled correctly"
      (let ((=> 'ok))
	(eq? 'ok (cond (#t identity =>) (else #f)))))

    (pass-if-exception "missing recipient"
      '(syntax-error . "Missing recipient")
      (cond (#t identity =>)))

    (pass-if-exception "extra recipient"
      '(syntax-error . "Extra expression")
      (cond (#t identity => identity identity))))

  (with-test-prefix "unmemoization"

    (pass-if "normal clauses"
      (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
        (foo 1) ; make sure, memoization has been performed
        (foo 2) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))

    (pass-if "else"
      (let ((foo (lambda () (cond (else 'bar)))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (cond (else 'bar))))))

    (pass-if "=>"
      (let ((foo (lambda () (cond (#t => identity)))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (cond (#t => identity)))))))

  (with-test-prefix "bad or missing clauses"

    (pass-if-exception "(cond)"
      exception:missing-clauses
      (eval '(cond)
	    (interaction-environment)))

    (pass-if-exception "(cond #t)"
      exception:bad-cond-clause
      (eval '(cond #t)
	    (interaction-environment)))

    (pass-if-exception "(cond 1)"
      exception:bad-cond-clause
      (eval '(cond 1)
	    (interaction-environment)))

    (pass-if-exception "(cond 1 2)"
      exception:bad-cond-clause
      (eval '(cond 1 2)
	    (interaction-environment)))

    (pass-if-exception "(cond 1 2 3)"
      exception:bad-cond-clause
      (eval '(cond 1 2 3)
	    (interaction-environment)))

    (pass-if-exception "(cond 1 2 3 4)"
      exception:bad-cond-clause
      (eval '(cond 1 2 3 4)
	    (interaction-environment)))

    (pass-if-exception "(cond ())"
      exception:bad-cond-clause
      (eval '(cond ())
	    (interaction-environment)))

    (pass-if-exception "(cond () 1)"
      exception:bad-cond-clause
      (eval '(cond () 1)
	    (interaction-environment)))

    (pass-if-exception "(cond (1) 1)"
      exception:bad-cond-clause
      (eval '(cond (1) 1)
	    (interaction-environment))))

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

    (pass-if-exception "=> (lambda (x y) #t)"
      exception:wrong-num-args
      (cond (1 => (lambda (x y) #t))))))

(with-test-prefix "case"

  (pass-if "clause with empty labels list"
    (case 1 (() #f) (else #t)))

  (with-test-prefix "case is hygienic"

    (pass-if-exception "bound 'else is handled correctly"
      exception:bad-case-labels
      (eval '(let ((else #f)) (case 1 (else #f)))
            (interaction-environment))))

  (with-test-prefix "unmemoization"

    (pass-if "normal clauses"
      (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
        (foo 1) ; make sure, memoization has been performed
        (foo 2) ; make sure, memoization has been performed
        (foo 3) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))

    (pass-if "empty labels"
      (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
        (foo 1) ; make sure, memoization has been performed
        (foo 2) ; make sure, memoization has been performed
        (foo 3) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))

  (with-test-prefix "bad or missing clauses"

    (pass-if-exception "(case)"
      exception:missing-clauses
      (eval '(case)
	    (interaction-environment)))

    (pass-if-exception "(case . \"foo\")"
      exception:bad-expression
      (eval '(case . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1)"
      exception:missing-clauses
      (eval '(case 1)
	    (interaction-environment)))

    (pass-if-exception "(case 1 . \"foo\")"
      exception:bad-expression
      (eval '(case 1 . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 \"foo\")"
      exception:bad-case-clause
      (eval '(case 1 "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 ())"
      exception:bad-case-clause
      (eval '(case 1 ())
	    (interaction-environment)))

    (pass-if-exception "(case 1 (\"foo\"))"
      exception:bad-case-clause
      (eval '(case 1 ("foo"))
	    (interaction-environment)))

    (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
      exception:bad-case-labels
      (eval '(case 1 ("foo" "bar"))
	    (interaction-environment)))

    (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
      exception:bad-expression
      (eval '(case 1 ((2) "bar") . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 ((2) \"bar\") (else))"
      exception:bad-case-clause
      (eval '(case 1 ((2) "bar") (else))
	    (interaction-environment)))

    (pass-if-exception "(case 1 (else #f) . \"foo\")"
      exception:bad-expression
      (eval '(case 1 (else #f) . "foo")
	    (interaction-environment)))

    (pass-if-exception "(case 1 (else #f) ((1) #t))"
      exception:misplaced-else-clause
      (eval '(case 1 (else #f) ((1) #t))
	    (interaction-environment)))))

(with-test-prefix "top-level define"

  (pass-if "redefinition"
    (let ((m (make-module)))
      (beautify-user-module! m)

      ;; The previous value of `round' must still be visible at the time the
      ;; new `round' is defined.  According to R5RS (Section 5.2.1), `define'
      ;; should behave like `set!' in this case (except that in the case of
      ;; Guile, we respect module boundaries).
      (eval '(define round round) m)
      (eq? (module-ref m 'round) round)))

  (with-test-prefix "currying"

    (pass-if "(define ((foo)) #f)"
      (eval '(begin
               (define ((foo)) #t)
               ((foo)))
            (interaction-environment))))

  (with-test-prefix "unmemoization"

    (pass-if "definition unmemoized without prior execution"
      (eval '(begin
               (define (blub) (cons ('(1 . 2)) 2))
               (equal?
                 (procedure-source blub)
                 '(lambda () (cons ('(1 . 2)) 2))))
            (interaction-environment)))

    (pass-if "definition with documentation unmemoized without prior execution"
      (eval '(begin
               (define (blub) "Comment" (cons ('(1 . 2)) 2))
               (equal?
                 (procedure-source blub)
                 '(lambda () "Comment" (cons ('(1 . 2)) 2))))
            (interaction-environment))))

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(define)"
      exception:missing-expr
      (eval '(define)
	    (interaction-environment)))))

(with-test-prefix "internal define"

  (pass-if "internal defines become letrec"
    (eval '(let ((a identity) (b identity) (c identity))
             (define (a x) (if (= x 0) 'a (b (- x 1))))
             (define (b x) (if (= x 0) 'b (c (- x 1))))
             (define (c x) (if (= x 0) 'c (a (- x 1))))
             (and (eq? 'a (a 0) (a 3))
                  (eq? 'b (a 1) (a 4))
                  (eq? 'c (a 2) (a 5))))
          (interaction-environment)))

  (pass-if "binding is created before expression is evaluated"
    ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
    (= (eval '(let ()
                (define foo
                  (begin
                    (set! foo 1)
                    (+ foo 1)))
                foo)
             (interaction-environment))
       2))

  (pass-if "internal defines with begin"
    (false-if-exception
     (eval '(let ((a identity) (b identity) (c identity))
              (define (a x) (if (= x 0) 'a (b (- x 1))))
              (begin
                (define (b x) (if (= x 0) 'b (c (- x 1)))))
              (define (c x) (if (= x 0) 'c (a (- x 1))))
              (and (eq? 'a (a 0) (a 3))
                   (eq? 'b (a 1) (a 4))
                   (eq? 'c (a 2) (a 5))))
           (interaction-environment))))

  (pass-if "internal defines with empty begin"
    (false-if-exception
     (eval '(let ((a identity) (b identity) (c identity))
              (define (a x) (if (= x 0) 'a (b (- x 1))))
              (begin)
              (define (b x) (if (= x 0) 'b (c (- x 1))))
              (define (c x) (if (= x 0) 'c (a (- x 1))))
              (and (eq? 'a (a 0) (a 3))
                   (eq? 'b (a 1) (a 4))
                   (eq? 'c (a 2) (a 5))))
           (interaction-environment))))

  (pass-if "internal defines with macro application"
    (false-if-exception
     (eval '(begin
              (defmacro my-define forms
                (cons 'define forms))
              (let ((a identity) (b identity) (c identity))
                (define (a x) (if (= x 0) 'a (b (- x 1))))
                (my-define (b x) (if (= x 0) 'b (c (- x 1))))
                (define (c x) (if (= x 0) 'c (a (- x 1))))
                (and (eq? 'a (a 0) (a 3))
                     (eq? 'b (a 1) (a 4))
                     (eq? 'c (a 2) (a 5)))))
           (interaction-environment))))

  (pass-if-exception "missing body expression"
    exception:missing-body-expr
    (eval '(let () (define x #t))
          (interaction-environment)))

  (pass-if "unmemoization"
    (eval '(begin
             (define (foo)
               (define (bar)
                 'ok)
               (bar))
             (foo)
             (equal?
              (procedure-source foo)
              '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
          (interaction-environment))))

(with-test-prefix "do"

  (with-test-prefix "unmemoization"

    (pass-if "normal case"
      (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
                                ((> i 9) (+ i j))
                              (identity i)))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (do ((i 1 (+ i 1)) (j 2))
                                ((> i 9) (+ i j))
                              (identity i))))))

    (pass-if "reduced case"
      (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
                                ((> i 9) (+ i j))
                              (identity i)))))
        (foo) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
                                ((> i 9) (+ i j))
                              (identity i))))))))

(with-test-prefix "set!"

  (with-test-prefix "unmemoization"

    (pass-if "normal set!"
      (let ((foo (lambda (x) (set! x (+ 1 x)))))
        (foo 1) ; make sure, memoization has been performed
        (equal? (procedure-source foo)
                '(lambda (x) (set! x (+ 1 x)))))))

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(set!)"
      exception:missing/extra-expr
      (eval '(set!)
	    (interaction-environment)))

    (pass-if-exception "(set! 1)"
      exception:missing/extra-expr
      (eval '(set! 1)
	    (interaction-environment)))

    (pass-if-exception "(set! 1 2 3)"
      exception:missing/extra-expr
      (eval '(set! 1 2 3)
	    (interaction-environment))))

  (with-test-prefix "bad variable"

    (pass-if-exception "(set! \"\" #t)"
      exception:bad-variable
      (eval '(set! "" #t)
	    (interaction-environment)))

    (pass-if-exception "(set! 1 #t)"
      exception:bad-variable
      (eval '(set! 1 #t)
	    (interaction-environment)))

    (pass-if-exception "(set! #t #f)"
      exception:bad-variable
      (eval '(set! #t #f)
	    (interaction-environment)))

    (pass-if-exception "(set! #f #t)"
      exception:bad-variable
      (eval '(set! #f #t)
	    (interaction-environment)))

    (pass-if-exception "(set! #\\space #f)"
      exception:bad-variable
      (eval '(set! #\space #f)
	    (interaction-environment)))))

(with-test-prefix "quote"

  (with-test-prefix "missing or extra expression"

    (pass-if-exception "(quote)"
      exception:missing/extra-expr
      (eval '(quote)
	    (interaction-environment)))

    (pass-if-exception "(quote a b)"
      exception:missing/extra-expr
      (eval '(quote a b)
	    (interaction-environment)))))

(with-test-prefix "while"

  (define (unreachable)
    (error "unreachable code has been reached!"))

  ;; Return a new procedure COND which when called (COND) will return #t the
  ;; first N times, then #f, then any further call is an error.  N=0 is
  ;; allowed, in which case #f is returned by the first call.
  (define (make-iterations-cond n)
    (lambda ()
      (cond ((not n)
	     (error "oops, condition re-tested after giving false"))
	    ((= 0 n)
	     (set! n #f)
	     #f)
	    (else
	     (set! n (1- n))
	     #t))))

  (pass-if-exception "too few args" exception:wrong-num-args
    (eval '(while) (interaction-environment)))

  (with-test-prefix "empty body"
    (do ((n 0 (1+ n)))
	((> n 5))
      (pass-if n
	(let ((cond (make-iterations-cond n)))
	  (while (cond)))
	#t)))

  (pass-if "initially false"
    (while #f
      (unreachable))
    #t)

  (with-test-prefix "in empty environment"

    ;; an environment with no bindings at all
    (define empty-environment
      (make-module 1))

    ;; these tests are 'unresolved because to work with ice-9 syncase it was
    ;; necessary to drop the unquote from `do' in the implementation, and
    ;; unfortunately that makes `while' depend on its evaluation environment

    (pass-if "empty body"
      (throw 'unresolved)
      (eval `(,while #f)
	    empty-environment)
      #t)

    (pass-if "initially false"
      (throw 'unresolved)
      (eval `(,while #f
	       #f)
	    empty-environment)
      #t)

    (pass-if "iterating"
      (throw 'unresolved)
      (let ((cond (make-iterations-cond 3)))
	(eval `(,while (,cond)
		 123 456)
	      empty-environment))
      #t))

  (with-test-prefix "iterations"
    (do ((n 0 (1+ n)))
	((> n 5))
      (pass-if n
	(let ((cond (make-iterations-cond n))
	      (i    0))
	  (while (cond)
	    (set! i (1+ i)))
	  (= i n)))))

  (with-test-prefix "break"

    (pass-if-exception "too many args" exception:wrong-num-args
      (while #t
	(break 1)))

    (with-test-prefix "from cond"
      (pass-if "first"
	(while (begin
		 (break)
		 (unreachable))
	  (unreachable))
	#t)

      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (if (cond)
		       #t
		       (begin
			 (break)
			 (unreachable)))
	      (set! i (1+ i)))
	    (= i n)))))

    (with-test-prefix "from body"
      (pass-if "first"
	(while #t
	  (break)
	  (unreachable))
	#t)

      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while #t
	      (if (not (cond))
		  (begin
		    (break)
		    (unreachable)))
	      (set! i (1+ i)))
	    (= i n)))))

    (pass-if "from nested"
      (while #t
	(let ((outer-break break))
	  (while #t
	    (outer-break)
	    (unreachable)))
	(unreachable))
      #t)

    (pass-if "from recursive"
      (let ((outer-break #f))
	(define (r n)
	  (while #t
	    (if (eq? n 'outer)
		(begin
		  (set! outer-break break)
		  (r 'inner))
		(begin
		  (outer-break)
		  (unreachable))))
	  (if (eq? n 'inner)
	      (error "broke only from inner loop")))
	(r 'outer))
      #t))

  (with-test-prefix "continue"

    (pass-if-exception "too many args" exception:wrong-num-args
      (while #t
	(continue 1)))

    (with-test-prefix "from cond"
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (if (cond)
		       (begin
			 (set! i (1+ i))
			 (continue)
			 (unreachable))
		       #f)
	      (unreachable))
	    (= i n)))))

    (with-test-prefix "from body"
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (cond)
	      (set! i (1+ i))
	      (continue)
	      (unreachable))
	    (= i n)))))

    (pass-if "from nested"
      (let ((cond (make-iterations-cond 3)))
	(while (cond)
	  (let ((outer-continue continue))
	    (while #t
	      (outer-continue)
	      (unreachable)))))
      #t)

    (pass-if "from recursive"
      (let ((outer-continue #f))
	(define (r n)
	  (let ((cond  (make-iterations-cond 3))
		(first #t))
	    (while (begin
		     (if (and (not first)
			      (eq? n 'inner))
			 (error "continued only to inner loop"))
		     (cond))
	      (set! first #f)
	      (if (eq? n 'outer)
		  (begin
		    (set! outer-continue continue)
		    (r 'inner))
		  (begin
		    (outer-continue)
		    (unreachable))))))
	(r 'outer))
      #t)))


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

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

(if (provided? 'threads)
    (begin

      (with-test-prefix "parallel"
	(pass-if "no forms"
	  (call-with-values
	      (lambda ()
		(parallel))
	    (lambda ()
	      #t)))

	(pass-if "1"
	  (call-with-values
	      (lambda ()
		(parallel 1))
	    (lambda (x)
	      (equal? x 1))))

	(pass-if "1 2"
	  (call-with-values
	      (lambda ()
		(parallel 1 2))
	    (lambda (x y)
	      (and (equal? x 1)
		   (equal? y 2)))))

	(pass-if "1 2 3"
	  (call-with-values
	      (lambda ()
		(parallel 1 2 3))
	    (lambda (x y z)
	      (and (equal? x 1)
		   (equal? y 2)
		   (equal? z 3))))))

      ;;
      ;; n-par-for-each
      ;;

      (with-test-prefix "n-par-for-each"

	(pass-if "0 in limit 10"
	  (n-par-for-each 10 noop '())
	  #t)

	(pass-if "6 in limit 10"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 10 (lambda (n)
				 (vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 1"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 1 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 2"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 2 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t))))

	(pass-if "6 in limit 3"
	  (let ((v (make-vector 6 #f)))
	    (n-par-for-each 3 (lambda (n)
				(vector-set! v n #t))
			    '(0 1 2 3 4 5))
	    (equal? v '#(#t #t #t #t #t #t)))))

      ;;
      ;; n-for-each-par-map
      ;;

      (with-test-prefix "n-for-each-par-map"

	(pass-if "0 in limit 10"
	  (n-for-each-par-map 10 noop noop '())
	  #t)

	(pass-if "6 in limit 10"
	  (let ((result '()))
	    (n-for-each-par-map 10
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 1"
	  (let ((result '()))
	    (n-for-each-par-map 1
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 2"
	  (let ((result '()))
	    (n-for-each-par-map 2
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0))))

	(pass-if "6 in limit 3"
	  (let ((result '()))
	    (n-for-each-par-map 3
				(lambda (n) (set! result (cons n result)))
				(lambda (n) (* 2 n))
				'(0 1 2 3 4 5))
	    (equal? result '(10 8 6 4 2 0)))))

      ;;
      ;; thread joining
      ;;

      (with-test-prefix "joining"

	;; scm_join_thread has a SCM_TICK in the middle of it, to
	;; allow asyncs to run (including signal delivery).  We used
	;; to have a bug whereby if the joined thread terminated at
	;; the same time as the joining thread is in this SCM_TICK,
	;; scm_join_thread would not notice and would hang forever.
	;; So in this test we are setting up the following sequence of
	;; events.
        ;;   T=0  other thread is created and starts running
	;;   T=2  main thread sets up an async that will sleep for 10 seconds
        ;;   T=2  main thread calls join-thread, which will...
        ;;   T=2  ...call the async, which starts sleeping
        ;;   T=5  other thread finishes its work and terminates
        ;;   T=7  async completes, main thread continues inside join-thread.
	(pass-if "don't hang when joined thread terminates in SCM_TICK"
	  (let ((other-thread (make-thread sleep 5)))
	    (letrec ((delay-count 10)
		     (aproc (lambda ()
			      (set! delay-count (- delay-count 1))
			      (if (zero? delay-count)
				  (sleep 5)
				  (system-async-mark aproc)))))
	      (sleep 2)
	      (system-async-mark aproc)
	      (join-thread other-thread)))
	  #t))))


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

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

;;;
;;; gmtime
;;;

(with-test-prefix "gmtime"

  (for-each (lambda (t)
	      (pass-if (list "in another thread after error" t)
		(or (provided? 'threads) (throw 'unsupported))

		(alarm 5)
		(false-if-exception (gmtime t))
		(join-thread (begin-thread (catch #t
					     (lambda () (gmtime t))
					     (lambda args #f))))
		(alarm 0)
		#t))

	    ;; time values that might provoke an error from libc
	    ;; on 32-bit glibc all values (which fit) are fine
	    ;; on 64-bit glibc apparently 2^63 can overflow a 32-bit tm_year
	    (list (1- (ash 1 31)) (1- (ash 1 63))
		  -1 (- (ash 1 31)) (- (ash 1 63)))))

;;;
;;; internal-time-units-per-second
;;;

(with-test-prefix "internal-time-units-per-second"

  ;; Check that sleep 1 gives about internal-time-units-per-second worth of
  ;; elapsed time from times:clock.  This mainly ensures
  ;; internal-time-units-per-second correctly indicates CLK_TCK units.
  ;;
  (pass-if "versus times and sleep"
    (or (defined? 'times) (throw 'unsupported))

    (let ((old (times)))
      (sleep 1)
      (let* ((new (times))
	     (elapsed (- (tms:clock new) (tms:clock old))))
	(<= (* 0.5 internal-time-units-per-second)
	    elapsed
	    (* 2 internal-time-units-per-second))))))

;;;
;;; localtime
;;;

(with-test-prefix "localtime"

  ;; gmtoff is calculated with some explicit code, try to exercise that
  ;; here, looking at cases where the localtime and gmtime are within the same
  ;; day, or crossing midnight, or crossing new year

  (pass-if "gmtoff of EST+5 at GMT 10:00am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 10)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "EST+5")))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing forward over day boundary
  (pass-if "gmtoff of EST+5 at GMT 3am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "EST+5")))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at GMT 10pm on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "AST-10")))
	(eqv? (* -10 3600) (tm:gmtoff tm)))))

  ;; crossing forward over year boundary
  (pass-if "gmtoff of EST+5 at GMT 3am on 1 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 1)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "EST+5")))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at GMT 10pm on 31 Dec 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 31)
      (set-tm:mon  tm 11)
      (set-tm:year tm 100)
      (let* ((t  (car (mktime tm "GMT")))
	     (tm (localtime t "AST-10")))
	(eqv? (* -10 3600) (tm:gmtoff tm))))))

;;;
;;; mktime
;;;

(with-test-prefix "mktime"

  ;; gmtoff is calculated with some explicit code, try to exercise that
  ;; here, looking at cases where the mktime and gmtime are within the same
  ;; day, or crossing midnight, or crossing new year

  (pass-if "gmtoff of EST+5 at 10:00am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 10)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "EST+5"))))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing forward over day boundary
  (pass-if "gmtoff of EST+5 at 10:00pm on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "EST+5"))))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at 3:00am on 10 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 10)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "AST-10"))))
	(eqv? (* -10 3600) (tm:gmtoff tm)))))

  ;; crossing forward over year boundary
  (pass-if "gmtoff of EST+5 at 10:00pm on 31 Dec 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 22)
      (set-tm:mday tm 31)
      (set-tm:mon  tm 11)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "EST+5"))))
	(eqv? (* 5 3600) (tm:gmtoff tm)))))

  ;; crossing backward over day boundary
  (pass-if "gmtoff of AST-10 at 3:00am on 1 Jan 2000"
    (let ((tm (gmtime 0)))
      (set-tm:hour tm 3)
      (set-tm:mday tm 1)
      (set-tm:mon  tm 0)
      (set-tm:year tm 100)
      (let ((tm (cdr (mktime tm "AST-10"))))
	(eqv? (* -10 3600) (tm:gmtoff tm))))))

;;;
;;; strftime
;;;

(with-test-prefix "strftime"

  ;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX.
  ;; If localtime is in daylight savings then it will decide there's no
  ;; daylight savings zone name for the fake ZOW, and come back empty.
  ;;
  ;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone
  ;; field in struct tm passed by guile.  That behaviour is reasonable
  ;; enough since that field is not in C99 so a C99 program won't know it
  ;; has to be set.  For the details on that see
  ;;
  ;;     http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722
  ;;
  ;; Not sure what to do about this in guile, it'd be nice for %Z to look at
  ;; tm:zone everywhere.
  ;;
  ;;
  ;; (pass-if "strftime %Z doesn't return garbage"
  ;; 	 (let ((t (localtime (current-time))))
  ;; 	   (set-tm:zone t "ZOW")
  ;; 	   (set-tm:isdst t 0)
  ;; 	   (string=? (strftime "%Z" t)
  ;; 		     "ZOW")))

  (with-test-prefix "C99 %z format"

    ;; C99 spec is empty string if no zone determinable
    ;;
    ;; On pre-C99 systems not sure what to expect if %z unsupported, probably
    ;; "%z" unchanged in C99 if timezone.  On AIX and Tru64 5.1b, it returns
    ;; a string such as "GMT" or "EST", instead of "+0000" or "-0500".  See
    ;; https://savannah.gnu.org/bugs/index.php?24130 for details.
    ;;
    (define have-strftime-%z
      (equal? (strftime "%z" (gmtime 0)) "+0000"))

    ;; %z here is quite possibly affected by the same tm:gmtoff vs current
    ;; zone as %Z above is, so in the following tests we make them the same.

    (pass-if "GMT"
      (or have-strftime-%z (throw 'unsupported))
      (putenv "TZ=GMT+0")
      (tzset)
      (let ((tm (localtime 86400)))
	(string=? "+0000" (strftime "%z" tm))))

    ;; prior to guile 1.6.9 and 1.8.1 this test failed, getting "+0500",
    ;; because we didn't adjust for tm:gmtoff being west of Greenwich versus
    ;; tm_gmtoff being east of Greenwich
    (pass-if "EST+5"
      (or have-strftime-%z (throw 'unsupported))
      (putenv "TZ=EST+5")
      (tzset)
      (let ((tm (localtime 86400)))
	(string=? "-0500" (strftime "%z" tm))))))

;;;
;;; strptime
;;;

(with-test-prefix "strptime"

  (pass-if "in another thread after error"
    (or (defined? 'strptime) (throw 'unsupported))
    (or (provided? 'threads) (throw 'unsupported))

    (alarm 5)
    (false-if-exception
     (strptime "%a" "nosuchday"))
    (join-thread (begin-thread (strptime "%d" "1")))
    (alarm 0)
    #t)

  (with-test-prefix "GNU %s format"

    ;; "%s" to parse a count of seconds since 1970 is a GNU extension
    (define have-strptime-%s
      (false-if-exception (strptime "%s" "0")))

    (pass-if "gmtoff on GMT"
      (or have-strptime-%s (throw 'unsupported))
      (putenv "TZ=GMT+0")
      (tzset)
      (let ((tm (car (strptime "%s" "86400"))))
	(eqv? 0 (tm:gmtoff tm))))

    ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from
    ;; strptime
    (pass-if "gmtoff on EST+5"
      (or have-strptime-%s (throw 'unsupported))
      (putenv "TZ=EST+5")
      (tzset)
      (let ((tm (car (strptime "%s" "86400"))))
	(eqv? (* 5 3600) (tm:gmtoff tm))))))