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

test-suite: Add `pass-if-equal'.

Browse source 
* test-suite/test-suite/lib.scm (pass-if-equal): New macro.
  (run-test): Upon `fail', pass ARGS to REPORT.
This commit is contained in:
Ludovic Courtès 2012-11-01 00:42:37 +01:00
parent 10744b7c50
commit d4eee584e0
2 changed files with 21 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

4
.dir-locals.el
View file

@ -3,7 +3,9 @@
((nil . ((fill-column . 72)
(tab-width . 8)))
(c-mode . ((c-file-style . "gnu")))
(scheme-mode . ((indent-tabs-mode . nil)))
(scheme-mode
. ((indent-tabs-mode . nil)
(eval . (put 'pass-if-equal 'scheme-indent-function 2))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))

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

@ -44,6 +44,7 @@
;; Reporting passes and failures.
run-test
pass-if expect-fail
pass-if-equal
pass-if-exception expect-fail-exception
;; Naming groups of tests in a regular fashion.
@ -332,7 +333,11 @@
((pass)
(report (if expect-pass 'pass 'upass) test-name))
((fail)
(report (if expect-pass 'fail 'xfail) test-name))
;; ARGS may contain extra info about the failure,
;; such as the expected and actual value.
(apply report (if expect-pass 'fail 'xfail)
test-name
args))
((unresolved untested unsupported)
(report key test-name))
((quit)
@ -352,6 +357,18 @@
((_ name rest ...)
(run-test name #t (lambda () rest ...)))))
(define-syntax pass-if-equal
(syntax-rules ()
"Succeed if and only if BODY's return value is equal? to EXPECTED."
((_ name expected body ...)
(run-test 'name #t
(lambda ()
(let ((result (begin body ...)))
(or (equal? expected result)
(throw 'fail
'expected-value expected
'actual-value result))))))))
;;; A short form for tests that are expected to fail, taken from Greg.
(define-syntax expect-fail
(syntax-rules ()