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