diff options
Diffstat (limited to 'test-suite/tests')
90 files changed, 4187 insertions, 1062 deletions
diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index a9e9b0d24..699c10ef4 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/and-let-star.test b/test-suite/tests/and-let-star.test index 0f74934f7..150600c34 100644 --- a/test-suite/tests/and-let-star.test +++ b/test-suite/tests/and-let-star.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; 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-and-let-star) #:use-module (test-suite lib) diff --git a/test-suite/tests/arbiters.test b/test-suite/tests/arbiters.test index 7591f02f0..36dc7edbd 100644 --- a/test-suite/tests/arbiters.test +++ b/test-suite/tests/arbiters.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test new file mode 100644 index 000000000..a8e251b83 --- /dev/null +++ b/test-suite/tests/asm-to-bytecode.test @@ -0,0 +1,110 @@ +;;;; test assembly to bytecode compilation -*- scheme -*- +;;;; +;;;; 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 asm-to-bytecode) + #:use-module (rnrs bytevector) + #:use-module (test-suite lib) + #:use-module (system vm instruction) + #:use-module (language assembly compile-bytecode)) + +(define (->u8-list sym val) + (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) + (uint32 4 ,bytevector-u32-native-set!)) + sym))) + (or entry (error "unknown sym" sym)) + (let ((bv (make-bytevector (car entry)))) + ((cadr entry) bv 0 val) + (bytevector->u8-list bv)))) + +(define (munge-bytecode v) + (let lp ((i 0) (out '())) + (if (= i (vector-length v)) + (list->u8vector (reverse out)) + (let ((x (vector-ref v i))) + (cond + ((symbol? x) + (lp (1+ i) (cons (instruction->opcode x) out))) + ((integer? x) + (lp (1+ i) (cons x out))) + ((pair? x) + (lp (1+ i) (append (reverse (apply ->u8-list x)) out))) + (else (error "bad test bytecode" x))))))) + +(define (comp-test x y) + (let* ((y (munge-bytecode y)) + (len (u8vector-length y)) + (v (make-u8vector len)) + (i 0)) + (define (write-byte b) (u8vector-set! v i b) (set! i (1+ i))) + (define (get-addr) i) + (run-test `(length ,x) #t + (lambda () + (write-bytecode x write-byte get-addr '()) + (= i len))) + (run-test `(compile-equal? ,x ,y) #t + (lambda () + (equal? v y))))) + + +(with-test-prefix "compiler" + (with-test-prefix "asm-to-bytecode" + + (comp-test '(make-int8 3) + #(make-int8 3)) + + (comp-test '(load-number "3.14") + (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.) + (char->integer #\1) (char->integer #\4))) + + (comp-test '(load-string "foo") + (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o) + (char->integer #\o))) + + (comp-test '(load-symbol "foo") + (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o) + (char->integer #\o))) + + (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) + #(load-program + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 0) ;; metalen + (uint32 0) ;; padding + make-int8 3 + return)) + + ;; the nops are to pad meta to an 8-byte alignment. not strictly + ;; necessary for this test, but representative of the common case. + (comp-test '(load-program 3 2 1 () 8 + (load-program 3 2 1 () 3 + #f + (make-int8 3) (return)) + (make-int8 3) (return) + (nop) (nop) (nop) (nop) (nop)) + #(load-program + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 8) ;; len + (uint32 19) ;; metalen + (uint32 0) ;; padding + make-int8 3 + return + nop nop nop nop nop + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 0) ;; metalen + (uint32 0) ;; padding + make-int8 3 + return)))) diff --git a/test-suite/tests/bit-operations.test b/test-suite/tests/bit-operations.test index 8e35257b3..0e9df7d09 100644 --- a/test-suite/tests/bit-operations.test +++ b/test-suite/tests/bit-operations.test @@ -1,10 +1,10 @@ ;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 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 2.1 of the License, or (at your option) any later version. +;;;; 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 @@ -15,8 +15,9 @@ ;;;; 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) - (ice-9 documentation)) +(define-module (test-bit-operations) + :use-module (test-suite lib) + :use-module (ice-9 documentation)) ;;; diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test new file mode 100644 index 000000000..1009fb051 --- /dev/null +++ b/test-suite/tests/bytevectors.test @@ -0,0 +1,684 @@ +;;;; bytevectors.test --- Exercise the R6RS bytevector API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-bytevector) + :use-module (test-suite lib) + :use-module (system base compile) + :use-module (rnrs bytevector)) + +;;; Some of the tests in here are examples taken from the R6RS Standard +;;; Libraries document. + +(define-syntax c&e + (syntax-rules (pass-if pass-if-exception) + ((_ (pass-if test-name exp)) + (begin (pass-if (string-append test-name " (eval)") + (primitive-eval 'exp)) + (pass-if (string-append test-name " (compile)") + (compile 'exp #:to 'value)))) + ((_ (pass-if-exception test-name exc exp)) + (begin (pass-if-exception (string-append test-name " (eval)") + exc (primitive-eval 'exp)) + (pass-if-exception (string-append test-name " (compile)") + exc (compile 'exp #:to 'value)))))) + +(define-syntax with-test-prefix/c&e + (syntax-rules () + ((_ section-name exp ...) + (with-test-prefix section-name (c&e exp) ...)))) + + + +(with-test-prefix/c&e "2.2 General Operations" + + (pass-if "native-endianness" + (not (not (memq (native-endianness) '(big little))))) + + (pass-if "make-bytevector" + (and (bytevector? (make-bytevector 20)) + (bytevector? (make-bytevector 20 3)))) + + (pass-if "bytevector-length" + (= (bytevector-length (make-bytevector 20)) 20)) + + (pass-if "bytevector=?" + (and (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 7)) + (not (bytevector=? (make-bytevector 20 7) + (make-bytevector 20 0)))))) + + +(with-test-prefix/c&e "2.3 Operations on Bytes and Octets" + + (pass-if "bytevector-{u8,s8}-ref" + (equal? '(-127 129 -1 255) + (let ((b1 (make-bytevector 16 -127)) + (b2 (make-bytevector 16 255))) + (list (bytevector-s8-ref b1 0) + (bytevector-u8-ref b1 0) + (bytevector-s8-ref b2 0) + (bytevector-u8-ref b2 0))))) + + (pass-if "bytevector-{u8,s8}-set!" + (equal? '(-126 130 -10 246) + (let ((b (make-bytevector 16 -127))) + + (bytevector-s8-set! b 0 -126) + (bytevector-u8-set! b 1 246) + + (list (bytevector-s8-ref b 0) + (bytevector-u8-ref b 0) + (bytevector-s8-ref b 1) + (bytevector-u8-ref b 1))))) + + (pass-if "bytevector->u8-list" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list + (let ((b (make-bytevector 6))) + (for-each (lambda (i v) + (bytevector-u8-set! b i v)) + (iota 6) + lst) + b))))) + + (pass-if "u8-list->bytevector" + (let ((lst '(1 2 3 128 150 255))) + (equal? lst + (bytevector->u8-list (u8-list->bytevector lst))))) + + (pass-if "bytevector-uint-{ref,set!} [small]" + (let ((b (make-bytevector 15))) + (bytevector-uint-set! b 0 #x1234 + (endianness little) 2) + (equal? (bytevector-uint-ref b 0 (endianness big) 2) + #x3412))) + + (pass-if "bytevector-uint-set! [large]" + (let ((b (make-bytevector 16))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector->u8-list b) + '(253 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 255)))) + + (pass-if "bytevector-uint-{ref,set!} [large]" + (let ((b (make-bytevector 120))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-uint-ref b 0 (endianness little) 16) + #xfffffffffffffffffffffffffffffffd))) + + (pass-if "bytevector-sint-ref [small]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-sint-ref b 0 (endianness big) 2) + (bytevector-sint-ref b 1 (endianness little) 2) + -16))) + + (pass-if "bytevector-sint-ref [large]" + (let ((b (make-bytevector 50))) + (bytevector-uint-set! b 0 (- (expt 2 128) 3) + (endianness little) 16) + (equal? (bytevector-sint-ref b 0 (endianness little) 16) + -3))) + + (pass-if "bytevector-sint-set! [small]" + (let ((b (make-bytevector 3))) + (bytevector-sint-set! b 0 -16 (endianness big) 2) + (bytevector-sint-set! b 1 -16 (endianness little) 2) + (equal? (bytevector->u8-list b) + '(#xff #xf0 #xff)))) + + (pass-if "equal?" + (let ((bv1 (u8-list->bytevector (iota 123))) + (bv2 (u8-list->bytevector (iota 123)))) + (equal? bv1 bv2)))) + + +(with-test-prefix/c&e "2.4 Operations on Integers of Arbitrary Size" + + (pass-if "bytevector->sint-list" + (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (equal? (bytevector->sint-list b (endianness little) 2) + '(513 -253 513 513)))) + + (pass-if "bytevector->uint-list" + (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1)))) + (equal? (bytevector->uint-list b (endianness big) 2) + '(513 65283 513 513)))) + + (pass-if "bytevector->uint-list [empty]" + (let ((b (make-bytevector 0))) + (null? (bytevector->uint-list b (endianness big) 2)))) + + (pass-if-exception "bytevector->sint-list [out-of-range]" + exception:out-of-range + (bytevector->sint-list (make-bytevector 6) (endianness little) 8)) + + (pass-if "bytevector->sint-list [off-by-one]" + (equal? (bytevector->sint-list (make-bytevector 31 #xff) + (endianness little) 8) + '(-1 -1 -1))) + + (pass-if "{sint,uint}-list->bytevector" + (let ((b1 (sint-list->bytevector '(513 -253 513 513) + (endianness little) 2)) + (b2 (uint-list->bytevector '(513 65283 513 513) + (endianness little) 2)) + (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (and (bytevector=? b1 b2) + (bytevector=? b2 b3)))) + + (pass-if "sint-list->bytevector [limits]" + (bytevector=? (sint-list->bytevector '(-32768 32767) + (endianness big) 2) + (let ((bv (make-bytevector 4))) + (bytevector-u8-set! bv 0 #x80) + (bytevector-u8-set! bv 1 #x00) + (bytevector-u8-set! bv 2 #x7f) + (bytevector-u8-set! bv 3 #xff) + bv))) + + (pass-if-exception "sint-list->bytevector [out-of-range]" + exception:out-of-range + (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big) + 2)) + + (pass-if-exception "uint-list->bytevector [out-of-range]" + exception:out-of-range + (uint-list->bytevector '(0 -1) (endianness big) 2))) + + +(with-test-prefix/c&e "2.5 Operations on 16-Bit Integers" + + (pass-if "bytevector-u16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u16-ref b 14 (endianness little)) + #xfdff) + (equal? (bytevector-u16-ref b 14 (endianness big)) + #xfffd)))) + + (pass-if "bytevector-s16-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s16-ref b 14 (endianness little)) + -513) + (equal? (bytevector-s16-ref b 14 (endianness big)) + -3)))) + + (pass-if "bytevector-s16-ref [unaligned]" + (let ((b (u8-list->bytevector '(#xff #xf0 #xff)))) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -16))) + + (pass-if "bytevector-{u16,s16}-ref" + (let ((b (make-bytevector 2))) + (bytevector-u16-set! b 0 44444 (endianness little)) + (and (equal? (bytevector-u16-ref b 0 (endianness little)) + 44444) + (equal? (bytevector-s16-ref b 0 (endianness little)) + (- 44444 65536))))) + + (pass-if "bytevector-native-{u16,s16}-{ref,set!}" + (let ((b (make-bytevector 2))) + (bytevector-u16-native-set! b 0 44444) + (and (equal? (bytevector-u16-native-ref b 0) + 44444) + (equal? (bytevector-s16-native-ref b 0) + (- 44444 65536))))) + + (pass-if "bytevector-s16-{ref,set!} [unaligned]" + (let ((b (make-bytevector 3))) + (bytevector-s16-set! b 1 -77 (endianness little)) + (equal? (bytevector-s16-ref b 1 (endianness little)) + -77)))) + + +(with-test-prefix/c&e "2.6 Operations on 32-bit Integers" + + (pass-if "bytevector-u32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u32-ref b 12 (endianness little)) + #xfdffffff) + (equal? (bytevector-u32-ref b 12 (endianness big)) + #xfffffffd)))) + + (pass-if "bytevector-s32-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s32-ref b 12 (endianness little)) + -33554433) + (equal? (bytevector-s32-ref b 12 (endianness big)) + -3)))) + + (pass-if "bytevector-{u32,s32}-ref" + (let ((b (make-bytevector 4))) + (bytevector-u32-set! b 0 2222222222 (endianness little)) + (and (equal? (bytevector-u32-ref b 0 (endianness little)) + 2222222222) + (equal? (bytevector-s32-ref b 0 (endianness little)) + (- 2222222222 (expt 2 32)))))) + + (pass-if "bytevector-{u32,s32}-native-{ref,set!}" + (let ((b (make-bytevector 4))) + (bytevector-u32-native-set! b 0 2222222222) + (and (equal? (bytevector-u32-native-ref b 0) + 2222222222) + (equal? (bytevector-s32-native-ref b 0) + (- 2222222222 (expt 2 32))))))) + + +(with-test-prefix/c&e "2.7 Operations on 64-bit Integers" + + (pass-if "bytevector-u64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-u64-ref b 8 (endianness little)) + #xfdffffffffffffff) + (equal? (bytevector-u64-ref b 8 (endianness big)) + #xfffffffffffffffd)))) + + (pass-if "bytevector-s64-ref" + (let ((b (u8-list->bytevector + '(255 255 255 255 255 255 255 255 + 255 255 255 255 255 255 255 253)))) + (and (equal? (bytevector-s64-ref b 8 (endianness little)) + -144115188075855873) + (equal? (bytevector-s64-ref b 8 (endianness big)) + -3)))) + + (pass-if "bytevector-{u64,s64}-ref" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-set! b 0 big (endianness little)) + (and (equal? (bytevector-u64-ref b 0 (endianness little)) + big) + (equal? (bytevector-s64-ref b 0 (endianness little)) + (- big (expt 2 64)))))) + + (pass-if "bytevector-{u64,s64}-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (big 9333333333333333333)) + (bytevector-u64-native-set! b 0 big) + (and (equal? (bytevector-u64-native-ref b 0) + big) + (equal? (bytevector-s64-native-ref b 0) + (- big (expt 2 64)))))) + + (pass-if "ref/set! with zero" + (let ((b (make-bytevector 8))) + (bytevector-s64-set! b 0 -1 (endianness big)) + (bytevector-u64-set! b 0 0 (endianness big)) + (= 0 (bytevector-u64-ref b 0 (endianness big)))))) + + +(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations" + + (pass-if "bytevector-ieee-single-native-{ref,set!}" + (let ((b (make-bytevector 4)) + (number 3.00)) + (bytevector-ieee-single-native-set! b 0 number) + (equal? (bytevector-ieee-single-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-single-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-single-set! b 0 number (endianness little)) + (bytevector-ieee-single-set! b 4 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 0 (endianness little)) + (bytevector-ieee-single-ref b 4 (endianness big))))) + + (pass-if "bytevector-ieee-single-{ref,set!} [unaligned]" + (let ((b (make-bytevector 9)) + (number 3.14)) + (bytevector-ieee-single-set! b 1 number (endianness little)) + (bytevector-ieee-single-set! b 5 number (endianness big)) + (equal? (bytevector-ieee-single-ref b 1 (endianness little)) + (bytevector-ieee-single-ref b 5 (endianness big))))) + + (pass-if "bytevector-ieee-double-native-{ref,set!}" + (let ((b (make-bytevector 8)) + (number 3.14)) + (bytevector-ieee-double-native-set! b 0 number) + (equal? (bytevector-ieee-double-native-ref b 0) + number))) + + (pass-if "bytevector-ieee-double-{ref,set!}" + (let ((b (make-bytevector 16)) + (number 3.14)) + (bytevector-ieee-double-set! b 0 number (endianness little)) + (bytevector-ieee-double-set! b 8 number (endianness big)) + (equal? (bytevector-ieee-double-ref b 0 (endianness little)) + (bytevector-ieee-double-ref b 8 (endianness big)))))) + + +(define (with-locale locale thunk) + ;; Run THUNK under LOCALE. + (let ((original-locale (setlocale LC_ALL))) + (catch 'system-error + (lambda () + (setlocale LC_ALL locale)) + (lambda (key . args) + (throw 'unresolved))) + + (dynamic-wind + (lambda () + #t) + thunk + (lambda () + (setlocale LC_ALL original-locale))))) + +(define (with-latin1-locale thunk) + ;; Try out several ISO-8859-1 locales and run THUNK under the one that + ;; works (if any). + (define %locales + (map (lambda (name) + (string-append name ".ISO-8859-1")) + '("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))) + + (let loop ((locales %locales)) + (if (null? locales) + (throw 'unresolved) + (catch 'unresolved + (lambda () + (with-locale (car locales) thunk)) + (lambda (key . args) + (loop (cdr locales))))))) + + +;; Default to the C locale for the following tests. +(setlocale LC_ALL "C") + + +(with-test-prefix "2.9 Operations on Strings" + + (pass-if "string->utf8" + (let* ((str "hello, world") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (string-length str)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "string->utf8 [latin-1]" + (with-latin1-locale + (lambda () + (let* ((str "hé, ça va bien ?") + (utf8 (string->utf8 str))) + (and (bytevector? utf8) + (= (bytevector-length utf8) + (+ 2 (string-length str)))))))) + + (pass-if "string->utf16" + (let* ((str "hello, world") + (utf16 (string->utf16 str))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness big) 2)))))) + + (pass-if "string->utf16 [little]" + (let* ((str "hello, world") + (utf16 (string->utf16 str (endianness little)))) + (and (bytevector? utf16) + (= (bytevector-length utf16) + (* 2 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 + (endianness little) 2)))))) + + + (pass-if "string->utf32" + (let* ((str "hello, world") + (utf32 (string->utf32 str))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness big) 4)))))) + + (pass-if "string->utf32 [little]" + (let* ((str "hello, world") + (utf32 (string->utf32 str (endianness little)))) + (and (bytevector? utf32) + (= (bytevector-length utf32) + (* 4 (string-length str))) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 + (endianness little) 4)))))) + + (pass-if "utf8->string" + (let* ((utf8 (u8-list->bytevector (map char->integer + (string->list "hello, world")))) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (bytevector-length utf8)) + (equal? (string->list str) + (map integer->char (bytevector->u8-list utf8)))))) + + (pass-if "utf8->string [latin-1]" + (with-latin1-locale + (lambda () + (let* ((utf8 (string->utf8 "hé, ça va bien ?")) + (str (utf8->string utf8))) + (and (string? str) + (= (string-length str) + (- (bytevector-length utf8) 2))))))) + + (pass-if "utf16->string" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 2)) + (str (utf16->string utf16))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness big) + 2)))))) + + (pass-if "utf16->string [little]" + (let* ((utf16 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 2)) + (str (utf16->string utf16 (endianness little)))) + (and (string? str) + (= (* 2 (string-length str)) + (bytevector-length utf16)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf16 (endianness little) + 2)))))) + (pass-if "utf32->string" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness big) 4)) + (str (utf32->string utf32))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness big) + 4)))))) + + (pass-if "utf32->string [little]" + (let* ((utf32 (uint-list->bytevector (map char->integer + (string->list "hello, world")) + (endianness little) 4)) + (str (utf32->string utf32 (endianness little)))) + (and (string? str) + (= (* 4 (string-length str)) + (bytevector-length utf32)) + (equal? (string->list str) + (map integer->char + (bytevector->uint-list utf32 (endianness little) + 4))))))) + + + +(with-test-prefix "Datum Syntax" + + (pass-if "empty" + (equal? (with-input-from-string "#vu8()" read) + (make-bytevector 0))) + + (pass-if "simple" + (equal? (with-input-from-string "#vu8(1 2 3 4 5)" read) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if ">127" + (equal? (with-input-from-string "#vu8(0 255 127 128)" read) + (u8-list->bytevector '(0 255 127 128)))) + + (pass-if "self-evaluating?" + (self-evaluating? (make-bytevector 1))) + + (pass-if "self-evaluating" + (equal? (eval (with-input-from-string "#vu8(1 2 3 4 5)" read) + (current-module)) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if "quoted" + (equal? (eval (with-input-from-string "'#vu8(1 2 3 4 5)" read) + (current-module)) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if "literal simple" + (equal? #vu8(1 2 3 4 5) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if "literal >127" + (equal? #vu8(0 255 127 128) + (u8-list->bytevector '(0 255 127 128)))) + + (pass-if "literal quoted" + (equal? '#vu8(1 2 3 4 5) + (u8-list->bytevector '(1 2 3 4 5)))) + + (pass-if-exception "incorrect prefix" + exception:read-error + (with-input-from-string "#vi8(1 2 3)" read)) + + (pass-if-exception "extraneous space" + exception:read-error + (with-input-from-string "#vu8 (1 2 3)" read)) + + (pass-if-exception "negative integers" + exception:wrong-type-arg + (with-input-from-string "#vu8(-1 -2 -3)" read)) + + (pass-if-exception "out-of-range integers" + exception:wrong-type-arg + (with-input-from-string "#vu8(0 256)" read))) + + +(with-test-prefix "Generalized Vectors" + + (pass-if "generalized-vector?" + (generalized-vector? #vu8(1 2 3))) + + (pass-if "generalized-vector-length" + (equal? (iota 16) + (map generalized-vector-length + (map make-bytevector (iota 16))))) + + (pass-if "generalized-vector-ref" + (let ((bv #vu8(255 127))) + (and (= 255 (generalized-vector-ref bv 0)) + (= 127 (generalized-vector-ref bv 1))))) + + (pass-if-exception "generalized-vector-ref [index out-of-range]" + exception:out-of-range + (let ((bv #vu8(1 2))) + (generalized-vector-ref bv 2))) + + (pass-if "generalized-vector-set!" + (let ((bv (make-bytevector 2))) + (generalized-vector-set! bv 0 255) + (generalized-vector-set! bv 1 77) + (equal? '(255 77) + (bytevector->u8-list bv)))) + + (pass-if-exception "generalized-vector-set! [index out-of-range]" + exception:out-of-range + (let ((bv (make-bytevector 2))) + (generalized-vector-set! bv 2 0))) + + (pass-if-exception "generalized-vector-set! [value out-of-range]" + exception:out-of-range + (let ((bv (make-bytevector 2))) + (generalized-vector-set! bv 0 256))) + + (pass-if "array-type" + (eq? 'vu8 (array-type #vu8()))) + + (pass-if "array-contents" + (let ((bv (u8-list->bytevector (iota 10)))) + (eq? bv (array-contents bv)))) + + (pass-if "array-ref" + (let ((bv (u8-list->bytevector (iota 10)))) + (equal? (iota 10) + (map (lambda (i) (array-ref bv i)) + (iota 10))))) + + (pass-if "array-set!" + (let ((bv (make-bytevector 10))) + (for-each (lambda (i) + (array-set! bv i i)) + (iota 10)) + (equal? (iota 10) + (bytevector->u8-list bv)))) + + (pass-if "make-typed-array" + (let ((bv (make-typed-array 'vu8 77 33))) + (equal? bv (u8-list->bytevector (make-list 33 77))))) + + (pass-if-exception "make-typed-array [out-of-range]" + exception:out-of-range + (make-typed-array 'vu8 256 77)) + + (pass-if "uniform-array->bytevector" + (let ((bv #vu8(0 1 128 255))) + (equal? bv (uniform-array->bytevector bv))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/c-api.test b/test-suite/tests/c-api.test index 4a165d4cb..7c1b3bbd1 100644 --- a/test-suite/tests/c-api.test +++ b/test-suite/tests/c-api.test @@ -3,20 +3,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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 srcdir (cdr (assq 'srcdir %guile-build-info))) diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index f14c832dd..b52b384c5 100644 --- a/test-suite/tests/chars.test +++ b/test-suite/tests/chars.test @@ -3,21 +3,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 - +;;;; 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)) diff --git a/test-suite/tests/common-list.test b/test-suite/tests/common-list.test index c6f659b1e..dae806844 100644 --- a/test-suite/tests/common-list.test +++ b/test-suite/tests/common-list.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test new file mode 100644 index 000000000..f9fabd7bc --- /dev/null +++ b/test-suite/tests/compiler.test @@ -0,0 +1,55 @@ +;;;; compiler.test --- tests for the compiler -*- scheme -*- +;;;; Copyright (C) 2008, 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 tests compiler) + :use-module (test-suite lib) + :use-module (test-suite guile-test) + :use-module (system base compile)) + + + +(with-test-prefix "basic" + + (pass-if "compile to value" + (equal? (compile 1) 1))) + + +(with-test-prefix "psyntax" + + (pass-if "redefinition" + ;; In this case the locally-bound `round' must have the same value as the + ;; imported `round'. See the same test in `syntax.test' for details. + (begin + (compile '(define round round)) + (compile '(eq? round (@@ (guile) round))))) + + (pass-if "compile in current module" + (let ((o (begin + (compile '(define-macro (foo) 'bar)) + (compile '(let ((bar 'ok)) (foo)))))) + (and (module-ref (current-module) 'foo) + (eq? o 'ok)))) + + (pass-if "compile in fresh module" + (let* ((m (let ((m (make-module))) + (beautify-user-module! m) + m)) + (o (begin + (compile '(define-macro (foo) 'bar) #:env m) + (compile '(let ((bar 'ok)) (foo)) #:env m)))) + (and (module-ref m 'foo) + (eq? o 'ok))))) diff --git a/test-suite/tests/continuations.test b/test-suite/tests/continuations.test index 7d76b762b..20a7a5ac1 100644 --- a/test-suite/tests/continuations.test +++ b/test-suite/tests/continuations.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-continuations) :use-module (test-suite lib)) diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test index d7a06a411..08cf1c4e1 100644 --- a/test-suite/tests/dynamic-scope.test +++ b/test-suite/tests/dynamic-scope.test @@ -1,33 +1,30 @@ ;;;; -*- scheme -*- ;;;; dynamic-scop.test --- test suite for dynamic scoping constructs ;;;; -;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-dynamic-scope) :use-module (test-suite lib)) -(define exception:missing-expr - (cons 'syntax-error "Missing expression")) -(define exception:bad-binding - (cons 'syntax-error "Bad binding")) +(define exception:syntax-error + (cons 'syntax-error "failed to match")) (define exception:duplicate-binding - (cons 'syntax-error "Duplicate binding")) + (cons 'syntax-error "duplicate")) (define global-a 0) (define (fetch-global-a) global-a) @@ -49,17 +46,17 @@ (interaction-environment))) (pass-if-exception "@bind missing expression" - exception:missing-expr + exception:syntax-error (eval '(@bind ((global-a 1))) (interaction-environment))) (pass-if-exception "@bind bad bindings" - exception:bad-binding + exception:syntax-error (eval '(@bind (a) #f) (interaction-environment))) (pass-if-exception "@bind bad bindings" - exception:bad-binding + exception:syntax-error (eval '(@bind ((a)) #f) (interaction-environment))) diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 067f7b16f..fd028dac6 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 @@ -19,6 +19,13 @@ :use-module (test-suite lib) :use-module (ice-9 weak-vector)) +(define *old-stack-level* (and=> (memq 'stack (debug-options)) cadr)) +(if *old-stack-level* + (debug-set! stack (* 2 *old-stack-level*))) + +(define *old-%load-should-autocompile* %load-should-autocompile) +(set! %load-should-autocompile #f) + ;;; ;;; elisp ;;; @@ -274,6 +281,19 @@ (write (eval-elisp expr)))))) (string=? calc expected)))) + (define (elisp-pass-if/maybe-error key expr expected) + (pass-if (with-output-to-string (lambda () (write expr))) + (string=? + (catch key + (lambda () + (with-output-to-string + (lambda () (write (eval-elisp expr))))) + (lambda (k . args) + (format (current-error-port) + "warning: caught ~a: ~a\n" k args) + (throw 'unresolved))) + expected))) + (elisp-pass-if '(and #f) "#f") (elisp-pass-if '(and #t) "#t") (elisp-pass-if '(and nil) "#nil") @@ -323,12 +343,17 @@ ;; loading the macro definition of lambda in subr.el. (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))") (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))") - (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) "(1 2 3 #nil)") + (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) + "(1 2 3 #nil)") + (elisp-pass-if '(setq x 3) "3") (elisp-pass-if '(defvar x 4) "x") (elisp-pass-if 'x "3") )) +(set! %load-should-autocompile *old-%load-should-autocompile*) +(debug-set! stack *old-stack-level*) + ;;; elisp.test ends here diff --git a/test-suite/tests/encoding-escapes.test b/test-suite/tests/encoding-escapes.test new file mode 100644 index 000000000..ea7a821e7 --- /dev/null +++ b/test-suite/tests/encoding-escapes.test @@ -0,0 +1,140 @@ +;;;; encoding-escapes.test --- test suite for Guile's string encodings -*- mode: scheme; coding: utf-8 -*- +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA + +(define-module (test-strings) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + +(define exception:conversion + (cons 'misc-error "^cannot convert to output locale")) + +;; Create a string from integer char values, eg. (string-ints 65) => "A" +(define (string-ints . args) + (apply string (map integer->char args))) + +(define s1 "última") +(define s2 "cédula") +(define s3 "años") +(define s4 "羅生門") + +(with-test-prefix "internal encoding" + + (pass-if "ultima" + (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61))) + + (pass-if "cedula" + (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61))) + + (pass-if "anos" + (string=? s3 (string-ints #x61 #xf1 #x6f #x73))) + + (pass-if "Rashomon" + (string=? s4 (string-ints #x7f85 #x751f #x9580)))) + +(with-test-prefix "chars" + + (pass-if "ultima" + (list= eqv? (string->list s1) + (list #\372 #\l #\t #\i #\m #\a))) + + (pass-if "cedula" + (list= eqv? (string->list s2) + (list #\c #\351 #\d #\u #\l #\a))) + + (pass-if "anos" + (list= eqv? (string->list s3) + (list #\a #\361 #\o #\s))) + + (pass-if "Rashomon" + (list= eqv? (string->list s4) + (list #\77605 #\72437 #\112600)))) + + +;; Check that an error is flagged on display output when the output +;; error strategy is 'error + +(with-test-prefix "display output errors" + + (pass-if-exception "ultima" + exception:conversion + (let ((pt (open-output-string))) + (set-port-encoding! pt "ASCII") + (set-port-conversion-strategy! pt 'error) + (display s1 pt))) + + (pass-if-exception "Rashomon" + exception:conversion + (let ((pt (open-output-string))) + (set-port-encoding! pt "ASCII") + (set-port-conversion-strategy! pt 'error) + (display s4 pt)))) + +;; Check that questions marks or substitutions appear when the conversion +;; mode is substitute +(with-test-prefix "display output substitutions" + + (pass-if "ultima" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ASCII") + (set-port-conversion-strategy! pt 'substitute) + (display s1 pt) + (string=? "?ltima" + (get-output-string pt)))) + + (pass-if "Rashomon" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ASCII") + (set-port-conversion-strategy! pt 'substitute) + (display s4 pt) + (string=? "???" + (get-output-string pt))))) + + +;; Check that hex escapes appear in the write output and that no error +;; is thrown. The output error strategy should be irrelevant here. +(with-test-prefix "display output escapes" + + (pass-if "ultima" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ASCII") + (set-port-conversion-strategy! pt 'escape) + (display s1 pt) + (string=? "\\xfaltima" + (get-output-string pt)))) + (pass-if "Rashomon" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ASCII") + (set-port-conversion-strategy! pt 'escape) + (display s4 pt) + (string=? "\\u7F85\\u751F\\u9580" + (get-output-string pt))))) + +(with-test-prefix "input escapes" + + (pass-if "última" + (with-locale "en_US.utf8" + (string=? "última" + (with-input-from-string "\"\\xfaltima\"" read)))) + + (pass-if "羅生門" + (with-locale "en_US.utf8" + (string=? "羅生門" + (with-input-from-string + "\"\\u7F85\\u751F\\u9580\"" read))))) + diff --git a/test-suite/tests/encoding-iso88591.test b/test-suite/tests/encoding-iso88591.test new file mode 100644 index 000000000..d4de5e534 --- /dev/null +++ b/test-suite/tests/encoding-iso88591.test @@ -0,0 +1,139 @@ +;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: iso-8859-1 -*- +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA + +(define-module (test-strings) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + +(define exception:conversion + (cons 'misc-error "^cannot convert to output locale")) + +;; Create a string from integer char values, eg. (string-ints 65) => "A" +(define (string-ints . args) + (apply string (map integer->char args))) + +;; Set locale to the environment's locale, so that the prints look OK. +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) + +(define s1 "última") +(define s2 "cédula") +(define s3 "años") +(define s4 "¿Cómo?") + +(with-test-prefix "string length" + + (pass-if "última" + (eq? (string-length s1) 6)) + + (pass-if "cédula" + (eq? (string-length s2) 6)) + + (pass-if "años" + (eq? (string-length s3) 4)) + + (pass-if "¿Cómo?" + (eq? (string-length s4) 6))) + +(with-test-prefix "internal encoding" + + (pass-if "última" + (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61))) + + (pass-if "cédula" + (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61))) + + (pass-if "años" + (string=? s3 (string-ints #x61 #xf1 #x6f #x73))) + + (pass-if "¿Cómo?" + (string=? s4 (string-ints #xbf #x43 #xf3 #x6d #x6f #x3f)))) + +(with-test-prefix "chars" + + (pass-if "última" + (list= eqv? (string->list s1) + (list #\ú #\l #\t #\i #\m #\a))) + + (pass-if "cédula" + (list= eqv? (string->list s2) + (list #\c #\é #\d #\u #\l #\a))) + + (pass-if "años" + (list= eqv? (string->list s3) + (list #\a #\ñ #\o #\s))) + + (pass-if "¿Cómo?" + (list= eqv? (string->list s4) + (list #\¿ #\C #\ó #\m #\o #\?)))) + +;; Check that the output is in ISO-8859-1 encoding +(with-test-prefix "display" + + (pass-if "s1" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ISO-8859-1") + (display s1 pt) + (list= eqv? + (list #xfa #x6c #x74 #x69 #x6d #x61) + (u8vector->list + (get-output-locale-u8vector pt))))) + + (pass-if "s2" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ISO-8859-1") + (display s2 pt) + (list= eqv? + (list #x63 #xe9 #x64 #x75 #x6c #x61) + (u8vector->list + (get-output-locale-u8vector pt)))))) + +(with-test-prefix "symbols == strings" + + (pass-if "última" + (eq? (string->symbol s1) 'última)) + + (pass-if "cédula" + (eq? (string->symbol s2) 'cédula)) + + (pass-if "años" + (eq? (string->symbol s3) 'años)) + + (pass-if "¿Cómo?" + (eq? (string->symbol s4) '¿Cómo?))) + +(with-test-prefix "non-ascii variable names" + + (pass-if "1" + (let ((á 1) + (ñ 2)) + (eq? (+ á ñ) 3)))) + +(with-test-prefix "output errors" + + (pass-if-exception "char 256" exception:conversion + (let ((pt (open-output-string))) + (set-port-encoding! pt "ISO-8859-1") + (set-port-conversion-strategy! pt 'error) + (display (string-ints 256) pt)))) + +;; Reset locales +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/encoding-iso88597.test b/test-suite/tests/encoding-iso88597.test new file mode 100644 index 000000000..22212690c --- /dev/null +++ b/test-suite/tests/encoding-iso88597.test @@ -0,0 +1,139 @@ +;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: iso-8859-7 -*- +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA + +(define-module (test-strings) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + +(define exception:conversion + (cons 'misc-error "^cannot convert to output locale")) + +;; Create a string from integer char values, eg. (string-ints 65) => "A" +(define (string-ints . args) + (apply string (map integer->char args))) + +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) + +(define s1 "Ðåñß") +(define s2 "ôçò") +(define s3 "êñéôéêÞò") +(define s4 "êáé") + +(with-test-prefix "string length" + + (pass-if "s1" + (eq? (string-length s1) 4)) + + (pass-if "s2" + (eq? (string-length s2) 3)) + + (pass-if "s3" + (eq? (string-length s3) 8)) + + (pass-if "s4" + (eq? (string-length s4) 3))) + +(with-test-prefix "internal encoding" + + (pass-if "s1" + (string=? s1 (string-ints #x03a0 #x03b5 #x03c1 #x03af))) + + (pass-if "s2" + (string=? s2 (string-ints #x03c4 #x03b7 #x03c2))) + + (pass-if "s3" + (string=? s3 (string-ints #x03ba #x03c1 #x03b9 #x03c4 #x03b9 #x03ba #x03ae #x03c2))) + + (pass-if "s4" + (string=? s4 (string-ints #x03ba #x03b1 #x03b9)))) + +(with-test-prefix "chars" + + (pass-if "s1" + (list= eqv? (string->list s1) + (list #\Ð #\å #\ñ #\ß))) + + (pass-if "s2" + (list= eqv? (string->list s2) + (list #\ô #\ç #\ò))) + + (pass-if "s3" + (list= eqv? (string->list s3) + (list #\ê #\ñ #\é #\ô #\é #\ê #\Þ #\ò))) + + (pass-if "s4" + (list= eqv? (string->list s4) + (list #\ê #\á #\é)))) + +;; Testing that the display of the string is output in the ISO-8859-7 +;; encoding +(with-test-prefix "display" + + (pass-if "s1" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ISO-8859-7") + (display s1 pt) + (list= eqv? + (list #xd0 #xe5 #xf1 #xdf) + (u8vector->list + (get-output-locale-u8vector pt))))) + (pass-if "s2" + (let ((pt (open-output-string))) + (set-port-encoding! pt "ISO-8859-7") + (display s2 pt) + (list= eqv? + (list #xf4 #xe7 #xf2) + (u8vector->list + (get-output-locale-u8vector pt)))))) + +(with-test-prefix "symbols == strings" + + (pass-if "Ðåñß" + (eq? (string->symbol s1) 'Ðåñß)) + + (pass-if "ôçò" + (eq? (string->symbol s2) 'ôçò)) + + (pass-if "êñéôéêÞò" + (eq? (string->symbol s3) 'êñéôéêÞò)) + + (pass-if "êáé" + (eq? (string->symbol s4) 'êáé))) + +(with-test-prefix "non-ascii variable names" + + (pass-if "1" + (let ((á 1) + (ñ 2)) + (eq? (+ á ñ) 3)))) + +(with-test-prefix "output errors" + + (pass-if-exception "char #x0400" + exception:conversion + (let ((pt (open-output-string))) + (set-port-encoding! pt "ISO-8859-7") + (set-port-conversion-strategy! pt 'error) + (display (string-ints #x0400) pt)))) + +;; Reset locale +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/encoding-utf8.test b/test-suite/tests/encoding-utf8.test new file mode 100644 index 000000000..a2613f1d7 --- /dev/null +++ b/test-suite/tests/encoding-utf8.test @@ -0,0 +1,108 @@ +;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: utf-8 -*- +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA + +(define-module (test-strings) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + +(define exception:conversion + (cons 'misc-error "^cannot convert to output locale")) + +;; Create a string from integer char values, eg. (string-ints 65) => "A" +(define (string-ints . args) + (apply string (map integer->char args))) + +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) + +(define s1 "última") +(define s2 "cédula") +(define s3 "años") +(define s4 "羅生門") + +(with-test-prefix "string length" + + (pass-if "última" + (eq? (string-length s1) 6)) + + (pass-if "cédula" + (eq? (string-length s2) 6)) + + (pass-if "años" + (eq? (string-length s3) 4)) + + (pass-if "羅生門" + (eq? (string-length s4) 3))) + +(with-test-prefix "internal encoding" + + (pass-if "última" + (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61))) + + (pass-if "cédula" + (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61))) + + (pass-if "años" + (string=? s3 (string-ints #x61 #xf1 #x6f #x73))) + + (pass-if "羅生門" + (string=? s4 (string-ints #x7f85 #x751f #x9580)))) + +(with-test-prefix "chars" + + (pass-if "última" + (list= eqv? (string->list s1) + (list #\ú #\l #\t #\i #\m #\a))) + + (pass-if "cédula" + (list= eqv? (string->list s2) + (list #\c #\é #\d #\u #\l #\a))) + + (pass-if "años" + (list= eqv? (string->list s3) + (list #\a #\ñ #\o #\s))) + + (pass-if "羅生門" + (list= eqv? (string->list s4) + (list #\ç¾… #\生 #\é–€)))) + +(with-test-prefix "symbols == strings" + + (pass-if "última" + (eq? (string->symbol s1) 'última)) + + (pass-if "cédula" + (eq? (string->symbol s2) 'cédula)) + + (pass-if "años" + (eq? (string->symbol s3) 'años)) + + (pass-if "羅生門" + (eq? (string->symbol s4) '羅生門))) + +(with-test-prefix "non-ascii variable names" + + (pass-if "1" + (let ((芥å·é¾ä¹‹ä»‹ 1) + (ñ 2)) + (eq? (+ 芥å·é¾ä¹‹ä»‹ ñ) 3)))) + +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/environments.nottest b/test-suite/tests/environments.nottest index 46883849a..90ef80f63 100644 --- a/test-suite/tests/environments.nottest +++ b/test-suite/tests/environments.nottest @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 5299b0406..47d7ca99f 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 @@ -24,6 +24,9 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) +(define exception:failed-match + (cons 'syntax-error "failed to match any pattern")) + ;;; ;;; miscellaneous @@ -85,17 +88,19 @@ ;; Macros are accepted as function parameters. ;; Functions that 'apply' macros are rewritten!!! - (expect-fail-exception "macro as argument" - exception:wrong-type-arg - (let ((f (lambda (p a b) (p a b)))) - (f and #t #t))) + (pass-if-exception "macro as argument" + exception:failed-match + (primitive-eval + '(let ((f (lambda (p a b) (p a b)))) + (f and #t #t)))) - (expect-fail-exception "passing macro as parameter" - exception:wrong-type-arg - (let* ((f (lambda (p a b) (p a b))) - (foo (procedure-source f))) - (f and #t #t) - (equal? (procedure-source f) foo))) + (pass-if-exception "passing macro as parameter" + exception:failed-match + (primitive-eval + '(let* ((f (lambda (p a b) (p a b))) + (foo (procedure-source f))) + (f and #t #t) + (equal? (procedure-source f) foo)))) )) @@ -214,7 +219,11 @@ ;; (define foo-closure (lambda () "hello")) (define bar-closure foo-closure) -(define foo-pws (make-procedure-with-setter car set-car!)) +;; make sure that make-procedure-with-setter returns an anonymous +;; procedure-with-setter by passing it an anonymous getter. +(define foo-pws (make-procedure-with-setter + (lambda (x) (car x)) + (lambda (x y) (set-car! x y)))) (define bar-pws foo-pws) (with-test-prefix "define set procedure-name" @@ -223,7 +232,7 @@ (eq? 'foo-closure (procedure-name bar-closure))) (pass-if "procedure-with-setter" - (eq? 'foo-pws (pk (procedure-name bar-pws))))) + (eq? 'foo-pws (procedure-name bar-pws)))) (if old-procnames-flag (debug-enable 'procnames) diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 4a9c1cb55..c2ec5f48d 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index b9913c2f2..a6bfb6eb5 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index cc3b6684b..04b31f138 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -3,20 +3,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-format) #:use-module (test-suite lib) diff --git a/test-suite/tests/fractions.test b/test-suite/tests/fractions.test index 0e1a4d6c1..3ee1347d8 100644 --- a/test-suite/tests/fractions.test +++ b/test-suite/tests/fractions.test @@ -1,17 +1,18 @@ ;;;; 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 -;;;; published by the Free Software Foundation; see file GNU-GPL. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software Foundation, -;;;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;;; 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 ;;;; Based in part on code from GNU CLISP, Copyright (C) 1993 Michael Stoll diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index a61850af2..847fb9ff4 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 @@ -25,18 +25,19 @@ ;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match ;; libguile/filesys.c of course) -(or (equal? (procedure-source stat:dev) - '(lambda (f) (vector-ref f 0))) - (error "oops, unexpected stat:dev definition")) (define (stat:dev! st dev) (vector-set! st 0 dev)) - -(or (equal? (procedure-source stat:ino) - '(lambda (f) (vector-ref f 1))) - (error "oops, unexpected stat:ino definition")) (define (stat:ino! st ino) (vector-set! st 1 ino)) +(let* ((s (stat "/")) + (i (stat:ino s)) + (d (stat:dev s))) + (stat:ino! s (1+ i)) + (stat:dev! s (1+ d)) + (if (not (and (= (stat:ino s) (1+ i)) + (= (stat:dev s) (1+ d)))) + (error "unexpected definitions of stat:dev and stat:ino"))) ;; ;; visited?-proc diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index 407c4a286..063dad6d1 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index fe4a8872b..2c6f41515 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; 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) (ice-9 getopt-long) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index fa53fd216..c060d12a6 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-goops) #:use-module (test-suite lib) @@ -191,7 +190,15 @@ (and (struct? x) (eq? (struct-ref x 0) 'hello) (eq? (struct-ref x 1) 'world))) - (current-module))))) + (current-module))) + + (pass-if "with accessors" + (eval '(define-class <qux> () + (x #:accessor x #:init-value 123) + (z #:accessor z #:init-value 789)) + (current-module)) + (eval '(equal? (x (make <qux>)) 123) (current-module))))) + (with-test-prefix "defining generics" @@ -253,6 +260,19 @@ (method-more-specific? m1 m2 '())) (current-module)))) +(with-test-prefix "the method cache" + (pass-if "defining a method with a rest arg" + (let ((m (current-module))) + (eval '(define-method (foo bar . baz) + (cons bar baz)) + m) + (eval '(foo 1) + m) + (eval '(foo 1 2) + m) + (eval '(equal? (foo 1 2) '(1 2)) + m)))) + (with-test-prefix "defining accessors" (with-test-prefix "define-accessor" diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test index 8e72d4106..470de4569 100644 --- a/test-suite/tests/guardians.test +++ b/test-suite/tests/guardians.test @@ -3,20 +3,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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 ;;; These tests make some questionable assumptions. ;;; diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index ccfd24ece..d2bde481c 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test index f8ed39919..68c724704 100644 --- a/test-suite/tests/hooks.test +++ b/test-suite/tests/hooks.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 78d7e54fb..c4777c21c 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -6,13 +6,13 @@ ;;;; 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. -;;;; +;;;; 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 diff --git a/test-suite/tests/import.test b/test-suite/tests/import.test index 4c4be02b2..1f2d26445 100644 --- a/test-suite/tests/import.test +++ b/test-suite/tests/import.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test index a091515b9..5f3e2aaf7 100644 --- a/test-suite/tests/interp.test +++ b/test-suite/tests/interp.test @@ -2,20 +2,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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 (pass-if "Internal defines 1" (letrec ((foo (lambda (arg) diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index 7dc0ef0f8..d7b7801c9 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index a71a34716..59f9dbb61 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -3,20 +3,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-load) :use-module (test-suite lib) diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index 43e35d8b7..f22cfe9c1 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -1,17 +1,17 @@ ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- -;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. +;;;; Copyright (C) 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 2.1 of the License, or (at your option) any later version. -;;;; +;;;; 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 @@ -34,6 +34,13 @@ (with-test-prefix "foundations" + (pass-if "modules don't remain anonymous" + ;; This is a requirement for `psyntax': it stores module names and relies + ;; on being able to `resolve-module' them. + (let ((m (make-module))) + (and (module-name m) + (eq? m (resolve-module (module-name m)))))) + (pass-if "module-add!" (let ((m (make-module)) (value (cons 'x 'y))) diff --git a/test-suite/tests/multilingual.nottest b/test-suite/tests/multilingual.nottest index 46a3ee2d3..cc911a108 100644 --- a/test-suite/tests/multilingual.nottest +++ b/test-suite/tests/multilingual.nottest @@ -4,20 +4,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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)) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 32627ed8c..774e228a7 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 @@ -22,6 +22,7 @@ ;;; ;;; miscellaneous ;;; +(setbinary) (define exception:numerical-overflow (cons 'numerical-overflow "^Numerical overflow")) @@ -1365,7 +1366,14 @@ ("1@0" 1.0) ("1@+0" 1.0) ("1@-0" 1.0) ("2+3i" ,(+ 2 (* 3 +i))) ("4-5i" ,(- 4 (* 5 +i))) ("1+i" 1+1i) ("1-i" 1-1i) ("+1i" 0+1i) ("-1i" 0-1i) - ("+i" +1i) ("-i" -1i))) + ("+i" +1i) ("-i" -1i) + ("1.0+.1i" 1.0+0.1i) + ("1.0-.1i" 1.0-0.1i) + (".1+.0i" 0.1) + ("1.+.0i" 1.0) + (".1+.1i" 0.1+0.1i) + ("1e1+.1i" 10+0.1i) + )) #t) (pass-if-exception "exponent too big" diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 040b68ba4..5929ce909 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-optargs) :use-module (test-suite lib) diff --git a/test-suite/tests/options.test b/test-suite/tests/options.test index f2f87143b..a795109ce 100644 --- a/test-suite/tests/options.test +++ b/test-suite/tests/options.test @@ -2,20 +2,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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)) diff --git a/test-suite/tests/pairs.test b/test-suite/tests/pairs.test index af2f3e275..a317307b2 100644 --- a/test-suite/tests/pairs.test +++ b/test-suite/tests/pairs.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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)) diff --git a/test-suite/tests/poe.test b/test-suite/tests/poe.test index 6c7625602..707dc0272 100644 --- a/test-suite/tests/poe.test +++ b/test-suite/tests/poe.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 1dd2bc78e..0a20cff7a 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 @@ -73,20 +73,46 @@ (open-input-pipe "echo hello")))))) #t) + (pass-if "open-input-pipe process gets (current-input-port) as stdin" + (let* ((p2c (pipe)) + (port (with-input-from-port (car p2c) + (lambda () + (open-input-pipe "read line && echo $line"))))) + (display "hello\n" (cdr p2c)) + (force-output (cdr p2c)) + (let ((result (eq? (read port) 'hello))) + (close-port (cdr p2c)) + (close-pipe port) + result))) + ;; After the child closes stdout (which it indicates here by writing - ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 and - ;; earlier a duplicate of stdout existed in the child, meaning eof was not - ;; seen. + ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 + ;; and earlier a duplicate of stdout existed in the child, meaning + ;; eof was not seen. + ;; + ;; Note that the objective here is to test that the parent sees EOF + ;; while the child is still alive. (It is obvious that the parent + ;; must see EOF once the child has died.) The use of the `p2c' + ;; pipe, and `echo closed' and `read' in the child, allows us to be + ;; sure that we are testing what the parent sees at a point where + ;; the child has closed stdout but is still alive. (pass-if "no duplicate" - (let* ((pair (pipe)) - (port (with-error-to-port (cdr pair) + (let* ((c2p (pipe)) + (p2c (pipe)) + (port (with-error-to-port (cdr c2p) (lambda () - (open-input-pipe - "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999"))))) - (close-port (cdr pair)) ;; write side - (and (char? (read-char (car pair))) ;; wait for child to do its thing - (char-ready? port) - (eof-object? (read-char port)))))) + (with-input-from-port (car p2c) + (lambda () + (open-input-pipe + "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read"))))))) + (close-port (cdr c2p)) ;; write side + (let ((result (eof-object? (read-char port)))) + (display "hello!\n" (cdr p2c)) + (force-output (cdr p2c)) + (close-pipe port) + result))) + + ) ;; ;; open-output-pipe @@ -121,27 +147,47 @@ #t) ;; After the child closes stdin (which it indicates here by writing - ;; "closed" to stderr), the parent should see a broken pipe. We setup to - ;; see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 and earlier a - ;; duplicate of stdin existed in the child, preventing the broken pipe - ;; occurring. + ;; "closed" to stderr), the parent should see a broken pipe. We + ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 + ;; and earlier a duplicate of stdin existed in the child, preventing + ;; the broken pipe occurring. + ;; + ;; Note that the objective here is to test that the parent sees a + ;; broken pipe while the child is still alive. (It is obvious that + ;; the parent will see a broken pipe once the child has died.) The + ;; use of the `c2p' pipe, and the repeated `echo closed' in the + ;; child, allows us to be sure that we are testing what the parent + ;; sees at a point where the child has closed stdin but is still + ;; alive. + ;; + ;; Note that `with-epipe' must apply only to the parent and not to + ;; the child process; we rely on the child getting SIGPIPE, to + ;; terminate it (and avoid leaving a zombie). (pass-if "no duplicate" - (with-epipe - (lambda () - (let* ((pair (pipe)) - (port (with-error-to-port (cdr pair) - (lambda () - (open-output-pipe - "exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null; sleep 999"))))) - (close-port (cdr pair)) ;; write side - (and (char? (read-char (car pair))) ;; wait for child to do its thing - (catch 'system-error - (lambda () - (write-char #\x port) - (force-output port) - #f) - (lambda (key name fmt args errno-list) - (= (car errno-list) EPIPE))))))))) + (let* ((c2p (pipe)) + (port (with-error-to-port (cdr c2p) + (lambda () + (open-output-pipe + "exec 0</dev/null; while true; do echo closed 1>&2; done"))))) + (close-port (cdr c2p)) ;; write side + (with-epipe + (lambda () + (let ((result + (and (char? (read-char (car c2p))) ;; wait for child to do its thing + (catch 'system-error + (lambda () + (write-char #\x port) + (force-output port) + #f) + (lambda (key name fmt args errno-list) + (= (car errno-list) EPIPE)))))) + ;; Now close our reading end of the pipe. This should give + ;; the child a broken pipe and so allow it to exit. + (close-port (car c2p)) + (close-pipe port) + result))))) + + ) ;; ;; close-pipe diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index f1ba80be0..76b3e5656 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-ports) :use-module (test-suite lib) @@ -34,6 +33,9 @@ ;;;; Some general utilities for testing ports. +;;; Make sure we are set up for 8-bit data +(setbinary) + ;;; Read from PORT until EOF, and return the result as a string. (define (read-all port) (let loop ((chars '())) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index e93d1689f..06b70baa0 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2003, 2004, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; 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-posix) :use-module (test-suite lib)) diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test index 5ab585058..6af73f6bb 100644 --- a/test-suite/tests/procprop.test +++ b/test-suite/tests/procprop.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; 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-procpop) :use-module (test-suite lib)) diff --git a/test-suite/tests/q.test b/test-suite/tests/q.test index 5c24e5202..03f1bebe9 100644 --- a/test-suite/tests/q.test +++ b/test-suite/tests/q.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test index e47364c66..e26fdada3 100644 --- a/test-suite/tests/r4rs.test +++ b/test-suite/tests/r4rs.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test index 8fa78e9c1..0bae630b5 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/test-suite/tests/r5rs_pitfall.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 @@ -27,15 +27,15 @@ (syntax-rules () ((_ test-id value expression) (run-test test-id #t (lambda () - (false-if-exception - (equal? expression value))))))) + (false-if-exception + (equal? expression value))))))) (define-syntax should-be-but-isnt (syntax-rules () ((_ test-id value expression) (run-test test-id #f (lambda () - (false-if-exception - (equal? expression value))))))) + (false-if-exception + (equal? expression value))))))) (define call/cc call-with-current-continuation) @@ -65,7 +65,7 @@ (should-be 1.2 #t (letrec ((x (call/cc list)) (y (call/cc list))) (cond ((procedure? x) (x (pair? y))) - ((procedure? y) (y (pair? x)))) + ((procedure? y) (y (pair? x)))) (let ((x (car x)) (y (car y))) (and (call/cc x) (call/cc y) (call/cc x))))) @@ -75,11 +75,11 @@ ;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU (should-be 1.3 #t (letrec ((x (call-with-current-continuation - (lambda (c) - (list #T c))))) + (lambda (c) + (list #T c))))) (if (car x) - ((cadr x) (list #F (lambda () x))) - (eq? x ((cadr x)))))) + ((cadr x) (list #F (lambda () x))) + (eq? x ((cadr x)))))) ;; Section 2: Proper call/cc and procedure application @@ -300,12 +300,12 @@ (define res1 #f) (define res2 #f) (set! res1 (map (lambda (x) - (if (= x 0) - (call/cc (lambda (k) (set! cont k) 0)) - 0)) - '(1 0 2))) + (if (= x 0) + (call/cc (lambda (k) (set! cont k) 0)) + 0)) + '(1 0 2))) (if (not executed-k) - (begin (set! executed-k #t) - (set! res2 res1) - (cont 1))) + (begin (set! executed-k #t) + (set! res2 res1) + (cont 1))) res2)) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test new file mode 100644 index 000000000..c2b0755f8 --- /dev/null +++ b/test-suite/tests/r6rs-ports.test @@ -0,0 +1,459 @@ +;;;; r6rs-ports.test --- Exercise the R6RS I/O port API. +;;;; +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-io-ports) + :use-module (test-suite lib) + :use-module (srfi srfi-1) + :use-module (srfi srfi-11) + :use-module (rnrs io ports) + :use-module (rnrs bytevector)) + +;;; All these tests assume Guile 1.8's port system, where characters are +;;; treated as octets. + +;;; Set the default encoding of future ports to be binary +(setbinary) + + +(with-test-prefix "7.2.5 End-of-File Object" + + (pass-if "eof-object" + (and (eqv? (eof-object) (eof-object)) + (eq? (eof-object) (eof-object))))) + + +(with-test-prefix "7.2.8 Binary Input" + + (pass-if "get-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "lookahead-u8" + (let ((port (open-input-string "A"))) + (and (= (char->integer #\A) (lookahead-u8 port)) + (not (eof-object? port)) + (= (char->integer #\A) (get-u8 port)) + (eof-object? (get-u8 port))))) + + (pass-if "get-bytevector-n [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 4))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n [long]" + (let* ((port (open-input-string "GNU Guile")) + (bv (get-bytevector-n port 256))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU Guile")))))) + + (pass-if-exception "get-bytevector-n with closed port" + exception:wrong-type-arg + + (let ((port (%make-void-port "r"))) + + (close-port port) + (get-bytevector-n port 3))) + + (pass-if "get-bytevector-n! [short]" + (let* ((port (open-input-string "GNU Guile")) + (bv (make-bytevector 4)) + (read (get-bytevector-n! port bv 0 4))) + (and (equal? read 4) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-n! [long]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (make-bytevector 256)) + (read (get-bytevector-n! port bv 0 256))) + (and (equal? read (string-length str)) + (equal? (map (lambda (i) + (bytevector-u8-ref bv i)) + (iota read)) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [simple]" + (let* ((str "GNU Guile") + (port (open-input-string str)) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str)))))) + + (pass-if "get-bytevector-some [only-some]" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read. + (- 4 (modulo index 5)))) + "r")) + (bv (get-bytevector-some port))) + (and (bytevector? bv) + (= index 4) + (= (bytevector-length bv) index) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list "GNU ")))))) + + (pass-if "get-bytevector-all" + (let* ((str "GNU Guile") + (index 0) + (port (make-soft-port + (vector #f #f #f + (lambda () + (if (>= index (string-length str)) + (eof-object) + (let ((c (string-ref str index))) + (set! index (+ index 1)) + c))) + (lambda () #t) + (let ((cont? #f)) + (lambda () + ;; Number of readily available octets: falls to + ;; zero after 4 octets have been read and then + ;; starts again. + (let ((a (if cont? + (- (string-length str) index) + (- 4 (modulo index 5))))) + (if (= 0 a) (set! cont? #t)) + a)))) + "r")) + (bv (get-bytevector-all port))) + (and (bytevector? bv) + (= index (string-length str)) + (= (bytevector-length bv) (string-length str)) + (equal? (bytevector->u8-list bv) + (map char->integer (string->list str))))))) + + +(define (make-soft-output-port) + (let* ((bv (make-bytevector 1024)) + (read-index 0) + (write-index 0) + (write-char (lambda (chr) + (bytevector-u8-set! bv write-index + (char->integer chr)) + (set! write-index (+ 1 write-index))))) + (make-soft-port + (vector write-char + (lambda (str) ;; write-string + (for-each write-char (string->list str))) + (lambda () #t) ;; flush-output + (lambda () ;; read-char + (if (>= read-index (bytevector-length bv)) + (eof-object) + (let ((c (bytevector-u8-ref bv read-index))) + (set! read-index (+ read-index 1)) + (integer->char c)))) + (lambda () #t)) ;; close-port + "rw"))) + +(with-test-prefix "7.2.11 Binary Output" + + (pass-if "put-u8" + (let ((port (make-soft-output-port))) + (put-u8 port 77) + (equal? (get-u8 port) 77))) + + (pass-if "put-bytevector [2 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256))) + (put-bytevector port bv) + (equal? (bytevector->u8-list bv) + (bytevector->u8-list + (get-bytevector-n port (bytevector-length bv)))))) + + (pass-if "put-bytevector [3 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10)) + (put-bytevector port bv start) + (equal? (drop (bytevector->u8-list bv) start) + (bytevector->u8-list + (get-bytevector-n port (- (bytevector-length bv) start)))))) + + (pass-if "put-bytevector [4 args]" + (let ((port (make-soft-output-port)) + (bv (make-bytevector 256)) + (start 10) + (count 77)) + (put-bytevector port bv start count) + (equal? (take (drop (bytevector->u8-list bv) start) count) + (bytevector->u8-list + (get-bytevector-n port count))))) + + (pass-if-exception "put-bytevector with closed port" + exception:wrong-type-arg + + (let* ((bv (make-bytevector 4)) + (port (%make-void-port "w"))) + + (close-port port) + (put-bytevector port bv)))) + + +(with-test-prefix "7.2.7 Input Ports" + + ;; This section appears here so that it can use the binary input + ;; primitives. + + (pass-if "open-bytevector-input-port [1 arg]" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv)) + (read-to-string + (lambda (port) + (let loop ((chr (read-char port)) + (result '())) + (if (eof-object? chr) + (apply string (reverse! result)) + (loop (read-char port) + (cons chr result))))))) + + (equal? (read-to-string port) str))) + + (pass-if-exception "bytevector-input-port is read-only" + exception:wrong-type-arg + + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #f))) + + (write "hello" port))) + + (pass-if "bytevector input port supports seeking" + (let* ((str "Hello Port!") + (bv (u8-list->bytevector (map char->integer + (string->list str)))) + (port (open-bytevector-input-port bv #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if-exception "make-custom-binary-input-port [wrong-num-args]" + exception:wrong-num-args + + ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully + ;; optional. + (make-custom-binary-input-port "port" (lambda args #t))) + + (pass-if "make-custom-binary-input-port" + (let* ((source (make-bytevector 7777)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + + (bytevector=? (get-bytevector-all port) source))) + + (pass-if "custom binary input port does not support `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + (not (or (port-has-port-position? port) + (port-has-set-port-position!? port))))) + + (pass-if "custom binary input port supports `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (get-pos (lambda () + (port-position source))) + (set-pos! (lambda (pos) + (set-port-position! source pos))) + (port (make-custom-binary-input-port "the port" read! + get-pos set-pos! #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if "custom binary input port `close-proc' is called" + (let* ((closed? #f) + (read! (lambda (bv start count) 0)) + (get-pos (lambda () 0)) + (set-pos! (lambda (pos) #f)) + (close! (lambda () (set! closed? #t))) + (port (make-custom-binary-input-port "the port" read! + get-pos set-pos! + close!))) + + (close-port port) + (gc) ; Test for marking a closed port. + closed?))) + + +(with-test-prefix "8.2.10 Output ports" + + (pass-if "open-bytevector-output-port" + (let-values (((port get-content) + (open-bytevector-output-port #f))) + (let ((source (make-bytevector 7777))) + (put-bytevector port source) + (and (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "open-bytevector-output-port [put-u8]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (put-u8 port 77) + (and (bytevector=? (get-content) (make-bytevector 1 77)) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "open-bytevector-output-port [display]" + (let-values (((port get-content) + (open-bytevector-output-port))) + (display "hello" port) + (and (bytevector=? (get-content) (string->utf8 "hello")) + (bytevector=? (get-content) (make-bytevector 0))))) + + (pass-if "bytevector output port supports `port-position'" + (let-values (((port get-content) + (open-bytevector-output-port))) + (let ((source (make-bytevector 7777)) + (overwrite (make-bytevector 33))) + (and (port-has-port-position? port) + (port-has-set-port-position!? port) + (begin + (put-bytevector port source) + (= (bytevector-length source) + (port-position port))) + (begin + (set-port-position! port 10) + (= 10 (port-position port))) + (begin + (put-bytevector port overwrite) + (bytevector-copy! overwrite 0 source 10 + (bytevector-length overwrite)) + (= (port-position port) + (+ 10 (bytevector-length overwrite)))) + (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "make-custom-binary-output" + (let ((port (make-custom-binary-output-port "cbop" + (lambda (x y z) 0) + #f #f #f))) + (and (output-port? port) + (binary-port? port) + (not (port-has-port-position? port)) + (not (port-has-set-port-position!? port))))) + + (pass-if "make-custom-binary-output-port [partial writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (bytevector-u8-set! sink sink-pos u8) + (set! sink-pos (+ 1 sink-pos)) + 1)))) + (port (make-custom-binary-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if "make-custom-binary-output-port [full writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (begin + (bytevector-copy! bv start + sink sink-pos + count) + (set! sink-pos (+ sink-pos count)) + count)))) + (port (make-custom-binary-output-port "cbop" write! + #f #f #f))) + (put-bytevector port source) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test index d923bc1f2..948a77870 100644 --- a/test-suite/tests/ramap.test +++ b/test-suite/tests/ramap.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index b068c716d..0eb851508 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -6,13 +6,13 @@ ;;;; 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. -;;;; +;;;; 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 @@ -35,6 +35,8 @@ (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 (read-string s) @@ -165,6 +167,11 @@ (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) @@ -189,3 +196,36 @@ (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 0))))) +(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))))) + + diff --git a/test-suite/tests/receive.test b/test-suite/tests/receive.test index 4b55bdf9f..3fb4abe20 100644 --- a/test-suite/tests/receive.test +++ b/test-suite/tests/receive.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; 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) diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 15f77a34c..730839970 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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) diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test index 4bfc41557..7626ceebf 100644 --- a/test-suite/tests/socket.test +++ b/test-suite/tests/socket.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test index a49c04857..292836d88 100644 --- a/test-suite/tests/sort.test +++ b/test-suite/tests/sort.test @@ -1,20 +1,19 @@ ;;;; sort.test --- tests Guile's sort functions -*- scheme -*- ;;;; Copyright (C) 2003, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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)) diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test index 5bfe68080..17d8ae2d9 100644 --- a/test-suite/tests/srcprop.test +++ b/test-suite/tests/srcprop.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 @@ -36,11 +36,51 @@ (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)")))) + (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)")))) + (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" @@ -48,7 +88,7 @@ (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)) diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 4f2838744..c163e7b69 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2003, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-1) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-10.test b/test-suite/tests/srfi-10.test index 248c04ff7..ab3cb884e 100644 --- a/test-suite/tests/srfi-10.test +++ b/test-suite/tests/srfi-10.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (srfi srfi-10)) diff --git a/test-suite/tests/srfi-11.test b/test-suite/tests/srfi-11.test index ec2ed86c8..40563dc18 100644 --- a/test-suite/tests/srfi-11.test +++ b/test-suite/tests/srfi-11.test @@ -2,20 +2,19 @@ ;;;; ;;;; 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 -;;;; 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, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-11) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test index 89759d0d3..d8e379959 100644 --- a/test-suite/tests/srfi-13.test +++ b/test-suite/tests/srfi-13.test @@ -3,20 +3,19 @@ ;;;; ;;;; 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 -;;;; 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, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-strings) #:use-module (test-suite lib) @@ -31,6 +30,9 @@ (define (string-ints . args) (apply string (map integer->char args))) +;; Some abbreviations +;; BMP - Basic Multilingual Plane (codepoints below U+FFFF) +;; SMP - Suplementary Multilingual Plane (codebpoints from U+10000 to U+1FFFF) ;;; ;;; string-any @@ -54,6 +56,12 @@ (pass-if "one match" (string-any #\C "abCde")) + (pass-if "one match: BMP" + (string-any (integer->char #x0100) "ab\u0100de")) + + (pass-if "one match: SMP" + (string-any (integer->char #x010300) "ab\U010300de")) + (pass-if "more than one match" (string-any #\X "abXXX")) @@ -152,7 +160,9 @@ (pass-if (string=? "" (string-append/shared "" ""))) (pass-if (string=? "xyz" (string-append/shared "xyz" ""))) (pass-if (string=? "xyz" (string-append/shared "" "xyz"))) - (pass-if (string=? "abcxyz" (string-append/shared "abc" "xyz")))) + (pass-if (string=? "abcxyz" (string-append/shared "abc" "xyz"))) + (pass-if (string=? "abc\u0100\u0101" + (string-append/shared "abc" "\u0100\u0101")))) (with-test-prefix "three args" (pass-if (string=? "" (string-append/shared "" "" ""))) @@ -192,7 +202,10 @@ (pass-if-exception "improper 1" exception:wrong-type-arg (string-concatenate '("a" . "b"))) - (pass-if (equal? "abc" (string-concatenate '("a" "b" "c"))))) + (pass-if (equal? "abc" (string-concatenate '("a" "b" "c")))) + + (pass-if "concatenate BMP" + (equal? "a\u0100" (string-concatenate '("a" "\u0100"))))) ;; ;; string-compare @@ -235,7 +248,10 @@ (pass-if-exception "improper 1" exception:wrong-type-arg (string-concatenate/shared '("a" . "b"))) - (pass-if (equal? "abc" (string-concatenate/shared '("a" "b" "c"))))) + (pass-if (equal? "abc" (string-concatenate/shared '("a" "b" "c")))) + + (pass-if "BMP" + (equal? "a\u0100c" (string-concatenate/shared '("a" "\u0100" "c"))))) ;;; ;;; string-every @@ -268,6 +284,9 @@ (pass-if "all match" (string-every #\X "XXXXX")) + (pass-if "all match BMP" + (string-every #\200000 "\U010000\U010000")) + (pass-if "no match at all, start index" (not (string-every #\X "Xbcde" 1))) @@ -387,6 +406,9 @@ (pass-if "nonempty, start index" (= (length (string->list "foo" 1 3)) 2)) + + (pass-if "nonempty, start index, BMP" + (= (length (string->list "\xff\u0100\u0300" 1 3)) 2)) ) (with-test-prefix "reverse-list->string" @@ -395,8 +417,10 @@ (string-null? (reverse-list->string '()))) (pass-if "nonempty" - (string=? "foo" (reverse-list->string '(#\o #\o #\f))))) + (string=? "foo" (reverse-list->string '(#\o #\o #\f)))) + (pass-if "nonempty, BMP" + (string=? "\u0100\u0101\u0102" (reverse-list->string '(#\402 #\401 #\400))))) (with-test-prefix "string-join" @@ -437,6 +461,11 @@ (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|" 'infix))) + (pass-if "two strings, explicit infix, BMP" + (string=? "\u0100\u0101::\u0102\u0103" + (string-join '("\u0100\u0101" "\u0102\u0103") "::" + 'infix))) + (pass-if-exception "empty list, strict infix" exception:strict-infix-grammar (string-join '() "|delim|" 'strict-infix)) @@ -485,9 +514,15 @@ (pass-if "full string" (string=? "foo-bar" (string-copy "foo-bar"))) + (pass-if "full string, BMP" + (string=? "foo-\u0100\u0101" (string-copy "foo-\u0100\u0101"))) + (pass-if "start index" (string=? "o-bar" (string-copy "foo-bar" 2))) + (pass-if "start index" + (string=? "o-bar" (string-copy "\u0100\u0101o-bar" 2))) + (pass-if "start and end index" (string=? "o-ba" (string-copy "foo-bar" 2 6))) ) @@ -520,6 +555,9 @@ (pass-if "non-empty string" (string=? "foo " (string-take "foo bar braz" 4))) + (pass-if "non-empty string BMP" + (string=? "\u0100oo " (string-take "\u0100oo \u0101ar braz" 4))) + (pass-if "full string" (string=? "foo bar braz" (string-take "foo bar braz" 12)))) @@ -531,6 +569,9 @@ (pass-if "non-empty string" (string=? "braz" (string-take-right "foo bar braz" 4))) + (pass-if "non-empty string" + (string=? "braz" (string-take-right "foo ba\u0100 braz" 4))) + (pass-if "full string" (string=? "foo bar braz" (string-take-right "foo bar braz" 12)))) @@ -542,6 +583,9 @@ (pass-if "non-empty string" (string=? "braz" (string-drop "foo bar braz" 8))) + (pass-if "non-empty string BMP" + (string=? "braz" (string-drop "foo \u0100\u0101\u0102 braz" 8))) + (pass-if "full string" (string=? "foo bar braz" (string-drop "foo bar braz" 0)))) @@ -553,6 +597,9 @@ (pass-if "non-empty string" (string=? "foo " (string-drop-right "foo bar braz" 8))) + (pass-if "non-empty string BMP" + (string=? "foo " (string-drop-right "foo \u0100\u0101\u0102 braz" 8))) + (pass-if "full string" (string=? "foo bar braz" (string-drop-right "foo bar braz" 0)))) diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test index fc6307149..56c944a42 100644 --- a/test-suite/tests/srfi-14.test +++ b/test-suite/tests/srfi-14.test @@ -1,22 +1,22 @@ -;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions. +;;;; srfi-14.test -*- mode:scheme; coding: iso-8859-1 -*- +;;;; --- Test suite for Guile's SRFI-14 functions. ;;;; Martin Grabmueller, 2001-07-16 ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-14) :use-module (srfi srfi-14) @@ -30,6 +30,30 @@ (define exception:non-char-return (cons 'misc-error "returned non-char")) + +(with-test-prefix "char set contents" + + (pass-if "empty set" + (list= eqv? + (char-set->list (char-set)) + '())) + + (pass-if "single char" + (list= eqv? + (char-set->list (char-set #\a)) + (list #\a))) + + (pass-if "contiguous chars" + (list= eqv? + (char-set->list (char-set #\a #\b #\c)) + (list #\a #\b #\c))) + + (pass-if "discontiguous chars" + (list= eqv? + (char-set->list (char-set #\a #\c #\e)) + (list #\a #\c #\e)))) + + (with-test-prefix "char-set?" (pass-if "success on empty set" @@ -114,7 +138,7 @@ (with-test-prefix "char-set cursor" (pass-if-exception "invalid character cursor" - exception:invalid-char-set-cursor + exception:wrong-type-arg (let* ((cs (char-set #\B #\r #\a #\z)) (cc (char-set-cursor cs))) (char-set-ref cs 1000))) @@ -149,30 +173,33 @@ (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c)) (char-set) (char-set #\a #\b))) 2))) +(define char-set:256 + (string->char-set (apply string (map integer->char (iota 256))))) + (with-test-prefix "char-set-unfold" (pass-if "create char set" - (char-set= char-set:full + (char-set= char-set:256 (char-set-unfold (lambda (s) (= s 256)) integer->char (lambda (s) (+ s 1)) 0))) (pass-if "create char set (base set)" - (char-set= char-set:full + (char-set= char-set:256 (char-set-unfold (lambda (s) (= s 256)) integer->char (lambda (s) (+ s 1)) 0 char-set:empty)))) (with-test-prefix "char-set-unfold!" (pass-if "create char set" - (char-set= char-set:full + (char-set= char-set:256 (char-set-unfold! (lambda (s) (= s 256)) integer->char (lambda (s) (+ s 1)) 0 (char-set-copy char-set:empty)))) (pass-if "create char set" - (char-set= char-set:full + (char-set= char-set:256 (char-set-unfold! (lambda (s) (= s 32)) integer->char (lambda (s) (+ s 1)) 0 - (char-set-copy char-set:full))))) + (char-set-copy char-set:256))))) (with-test-prefix "char-set-for-each" @@ -187,9 +214,15 @@ (with-test-prefix "char-set-map" - (pass-if "upper case char set" - (char-set= (char-set-map char-upcase char-set:lower-case) - char-set:upper-case))) + (pass-if "upper case char set 1" + (char-set= (char-set-map char-upcase + (string->char-set "abcdefghijklmnopqrstuvwxyz")) + (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) + + (pass-if "upper case char set 2" + (char-set= (char-set-map char-upcase + (string->char-set "àáâãäåæçèéêëìíîïñòóôõöøùúûüýþ")) + (string->char-set "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝÞ")))) (with-test-prefix "string->char-set" @@ -198,42 +231,104 @@ (char-set= (list->char-set chars) (string->char-set (apply string chars)))))) -;; Make sure we get an ASCII charset and character classification. -(if (defined? 'setlocale) (setlocale LC_CTYPE "C")) +(with-test-prefix "char-set->string" + + (pass-if "some char set" + (let ((cs (char-set #\g #\u #\i #\l #\e))) + (string=? (char-set->string cs) + "egilu")))) (with-test-prefix "standard char sets (ASCII)" + (pass-if "char-set:lower-case" + (char-set<= (string->char-set "abcdefghijklmnopqrstuvwxyz") + char-set:lower-case)) + + (pass-if "char-set:upper-case" + (char-set<= (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + char-set:upper-case)) + + (pass-if "char-set:title-case" + (char-set<= (string->char-set "") + char-set:title-case)) + (pass-if "char-set:letter" - (char-set= (string->char-set - (string-append "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) - char-set:letter)) + (char-set<= (char-set-union + (string->char-set "abcdefghijklmnopqrstuvwxyz") + (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) + char-set:letter)) - (pass-if "char-set:punctuation" - (char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}") - char-set:punctuation)) + (pass-if "char-set:digit" + (char-set<= (string->char-set "0123456789") + char-set:digit)) - (pass-if "char-set:symbol" - (char-set= (string->char-set "$+<=>^`|~") - char-set:symbol)) + (pass-if "char-set:hex-digit" + (char-set<= (string->char-set "0123456789abcdefABCDEF") + char-set:hex-digit)) (pass-if "char-set:letter+digit" - (char-set= char-set:letter+digit - (char-set-union char-set:letter char-set:digit))) + (char-set<= (char-set-union + (string->char-set "abcdefghijklmnopqrstuvwxyz") + (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + (string->char-set "0123456789")) + char-set:letter+digit)) - (pass-if "char-set:graphic" - (char-set= char-set:graphic - (char-set-union char-set:letter char-set:digit - char-set:punctuation char-set:symbol))) + (pass-if "char-set:punctuation" + (char-set<= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}") + char-set:punctuation)) - (pass-if "char-set:printing" - (char-set= char-set:printing - (char-set-union char-set:whitespace char-set:graphic)))) + (pass-if "char-set:symbol" + (char-set<= (string->char-set "$+<=>^`|~") + char-set:symbol)) + (pass-if "char-set:graphic" + (char-set<= (char-set-union + (string->char-set "abcdefghijklmnopqrstuvwxyz") + (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + (string->char-set "0123456789") + (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}") + (string->char-set "$+<=>^`|~")) + char-set:graphic)) + + (pass-if "char-set:whitespace" + (char-set<= (string->char-set + (string + (integer->char #x09) + (integer->char #x0a) + (integer->char #x0b) + (integer->char #x0c) + (integer->char #x0d) + (integer->char #x20))) + char-set:whitespace)) + + (pass-if "char-set:printing" + (char-set<= (char-set-union + (string->char-set "abcdefghijklmnopqrstuvwxyz") + (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + (string->char-set "0123456789") + (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}") + (string->char-set "$+<=>^`|~") + (string->char-set (string + (integer->char #x09) + (integer->char #x0a) + (integer->char #x0b) + (integer->char #x0c) + (integer->char #x0d) + (integer->char #x20)))) + char-set:printing)) + + (pass-if "char-set:iso-control" + (char-set<= (string->char-set + (apply string + (map integer->char (append + ;; U+0000 to U+001F + (iota #x20) + (list #x7f))))) + char-set:iso-control))) ;;; -;;; 8-bit charsets. +;;; Non-ASCII codepoints ;;; ;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of ;;; SRFI-14 for implementations supporting this charset is well-defined. @@ -242,76 +337,105 @@ (define (every? pred lst) (not (not (every pred lst)))) -(define (find-latin1-locale) - ;; Try to find and install an ISO-8859-1 locale. Return `#f' on failure. - (if (defined? 'setlocale) - (let loop ((locales (map (lambda (lang) - (string-append lang ".iso88591")) - '("de_DE" "en_GB" "en_US" "es_ES" - "fr_FR" "it_IT")))) - (if (null? locales) - #f - (if (false-if-exception (setlocale LC_CTYPE (car locales))) - (car locales) - (loop (cdr locales))))) - #f)) +(define oldlocale #f) +(if (defined? 'setlocale) + (set! oldlocale (setlocale LC_ALL ""))) +(with-test-prefix "Latin-1 (8-bit charset)" -(define %latin1 (find-latin1-locale)) + (pass-if "char-set:lower-case" + (char-set<= (string->char-set + (string-append "abcdefghijklmnopqrstuvwxyz" + "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ") + char-set:lower-case))) -(with-test-prefix "Latin-1 (8-bit charset)" + (pass-if "char-set:upper-case" + (char-set<= (string->char-set + (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ") + char-set:lower-case))) - ;; Note: the membership tests below are not exhaustive. - - (pass-if "char-set:letter (membership)" - (if (not %latin1) - (throw 'unresolved) - (let ((letters (char-set->list char-set:letter))) - (every? (lambda (8-bit-char) - (memq 8-bit-char letters)) - (append '(#\a #\b #\c) ;; ASCII - (string->list "çéèâùÉÀÈÊ") ;; French - (string->list "øñÑíßåæðþ")))))) - - (pass-if "char-set:letter (size)" - (if (not %latin1) - (throw 'unresolved) - (= (char-set-size char-set:letter) 117))) - - (pass-if "char-set:lower-case (size)" - (if (not %latin1) - (throw 'unresolved) - (= (char-set-size char-set:lower-case) (+ 26 33)))) - - (pass-if "char-set:upper-case (size)" - (if (not %latin1) - (throw 'unresolved) - (= (char-set-size char-set:upper-case) (+ 26 30)))) - - (pass-if "char-set:punctuation (membership)" - (if (not %latin1) - (throw 'unresolved) - (let ((punctuation (char-set->list char-set:punctuation))) - (every? (lambda (8-bit-char) - (memq 8-bit-char punctuation)) - (append '(#\! #\. #\?) ;; ASCII - (string->list "¡¿") ;; Castellano - (string->list "«»")))))) ;; French + (pass-if "char-set:title-case" + (char-set<= (string->char-set "") + char-set:title-case)) + + (pass-if "char-set:letter" + (char-set<= (string->char-set + (string-append + ;; Lowercase + "abcdefghijklmnopqrstuvwxyz" + "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ" + ;; Uppercase + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ" + ;; Uncased + "ªº")) + char-set:letter)) + + (pass-if "char-set:digit" + (char-set<= (string->char-set "0123456789") + char-set:digit)) + + (pass-if "char-set:hex-digit" + (char-set<= (string->char-set "0123456789abcdefABCDEF") + char-set:hex-digit)) (pass-if "char-set:letter+digit" - (char-set= char-set:letter+digit - (char-set-union char-set:letter char-set:digit))) + (char-set<= (char-set-union + char-set:letter + char-set:digit) + char-set:letter+digit)) - (pass-if "char-set:graphic" - (char-set= char-set:graphic - (char-set-union char-set:letter char-set:digit - char-set:punctuation char-set:symbol))) + (pass-if "char-set:punctuation" + (char-set<= (string->char-set + (string-append "!\"#%&'()*,-./:;?@[\\]_{}" + "¡«·»¿")) + char-set:punctuation)) + (pass-if "char-set:symbol" + (char-set<= (string->char-set + (string-append "$+<=>^`|~" + "¢£¤¥¦§¨©¬®¯°±´¶¸×÷")) + char-set:symbol)) + + ;; Note that SRFI-14 itself is inconsistent here. Characters that + ;; are non-digit numbers (such as category No) are clearly 'graphic' + ;; but don't occur in the letter, digit, punct, or symbol charsets. + (pass-if "char-set:graphic" + (char-set<= (char-set-union + char-set:letter + char-set:digit + char-set:punctuation + char-set:symbol) + char-set:graphic)) + + (pass-if "char-set:whitespace" + (char-set<= (string->char-set + (string + (integer->char #x09) + (integer->char #x0a) + (integer->char #x0b) + (integer->char #x0c) + (integer->char #x0d) + (integer->char #x20) + (integer->char #xa0))) + char-set:whitespace)) + (pass-if "char-set:printing" - (char-set= char-set:printing - (char-set-union char-set:whitespace char-set:graphic)))) - -;; Local Variables: -;; mode: scheme -;; coding: latin-1 -;; End: + (char-set<= (char-set-union char-set:graphic char-set:whitespace) + char-set:printing)) + + (pass-if "char-set:iso-control" + (char-set<= (string->char-set + (apply string + (map integer->char (append + ;; U+0000 to U+001F + (iota #x20) + (list #x7f) + ;; U+007F to U+009F + (map (lambda (x) (+ #x80 x)) + (iota #x20)))))) + char-set:iso-control))) + +(if (defined? 'setlocale) + (setlocale LC_ALL oldlocale)) diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index fbacb15a3..d9e0054ba 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -2,20 +2,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-17) :use-module (test-suite lib) @@ -50,6 +49,9 @@ (define %some-variable #f) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) + (with-test-prefix "set!" (with-test-prefix "target is not procedure with setter" @@ -59,7 +61,7 @@ (set! (symbol->string 'x) 1)) (pass-if-exception "(set! '#f 1)" - exception:bad-variable + exception:bad-quote (eval '(set! '#f 1) (interaction-environment)))) (with-test-prefix "target uses macro" @@ -72,7 +74,7 @@ ;; The `(quote x)' below used to be memoized as an infinite list before ;; Guile 1.8.3. (pass-if-exception "(set! 'x 1)" - exception:bad-variable + exception:bad-quote (eval '(set! 'x 1) (interaction-environment))))) ;; diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index fa309e6ce..b769ce1a2 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -3,26 +3,30 @@ ;;;; ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-18) #:use-module (test-suite lib)) -(and (provided? 'threads) - (use-modules (srfi srfi-18)) +;; two expressions so that the srfi-18 import is in effect for expansion +;; of the rest +(if (provided? 'threads) + (use-modules (srfi srfi-18))) + +(and + (provided? 'threads) (with-test-prefix "current-thread" diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 259a88a4e..f48ce6286 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;; SRFI-19 overrides current-date, so we have to do the test in a ;; separate module, or later tests will fail. diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index bd6977333..6d65ce2bc 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -5,7 +5,7 @@ ;;;; 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. +;;;; 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 @@ -23,7 +23,7 @@ (with-test-prefix "rec special form" (pass-if-exception "bogus variable" '(misc-error . ".*") - (rec #:foo)) + (sc-expand '(rec #:foo))) (pass-if "rec expressions" (let ((ones-list (rec ones (cons 1 (delay ones))))) diff --git a/test-suite/tests/srfi-34.test b/test-suite/tests/srfi-34.test index 2195d9471..17864b642 100644 --- a/test-suite/tests/srfi-34.test +++ b/test-suite/tests/srfi-34.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-34) :duplicates (last) ;; avoid warning about srfi-34 replacing `raise' diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test index 83efd61d9..24ee60248 100644 --- a/test-suite/tests/srfi-35.test +++ b/test-suite/tests/srfi-35.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-35) :use-module (test-suite lib) diff --git a/test-suite/tests/srfi-37.test b/test-suite/tests/srfi-37.test index d7745876d..1f739c5c5 100644 --- a/test-suite/tests/srfi-37.test +++ b/test-suite/tests/srfi-37.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-37) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-39.test b/test-suite/tests/srfi-39.test index 277a3c60d..0153e58b4 100644 --- a/test-suite/tests/srfi-39.test +++ b/test-suite/tests/srfi-39.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-39) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test index ee773a3f9..8a9d53a61 100644 --- a/test-suite/tests/srfi-4.test +++ b/test-suite/tests/srfi-4.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (srfi srfi-4) (test-suite lib)) diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test index 217fc9f78..68fc70dff 100644 --- a/test-suite/tests/srfi-6.test +++ b/test-suite/tests/srfi-6.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; 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)) diff --git a/test-suite/tests/srfi-60.test b/test-suite/tests/srfi-60.test index fff89f1ca..940934f3e 100644 --- a/test-suite/tests/srfi-60.test +++ b/test-suite/tests/srfi-60.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright 2005, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-60) #:duplicates (last) ;; avoid warning about srfi-60 replacing `bit-count' diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test index 1d240d28c..e99b76c6d 100644 --- a/test-suite/tests/srfi-69.test +++ b/test-suite/tests/srfi-69.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-69) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-88.test b/test-suite/tests/srfi-88.test index 63f40cc40..b879941b2 100644 --- a/test-suite/tests/srfi-88.test +++ b/test-suite/tests/srfi-88.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-88) :use-module (test-suite lib) diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test index c212ea6aa..f8cb0b491 100644 --- a/test-suite/tests/srfi-9.test +++ b/test-suite/tests/srfi-9.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-numbers) #:use-module (test-suite lib) diff --git a/test-suite/tests/srfi-98.test b/test-suite/tests/srfi-98.test new file mode 100644 index 000000000..ac0d5178e --- /dev/null +++ b/test-suite/tests/srfi-98.test @@ -0,0 +1,37 @@ +;;;; srfi-98.test --- Test suite for Guile's SRFI-98 functions. -*- scheme -*- +;;;; +;;;; Copyright 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-srfi-98) + #:use-module (srfi srfi-98) + #:use-module (test-suite lib)) + +(with-test-prefix "get-environment-variable" + (pass-if "get-environment-variable retrieves binding" + (putenv "foo=bar") + (equal? (get-environment-variable "foo") "bar")) + + (pass-if "get-environment-variable #f on unbound name" + (unsetenv "foo") + (not (get-environment-variable "foo")))) + +(with-test-prefix "get-environment-variables" + + (pass-if "get-environment-variables contains binding" + (putenv "foo=bar") + (equal? (assoc-ref (get-environment-variables) "foo") "bar"))) + diff --git a/test-suite/tests/streams.test b/test-suite/tests/streams.test index 92277c19c..780021c7e 100644 --- a/test-suite/tests/streams.test +++ b/test-suite/tests/streams.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-streams) :use-module (test-suite lib) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 51f163254..c78fe55ff 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,34 +1,222 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- August 1999 ;;;; -;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-strings) #:use-module (test-suite lib)) - (define exception:read-only-string (cons 'misc-error "^string is read-only")) +(define exception:illegal-escape + (cons 'read-error "illegal character in escape sequence")) +;; Wrong types may have either the 'wrong-type-arg key when +;; interpreted or 'vm-error when compiled. This matches both. +(define exception:wrong-type-arg + (cons #t "Wrong type")) ;; Create a string from integer char values, eg. (string-ints 65) => "A" (define (string-ints . args) (apply string (map integer->char args))) +;; +;; string internals +;; + +;; Some abbreviations +;; BMP - Basic Multilingual Plane (codepoints below U+FFFF) +;; SMP - Suplementary Multilingual Plane (codebpoints from U+10000 to U+1FFFF) + +(with-test-prefix "string internals" + + (pass-if "new string starts at 1st char in stringbuf" + (let ((s "abc")) + (= 0 (assq-ref (%string-dump s) 'start)))) + + (pass-if "length of new string same as stringbuf" + (let ((s "def")) + (= (string-length s) (assq-ref (%string-dump s) 'stringbuf-length)))) + + (pass-if "contents of new string same as stringbuf" + (let ((s "ghi")) + (string=? s (assq-ref (%string-dump s) 'stringbuf-chars)))) + + (pass-if "writable strings are not read-only" + (let ((s "zyx")) + (not (assq-ref (%string-dump s) 'read-only)))) + + (pass-if "read-only strings are read-only" + (let ((s (substring/read-only "zyx" 0))) + (assq-ref (%string-dump s) 'read-only))) + + (pass-if "new Latin-1 encoded strings are not shared" + (let ((s "abc")) + (not (assq-ref (%string-dump s) 'stringbuf-shared)))) + + (pass-if "new UCS-4 encoded strings are not shared" + (let ((s "\u0100bc")) + (not (assq-ref (%string-dump s) 'stringbuf-shared)))) + + ;; Should this be true? It isn't currently true. + (pass-if "null shared substrings are shared" + (let* ((s1 "") + (s2 (substring/shared s1 0 0))) + (throw 'untested) + (eq? (assq-ref (%string-dump s2) 'shared) + s1))) + + (pass-if "ASCII shared substrings are shared" + (let* ((s1 "foobar") + (s2 (substring/shared s1 0 3))) + (eq? (assq-ref (%string-dump s2) 'shared) + s1))) + + (pass-if "BMP shared substrings are shared" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring/shared s1 0 3))) + (eq? (assq-ref (%string-dump s2) 'shared) + s1))) + + (pass-if "null substrings are not shared" + (let* ((s1 "") + (s2 (substring s1 0 0))) + (not (eq? (assq-ref (%string-dump s2) 'shared) + s1)))) + + (pass-if "ASCII substrings are not shared" + (let* ((s1 "foobar") + (s2 (substring s1 0 3))) + (not (eq? (assq-ref (%string-dump s2) 'shared) + s1)))) + + (pass-if "BMP substrings are not shared" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring s1 0 3))) + (not (eq? (assq-ref (%string-dump s2) 'shared) + s1)))) + + (pass-if "ASCII substrings share stringbufs before copy-on-write" + (let* ((s1 "foobar") + (s2 (substring s1 0 3))) + (assq-ref (%string-dump s1) 'stringbuf-shared))) + + (pass-if "BMP substrings share stringbufs before copy-on-write" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring s1 0 3))) + (assq-ref (%string-dump s1) 'stringbuf-shared))) + + (pass-if "ASCII substrings don't share stringbufs after copy-on-write" + (let* ((s1 "foobar") + (s2 (substring s1 0 3))) + (string-set! s2 0 #\F) + (not (assq-ref (%string-dump s2) 'stringbuf-shared)))) + + (pass-if "BMP substrings don't share stringbufs after copy-on-write" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring s1 0 3))) + (string-set! s2 0 #\F) + (not (assq-ref (%string-dump s2) 'stringbuf-shared)))) + + (with-test-prefix "encodings" + + (pass-if "null strings are Latin-1 encoded" + (let ((s "")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "ASCII strings are Latin-1 encoded" + (let ((s "jkl")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "Latin-1 strings are Latin-1 encoded" + (let ((s "\xC0\xC1\xC2")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "BMP strings are UCS-4 encoded" + (let ((s "\u0100\u0101\x0102")) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "SMP strings are UCS-4 encoded" + (let ((s "\U010300\u010301\x010302")) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "null list->string is Latin-1 encoded" + (let ((s (string-ints))) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "ASCII list->string is Latin-1 encoded" + (let ((s (string-ints 65 66 67))) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "Latin-1 list->string is Latin-1 encoded" + (let ((s (string-ints #xc0 #xc1 #xc2))) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))) + + (pass-if "BMP list->string is UCS-4 encoded" + (let ((s (string-ints #x0100 #x0101 #x0102))) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "SMP list->string is UCS-4 encoded" + (let ((s (string-ints #x010300 #x010301 #x010302))) + (assq-ref (%string-dump s) 'stringbuf-wide))) + + (pass-if "encoding of string not based on escape style" + (let ((s "\U000040")) + (not (assq-ref (%string-dump s) 'stringbuf-wide)))))) + +(with-test-prefix "hex escapes" + + (pass-if-exception "non-hex char in two-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\x0g\"" read)) + + (pass-if-exception "non-hex char in four-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\u000g\"" read)) + + (pass-if-exception "non-hex char in six-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\U00000g\"" read)) + + (pass-if-exception "premature termination of two-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\x0\"" read)) + + (pass-if-exception "premature termination of four-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\u000\"" read)) + + (pass-if-exception "premature termination of six-digit hex-escape" + exception:illegal-escape + (with-input-from-string "\"\\U00000\"" read)) + + (pass-if "extra hex digits ignored for two-digit hex escape" + (eqv? (string-ref "--\xfff--" 2) + (integer->char #xff))) + + (pass-if "extra hex digits ignored for four-digit hex escape" + (eqv? (string-ref "--\u0100f--" 2) + (integer->char #x0100))) + + (pass-if "extra hex digits ignored for six-digit hex escape" + (eqv? (string-ref "--\U010300f--" 2) + (integer->char #x010300))) + + (pass-if "escaped characters match non-escaped ASCII characters" + (string=? "ABC" "\x41\u0042\U000043"))) ;; ;; string=? @@ -182,8 +370,20 @@ exception:out-of-range (string-ref "hello" -1)) - (pass-if "regular string" - (char=? (string-ref "GNU Guile" 4) #\G))) + (pass-if "regular string, ASCII char" + (char=? (string-ref "GNU Guile" 4) #\G)) + + (pass-if "regular string, hex escaped Latin-1 char" + (char=? (string-ref "--\xff--" 2) + (integer->char #xff))) + + (pass-if "regular string, hex escaped BMP char" + (char=? (string-ref "--\u0100--" 2) + (integer->char #x0100))) + + (pass-if "regular string, hex escaped SMP char" + (char=? (string-ref "--\U010300--" 2) + (integer->char #x010300)))) ;; ;; string-set! @@ -211,12 +411,37 @@ exception:read-only-string (string-set! (substring/read-only "abc" 0) 1 #\space)) - (pass-if "regular string" + (pass-if "regular string, ASCII char" (let ((s (string-copy "GNU guile"))) (string-set! s 4 #\G) - (char=? (string-ref s 4) #\G)))) + (char=? (string-ref s 4) #\G))) + (pass-if "regular string, Latin-1 char" + (let ((s (string-copy "GNU guile"))) + (string-set! s 4 (integer->char #xfe)) + (char=? (string-ref s 4) (integer->char #xfe)))) + + (pass-if "regular string, BMP char" + (let ((s (string-copy "GNU guile"))) + (string-set! s 4 (integer->char #x0100)) + (char=? (string-ref s 4) (integer->char #x0100)))) + (pass-if "regular string, SMP char" + (let ((s (string-copy "GNU guile"))) + (string-set! s 4 (integer->char #x010300)) + (char=? (string-ref s 4) (integer->char #x010300))))) + +;; +;; list->string +;; +(with-test-prefix "string" + + (pass-if-exception "convert circular list to string" + exception:wrong-type-arg + (let ((foo (list #\a #\b #\c))) + (set-cdr! (cddr foo) (cdr foo)) + (apply string foo)))) + (with-test-prefix "string-split" ;; in guile 1.6.7 and earlier, character >=128 wasn't matched in the string diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test index 127115eb2..e114abb1a 100644 --- a/test-suite/tests/structs.test +++ b/test-suite/tests/structs.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-structs) :use-module (test-suite lib)) diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test index 3fe3402f8..c87aa21d1 100644 --- a/test-suite/tests/symbols.test +++ b/test-suite/tests/symbols.test @@ -1,21 +1,20 @@ ;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*- ;;;; -;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-symbols) #:use-module (test-suite lib) @@ -32,6 +31,60 @@ (define (documented? object) (not (not (object-documentation object)))) +(define (symbol-length s) + (string-length (symbol->string s))) + +;; +;; symbol internals +;; + +(with-test-prefix "symbol internals" + + (pass-if "length of new symbol same as stringbuf" + (let ((s 'def)) + (= (symbol-length s) (assq-ref (%symbol-dump s) 'stringbuf-length)))) + + (pass-if "contents of new symbol same as stringbuf" + (let ((s 'ghi)) + (string=? (symbol->string s) + (assq-ref (%symbol-dump s) 'stringbuf-chars)))) + + + (with-test-prefix "hashes" + + (pass-if "equal symbols have equal hashes" + (let ((s1 'mux) + (s2 'mux)) + (= (assq-ref (%symbol-dump s1) 'hash) + (assq-ref (%symbol-dump s2) 'hash)))) + + (pass-if "different symbols have different hashes" + (let ((s1 'mux) + (s2 'muy)) + (not (= (assq-ref (%symbol-dump s1) 'hash) + (assq-ref (%symbol-dump s2) 'hash)))))) + + (with-test-prefix "encodings" + + (pass-if "the null symbol is Latin-1 encoded" + (let ((s '#{}#)) + (not (assq-ref (%symbol-dump s) 'stringbuf-wide)))) + + (pass-if "ASCII symbols are Latin-1 encoded" + (let ((s 'jkl)) + (not (assq-ref (%symbol-dump s) 'stringbuf-wide)))) + + (pass-if "Latin-1 symbols are Latin-1 encoded" + (let ((s (string->symbol "\xC0\xC1\xC2"))) + (not (assq-ref (%symbol-dump s) 'stringbuf-wide)))) + + (pass-if "BMP symbols are UCS-4 encoded" + (let ((s (string->symbol "\u0100\u0101\x0102"))) + (assq-ref (%symbol-dump s) 'stringbuf-wide))) + + (pass-if "SMP symbols are UCS-4 encoded" + (let ((s (string->symbol "\U010300\u010301\x010302"))) + (assq-ref (%symbol-dump s) 'stringbuf-wide))))) ;;; ;;; symbol? @@ -48,6 +101,16 @@ (pass-if "symbol" (symbol? 'foo))) +;;; +;;; wide symbols +;;; + +(with-test-prefix "BMP symbols" + + (pass-if "BMP symbol's string" + (and (= 4 (string-length "abc\u0100")) + (string=? "abc\u0100" + (symbol->string (string->symbol "abc\u0100")))))) ;;; ;;; symbol->string diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index c681fc381..4cd93369a 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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 ;; These tests are in a module so that the syntax transformer does not ;; affect code outside of this file. diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 1277e5204..282072b5b 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -1,26 +1,30 @@ ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- ;;;; -;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-syntax) :use-module (test-suite lib)) +(define exception:generic-syncase-error + (cons 'syntax-error "source expression failed to match")) +(define exception:unexpected-syntax + (cons 'syntax-error "unexpected syntax")) + (define exception:bad-expression (cons 'syntax-error "Bad expression")) @@ -29,22 +33,32 @@ (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:missing-body-expr - (cons 'syntax-error "Missing body expression")) + (cons 'syntax-error "no expressions in body")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) (define exception:illegal-empty-combination (cons 'syntax-error "Illegal empty combination")) +(define exception:bad-lambda + '(syntax-error . "bad lambda")) +(define exception:bad-let + '(syntax-error . "bad let ")) +(define exception:bad-letrec + '(syntax-error . "bad letrec ")) +(define exception:bad-set! + '(syntax-error . "bad set!")) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) (define exception:bad-bindings (cons 'syntax-error "Bad bindings")) (define exception:bad-binding (cons 'syntax-error "Bad binding")) (define exception:duplicate-binding - (cons 'syntax-error "Duplicate binding")) + (cons 'syntax-error "duplicate bound variable")) (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals - (cons 'syntax-error "Bad formals")) + '(syntax-error . "invalid parameter list")) (define exception:bad-formal (cons 'syntax-error "Bad formal")) (define exception:duplicate-formal @@ -67,13 +81,13 @@ (with-test-prefix "Bad argument list" (pass-if-exception "improper argument list of length 1" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo . 1)) (interaction-environment))) (pass-if-exception "improper argument list of length 2" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo 1 . 2)) (interaction-environment)))) @@ -88,7 +102,7 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" - exception:illegal-empty-combination + exception:unexpected-syntax (eval '() (interaction-environment))))) @@ -106,28 +120,32 @@ (with-test-prefix "unquote-splicing" (pass-if-exception "extra arguments" - exception:missing/extra-expr - (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) + '(syntax-error . "unquote-splicing takes exactly one argument") + (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) + (interaction-environment))))) (with-test-prefix "begin" (pass-if "legal (begin)" - (begin) - #t) + (eval '(begin (begin) #t) (interaction-environment))) (with-test-prefix "unmemoization" + ;; FIXME. I have no idea why, but the expander is filling in (if #f + ;; #f) as the second arm of the if, if the second arm is missing. I + ;; thought I made it not do that. But in the meantime, let's adapt, + ;; since that's not what we're testing. + (pass-if "normal begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))) - (foo) ; make sure, memoization has been performed + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))) (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))) (pass-if "redundant nested begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))) + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))) (pass-if "redundant begin at start of body" (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized @@ -135,10 +153,20 @@ (equal? (procedure-source foo) '(lambda () (begin (+ 1) (+ 2))))))) - (expect-fail-exception "illegal (begin)" - exception:bad-body - (if #t (begin)) - #t)) + (pass-if-exception "illegal (begin)" + exception:generic-syncase-error + (eval '(begin (if #t (begin)) #t) (interaction-environment)))) + +(define-syntax matches? + (syntax-rules (_) + ((_ (op arg ...) pat) (let ((x (op arg ...))) + (matches? x pat))) + ((_ x ()) (null? x)) + ((_ x (a . b)) (and (pair? x) + (matches? (car x) a) + (matches? (cdr x) b))) + ((_ x _) #t) + ((_ x pat) (equal? x 'pat)))) (with-test-prefix "lambda" @@ -146,30 +174,28 @@ (pass-if "normal lambda" (let ((foo (lambda () (lambda (x y) (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) (+ _ _)))))) (pass-if "lambda with documentation" (let ((foo (lambda () (lambda (x y) "docstring" (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) "docstring" (+ x y))))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) "docstring" (+ _ _))))))) (with-test-prefix "bad formals" (pass-if-exception "(lambda)" - exception:missing-expr + exception:bad-lambda (eval '(lambda) (interaction-environment))) (pass-if-exception "(lambda . \"foo\")" - exception:bad-expression + exception:bad-lambda (eval '(lambda . "foo") (interaction-environment))) (pass-if-exception "(lambda \"foo\")" - exception:missing-expr + exception:bad-lambda (eval '(lambda "foo") (interaction-environment))) @@ -179,22 +205,22 @@ (interaction-environment))) (pass-if-exception "(lambda (x 1) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x 1) 2) (interaction-environment))) (pass-if-exception "(lambda (1 x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (1 x) 2) (interaction-environment))) (pass-if-exception "(lambda (x \"a\") 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x "a") 2) (interaction-environment))) (pass-if-exception "(lambda (\"a\" x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda ("a" x) 2) (interaction-environment)))) @@ -202,20 +228,20 @@ ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x) 1) (interaction-environment))) ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x x) 1) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(lambda ())" - exception:missing-expr + exception:bad-lambda (eval '(lambda ()) (interaction-environment))))) @@ -225,9 +251,8 @@ (pass-if "normal let" (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -238,42 +263,42 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let)" - exception:missing-expr + exception:bad-let (eval '(let) (interaction-environment))) (pass-if-exception "(let 1)" - exception:missing-expr + exception:bad-let (eval '(let 1) (interaction-environment))) (pass-if-exception "(let (x))" - exception:missing-expr + exception:bad-let (eval '(let (x)) (interaction-environment))) (pass-if-exception "(let ((x)))" - exception:missing-expr + exception:bad-let (eval '(let ((x))) (interaction-environment))) (pass-if-exception "(let (x) 1)" - exception:bad-binding + exception:bad-let (eval '(let (x) 1) (interaction-environment))) (pass-if-exception "(let ((x)) 3)" - exception:bad-binding + exception:bad-let (eval '(let ((x)) 3) (interaction-environment))) (pass-if-exception "(let ((x 1) y) x)" - exception:bad-binding + exception:bad-let (eval '(let ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let ((1 2)) 3)" - exception:bad-variable + exception:bad-let (eval '(let ((1 2)) 3) (interaction-environment)))) @@ -287,12 +312,12 @@ (with-test-prefix "bad body" (pass-if-exception "(let ())" - exception:missing-expr + exception:bad-let (eval '(let ()) (interaction-environment))) (pass-if-exception "(let ((x 1)))" - exception:missing-expr + exception:bad-let (eval '(let ((x 1))) (interaction-environment))))) @@ -307,19 +332,19 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let x (y))" - exception:missing-expr + exception:bad-let (eval '(let x (y)) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let x ())" - exception:missing-expr + exception:bad-let (eval '(let x ()) (interaction-environment))) (pass-if-exception "(let x ((y 1)))" - exception:missing-expr + exception:bad-let (eval '(let x ((y 1))) (interaction-environment))))) @@ -329,19 +354,16 @@ (pass-if "normal let*" (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let* ((x 1) (y 2)) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _))))))) (pass-if "let* without bindings" (let ((foo (lambda () (let ((x 1) (y 2)) (let* () (and (= x 1) (= y 2))))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((x 1) (y 2)) - (let* () - (and (= x 1) (= y 2))))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) + (if (= _ 1) (= _ 2) #f))))))) (with-test-prefix "bindings" @@ -361,59 +383,59 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let*)" - exception:missing-expr + exception:generic-syncase-error (eval '(let*) (interaction-environment))) (pass-if-exception "(let* 1)" - exception:missing-expr + exception:generic-syncase-error (eval '(let* 1) (interaction-environment))) (pass-if-exception "(let* (x))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* (x)) (interaction-environment))) (pass-if-exception "(let* (x) 1)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* (x) 1) (interaction-environment))) (pass-if-exception "(let* ((x)) 3)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x)) 3) (interaction-environment))) (pass-if-exception "(let* ((x 1) y) x)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let* x ())" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x ()) (interaction-environment))) (pass-if-exception "(let* x (y))" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x (y)) (interaction-environment))) (pass-if-exception "(let* ((1 2)) 3)" - exception:bad-variable + exception:generic-syncase-error (eval '(let* ((1 2)) 3) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let* ())" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ()) (interaction-environment))) (pass-if-exception "(let* ((x 1)))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ((x 1))) (interaction-environment))))) @@ -423,9 +445,8 @@ (pass-if "normal letrec" (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (letrec ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (letrec ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -437,47 +458,47 @@ (with-test-prefix "bad bindings" (pass-if-exception "(letrec)" - exception:missing-expr + exception:bad-letrec (eval '(letrec) (interaction-environment))) (pass-if-exception "(letrec 1)" - exception:missing-expr + exception:bad-letrec (eval '(letrec 1) (interaction-environment))) (pass-if-exception "(letrec (x))" - exception:missing-expr + exception:bad-letrec (eval '(letrec (x)) (interaction-environment))) (pass-if-exception "(letrec (x) 1)" - exception:bad-binding + exception:bad-letrec (eval '(letrec (x) 1) (interaction-environment))) (pass-if-exception "(letrec ((x)) 3)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x)) 3) (interaction-environment))) (pass-if-exception "(letrec ((x 1) y) x)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x 1) y) x) (interaction-environment))) (pass-if-exception "(letrec x ())" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x ()) (interaction-environment))) (pass-if-exception "(letrec x (y))" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x (y)) (interaction-environment))) (pass-if-exception "(letrec ((1 2)) 3)" - exception:bad-variable + exception:bad-letrec (eval '(letrec ((1 2)) 3) (interaction-environment)))) @@ -491,12 +512,12 @@ (with-test-prefix "bad body" (pass-if-exception "(letrec ())" - exception:missing-expr + exception:bad-letrec (eval '(letrec ()) (interaction-environment))) (pass-if-exception "(letrec ((x 1)))" - exception:missing-expr + exception:bad-letrec (eval '(letrec ((x 1))) (interaction-environment))))) @@ -508,17 +529,17 @@ (let ((foo (lambda (x) (if x (+ 1) (+ 2))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (if x (+ 1) (+ 2)))))) + (matches? (procedure-source foo) + (lambda (_) (if _ (+ 1) (+ 2)))))) - (pass-if "if without else" + (expect-fail "if without else" (let ((foo (lambda (x) (if x (+ 1))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed (equal? (procedure-source foo) '(lambda (x) (if x (+ 1)))))) - (pass-if "if #f without else" + (expect-fail "if #f without else" (let ((foo (lambda () (if #f #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) @@ -527,12 +548,12 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(if)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if) (interaction-environment))) (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if 1 2 3 4) (interaction-environment))))) @@ -594,78 +615,77 @@ (eq? 'ok (cond (#t identity =>) (else #f))))) (pass-if-exception "missing recipient" - '(syntax-error . "Missing recipient") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity =>))) (pass-if-exception "extra recipient" - '(syntax-error . "Extra expression") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity => identity identity)))) (with-test-prefix "unmemoization" + ;; FIXME: the (if #f #f) is a hack! (pass-if "normal clauses" - (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed + (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz))))) (equal? (procedure-source foo) - '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))) + '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f))))))) (pass-if "else" (let ((foo (lambda () (cond (else 'bar))))) - (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (cond (else 'bar)))))) + '(lambda () 'bar)))) + ;; FIXME: the (if #f #f) is a hack! (pass-if "=>" (let ((foo (lambda () (cond (#t => identity))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (cond (#t => identity))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ #t)) + (if _ (identity _) (if #f #f)))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(cond)" - exception:missing-clauses + exception:generic-syncase-error (eval '(cond) (interaction-environment))) (pass-if-exception "(cond #t)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond #t) (interaction-environment))) (pass-if-exception "(cond 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1) (interaction-environment))) (pass-if-exception "(cond 1 2)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2) (interaction-environment))) (pass-if-exception "(cond 1 2 3)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3) (interaction-environment))) (pass-if-exception "(cond 1 2 3 4)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3 4) (interaction-environment))) (pass-if-exception "(cond ())" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond ()) (interaction-environment))) (pass-if-exception "(cond () 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond () 1) (interaction-environment))) (pass-if-exception "(cond (1) 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond (1) 1) (interaction-environment)))) @@ -683,7 +703,7 @@ (with-test-prefix "case is hygienic" (pass-if-exception "bound 'else is handled correctly" - exception:bad-case-labels + exception:generic-syncase-error (eval '(let ((else #f)) (case 1 (else #f))) (interaction-environment)))) @@ -691,79 +711,83 @@ (pass-if "normal clauses" (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '(2)) + 'baz + 'foobar)))))) (pass-if "empty labels" (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '()) + 'baz + 'foobar))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(case)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case) (interaction-environment))) (pass-if-exception "(case . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case . "foo") (interaction-environment))) (pass-if-exception "(case 1)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case 1) (interaction-environment))) (pass-if-exception "(case 1 . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 . "foo") (interaction-environment))) (pass-if-exception "(case 1 \"foo\")" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 "foo") (interaction-environment))) (pass-if-exception "(case 1 ())" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ()) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\"))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ("foo")) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\" \"bar\"))" - exception:bad-case-labels + exception:generic-syncase-error (eval '(case 1 ("foo" "bar")) (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 ((2) "bar") . "foo") (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") (else))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ((2) "bar") (else)) (interaction-environment))) (pass-if-exception "(case 1 (else #f) . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 (else #f) . "foo") (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:misplaced-else-clause + exception:generic-syncase-error (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) @@ -780,36 +804,27 @@ (eval '(define round round) m) (eq? (module-ref m 'round) round))) - (with-test-prefix "currying" - - (pass-if "(define ((foo)) #f)" - (eval '(begin - (define ((foo)) #t) - ((foo))) - (interaction-environment)))) - (with-test-prefix "unmemoization" (pass-if "definition unmemoized without prior execution" - (eval '(begin - (define (blub) (cons ('(1 . 2)) 2)) - (equal? - (procedure-source blub) - '(lambda () (cons ('(1 . 2)) 2)))) - (interaction-environment))) + (primitive-eval '(begin + (define (blub) (cons ('(1 . 2)) 2)) + (equal? + (procedure-source blub) + '(lambda () (cons ('(1 . 2)) 2)))))) + (pass-if "definition with documentation unmemoized without prior execution" - (eval '(begin - (define (blub) "Comment" (cons ('(1 . 2)) 2)) - (equal? - (procedure-source blub) - '(lambda () "Comment" (cons ('(1 . 2)) 2)))) - (interaction-environment)))) - + (primitive-eval '(begin + (define (blub) "Comment" (cons ('(1 . 2)) 2)) + (equal? + (procedure-source blub) + '(lambda () "Comment" (cons ('(1 . 2)) 2))))))) + (with-test-prefix "missing or extra expressions" (pass-if-exception "(define)" - exception:missing-expr + exception:generic-syncase-error (eval '(define) (interaction-environment))))) @@ -880,40 +895,15 @@ (interaction-environment))) (pass-if "unmemoization" - (eval '(begin - (define (foo) - (define (bar) - 'ok) - (bar)) - (foo) - (equal? - (procedure-source foo) - '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar))))) - (interaction-environment)))) - -(with-test-prefix "do" - - (with-test-prefix "unmemoization" - - (pass-if "normal case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i)))))) - - (pass-if "reduced case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here - ((> i 9) (+ i j)) - (identity i)))))))) + (primitive-eval '(begin + (define (foo) + (define (bar) + 'ok) + (bar)) + (foo) + (matches? + (procedure-source foo) + (lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))))) (with-test-prefix "set!" @@ -922,50 +912,50 @@ (pass-if "normal set!" (let ((foo (lambda (x) (set! x (+ 1 x))))) (foo 1) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (set! x (+ 1 x))))))) + (matches? (procedure-source foo) + (lambda (_) (set! _ (+ 1 _))))))) (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr + exception:bad-set! (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1 2 3) (interaction-environment)))) (with-test-prefix "bad variable" (pass-if-exception "(set! \"\" #t)" - exception:bad-variable + exception:bad-set! (eval '(set! "" #t) (interaction-environment))) (pass-if-exception "(set! 1 #t)" - exception:bad-variable + exception:bad-set! (eval '(set! 1 #t) (interaction-environment))) (pass-if-exception "(set! #t #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #t #f) (interaction-environment))) (pass-if-exception "(set! #f #t)" - exception:bad-variable + exception:bad-set! (eval '(set! #f #t) (interaction-environment))) (pass-if-exception "(set! #\\space #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #\space #f) (interaction-environment))))) @@ -974,12 +964,12 @@ (with-test-prefix "missing or extra expression" (pass-if-exception "(quote)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote) (interaction-environment))) (pass-if-exception "(quote a b)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote a b) (interaction-environment))))) @@ -1010,46 +1000,27 @@ (do ((n 0 (1+ n))) ((> n 5)) (pass-if n - (let ((cond (make-iterations-cond n))) - (while (cond))) - #t))) + (eval `(letrec ((make-iterations-cond + (lambda (n) + (lambda () + (cond ((not n) + (error "oops, condition re-tested after giving false")) + ((= 0 n) + (set! n #f) + #f) + (else + (set! n (1- n)) + #t)))))) + (let ((cond (make-iterations-cond ,n))) + (while (cond)) + #t)) + (interaction-environment))))) (pass-if "initially false" (while #f (unreachable)) #t) - (with-test-prefix "in empty environment" - - ;; an environment with no bindings at all - (define empty-environment - (make-module 1)) - - ;; these tests are 'unresolved because to work with ice-9 syncase it was - ;; necessary to drop the unquote from `do' in the implementation, and - ;; unfortunately that makes `while' depend on its evaluation environment - - (pass-if "empty body" - (throw 'unresolved) - (eval `(,while #f) - empty-environment) - #t) - - (pass-if "initially false" - (throw 'unresolved) - (eval `(,while #f - #f) - empty-environment) - #t) - - (pass-if "iterating" - (throw 'unresolved) - (let ((cond (make-iterations-cond 3))) - (eval `(,while (,cond) - 123 456) - empty-environment)) - #t)) - (with-test-prefix "iterations" (do ((n 0 (1+ n))) ((> n 5)) @@ -1063,8 +1034,9 @@ (with-test-prefix "break" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (break 1))) + (eval '(while #t + (break 1)) + (interaction-environment))) (with-test-prefix "from cond" (pass-if "first" @@ -1135,8 +1107,9 @@ (with-test-prefix "continue" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (continue 1))) + (eval '(while #t + (continue 1)) + (interaction-environment))) (with-test-prefix "from cond" (do ((n 0 (1+ n))) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index caace7fd4..26efe8580 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -2,25 +2,38 @@ ;;;; ;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, +;;;; 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 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 +;;;; 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-threads) :use-module (ice-9 threads) :use-module (test-suite lib)) +(define (asyncs-still-working?) + (let ((a #f)) + (system-async-mark (lambda () + (set! a #t))) + ;; The point of the following (equal? ...) is to go through + ;; primitive code (scm_equal_p) that includes a SCM_TICK call and + ;; hence gives system asyncs a chance to run. Of course the + ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the + ;; near future we may be using the VM instead of the traditional + ;; compiler, and then we will still want asyncs-still-working? to + ;; work. (The VM should probably have SCM_TICK calls too, but + ;; let's not rely on that here.) + (equal? '(a b c) '(a b c)) + a)) (if (provided? 'threads) (begin @@ -101,6 +114,9 @@ (with-test-prefix "n-for-each-par-map" + (pass-if "asyncs are still working 2" + (asyncs-still-working?)) + (pass-if "0 in limit 10" (n-for-each-par-map 10 noop noop '()) #t) @@ -143,12 +159,18 @@ (with-test-prefix "lock-mutex" + (pass-if "asyncs are still working 3" + (asyncs-still-working?)) + (pass-if "timed locking fails if timeout exceeded" (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (lock-mutex m (+ (current-time) 1))))) (not (join-thread t))))) + (pass-if "asyncs are still working 6" + (asyncs-still-working?)) + (pass-if "timed locking succeeds if mutex unlocked within timeout" (let* ((m (make-mutex)) (c (make-condition-variable)) @@ -164,7 +186,12 @@ (unlock-mutex cm) (sleep 1) (unlock-mutex m) - (join-thread t))))) + (join-thread t)))) + + (pass-if "asyncs are still working 7" + (asyncs-still-working?)) + + ) ;; ;; timed mutex unlocking @@ -172,12 +199,18 @@ (with-test-prefix "unlock-mutex" + (pass-if "asyncs are still working 5" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #f if timeout exceeded" (let ((m (make-mutex)) (c (make-condition-variable))) (lock-mutex m) (not (unlock-mutex m c (current-time))))) + (pass-if "asyncs are still working 4" + (asyncs-still-working?)) + (pass-if "timed unlocking returns #t if condition signaled" (let ((m1 (make-mutex)) (m2 (make-mutex)) @@ -226,7 +259,36 @@ (pass-if "timed joining succeeds if thread exits within timeout" (let ((t (begin-thread (begin (sleep 1) #t)))) - (join-thread t (+ (current-time) 2))))) + (join-thread t (+ (current-time) 2)))) + + (pass-if "asyncs are still working 1" + (asyncs-still-working?)) + + ;; scm_join_thread_timed has a SCM_TICK in the middle of it, + ;; to allow asyncs to run (including signal delivery). We + ;; used to have a bug whereby if the joined thread terminated + ;; at the same time as the joining thread is in this SCM_TICK, + ;; scm_join_thread_timed would not notice and would hang + ;; forever. So in this test we are setting up the following + ;; sequence of events. + ;; T=0 other thread is created and starts running + ;; T=2 main thread sets up an async that will sleep for 10 seconds + ;; T=2 main thread calls join-thread, which will... + ;; T=2 ...call the async, which starts sleeping + ;; T=5 other thread finishes its work and terminates + ;; T=7 async completes, main thread continues inside join-thread. + (pass-if "don't hang when joined thread terminates in SCM_TICK" + (let ((other-thread (make-thread sleep 5))) + (letrec ((delay-count 10) + (aproc (lambda () + (set! delay-count (- delay-count 1)) + (if (zero? delay-count) + (sleep 5) + (system-async-mark aproc))))) + (sleep 2) + (system-async-mark aproc) + (join-thread other-thread))) + #t)) ;; ;; thread cancellation diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index d5639eb68..da7a48c04 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -3,20 +3,19 @@ ;;;; ;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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-time) #:use-module (test-suite lib) @@ -203,6 +202,11 @@ (string=? (strftime "%Z" t) "ZOW"))) + (pass-if "strftime passes wide characters" + (let ((t (localtime (current-time)))) + (string=? (substring (strftime "\u0100%Z" t) 0 1) + "\u0100"))) + (with-test-prefix "C99 %z format" ;; %z here is quite possibly affected by the same tm:gmtoff vs current diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test new file mode 100644 index 000000000..ee5e4d352 --- /dev/null +++ b/test-suite/tests/tree-il.test @@ -0,0 +1,591 @@ +;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- +;;;; Andy Wingo <wingo@pobox.com> --- May 2009 +;;;; +;;;; 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 tree-il) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system base pmatch) + #:use-module (system base message) + #:use-module (language tree-il) + #:use-module (language glil) + #:use-module (srfi srfi-13)) + +;; Of course, the GLIL that is emitted depends on the source info of the +;; input. Here we're not concerned about that, so we strip source +;; information from the incoming tree-il. + +(define (strip-source x) + (post-order! (lambda (x) (set! (tree-il-src x) #f)) + x)) + +(define-syntax assert-scheme->glil + (syntax-rules () + ((_ in out) + (let ((tree-il (strip-source + (compile 'in #:from 'scheme #:to 'tree-il)))) + (pass-if 'in + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil + (syntax-rules () + ((_ in out) + (pass-if 'in + (let ((tree-il (strip-source (parse-tree-il 'in)))) + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil/pmatch + (syntax-rules () + ((_ in pat test ...) + (let ((exp 'in)) + (pass-if 'in + (let ((glil (unparse-glil + (compile (strip-source (parse-tree-il exp)) + #:from 'tree-il #:to 'glil)))) + (pmatch glil + (pat (guard test ...) #t) + (else #f)))))))) + +(with-test-prefix "void" + (assert-tree-il->glil + (void) + (program 0 0 0 () (void) (call return 1))) + (assert-tree-il->glil + (begin (void) (const 1)) + (program 0 0 0 () (const 1) (call return 1))) + (assert-tree-il->glil + (apply (primitive +) (void) (const 1)) + (program 0 0 0 () (void) (call add1 1) (call return 1)))) + +(with-test-prefix "application" + (assert-tree-il->glil + (apply (toplevel foo) (const 1)) + (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) + (assert-tree-il->glil/pmatch + (begin (apply (toplevel foo) (const 1)) (void)) + (program 0 0 0 () (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) + (call drop 1) (branch br ,l2) + (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) (apply (toplevel bar))) + (program 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) + (call goto/args 1)))) + +(with-test-prefix "conditional" + (assert-tree-il->glil/pmatch + (if (const #t) (const 1) (const 2)) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (call return 1) + (label ,l2) (const 2) (call return 1)) + (eq? l1 l2)) + + (assert-tree-il->glil/pmatch + (begin (if (const #t) (const 1) (const 2)) (const #f)) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) + (label ,l3) (label ,l4) (const #f) (call return 1)) + (eq? l1 l3) (eq? l2 l4)) + + (assert-tree-il->glil/pmatch + (apply (primitive null?) (if (const #t) (const 1) (const 2))) + (program 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (branch br ,l2) + (label ,l3) (const 2) (label ,l4) + (call null? 1) (call return 1)) + (eq? l1 l3) (eq? l2 l4))) + +(with-test-prefix "primitive-ref" + (assert-tree-il->glil + (primitive +) + (program 0 0 0 () (toplevel ref +) (call return 1))) + + (assert-tree-il->glil + (begin (primitive +) (const #f)) + (program 0 0 0 () (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (primitive +)) + (program 0 0 0 () (toplevel ref +) (call null? 1) + (call return 1)))) + +(with-test-prefix "lexical refs" + (assert-tree-il->glil + (let (x) (y) ((const 1)) (lexical x y)) + (program 0 0 1 () + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) + (program 0 0 1 () + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (const #f) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) + (program 0 0 1 () + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "lexical sets" + (assert-tree-il->glil + ;; unreferenced sets may be optimized away -- make sure they are ref'd + (let (x) (y) ((const 1)) + (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) + (program 0 0 1 () + (const 1) (bind (x #t 0)) (lexical #t #t box 0) + (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) + (void) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) + (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) + (lexical x y))) + (program 0 0 1 () + (const 1) (bind (x #t 0)) (lexical #t #t box 0) + (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) + (lexical #t #t ref 0) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) + (apply (primitive null?) + (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) + (program 0 0 1 () + (const 1) (bind (x #t 0)) (lexical #t #t box 0) + (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) + (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "module refs" + (assert-tree-il->glil + (@ (foo) bar) + (program 0 0 0 () + (module public ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@ (foo) bar) (const #f)) + (program 0 0 0 () + (module public ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@ (foo) bar)) + (program 0 0 0 () + (module public ref (foo) bar) + (call null? 1) (call return 1))) + + (assert-tree-il->glil + (@@ (foo) bar) + (program 0 0 0 () + (module private ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@@ (foo) bar) (const #f)) + (program 0 0 0 () + (module private ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@@ (foo) bar)) + (program 0 0 0 () + (module private ref (foo) bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "module sets" + (assert-tree-il->glil + (set! (@ (foo) bar) (const 2)) + (program 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 () + (const 2) (module public set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@ (foo) bar) (const 2))) + (program 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call null? 1) (call return 1))) + + (assert-tree-il->glil + (set! (@@ (foo) bar) (const 2)) + (program 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 () + (const 2) (module private set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) + (program 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel refs" + (assert-tree-il->glil + (toplevel bar) + (program 0 0 0 () + (toplevel ref bar) + (call return 1))) + + (assert-tree-il->glil + (begin (toplevel bar) (const #f)) + (program 0 0 0 () + (toplevel ref bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (toplevel bar)) + (program 0 0 0 () + (toplevel ref bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel sets" + (assert-tree-il->glil + (set! (toplevel bar) (const 2)) + (program 0 0 0 () + (const 2) (toplevel set bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (toplevel bar) (const 2)) (const #f)) + (program 0 0 0 () + (const 2) (toplevel set bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (toplevel bar) (const 2))) + (program 0 0 0 () + (const 2) (toplevel set bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel defines" + (assert-tree-il->glil + (define bar (const 2)) + (program 0 0 0 () + (const 2) (toplevel define bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (define bar (const 2)) (const #f)) + (program 0 0 0 () + (const 2) (toplevel define bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (define bar (const 2))) + (program 0 0 0 () + (const 2) (toplevel define bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "constants" + (assert-tree-il->glil + (const 2) + (program 0 0 0 () + (const 2) (call return 1))) + + (assert-tree-il->glil + (begin (const 2) (const #f)) + (program 0 0 0 () + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (const 2)) + (program 0 0 0 () + (const 2) (call null? 1) (call return 1)))) + +(with-test-prefix "lambda" + (assert-tree-il->glil + (lambda (x) (y) () (const 2)) + (program 0 0 0 () + (program 1 0 0 () + (bind (x #f 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x x1) (y y1) () (const 2)) + (program 0 0 0 () + (program 2 0 0 () + (bind (x #f 0) (x1 #f 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda x y () (const 2)) + (program 0 0 0 () + (program 1 1 0 () + (bind (x #f 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (const 2)) + (program 0 0 0 () + (program 2 1 0 () + (bind (x #f 0) (x1 #f 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x y)) + (program 0 0 0 () + (program 2 1 0 () + (bind (x #f 0) (x1 #f 1)) + (lexical #t #f ref 0) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x1 y1)) + (program 0 0 0 () + (program 2 1 0 () + (bind (x #f 0) (x1 #f 1)) + (lexical #t #f ref 1) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) + (program 0 0 0 () + (program 1 0 0 () + (bind (x #f 0)) + (program 1 0 0 () + (bind (y #f 0)) + (lexical #f #f ref 0) (call return 1)) + (lexical #t #f ref 0) + (call vector 1) + (call make-closure 2) + (call return 1)) + (call return 1)))) + +(with-test-prefix "sequence" + (assert-tree-il->glil + (begin (begin (const 2) (const #f)) (const #t)) + (program 0 0 0 () + (const #t) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (begin (const #f) (const 2))) + (program 0 0 0 () + (const 2) (call null? 1) (call return 1)))) + +;; FIXME: binding info for or-hacked locals might bork the disassembler, +;; and could be tightened in any case +(with-test-prefix "the or hack" + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical a b)))) + (program 0 0 1 () + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (branch br-if-not ,l1) + (lexical #t #f ref 0) (call return 1) + (label ,l2) + (const 2) (bind (a #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (call return 1) + (unbind) + (unbind)) + (eq? l1 l2)) + + ;; second bound var is unreferenced + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical x y)))) + (program 0 0 1 () + (const 1) (bind (x #f 0)) (lexical #t #f set 0) + (lexical #t #f ref 0) (branch br-if-not ,l1) + (lexical #t #f ref 0) (call return 1) + (label ,l2) + (lexical #t #f ref 0) (call return 1) + (unbind)) + (eq? l1 l2))) + +(with-test-prefix "apply" + (assert-tree-il->glil + (apply (primitive @apply) (toplevel foo) (toplevel bar)) + (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) + (program 0 0 0 () + (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) + (program 0 0 0 () + (toplevel ref foo) + (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) + (call goto/args 1)))) + +(with-test-prefix "call/cc" + (assert-tree-il->glil + (apply (primitive @call-with-current-continuation) (toplevel foo)) + (program 0 0 0 () (toplevel ref foo) (call goto/cc 1))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) + (program 0 0 0 () + (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) + (apply (toplevel @call-with-current-continuation) (toplevel bar))) + (program 0 0 0 () + (toplevel ref foo) + (toplevel ref bar) (call call/cc 1) + (call goto/args 1)))) + + +(with-test-prefix "tree-il-fold" + + (pass-if "empty tree" + (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark))) + (and (eq? mark + (tree-il-fold (lambda (x y) (set! leaf? #t) y) + (lambda (x y) (set! down? #t) y) + (lambda (x y) (set! up? #t) y) + mark + '())) + (not leaf?) + (not up?) + (not down?)))) + + (pass-if "lambda and application" + (let* ((leaves '()) (ups '()) (downs '()) + (result (tree-il-fold (lambda (x y) + (set! leaves (cons x leaves)) + (1+ y)) + (lambda (x y) + (set! downs (cons x downs)) + (1+ y)) + (lambda (x y) + (set! ups (cons x ups)) + (1+ y)) + 0 + (parse-tree-il + '(lambda (x y) (x1 y1) + (apply (toplevel +) + (lexical x x1) + (lexical y y1))))))) + (and (equal? (map strip-source leaves) + (list (make-lexical-ref #f 'y 'y1) + (make-lexical-ref #f 'x 'x1) + (make-toplevel-ref #f '+))) + (= (length downs) 2) + (equal? (reverse (map strip-source ups)) + (map strip-source downs)))))) + + +;;; +;;; Warnings. +;;; + +;; Make sure we get English messages. +(setlocale LC_ALL "C") + +(define (call-with-warnings thunk) + (let ((port (open-output-string))) + (with-fluid* *current-warning-port* port + thunk) + (let ((warnings (get-output-string port))) + (string-tokenize warnings + (char-set-complement (char-set #\newline)))))) + +(define %opts-w-unused + '(#:warnings (unused-variable))) + + +(with-test-prefix "warnings" + + (pass-if "unknown warning type" + (let ((w (call-with-warnings + (lambda () + (compile #t #:opts '(#:warnings (does-not-exist))))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unknown warning"))))) + + (with-test-prefix "unused-variable" + + (pass-if "quiet" + (null? (call-with-warnings + (lambda () + (compile '(lambda (x y) (+ x y)) + #:opts %opts-w-unused))))) + + (pass-if "let/unused" + (let ((w (call-with-warnings + (lambda () + (compile '(lambda (x) + (let ((y (+ x 2))) + x)) + #:opts %opts-w-unused))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unused variable `y'"))))) + + (pass-if "shadowed variable" + (let ((w (call-with-warnings + (lambda () + (compile '(lambda (x) + (let ((y x)) + (let ((y (+ x 2))) + (+ x y)))) + #:opts %opts-w-unused))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unused variable `y'"))))) + + (pass-if "letrec" + (null? (call-with-warnings + (lambda () + (compile '(lambda () + (letrec ((x (lambda () (y))) + (y (lambda () (x)))) + y)) + #:opts %opts-w-unused))))) + + (pass-if "unused argument" + ;; Unused arguments should not be reported. + (null? (call-with-warnings + (lambda () + (compile '(lambda (x y z) #t) + #:opts %opts-w-unused))))))) diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test index 576a9286c..5d584e86e 100644 --- a/test-suite/tests/unif.test +++ b/test-suite/tests/unif.test @@ -1,11 +1,11 @@ ;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- ;;;; -;;;; Copyright 2004, 2006 Free Software Foundation, Inc. +;;;; Copyright 2004, 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 2.1 of the License, or (at your option) any later version. +;;;; 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 @@ -17,7 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-unif) - #:use-module (test-suite lib)) + #:use-module (test-suite lib)) ;;; ;;; array? diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test index 738a0828a..22434bfc6 100644 --- a/test-suite/tests/vectors.test +++ b/test-suite/tests/vectors.test @@ -2,20 +2,19 @@ ;;;; ;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. ;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; This 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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 vectors) :use-module (test-suite lib)) diff --git a/test-suite/tests/version.test b/test-suite/tests/version.test index b2a491950..5b7acc93d 100644 --- a/test-suite/tests/version.test +++ b/test-suite/tests/version.test @@ -3,20 +3,19 @@ ;;;; ;;;; 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 -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. +;;;; 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 program is distributed in the hope that it will be useful, +;;;; 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 General Public License for more details. +;;;; 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 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 +;;;; 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)) diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test index 7bb77b07c..b469887c2 100644 --- a/test-suite/tests/weaks.test +++ b/test-suite/tests/weaks.test @@ -4,7 +4,7 @@ ;;;; 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. +;;;; 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 |