1;;
2;; A quick hack to run test suite written for Chibi
3;;
4
5(define-module compat.chibi-test
6  (use gauche.test)
7  (use util.match)
8  (export chibi-test current-test-comparator))
9(select-module compat.chibi-test)
10
11(define current-test-comparator (make-parameter equal?))
12(define-syntax gauche:parameterize parameterize)
13(define gauche:test-error test-error)
14
15;; chibi allows internal defines to interleave expressions.  Gauche can't
16;; do that, so we translate the whole body of chibi-test into
17;; nested lets.
18
19;; we also cheat the scope - we want to replace macros such as
20;; test, include and parameterize, but we want them to be effective
21;; only inside chibi-test.
22
23(define-syntax chibi-test
24  (er-macro-transformer
25   (^[f r c]
26     `(let-syntax
27          ([parameterize
28            (syntax-rules ()
29              [(_ bindings . fs)
30               (,(r'gauche:parameterize) bindings
31                (,(r'chibi-test:expand) fs))])]
32           [use
33            ;; NB: We ignore 'use' in the chibi test file; necessary modules
34            ;; are supposed to be already used in the includer.
35            (syntax-rules ()
36              [(_ . args) (begin)])]
37           [import
38            ;; So as import
39            (syntax-rules ()
40              [(_ . args) (begin)])]
41           [include
42            (syntax-rules ()
43              [(_ file) (,(r'chibi-test:include) file)])]
44           [test
45            (syntax-rules ()
46              [(_ name expected expr)
47               (,(r'test*) name expected expr (current-test-comparator))]
48              [(_ expected expr)
49               (,(r'test*) 'expr expected expr (current-test-comparator))])]
50           [test-group
51            (syntax-rules ()
52              [(_ name . fs)
53               (begin
54                 (,(r'test-section) name)
55                 (,(r'chibi-test:expand) fs))])]
56           [test-assert
57            (syntax-rules ()
58              [(_ expr)
59               (,(r'test*) 'expr #t (,(r'boolean) expr))]
60              [(_ name expr)
61               (,(r'test*) name #t (,(r'boolean) expr))])]
62           [test-not
63            (syntax-rules ()
64              [(_ expr)
65               (,(r'test*) 'expr #f (,(r'boolean) expr))]
66              [(_ name expr)
67               (,(r'test*) name #f (,(r'boolean) expr))])]
68           [test-error
69            (syntax-rules ()
70              [(_ expr)
71               (,(r'test*) 'expr (,(r'gauche:test-error)) expr)])]
72           [test-exit
73            ;; ignore test-exit, for it is inside chibi-test and we don't
74            ;; want to exit.
75            (syntax-rules ()
76              [(_ . args) (begin)])]
77           )
78       (,(r'chibi-test:expand) ,(cdr f))))))
79
80;; We gather definitions at the same level, so that mutually recursive
81;; definitions work
82(define-syntax chibi-test:expand
83  (er-macro-transformer
84   (^[f r c]
85     (let loop ([forms (cadr f)]
86                [defs '()])
87       (match forms
88         [()
89          (if (null? defs)
90            (quasirename r `(begin))
91            (quasirename r `(let () ,@(reverse defs) (begin))))]
92         [(form)
93          (if (null? defs)
94            (car forms)
95            (quasirename r `(let () ,@(reverse defs) ,(car forms))))]
96         [((and ((? (cut c <> (r'define))) . _) def) . forms)
97          (loop forms (cons def defs))]
98         [(form . forms)
99          (if (null? defs)
100            (quasirename r `(let () ,form (chibi-test:expand ,forms)))
101            (quasirename r `(let () ,@(reverse defs)
102                                 ,form (chibi-test:expand ,forms))))])))))
103
104(define-syntax chibi-test:include
105  (er-macro-transformer
106   (^[f r c]
107     (let ([file (cadr f)])
108       (let1 iport ((with-module gauche.internal pass1/open-include-file)
109                    file (current-load-path))
110         (unwind-protect
111             `(,(r 'chibi-test:expand) ,(port->sexp-list iport))
112           (close-port iport)))))))
113
114;; A hack to make Gauche think it has loaded chibi.test so that it won't
115;; tripped by (import (chibi test)) in the test code.
116(define-module chibi.test (extend compat.chibi-test))
117(provide "chibi/test")
118(provide "compat/chibi-test")
119