[Guile-commits] GNU Guile branch, master, updated. v2.1.0-869-gaf11242

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=af11242268c22fb80a102e66f142e0073f7889cc

The branch, master has been updated
       via  af11242268c22fb80a102e66f142e0073f7889cc (commit)
      from  48e65b446822bffec9aa874bd39ca25ac4f29589 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit af11242268c22fb80a102e66f142e0073f7889cc
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 2 22:00:14 2014 +0200

    (test-suite lib) uses plain old catch, not stack-catch
    
    * test-suite/test-suite/lib.scm (run-test-exception): Refactor to just
      use "catch" instead of stack-catch.

-----------------------------------------------------------------------

Summary of changes:
 test-suite/test-suite/lib.scm |   50 ++++++++++++++++++-----------------------
 1 files changed, 22 insertions(+), 28 deletions(-)

diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 740beb1..9ecaf89 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -1,6 +1,6 @@
 ;;;; test-suite/lib.scm --- generic support for testing
 ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
-;;;;   2011, 2012, 2013 Free Software Foundation, Inc.
+;;;;   2011, 2012, 2013, 2014 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
@@ -18,8 +18,8 @@
 ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-suite lib)
-  #:use-module (ice-9 stack-catch)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 match)
   #:autoload   (srfi srfi-1)  (append-map)
   #:autoload   (system base compile) (compile)
   #:export (
@@ -383,32 +383,26 @@
 
 ;;; A helper function to implement the macros that test for exceptions.
 (define (run-test-exception name exception expect-pass thunk)
-  (run-test name expect-pass
-    (lambda ()
-      (stack-catch (car exception)
-       (lambda () (thunk) #f)
-       (lambda (key proc message . rest)
-         (cond
-           ;; handle explicit key
-           ((string-match (cdr exception) message)
-            #t)
-           ;; handle `(error ...)' which uses `misc-error' for key and doesn't
-           ;; yet format the message and args (we have to do it here).
-           ((and (eq? 'misc-error (car exception))
-                 (list? rest)
-                 (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))))))))
+  (match exception
+    ((expected-key . expected-pattern)
+     (run-test
+      name
+      expect-pass
+      (lambda ()
+        (catch expected-key
+          (lambda () (thunk) #f)
+          (lambda (key proc message . rest)
+            ;; Match the message against the expected pattern.  If that
+            ;; doesn't work, in the case of `misc-error' and
+            ;; `syntax-error' we treat the message as a format string,
+            ;; and format it.  This is pretty terrible but it's
+            ;; historical.
+            (or (and (string-match expected-pattern message) #t)
+                (and (memq expected-key '(misc-error syntax-error))
+                     (list? rest)
+                     (let ((out (apply simple-format #f message (car rest))))
+                       (and (string-match expected-pattern out) #t)))
+                (apply throw key proc message rest)))))))))
 
 ;;; A short form for tests that expect a certain exception to be thrown.
 (define-syntax pass-if-exception


hooks/post-receive
-- 
GNU Guile