From b2bcfdbec907c5a79efb14631a2d61dc7eae776f Mon Sep 17 00:00:00 2001 From: John Clements Date: Sat, 28 Nov 2009 02:31:17 +0000 Subject: [PATCH] updated srfi 19 tests from dave gurnell svn: r17084 --- collects/tests/srfi/19/tests.ss | 282 +++++++++++++++----------------- 1 file changed, 135 insertions(+), 147 deletions(-) diff --git a/collects/tests/srfi/19/tests.ss b/collects/tests/srfi/19/tests.ss index c6fa05db59..c12248d6bf 100644 --- a/collects/tests/srfi/19/tests.ss +++ b/collects/tests/srfi/19/tests.ss @@ -1,74 +1,84 @@ -(module tests mzscheme +#lang scheme/base - ;; Tests by Will Fitzgerald, augmented by John Clements -- 2004-08-16 +;; Tests by Will Fitzgerald, augmented by: +;; John Clements -- 2004-08-16 +;; Dave Gurnell (string->date, date->string) -- 2007-09-14 +;; Dave Gurnell (time{=,<,>,<=,>=}?) -- 2009-11-26 - ;; Updated to SchemeUnit 2 syntax by Dave Gurnell -- 2007-09-14 +(require srfi/19/time) - (require srfi/19/time) +(require schemeunit/test + schemeunit/text-ui) - (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))) +(define-check (check-comparisons comparison times expected) + (for ([time0 (in-list times)] + [expected (in-list expected)]) + (for ([time1 (in-list times)] + [expected (in-list expected)]) + (with-check-info (['comparison comparison] + ['time0 time0] + ['time1 time1]) + (let ([actual (comparison time0 time1)]) + (check-equal? actual expected)))))) - (define cur-tz (date-zone-offset (current-date))) - - ; Test suite ----------------------------------- +(define cur-tz (date-zone-offset (current-date))) - (define srfi-19-test-suite - (test-suite - "Tests for SRFI 19" +; Test suite ------------------------------------- - (test-not-exn - "Creating time structures" +(define srfi-19-test-suite + (test-suite "Tests for SRFI 19" + + (test-not-exn "Creating time structures" (lambda () (list (current-time 'time-tai) (current-time 'time-utc) (current-time 'time-monotonic) (current-time 'time-thread) (current-time 'time-process)))) - - (test-not-exn - "Testing time resolutions" + + (test-not-exn "Testing time resolutions" (lambda () (list (time-resolution 'time-tai) (time-resolution 'time-utc) (time-resolution 'time-monotonic) (time-resolution 'time-thread) (time-resolution 'time-process)))) - - (test-case - "Time comparisons (time=?, etc.)" - (let ((t1 (make-time 'time-utc 0 1)) - (t2 (make-time 'time-utc 0 1)) - (t3 (make-time 'time-utc 0 2)) - (t11 (make-time 'time-utc 1001 1)) - (t12 (make-time 'time-utc 1001 1)) - (t13 (make-time 'time-utc 1001 2))) - (check time=? t1 t2) - (check time>? t3 t2) - (check time=? t1 t2) - (check time>=? t3 t2) - (check time<=? t1 t2) - (check time<=? t2 t3) - (check time=? t11 t12) - (check time>? t13 t12) - (check time=? t11 t12) - (check time>=? t13 t12) - (check time<=? t11 t12) - (check time<=? t12 t13))) - - (test-case - "Time difference" + + (test-case "Time comparisons (time=?, etc.)" + (let ([t0 (make-time 'time-utc 0 1)] + [t1 (make-time 'time-utc 0 1)] + [t2 (make-time 'time-utc 1 1)] + [t3 (make-time 'time-utc 0 2)]) + (check-comparisons time=? (list t0 t1 t2 t3) '((#t #t #f #f) + (#t #t #f #f) + (#f #f #t #f) + (#f #f #f #t))) + (check-comparisons time? (list t0 t1 t2 t3) '((#f #f #f #f) + (#f #f #f #f) + (#t #t #f #f) + (#t #t #t #f))) + (check-comparisons time<=? (list t0 t1 t2 t3) '((#t #t #t #t) + (#t #t #t #t) + (#f #f #t #t) + (#f #f #f #t))) + (check-comparisons time>=? (list t0 t1 t2 t3) '((#t #t #f #f) + (#t #t #f #f) + (#t #t #t #f) + (#t #t #t #t))))) + + (test-case "Time difference" (let ((t1 (make-time 'time-utc 0 3000)) (t2 (make-time 'time-utc 0 1000)) (t3 (make-time 'time-duration 0 2000)) (t4 (make-time 'time-duration 0 -2000))) (check time=? t3 (time-difference t1 t2)) (check time=? t4 (time-difference t2 t1)))) - - (test-case - "TAI-UTC Conversions" + + (test-case "TAI-UTC Conversions" (check-one-utc-tai-edge 915148800 32 31) (check-one-utc-tai-edge 867715200 31 30) (check-one-utc-tai-edge 820454400 30 29) @@ -95,15 +105,8 @@ (check-one-utc-tai-edge 0 0 0) ;; at the epoch (check-one-utc-tai-edge 10 0 0) ;; close to it ... (check-one-utc-tai-edge 1045789645 32 32)) ;; about now ... - - (test-case - "time-second" - (check-equal? (time-second (make-time 'time-duration 34 52)) 52) - (check-equal? (time-nanosecond (make-time 'time-duration 34 52)) 34)) - - - (test-case - "TAI-Date Conversions" + + (test-case "TAI-Date Conversions" (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0) (srfi:make-date 0 58 59 23 31 12 1998 0)) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0) @@ -112,9 +115,8 @@ (srfi:make-date 0 60 59 23 31 12 1998 0)) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0) (srfi:make-date 0 0 0 0 1 1 1999 0))) - - (test-case - "Date-UTC Conversions" + + (test-case "Date-UTC Conversions" (check time=? (make-time time-utc 0 (- 915148800 2)) (date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0))) (check time=? (make-time time-utc 0 (- 915148800 1)) @@ -126,44 +128,36 @@ (date->time-utc (srfi:make-date 0 0 0 0 1 1 1999 0))) (check time=? (make-time time-utc 0 (+ 915148800 1)) (date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0)))) - - (test-case - "TZ Offset conversions" + + (test-case "TZ Offset conversions" (let ((ct-utc (make-time time-utc 6320000 1045944859)) (ct-tai (make-time time-tai 6320000 1045944891)) (cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000))) (check time=? ct-utc (date->time-utc cd)) (check time=? ct-tai (date->time-tai cd)))) - - - ;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going - ;; to change the test case to match the implementation... - (test-case - "date->string conversions" + + + ;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going + ;; to change the test case to match the implementation... + (test-case "date->string conversions" (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120)) "~~ @ ~a @ ~A @ ~b @ ~B @ ~c @ ~d @ ~D @ ~e @ ~f @ ~h @ ~H") - "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04") - (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120)) - "~4") - "2007-06-05T04:03:02-0200")) - - - ;; looks like these tests need to ignore the time zone. -- JBC, 2009-08-27 - - (test-case - "[DJG] date->string conversions of dates with nanosecond components" - (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 cur-tz) "~N") "123456789") - (check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 cur-tz) "~N") "012345678") - (check-equal? (date->string (srfi:make-date 1234567 2 3 4 5 6 2007 cur-tz) "~N") "001234567") - (check-equal? (date->string (srfi:make-date 123456 2 3 4 5 6 2007 cur-tz) "~N") "000123456") - (check-equal? (date->string (srfi:make-date 12345 2 3 4 5 6 2007 cur-tz) "~N") "000012345") - (check-equal? (date->string (srfi:make-date 1234 2 3 4 5 6 2007 cur-tz) "~N") "000001234") - (check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 cur-tz) "~N") "000000123") - (check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 cur-tz) "~N") "000000012") - (check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 cur-tz) "~N") "000000001")) - - (test-case - "[DJG] string->date conversions of dates with nanosecond components" + "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04")) + + + + (test-case "[DJG] date->string conversions of dates with nanosecond components" + (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 0) "~N") "123456789") + (check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 0) "~N") "012345678") + (check-equal? (date->string (srfi:make-date 1234567 2 3 4 5 6 2007 0) "~N") "001234567") + (check-equal? (date->string (srfi:make-date 123456 2 3 4 5 6 2007 0) "~N") "000123456") + (check-equal? (date->string (srfi:make-date 12345 2 3 4 5 6 2007 0) "~N") "000012345") + (check-equal? (date->string (srfi:make-date 1234 2 3 4 5 6 2007 0) "~N") "000001234") + (check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 0) "~N") "000000123") + (check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 0) "~N") "000000012") + (check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 0) "~N") "000000001")) + + (test-case "[DJG] string->date conversions of dates with nanosecond components" (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 #t #t #t cur-tz) "check 1") (check-equal? (string->date "12:00:00.12345678" "~H:~M:~S.~N") (srfi:make-date 123456780 0 0 12 #t #t #t cur-tz) "check 2") (check-equal? (string->date "12:00:00.1234567" "~H:~M:~S.~N") (srfi:make-date 123456700 0 0 12 #t #t #t cur-tz) "check 3") @@ -182,73 +176,67 @@ (check-equal? (string->date "12:00:00.000000123" "~H:~M:~S.~N") (srfi:make-date 123 0 0 12 #t #t #t cur-tz) "check 16") (check-equal? (string->date "12:00:00.000000012" "~H:~M:~S.~N") (srfi:make-date 12 0 0 12 #t #t #t cur-tz) "check 17") (check-equal? (string->date "12:00:00.000000001" "~H:~M:~S.~N") (srfi:make-date 1 0 0 12 #t #t #t cur-tz) "check 18")) - - (test-case - "date<->julian-day conversion" + + (test-case "date<->julian-day conversion" (check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (date->julian-day (srfi:make-date 0 0 0 0 1 1 2003 0)))) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)]) (check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200)))) - - (test-case - "date->modified-julian-day conversion" + + (test-case "date->modified-julian-day conversion" (check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2003 0)))) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)]) - (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200)))) + (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200)))))) - )) +; Helper checks and procedures ----------------- - ; Helper checks and procedures ----------------- +(define-check (check-one-utc-tai-edge utc tai-diff tai-last-diff) + (let* (;; right on the edge they should be the same + (utc-basic (make-time 'time-utc 0 utc)) + (tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) + (utc->tai-basic (time-utc->time-tai utc-basic)) + (tai->utc-basic (time-tai->time-utc tai-basic)) + + ;; a second before they should be the old diff + (utc-basic-1 (make-time 'time-utc 0 (- utc 1))) + (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1))) + (utc->tai-basic-1 (time-utc->time-tai utc-basic-1)) + (tai->utc-basic-1 (time-tai->time-utc tai-basic-1)) + + ;; a second later they should be the new diff + (utc-basic+1 (make-time 'time-utc 0 (+ utc 1))) + (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1))) + (utc->tai-basic+1 (time-utc->time-tai utc-basic+1)) + (tai->utc-basic+1 (time-tai->time-utc tai-basic+1)) + + ;; ok, let's move the clock half a month or so plus half a second + (shy (* 15 24 60 60)) + (hs (/ (expt 10 9) 2)) + ;; a second later they should be the new diff + (utc-basic+2 (make-time 'time-utc hs (+ utc shy))) + (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy))) + (utc->tai-basic+2 (time-utc->time-tai utc-basic+2)) + (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))) + + (check time=? utc-basic tai->utc-basic) + (check time=? tai-basic utc->tai-basic) + (check time=? utc-basic-1 tai->utc-basic-1) + (check time=? tai-basic-1 utc->tai-basic-1) + (check time=? utc-basic+1 tai->utc-basic+1) + (check time=? tai-basic+1 utc->tai-basic+1) + (check time=? utc-basic+2 tai->utc-basic+2) + (check time=? tai-basic+2 utc->tai-basic+2))) - (define-check (check-one-utc-tai-edge utc tai-diff tai-last-diff) - (let* (;; right on the edge they should be the same - (utc-basic (make-time 'time-utc 0 utc)) - (tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) - (utc->tai-basic (time-utc->time-tai utc-basic)) - (tai->utc-basic (time-tai->time-utc tai-basic)) +(define (tm:date= d1 d2) + (and (= (srfi:date-year d1) (srfi:date-year d2)) + (= (srfi:date-month d1) (srfi:date-month d2)) + (= (srfi:date-day d1) (srfi:date-day d2)) + (= (srfi:date-hour d1) (srfi:date-hour d2)) + (= (srfi:date-second d1) (srfi:date-second d2)) + (= (date-nanosecond d1) (date-nanosecond d2)) + (= (date-zone-offset d1) (date-zone-offset d2)))) - ;; a second before they should be the old diff - (utc-basic-1 (make-time 'time-utc 0 (- utc 1))) - (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1))) - (utc->tai-basic-1 (time-utc->time-tai utc-basic-1)) - (tai->utc-basic-1 (time-tai->time-utc tai-basic-1)) +; Main module body ------------------------------- - ;; a second later they should be the new diff - (utc-basic+1 (make-time 'time-utc 0 (+ utc 1))) - (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1))) - (utc->tai-basic+1 (time-utc->time-tai utc-basic+1)) - (tai->utc-basic+1 (time-tai->time-utc tai-basic+1)) - - ;; ok, let's move the clock half a month or so plus half a second - (shy (* 15 24 60 60)) - (hs (/ (expt 10 9) 2)) - ;; a second later they should be the new diff - (utc-basic+2 (make-time 'time-utc hs (+ utc shy))) - (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy))) - (utc->tai-basic+2 (time-utc->time-tai utc-basic+2)) - (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))) - - (check time=? utc-basic tai->utc-basic) - (check time=? tai-basic utc->tai-basic) - (check time=? utc-basic-1 tai->utc-basic-1) - (check time=? tai-basic-1 utc->tai-basic-1) - (check time=? utc-basic+1 tai->utc-basic+1) - (check time=? tai-basic+1 utc->tai-basic+1) - (check time=? utc-basic+2 tai->utc-basic+2) - (check time=? tai-basic+2 utc->tai-basic+2))) - - (define (tm:date= d1 d2) - (and (= (srfi:date-year d1) (srfi:date-year d2)) - (= (srfi:date-month d1) (srfi:date-month d2)) - (= (srfi:date-day d1) (srfi:date-day d2)) - (= (srfi:date-hour d1) (srfi:date-hour d2)) - (= (srfi:date-second d1) (srfi:date-second d2)) - (= (date-nanosecond d1) (date-nanosecond d2)) - (= (date-zone-offset d1) (date-zone-offset d2)))) - - ; Main module body ----------------------------- - - (test/text-ui srfi-19-test-suite) - - ) +(run-tests srfi-19-test-suite)