X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/01ad5a7ba9edb5d8c96567ed80ea1a34019c5338..15993bce1cd0a2e69f11a6ac1725fa7a219c5b7c:/test-suite/lib.scm

diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index f32c7c308..b63c5952e 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -1,5 +1,6 @@
 ;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010 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
@@ -17,10 +18,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
@@ -37,6 +39,7 @@
  exception:string-contains-nul
  exception:read-error
  exception:null-pointer-error
+ exception:vm-error
 
  ;; Reporting passes and failures.
  run-test
@@ -44,7 +47,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.
@@ -172,7 +178,7 @@
 ;;;;   ("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"
@@ -274,13 +280,15 @@
 (define exception:system-error
   (cons 'system-error ".*"))
 (define exception:encoding-error
-  (cons 'encoding-error "(cannot convert to output locale|input locale conversion 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
@@ -435,16 +443,40 @@
 ;;; 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)))))