diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-11-17 23:04:11 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-11-19 13:34:43 +0100 |
commit | fb032fa722d81f575169e3be5623ebb761f28da0 (patch) | |
tree | 99fc5e6be2bc6a18ee7a4aea26fcf79a665cbc3f | |
parent | 553d4bf8ea4ca1f844e9f2dd7edcc2ce4ee9fe62 (diff) | |
download | guile-fb032fa722d81f575169e3be5623ebb761f28da0.tar.gz |
Move `with-test-prefix/c&e' to `(test-suite lib)'.
* test-suite/tests/bytevectors.test (c&e, with-test-prefix/c&e): Move...
* test-suite/lib.scm: ... here.
(with-test-prefix): Rewrite using `syntax-rules'.
-rw-r--r-- | test-suite/lib.scm | 43 | ||||
-rw-r--r-- | test-suite/tests/bytevectors.test | 20 |
2 files changed, 36 insertions, 27 deletions
diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 13a268ab5..8ebcb0176 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -17,10 +17,11 @@ ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite lib) - :use-module (ice-9 stack-catch) - :use-module (ice-9 regex) - :autoload (srfi srfi-1) (append-map) - :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 @@ -45,7 +46,10 @@ 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. @@ -438,8 +442,33 @@ ;;; 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) diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 68523b741..081e4ee47 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -25,26 +25,6 @@ ;;; Some of the tests in here are examples taken from the R6RS Standard ;;; Libraries document. -(define-syntax c&e - (syntax-rules (pass-if pass-if-exception) - ((_ (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))))))) - -(define-syntax with-test-prefix/c&e - (syntax-rules () - ((_ section-name exp ...) - (with-test-prefix section-name (c&e exp) ...)))) - - (with-test-prefix/c&e "2.2 General Operations" |