From 10e3659b0cba48e834d577600392edbcfbff3b4b Mon Sep 17 00:00:00 2001
From: Eric Blossom
Date: Mon, 8 Nov 2010 13:48:44 -0800
Subject: New macros pass-if-throw & expect-fail-throw that test exceptions.

Confirmed with "connect-5" test in 00_runtime_basics.test.
---
 .../src/guile/gnuradio/test-suite/lib.scm          | 26 ++++++++++++++++++++++
 .../src/guile/tests/00_runtime_basics.test         | 21 ++++++-----------
 2 files changed, 33 insertions(+), 14 deletions(-)

(limited to 'gnuradio-core')

diff --git a/gnuradio-core/src/guile/gnuradio/test-suite/lib.scm b/gnuradio-core/src/guile/gnuradio/test-suite/lib.scm
index b7046a8b0..458e627de 100644
--- a/gnuradio-core/src/guile/gnuradio/test-suite/lib.scm
+++ b/gnuradio-core/src/guile/gnuradio/test-suite/lib.scm
@@ -38,6 +38,7 @@
  run-test
  pass-if expect-fail
  pass-if-exception expect-fail-exception
+ pass-if-throw expect-fail-throw
 
  ;; Naming groups of tests in a regular fashion.
  with-test-prefix with-test-prefix* current-test-prefix
@@ -340,6 +341,13 @@
       `(run-test ,name #f (lambda () ,@rest))))
 
 ;;; A helper function to implement the macros that test for exceptions.
+;;;
+;;; This doesn't work for all exceptions, just those that were
+;;; raised by scm-error or error.  This doesn't include those
+;;; raised by throw in the general case, or SWIG in particular.
+;;;
+;;; See also run-raise-exception, pass-if-throw and expect-fail-throw
+;;; for alternatives that work with all exceptions.
 (define (run-test-exception name exception expect-pass thunk)
   (run-test name expect-pass
     (lambda ()
@@ -376,6 +384,24 @@
 (defmacro expect-fail-exception (name exception body . rest)
   `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
 
+
+;;; Helper for macros below
+(define (run-test-throw name exception-key expect-pass thunk)
+  (run-test name expect-pass
+    (lambda ()
+      (stack-catch exception-key
+	(lambda () (thunk) #f)
+	(lambda (key . rest) #t)))))
+
+;;; A short form for tests that expect a certain exception to be thrown,
+;;; where the exception is specified only by the exception-key symbol.
+(defmacro pass-if-throw (name exception-key body . rest)
+  `(,run-test-throw ,name ,exception-key #t (lambda () ,body ,@rest)))
+
+;;; A short form for tests that expect a certain exception to be thrown,
+;;; where the exception is specified only by the exception-key symbol.
+(defmacro expect-fail-throw (name exception-key body . rest)
+  `(,run-test-throw ,name ,exception-key #f (lambda () ,body ,@rest)))
 
 ;;;; TEST NAMES
 ;;;;
diff --git a/gnuradio-core/src/guile/tests/00_runtime_basics.test b/gnuradio-core/src/guile/tests/00_runtime_basics.test
index 989ae423c..93dcff4d7 100644
--- a/gnuradio-core/src/guile/tests/00_runtime_basics.test
+++ b/gnuradio-core/src/guile/tests/00_runtime_basics.test
@@ -33,7 +33,7 @@
   (list->vector (map f (vector->list v))))
 
 
-(with-test-prefix "test-connect-1"
+(with-test-prefix "connect-1"
  (let* ((src-data #(-5 -4 -3 -2 -1 0 1 2 3 4 5))
 	 (expected-result (vector-map (lambda (x) (* x 2)) src-data))
 	 (tb (gr:top-block-swig "QA top block"))
@@ -50,7 +50,7 @@
     (test-equal expected-result (gr:data dst))
     ))
 
-(with-test-prefix "test-connect-2"
+(with-test-prefix "connect-2"
   (let* ((src-data #(-5 -4 -3 -2 -1 0 1 2 3 4 5))
 	 (expected-result (vector-map (lambda (x) (* x 2)) src-data))
 	 (tb (gr:top-block-swig "QA top block"))
@@ -66,7 +66,7 @@
     (test-equal expected-result (gr:data dst))))
 
 
-(with-test-prefix "test-connect-3"
+(with-test-prefix "connect-3"
   (let* ((src-data #(-5 -4 -3 -2 -1 0 1 2 3 4 5))
 	 (expected-result (vector-map (lambda (x) (* x 2)) src-data))
 	 (tb (gr:top-block-swig "QA top block"))
@@ -82,7 +82,7 @@
     (test-equal expected-result (gr:data dst))))
 
 
-(with-test-prefix "test-connect-4"
+(with-test-prefix "connect-4"
   (let* ((src-data #(-5 -4 -3 -2 -1 0 1 2 3 4 5))
 	 (expected-result (vector-map (lambda (x) (* x 2)) src-data))
 	 (tb (gr:top-block-swig "QA top block"))
@@ -96,11 +96,7 @@
     (gr:run tb)
     (test-equal expected-result (gr:data dst))))
 
-#!
-;;; FIXME pass-if-exception is broken if the underlying code throws
-;;; (like ours does).  Need to write our own test utility for
-;;; exceptions.
-(with-test-prefix "test-connect-5"
+(with-test-prefix "connect-5"
   (let* ((src-data #(-5 -4 -3 -2 -1 0 1 2 3 4 5))
 	 (expected-result (vector-map (lambda (x) (* x 2)) src-data))
 	 (tb (gr:top-block-swig "QA top block"))
@@ -108,14 +104,11 @@
 	 (op (gr:multiply-const-ii 2))
 	 (dst (gr:vector-sink-i)))
 
-    ;; FIXME This isn't working...
-    (pass-if-exception "bad port" exception:swig-exception
+    (pass-if-throw "bad port exception" 'swig-exception
       (gr:connect tb src op (gr:ep dst 1)))
-
     ))
-!#
 
-(with-test-prefix "test-io-signature-1"
+(with-test-prefix "io-signature-1"
   (let ((ios1 (gr:io-signature 1 2 8))
 	(ios2 (gr:io-signature2 1 2 16 32))
 	(ios3 (gr:io-signature3 1 -1 14 32 48))
-- 
cgit