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

;; SRFI-19 overrides current-date, so we have to do the test in a
;; separate module, or later tests will fail.

(define-module (test-suite test-srfi-19)
  :duplicates (last)  ;; avoid warning about srfi-19 replacing `current-time'
  :use-module (test-suite lib)
  :use-module (srfi srfi-19)
  :use-module (ice-9 format))

;; Make sure we use the default locale.
(setlocale LC_ALL "C")

(define (with-tz* tz thunk)
  "Temporarily set the TZ environment variable to the passed string
value and call THUNK."
  (let ((old-tz #f))
    (dynamic-wind
	(lambda ()
	  (set! old-tz (getenv "TZ"))
	  (putenv (format "TZ=~A" tz)))
	thunk
	(lambda ()
	  (if old-tz
	      (putenv (format "TZ=~A" old-tz))
	      (putenv "TZ"))))))

(defmacro with-tz (tz . body)
  `(with-tz* ,tz (lambda () ,@body)))

(define (test-integral-time-structure date->time)
  "Test whether the given DATE->TIME procedure creates a time
structure with integral seconds.  (The seconds shall be maintained as
integers, or precision may go away silently.  The SRFI-19 reference
implementation was not OK for Guile in this respect because of Guile's
incomplete numerical tower implementation.)"
  (pass-if (format "~A makes integer seconds"
		   date->time)
	   (exact? (time-second
		    (date->time (make-date 0 0 0 12 1 6 2001 0))))))

(define (test-time->date time->date date->time)
  (pass-if (format "~A works"
		   time->date)
	   (begin
	     (time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
	     #t)))

(define (test-dst time->date date->time)
  (pass-if (format "~A respects local DST if no TZ-OFFSET given"
		   time->date)
	   (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
	     ;; on 2001-06-01, there should be 4 hours zone offset
	     ;; between EST (EDT) and GMT
	     (= (date-zone-offset
		 (with-tz "EST5EDT"
		   (time->date time)))
		-14400))))

(define-macro (test-time-conversion a b)
  (let* ((a->b-sym (symbol-append a '-> b))
	 (b->a-sym (symbol-append b '-> a)))
    `(pass-if (format "~A and ~A work and are inverses of each other"
		      ',a->b-sym ',b->a-sym)
	      (let ((time (make-time ,a 12345 67890123)))
		(time=? time (,b->a-sym (,a->b-sym time)))))))

(define (test-time-comparison cmp a b)
  (pass-if (format #f "~A works" cmp)
           (cmp a b)))

(define (test-time-arithmetic op a b res)
  (pass-if (format #f "~A works" op)
           (time=? (op a b) res)))

;; return true if time objects X and Y are equal
(define (time-equal? x y)
  (and (eq?  (time-type x)       (time-type y))
       (eqv? (time-second x)     (time-second y))
       (eqv? (time-nanosecond x) (time-nanosecond y))))

(with-test-prefix "SRFI date/time library"
  ;; check for typos and silly errors
  (pass-if "date-zone-offset is defined"
	   (and (defined? 'date-zone-offset)
		date-zone-offset
		#t))
  (pass-if "add-duration is defined"
	   (and (defined? 'add-duration)
		add-duration
		#t))
  (pass-if "(current-time time-tai) works"
	   (time? (current-time time-tai)))
  (pass-if "(current-time time-process) works"
           (time? (current-time time-process)))
  (test-time-conversion time-utc time-tai)
  (test-time-conversion time-utc time-monotonic)
  (test-time-conversion time-tai time-monotonic)
  (pass-if "string->date works"
	   (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
		  #t))
  ;; check for code paths where reals were passed to quotient, which
  ;; doesn't work in Guile (and is unspecified in R5RS)
  (test-time->date time-utc->date date->time-utc)
  (test-time->date time-tai->date date->time-tai)
  (test-time->date time-monotonic->date date->time-monotonic)
  (pass-if "Fractional nanoseconds are handled"
	   (begin (make-time time-duration 1000000000.5 0) #t))
  ;; the seconds in a time shall be maintained as integers, or
  ;; precision may silently go away
  (test-integral-time-structure date->time-utc)
  (test-integral-time-structure date->time-tai)
  (test-integral-time-structure date->time-monotonic)
  ;; check for DST and zone related problems
  (pass-if "date->time-utc is the inverse of time-utc->date"
	   (let ((time (date->time-utc
			(make-date 0 0 0 14 1 6 2001 7200))))
	     (time=? time
		     (date->time-utc (time-utc->date time 7200)))))
  (test-dst time-utc->date date->time-utc)
  (test-dst time-tai->date date->time-tai)
  (test-dst time-monotonic->date date->time-monotonic)
  (test-dst julian-day->date date->julian-day)
  (test-dst modified-julian-day->date date->modified-julian-day)

  (pass-if "`date->julian-day' honors timezone"
    (let ((now (current-date -14400)))
      (time=? (date->time-utc (julian-day->date (date->julian-day now)))
              (date->time-utc now))))

  (pass-if "string->date respects local DST if no time zone is read"
	   (time=? (date->time-utc
		    (with-tz "EST5EDT"
		      (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
		   (date->time-utc
		    (make-date 0 0 0 12 1 6 2001 0))))
  (pass-if "string->date understands days and months"
           (time=? (let ((d (string->date "Saturday, December 9, 2006"
                                          "~A, ~B ~d, ~Y")))
                     (date->time-utc (make-date (date-nanosecond d)
                                                (date-second d)
                                                (date-minute d)
                                                (date-hour d)
                                                (date-day d)
                                                (date-month d)
                                                (date-year d)
                                                0)))
                   (date->time-utc
                    (make-date 0 0 0 0 9 12 2006 0))))

  (pass-if "string->date works on Sunday"
    ;; `string->date' never rests!
    (let* ((str  "Sun, 05 Jun 2005 18:33:00 +0200")
           (date (string->date str "~a, ~d ~b ~Y ~H:~M:~S ~z")))
      (equal? "Sun Jun 05 18:33:00+0200 2005"
              (date->string date))))

  ;; check time comparison procedures
  (let* ((time1 (make-time time-monotonic 0 0))
         (time2 (make-time time-monotonic 0 0))
         (time3 (make-time time-monotonic 385907 998360432))
         (time4 (make-time time-monotonic 385907 998360432)))
    (test-time-comparison time<=? time1 time3)
    (test-time-comparison time<?  time1 time3)
    (test-time-comparison time=?  time1 time2)
    (test-time-comparison time>=? time3 time3)
    (test-time-comparison time>?  time3 time2))
  ;; check time arithmetic procedures
  (let* ((time1 (make-time time-monotonic 0 0))
         (time2 (make-time time-monotonic 385907 998360432))
         (diff (time-difference time2 time1)))
    (test-time-arithmetic add-duration time1 diff time2)
    (test-time-arithmetic subtract-duration time2 diff time1))

  (with-test-prefix "date->time-tai"
    ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
    ;; seconds of TAI in date->time-tai
    (pass-if "31dec98 23:59:59"
      (time-equal? (make-time time-tai 0 915148830)
		   (date->time-tai (make-date 0 59 59 23 31 12 1998 0))))
    (pass-if "1jan99 0:00:00"
      (time-equal? (make-time time-tai 0 915148832)
		   (date->time-tai (make-date 0 0  0  0   1  1 1999 0))))

    ;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2
    ;; seconds of TAI in date->time-tai
    (pass-if "31dec05 23:59:59"
      (time-equal? (make-time time-tai 0 1136073631)
		   (date->time-tai (make-date 0 59 59 23 31 12 2005 0))))
    (pass-if "1jan06 0:00:00"
      (time-equal? (make-time time-tai 0 1136073633)
		   (date->time-tai (make-date 0 0  0  0   1  1 2006 0)))))

  (with-test-prefix "date-week-number"
    (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
    (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))
    (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))))

;; Local Variables:
;; eval: (put 'with-tz 'scheme-indent-function 1)
;; End:


code:
; CONFIDENCE TEST FOR IMPLEMENTATION OF SRFI-26
; =============================================
;
; Sebastian.Egner@philips.com, 3-Jun-2002.
;
; This file checks a few assertions about the implementation.
; If you run it and no error message is issued, the implementation
; is correct on the cases that have been tested.
;
; compliance:
;   Scheme R5RS with
;     SRFI-23: error
;
; loading this file into Scheme 48 0.57 after 'cut.scm' has been loaded:
;   ,open srfi-23
;   ,load check.scm

; (check expr)
;    evals expr and issues an error if it is not #t.

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

(define (check expr)
  (pass-if "cut/cute" (eval expr (interaction-environment))))

; (check-all)
;    runs several tests on cut and reports.

(define (check-all)
  (for-each
   check
   '( ; cuts
     (equal? ((cut list)) '())
     (equal? ((cut list <...>)) '())
     (equal? ((cut list 1)) '(1))
     (equal? ((cut list <>) 1) '(1))
     (equal? ((cut list <...>) 1) '(1))
     (equal? ((cut list 1 2)) '(1 2))
     (equal? ((cut list 1 <>) 2) '(1 2))
     (equal? ((cut list 1 <...>) 2) '(1 2))
     (equal? ((cut list 1 <...>) 2 3 4) '(1 2 3 4))
     (equal? ((cut list 1 <> 3 <>) 2 4) '(1 2 3 4))
     (equal? ((cut list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
     (equal? (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y)) '(ok))
     (equal?
      (let ((a 0))
	(map (cut + (begin (set! a (+ a 1)) a) <>)
	     '(1 2))
	a)
      2)
      ; cutes
     (equal? ((cute list)) '())
     (equal? ((cute list <...>)) '())
     (equal? ((cute list 1)) '(1))
     (equal? ((cute list <>) 1) '(1))
     (equal? ((cute list <...>) 1) '(1))
     (equal? ((cute list 1 2)) '(1 2))
     (equal? ((cute list 1 <>) 2) '(1 2))
     (equal? ((cute list 1 <...>) 2) '(1 2))
     (equal? ((cute list 1 <...>) 2 3 4) '(1 2 3 4))
     (equal? ((cute list 1 <> 3 <>) 2 4) '(1 2 3 4))
     (equal? ((cute list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
     (equal?
      (let ((a 0))
	(map (cute + (begin (set! a (+ a 1)) a) <>)
	     '(1 2))
	a)
      1))))

; run the checks when loading
(with-test-prefix "SRFI-26"
  (check-all))

license: mit


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

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

(with-test-prefix "rec special form"

  (pass-if-exception "bogus variable" '(misc-error . ".*")
    (eval '(rec #:foo) (current-module)))

  (pass-if "rec expressions"
    (let ((ones-list (rec ones (cons 1 (delay ones)))))
      (and (= 1 (car ones-list))
           (= 1 (car (force (cdr ones-list)))))))

  (pass-if "rec functions"
    (let ((test-func (rec (add-upto n)
                       (if (positive? n)
                           (+ n (add-upto (- n 1)))
                           0))))
      (= 15 (test-func 5)))))


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

(define-module (test-suite test-srfi-34)
  :duplicates (last)  ;; avoid warning about srfi-34 replacing `raise'
  :use-module (test-suite lib)
  :use-module (srfi srfi-13)
  :use-module (srfi srfi-34))

(define (expr-prints-and-evals-to? expr printout result)
  (let ((actual-result *unspecified*))
    (let ((actual-printout
	   (string-trim-both
	    (with-output-to-string
	      (lambda ()
		(set! actual-result
		      (eval expr (current-module))))))))
      ;;(write (list actual-printout printout actual-result result))
      ;;(newline)
      (and (equal? actual-printout printout)
	   (equal? actual-result result)))))

(with-test-prefix "SRFI 34"

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

  (pass-if "example 1"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "condition: ")
					  (write x)
					  (newline)
					  (k 'exception))
					(lambda ()
					  (+ 1 (raise 'an-error))))))
	    "condition: an-error"
	    'exception))

  ;; SRFI 34 specifies that the behaviour of the call/cc expression
  ;; after printing "something went wrong" is unspecified, which is
  ;; tricky to test for in a positive way ...  Guile behaviour at time
  ;; of writing is to signal a "lazy-catch handler did return" error,
  ;; which feels about right to me.
  (pass-if "example 2"
	   (expr-prints-and-evals-to?
	    '(false-if-exception
	      (call-with-current-continuation
	       (lambda (k)
		 (with-exception-handler (lambda (x)
					   (display "something went wrong")
					   (newline)
					   'dont-care)
					 (lambda ()
					   (+ 1 (raise 'an-error)))))))
	    "something went wrong"
	    #f))

  (pass-if "example 3"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     (else
		      (display "condition: ")
		      (write condition)
		      (newline)
		      'exception))
		    (+ 1 (raise 'an-error)))
	    "condition: an-error"
	    'exception))

  (pass-if "example 4"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     (else
		      (display "something went wrong")
		      (newline)
		      'dont-care))
		    (+ 1 (raise 'an-error)))
	    "something went wrong"
	    'dont-care))

  (pass-if "example 5"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "reraised ") (write x) (newline)
					  (k 'zero))
					(lambda ()
					  (guard (condition
						  ((positive? condition) 'positive)
						  ((negative? condition) 'negative))
						 (raise 1))))))
	    ""
	    'positive))

  (pass-if "example 6"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "reraised ") (write x) (newline)
					  (k 'zero))
					(lambda ()
					  (guard (condition
						  ((positive? condition) 'positive)
						  ((negative? condition) 'negative))
						 (raise -1))))))
	    ""
	    'negative))

  (pass-if "example 7"
	   (expr-prints-and-evals-to?
	    '(call-with-current-continuation
	      (lambda (k)
		(with-exception-handler (lambda (x)
					  (display "reraised ") (write x) (newline)
					  (k 'zero))
					(lambda ()
					  (guard (condition
						  ((positive? condition) 'positive)
						  ((negative? condition) 'negative))
						 (raise 0))))))
	    "reraised 0"
	    'zero))

  (pass-if "example 8"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     ((assq 'a condition) => cdr)
		     ((assq 'b condition)))
		    (raise (list (cons 'a 42))))
	    ""
	    42))

  (pass-if "example 9"
	   (expr-prints-and-evals-to?
	    '(guard (condition
		     ((assq 'a condition) => cdr)
		     ((assq 'b condition)))
		    (raise (list (cons 'b 23))))
	    ""
	    '(b . 23)))

  (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
           ;; In Guile 1.8.5 and earlier, unwinders would be called before
           ;; the exception handler, which reads "The handler is called in
           ;; the dynamic environment of the call to `raise'".
           (call/cc
            (lambda (return)
              (let ((inside? #f))
                (with-exception-handler
                 (lambda (c)
                   ;; This handler must be called before the unwinder below.
                   (return inside?))
                 (lambda ()
                   (dynamic-wind
                     (lambda ()
                       (set! inside? #t))
                     (lambda ()
                       (raise 'some-exception))
                     (lambda ()
                       ;; This unwinder should not be executed before the
                       ;; handler is called.
                       (set! inside? #f))))))))))


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

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

(with-test-prefix "cond-expand"
  (pass-if "srfi-35"
    (cond-expand (srfi-35 #t)
                 (else    #f))))

(with-test-prefix "condition types"
  (pass-if "&condition"
    (condition-type? &condition))

  (pass-if "make-condition-type"
    (condition-type? (make-condition-type 'foo &condition '(a b))))

  (pass-if "struct-vtable-name"
    (let ((ct  (make-condition-type 'chbouib &condition '(a b))))
      (eq? 'chbouib (struct-vtable-name ct)))))

(with-test-prefix "conditions"

  (pass-if "&condition"
    (let ((c (make-condition &condition)))
      (and (condition? c)
           (condition-has-type? c &condition))))

  (pass-if "simple condition"
    (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
           (c  (make-condition ct 'b 1 'a 0)))
      (and (condition? c)
           (condition-has-type? c ct))))

  (pass-if "simple condition with inheritance"
    (let* ((top (make-condition-type 'foo &condition '(a b)))
           (ct  (make-condition-type 'bar top '(c d)))
           (c   (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
      (and (condition? c)
           (condition-has-type? c ct)
           (condition-has-type? c top))))

  (pass-if "condition-ref"
    (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
           (c  (make-condition ct 'b 1 'a 0)))
      (and (eq? (condition-ref c 'a) 0)
           (eq? (condition-ref c 'b) 1))))

  (pass-if "condition-ref with inheritance"
    (let* ((top (make-condition-type 'foo &condition '(a b)))
           (ct  (make-condition-type 'bar top '(c d)))
           (c   (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
      (and (eq? (condition-ref c 'a) 0)
           (eq? (condition-ref c 'b) 1)
           (eq? (condition-ref c 'c) 2)
           (eq? (condition-ref c 'd) 3))))

  (pass-if "extract-condition"
    (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
           (c  (make-condition ct 'b 1 'a 0)))
      (equal? c (extract-condition c ct)))))

(with-test-prefix "compound conditions"
  (pass-if "condition-has-type?"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (and (condition? c)
           (condition-has-type? c t1)
           (condition-has-type? c t2))))

  (pass-if "condition-ref"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (equal? (map (lambda (field)
                     (condition-ref c field))
                   '(a b c d))
              '(0 1 2 3))))

  (pass-if "condition-ref with same-named fields"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(a c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'a -1 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (equal? (map (lambda (field)
                     (condition-ref c field))
                   '(a b c d))
              '(0 1 2 3))))

  (pass-if "extract-condition"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (make-compound-condition c1 c2)))
      (and (equal? c1 (extract-condition c t1))
           (equal? c2 (extract-condition c t2)))))

  (pass-if "extract-condition with same-named fields"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(a c)))
           (c1 (make-condition t1 'a 0  'b 1))
           (c2 (make-condition t2 'a -1 'c 2))
           (c  (make-compound-condition c1 c2)))
      (and (equal? c1 (extract-condition c t1))
           (equal? c2 (extract-condition c t2))))))

(with-test-prefix "syntax"
  (pass-if "define-condition-type"
    (let ((m (current-module)))
      (eval '(define-condition-type &chbouib &condition
               chbouib?
               (one   chbouib-one)
               (two   chbouib-two))
            m)
      (eval '(and (condition-type? &chbouib)
                  (procedure? chbouib?)
                  (let ((c (make-condition &chbouib 'one 1 'two 2)))
                    (and (condition? c)
                         (chbouib? c)
                         (eq? (chbouib-one c) 1)
                         (eq? (chbouib-two c) 2))))
            m)))

  (pass-if "condition"
    (let* ((t (make-condition-type 'chbouib &condition '(a b)))
           (c (condition (t (b 2) (a 1)))))
      (and (condition? c)
           (condition-has-type? c t)
           (equal? (map (lambda (f)
                          (condition-ref c f))
                        '(a b))
                   '(1 2)))))

  (pass-if-exception "condition with missing fields"
    exception:miscellaneous-error
    (let ((t (make-condition-type 'chbouib &condition '(a b c))))
      (condition (t (a 1) (b 2)))))

  (pass-if "compound condition"
    (let* ((t1 (make-condition-type 'foo &condition '(a b)))
           (t2 (make-condition-type 'bar &condition '(c d)))
           (c1 (make-condition t1 'a 0 'b 1))
           (c2 (make-condition t2 'c 2 'd 3))
           (c  (condition (t1 (a 0) (b 1))
                          (t2 (c 2) (d 3)))))
      (and (equal? c1 (extract-condition c t1))
           (equal? c2 (extract-condition c t2))))))

;;;
;;; Examples from the SRFI.
;;;

(define-condition-type &c &condition
  c?
  (x c-x))

(define-condition-type &c1 &c
  c1?
  (a c1-a))

(define-condition-type &c2 &c
  c2?
  (b c2-b))

(define v1
  (make-condition &c1 'x "V1" 'a "a1"))

(define v2
  (condition (&c2 (x "V2") (b "b2"))))

(define v3
  (condition (&c1 (x "V3/1") (a "a3"))
             (&c2 (b "b3"))))

(define v4
  (make-compound-condition v1 v2))

(define v5
  (make-compound-condition v2 v3))

(with-test-prefix "examples"

  (pass-if "v1"
    (condition? v1))

  (pass-if "(c? v1)"
    (c? v1))

  (pass-if "(c1? v1)"
    (c1? v1))

  (pass-if "(not (c2? v1))"
    (not (c2? v1)))

  (pass-if "(c-x v1)"
    (equal? (c-x v1) "V1"))

  (pass-if "(c1-a v1)"
    (equal? (c1-a v1) "a1"))

  (pass-if "v2"
    (condition? v2))

  (pass-if "(c? v2)"
    (c? v2))

  (pass-if "(c2? v2)"
    (c2? v2))

  (pass-if "(not (c1? v2))"
    (not (c1? v2)))

  (pass-if "(c-x v2)"
    (equal? (c-x v2) "V2"))

  (pass-if "(c2-b v2)"
    (equal? (c2-b v2) "b2"))

  (pass-if "v3"
    (condition? v3))

  (pass-if "(c? v3)"
    (c? v3))

  (pass-if "(c1? v3)"
    (c1? v3))

  (pass-if "(c2? v3)"
    (c2? v3))

  (pass-if "(c-x v3)"
    (equal? (c-x v3) "V3/1"))

  (pass-if "(c1-a v3)"
    (equal? (c1-a v3) "a3"))

  (pass-if "(c2-b v3)"
    (equal? (c2-b v3) "b3"))

  (pass-if "v4"
    (condition? v4))

  (pass-if "(c? v4)"
    (c? v4))

  (pass-if "(c1? v4)"
    (c1? v4))

  (pass-if "(c2? v4)"
    (c2? v4))

  (pass-if "(c-x v4)"
    (equal? (c-x v4) "V1"))

  (pass-if "(c1-a v4)"
    (equal? (c1-a v4) "a1"))

  (pass-if "(c2-b v4)"
    (equal? (c2-b v4) "b2"))

  (pass-if "v5"
    (condition? v5))

  (pass-if "(c? v5)"
    (c? v5))

  (pass-if "(c1? v5)"
    (c1? v5))

  (pass-if "(c2? v5)"
    (c2? v5))

  (pass-if "(c-x v5)"
    (equal? (c-x v5) "V2"))

  (pass-if "(c1-a v5)"
    (equal? (c1-a v5) "a3"))

  (pass-if "(c2-b v5)"
    (equal? (c2-b v5) "b2")))


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

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

(with-test-prefix "SRFI-37"

  (pass-if "empty calls with count-modified seeds"
    (equal? (list 21 42)
	    (call-with-values
		(lambda ()
		  (args-fold '("1" "3" "4") '()
			     (lambda (opt name arg seed seed2)
			       (values 1 2))
			     (lambda (op seed seed2)
			       (values (1+ seed) (+ 2 seed2)))
			     18 36))
	      list)))

  (pass-if "short opt params"
    (let ((a-set #f) (b-set #f) (c-val #f) (d-val #f) (no-fail #t) (no-operands #t))
      (args-fold '("-abcdoit" "-ad" "whatev")
		 (list (option '(#\a) #f #f (lambda (opt name arg)
					      (set! a-set #t)
					      (values)))
		       (option '(#\b) #f #f (lambda (opt name arg)
					      (set! b-set #t)
					      (values)))
		       (option '("cdoit" #\c) #f #t
			       (lambda (opt name arg)
				 (set! c-val arg)
				 (values)))
		       (option '(#\d) #f #t
			       (lambda (opt name arg)
				 (set! d-val arg)
				 (values))))
		 (lambda (opt name arg) (set! no-fail #f) (values))
		 (lambda (oper) (set! no-operands #f) (values)))
      (equal? '(#t #t "doit" "whatev" #t #t)
	      (list a-set b-set c-val d-val no-fail no-operands))))

  (pass-if "single unrecognized long-opt"
    (equal? "fake"
	    (args-fold '("--fake" "-i2")
		       (list (option '(#\i) #t #f
				     (lambda (opt name arg k) k)))
		       (lambda (opt name arg k) name)
		       (lambda (operand k) #f)
		       #f)))

  (pass-if "long req'd/optional"
    (equal? '(#f "bsquare" "apple")
	    (args-fold '("--x=pple" "--y=square" "--y")
		       (list (option '("x") #t #f
				     (lambda (opt name arg k)
				       (cons (string-append "a" arg) k)))
			     (option '("y") #f #t
				     (lambda (opt name arg k)
				       (cons (if arg
						 (string-append "b" arg)
						 #f) k))))
		       (lambda (opt name arg k) #f)
		       (lambda (opt name arg k) #f)
		       '())))

  ;; this matches behavior of getopt_long in libc 2.4
  (pass-if "short options absorb special markers in the next arg"
    (let ((arg-proc (lambda (opt name arg k)
		      (acons name arg k))))
      (equal? '((#\y . "-z") (#\x . "--") (#\z . #f))
	      (args-fold '("-zx" "--" "-y" "-z" "--")
			 (list (option '(#\x) #f #t arg-proc)
			       (option '(#\z) #f #f arg-proc)
			       (option '(#\y) #t #f arg-proc))
			 (lambda (opt name arg k) #f)
			 (lambda (opt name arg k) #f)
			 '()))))

  (pass-if "short options without arguments"
    ;; In Guile 1.8.4 and earlier, using short names of argument-less options
    ;; would lead to a stack overflow.
    (let ((arg-proc (lambda (opt name arg k)
		      (acons name arg k))))
      (equal? '((#\x . #f))
	      (args-fold '("-x")
			 (list (option '(#\x) #f #f arg-proc))
			 (lambda (opt name arg k) #f)
			 (lambda (opt name arg k) #f)
			 '()))))

)


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

(define-module (test-srfi-39)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-39)
  #:duplicates (last) ;; avoid warning about srfi-34 replacing `raise'
  )

(define a (make-parameter 3))
(define b (make-parameter 4))

(define (check a b a-val b-val)
  (and (eqv? (a) a-val)) (eqv? (b) b-val))

(define c (make-parameter 2 (lambda (x) (if (< x 10) x 10))))
(define d (make-parameter 15 (lambda (x) (if (< x 10) x 10))))

(with-test-prefix "SRFI-39"

  (pass-if "test 1"
    (check a b 3 4))

  (pass-if "test 2"
    (parameterize ((a 2) (b 1))
      (and (check a b 2 1)
	   (parameterize ((b 8))
	     (check a b 2 8)))))

  (pass-if "test 3"
    (check a b 3 4))

  (pass-if "test 4"
    (check c d 2 10))

  (pass-if "test 5"
    (parameterize ((a 0) (b 1) (c 98) (d 9))
      (and (check a b 0 1)
           (check c d 10 9)
           (parameterize ((c (a)) (d (b)))
	     (and (check a b 0 1)
		  (check c d 0 1))))))

  (pass-if "SRFI-34"
    (let ((inside? (make-parameter #f)))
      (call/cc (lambda (return)
                 (with-exception-handler
                  (lambda (c)
                    ;; This handler should be called in the dynamic
                    ;; environment installed by `parameterize'.
                    (return (inside?)))
                  (lambda ()
                    (parameterize ((inside? #t))
                      (raise 'some-exception)))))))))

(let ()
  (define (test-ports param new-port new-port-2)
    (let ((old-port (param)))

      (pass-if "new value"
	(parameterize ((param new-port))
	  (eq? (param) new-port)))

      (pass-if "set value"
	(parameterize ((param old-port))
	  (param new-port)
	  (eq? (param) new-port)))

      (pass-if "old restored"
	(parameterize ((param new-port))
	  #f)
	(eq? (param) old-port))

      (pass-if "throw exit"
	(catch 'bail
	  (lambda ()
	    (parameterize ((param new-port))
	      (throw 'bail)))
	  (lambda args #f))
	(eq? (param) old-port))

      (pass-if "call/cc re-enter"
	(let ((cont  #f)
	      (count 0)
	      (port  #f)
	      (good  #t))
	  (parameterize ((param new-port))
	    (call/cc (lambda (k) (set! cont k)))
	    (set! count (1+ count))
	    (set! port (param))
	    (if (= 1 count) (param new-port-2)))
	  (set! good (and good (eq? (param) old-port)))
	  (case count
	    ((1)
	     (set! good (and good (eq? port new-port)))
	     ;; re-entering should give new-port-2 left there last time
	     (cont))
	    ((2)
	     (set! good (and good (eq? port new-port-2)))))
	  good))

      (pass-if "original unchanged"
	(eq? (param) old-port))))

  (with-test-prefix "current-input-port"
    (test-ports current-input-port
		(open-input-string "xyz") (open-input-string "xyz")))

  (with-test-prefix "current-output-port"
    (test-ports current-output-port
		(open-output-string) (open-output-string)))

  (with-test-prefix "current-error-port"
    (test-ports current-error-port
		(open-output-string) (open-output-string))))


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

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

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

  (pass-if "make-u8vector"
    (equal? (list->u8vector '(7 7 7 7))
            (make-u8vector 4 7))))

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

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

  (pass-if "make-s8vector"
    (equal? (list->s8vector '(7 7 7 7))
            (make-s8vector 4 7))))

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

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

  (pass-if "make-u16vector"
    (equal? (list->u16vector '(7 7 7 7))
            (make-u16vector 4 7))))

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

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

  (pass-if "make-s16vector"
    (equal? (list->s16vector '(7 7 7 7))
            (make-s16vector 4 7))))

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

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

  (pass-if "make-u32vector"
    (equal? (list->u32vector '(7 7 7 7))
            (make-u32vector 4 7))))

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

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

  (pass-if "make-s32vector"
    (equal? (list->s32vector '(7 7 7 7))
            (make-s32vector 4 7))))

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

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

  (pass-if "make-u64vector"
    (equal? (list->u64vector '(7 7 7 7))
            (make-u64vector 4 7))))

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

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

  (pass-if "make-s64vector"
    (equal? (list->s64vector '(7 7 7 7))
            (make-s64vector 4 7))))

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

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

  (pass-if "make-f32vector"
    (equal? (list->f32vector '(7 7 7 7))
            (make-f32vector 4 7))))

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

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

  (pass-if "make-f64vector"
    (equal? (list->f64vector '(7 7 7 7))
            (make-f64vector 4 7))))


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

(use-modules (test-suite lib))

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


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

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

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

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


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

(define-module (test-suite test-numbers)
  #:use-module (test-suite lib)
  #:use-module ((system base compile) #:select (compile))
  #:use-module (srfi srfi-9))

(define-record-type :qux (make-qux) qux?)

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

  ;; Constructors are defined using `define-integrable', meaning that direct
  ;; calls as in `(make-foo)' lead to a compile-time psyntax error, hence the
  ;; distinction below.

  (pass-if-exception "foo 0 args (inline)" exception:syntax-pattern-unmatched
     (compile '(make-foo) #:env (current-module)))
  (pass-if-exception "foo 2 args (inline)" exception:syntax-pattern-unmatched
     (compile '(make-foo 1 2) #:env (current-module)))

  (pass-if-exception "foo 0 args" exception:wrong-num-args
     (let ((make-foo make-foo))
       (make-foo)))
  (pass-if-exception "foo 2 args" exception:wrong-num-args
     (let ((make-foo make-foo))
       (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:
;;;; srfi-98.test --- Test suite for Guile's SRFI-98 functions. -*- scheme -*-
;;;;
;;;; Copyright 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

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

(with-test-prefix "get-environment-variable"
  (pass-if "get-environment-variable retrieves binding"
    (putenv "foo=bar")
    (equal? (get-environment-variable "foo") "bar"))

  (pass-if "get-environment-variable #f on unbound name"
    (unsetenv "foo")
    (not (get-environment-variable "foo"))))

(with-test-prefix "get-environment-variables"

  (pass-if "get-environment-variables contains binding"
    (putenv "foo=bar")
    (equal? (assoc-ref (get-environment-variables) "foo") "bar")))


code:
;; guile-lib                    -*- scheme -*-
;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this program; if not, contact:
;;
;; Free Software Foundation           Voice:  +1-617-542-5942
;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
;; Boston, MA  02111-1307,  USA       gnu@gnu.org

;;; Commentary:
;;
;; Unit tests for (debugging statprof).
;;
;;; Code:

(define-module (test-suite test-statprof)
  #:use-module (test-suite lib)
  #:use-module (system base compile)
  #:use-module (srfi srfi-1)
  #:use-module (statprof))

;; FIXME
(debug-enable 'debug)
(trap-enable 'traps)

(pass-if "statistical sample counts within expected range"
  (let ()
    ;; test to see that if we call 3 identical functions equally, they
    ;; show up equally in the call count, +/- 30%. it's a big range, and
    ;; I tried to do something more statistically valid, but failed (for
    ;; the moment).

    ;; make sure these are compiled so we're not swamped in `eval'
    (define (make-func)
      (compile '(lambda (n)
                  (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))))
    (define run-test
      (compile '(lambda (num-calls funcs)
                  (let loop ((x num-calls) (funcs funcs))
                    (cond
                     ((positive? x)
                      ((car funcs) x)
                      (loop (- x 1) (cdr funcs))))))))

    (let ((num-calls 40000)
          (funcs (circular-list (make-func) (make-func) (make-func))))

      ;; Run test. 10000 us == 100 Hz.
      (statprof-reset 0 10000 #f #f)
      (statprof-start)
      (run-test num-calls funcs)
      (statprof-stop)

      (let* ((a-data (statprof-proc-call-data (car funcs)))
             (b-data (statprof-proc-call-data (cadr funcs)))
             (c-data (statprof-proc-call-data (caddr funcs)))
             (samples (map statprof-call-data-cum-samples
                           (list a-data b-data c-data)))
             (average (/ (apply + samples) 3))
             (max-allowed-drift 0.30) ; 30%
             (diffs (map (lambda (x) (abs (- x average)))
                         samples))
             (max-diff (apply max diffs)))

        (let ((drift-fraction (/ max-diff average)))
          (or (< drift-fraction max-allowed-drift)
              ;; don't stop the the test suite for what statistically is
              ;; bound to happen.
              (throw 'unresolved (pk average drift-fraction))))))))

(pass-if "accurate call counting"
  (let ()
    ;; Test to see that if we call a function N times while the profiler
    ;; is active, it shows up N times.
    (let ((num-calls 200))

      (define (do-nothing n)
        (simple-format #f "FOO ~A\n" (+ n n)))

      (throw 'unresolved) ;; need to fix VM tracing.

      ;; Run test.
      (statprof-reset 0 50000 #t #f)
      (statprof-start)
      (let loop ((x num-calls))
        (cond
         ((positive? x)
          (do-nothing x)
          (loop (- x 1))
          #t)))
      (statprof-stop)

      ;;(statprof-display)

      ;; Check result.
      (let ((proc-data (statprof-proc-call-data do-nothing)))
        (and proc-data
             (= (statprof-call-data-calls proc-data)
                num-calls))))))


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

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

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

(define exception:read-only-string
  (cons 'misc-error "^string is read-only"))
(define exception:illegal-escape
  (cons 'read-error "illegal character in escape sequence"))
;; Wrong types may have either the 'wrong-type-arg key when
;; interpreted or 'vm-error when compiled.  This matches both.
(define exception:wrong-type-arg
  (cons #t "Wrong type"))

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

;;
;; string internals
;;

;; Some abbreviations
;; BMP - Basic Multilingual Plane (codepoints below U+FFFF)
;; SMP - Suplementary Multilingual Plane (codebpoints from U+10000 to U+1FFFF)

(with-test-prefix "string internals"

  (pass-if "new string starts at 1st char in stringbuf"
    (let ((s "abc"))
      (= 0 (assq-ref (%string-dump s) 'start))))

  (pass-if "length of new string same as stringbuf"
    (let ((s "def"))
      (= (string-length s) (assq-ref (%string-dump s) 'stringbuf-length))))

  (pass-if "contents of new string same as stringbuf"
    (let ((s "ghi"))
      (string=? s (assq-ref (%string-dump s) 'stringbuf-chars))))

  (pass-if "writable strings are not read-only"
    (let ((s "zyx"))
      (not (assq-ref (%string-dump s) 'read-only))))

  (pass-if "read-only strings are read-only"
    (let ((s (substring/read-only "zyx" 0)))
      (assq-ref (%string-dump s) 'read-only)))

  (pass-if "new Latin-1 encoded strings are not shared"
    (let ((s "abc"))
      (not (assq-ref (%string-dump s) 'stringbuf-shared))))

  (pass-if "new UCS-4 encoded strings are not shared"
    (let ((s "\u0100bc"))
      (not (assq-ref (%string-dump s) 'stringbuf-shared))))

  ;; Should this be true? It isn't currently true.
  (pass-if "null shared substrings are shared"
    (let* ((s1 "")
           (s2 (substring/shared s1 0 0)))
      (throw 'untested)
      (eq? (assq-ref (%string-dump s2) 'shared)
           s1)))

  (pass-if "ASCII shared substrings are shared"
    (let* ((s1 "foobar")
           (s2 (substring/shared s1 0 3)))
      (eq? (assq-ref (%string-dump s2) 'shared)
           s1)))

  (pass-if "BMP shared substrings are shared"
    (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
           (s2 (substring/shared s1 0 3)))
      (eq? (assq-ref (%string-dump s2) 'shared)
           s1)))

  (pass-if "null substrings are not shared"
    (let* ((s1 "")
           (s2 (substring s1 0 0)))
      (not (eq? (assq-ref (%string-dump s2) 'shared)
                s1))))

  (pass-if "ASCII substrings are not shared"
    (let* ((s1 "foobar")
           (s2 (substring s1 0 3)))
      (not (eq? (assq-ref (%string-dump s2) 'shared)
                s1))))

  (pass-if "BMP substrings are not shared"
    (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
           (s2 (substring s1 0 3)))
      (not (eq? (assq-ref (%string-dump s2) 'shared)
                s1))))

  (pass-if "ASCII substrings share stringbufs before copy-on-write"
    (let* ((s1 "foobar")
           (s2 (substring s1 0 3)))
      (assq-ref (%string-dump s1) 'stringbuf-shared)))

  (pass-if "BMP substrings share stringbufs before copy-on-write"
    (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
           (s2 (substring s1 0 3)))
      (assq-ref (%string-dump s1) 'stringbuf-shared)))

  (pass-if "ASCII substrings don't share stringbufs after copy-on-write"
    (let* ((s1 "foobar")
           (s2 (substring s1 0 3)))
      (string-set! s2 0 #\F)
      (not (assq-ref (%string-dump s2) 'stringbuf-shared))))

  (pass-if "BMP substrings don't share stringbufs after copy-on-write"
    (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
           (s2 (substring s1 0 3)))
      (string-set! s2 0 #\F)
      (not (assq-ref (%string-dump s2) 'stringbuf-shared))))

  (with-test-prefix "encodings"

    (pass-if "null strings are Latin-1 encoded"
      (let ((s ""))
        (not (assq-ref (%string-dump s) 'stringbuf-wide))))

    (pass-if "ASCII strings are Latin-1 encoded"
      (let ((s "jkl"))
        (not (assq-ref (%string-dump s) 'stringbuf-wide))))

    (pass-if "Latin-1 strings are Latin-1 encoded"
      (let ((s "\xC0\xC1\xC2"))
        (not (assq-ref (%string-dump s) 'stringbuf-wide))))

    (pass-if "BMP strings are UCS-4 encoded"
      (let ((s "\u0100\u0101\x0102"))
        (assq-ref (%string-dump s) 'stringbuf-wide)))

    (pass-if "SMP strings are UCS-4 encoded"
      (let ((s "\U010300\u010301\x010302"))
        (assq-ref (%string-dump s) 'stringbuf-wide)))

    (pass-if "null list->string is Latin-1 encoded"
      (let ((s (string-ints)))
        (not (assq-ref (%string-dump s) 'stringbuf-wide))))

    (pass-if "ASCII list->string is Latin-1 encoded"
      (let ((s (string-ints 65 66 67)))
        (not (assq-ref (%string-dump s) 'stringbuf-wide))))

    (pass-if "Latin-1 list->string is Latin-1 encoded"
      (let ((s (string-ints #xc0 #xc1 #xc2)))
        (not (assq-ref (%string-dump s) 'stringbuf-wide))))

    (pass-if "BMP list->string is UCS-4 encoded"
      (let ((s (string-ints #x0100 #x0101 #x0102)))
        (assq-ref (%string-dump s) 'stringbuf-wide)))

    (pass-if "SMP list->string is UCS-4 encoded"
      (let ((s (string-ints #x010300 #x010301 #x010302)))
        (assq-ref (%string-dump s) 'stringbuf-wide)))

    (pass-if "encoding of string not based on escape style"
      (let ((s "\U000040"))
        (not (assq-ref (%string-dump s) 'stringbuf-wide))))))

(with-test-prefix "escapes"

  (pass-if-exception "non-hex char in two-digit hex-escape"
    exception:illegal-escape
    (with-input-from-string "\"\\x0g\"" read))

  (pass-if-exception "non-hex char in four-digit hex-escape"
    exception:illegal-escape
    (with-input-from-string "\"\\u000g\"" read))

  (pass-if-exception "non-hex char in six-digit hex-escape"
    exception:illegal-escape
    (with-input-from-string "\"\\U00000g\"" read))

  (pass-if-exception "premature termination of two-digit hex-escape"
    exception:illegal-escape
    (with-input-from-string "\"\\x0\"" read))

  (pass-if-exception "premature termination of four-digit hex-escape"
    exception:illegal-escape
    (with-input-from-string "\"\\u000\"" read))

  (pass-if-exception "premature termination of six-digit hex-escape"
    exception:illegal-escape
    (with-input-from-string "\"\\U00000\"" read))

  (pass-if "extra hex digits ignored for two-digit hex escape"
    (eqv? (string-ref "--\xfff--" 2)
          (integer->char #xff)))

  (pass-if "extra hex digits ignored for four-digit hex escape"
    (eqv? (string-ref "--\u0100f--" 2)
          (integer->char #x0100)))

  (pass-if "extra hex digits ignored for six-digit hex escape"
    (eqv? (string-ref "--\U010300f--" 2)
          (integer->char #x010300)))

  (pass-if "escaped characters match non-escaped ASCII characters"
    (string=? "ABC" "\x41\u0042\U000043"))

  (pass-if "R5RS backslash escapes"
    (string=? "\"\\" (string #\" #\\)))

  (pass-if "R6RS backslash escapes"
    (string=? "\a\b\t\n\v\f\r"
              (string #\alarm #\backspace #\tab #\newline #\vtab
                      #\page #\return)))

  (pass-if "Guile extensions backslash escapes"
    (string=? "\0" (string #\nul))))

;;
;; string?
;;
(with-test-prefix "string?"

  (pass-if "string"
    (string? "abc"))

  (pass-if "symbol"
    (not (string? 'abc))))

;;
;; string-null?
;;

(with-test-prefix "string-null?"

  (pass-if "null string"
    (string-null? ""))

  (pass-if "non-null string"
    (not (string-null? "a")))

  (pass-if "respects \\0"
    (not (string-null? "\0")))

  (pass-if-exception "symbol"
    exception:wrong-type-arg
    (string-null? 'a)))

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

    (pass-if-exception "1st argument EOF"
      exception:wrong-type-arg
      (string=? (with-input-from-string "" read) "b"))

    (pass-if-exception "2nd argument EOF"
      exception:wrong-type-arg
      (string=? "a" (with-input-from-string "" read)))))

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

;;
;; Unicode string normalization forms
;;

;;
;; string-normalize-nfd
;;

(with-test-prefix "string-normalize-nfd"

  (pass-if "canonical decomposition is equal?"
    (equal? (string-normalize-nfd "\xe9") "\x65\u0301")))

;;
;; string-normalize-nfkd
;;

(with-test-prefix "string-normalize-nfkd"

  (pass-if "compatibility decomposition is equal?"
    (equal? (string-normalize-nfkd "\u1e9b\u0323") "s\u0323\u0307")))

;;
;; string-normalize-nfc
;;

(with-test-prefix "string-normalize-nfc"

  (pass-if "canonical composition is equal?"
    (equal? (string-normalize-nfc "\x65\u0301") "\xe9")))

;;
;; string-normalize-nfkc
;;

(with-test-prefix "string-normalize-nfkc"

  (pass-if "compatibility composition is equal?"
    (equal? (string-normalize-nfkc "\u1e9b\u0323") "\u1e69")))

;;
;; 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, ASCII char"
    (char=? (string-ref "GNU Guile" 4) #\G))

  (pass-if "regular string, hex escaped Latin-1 char"
    (char=? (string-ref "--\xff--" 2)
            (integer->char #xff)))

  (pass-if "regular string, hex escaped BMP char"
    (char=? (string-ref "--\u0100--" 2)
            (integer->char #x0100)))

  (pass-if "regular string, hex escaped SMP char"
    (char=? (string-ref "--\U010300--" 2)
            (integer->char #x010300))))

;;
;; 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, ASCII char"
    (let ((s (string-copy "GNU guile")))
      (string-set! s 4 #\G)
      (char=? (string-ref s 4) #\G)))

  (pass-if "regular string, Latin-1 char"
    (let ((s (string-copy "GNU guile")))
      (string-set! s 4 (integer->char #xfe))
      (char=? (string-ref s 4) (integer->char #xfe))))

  (pass-if "regular string, BMP char"
    (let ((s (string-copy "GNU guile")))
      (string-set! s 4 (integer->char #x0100))
      (char=? (string-ref s 4) (integer->char #x0100))))

  (pass-if "regular string, SMP char"
    (let ((s (string-copy "GNU guile")))
      (string-set! s 4 (integer->char #x010300))
      (char=? (string-ref s 4) (integer->char #x010300)))))

;;
;; list->string
;;
(with-test-prefix "string"

  (pass-if-exception "convert circular list to string"
     exception:wrong-type-arg
     (let ((foo (list #\a #\b #\c)))
       (set-cdr! (cddr foo) (cdr foo))
       (apply string foo))))

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

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

  (pass-if "struct-ref"
     (let ((ball (make-ball red "Alice")))
       (equal? (struct-ref ball 0) "Alice")))

  (pass-if "struct-set!"
     (let* ((v (make-vtable "pw"))
            (s (make-struct v 0))
            (r (struct-set! s 0 'a)))
       (eq? r
            (struct-ref s 0)
            'a)))

  (pass-if-exception "struct-ref out-of-range"
     exception:out-of-range
     (let* ((v (make-vtable "prpr"))
            (s (make-struct v 0 'a 'b)))
       (struct-ref s 2)))

  (pass-if-exception "struct-set! out-of-range"
     exception:out-of-range
     (let* ((v (make-vtable "pwpw"))
            (s (make-struct v 0 'a 'b)))
       (struct-set! s 2 'c))))

(with-test-prefix "equal?"

  (pass-if "simple structs"
     (let* ((vtable (make-vtable "pr"))
            (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")))))