;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
+;;;; 2011 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite lib)
- :use-module (ice-9 stack-catch)
- :use-module (ice-9 regex)
- :export (
+ #:use-module (ice-9 stack-catch)
+ #:use-module (ice-9 regex)
+ #:autoload (srfi srfi-1) (append-map)
+ #:autoload (system base compile) (compile)
+ #:export (
;; Exceptions which are commonly being tested for.
+ exception:syntax-pattern-unmatched
exception:bad-variable
exception:missing-expression
exception:out-of-range exception:unbound-var
exception:numerical-overflow
exception:struct-set!-denied
exception:system-error
+ exception:encoding-error
exception:miscellaneous-error
exception:string-contains-nul
exception:read-error
+ exception:null-pointer-error
+ exception:vm-error
;; Reporting passes and failures.
run-test
pass-if-exception expect-fail-exception
;; Naming groups of tests in a regular fashion.
- with-test-prefix with-test-prefix* current-test-prefix
+ with-test-prefix
+ with-test-prefix*
+ with-test-prefix/c&e
+ current-test-prefix
format-test-name
;; Using the debugging evaluator.
with-debugging-evaluator with-debugging-evaluator*
+ ;; 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?
make-count-reporter print-counts
;;;; ("basic arithmetic" "subtraction"), and
;;;; ("multiplication").
;;;;
-;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends
+;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX appends
;;;; a new element to the current prefix:
;;;;
;;;; (with-test-prefix "arithmetic"
;;;;
;;; Define some exceptions which are commonly being tested for.
+(define exception:syntax-pattern-unmatched
+ (cons 'syntax-error "source expression failed to match any pattern"))
(define exception:bad-variable
(cons 'syntax-error "Bad variable"))
(define exception:missing-expression
(cons 'misc-error "^set! denied for field"))
(define exception:system-error
(cons 'system-error ".*"))
+(define exception:encoding-error
+ (cons 'encoding-error "(cannot convert to output locale|input (locale conversion|decoding) error)"))
(define exception:miscellaneous-error
(cons 'misc-error "^.*"))
(define exception:read-error
(cons 'read-error "^.*$"))
+(define exception:null-pointer-error
+ (cons 'null-pointer-error "^.*$"))
+(define exception:vm-error
+ (cons 'vm-error "^.*$"))
;; as per throw in scm_to_locale_stringn()
(define exception:string-contains-nul
;;;; Turn a test name into a nice human-readable string.
(define (format-test-name name)
- (call-with-output-string
- (lambda (port)
- (let loop ((name name)
- (separator ""))
- (if (pair? name)
- (begin
- (display separator port)
- (display (car name) port)
- (loop (cdr name) ": ")))))))
+ ;; Choose a Unicode-capable encoding so that the string port can contain any
+ ;; valid Unicode character.
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-output-string
+ (lambda (port)
+ (let loop ((name name)
+ (separator ""))
+ (if (pair? name)
+ (begin
+ (display separator port)
+ (display (car name) port)
+ (loop (cdr name) ": "))))))))
;;;; For a given test-name, deliver the full name including all prefixes.
(define (full-name name)
;;; The name prefix is only changed within the dynamic scope of the
;;; with-test-prefix expression. Return the value returned by the last
;;; BODY expression.
-(defmacro with-test-prefix (prefix . body)
- `(with-test-prefix* ,prefix (lambda () ,@body)))
+(define-syntax with-test-prefix
+ (syntax-rules ()
+ ((_ prefix body ...)
+ (with-test-prefix* prefix (lambda () body ...)))))
+
+(define-syntax c&e
+ (syntax-rules (pass-if pass-if-exception)
+ "Run the given tests both with the evaluator and the compiler/VM."
+ ((_ (pass-if test-name exp))
+ (begin (pass-if (string-append test-name " (eval)")
+ (primitive-eval 'exp))
+ (pass-if (string-append test-name " (compile)")
+ (compile 'exp #:to 'value #:env (current-module)))))
+ ((_ (pass-if-exception test-name exc exp))
+ (begin (pass-if-exception (string-append test-name " (eval)")
+ exc (primitive-eval 'exp))
+ (pass-if-exception (string-append test-name " (compile)")
+ exc (compile 'exp #:to 'value
+ #:env (current-module)))))))
+
+;;; (with-test-prefix/c&e PREFIX BODY ...)
+;;; Same as `with-test-prefix', but the enclosed tests are run both with
+;;; the compiler/VM and the evaluator.
+(define-syntax with-test-prefix/c&e
+ (syntax-rules ()
+ ((_ section-name exp ...)
+ (with-test-prefix section-name (c&e exp) ...))))
;;; Call THUNK using the debugging evaluator.
(define (with-debugging-evaluator* thunk)
(let ((dopts #f))
(dynamic-wind
(lambda ()
- (set! dopts (debug-options))
- (debug-enable 'debug))
+ (set! dopts (debug-options)))
thunk
(lambda ()
(debug-options dopts)))))
(define-macro (with-debugging-evaluator . body)
`(with-debugging-evaluator* (lambda () ,@body)))
+;;; Call THUNK with a given locale
+(define (with-locale* nloc thunk)
+ (let ((loc #f))
+ (dynamic-wind
+ (lambda ()
+ (if (defined? 'setlocale)
+ (begin
+ (set! loc (false-if-exception (setlocale LC_ALL)))
+ (if (or (not loc)
+ (not (false-if-exception (setlocale LC_ALL nloc))))
+ (throw 'unresolved)))
+ (throw 'unresolved)))
+ thunk
+ (lambda ()
+ (if (and (defined? 'setlocale) loc)
+ (setlocale LC_ALL loc))))))
+
+;;; Evaluate BODY... using the given locale.
+(define-syntax with-locale
+ (syntax-rules ()
+ ((_ 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 ...)))))
\f
;;;; REPORTERS
HCoop / bpt / guile.git / blobdiff