mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 03:30:22 +02:00
Code Activity

Import R6RS bytevectors and I/O ports from Guile-R6RS-Libs 0.2.

Browse source 
* README: Document dependency on GNU libunistring.

* benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add
  `benchmark/bytevectors.bm'.

* configure.in: Make sure we have libunistring; update $LIBS.

* libguile.h: Include "bytevectors.h" and "r6rs-ports.h".

* libguile/Makefile.am (libguile_la_SOURCES): Add `bytevectors.c' and
  `r6rs-ports.c'
  (DOT_X_FILES): Add `bytevectors.x' and `r6rs-ports.x'.
  (DOT_DOC_FILES): Add `bytevectors.doc' and `r6rs-ports.doc'.
  (noinst_HEADERS): Add `ieee-754.h'.
  (modinclude_HEADERS): Add `bytevectors.h' and `r6rs-ports.h'

* libguile/validate.h (SCM_VALIDATE_BYTEVECTOR): New macro.

* module/Makefile.am (SOURCES): Add $(RNRS_SOURCES).
  (RNRS_SOURCES): New variable.

* test-suite/Makefile.am (SCM_TESTS): Add `bytevectors.test' and
  `r6rs-ports.test'.
This commit is contained in:
Ludovic Courtès 2009-05-27 18:18:07 +02:00
parent 24d56127bb
commit 1ee2c72eaf
18 changed files with 4688 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

2
test-suite/Makefile.am
View file

@ -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 \

531
test-suite/tests/bytevectors.test Normal file
View file

@ -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:

455
test-suite/tests/r6rs-ports.test Normal file
View file

@ -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: