1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;;;
3;;; Tests these (scheme time) procedures:
4;;;
5;;;     current-jiffy
6;;;     current-second
7;;;     jiffies-per-second
8
9
10(define-library (tests scheme time)
11  (export run-time-tests)
12  (import (scheme base)
13          (scheme time)
14          (tests scheme test))
15
16  (begin
17
18   (define (run-time-tests)
19
20     ;; Compilers might optimize this into (if #f #f),
21     ;; but the tests would still work.
22
23     (define (countdown n)
24       (if (> n 0)
25           (countdown (- n 1))))
26
27     (define (count-until thunk)
28       (define million 1000000)
29       (let loop ((k 0))
30         (if (thunk)
31             (* k million)
32             (begin (countdown million)
33                    (loop (+ k 1))))))
34
35     (define loops/s 0)
36
37     (test (map exact?
38                (list (current-second) (current-jiffy) (jiffies-per-second)))
39           '(#f #t #t))
40
41     ;; Jiffy timing should be accurate to within a tenth of a second,
42     ;; even if there's just one jiffy per second.
43     ;;
44     ;; In many implementations of the R7RS, (current-second) appears
45     ;; to have 1-second resolution.  The following code therefore
46     ;; waits for a transition between seconds before starting its
47     ;; timing.
48
49     (test (let* ((t0 (truncate (current-second)))
50                  (t1 (+ t0 (inexact 1))))
51             (count-until (lambda () (<= t1 (current-second))))
52             (let* ((jifs/second (jiffies-per-second))
53                    (t0 (current-second))
54                    (j0 (current-jiffy))
55                    (j1 (+ j0 jifs/second)))
56               (let* ((n (count-until (lambda () (<= j1 (current-jiffy)))))
57                      (j (current-jiffy))
58                      (t (current-second)))
59                 (set! loops/s n)
60                 (list (exact (round (- t t0)))
61                       (<= j1 j)
62                       (<= j (+ j1 (/ jifs/second 10)))))))
63           '(1 #t #t))
64
65     loops/s)))
66