-;;;; bytevectors.test --- Exercise the R6RS bytevector API.
+;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;; Ludovic Courtès
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
+;;;; 2014 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
(define-module (test-bytevector)
:use-module (test-suite lib)
:use-module (system base compile)
- :use-module (rnrs bytevector))
+ :use-module (rnrs bytevectors))
;;; 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) ...))))
-
-
\f
(with-test-prefix/c&e "2.2 General Operations"
(and (bytevector=? (make-bytevector 20 7)
(make-bytevector 20 7))
(not (bytevector=? (make-bytevector 20 7)
- (make-bytevector 20 0))))))
+ (make-bytevector 20 0)))))
+
+ (pass-if "bytevector-copy! overlapping"
+ ;; See <http://debbugs.gnu.org/10070>.
+ (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))
+ (bytevector-copy! b 0 b 3 4)
+ (bytevector->u8-list b)
+ (bytevector=? b #vu8(1 2 3 1 2 3 4 8)))))
\f
(with-test-prefix/c&e "2.3 Operations on Bytes and Octets"
(pass-if-exception "bytevector->sint-list [out-of-range]"
exception:out-of-range
- (bytevector->sint-list (make-bytevector 6) (endianness little) 8))
+ (bytevector->sint-list (make-bytevector 6) (endianness little) -1))
- (pass-if "bytevector->sint-list [off-by-one]"
- (equal? (bytevector->sint-list (make-bytevector 31 #xff)
- (endianness little) 8)
- '(-1 -1 -1)))
+ (pass-if-exception "bytevector->uint-list [out-of-range]"
+ exception:out-of-range
+ (bytevector->uint-list (make-bytevector 6) (endianness little) 0))
+
+ (pass-if-exception "bytevector->uint-list [word size doesn't divide length]"
+ exception:wrong-type-arg
+ (bytevector->uint-list (make-bytevector 6) (endianness little) 4))
(pass-if "{sint,uint}-list->bytevector"
(let ((b1 (sint-list->bytevector '(513 -253 513 513)
\f
(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations"
+ (pass-if "single, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 128 63) b)))
+
+ (pass-if "single, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 128 0 0) b)))
+
(pass-if "bytevector-ieee-single-native-{ref,set!}"
(let ((b (make-bytevector 4))
(number 3.00))
(equal? (bytevector-ieee-single-ref b 1 (endianness little))
(bytevector-ieee-single-ref b 5 (endianness big)))))
+ (pass-if "double, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 0 0 0 0 240 63) b)))
+
+ (pass-if "double, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 240 0 0 0 0 0 0) b)))
+
(pass-if "bytevector-ieee-double-native-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
(bytevector-ieee-double-ref b 8 (endianness big))))))
\f
-(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")
+(when (defined? 'setlocale)
+ (setlocale LC_ALL "C"))
(with-test-prefix "2.9 Operations on Strings"
(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))))))))
+ (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")
(bytevector->uint-list utf32
(endianness big) 4))))))
+ (pass-if "string->utf32 [Greek]"
+ (let* ((str "Ἄνεμοι")
+ (utf32 (string->utf32 str)))
+ (and (bytevector? utf32)
+ (equal? (bytevector->uint-list utf32 (endianness big) 4)
+ '(#x1f0c #x3bd #x3b5 #x3bc #x3bf #x3b9)))))
+
(pass-if "string->utf32 [little]"
(let* ((str "hello, world")
(utf32 (string->utf32 str (endianness little))))
(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)))))))
+ (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
(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))
(with-input-from-string "#vu8(0 256)" read)))
\f
-(with-test-prefix "Generalized Vectors"
+(with-test-prefix "Arrays"
- (pass-if "generalized-vector?"
- (generalized-vector? #vu8(1 2 3)))
+ (pass-if "array?"
+ (array? #vu8(1 2 3)))
- (pass-if "generalized-vector-length"
+ (pass-if "array-length"
(equal? (iota 16)
- (map generalized-vector-length
+ (map array-length
(map make-bytevector (iota 16)))))
- (pass-if "generalized-vector-ref"
+ (pass-if "array-ref"
(let ((bv #vu8(255 127)))
- (and (= 255 (generalized-vector-ref bv 0))
- (= 127 (generalized-vector-ref bv 1)))))
+ (and (= 255 (array-ref bv 0))
+ (= 127 (array-ref bv 1)))))
- (pass-if-exception "generalized-vector-ref [index out-of-range]"
+ (pass-if-exception "array-ref [index out-of-range]"
exception:out-of-range
(let ((bv #vu8(1 2)))
- (generalized-vector-ref bv 2)))
+ (array-ref bv 2)))
- (pass-if "generalized-vector-set!"
+ (pass-if "array-set!"
(let ((bv (make-bytevector 2)))
- (generalized-vector-set! bv 0 255)
- (generalized-vector-set! bv 1 77)
+ (array-set! bv 255 0)
+ (array-set! bv 77 1)
(equal? '(255 77)
(bytevector->u8-list bv))))
- (pass-if-exception "generalized-vector-set! [index out-of-range]"
+ (pass-if-exception "array-set! [index out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
- (generalized-vector-set! bv 2 0)))
+ (array-set! bv 0 2)))
- (pass-if-exception "generalized-vector-set! [value out-of-range]"
+ (pass-if-exception "array-set! [value out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
- (generalized-vector-set! bv 0 256)))
+ (array-set! bv 256 0)))
(pass-if "array-type"
(eq? 'vu8 (array-type #vu8())))
(pass-if-exception "make-typed-array [out-of-range]"
exception:out-of-range
- (make-typed-array 'vu8 256 77))
+ (make-typed-array 'vu8 256 77)))
+
+\f
+(with-test-prefix "uniform-array->bytevector"
- (pass-if "uniform-array->bytevector"
+ (pass-if "bytevector"
(let ((bv #vu8(0 1 128 255)))
- (equal? bv (uniform-array->bytevector bv)))))
+ (equal? bv (uniform-array->bytevector bv))))
+
+ (pass-if "empty bitvector"
+ (let ((bv (uniform-array->bytevector (make-bitvector 0))))
+ (equal? bv #vu8())))
+
+ (pass-if "bitvector < 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector == 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector > 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector == 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 32 #t))))
+ (= (bytevector-length bv) 4)))
+ (pass-if "bitvector > 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 33 #t))))
+ (= (bytevector-length bv) 8))))
;;; Local Variables:
-;;; coding: latin-1
-;;; mode: scheme
+;;; eval: (put 'with-test-prefix/c&e 'scheme-indent-function 1)
;;; End:
HCoop / bpt / guile.git / blobdiff