diff options
Diffstat (limited to 'test-suite')
| -rw-r--r-- | test-suite/Makefile.am | 2 | ||||
| -rw-r--r-- | test-suite/tests/bytevectors.test | 531 | ||||
| -rw-r--r-- | test-suite/tests/r6rs-ports.test | 455 |
3 files changed, 988 insertions, 0 deletions
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3854d4ab1..0b986d4a2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \ tests/arbiters.test \ tests/asm-to-bytecode.test \ tests/bit-operations.test \ + tests/bytevectors.test \ tests/c-api.test \ tests/chars.test \ tests/common-list.test \ @@ -62,6 +63,7 @@ SCM_TESTS = tests/alist.test \ tests/q.test \ tests/r4rs.test \ tests/r5rs_pitfall.test \ + tests/r6rs-ports.test \ tests/ramap.test \ tests/reader.test \ tests/receive.test \ diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test new file mode 100644 index 000000000..b2ae65c1f --- /dev/null +++ b/test-suite/tests/bytevectors.test @@ -0,0 +1,531 @@ +;;;; 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 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-bytevector) + :use-module (test-suite lib) + :use-module (rnrs bytevector)) + +;;; Some of the tests in here are examples taken from the R6RS Standard +;;; Libraries document. + + +(with-test-prefix "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 "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))))) + + +(with-test-prefix "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 "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 "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 "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 "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))))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test new file mode 100644 index 000000000..204f37144 --- /dev/null +++ b/test-suite/tests/r6rs-ports.test @@ -0,0 +1,455 @@ +;;;; 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 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(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. + + +(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) + 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: |