Fix bug #31081 (`lookahead-u8' returns an s8.)

[bpt/guile.git] / test-suite / tests / r6rs-ports.test

diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index c2b0755..7d80ed7 100644 (file)
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
-;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
+;;;; r6rs-ports.test --- R6RS I/O port tests.   -*- coding: iso-8859-1; -*-
 ;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
 ;;;; Ludovic Courtès
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -22,13 +22,13 @@
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-11)
   :use-module (rnrs io ports)
-  :use-module (rnrs bytevector))
+  :use-module (rnrs bytevectors))
 
 ;;; 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)
+;; Set the default encoding of future ports to be Latin-1.
+(fluid-set! %default-port-encoding #f)
 
 \f
 (with-test-prefix "7.2.5 End-of-File Object"
@@ -52,6 +52,11 @@
            (= (char->integer #\A) (get-u8 port))
            (eof-object? (get-u8 port)))))
 
+  (pass-if "lookahead-u8: result is unsigned"
+    ;; Bug #31081.
+    (let ((port (open-bytevector-input-port #vu8(255))))
+      (= (lookahead-u8 port) 255)))
+
   (pass-if "get-bytevector-n [short]"
     (let* ((port (open-input-string "GNU Guile"))
            (bv (get-bytevector-n port 4)))
@@ -185,32 +190,41 @@
       (put-u8 port 77)
       (equal? (get-u8 port) 77)))
 
+  ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
+  ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
+  ;; the bytes through, unmodified.  This is hacky, but we can't use
+  ;; "custom binary output ports" here because they're only tested
+  ;; later.
+
   (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))))))
+    (with-latin1-locale
+     (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))))))
+    (with-latin1-locale
+     (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)))))
+    (with-latin1-locale
+     (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
@@ -219,7 +233,30 @@
            (port (%make-void-port "w")))
 
       (close-port port)
-      (put-bytevector port bv))))
+      (put-bytevector port bv)))
+
+  (pass-if "put-bytevector with UTF-16 string port"
+    (let* ((str "hello, world")
+           (bv  (string->utf16 str)))
+      (equal? str
+              (with-fluids ((%default-port-encoding "UTF-16BE"))
+                (call-with-output-string
+                  (lambda (port)
+                    (put-bytevector port bv)))))))
+
+  (pass-if "put-bytevector with wrong-encoding string port"
+    (let* ((str "hello, world")
+           (bv  (string->utf16 str)))
+      (catch 'encoding-error
+        (lambda ()
+          (with-fluids ((%default-port-encoding "UTF-32"))
+            (call-with-output-string
+              (lambda (port)
+                (put-bytevector port bv)))))
+        (lambda (key subr message errno from to faulty-bv)
+          (and (bytevector=? faulty-bv bv)
+               (string=? to "UTF-32")
+               (string? (strerror errno))))))))
 
 \f
 (with-test-prefix "7.2.7 Input Ports"
@@ -452,8 +489,6 @@
            (not eof?)
            (bytevector=? sink source)))))
 
-
 ;;; Local Variables:
-;;; coding: latin-1
 ;;; mode: scheme
 ;;; End: