1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
;; Copyright © 2022 Hugo Hörnquist
;; Copyright for this file, however, majority of contents borrowed under the
;; below mentioned license agreement from srfi/srfi-64/testing.scm of Guile 2.2.7.
;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
;; Added "full" support for Chicken, Gauche, Guile and SISC.
;; Alex Shinn, Copyright (c) 2005.
;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;; Commentary:
;; The code is directly copied from Guile's source tree
;; (module/srfi/srfi-64/testing.scm), but @var{etype}
;; is passed to @code{catch}, causing it to actually
;; check the expected error.
;;; Code:
(define-module (srfi srfi-64 test-error)
:use-module (srfi srfi-64)
:use-module (hnh util)
:replace (test-error))
(define %test-source-line2 (@@ (srfi srfi-64) %test-source-line2))
(define %test-on-test-begin (@@ (srfi srfi-64) %test-on-test-begin))
(define %test-on-test-end (@@ (srfi srfi-64) %test-on-test-end))
(define %test-report-result (@@ (srfi srfi-64) %test-report-result))
(define-syntax %test-error
(syntax-rules ()
((%test-error r etype expr)
(cond ((%test-on-test-begin r)
(let ((et etype))
(test-result-set! r 'expected-error et)
(%test-on-test-end r
(catch etype
(lambda ()
(test-result-set! r 'actual-value expr)
#f)
(lambda (key . args)
;; TODO: decide how to specify expected
;; error types for Guile.
(test-result-set! r 'actual-error
(cons key args))
#t)))
(%test-report-result)))))))
(define-syntax test-error
(lambda (x)
(syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
(((mac tname etype expr) line)
(syntax
(let* ((r (test-runner-get))
(name tname))
(test-result-alist! r (cons (cons 'test-name tname) line))
(%test-error r etype expr))))
(((mac etype expr) line)
(syntax
(let* ((r (test-runner-get)))
(test-result-alist! r line)
(%test-error r etype expr))))
(((mac expr) line)
(syntax
(let* ((r (test-runner-get)))
(test-result-alist! r line)
(%test-error r #t expr)))))))
|
