code:
;;;; reader.test --- Reader test.    -*- coding: iso-8859-1; mode: scheme -*-
;;;;
;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; 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 reader)
  :use-module (srfi srfi-1)
  :use-module (test-suite lib))

(define exception:eof
  (cons 'read-error "end of file$"))
(define exception:unexpected-rparen
  (cons 'read-error "unexpected \")\"$"))
(define exception:unterminated-block-comment
  (cons 'read-error "unterminated `#. \\.\\.\\. .#' comment$"))
(define exception:unknown-character-name
  (cons 'read-error "unknown character name .*$"))
(define exception:unknown-sharp-object
  (cons 'read-error "Unknown # object: .*$"))
(define exception:eof-in-string
  (cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
  (cons 'read-error "illegal character in escape sequence: .*$"))
(define exception:missing-expression
  (cons 'read-error "no expression after #;"))
(define exception:mismatched-paren
  (cons 'read-error "mismatched close paren"))

(define (read-string s)
  (with-fluids ((%default-port-encoding #f))
    (with-input-from-string s (lambda () (read)))))

(define (with-read-options opts thunk)
  (let ((saved-options (read-options)))
    (dynamic-wind
        (lambda ()
          (read-options opts))
        thunk
        (lambda ()
          (read-options saved-options)))))

(with-test-prefix "reading"
  (pass-if "0"
    (equal? (read-string "0") 0))
  (pass-if "1++i"
    (equal? (read-string "1++i") '1++i))
  (pass-if "1+i+i"
    (equal? (read-string "1+i+i") '1+i+i))
  (pass-if "1+e10000i"
    (equal? (read-string "1+e10000i") '1+e10000i))

  ;; At one time the arg list for "Unknown # object: ~S" didn't make it out
  ;; of read.c.  Check that `format' can be applied to this error.
  (pass-if "error message on bad #"
    (catch #t
	   (lambda ()
	     (read-string "#ZZZ")
	     ;; oops, this # is supposed to be unrecognised
	     #f)
	   (lambda (key subr message args rest)
	     (apply format #f message args)
	     ;; message and args are ok
	     #t)))

  (pass-if "block comment"
    (equal? '(+ 1 2 3)
            (read-string "(+ 1 #! this is a\ncomment !# 2 3)")))

  (pass-if "block comment finishing s-exp"
    (equal? '(+ 2)
            (read-string "(+ 2 #! a comment\n!#\n) ")))

  (pass-if "R6RS lexeme comment"
    (equal? '(+ 1 2 3)
            (read-string "(+ 1 #!r6rs 2 3)")))

  (pass-if "partial R6RS lexeme comment"
    (equal? '(+ 1 2 3)
            (read-string "(+ 1 #!r6r !# 2 3)")))

  (pass-if "R6RS/SRFI-30 block comment"
    (equal? '(+ 1 2 3)
            (read-string "(+ 1 #| this is a\ncomment |# 2 3)")))

  (pass-if "R6RS/SRFI-30 nested block comment"
    (equal? '(a b c)
            (read-string "(a b c #| d #| e |# f |#)")))

  (pass-if "R6RS/SRFI-30 block comment syntax overridden"
    ;; To be compatible with 1.8 and earlier, we should be able to override
    ;; this syntax.
    (let ((rhp read-hash-procedures))
      (dynamic-wind
        (lambda ()
          (read-hash-extend #\| (lambda args 'not)))
        (lambda ()
          (fold (lambda (x y result)
                  (and result (eq? x y)))
                #t
                (read-string "(this is #| a comment)")
                `(this is not a comment)))
        (lambda ()
          (set! read-hash-procedures rhp)))))

  (pass-if "unprintable symbol"
    ;; The reader tolerates unprintable characters for symbols.
    (equal? (string->symbol "\x01\x02\x03")
            (read-string "\x01\x02\x03")))

  (pass-if "CR recognized as a token delimiter"
    ;; In 1.8.3, character 0x0d was not recognized as a delimiter.
    (equal? (read-string "one\x0dtwo") 'one))

  (pass-if "returned strings are mutable"
    ;; Per R5RS Section 3.4, "Storage Model", `read' is supposed to return
    ;; mutable objects.
    (let ((str (with-input-from-string "\"hello, world\"" read)))
      (string-set! str 0 #\H)
      (string=? str "Hello, world")))

  (pass-if "square brackets are parens"
    (equal? '() (read-string "[]")))

  (pass-if-exception "paren mismatch" exception:unexpected-rparen
                     (read-string "'[)"))

  (pass-if-exception "paren mismatch (2)" exception:mismatched-paren
                     (read-string "'(]")))

(pass-if-exception "radix passed to number->string can't be zero"
  exception:out-of-range
  (number->string 10 0))
(pass-if-exception "radix passed to number->string can't be one either"
  exception:out-of-range
  (number->string 10 1))

(with-test-prefix "mismatching parentheses"
  (pass-if-exception "opening parenthesis"
    exception:eof
    (read-string "("))
  (pass-if-exception "closing parenthesis following mismatched opening"
    exception:unexpected-rparen
    (read-string ")"))
  (pass-if-exception "opening vector parenthesis"
    exception:eof
    (read-string "#("))
  (pass-if-exception "closing parenthesis following mismatched vector opening"
     exception:unexpected-rparen
     (read-string ")")))

(with-test-prefix "exceptions"

  ;; Reader exceptions: although they are not documented, they may be relied
  ;; on by some programs, hence these tests.

  (pass-if-exception "unterminated block comment"
    exception:unterminated-block-comment
    (read-string "(+ 1 #! comment\n..."))
  (pass-if-exception "R6RS/SRFI-30 unterminated nested block comment"
    exception:unterminated-block-comment
    (read-string "(foo #| bar #| |#)"))
  (pass-if-exception "unknown character name"
    exception:unknown-character-name
    (read-string "#\\theunknowncharacter"))
  (pass-if-exception "unknown sharp object"
    exception:unknown-sharp-object
    (read-string "#?"))
  (pass-if-exception "eof in string"
    exception:eof-in-string
    (read-string "\"the string that never ends"))
  (pass-if-exception "illegal escape in string"
    exception:illegal-escape
    (read-string "\"some string \\???\"")))

(with-test-prefix "read-options"
  (pass-if "case-sensitive"
    (not (eq? 'guile 'GuiLe)))
  (pass-if "case-insensitive"
    (eq? 'guile
         (with-read-options '(case-insensitive)
           (lambda ()
             (read-string "GuiLe")))))
  (pass-if "prefix keywords"
    (eq? #:keyword
         (with-read-options '(keywords prefix case-insensitive)
           (lambda ()
             (read-string ":KeyWord")))))
  (pass-if "prefix non-keywords"
    (symbol? (with-read-options '(keywords prefix)
               (lambda ()
                 (read-string "srfi88-keyword:")))))
  (pass-if "postfix keywords"
    (eq? #:keyword
         (with-read-options '(keywords postfix)
           (lambda ()
             (read-string "keyword:")))))
  (pass-if "long postfix keywords"
    (eq? #:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
         (with-read-options '(keywords postfix)
           (lambda ()
             (read-string "keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:")))))
  (pass-if "`:' is not a postfix keyword (per SRFI-88)"
    (eq? ':
         (with-read-options '(keywords postfix)
           (lambda ()
             (read-string ":")))))
  (pass-if "no positions"
    (let ((sexp (with-read-options '()
                  (lambda ()
                    (read-string "(+ 1 2 3)")))))
      (and (not (source-property sexp 'line))
           (not (source-property sexp 'column)))))
  (pass-if "positions"
    (let ((sexp (with-read-options '(positions)
                  (lambda ()
                    (read-string "(+ 1 2 3)")))))
      (and (equal? (source-property sexp 'line) 0)
           (equal? (source-property sexp 'column) 0))))
  (pass-if "positions on quote"
    (let ((sexp (with-read-options '(positions)
                   (lambda ()
                    (read-string "'abcde")))))
      (and (equal? (source-property sexp 'line) 0)
           (equal? (source-property sexp 'column) 0))))
  (with-test-prefix "r6rs-hex-escapes"
      (pass-if-exception "non-hex char in two-digit hex-escape"
      exception:illegal-escape
      (with-read-options '(r6rs-hex-escapes)
        (lambda ()
          (with-input-from-string "\"\\x0g;\"" read))))

    (pass-if-exception "non-hex char in four-digit hex-escape"
      exception:illegal-escape
      (with-read-options '(r6rs-hex-escapes)
        (lambda ()
          (with-input-from-string "\"\\x000g;\"" read))))

    (pass-if-exception "non-hex char in six-digit hex-escape"
      exception:illegal-escape
      (with-read-options '(r6rs-hex-escapes)
        (lambda ()
          (with-input-from-string "\"\\x00000g;\"" read))))

    (pass-if-exception "no semicolon at termination of one-digit hex-escape"
      exception:illegal-escape
      (with-read-options '(r6rs-hex-escapes)
        (lambda ()
          (with-input-from-string "\"\\x0\"" read))))

    (pass-if-exception "no semicolon at termination of three-digit hex-escape"
      exception:illegal-escape
      (with-read-options '(r6rs-hex-escapes)
        (lambda ()
          (with-input-from-string "\"\\x000\"" read))))

    (pass-if "two-digit hex escape"
      (eqv?
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (string-ref (with-input-from-string "\"--\\xff;--\"" read) 2)))
       (integer->char #xff)))

    (pass-if "four-digit hex escape"
      (eqv?
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (string-ref (with-input-from-string "\"--\\x0100;--\"" read) 2)))
       (integer->char #x0100)))

    (pass-if "six-digit hex escape"
      (eqv?
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (string-ref (with-input-from-string "\"--\\x010300;--\"" read) 2)))
       (integer->char #x010300)))

    (pass-if "escaped characters match non-escaped ASCII characters"
      (string=?
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (with-input-from-string "\"\\x41;\\x0042;\\x000043;\"" read)))
       "ABC"))

    (pass-if "write R6RS string escapes"
       (let* ((s1 (apply string
                         (map integer->char '(#x8 ; backspace
                                              #x20 ; space
                                              #x30 ; zero
                                              #x40 ; at sign
                                              ))))
              (s2 (with-read-options '(r6rs-hex-escapes)
                     (lambda ()
                      (with-output-to-string
                        (lambda () (write s1)))))))
         (lset= eqv?
                (string->list s2)
                (list #\" #\\ #\x #\8 #\; #\space #\0 #\@ #\"))))

    (pass-if "display R6RS string escapes"
      (string=?
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (let ((pt (open-output-string))
                 (s1 (apply string (map integer->char
                                        '(#xFF #x100 #xFFF #x1000 #xFFFF #x10000)))))
             (set-port-encoding! pt "ASCII")
             (set-port-conversion-strategy! pt 'escape)
             (display s1 pt)
             (get-output-string pt))))
       "\\xff;\\x100;\\xfff;\\x1000;\\xffff;\\x10000;"))

    (pass-if "one-digit hex escape"
      (eqv? (with-input-from-string "#\\xA" read)
            (integer->char #x0A)))

    (pass-if "two-digit hex escape"
      (eqv? (with-input-from-string "#\\xFF" read)
            (integer->char #xFF)))

    (pass-if "four-digit hex escape"
      (eqv? (with-input-from-string "#\\x00FF" read)
            (integer->char #xFF)))

    (pass-if "eight-digit hex escape"
      (eqv? (with-input-from-string "#\\x00006587" read)
            (integer->char #x6587)))

    (pass-if "write R6RS escapes"
      (string=?
       (with-read-options '(r6rs-hex-escapes)
         (lambda ()
           (with-output-to-string
             (lambda ()
               (write (integer->char #x80))))))
       "#\\x80"))))

(with-test-prefix "#;"
  (for-each
   (lambda (pair)
     (pass-if (car pair)
       (equal? (with-input-from-string (car pair) read) (cdr pair))))

   '(("#;foo 10". 10)
     ("#;(10 20 30) foo" . foo)
     ("#;   (10 20 30) foo" . foo)
     ("#;\n10\n20" . 20)))

  (pass-if "#;foo"
    (eof-object? (with-input-from-string "#;foo" read)))

  (pass-if-exception "#;"
    exception:missing-expression
    (with-input-from-string "#;" read))
  (pass-if-exception "#;("
    exception:eof
    (with-input-from-string "#;(" read)))

(with-test-prefix "#'"
  (for-each
   (lambda (pair)
     (pass-if (car pair)
       (equal? (with-input-from-string (car pair) read) (cdr pair))))

   '(("#'foo". (syntax foo))
     ("#`foo" . (quasisyntax foo))
     ("#,foo" . (unsyntax foo))
     ("#,@foo" . (unsyntax-splicing foo)))))


code:
;;;; receive.test --- Test suite for Guile receive 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-receive)
  #:use-module (test-suite lib)
  #:use-module (ice-9 receive))

;;;
;;; receive
;;;

(with-test-prefix "receive"

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

license: mit


code:
;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*-
;;;;
;;;; Copyright (C) 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-records)
  #:use-module (ice-9 format)
  #:use-module (test-suite lib))

;; ascii names and symbols, custom printer
(define rtd-foo (make-record-type "foo" '(x y)
                                  (lambda (s p)
                                    (display "#<it is a foo>" p))))
(define make-foo (record-constructor rtd-foo))
(define foo? (record-predicate rtd-foo))
(define get-foo-x (record-accessor rtd-foo 'x))
(define get-foo-y (record-accessor rtd-foo 'y))
(define set-foo-x! (record-modifier rtd-foo 'x))
(define set-foo-y! (record-modifier rtd-foo 'y))

;; non-Latin-1 names and symbols, default printer
(define rtd-fŏŏ (make-record-type "fŏŏ" '(x ȳ)))
(define make-fŏŏ (record-constructor rtd-fŏŏ))
(define fŏŏ? (record-predicate rtd-fŏŏ))
(define get-fŏŏ-x (record-accessor rtd-fŏŏ 'x))
(define get-fŏŏ-ȳ (record-accessor rtd-fŏŏ 'ȳ))
(define set-fŏŏ-x! (record-modifier rtd-fŏŏ 'x))
(define set-fŏŏ-ȳ! (record-modifier rtd-fŏŏ 'ȳ))

(with-test-prefix "records"

  (with-test-prefix "constructor"

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

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

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

    (pass-if "non-latin-1" exception:wrong-num-args
      (fŏŏ? (make-fŏŏ 1 2))))

  (with-test-prefix "modifier and getter"

    (pass-if "set"
      (let ((r (make-foo 1 2)))
        (set-foo-x! r 3)
        (eqv? (get-foo-x r) 3)))

    (pass-if "set 2"
      (let ((r (make-fŏŏ 1 2)))
        (set-fŏŏ-ȳ! r 3)
        (eqv? (get-fŏŏ-ȳ r) 3))))

  (with-test-prefix "record type name"

    (pass-if "foo"
      (string=? "foo" (record-type-name rtd-foo)))

    (pass-if "fŏŏ"
      (string=? "fŏŏ" (record-type-name rtd-fŏŏ))))

  (with-test-prefix "printer"

    (pass-if "foo"
      (string=? "#<it is a foo>"
                (with-output-to-string
                  (lambda () (display (make-foo 1 2))))))

    (pass-if "fŏŏ"
      (with-locale "en_US.utf8"
        (string-prefix? "#<fŏŏ"
                        (with-output-to-string
                          (lambda () (display (make-fŏŏ 1 2)))))))))


code:
;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;;
;;;; 	Copyright (C) 1999, 2004, 2006, 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-suite test-regexp)
  #:use-module (test-suite lib)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 regex))

(if (defined? 'setlocale)
    (setlocale LC_ALL "C"))

;; Don't fail if we can't display a test name to stdout/stderr.
(set-port-conversion-strategy! (current-output-port) 'escape)
(set-port-conversion-strategy! (current-error-port) 'escape)

;;; Run a regexp-substitute or regexp-substitute/global test, once
;;; providing a real port and once providing #f, requesting direct
;;; string output.
(define (vary-port func expected . args)
  (pass-if "port is string port"
	   (equal? expected
		   (call-with-output-string
		    (lambda (port)
		      (apply func port args)))))
  (pass-if "port is #f"
	   (equal? expected
		   (apply func #f args))))

(define (object->string obj)
  (call-with-output-string
   (lambda (port)
     (write obj port))))

;;;
;;; make-regexp
;;;

(with-test-prefix "make-regexp"

  (pass-if-exception "no args" exception:wrong-num-args
    (make-regexp))

  (pass-if-exception "bad pat arg" exception:wrong-type-arg
    (make-regexp 'blah))

  ;; in guile prior to 1.6.5 make-regex didn't validate its flags args
  (pass-if-exception "bad arg 2" exception:wrong-type-arg
    (make-regexp "xyz" 'abc))

  (pass-if-exception "bad arg 3" exception:wrong-type-arg
    (make-regexp "xyz" regexp/icase 'abc)))

;;;
;;; match:string
;;;

(with-test-prefix "match:string"

  (pass-if "foo"
    (string=? "foo" (match:string (string-match ".*" "foo"))))

  (pass-if "foo offset 1"
    (string=? "foo" (match:string (string-match ".*" "foo" 1)))))

;;;
;;; regexp-exec
;;;

(with-test-prefix "regexp-exec"

  (pass-if-exception "non-integer offset" exception:wrong-type-arg
    (let ((re (make-regexp "ab+")))
      (regexp-exec re "aaaabbbb" 1.5 'bogus-flags-arg)))

  (pass-if-exception "non-string input" exception:wrong-type-arg
    (let ((re (make-regexp "ab+")))
      (regexp-exec re 'not-a-string)))

  (pass-if-exception "non-string input, with offset" exception:wrong-type-arg
    (let ((re (make-regexp "ab+")))
      (regexp-exec re 'not-a-string 5)))

  ;; in guile 1.8.1 and earlier, a #\nul character in the input string was
  ;; only detected in a critical section, and the resulting error throw
  ;; abort()ed the program
  (pass-if-exception "nul in input" exception:string-contains-nul
    (let ((re (make-regexp "ab+")))
      (regexp-exec re (string #\a #\b (integer->char 0)))))

  ;; in guile 1.8.1 and earlier, a bogus flags argument was only detected
  ;; inside a critical section, and the resulting error throw abort()ed the
  ;; program
  (pass-if-exception "non-integer flags" exception:wrong-type-arg
    (let ((re (make-regexp "ab+")))
      (regexp-exec re "aaaabbbb" 0 'bogus-flags-arg))))

;;;
;;; fold-matches
;;;

(with-test-prefix "fold-matches"

  (pass-if "without flags"
    (equal? '("hello")
            (fold-matches "^[a-z]+$" "hello" '()
                          (lambda (match result)
                            (cons (match:substring match)
                                  result)))))

  (pass-if "with flags"
    ;; Prior to 1.8.6, passing an additional flag would not work.
    (null?
     (fold-matches "^[a-z]+$" "hello" '()
                   (lambda (match result)
                     (cons (match:substring match)
                           result))
                   (logior regexp/notbol regexp/noteol)))))

;;;
;;; regexp-quote
;;;

(with-test-prefix "regexp-quote"

  (pass-if-exception "no args" exception:wrong-num-args
    (regexp-quote))

  (pass-if-exception "bad string arg" exception:wrong-type-arg
    (regexp-quote 'blah))

  (let ((lst `((regexp/basic    ,regexp/basic)
	       (regexp/extended ,regexp/extended)))
	;; string of all characters, except #\nul which doesn't work because
	;; it's the usual end-of-string for the underlying C regexec()
	(allchars (list->string (map integer->char
				     (cdr (iota char-code-limit))))))
    (for-each
     (lambda (elem)
       (let ((name (car  elem))
	     (flag (cadr elem)))

	 (with-test-prefix name

	   ;; try on each individual character, except #\nul
	   (do ((i 1 (1+ i)))
	       ((>= i char-code-limit))
             (let* ((c (integer->char i))
                    (s (string c)))
               (pass-if (list "char" i (format #f "~s ~s" c s))
                 (with-latin1-locale
                  (let* ((q (regexp-quote s))
                         (m (regexp-exec (make-regexp q flag) s)))
                    (and (= 0 (match:start m))
                         (= 1 (match:end m))))))))

	   ;; try on pattern "aX" where X is each character, except #\nul
	   ;; this exposes things like "?" which are special only when they
	   ;; follow a pattern to repeat or whatever ("a" in this case)
	   (do ((i 1 (1+ i)))
	       ((>= i char-code-limit))
             (let* ((c (integer->char i))
                    (s (string #\a c))
                    (q (regexp-quote s)))
               (pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
                 (with-latin1-locale
		  (let* ((m (regexp-exec (make-regexp q flag) s)))
                    (and (= 0 (match:start m))
                         (= 2 (match:end m))))))))

	   (pass-if "string of all chars"
             (with-latin1-locale
               (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
                                                  flag) allchars)))
                 (and (= 0 (match:start m))
                      (= (string-length allchars) (match:end m)))))))))
     lst)))

;;;
;;; regexp-substitute
;;;

(with-test-prefix "regexp-substitute"
  (let ((match
	 (string-match "patleft(sub1)patmid(sub2)patright"
		       "contleftpatleftsub1patmidsub2patrightcontright")))
    (define (try expected . args)
      (with-test-prefix (object->string args)
	(apply vary-port regexp-substitute expected match args)))

    (try "")
    (try "string1" "string1")
    (try "string1string2" "string1" "string2")
    (try "patleftsub1patmidsub2patright" 0)
    (try "hi-patleftsub1patmidsub2patright-bye" "hi-" 0 "-bye")
    (try "sub1" 1)
    (try "hi-sub1-bye" "hi-" 1 "-bye")
    (try "hi-sub2-bye" "hi-" 2 "-bye")
    (try "contleft" 'pre)
    (try "contright" 'post)
    (try "contrightcontleft" 'post 'pre)
    (try "contrightcontleftcontrightcontleft" 'post 'pre 'post 'pre)
    (try "contrightsub2sub1contleft" 'post 2 1 'pre)
    (try "foosub1sub1sub1sub1bar" "foo" 1 1 1 1 "bar")))

(with-test-prefix "regexp-substitute/global"

  (define (try expected . args)
    (with-test-prefix (object->string args)
      (apply vary-port regexp-substitute/global expected args)))

  (try "hi" "a(x*)b" "ab" "hi")
  (try ""   "a(x*)b" "ab" 1)
  (try "xx" "a(x*)b" "axxb" 1)
  (try "xx" "a(x*)b" "_axxb_" 1)
  (try "pre" "a(x*)b" "preaxxbpost" 'pre)
  (try "post" "a(x*)b" "preaxxbpost" 'post)
  (try "string" "x" "string" 'pre "y" 'post)
  (try "4" "a(x*)b" "_axxb_" (lambda (m)
				(number->string (match:end m 1))))

  (try "_aybycyd_" "x+" "_axbxxcxxxd_" 'pre "y" 'post)

  ;; This should not go into an infinite loop, just because the regexp
  ;; can match the empty string.  This test also kind of beats on our
  ;; definition of where a null string can match.
  (try "y_yaybycydy_y" "x*" "_axbxxcxxxd_" 'pre "y" 'post)

  ;; These kind of bother me.  The extension from regexp-substitute to
  ;; regexp-substitute/global is only natural if your item list
  ;; includes both pre and post.  If those are required, why bother
  ;; to include them at all?
  (try "4:7:12:_" "a(x*)b" "_axxbaxbaxxxb_"
       (lambda (m) (number->string (match:end m 1))) ":"
       'post)
  (try "4:10:19:_:19:10:4" "a(x*)b" "_axxbaxxxxbaxxxxxxxb_"
       (lambda (m) (number->string (match:end m 1))) ":"
       'post
       ":" (lambda (m) (number->string (match:end m 1))))

  ;; Jan Nieuwenhuizen's bug, 2 Sep 1999
  (try "" "_" (make-string 500 #\_)
       'post))


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

(define-module (test-suite tests rnrs-libraries)
  #:use-module (test-suite lib))

;; First, check that Guile modules are r6rs modules.
;;
(with-test-prefix "ice-9 receive"
  (define iface #f)

  (pass-if "import"
    (eval '(begin
             (import (ice-9 receive))
             #t)
          (current-module)))

  (pass-if "resolve-interface"
    (module? (resolve-interface '(ice-9 receive))))

  (set! iface (resolve-interface '(ice-9 receive)))

  (pass-if "resolve-r6rs-interface"
    (eq? iface (resolve-r6rs-interface '(ice-9 receive))))

  (pass-if "resolve-r6rs-interface (2)"
    (eq? iface (resolve-r6rs-interface '(library (ice-9 receive)))))

  (pass-if "module uses"
    (and (memq iface (module-uses (current-module))) #t))

  (pass-if "interface contents"
    (equal? '(receive)
            (hash-map->list (lambda (sym var) sym) (module-obarray iface))))

  (pass-if "interface uses"
    (null? (module-uses iface)))

  (pass-if "version"
    (or (not (module-version iface))
        (null? (module-version iface))))

  (pass-if "calling receive from current env"
    (equal? (eval '(receive (a b) (values 10 32)
                     (+ a b))
                  (current-module))
            42)))

;; And check that r6rs modules are guile modules.
;;
(with-test-prefix "rnrs-test-a"
  (define iface #f)

  (pass-if "no double"
    (not (module-local-variable (current-module) 'double)))

  (pass-if "import"
    (eval '(begin
             (import (test-suite tests rnrs-test-a))
             #t)
          (current-module)))

  (pass-if "still no double"
    (not (module-local-variable (current-module) 'double)))

  (pass-if "resolve-interface"
    (module? (resolve-interface '(test-suite tests rnrs-test-a))))

  (set! iface (resolve-interface '(test-suite tests rnrs-test-a)))

  (pass-if "resolve-interface (2)"
    (eq? iface (resolve-interface '(test-suite tests rnrs-test-a))))

  (pass-if "resolve-r6rs-interface"
    (eq? iface (resolve-r6rs-interface '(test-suite tests rnrs-test-a))))

  (pass-if "resolve-r6rs-interface (2)"
    (eq? iface (resolve-r6rs-interface '(library (test-suite tests rnrs-test-a)))))

  (pass-if "module uses"
    (and (memq iface (module-uses (current-module))) #t))

  (pass-if "interface contents"
    (equal? '(double)
            (hash-map->list (lambda (sym var) sym) (module-obarray iface))))

  (pass-if "interface uses"
    (null? (module-uses iface)))

  (pass-if "version"
    (or (not (module-version iface))
        (null? (module-version iface))))

  (pass-if "calling double"
    (equal? ((module-ref iface 'double) 10)
            20))

  (pass-if "calling double from current env"
    (equal? (eval '(double 20) (current-module))
            40)))

;; Guile should ignore explicit phase specifications
;;
(with-test-prefix "implicit phasing"
  (with-test-prefix "in library form"
    (pass-if "explicit phasing ignored"
      (import (for (guile) (meta -1))) #t))

  (with-test-prefix "in library form"
    (pass-if "explicit phasing ignored"
      (save-module-excursion
       (lambda ()
         (library (test)
           (export)
           (import (for (guile) (meta -1))))
         #t)))))

;; Now import features.
;;
(with-test-prefix "import features"
  (define iface #f)

  (with-test-prefix "only"
    (pass-if "contents"
      (equal? '(+)
              (hash-map->list
               (lambda (sym var) sym)
               (module-obarray (resolve-r6rs-interface '(only (guile) +)))))))

  (with-test-prefix "except"
    (let ((bindings (hash-map->list
                     (lambda (sym var) sym)
                     (module-obarray
                      (resolve-r6rs-interface '(except (guile) +))))))
      (pass-if "contains"
        (equal? (length bindings)
                (1- (hash-fold
                     (lambda (sym var n) (1+ n))
                     0
                     (module-obarray (resolve-interface '(guile)))))))
      (pass-if "does not contain"
        (not (memq '+ bindings)))))

  (with-test-prefix "prefix"
    (let ((iface (resolve-r6rs-interface '(prefix (ice-9 q) q:))))
      (pass-if "contains"
        ((module-ref iface 'q:q?) ((module-ref iface 'q:make-q))))
      (pass-if "does not contain"
        (not (module-local-variable iface 'make-q)))))

  (with-test-prefix "rename"
    (let ((iface (resolve-r6rs-interface
                  '(rename (only (guile) cons car cdr)
                           (cons snoc)
                           (car rac)
                           (cdr rdc)))))
      (pass-if "contents"
        (equal? '("rac" "rdc" "snoc")
                (sort
                 (hash-map->list
                  (lambda (sym var) (symbol->string sym))
                  (module-obarray iface))
                 string<)))
      (pass-if "contains"
        (equal? 3 ((module-ref iface 'rac)
                   ((module-ref iface 'snoc) 3 4))))))

  (with-test-prefix "srfi"
    (pass-if "renaming works"
      (eq? (resolve-interface '(srfi srfi-1))
           (resolve-r6rs-interface '(srfi :1)))))

  (with-test-prefix "macro"
    (pass-if "multiple clauses"
      (eval '(begin
               (import (rnrs) (for (rnrs) expand) (rnrs))
               #t)
            (current-module)))))


code:
;;; test of defining rnrs libraries

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

(library (test-suite tests rnrs-test-a)
  (export double)
  (import (guile))

  (define (double x)
    (* x 2)))


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

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

(with-test-prefix "sigaction"

  (pass-if-exception "handler arg is an invalid integer"
    exception:out-of-range
    (sigaction SIGINT 51))

  )


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

;;;
;;; htonl
;;;

(if (defined? 'htonl)
    (with-test-prefix "htonl"

      (pass-if "0" (eqv? 0 (htonl 0)))

      (pass-if-exception "-1" exception:out-of-range
        (htonl -1))

      ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
      ;; an overflow for values 2^32 <= x < 2^63
      (pass-if-exception "2^32" exception:out-of-range
        (htonl (ash 1 32)))

      (pass-if-exception "2^1024" exception:out-of-range
        (htonl (ash 1 1024)))))

;;;
;;; inet-ntop
;;;

(if (defined? 'inet-ntop)
    (with-test-prefix "inet-ntop"

      (with-test-prefix "ipv6"
	(pass-if "0"
	  (string? (inet-ntop AF_INET6 0)))

	(pass-if "2^128-1"
	  (string? (inet-ntop AF_INET6 (1- (ash 1 128)))))

	(pass-if-exception "-1" exception:out-of-range
	  (inet-ntop AF_INET6 -1))

	(pass-if-exception "2^128" exception:out-of-range
	  (inet-ntop AF_INET6 (ash 1 128)))

	(pass-if-exception "2^1024" exception:out-of-range
	  (inet-ntop AF_INET6 (ash 1 1024))))))

;;;
;;; inet-pton
;;;

(if (defined? 'inet-pton)
    (with-test-prefix "inet-pton"

      (with-test-prefix "ipv6"
	(pass-if "00:00:00:00:00:00:00:00"
	  (eqv? 0 (inet-pton AF_INET6 "00:00:00:00:00:00:00:00")))

	(pass-if "0:0:0:0:0:0:0:1"
	  (eqv? 1 (inet-pton AF_INET6 "0:0:0:0:0:0:0:1")))

	(pass-if "::1"
	  (eqv? 1 (inet-pton AF_INET6 "::1")))

	(pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
	  (eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
		(inet-pton AF_INET6
			   "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")))

	(pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
	  (eqv? #xF0000000000000000000000000000000
		(inet-pton AF_INET6
			   "F000:0000:0000:0000:0000:0000:0000:0000")))

	(pass-if "0F00:0000:0000:0000:0000:0000:0000:0000"
	  (eqv? #x0F000000000000000000000000000000
		(inet-pton AF_INET6
			   "0F00:0000:0000:0000:0000:0000:0000:0000")))

	(pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
	  (eqv? #xF0
		(inet-pton AF_INET6
			   "0000:0000:0000:0000:0000:0000:0000:00F0"))))))

(if (defined? 'inet-ntop)
    (with-test-prefix "inet-ntop"

      (with-test-prefix "ipv4"
	(pass-if "127.0.0.1"
	  (equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))

      (if (defined? 'AF_INET6)
	  (with-test-prefix "ipv6"
	    (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
	      (string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
			   (inet-ntop AF_INET6 (- (expt 2 128) 1))))

	    (pass-if "::1"
	      (equal? "::1" (inet-ntop AF_INET6 1)))))))

;;;
;;; make-socket-address
;;;

(with-test-prefix "make-socket-address"
  (if (defined? 'AF_INET)
      (pass-if "AF_INET"
	(let ((sa (make-socket-address AF_INET 123456 80)))
	  (and (= (sockaddr:fam  sa) AF_INET)
	       (= (sockaddr:addr sa) 123456)
	       (= (sockaddr:port sa) 80)))))

  (if (defined? 'AF_INET6)
      (pass-if "AF_INET6"
	;; Since the platform doesn't necessarily support `scopeid', we won't
        ;; test it.
	(let ((sa* (make-socket-address AF_INET6 123456 80 1))
	      (sa+ (make-socket-address AF_INET6 123456 80)))
	  (and (= (sockaddr:fam  sa*) (sockaddr:fam  sa+) AF_INET6)
	       (= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456)
	       (= (sockaddr:port sa*) (sockaddr:port sa+) 80)
	       (= (sockaddr:flowinfo sa*) 1)))))

  (if (defined? 'AF_UNIX)
      (pass-if "AF_UNIX"
	(let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket")))
	  (and (= (sockaddr:fam sa) AF_UNIX)
	       (string=? (sockaddr:path sa) "/tmp/unix-socket"))))))

;;;
;;; ntohl
;;;

(if (defined? 'ntohl)
    (with-test-prefix "ntohl"

      (pass-if "0" (eqv? 0 (ntohl 0)))

      (pass-if-exception "-1" exception:out-of-range
        (ntohl -1))

      ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
      ;; an overflow for values 2^32 <= x < 2^63
      (pass-if-exception "2^32" exception:out-of-range
        (ntohl (ash 1 32)))

      (pass-if-exception "2^1024" exception:out-of-range
        (ntohl (ash 1 1024)))))

;;;
;;; AF_UNIX sockets and `make-socket-address'
;;;

(define %tmpdir
  ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
  (or (getenv "TMPDIR") "/tmp"))

(define %curdir
  ;; Remember the current working directory.
  (getcwd))

;; Temporarily cd to %TMPDIR.  The goal is to work around path name
;; limitations, which can lead to exceptions like:
;;
;;  (misc-error "scm_to_sockaddr"
;;              "unix address path too long: ~A"
;;              ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
;;              #f)
(chdir %tmpdir)

(define (temp-file-path)
  ;; Return a temporary file name, assuming the current directory is %TMPDIR.
  (string-append "guile-test-socket-"
                 (number->string (current-time)) "-"
                 (number->string (random 100000))))

(if (defined? 'AF_UNIX)
    (with-test-prefix "AF_UNIX/SOCK_DGRAM"

      ;; testing `bind' and `sendto' and datagram sockets

      (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
	    (server-bound? #f)
	    (path (temp-file-path)))

	(pass-if "bind"
	  (catch 'system-error
	    (lambda ()
	      (bind server-socket AF_UNIX path)
	      (set! server-bound? #t)
	      #t)
	    (lambda args
	      (let ((errno (system-error-errno args)))
		(cond ((= errno EADDRINUSE) (throw 'unresolved))
		      (else (apply throw args)))))))

	(pass-if "bind/sockaddr"
	  (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
		 (path (temp-file-path))
		 (sockaddr (make-socket-address AF_UNIX path)))
	    (catch 'system-error
	      (lambda ()
		(bind sock sockaddr)
		(false-if-exception (delete-file path))
		#t)
	      (lambda args
		(let ((errno (system-error-errno args)))
		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
			(else (apply throw args))))))))

	(pass-if "sendto"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (let ((client (socket AF_UNIX SOCK_DGRAM 0)))
		(> (sendto client "hello" AF_UNIX path) 0))))

	(pass-if "sendto/sockaddr"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (let ((client (socket AF_UNIX SOCK_DGRAM 0))
		    (sockaddr (make-socket-address AF_UNIX path)))
		(> (sendto client "hello" sockaddr) 0))))

	(false-if-exception (delete-file path)))))

(if (defined? 'AF_UNIX)
    (with-test-prefix "AF_UNIX/SOCK_STREAM"

      ;; testing `bind', `listen' and `connect' on stream-oriented sockets

      (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
	    (server-bound? #f)
	    (server-listening? #f)
	    (server-pid #f)
	    (path (temp-file-path)))

	(pass-if "bind"
	  (catch 'system-error
	    (lambda ()
	      (bind server-socket AF_UNIX path)
	      (set! server-bound? #t)
	      #t)
	    (lambda args
	      (let ((errno (system-error-errno args)))
		(cond ((= errno EADDRINUSE) (throw 'unresolved))
		      (else (apply throw args)))))))

	(pass-if "bind/sockaddr"
	  (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
		 (path (temp-file-path))
		 (sockaddr (make-socket-address AF_UNIX path)))
	    (catch 'system-error
	      (lambda ()
		(bind sock sockaddr)
		(false-if-exception (delete-file path))
		#t)
	      (lambda args
		(let ((errno (system-error-errno args)))
		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
			(else (apply throw args))))))))

	(pass-if "listen"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (begin
		(listen server-socket 123)
		(set! server-listening? #t)
		#t)))

	(force-output (current-output-port))
	(force-output (current-error-port))
	(if server-listening?
	    (let ((pid (primitive-fork)))
	      ;; Spawn a server process.
	      (case pid
		((-1) (throw 'unresolved))
		((0)   ;; the kid:  serve two connections and exit
		 (let serve ((conn
			      (false-if-exception (accept server-socket)))
			     (count 1))
		   (if (not conn)
		       (exit 1)
		       (if (> count 0)
			   (serve (false-if-exception (accept server-socket))
				  (- count 1)))))
		 (exit 0))
		(else  ;; the parent
		 (set! server-pid pid)
		 #t))))

	(pass-if "connect"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_UNIX SOCK_STREAM 0)))
		(connect s AF_UNIX path)
		#t)))

	(pass-if "connect/sockaddr"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_UNIX SOCK_STREAM 0)))
		(connect s (make-socket-address AF_UNIX path))
		#t)))

	(pass-if "accept"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((status (cdr (waitpid server-pid))))
		(eq? 0 (status:exit-val status)))))

	(false-if-exception (delete-file path))

	#t)))

(if (defined? 'AF_INET6)
    (with-test-prefix "AF_INET6/SOCK_STREAM"

      ;; testing `bind', `listen' and `connect' on stream-oriented sockets

      (let ((server-socket
             ;; Some platforms don't support this protocol/family combination.
             (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
	    (server-bound? #f)
	    (server-listening? #f)
	    (server-pid #f)
	    (ipv6-addr 1)		; ::1
	    (server-port 8889)
	    (client-port 9998))

	(pass-if "bind"
          (if (not server-socket)
              (throw 'unresolved))
	  (catch 'system-error
	    (lambda ()
	      (bind server-socket AF_INET6 ipv6-addr server-port)
	      (set! server-bound? #t)
	      #t)
	    (lambda args
	      (let ((errno (system-error-errno args)))
		(cond ((= errno EADDRINUSE) (throw 'unresolved))
		      (else (apply throw args)))))))

	(pass-if "bind/sockaddr"
	  (let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
		 (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
            (if (not sock)
                (throw 'unresolved))
	    (catch 'system-error
	      (lambda ()
		(bind sock sockaddr)
		#t)
	      (lambda args
		(let ((errno (system-error-errno args)))
		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
			(else (apply throw args))))))))

	(pass-if "listen"
	  (if (not server-bound?)
	      (throw 'unresolved)
	      (begin
		(listen server-socket 123)
		(set! server-listening? #t)
		#t)))

	(force-output (current-output-port))
	(force-output (current-error-port))
	(if server-listening?
	    (let ((pid (primitive-fork)))
	      ;; Spawn a server process.
	      (case pid
		((-1) (throw 'unresolved))
		((0)   ;; the kid:  serve two connections and exit
		 (let serve ((conn
			      (false-if-exception (accept server-socket)))
			     (count 1))
		   (if (not conn)
		       (exit 1)
		       (if (> count 0)
			   (serve (false-if-exception (accept server-socket))
				  (- count 1)))))
		 (exit 0))
		(else  ;; the parent
		 (set! server-pid pid)
		 #t))))

	(pass-if "connect"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_INET6 SOCK_STREAM 0)))
		(connect s AF_INET6 ipv6-addr server-port)
		#t)))

	(pass-if "connect/sockaddr"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((s (socket AF_INET6 SOCK_STREAM 0)))
		(connect s (make-socket-address AF_INET6 ipv6-addr server-port))
		#t)))

	(pass-if "accept"
	  (if (not server-pid)
	      (throw 'unresolved)
	      (let ((status (cdr (waitpid server-pid))))
		(eq? 0 (status:exit-val status)))))

	#t)))

;; Switch back to the previous directory.
(false-if-exception (chdir %curdir))


code:
;;;; sort.test --- tests Guile's sort functions    -*- scheme -*-
;;;; Copyright (C) 2003, 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 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))

(define (randomize-vector! v n)
  (array-index-map! v (lambda (i) (random n)))
  v)

(with-test-prefix "sort"

  (pass-if-exception "less function taking less than two arguments"
    exception:wrong-num-args
    (sort '(1 2) (lambda (x) #t)))

  (pass-if-exception "less function taking more than two arguments"
    exception:wrong-num-args
    (sort '(1 2) (lambda (x y z) z)))

  (pass-if "sort!"
    (let ((v (randomize-vector! (make-vector 1000) 1000)))
      (sorted? (sort! v <) <)))

  (pass-if "sort! of non-contigous vector"
    (let* ((a (make-array 0 1000 3))
	   (v (make-shared-array a (lambda (i) (list i 0)) 1000)))
      (randomize-vector! v 1000)
      (sorted? (sort! v <) <)))

  (pass-if "sort! of negative-increment vector"
    (let* ((a (make-array 0 1000 3))
	   (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
      (randomize-vector! v 1000)
      (sorted? (sort! v <) <)))

  (pass-if "stable-sort!"
    (let ((v (randomize-vector! (make-vector 1000) 1000)))
      (sorted? (stable-sort! v <) <)))

  (pass-if "stable-sort! of non-contigous vector"
    (let* ((a (make-array 0 1000 3))
	   (v (make-shared-array a (lambda (i) (list i 0)) 1000)))
      (randomize-vector! v 1000)
      (sorted? (stable-sort! v <) <)))

  (pass-if "stable-sort! of negative-increment vector"
    (let* ((a (make-array 0 1000 3))
	   (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
      (randomize-vector! v 1000)
      (sorted? (stable-sort! v <) <))))

;;;
;;; stable-sort
;;;

(with-test-prefix "stable-sort"

  ;; in guile 1.8.0 and 1.8.1 this test failed, an empty list provoked a
  ;; wrong-type-arg exception (where it shouldn't)
  (pass-if "empty list"
    (eq? '() (stable-sort '() <))))


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

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

;;;
;;; source-properties
;;;

(with-test-prefix "source-properties"

  (pass-if "no props"
    (null? (source-properties (list 1 2 3))))

  (read-enable 'positions)
  (let ((s (read (open-input-string "(1 . 2)"))))

    (pass-if "read properties"
      (not (null? (source-properties s))))))

;;;
;;; set-source-property!
;;;

(with-test-prefix "set-source-property!"
  (read-enable 'positions)

  (pass-if "setting the breakpoint property works"
    (let ((s (read (open-input-string "(+ 3 4)"))))
      (throw 'unresolved)
      (set-source-property! s 'breakpoint #t)
      (let ((current-trap-opts (evaluator-traps-interface))
	    (current-debug-opts (debug-options-interface))
	    (trap-called #f))
	(trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
	(trap-enable 'traps)
	(debug-enable 'debug)
	(debug-enable 'breakpoints)
	(with-traps (lambda ()
		      (primitive-eval s)))
	(evaluator-traps-interface current-trap-opts)
	(debug-options-interface current-debug-opts)
	trap-called))))

;;;
;;; set-source-properties!
;;;

(with-test-prefix "set-source-properties!"
  (read-enable 'positions)

  (pass-if "setting the breakpoint property works"
    (let ((s (read (open-input-string "(+ 3 4)"))))
      (throw 'unresolved)
      (set-source-properties! s '((breakpoint #t)))
      (let ((current-trap-opts (evaluator-traps-interface))
	    (current-debug-opts (debug-options-interface))
	    (trap-called #f))
	(trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
	(trap-enable 'traps)
	(debug-enable 'debug)
	(debug-enable 'breakpoints)
	(with-traps (lambda ()
		      (primitive-eval s)))
	(evaluator-traps-interface current-trap-opts)
	(debug-options-interface current-debug-opts)
	trap-called)))

  (let ((s (read (open-input-string "(1 . 2)"))))

    (with-test-prefix "copied props"
      (pass-if "visible to source-property"
	(let ((t (cons 3 4)))
	  (set-source-properties! t (source-properties s))
	  (number? (source-property t 'line))))

      (pass-if "visible to source-properties"
	(let ((t (cons 3 4)))
	  (set-source-properties! t (source-properties s))
	  (not (null? (source-properties t))))))))