test: Add performance test.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 21 Oct 2018 10:04:25 +0000 (12:04 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 21 Oct 2018 10:04:25 +0000 (12:04 +0200)
* module/mes/test.scm (pass-if-timeout): New macro.
* tests/perform.test: New test.
* build-aux/check-mes.sh (tests): Run it.

build-aux/check-mes.sh
module/mes/test.scm
tests/perform.test [new file with mode: 0755]

index 1e735711b79d0eb70d79d6f1914224458f88ecbb..254b2ec615dd2a813332045675fedae0831821ca 100755 (executable)
@@ -36,6 +36,7 @@ tests/boot.test
 tests/read.test
 tests/srfi-0.test
 tests/macro.test
 tests/read.test
 tests/srfi-0.test
 tests/macro.test
+tests/perform.test
 tests/base.test
 tests/quasiquote.test
 tests/let.test
 tests/base.test
 tests/quasiquote.test
 tests/let.test
index ad922ccc474d050844be926bb3866953751fc39f..f33b5843cece61c201d4b566b9a9cb5c5255566e 100644 (file)
 ;;; Code:
 
 (define-module (mes test)
 ;;; Code:
 
 (define-module (mes test)
+  #:use-module (ice-9 rdelim)
   #:export (
             pass-if
             pass-if-equal
             pass-if-not
             pass-if-eq
   #:export (
             pass-if
             pass-if-equal
             pass-if-not
             pass-if-eq
+            pass-if-timeout
             result
             seq? ; deprecated
             sequal? ; deprecated
             result
             seq? ; deprecated
             sequal? ; deprecated
@@ -38,6 +40,7 @@
 
 (cond-expand
  (mes
 
 (cond-expand
  (mes
+  (define (inexact->exact x) x)
   (define mes? #t)
   (define guile? #f)
   (define guile-2? #f)
   (define mes? #t)
   (define guile? #f)
   (define guile-2? #f)
         (display "actual: ") (display a) (newline)
         #f)))
 
         (display "actual: ") (display a) (newline)
         #f)))
 
+(define (sless? a expect)
+  (or (< a expect)
+      (begin
+        (display ": fail") (newline)
+        (display "expected: ") (display expect) (newline)
+        (display "actual: ") (display a) (newline)
+        #f)))
+
 (define (sequal2? actual expect)
   (or (equal? actual expect)
       (begin
 (define (sequal2? actual expect)
   (or (equal? actual expect)
       (begin
    'begin
    (list display "test: ") (list display name)
    (list 'result (list not f)))) ;; FIXME
    'begin
    (list display "test: ") (list display name)
    (list 'result (list not f)))) ;; FIXME
+
+(define internal-time-units-per-milli-second
+  (/ internal-time-units-per-second 1000))
+(define (test-time thunk)
+  ((lambda (start)
+     (begin
+       (thunk)
+       (inexact->exact (/ (- (get-internal-run-time) start)
+                          internal-time-units-per-milli-second))))
+   (get-internal-run-time)))
+
+(define-macro (pass-if-timeout name limit . body)
+  (list 'pass-if name (list sless? (list test-time (cons* 'lambda '_ body)) limit)))
diff --git a/tests/perform.test b/tests/perform.test
new file mode 100755 (executable)
index 0000000..b971953
--- /dev/null
@@ -0,0 +1,57 @@
+#! /bin/sh
+# -*-scheme-*-
+if [ "$MES" != guile ]; then
+    export MES_BOOT=boot-02.scm
+    MES=${MES-$(dirname $0)/../src/mes}
+    $MES < $0
+    exit $?
+fi
+exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests perform)' -s "$0" "$@"
+!#
+
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Mes.
+;;;
+;;; GNU Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests boot)
+  #:use-module (mes mes-0)
+  #:use-module (mes test))
+
+(cond-expand
+ (mes
+  (define (round x) x)
+  (primitive-load "module/mes/test.scm"))
+ (guile-2)
+ (guile
+  (use-modules (ice-9 syncase))))
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if-timeout "loop 1M"
+                 100
+                 ((lambda (loop)
+                    (set! loop
+                          (lambda (i)
+                            (if (> i 0)
+                                (loop (- i 1)))))
+                    (loop 100000))
+                  *unspecified*))
+
+(result 'report 1) ; at least until we have bogomips, to fail