summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-06-22 13:18:02 +0200
committerAndy Wingo <wingo@pobox.com>2012-06-22 13:18:02 +0200
commit0dd7c5407599b65a1a3da4b9bd8feccc715b51f7 (patch)
tree7e54c75087c5ea3f876bcb54cc49c70ec87ae0b5 /test-suite/tests
parent747747ee06ac64c224b91e8f64f810a1159c1675 (diff)
parent2874f66017b7bfae256e85af84689d00ecc418ab (diff)
downloadguile-0dd7c5407599b65a1a3da4b9bd8feccc715b51f7.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/deprecated.c libguile/ports.c libguile/ports.h libguile/strports.c test-suite/tests/cse.test
Diffstat (limited to 'test-suite/tests')
-rw-r--r--test-suite/tests/coverage.test12
-rw-r--r--test-suite/tests/cse.test17
-rw-r--r--test-suite/tests/foreign.test24
-rw-r--r--test-suite/tests/ftw.test7
-rw-r--r--test-suite/tests/ports.test66
-rw-r--r--test-suite/tests/r6rs-ports.test11
-rw-r--r--test-suite/tests/srfi-6.test26
7 files changed, 147 insertions, 16 deletions
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 4ac404344..b29de0f20 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 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
@@ -216,6 +216,16 @@
(= 3 result)
(not (procedure-execution-count data proc))))))
+ (pass-if "applicable struct"
+ (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
+ (proc (lambda args (length args)))
+ (b (make-struct <box> 0 proc)))
+ (let-values (((data result)
+ (with-code-coverage %test-vm b)))
+ (and (coverage-data? data)
+ (= 0 result)
+ (= (procedure-execution-count data proc) 1)))))
+
(pass-if "called from C"
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
;; test makes sure that they get to use %TEST-VM.
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index d09dc53db..154cc0614 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -266,4 +266,19 @@
(let ((x (car y)))
(cons x (car y)))
(let (x) (_) ((primcall car (toplevel y)))
- (primcall cons (lexical x _) (lexical x _)))))
+ (primcall cons (lexical x _) (lexical x _))))
+
+ ;; Dominating expressions only provide predicates when evaluated in
+ ;; test context.
+ (pass-if-cse
+ (let ((t (car x)))
+ (if (car x)
+ 'one
+ 'two))
+ ;; Actually this one should reduce in other ways, but this is the
+ ;; current reduction:
+ (seq
+ (primcall car (toplevel x))
+ (if (primcall car (toplevel x))
+ (const one)
+ (const two)))))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 47686eebd..7c5ecd62f 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -25,6 +25,7 @@
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
#:use-module (test-suite lib))
@@ -160,6 +161,29 @@
(with-test-prefix "pointer<->string"
+ (pass-if-exception "%default-port-conversion-strategy is error"
+ exception:encoding-error
+ (let ((s "χαοσ"))
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (string->pointer s "ISO-8859-1"))))
+
+ (pass-if "%default-port-conversion-strategy is escape"
+ (let ((s "teĥniko"))
+ (equal? (with-fluids ((%default-port-conversion-strategy 'escape))
+ (pointer->string (string->pointer s "ISO-8859-1")))
+ (format #f "te\\u~4,'0xniko"
+ (char->integer #\ĥ)))))
+
+ (pass-if "%default-port-conversion-strategy is substitute"
+ (let ((s "teĥniko")
+ (member (negate (negate member))))
+ (member (with-fluids ((%default-port-conversion-strategy 'substitute))
+ (pointer->string (string->pointer s "ISO-8859-1")))
+ '("te?niko"
+
+ ;; This form is found on FreeBSD 8.2 and Darwin 10.8.0.
+ "te^hniko"))))
+
(pass-if "bijection"
(let ((s "hello, world"))
(string=? s (pointer->string (string->pointer s)))))
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index 805c779bf..33537d04b 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -310,14 +310,17 @@
(pass-if "test-suite"
(let ((select? (cut string-suffix? ".test" <>)))
(match (scandir (string-append %test-dir "/tests") select?)
- (("." ".." "00-initial-env.test" (? select?) ...)
+ (("00-initial-env.test" (? select?) ...)
#t))))
(pass-if "flat file"
(not (scandir (string-append %test-dir "/Makefile.am"))))
(pass-if "EACCES"
- (not (scandir "/.does-not-exist."))))
+ (not (scandir "/.does-not-exist.")))
+
+ (pass-if "no select"
+ (null? (scandir %test-dir (lambda (_) #f)))))
;;; Local Variables:
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 2aec1f0b2..613d2693f 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -58,6 +58,34 @@
string))
+
+(with-test-prefix "%default-port-conversion-strategy"
+
+ (pass-if "initial value"
+ (eq? 'substitute (fluid-ref %default-port-conversion-strategy)))
+
+ (pass-if "file port"
+ (let ((strategies '(error substitute escape)))
+ (equal? (map (lambda (s)
+ (with-fluids ((%default-port-conversion-strategy s))
+ (call-with-output-file "/dev/null"
+ (lambda (p)
+ (port-conversion-strategy p)))))
+ strategies)
+ strategies)))
+
+ (pass-if "(set-port-conversion-strategy! #f sym)"
+ (begin
+ (set-port-conversion-strategy! #f 'error)
+ (and (eq? (fluid-ref %default-port-conversion-strategy) 'error)
+ (begin
+ (set-port-conversion-strategy! #f 'substitute)
+ (eq? (fluid-ref %default-port-conversion-strategy)
+ 'substitute)))))
+
+)
+
+
;;;; Normal file ports.
;;; Write out an s-expression, and read it back.
@@ -385,6 +413,22 @@
(pass-if "output check"
(string=? text result)))
+ (pass-if "encoding failure leads to exception"
+ ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
+ ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (let ((p (open-input-string "λ"))) ; raise an exception
+ #f)))
+ (lambda (key . rest)
+ #t)
+ (lambda (key . rest)
+ ;; At this point, the port-table mutex used to be still held,
+ ;; hence the deadlock. This situation would occur when trying
+ ;; to print a backtrace, for instance.
+ (input-port? (open-input-string "foo")))))
+
(pass-if "%default-port-encoding is honored"
(let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
(equal? (map (lambda (e)
@@ -396,6 +440,20 @@
encodings)
encodings)))
+ (pass-if "%default-port-conversion-strategy is honored"
+ (let ((strategies '(error substitute escape)))
+ (equal? (map (lambda (s)
+ (with-fluids ((%default-port-conversion-strategy s))
+ (call-with-output-string
+ (lambda (p)
+ (and (eq? s (port-conversion-strategy p))
+ (begin
+ (set-port-conversion-strategy! p s)
+ (display (port-conversion-strategy p)
+ p)))))))
+ strategies)
+ (map symbol->string strategies))))
+
(pass-if "suitable encoding [latin-1]"
(let ((str "hello, world"))
(with-fluids ((%default-port-encoding "ISO-8859-1"))
@@ -412,15 +470,17 @@
(lambda ()
(display str)))))))
- (pass-if "wrong encoding"
+ (pass-if "wrong encoding, error"
(let ((str "ĉu bone?"))
(catch 'encoding-error
(lambda ()
;; Latin-1 cannot represent ‘ĉ’.
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (with-fluids ((%default-port-encoding "ISO-8859-1")
+ (%default-port-conversion-strategy 'error))
(with-output-to-string
(lambda ()
- (display str)))))
+ (display str))))
+ #f) ; so the test really fails here
(lambda (key subr message errno port chr)
(and (eq? chr #\ĉ)
(string? (strerror errno)))))))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index f3e8c2c5d..46da67f59 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -306,10 +306,12 @@
(bv (string->utf16 str)))
(catch 'decoding-error
(lambda ()
- (with-fluids ((%default-port-encoding "UTF-32"))
+ (with-fluids ((%default-port-encoding "UTF-32")
+ (%default-port-conversion-strategy 'error))
(call-with-output-string
(lambda (port)
- (put-bytevector port bv)))))
+ (put-bytevector port bv)))
+ #f)) ; fail if we reach this point
(lambda (key subr message errno port)
(string? (strerror errno)))))))
@@ -662,7 +664,8 @@
(tp (transcoded-port b t)))
(guard (c ((i/o-decoding-error? c)
(eq? (i/o-error-port c) tp)))
- (get-line tp))))
+ (get-line tp)
+ #f))) ; fail if we reach this point
(pass-if "transcoded-port [error handling mode = replace]"
(let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test
index 68fc70dff..bd9167cca 100644
--- a/test-suite/tests/srfi-6.test
+++ b/test-suite/tests/srfi-6.test
@@ -1,6 +1,6 @@
;;;; srfi-6.test --- test suite for SRFI-6 -*- scheme -*-
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2012 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
@@ -37,13 +37,21 @@
(char=? #\y (read-char port))
(char=? #\z (read-char port))
(eof-object? (read-char port)))))
-
+
+ (pass-if "read-char, Unicode"
+ ;; String ports should always be Unicode-capable.
+ ;; See <http://bugs.gnu.org/11197>.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (let ((port (open-input-string "λμ")))
+ (and (char=? #\λ (read-char port))
+ (char=? #\μ (read-char port))))))
+
(with-test-prefix "unread-char"
(pass-if "one char"
(let ((port (open-input-string "")))
- (unread-char #\x port)
- (and (char=? #\x (read-char port))
+ (unread-char #\x port)
+ (and (char=? #\x (read-char port))
(eof-object? (read-char port)))))
(pass-if "after eof"
@@ -75,7 +83,15 @@
(let ((port (open-output-string)))
(display "xyz" port)
(string=? "xyz" (get-output-string port))))
-
+
+ (pass-if "λ"
+ ;; Writing to an output string should always work.
+ ;; See <http://bugs.gnu.org/11197>.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (let ((port (open-output-string)))
+ (display "λ" port)
+ (string=? "λ" (get-output-string port)))))
+
(pass-if "seek"
(let ((port (open-output-string)))
(display "abcdef" port)