test: Add performance test.
[mes.git] / module / mes / test.scm
1 ;;; -*-scheme-*-
2
3 ;;; GNU Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of GNU Mes.
7 ;;;
8 ;;; GNU Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; GNU Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; test.mes can be loaded after base.mes.  It provides a minimalistic
24 ;;; test framework: pass-if, pass-if-not, seq?, sequal? and result.
25
26 ;;; Code:
27
28 (define-module (mes test)
29   #:use-module (ice-9 rdelim)
30   #:export (
31             pass-if
32             pass-if-equal
33             pass-if-not
34             pass-if-eq
35             pass-if-timeout
36             result
37             seq? ; deprecated
38             sequal? ; deprecated
39             ))
40
41 (cond-expand
42  (mes
43   (define (inexact->exact x) x)
44   (define mes? #t)
45   (define guile? #f)
46   (define guile-2? #f)
47   (define guile-1.8? #f))
48  (guile-2
49   (define mes? #f)
50   (define guile? #t)
51   (define guile-2? #t)
52   (define guile-1.8? #f))
53  (guile
54   (define mes? #f)
55   (define guile? #f)
56   (define guile-2? #f)
57   (define guile-1.8? #t)))
58
59 (define result
60   ((lambda (pass fail)
61      (lambda (. t)
62        (if (or (null? t) (eq? (car t) 'result)) (list pass fail)
63            (if (eq? (car t) 'report)
64                (begin
65                  ((lambda (expect)
66                     (begin (display "expect: ") (write expect) (newline))
67                     (newline)
68                     (display "passed: ") (display pass) (newline)
69                     (display "failed: ") (display fail) (newline)
70                     (if (not (eq? expect 0)) (begin (display "expect: ") (write expect) (newline)))
71                     (display "total: ") (display (+ pass fail)) (newline)
72                     (exit (if (eq? expect fail) 0 fail)))
73                   (if (null? (cdr t)) 0 (cadr t))))
74                (if (car t) (begin (display ": pass") (newline) (set! pass (+ pass 1)))
75                    (begin (display ": fail") (newline) (set! fail (+ fail 1))))))))
76    0 0))
77
78 (define (seq? expect a) ;;REMOVE ME
79   (or (eq? a expect)
80       (begin
81         (display ": fail")
82         (newline)
83         (display "expected: ")
84         (display expect) (newline)
85         (display "actual: ")
86         (display a)
87         (newline)
88         #f)))
89
90 (define (sequal? expect a) ;;REMOVE ME
91   (or (equal? a expect)
92       (begin
93         (display ": fail")
94         (newline)
95         (display "expected: ")
96         (display expect) (newline)
97         (display "actual: ")
98         (display a)
99         (newline)
100         #f)))
101
102 (define (seq2? a expect)
103   (or (eq? a expect)
104       (begin
105         (display ": fail") (newline)
106         (display "expected: ") (display expect) (newline)
107         (display "actual: ") (display a) (newline)
108         #f)))
109
110 (define (sless? a expect)
111   (or (< a expect)
112       (begin
113         (display ": fail") (newline)
114         (display "expected: ") (display expect) (newline)
115         (display "actual: ") (display a) (newline)
116         #f)))
117
118 (define (sequal2? actual expect)
119   (or (equal? actual expect)
120       (begin
121         (display ": fail") (newline)
122         (display "expected: ") (display expect) (newline)
123         (display "actual: ") (display actual) (newline)
124         #f)))
125
126 (define-macro (pass-if name t)
127   (list
128    'begin
129    (list display "test: ") (list display name)
130    (list 'result t))) ;; FIXME
131
132 (define-macro (pass-if-eq name expect . body)
133   (list 'pass-if name (list seq2? (cons 'begin body) expect)))
134
135 (define-macro (pass-if-equal name expect . body)
136   (list 'pass-if name (list sequal2? (cons 'begin body) expect)))
137
138 (define-macro (expect-fail name expect . body)
139   (list 'pass-if name (list not (list sequal2? (cons 'begin body) expect))))
140
141 (define-macro (pass-if-not name f)
142   (list
143    'begin
144    (list display "test: ") (list display name)
145    (list 'result (list not f)))) ;; FIXME
146
147 (define internal-time-units-per-milli-second
148   (/ internal-time-units-per-second 1000))
149 (define (test-time thunk)
150   ((lambda (start)
151      (begin
152        (thunk)
153        (inexact->exact (/ (- (get-internal-run-time) start)
154                           internal-time-units-per-milli-second))))
155    (get-internal-run-time)))
156
157 (define-macro (pass-if-timeout name limit . body)
158   (list 'pass-if name (list sless? (list test-time (cons* 'lambda '_ body)) limit)))