diff options
Diffstat (limited to 'test-suite/tests')
70 files changed, 506 insertions, 365 deletions
diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index e3722dc4d..a9e9b0d24 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -1,5 +1,5 @@ ;;;; alist.test --- tests guile's alists -*- scheme -*- -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/and-let-star.test b/test-suite/tests/and-let-star.test index 099c3422d..0f74934f7 100644 --- a/test-suite/tests/and-let-star.test +++ b/test-suite/tests/and-let-star.test @@ -1,6 +1,6 @@ ;;;; and-let-star.test --- Tests for Guile and-let-star module. -*- scheme -*- ;;;; -;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/arbiters.test b/test-suite/tests/arbiters.test index 3aedabd24..7591f02f0 100644 --- a/test-suite/tests/arbiters.test +++ b/test-suite/tests/arbiters.test @@ -1,6 +1,6 @@ ;;;; arbiters.test --- test arbiters functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; 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 diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index f63f894ea..8e35257b3 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -1,5 +1,5 @@ ;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 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 diff --git a/test-suite/tests/c-api.test b/test-suite/tests/c-api.test index 6c24c0aac..4a165d4cb 100644 --- a/test-suite/tests/c-api.test +++ b/test-suite/tests/c-api.test @@ -1,7 +1,7 @@ ;;;; c-api.test --- complementary test suite for the c-api -*- scheme -*- ;;;; MDJ 990915 <djurfeldt@nada.kth.se> ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index b7319466b..f14c832dd 100644 --- a/test-suite/tests/chars.test +++ b/test-suite/tests/chars.test @@ -1,7 +1,7 @@ ;;;; chars.test --- test suite for Guile's char functions -*- scheme -*- ;;;; Greg J. Badros <gjb@cs.washington.edu> ;;;; -;;;; Copyright (C) 2000 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test index 511da1f57..c6f659b1e 100644 --- a/test-suite/tests/common-list.test +++ b/test-suite/tests/common-list.test @@ -1,5 +1,5 @@ ;;;; common-list.test --- tests guile's common list functions -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 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 diff --git a/test-suite/tests/continuations.test b/test-suite/tests/continuations.test index 6d8a6a69a..c1b6803cb 100644 --- a/test-suite/tests/continuations.test +++ b/test-suite/tests/continuations.test @@ -1,7 +1,7 @@ ;;;; -*- scheme -*- ;;;; continuations.test --- test suite for continutations ;;;; -;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test index 60f91f05e..d7a06a411 100644 --- a/test-suite/tests/dynamic-scope.test +++ b/test-suite/tests/dynamic-scope.test @@ -1,7 +1,7 @@ ;;;; -*- scheme -*- ;;;; dynamic-scop.test --- test suite for dynamic scoping constructs ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 964e8baeb..067f7b16f 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -1,5 +1,5 @@ ;;;; elisp.test --- tests guile's elisp support -*- scheme -*- -;;;; Copyright (C) 2002, 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 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 diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.test index d96295f22..19117e3b5 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.test @@ -1,5 +1,5 @@ ;;;; environments.test -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 18541da94..6bca6235c 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 565cc8fea..4a9c1cb55 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -1,5 +1,5 @@ ;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- -;;;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 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 diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index 6ccb021ea..7ba4feb06 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -1,6 +1,6 @@ ;;;; filesys.test --- test file system functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; 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 @@ -17,7 +17,14 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-filesys) - #:use-module (test-suite lib)) + #:use-module (test-suite lib) + #:use-module (test-suite guile-test)) + +(define (test-file) + (data-file-name "filesys-test.tmp")) +(define (test-symlink) + (data-file-name "filesys-test-link.tmp")) + ;;; ;;; copy-file @@ -37,3 +44,84 @@ (let ((old-next (next-fd))) (false-if-exception (copy-file "/dev/null" "no/such/dir/foo")) (= old-next (next-fd))))) + +;;; +;;; lstat +;;; + +(with-test-prefix "lstat" + + (pass-if "normal file" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (eqv? 5 (stat:size (lstat (test-file))))) + + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (delete-file (test-symlink)) + (if (not (false-if-exception + (begin (symlink (test-file) (test-symlink)) #t))) + (display "cannot create symlink, lstat test skipped\n") + (pass-if "symlink" + ;; not much to test, except that it works + (->bool (lstat (test-symlink)))))) + +;;; +;;; opendir and friends +;;; + +(with-test-prefix "opendir" + + (with-test-prefix "root directory" + (let ((d (opendir "/"))) + (pass-if "not empty" + (string? (readdir d))) + (pass-if "all entries are strings" + (let more () + (let ((f (readdir d))) + (cond ((string? f) + (more)) + ((eof-object? f) + #t) + (else + #f))))) + (closedir d)))) + +;;; +;;; stat +;;; + +(with-test-prefix "stat" + + (with-test-prefix "filename" + + (pass-if "size" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (eqv? 5 (stat:size (stat (test-file)))))) + + (with-test-prefix "file descriptor" + + (pass-if "size" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let* ((fd (open-fdes (test-file) O_RDONLY)) + (st (stat fd))) + (close-fdes fd) + (eqv? 5 (stat:size st))))) + + (with-test-prefix "port" + + (pass-if "size" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let* ((port (open-file (test-file) "r+")) + (st (stat port))) + (close-port port) + (eqv? 5 (stat:size st)))))) + diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index a99dfa737..3cdc8dc75 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -1,7 +1,7 @@ ;;;; format.test --- test suite for Guile's CL-ish format -*- scheme -*- ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 ;;;; -;;;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/fractions.test b/test-suite/tests/fractions.test index 9a95e126b..0e1a4d6c1 100644 --- a/test-suite/tests/fractions.test +++ b/test-suite/tests/fractions.test @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License version 2 as diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index c425e2daa..abd714b9a 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -1,5 +1,5 @@ ;;;; gc.test --- test guile's garbage collection -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 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 diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index b73eeb402..fe4a8872b 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -1,7 +1,7 @@ ;;;; getopt-long.test --- long options processing -*- scheme -*- ;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001 ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 7939ab296..dd61369c5 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -1,6 +1,6 @@ ;;;; goops.test --- test suite for GOOPS -*- scheme -*- ;;;; -;;;; Copyright (C) 2001,2003,2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2001,2003,2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test index f07e4a904..15f67e609 100644 --- a/test-suite/tests/guardians.test +++ b/test-suite/tests/guardians.test @@ -1,7 +1,7 @@ ;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- July 1999 ;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index 2c589a088..8215df118 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -1,6 +1,6 @@ ;;;; hash.test --- test guile hashing -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test index cb43c019d..f8ed39919 100644 --- a/test-suite/tests/hooks.test +++ b/test-suite/tests/hooks.test @@ -1,5 +1,5 @@ ;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*- -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/import.test b/test-suite/tests/import.test index cdd75e5a2..4c4be02b2 100644 --- a/test-suite/tests/import.test +++ b/test-suite/tests/import.test @@ -1,5 +1,5 @@ ;;;; import.test --- test selective and renaming imports -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test index c84e6b397..a091515b9 100644 --- a/test-suite/tests/interp.test +++ b/test-suite/tests/interp.test @@ -1,6 +1,6 @@ ;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*- ;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 98c14e9e6..7dc0ef0f8 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -1,5 +1,5 @@ ;;;; list.test --- tests guile's lists -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 6bcd01f2e..a71a34716 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -1,7 +1,7 @@ ;;;; load.test --- test LOAD and path searching functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; -;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test new file mode 100644 index 000000000..9541f0662 --- /dev/null +++ b/test-suite/tests/modules.test @@ -0,0 +1,50 @@ +;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- + +;;;; Copyright (C) 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 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 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)) + +(with-test-prefix "autoload" + + (pass-if "autoloaded" + (catch #t + (lambda () + ;; Simple autoloading. + (eval '(begin + (define-module (test-autoload-one) + :autoload (ice-9 q) (make-q)) + (not (not make-q))) + (current-module))) + (lambda (key . args) + #f))) + + ;; In Guile 1.8.0 this failed because the binder in + ;; `make-autoload-interface' would try to remove the autoload interface + ;; from the module's "uses" without making sure it is still part of these + ;; "uses". + ;; + (pass-if "autoloaded+used" + (catch #t + (lambda () + (eval '(begin + (define-module (test-autoload-two) + :autoload (ice-9 q) (make-q) + :use-module (ice-9 q)) + (not (not make-q))) + (current-module))) + (lambda (key . args) + #f)))) diff --git a/test-suite/tests/multilingual.nottest b/test-suite/tests/multilingual.nottest index 18163d3a1..46a3ee2d3 100644 --- a/test-suite/tests/multilingual.nottest +++ b/test-suite/tests/multilingual.nottest @@ -2,7 +2,7 @@ ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; This isn't a test yet, because we don't have multilingual support yet. ;;;; -;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index c19b065ca..54117b044 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1,5 +1,5 @@ ;;;; numbers.test --- tests guile's numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index a45d3609b..040b68ba4 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -1,7 +1,7 @@ ;;;; optargs.test --- test suite for optional arg processing -*- scheme -*- ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/options.test b/test-suite/tests/options.test index 168676b30..f2f87143b 100644 --- a/test-suite/tests/options.test +++ b/test-suite/tests/options.test @@ -1,6 +1,6 @@ ;;;; options.test --- test suite for options interface -*- scheme -*- ;;;; -;;;; Copyright (C) 2002 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/pairs.test b/test-suite/tests/pairs.test index 97fd34f64..af2f3e275 100644 --- a/test-suite/tests/pairs.test +++ b/test-suite/tests/pairs.test @@ -1,6 +1,6 @@ ;;;; pairs.test --- test suite for Guile's pair functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/poe.test b/test-suite/tests/poe.test index 8d353de55..6c7625602 100644 --- a/test-suite/tests/poe.test +++ b/test-suite/tests/poe.test @@ -1,6 +1,6 @@ ;;;; poe.test --- exercise ice-9/poe.scm -*- scheme -*- ;;;; -;;;; Copyright 2003 Free Software Foundation, Inc. +;;;; Copyright 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 @@ -25,6 +25,64 @@ ;; pure-funcq ;; +(with-test-prefix "pure-funcq" + + (with-test-prefix "no args" + (define obj (vector 123)) ;; not gc'ed + (define called #f) + (define (foo) + (set! called #t) + obj) + + (let ((func (pure-funcq foo))) + + (pass-if "called first" + (set! called #f) + (and (eq? obj (func)) + called)) + + (pass-if "not called second" + (set! called #f) + (and (eq? obj (func)) + (not called))))) + + (with-test-prefix "1 arg" + (define obj1 (vector 123)) ;; not gc'ed + (define obj2 (vector 456)) ;; not gc'ed + (define called #f) + (define (foo sym) + (set! called #t) + (case sym + ((x) obj1) + ((y) obj2) + (else (error "oops")))) + + (let ((func (pure-funcq foo))) + + (pass-if "called first x" + (set! called #f) + (and (eq? obj1 (func 'x)) + called)) + + (pass-if "not called second x" + (set! called #f) + (and (eq? obj1 (func 'x)) + (not called))) + + (pass-if "called first y" + (set! called #f) + (and (eq? obj2 (func 'y)) + called)) + + (pass-if "not called second y" + (set! called #f) + (and (eq? obj2 (func 'y)) + (not called))) + + (pass-if "not called third x" + (set! called #f) + (and (eq? obj1 (func 'x)) + (not called)))))) ;; ;; perfect-funcq diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index d83d91c4c..19d3edc49 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -1,6 +1,6 @@ ;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*- ;;;; -;;;; Copyright 2003 Free Software Foundation, Inc. +;;;; Copyright 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 diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index aab58d071..15f888e00 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1,7 +1,7 @@ ;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 ;;;; -;;;; Copyright (C) 1999, 2001, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -538,6 +538,42 @@ (while (not (eof-object? (read-char port)))) (= 8 (port-column port)))))) +;;; +;;; truncate-file +;;; + +(with-test-prefix "truncate-file" + + (with-test-prefix "filename" + + (pass-if "shorten" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (truncate-file (test-file) 1) + (eqv? 1 (stat:size (stat (test-file)))))) + + (with-test-prefix "file descriptor" + + (pass-if "shorten" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((fd (open-fdes (test-file) O_RDWR))) + (truncate-file fd 1) + (close-fdes fd)) + (eqv? 1 (stat:size (stat (test-file)))))) + + (with-test-prefix "file port" + + (pass-if "shorten" + (call-with-output-file (test-file) + (lambda (port) + (display "hello" port))) + (let ((port (open-file (test-file) "r+"))) + (truncate-file port 1)) + (eqv? 1 (stat:size (stat (test-file))))))) + ;;;; testing read-delimited and friends diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index 6e8d51af5..cd76a44ec 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -1,6 +1,6 @@ ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2004 Free Software Foundation, Inc. +;;;; Copyright 2003, 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/q.test b/test-suite/tests/q.test index d9238c3ee..5c24e5202 100644 --- a/test-suite/tests/q.test +++ b/test-suite/tests/q.test @@ -1,6 +1,6 @@ ;;;; q.test --- test (ice-9 q) module -*- scheme -*- ;;;; -;;;; Copyright 2004 Free Software Foundation, Inc. +;;;; Copyright 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 diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index 8abfabb3e..e47364c66 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -1,5 +1,5 @@ ;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*- -;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test index 1c99b5fc9..8fa78e9c1 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/test-suite/tests/r5rs_pitfall.test @@ -1,5 +1,5 @@ ;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*- -;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 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 diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test index 088a2d3e8..d923bc1f2 100644 --- a/test-suite/tests/ramap.test +++ b/test-suite/tests/ramap.test @@ -1,6 +1,6 @@ ;;;; ramap.test --- test array mapping functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/receive.test b/test-suite/tests/receive.test index 2619a268a..4b55bdf9f 100644 --- a/test-suite/tests/receive.test +++ b/test-suite/tests/receive.test @@ -1,6 +1,6 @@ ;;;; receive.test --- Test suite for Guile receive module. -*- scheme -*- ;;;; -;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 1e7cdd20d..7e7914534 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -1,7 +1,7 @@ ;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; -;;;; Copyright (C) 1999, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/slib.test b/test-suite/tests/slib.test index fa9a601ce..e69de29bb 100644 --- a/test-suite/tests/slib.test +++ b/test-suite/tests/slib.test @@ -1,292 +0,0 @@ -;;;; slib.test --- Test suite for Guile's SLIB glue. -*- scheme -*- -;;;; -;;;; Copyright 2003, 2004 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;;; Boston, MA 02110-1301 USA - -;; These tests are run only if slib is available. slib will need to be -;; installed (or linked) under the configured guile $prefix. -;; -(if (catch #t - (lambda () (resolve-module '(ice-9 slib))) - (lambda args #f)) - (begin - - (define-module (test-suite test-ice-9-slib) - #:use-module (test-suite lib) - #:use-module (ice-9 slib)) - - - (with-test-prefix "Configuration" - - ;; - ;; char-code-limit - ;; - - (with-test-prefix "char-code-limit" - (pass-if "integer" (integer? char-code-limit))) - - ;; - ;; most-positive-fixnum - ;; - - (with-test-prefix "most-positive-fixnum" - (pass-if "integer" (integer? most-positive-fixnum))) - - ;; - ;; slib:form-feed - ;; - - (with-test-prefix "slib:form-feed" - ;; in guile 1.6.4 this wasn't exported - (pass-if "char" (char? slib:form-feed))) - - ;; - ;; slib:report - ;; - - (with-test-prefix "slib:report" - (pass-if "exists" (procedure? slib:report))) - - ;; - ;; slib:report-version - ;; - - (with-test-prefix "slib:report-version" - (pass-if "exists" (procedure? slib:report-version))) - - ;; - ;; slib:tab - ;; - - (with-test-prefix "slib:tab" - ;; in guile 1.6.4 this wasn't exported - (pass-if "char" (char? slib:tab))) - - ;; - ;; software-type - ;; - - (with-test-prefix "software-type" - (pass-if "exists" (procedure? software-type)))) - - - (with-test-prefix "Input/Output" - - ;; - ;; call-with-open-ports - ;; - - (with-test-prefix "call-with-open-ports" - (pass-if "exists" (procedure? call-with-open-ports)) - - (pass-if "close on return" - (let ((port (open-input-file "/dev/null"))) - (call-with-open-ports port (lambda (port) #f)) - (port-closed? port)))) - - ;; - ;; delete-file - ;; - - ;; in guile 1.6.4 and earlier delete-file didn't match the slib spec - (with-test-prefix "delete-file" - (pass-if "non existant file" - (eq? #f (delete-file "nosuchfile"))) - (pass-if "existing file" - (call-with-output-file "slibtest.tmp" noop) - (eq? #t (delete-file "slibtest.tmp")))) - - ;; - ;; output-port-height - ;; - - (with-test-prefix "output-port-height" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? output-port-height))) - - ;; - ;; output-port-width - ;; - - (with-test-prefix "output-port-width" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? output-port-width))) - - ;; - ;; open-file - ;; - - ;; this style open-file is only a requirement in slib 3a1 and up, but - ;; we provide it always - (with-test-prefix "open-file" - (pass-if "r" (port? (open-file "/dev/null" 'r))) - (pass-if "rb" (port? (open-file "/dev/null" 'rb))) - (pass-if "w" (port? (open-file "/dev/null" 'w))) - (pass-if "wb" (port? (open-file "/dev/null" 'wb))))) - - - (with-test-prefix "System stuff" - - ;; - ;; browse-url - ;; - - (with-test-prefix "browse-url" - (pass-if "exists" (procedure? browse-url))) - - ;; - ;; slib:error - ;; - - (with-test-prefix "slib:error" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? slib:error))) - - ;; - ;; slib:eval - ;; - - (with-test-prefix "slib:eval" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? slib:eval))) - - ;; - ;; slib:eval-load - ;; - - (with-test-prefix "slib:eval-load" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? slib:eval-load))) - - ;; - ;; slib:exit - ;; - - (with-test-prefix "slib:exit" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? slib:exit))) - - ;; - ;; slib:load - ;; - - (with-test-prefix "slib:load" - (pass-if "exists" (procedure? slib:load))) - - ;; - ;; slib:load-source - ;; - - (with-test-prefix "slib:load-source" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? slib:load-source))) - - ;; - ;; slib:warn - ;; - - (with-test-prefix "slib:warn" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? slib:warn)))) - - - (with-test-prefix "Miscellany" - - ;; - ;; identity - ;; - - (with-test-prefix "identity" - (pass-if "exists" (procedure? identity))) - - (with-test-prefix "Legacy" - - ;; - ;; nil - ;; - - ;; in guile 1.6.4 and earlier this was missing - (with-test-prefix "nil" - (pass-if "value" (eq? #f nil))) - - ;; - ;; t - ;; - - ;; in guile 1.6.4 and earlier this was missing - (with-test-prefix "t" - (pass-if "value" (eq? #t t))))) - - - ;; - ;; rev2-procedures - ;; - - ;; in guile 1.6.4 the 'rev2-procedures feature we defined claimed - ;; these existed, but they didn't - (with-test-prefix "rev2-procedures" - (require 'rev2-procedures) - (pass-if "-1+" (procedure? -1+)) - (pass-if "<?" (procedure? <?)) - (pass-if "<=?" (procedure? <=?)) - (pass-if "=?" (procedure? =?)) - (pass-if ">?" (procedure? >?)) - (pass-if ">=?" (procedure? >=?))) - - - ;; - ;; system - ;; - - ;; in guile 1.6.4 and earlier system didn't match the slib spec - (with-test-prefix "system" - (pass-if "exit 0" (= 0 (system "exit 0"))) - (pass-if "exit 1" (= 1 (system "exit 1"))) - (pass-if "exit 99" (= 99 (system "exit 99")))) - - - (with-test-prefix "Time" - - ;; - ;; difftime - ;; - - (with-test-prefix "difftime" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? difftime))) - - ;; - ;; offset-time - ;; - - (with-test-prefix "offset-time" - ;; in guile 1.6.4 this wasn't exported - (pass-if "exists" (procedure? offset-time)))) - - - (require 'array) - (with-test-prefix "array" - - ;; - ;; create-array - ;; - - ;; create-array isn't in old slib, but when it exists it should work - (if (defined? 'create-array) - (with-test-prefix "create-array" - (pass-if "As32 create" - (array? (create-array (As32 0) '(0 1))))))))) diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test index 79df42f0b..dd91f35b6 100644 --- a/test-suite/tests/socket.test +++ b/test-suite/tests/socket.test @@ -1,6 +1,6 @@ ;;;; socket.test --- test socket functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test index 77c2da858..af4578ca0 100644 --- a/test-suite/tests/sort.test +++ b/test-suite/tests/sort.test @@ -1,5 +1,5 @@ ;;;; sort.test --- tests Guile's sort functions -*- scheme -*- -;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test index 084a752be..5bfe68080 100644 --- a/test-suite/tests/srcprop.test +++ b/test-suite/tests/srcprop.test @@ -1,6 +1,6 @@ ;;;; srcprop.test --- test Guile source properties -*- scheme -*- ;;;; -;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; 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 diff --git a/test-suite/tests/srfi-10.test b/test-suite/tests/srfi-10.test index 96642e00a..248c04ff7 100644 --- a/test-suite/tests/srfi-10.test +++ b/test-suite/tests/srfi-10.test @@ -1,7 +1,7 @@ ;;;; srfi-10.test --- Test suite for Guile's SRFI-10 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-05-10 ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-11.test b/test-suite/tests/srfi-11.test index 3c2ad2f37..ec2ed86c8 100644 --- a/test-suite/tests/srfi-11.test +++ b/test-suite/tests/srfi-11.test @@ -1,6 +1,6 @@ ;;;; srfi-11.test --- exercise SRFI-11 let-values ;;;; -;;;; Copyright 2004 Free Software Foundation, Inc. +;;;; Copyright 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index b135434e5..89759d0d3 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -1,7 +1,7 @@ ;;;; srfi-13.test --- Test suite for Guile's SRFI-13 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-05-07 ;;;; -;;;; Copyright (C) 2001, 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -18,11 +18,20 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (srfi srfi-13) (srfi srfi-14) (test-suite lib)) +(define-module (test-strings) + #:use-module (test-suite lib) + #:use-module (srfi srfi-13) + #:use-module (srfi srfi-14)) + (define exception:strict-infix-grammar (cons 'misc-error "^strict-infix")) +;; Create a string from integer char values, eg. (string-ints 65) => "A" +(define (string-ints . args) + (apply string (map integer->char args))) + + ;;; ;;; string-any ;;; @@ -185,6 +194,32 @@ (pass-if (equal? "abc" (string-concatenate '("a" "b" "c"))))) +;; +;; string-compare +;; + +(with-test-prefix "string-compare" + + (pass-if "same as char<?" + (eq? (char<? (integer->char 0) (integer->char 255)) + (string-compare (string-ints 0) (string-ints 255) + (lambda (pos) #t) ;; lt + (lambda (pos) #f) ;; eq + (lambda (pos) #f))))) ;; gt + +;; +;; string-compare-ci +;; + +(with-test-prefix "string-compare-ci" + + (pass-if "same as char-ci<?" + (eq? (char-ci<? (integer->char 0) (integer->char 255)) + (string-compare-ci (string-ints 0) (string-ints 255) + (lambda (pos) #t) ;; lt + (lambda (pos) #f) ;; eq + (lambda (pos) #f))))) ;; gt + ;;; ;;; string-concatenate/shared ;;; diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test index ca4e961e6..fabb7842d 100644 --- a/test-suite/tests/srfi-14.test +++ b/test-suite/tests/srfi-14.test @@ -1,7 +1,7 @@ ;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-07-16 ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index 52a195576..806b420a6 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -1,6 +1,6 @@ ;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*- ;;;; -;;;; Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index f694b8613..126198afa 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -1,7 +1,7 @@ ;;;; 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 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index 5f00a73b5..bd6977333 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -1,6 +1,6 @@ ;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*- ;;;; -;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; 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 diff --git a/test-suite/tests/srfi-34.test b/test-suite/tests/srfi-34.test index 1875f39da..2c7f4b202 100644 --- a/test-suite/tests/srfi-34.test +++ b/test-suite/tests/srfi-34.test @@ -1,6 +1,6 @@ ;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*- ;;;; -;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-39.test b/test-suite/tests/srfi-39.test index 2c09d138d..1b7923a25 100644 --- a/test-suite/tests/srfi-39.test +++ b/test-suite/tests/srfi-39.test @@ -1,6 +1,6 @@ ;;;; srfi-39.test --- -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test index b2e80f5e4..ee773a3f9 100644 --- a/test-suite/tests/srfi-4.test +++ b/test-suite/tests/srfi-4.test @@ -1,7 +1,7 @@ ;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-06-26 ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test index 1b485939b..217fc9f78 100644 --- a/test-suite/tests/srfi-6.test +++ b/test-suite/tests/srfi-6.test @@ -1,6 +1,6 @@ ;;;; srfi-6.test --- test suite for SRFI-6 -*- scheme -*- ;;;; -;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-60.test b/test-suite/tests/srfi-60.test index a521529a8..5822cb1d0 100644 --- a/test-suite/tests/srfi-60.test +++ b/test-suite/tests/srfi-60.test @@ -1,6 +1,6 @@ ;;;; srfi-60.test --- Test suite for Guile's SRFI-60 functions. -*- scheme -*- ;;;; -;;;; Copyright 2005 Free Software Foundation, Inc. +;;;; Copyright 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index 4781b80ad..9a6f8e31a 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -1,7 +1,7 @@ ;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-05-10 ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/streams.test b/test-suite/tests/streams.test index 1d5fc8d95..92277c19c 100644 --- a/test-suite/tests/streams.test +++ b/test-suite/tests/streams.test @@ -1,6 +1,6 @@ ;;;; streams.test --- test Guile ice-9 streams module -*- scheme -*- ;;;; -;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 7a2d40d40..aa9196e68 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,7 +1,7 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- August 1999 ;;;; -;;;; Copyright (C) 1999, 2001, 2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -18,11 +18,22 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (test-suite lib)) +(define-module (test-strings) + #:use-module (test-suite lib)) + (define exception:read-only-string (cons 'misc-error "^string is read-only")) +;; Create a string from integer char values, eg. (string-ints 65) => "A" +(define (string-ints . args) + (apply string (map integer->char args))) + + +;; +;; string=? +;; + (with-test-prefix "string=?" (pass-if "respects 1st parameter's string length" @@ -41,6 +52,10 @@ exception:wrong-type-arg (string=? "a" 'b)))) +;; +;; string<? +;; + (with-test-prefix "string<?" (pass-if "respects string length" @@ -55,7 +70,15 @@ (pass-if-exception "2nd argument symbol" exception:wrong-type-arg - (string<? "a" 'b)))) + (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<?" @@ -71,7 +94,75 @@ (pass-if-exception "2nd argument symbol" exception:wrong-type-arg - (string-ci<? "a" 'b)))) + (string-ci<? "a" 'b))) + + (pass-if "same as char-ci<?" + (eq? (char-ci<? (integer->char 0) (integer->char 255)) + (string-ci<? (string-ints 0) (string-ints 255))))) + +;; +;; string<=? +;; + +(with-test-prefix "string<=?" + + (pass-if "same as char<=?" + (eq? (char<=? (integer->char 0) (integer->char 255)) + (string<=? (string-ints 0) (string-ints 255))))) + +;; +;; string-ci<=? +;; + +(with-test-prefix "string-ci<=?" + + (pass-if "same as char-ci<=?" + (eq? (char-ci<=? (integer->char 0) (integer->char 255)) + (string-ci<=? (string-ints 0) (string-ints 255))))) + +;; +;; string>? +;; + +(with-test-prefix "string>?" + + (pass-if "same as char>?" + (eq? (char>? (integer->char 0) (integer->char 255)) + (string>? (string-ints 0) (string-ints 255))))) + +;; +;; string-ci>? +;; + +(with-test-prefix "string-ci>?" + + (pass-if "same as char-ci>?" + (eq? (char-ci>? (integer->char 0) (integer->char 255)) + (string-ci>? (string-ints 0) (string-ints 255))))) + +;; +;; string>=? +;; + +(with-test-prefix "string>=?" + + (pass-if "same as char>=?" + (eq? (char>=? (integer->char 0) (integer->char 255)) + (string>=? (string-ints 0) (string-ints 255))))) + +;; +;; string-ci>=? +;; + +(with-test-prefix "string-ci>=?" + + (pass-if "same as char-ci>=?" + (eq? (char-ci>=? (integer->char 0) (integer->char 255)) + (string-ci>=? (string-ints 0) (string-ints 255))))) + +;; +;; string-set! +;; (with-test-prefix "string-set!" diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test index 88632aa1e..b57667f7f 100644 --- a/test-suite/tests/symbols.test +++ b/test-suite/tests/symbols.test @@ -1,6 +1,6 @@ ;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*- ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index 4df9dfa2b..1184f7b54 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -1,6 +1,6 @@ ;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*- ;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index e944d30a4..37d608ce7 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -1,6 +1,6 @@ ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- ;;;; -;;;; Copyright (C) 2001,2003,2004, 2005 Free Software Foundation, Inc. +;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 88109655f..511927719 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -1,6 +1,6 @@ ;;;; threads.test --- Tests for Guile threading. -*- scheme -*- ;;;; -;;;; Copyright 2003 Free Software Foundation, Inc. +;;;; Copyright 2003, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index b872e1b99..3cbbb15f8 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -1,7 +1,7 @@ ;;;; time.test --- test suite for Guile's time functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004 ;;;; -;;;; Copyright (C) 1999, 2004 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2004, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 062a34e91..a5be1826f 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -1,6 +1,6 @@ ;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- ;;;; -;;;; Copyright 2004 Free Software Foundation, Inc. +;;;; Copyright 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 @@ -325,6 +325,20 @@ (with-test-prefix "array-set!" + (with-test-prefix "bitvector" + + ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set! + ;; on a bitvector like the following + (let ((a (make-bitvector 1))) + (pass-if "one elem set #t" + (begin + (array-set! a #t 0) + (eq? #t (array-ref a 0)))) + (pass-if "one elem set #f" + (begin + (array-set! a #f 0) + (eq? #f (array-ref a 0)))))) + (with-test-prefix "byte" (let ((a (make-s8vector 1))) @@ -406,8 +420,69 @@ ;;; make-shared-array ;;; +(define exception:mapping-out-of-range + (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array + (with-test-prefix "make-shared-array" + ;; this failed in guile 1.8.0 + (pass-if "vector unchanged" + (let* ((a (make-array #f '(0 7))) + (s (make-shared-array a list '(0 7)))) + (array-equal? a s))) + + (pass-if-exception "vector, high too big" exception:mapping-out-of-range + (let* ((a (make-array #f '(0 7)))) + (make-shared-array a list '(0 8)))) + + (pass-if-exception "vector, low too big" exception:out-of-range + (let* ((a (make-array #f '(0 7)))) + (make-shared-array a list '(-1 7)))) + + (pass-if "truncate columns" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2) + #2((a b) (d e) (g h)))) + + (pass-if "pick one column" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i) (list i 2)) + '(0 2)) + #(c f i))) + + (pass-if "diagonal" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i) (list i i)) + '(0 2)) + #(a e i))) + + ;; this failed in guile 1.8.0 + (pass-if "2 dims from 1 dim" + (array-equal? (make-shared-array #1(a b c d e f g h i j k l) + (lambda (i j) (list (+ (* i 3) j))) + 4 3) + #2((a b c) (d e f) (g h i) (j k l)))) + + (pass-if "reverse columns" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i j) (list i (- 2 j))) + 3 3) + #2((c b a) (f e d) (i h g)))) + + (pass-if "fixed offset, 0 based becomes 1 based" + (let* ((x #2((a b c) (d e f) (g h i))) + (y (make-shared-array x + (lambda (i j) (list (1- i) (1- j))) + '(1 3) '(1 3)))) + (and (eq? (array-ref x 0 0) 'a) + (eq? (array-ref y 1 1) 'a)))) + + ;; this failed in guile 1.8.0 + (pass-if "stride every third element" + (array-equal? (make-shared-array #1(a b c d e f g h i j k l) + (lambda (i) (list (* i 3))) + 4) + #1(a d g j))) + (pass-if "shared of shared" (let* ((a #2((1 2 3) (4 5 6) (7 8 9))) (s1 (make-shared-array a (lambda (i) (list i 1)) 3)) diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test index c4907f872..1fb16bcb0 100644 --- a/test-suite/tests/vectors.test +++ b/test-suite/tests/vectors.test @@ -1,6 +1,6 @@ ;;;; vectors.test --- test suite for Guile's vector functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test index 0ef230629..b2a491950 100644 --- a/test-suite/tests/version.test +++ b/test-suite/tests/version.test @@ -1,7 +1,7 @@ ;;;; versions.test --- test suite for Guile's version functions -*- scheme -*- ;;;; Greg J. Badros <gjb@cs.washington.edu> ;;;; -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test index 64edb735e..7bb77b07c 100644 --- a/test-suite/tests/weaks.test +++ b/test-suite/tests/weaks.test @@ -1,5 +1,5 @@ ;;;; weaks.test --- tests guile's weaks -*- scheme -*- -;;;; Copyright (C) 1999, 2001, 2003 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 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 |