diff options
author | Andy Wingo <wingo@pobox.com> | 2012-06-22 13:18:02 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-06-22 13:18:02 +0200 |
commit | 0dd7c5407599b65a1a3da4b9bd8feccc715b51f7 (patch) | |
tree | 7e54c75087c5ea3f876bcb54cc49c70ec87ae0b5 /test-suite/tests | |
parent | 747747ee06ac64c224b91e8f64f810a1159c1675 (diff) | |
parent | 2874f66017b7bfae256e85af84689d00ecc418ab (diff) | |
download | guile-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.test | 12 | ||||
-rw-r--r-- | test-suite/tests/cse.test | 17 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 24 | ||||
-rw-r--r-- | test-suite/tests/ftw.test | 7 | ||||
-rw-r--r-- | test-suite/tests/ports.test | 66 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 11 | ||||
-rw-r--r-- | test-suite/tests/srfi-6.test | 26 |
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) |