Commit | Line | Data |
---|---|---|
025f75b4 MV |
1 | ;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- |
2 | ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 | |
3 | ;;;; | |
6e7d5622 | 4 | ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. |
176d0e0b | 5 | ;;;; |
025f75b4 MV |
6 | ;;;; This program is free software; you can redistribute it and/or modify |
7 | ;;;; it under the terms of the GNU General Public License as published by | |
8 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
9 | ;;;; any later version. | |
176d0e0b | 10 | ;;;; |
025f75b4 MV |
11 | ;;;; This program is distributed in the hope that it will be useful, |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;;; GNU General Public License for more details. | |
176d0e0b | 15 | ;;;; |
025f75b4 MV |
16 | ;;;; You should have received a copy of the GNU General Public License |
17 | ;;;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
18 | ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
19 | ;;;; Boston, MA 02110-1301 USA | |
025f75b4 MV |
20 | |
21 | ;; SRFI-19 overrides current-date, so we have to do the test in a | |
22 | ;; separate module, or later tests will fail. | |
23 | ||
24 | (define-module (test-suite test-srfi-19) | |
cd6f7d0b | 25 | :duplicates (last) ;; avoid warning about srfi-19 replacing `current-time' |
025f75b4 MV |
26 | :use-module (test-suite lib) |
27 | :use-module (srfi srfi-19) | |
28 | :use-module (ice-9 format)) | |
29 | ||
30 | (define (with-tz* tz thunk) | |
31 | "Temporarily set the TZ environment variable to the passed string | |
32 | value and call THUNK." | |
33 | (let ((old-tz #f)) | |
34 | (dynamic-wind | |
35 | (lambda () | |
36 | (set! old-tz (getenv "TZ")) | |
37 | (putenv (format "TZ=~A" tz))) | |
38 | thunk | |
39 | (lambda () | |
40 | (if old-tz | |
41 | (putenv (format "TZ=~A" old-tz)) | |
42 | (putenv "TZ")))))) | |
43 | ||
44 | (defmacro with-tz (tz . body) | |
45 | `(with-tz* ,tz (lambda () ,@body))) | |
46 | ||
47 | (define (test-integral-time-structure date->time) | |
48 | "Test whether the given DATE->TIME procedure creates a time | |
49 | structure with integral seconds. (The seconds shall be maintained as | |
50 | integers, or precision may go away silently. The SRFI-19 reference | |
51 | implementation was not OK for Guile in this respect because of Guile's | |
52 | incomplete numerical tower implementation.)" | |
53 | (pass-if (format "~A makes integer seconds" | |
54 | date->time) | |
55 | (exact? (time-second | |
176d0e0b | 56 | (date->time (make-date 0 0 0 12 1 6 2001 0)))))) |
025f75b4 MV |
57 | |
58 | (define (test-time->date time->date date->time) | |
59 | (pass-if (format "~A works" | |
60 | time->date) | |
61 | (begin | |
62 | (time->date (date->time (make-date 0 0 0 12 1 6 2001 0))) | |
63 | #t))) | |
64 | ||
65 | (define (test-dst time->date date->time) | |
66 | (pass-if (format "~A respects local DST if no TZ-OFFSET given" | |
67 | time->date) | |
68 | (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0)))) | |
957f3c2b KR |
69 | ;; on 2001-06-01, there should be 4 hours zone offset |
70 | ;; between EST (EDT) and GMT | |
025f75b4 | 71 | (= (date-zone-offset |
957f3c2b | 72 | (with-tz "EST5EDT" |
025f75b4 | 73 | (time->date time))) |
957f3c2b | 74 | -14400)))) |
025f75b4 MV |
75 | |
76 | (define-macro (test-time-conversion a b) | |
77 | (let* ((a->b-sym (symbol-append a '-> b)) | |
78 | (b->a-sym (symbol-append b '-> a))) | |
79 | `(pass-if (format "~A and ~A work and are inverses of each other" | |
80 | ',a->b-sym ',b->a-sym) | |
81 | (let ((time (make-time ,a 12345 67890123))) | |
82 | (time=? time (,b->a-sym (,a->b-sym time))))))) | |
83 | ||
176d0e0b TTN |
84 | (define (test-time-comparison cmp a b) |
85 | (pass-if (format #f "~A works" cmp) | |
86 | (cmp a b))) | |
87 | ||
88 | (define (test-time-arithmetic op a b res) | |
89 | (pass-if (format #f "~A works" op) | |
90 | (time=? (op a b) res))) | |
91 | ||
c992cc96 KR |
92 | ;; return true if time objects X and Y are equal |
93 | (define (time-equal? x y) | |
94 | (and (eq? (time-type x) (time-type y)) | |
95 | (eqv? (time-second x) (time-second y)) | |
96 | (eqv? (time-nanosecond x) (time-nanosecond y)))) | |
97 | ||
025f75b4 MV |
98 | (with-test-prefix "SRFI date/time library" |
99 | ;; check for typos and silly errors | |
100 | (pass-if "date-zone-offset is defined" | |
101 | (and (defined? 'date-zone-offset) | |
102 | date-zone-offset | |
176d0e0b | 103 | #t)) |
025f75b4 MV |
104 | (pass-if "add-duration is defined" |
105 | (and (defined? 'add-duration) | |
106 | add-duration | |
107 | #t)) | |
108 | (pass-if "(current-time time-tai) works" | |
109 | (begin (current-time time-tai) #t)) | |
110 | (test-time-conversion time-utc time-tai) | |
111 | (test-time-conversion time-utc time-monotonic) | |
112 | (test-time-conversion time-tai time-monotonic) | |
113 | (pass-if "string->date works" | |
114 | (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M") | |
115 | #t)) | |
116 | ;; check for code paths where reals were passed to quotient, which | |
117 | ;; doesn't work in Guile (and is unspecified in R5RS) | |
118 | (test-time->date time-utc->date date->time-utc) | |
119 | (test-time->date time-tai->date date->time-tai) | |
120 | (test-time->date time-monotonic->date date->time-monotonic) | |
121 | (pass-if "Fractional nanoseconds are handled" | |
122 | (begin (make-time time-duration 1000000000.5 0) #t)) | |
123 | ;; the seconds in a time shall be maintained as integers, or | |
124 | ;; precision may silently go away | |
125 | (test-integral-time-structure date->time-utc) | |
126 | (test-integral-time-structure date->time-tai) | |
127 | (test-integral-time-structure date->time-monotonic) | |
128 | ;; check for DST and zone related problems | |
129 | (pass-if "date->time-utc is the inverse of time-utc->date" | |
130 | (let ((time (date->time-utc | |
131 | (make-date 0 0 0 14 1 6 2001 7200)))) | |
132 | (time=? time | |
133 | (date->time-utc (time-utc->date time 7200))))) | |
134 | (test-dst time-utc->date date->time-utc) | |
135 | (test-dst time-tai->date date->time-tai) | |
136 | (test-dst time-monotonic->date date->time-monotonic) | |
137 | (test-dst julian-day->date date->julian-day) | |
138 | (test-dst modified-julian-day->date date->modified-julian-day) | |
139 | (pass-if "string->date respects local DST if no time zone is read" | |
140 | (time=? (date->time-utc | |
957f3c2b KR |
141 | (with-tz "EST5EDT" |
142 | (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M"))) | |
025f75b4 | 143 | (date->time-utc |
176d0e0b TTN |
144 | (make-date 0 0 0 12 1 6 2001 0)))) |
145 | ;; check time comparison procedures | |
146 | (let* ((time1 (make-time time-monotonic 0 0)) | |
147 | (time2 (make-time time-monotonic 0 0)) | |
148 | (time3 (make-time time-monotonic 385907 998360432)) | |
149 | (time4 (make-time time-monotonic 385907 998360432))) | |
150 | (test-time-comparison time<=? time1 time3) | |
151 | (test-time-comparison time<? time1 time3) | |
152 | (test-time-comparison time=? time1 time2) | |
153 | (test-time-comparison time>=? time3 time3) | |
154 | (test-time-comparison time>? time3 time2)) | |
155 | ;; check time arithmetic procedures | |
156 | (let* ((time1 (make-time time-monotonic 0 0)) | |
157 | (time2 (make-time time-monotonic 385907 998360432)) | |
158 | (diff (time-difference time2 time1))) | |
159 | (test-time-arithmetic add-duration time1 diff time2) | |
01dbf76f KR |
160 | (test-time-arithmetic subtract-duration time2 diff time1)) |
161 | ||
c992cc96 KR |
162 | (with-test-prefix "date->time-tai" |
163 | ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2 | |
164 | ;; seconds of TAI in date->time-tai | |
165 | (pass-if "31dec98 23:59:59" | |
166 | (time-equal? (make-time time-tai 0 915148830) | |
167 | (date->time-tai (make-date 0 59 59 23 31 12 1998 0)))) | |
168 | (pass-if "1jan99 0:00:00" | |
169 | (time-equal? (make-time time-tai 0 915148832) | |
170 | (date->time-tai (make-date 0 0 0 0 1 1 1999 0)))) | |
171 | ||
172 | ;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2 | |
173 | ;; seconds of TAI in date->time-tai | |
174 | (pass-if "31dec05 23:59:59" | |
175 | (time-equal? (make-time time-tai 0 1136073631) | |
176 | (date->time-tai (make-date 0 59 59 23 31 12 2005 0)))) | |
177 | (pass-if "1jan06 0:00:00" | |
178 | (time-equal? (make-time time-tai 0 1136073633) | |
179 | (date->time-tai (make-date 0 0 0 0 1 1 2006 0))))) | |
180 | ||
01dbf76f KR |
181 | (with-test-prefix "date-week-number" |
182 | (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0))) | |
183 | (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0))) | |
184 | (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0))))) | |
185 | ||
025f75b4 MV |
186 | |
187 | ;; Local Variables: | |
188 | ;; eval: (put 'with-tz 'scheme-indent-function 1) | |
189 | ;; End: |