diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 34e578e51..41dda9882 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -19,6 +19,7 @@ (define-module (test-suite lib) :use-module (ice-9 stack-catch) :use-module (ice-9 regex) + :autoload (srfi srfi-1) (append-map) :export ( ;; Exceptions which are commonly being tested for. @@ -48,8 +49,8 @@ ;; Using the debugging evaluator. with-debugging-evaluator with-debugging-evaluator* -;; Using a given locale -with-locale with-locale* + ;; Using a given locale + with-locale with-locale* with-latin1-locale with-latin1-locale* ;; Reporting results in various ways. register-reporter unregister-reporter reporter-registered? @@ -472,6 +473,33 @@ with-locale with-locale* ((_ loc body ...) (with-locale* loc (lambda () body ...))))) +;;; Try out several ISO-8859-1 locales and run THUNK under the one that works +;;; (if any). +(define (with-latin1-locale* thunk) + (define %locales + (append-map (lambda (name) + (list (string-append name ".ISO-8859-1") + (string-append name ".iso88591") + (string-append name ".ISO8859-1"))) + '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US" + "fr_FR" "pt_PT" "nl_NL" "sv_SE"))) + + (let loop ((locales %locales)) + (if (null? locales) + (throw 'unresolved) + (catch 'unresolved + (lambda () + (with-locale* (car locales) thunk)) + (lambda (key . args) + (loop (cdr locales))))))) + +;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none +;;; was found. +(define-syntax with-latin1-locale + (syntax-rules () + ((_ body ...) + (with-latin1-locale* (lambda () body ...))))) + ;;;; REPORTERS ;;;; diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 35bdb4795..3f68c81f6 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -377,39 +377,6 @@ (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") @@ -428,12 +395,11 @@ (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)))))))) + (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") @@ -492,12 +458,11 @@ (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))))))) + (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