mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

(test-suite lib) uses plain old catch, not stack-catch

Browse source 
* test-suite/test-suite/lib.scm (run-test-exception): Refactor to just
  use "catch" instead of stack-catch.
This commit is contained in:
Andy Wingo 2014-04-02 22:00:14 +02:00
parent 48e65b4468
commit af11242268
1 changed files with 22 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

50
test-suite/test-suite/lib.scm
View file

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