Have `scm_take_locale_symbol ()' return an interned symbol (fixes bug #25865).

[bpt/guile.git] / test-suite / lib.scm

diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index 90b0837..c4ddf9e 100644 (file)
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -1,5 +1,5 @@
 ;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -13,8 +13,8 @@
 ;;;;
 ;;;; You should have received a copy of the GNU General Public License
 ;;;; along with this software; see the file COPYING.  If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
 
 (define-module (test-suite lib)
   :use-module (ice-9 stack-catch)
@@ -22,8 +22,16 @@
   :export (
 
  ;; Exceptions which are commonly being tested for.
+ exception:bad-variable
+ exception:missing-expression
  exception:out-of-range exception:unbound-var
+ exception:used-before-defined
  exception:wrong-num-args exception:wrong-type-arg
+ exception:numerical-overflow
+ exception:struct-set!-denied
+ exception:system-error
+ exception:miscellaneous-error
+ exception:string-contains-nul
 
  ;; Reporting passes and failures.
  run-test
@@ -32,14 +40,17 @@
 
  ;; Naming groups of tests in a regular fashion.
  with-test-prefix with-test-prefix* current-test-prefix
+ format-test-name
+
+ ;; Using the debugging evaluator.
+ with-debugging-evaluator with-debugging-evaluator*
 
  ;; Reporting results in various ways.
  register-reporter unregister-reporter reporter-registered?
  make-count-reporter print-counts
  make-log-reporter
  full-reporter
- user-reporter
- format-test-name))
+ user-reporter))
 
 
 ;;;; If you're using Emacs's Scheme mode:
@@ -232,14 +243,33 @@
 ;;;;
 
 ;;; Define some exceptions which are commonly being tested for.
+(define exception:bad-variable
+  (cons 'syntax-error "Bad variable"))
+(define exception:missing-expression
+  (cons 'misc-error "^missing or extra expression"))
 (define exception:out-of-range
-  (cons 'out-of-range "^Argument .*out of range"))
+  (cons 'out-of-range "^.*out of range"))
 (define exception:unbound-var
   (cons 'unbound-variable "^Unbound variable"))
+(define exception:used-before-defined
+  (cons 'unbound-variable "^Variable used before given a value"))
 (define exception:wrong-num-args
   (cons 'wrong-number-of-args "^Wrong number of arguments"))
 (define exception:wrong-type-arg
-  (cons 'wrong-type-arg "^Wrong type argument"))
+  (cons 'wrong-type-arg "^Wrong type"))
+(define exception:numerical-overflow
+  (cons 'numerical-overflow "^Numerical overflow"))
+(define exception:struct-set!-denied
+  (cons 'misc-error "^set! denied for field"))
+(define exception:system-error
+  (cons 'system-error ".*"))
+(define exception:miscellaneous-error
+  (cons 'misc-error "^.*"))
+
+;; as per throw in scm_to_locale_stringn()
+(define exception:string-contains-nul
+  (cons 'misc-error "^string contains #\\\\nul character"))
+
 
 ;;; Display all parameters to the default output port, followed by a newline.
 (define (display-line . objs)
@@ -320,6 +350,13 @@
                  (string-match (cdr exception)
                                (apply simple-format #f message (car rest))))
             #t)
+           ;; handle syntax errors which use `syntax-error' for key and don't
+           ;; yet format the message and args (we have to do it here).
+           ((and (eq? 'syntax-error (car exception))
+                 (list? rest)
+                 (string-match (cdr exception)
+                               (apply simple-format #f message (car rest))))
+            #t)
            ;; unhandled; throw again
            (else
             (apply throw key proc message rest))))))))
@@ -374,6 +411,22 @@
 (defmacro with-test-prefix (prefix . body)
   `(with-test-prefix* ,prefix (lambda () ,@body)))
 
+;;; Call THUNK using the debugging evaluator.
+(define (with-debugging-evaluator* thunk)
+  (let ((dopts #f))
+    (dynamic-wind
+       (lambda ()
+         (set! dopts (debug-options))
+         (debug-enable 'debug))
+       thunk
+       (lambda ()
+         (debug-options dopts)))))
+
+;;; Evaluate BODY... using the debugging evaluator.
+(define-macro (with-debugging-evaluator . body)
+  `(with-debugging-evaluator* (lambda () ,@body)))
+
+
 \f
 ;;;; REPORTERS
 ;;;;