summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-11-17 23:04:11 +0100
committerLudovic Courtès <ludo@gnu.org>2010-11-19 13:34:43 +0100
commitfb032fa722d81f575169e3be5623ebb761f28da0 (patch)
tree99fc5e6be2bc6a18ee7a4aea26fcf79a665cbc3f
parent553d4bf8ea4ca1f844e9f2dd7edcc2ce4ee9fe62 (diff)
downloadguile-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.scm43
-rw-r--r--test-suite/tests/bytevectors.test20
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"