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         (write expect) (newline)
  85         (display "actual: ")
  86         (write 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         (write expect) (newline)
  97         (display "actual: ")
  98         (write 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: ") (write expect) (newline)
 107         (display "actual: ") (write a) (newline)
 108         #f)))
 109
 110 (define (sless? a expect)
 111   (or (< a expect)
 112       (begin
 113         (display ": fail") (newline)
 114         (display "expected: ") (write expect) (newline)
 115         (display "actual: ") (write a) (newline)
 116         #f)))
 117
 118 (define (sequal2? actual expect)
 119   (or (equal? actual expect)
 120       (begin
 121         (display ": fail") (newline)
 122         (display "expected: ") (write expect) (newline)
 123         (display "actual: ") (write 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)))