suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

updated srfi 19 tests from dave gurnell

Browse Source 
svn: r17084
This commit is contained in:
John Clements 2009-11-28 02:31:17 +00:00
parent 97a41443a9
commit b2bcfdbec9
1 changed files with 135 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
collects/tests/srfi/19/tests.ss
View File

@ -1,24 +1,34 @@
(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)) (define-check (check-comparisons comparison times expected)
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))) (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))) (define cur-tz (date-zone-offset (current-date)))
; Test suite ----------------------------------- ; Test suite -------------------------------------
(define srfi-19-test-suite (define srfi-19-test-suite
(test-suite (test-suite "Tests for SRFI 19"
"Tests for SRFI 19"
(test-not-exn (test-not-exn "Creating time structures"
"Creating time structures"
(lambda () (lambda ()
(list (current-time 'time-tai) (list (current-time 'time-tai)
(current-time 'time-utc) (current-time 'time-utc)
@ -26,8 +36,7 @@
(current-time 'time-thread) (current-time 'time-thread)
(current-time 'time-process)))) (current-time 'time-process))))
(test-not-exn (test-not-exn "Testing time resolutions"
"Testing time resolutions"
(lambda () (lambda ()
(list (time-resolution 'time-tai) (list (time-resolution 'time-tai)
(time-resolution 'time-utc) (time-resolution 'time-utc)
@ -35,31 +44,33 @@
(time-resolution 'time-thread) (time-resolution 'time-thread)
(time-resolution 'time-process)))) (time-resolution 'time-process))))
(test-case (test-case "Time comparisons (time=?, etc.)"
"Time comparisons (time=?, etc.)" (let ([t0 (make-time 'time-utc 0 1)]
(let ((t1 (make-time 'time-utc 0 1)) [t1 (make-time 'time-utc 0 1)]
(t2 (make-time 'time-utc 0 1)) [t2 (make-time 'time-utc 1 1)]
(t3 (make-time 'time-utc 0 2)) [t3 (make-time 'time-utc 0 2)])
(t11 (make-time 'time-utc 1001 1)) (check-comparisons time=? (list t0 t1 t2 t3) '((#t #t #f #f)
(t12 (make-time 'time-utc 1001 1)) (#t #t #f #f)
(t13 (make-time 'time-utc 1001 2))) (#f #f #t #f)
(check time=? t1 t2) (#f #f #f #t)))
(check time>? t3 t2) (check-comparisons time<? (list t0 t1 t2 t3) '((#f #f #t #t)
(check time<? t2 t3) (#f #f #t #t)
(check time>=? t1 t2) (#f #f #f #t)
(check time>=? t3 t2) (#f #f #f #f)))
(check time<=? t1 t2) (check-comparisons time>? (list t0 t1 t2 t3) '((#f #f #f #f)
(check time<=? t2 t3) (#f #f #f #f)
(check time=? t11 t12) (#t #t #f #f)
(check time>? t13 t12) (#t #t #t #f)))
(check time<? t12 t13) (check-comparisons time<=? (list t0 t1 t2 t3) '((#t #t #t #t)
(check time>=? t11 t12) (#t #t #t #t)
(check time>=? t13 t12) (#f #f #t #t)
(check time<=? t11 t12) (#f #f #f #t)))
(check time<=? t12 t13))) (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 (test-case "Time difference"
"Time difference"
(let ((t1 (make-time 'time-utc 0 3000)) (let ((t1 (make-time 'time-utc 0 3000))
(t2 (make-time 'time-utc 0 1000)) (t2 (make-time 'time-utc 0 1000))
(t3 (make-time 'time-duration 0 2000)) (t3 (make-time 'time-duration 0 2000))
@ -67,8 +78,7 @@
(check time=? t3 (time-difference t1 t2)) (check time=? t3 (time-difference t1 t2))
(check time=? t4 (time-difference t2 t1)))) (check time=? t4 (time-difference t2 t1))))
(test-case (test-case "TAI-UTC Conversions"
"TAI-UTC Conversions"
(check-one-utc-tai-edge 915148800 32 31) (check-one-utc-tai-edge 915148800 32 31)
(check-one-utc-tai-edge 867715200 31 30) (check-one-utc-tai-edge 867715200 31 30)
(check-one-utc-tai-edge 820454400 30 29) (check-one-utc-tai-edge 820454400 30 29)
@ -96,14 +106,7 @@
(check-one-utc-tai-edge 10 0 0) ;; close to it ... (check-one-utc-tai-edge 10 0 0) ;; close to it ...
(check-one-utc-tai-edge 1045789645 32 32)) ;; about now ... (check-one-utc-tai-edge 1045789645 32 32)) ;; about now ...
(test-case (test-case "TAI-Date Conversions"
"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"
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0) (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)) (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) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
@ -113,8 +116,7 @@
(check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 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))) (srfi:make-date 0 0 0 0 1 1 1999 0)))
(test-case (test-case "Date-UTC Conversions"
"Date-UTC Conversions"
(check time=? (make-time time-utc 0 (- 915148800 2)) (check time=? (make-time time-utc 0 (- 915148800 2))
(date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0))) (date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0)))
(check time=? (make-time time-utc 0 (- 915148800 1)) (check time=? (make-time time-utc 0 (- 915148800 1))
@ -127,8 +129,7 @@
(check time=? (make-time time-utc 0 (+ 915148800 1)) (check time=? (make-time time-utc 0 (+ 915148800 1))
(date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0)))) (date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0))))
(test-case (test-case "TZ Offset conversions"
"TZ Offset conversions"
(let ((ct-utc (make-time time-utc 6320000 1045944859)) (let ((ct-utc (make-time time-utc 6320000 1045944859))
(ct-tai (make-time time-tai 6320000 1045944891)) (ct-tai (make-time time-tai 6320000 1045944891))
(cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000))) (cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000)))
@ -138,32 +139,25 @@
;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going ;; 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... ;; to change the test case to match the implementation...
(test-case (test-case "date->string conversions"
"date->string conversions"
(check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120)) (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") "~~ @ ~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") "~ @ 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 (test-case "[DJG] date->string conversions of dates with nanosecond components"
"[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 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 0) "~N") "012345678")
(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 0) "~N") "001234567")
(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 0) "~N") "000123456")
(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 0) "~N") "000012345")
(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 0) "~N") "000001234")
(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 0) "~N") "000000123")
(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 0) "~N") "000000012")
(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 0) "~N") "000000001"))
(check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 cur-tz) "~N") "000000001"))
(test-case (test-case "[DJG] string->date conversions of dates with nanosecond components"
"[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.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.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") (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")
@ -183,25 +177,21 @@
(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.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")) (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 (test-case "date<->julian-day conversion"
"date<->julian-day conversion"
(check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (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)))) (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)]) (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)))) (check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))))
(test-case (test-case "date->modified-julian-day conversion"
"date->modified-julian-day conversion"
(check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (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)))) (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)]) (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)
(define-check (check-one-utc-tai-edge utc tai-diff tai-last-diff)
(let* (;; right on the edge they should be the same (let* (;; right on the edge they should be the same
(utc-basic (make-time 'time-utc 0 utc)) (utc-basic (make-time 'time-utc 0 utc))
(tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) (tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
@ -238,7 +228,7 @@
(check time=? utc-basic+2 tai->utc-basic+2) (check time=? utc-basic+2 tai->utc-basic+2)
(check time=? tai-basic+2 utc->tai-basic+2))) (check time=? tai-basic+2 utc->tai-basic+2)))
(define (tm:date= d1 d2) (define (tm:date= d1 d2)
(and (= (srfi:date-year d1) (srfi:date-year d2)) (and (= (srfi:date-year d1) (srfi:date-year d2))
(= (srfi:date-month d1) (srfi:date-month d2)) (= (srfi:date-month d1) (srfi:date-month d2))
(= (srfi:date-day d1) (srfi:date-day d2)) (= (srfi:date-day d1) (srfi:date-day d2))
@ -247,8 +237,6 @@
(= (date-nanosecond d1) (date-nanosecond d2)) (= (date-nanosecond d1) (date-nanosecond d2))
(= (date-zone-offset d1) (date-zone-offset d2)))) (= (date-zone-offset d1) (date-zone-offset d2))))
; Main module body ----------------------------- ; Main module body -------------------------------
(test/text-ui srfi-19-test-suite) (run-tests srfi-19-test-suite)
)