[bpt/guile.git] / test-suite / tests / srfi-19.test

;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
;;;; 	Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

;; SRFI-19 overrides current-date, so we have to do the test in a
;; separate module, or later tests will fail.

(define-module (test-suite test-srfi-19)
  :duplicates (last)  ;; avoid warning about srfi-19 replacing `current-time'
  :use-module (test-suite lib)
  :use-module (srfi srfi-19)
  :use-module (ice-9 format))

;; Make sure we use the default locale.
(setlocale LC_ALL "C")

(define (with-tz* tz thunk)
  "Temporarily set the TZ environment variable to the passed string
value and call THUNK."
  (let ((old-tz #f))
    (dynamic-wind
	(lambda ()
	  (set! old-tz (getenv "TZ"))
	  (putenv (format "TZ=~A" tz)))
	thunk
	(lambda ()
	  (if old-tz
	      (putenv (format "TZ=~A" old-tz))
	      (putenv "TZ"))))))

(defmacro with-tz (tz . body)
  `(with-tz* ,tz (lambda () ,@body)))

(define (test-integral-time-structure date->time)
  "Test whether the given DATE->TIME procedure creates a time
structure with integral seconds.  (The seconds shall be maintained as
integers, or precision may go away silently.  The SRFI-19 reference
implementation was not OK for Guile in this respect because of Guile's
incomplete numerical tower implementation.)"
  (pass-if (format "~A makes integer seconds"
		   date->time)
	   (exact? (time-second
		    (date->time (make-date 0 0 0 12 1 6 2001 0))))))

(define (test-time->date time->date date->time)
  (pass-if (format "~A works"
		   time->date)
	   (begin
	     (time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
	     #t)))

(define (test-dst time->date date->time)
  (pass-if (format "~A respects local DST if no TZ-OFFSET given"
		   time->date)
	   (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
	     ;; on 2001-06-01, there should be 4 hours zone offset
	     ;; between EST (EDT) and GMT
	     (= (date-zone-offset
		 (with-tz "EST5EDT"
		   (time->date time)))
		-14400))))

(define-macro (test-time-conversion a b)
  (let* ((a->b-sym (symbol-append a '-> b))
	 (b->a-sym (symbol-append b '-> a)))
    `(pass-if (format "~A and ~A work and are inverses of each other"
		      ',a->b-sym ',b->a-sym)
	      (let ((time (make-time ,a 12345 67890123)))
		(time=? time (,b->a-sym (,a->b-sym time)))))))

(define (test-time-comparison cmp a b)
  (pass-if (format #f "~A works" cmp)
           (cmp a b)))

(define (test-time-arithmetic op a b res)
  (pass-if (format #f "~A works" op)
           (time=? (op a b) res)))

;; return true if time objects X and Y are equal
(define (time-equal? x y)
  (and (eq?  (time-type x)       (time-type y))
       (eqv? (time-second x)     (time-second y))
       (eqv? (time-nanosecond x) (time-nanosecond y))))

(with-test-prefix "SRFI date/time library"
  ;; check for typos and silly errors
  (pass-if "date-zone-offset is defined"
	   (and (defined? 'date-zone-offset)
		date-zone-offset
		#t))
  (pass-if "add-duration is defined"
	   (and (defined? 'add-duration)
		add-duration
		#t))
  (pass-if "(current-time time-tai) works"
	   (time? (current-time time-tai)))
  (pass-if "(current-time time-process) works"
           (time? (current-time time-process)))
  (test-time-conversion time-utc time-tai)
  (test-time-conversion time-utc time-monotonic)
  (test-time-conversion time-tai time-monotonic)
  (pass-if "string->date works"
	   (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
		  #t))
  ;; check for code paths where reals were passed to quotient, which
  ;; doesn't work in Guile (and is unspecified in R5RS)
  (test-time->date time-utc->date date->time-utc)
  (test-time->date time-tai->date date->time-tai)
  (test-time->date time-monotonic->date date->time-monotonic)
  (pass-if "Fractional nanoseconds are handled"
	   (begin (make-time time-duration 1000000000.5 0) #t))
  ;; the seconds in a time shall be maintained as integers, or
  ;; precision may silently go away
  (test-integral-time-structure date->time-utc)
  (test-integral-time-structure date->time-tai)
  (test-integral-time-structure date->time-monotonic)
  ;; check for DST and zone related problems
  (pass-if "date->time-utc is the inverse of time-utc->date"
	   (let ((time (date->time-utc
			(make-date 0 0 0 14 1 6 2001 7200))))
	     (time=? time
		     (date->time-utc (time-utc->date time 7200)))))
  (test-dst time-utc->date date->time-utc)
  (test-dst time-tai->date date->time-tai)
  (test-dst time-monotonic->date date->time-monotonic)
  (test-dst julian-day->date date->julian-day)
  (test-dst modified-julian-day->date date->modified-julian-day)
  (pass-if "string->date respects local DST if no time zone is read"
	   (time=? (date->time-utc
		    (with-tz "EST5EDT"
		      (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
		   (date->time-utc
		    (make-date 0 0 0 12 1 6 2001 0))))
  (pass-if "string->date understands days and months"
           (time=? (let ((d (string->date "Saturday, December 9, 2006"
                                          "~A, ~B ~d, ~Y")))
                     (date->time-utc (make-date (date-nanosecond d)
                                                (date-second d)
                                                (date-minute d)
                                                (date-hour d)
                                                (date-day d)
                                                (date-month d)
                                                (date-year d)
                                                0)))
                   (date->time-utc
                    (make-date 0 0 0 0 9 12 2006 0))))
  ;; check time comparison procedures
  (let* ((time1 (make-time time-monotonic 0 0))
         (time2 (make-time time-monotonic 0 0))
         (time3 (make-time time-monotonic 385907 998360432))
         (time4 (make-time time-monotonic 385907 998360432)))
    (test-time-comparison time<=? time1 time3)
    (test-time-comparison time<?  time1 time3)
    (test-time-comparison time=?  time1 time2)
    (test-time-comparison time>=? time3 time3)
    (test-time-comparison time>?  time3 time2))
  ;; check time arithmetic procedures
  (let* ((time1 (make-time time-monotonic 0 0))
         (time2 (make-time time-monotonic 385907 998360432))
         (diff (time-difference time2 time1)))
    (test-time-arithmetic add-duration time1 diff time2)
    (test-time-arithmetic subtract-duration time2 diff time1))

  (with-test-prefix "date->time-tai"
    ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
    ;; seconds of TAI in date->time-tai
    (pass-if "31dec98 23:59:59"
      (time-equal? (make-time time-tai 0 915148830)
		   (date->time-tai (make-date 0 59 59 23 31 12 1998 0))))
    (pass-if "1jan99 0:00:00"
      (time-equal? (make-time time-tai 0 915148832)
		   (date->time-tai (make-date 0 0  0  0   1  1 1999 0))))

    ;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2
    ;; seconds of TAI in date->time-tai
    (pass-if "31dec05 23:59:59"
      (time-equal? (make-time time-tai 0 1136073631)
		   (date->time-tai (make-date 0 59 59 23 31 12 2005 0))))
    (pass-if "1jan06 0:00:00"
      (time-equal? (make-time time-tai 0 1136073633)
		   (date->time-tai (make-date 0 0  0  0   1  1 2006 0)))))

  (with-test-prefix "date-week-number"
    (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
    (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))
    (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))))


;; Local Variables:
;; eval: (put 'with-tz 'scheme-indent-function 1)
;; End:
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	;;;;
c122500a	4	;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007 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
025f75b4 MV	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,
92205699 MV	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
a2f00b9b LC	30	;; Make sure we use the default locale.
	31	(setlocale LC_ALL "C")
	32
025f75b4 MV	33	(define (with-tz* tz thunk)
	34	"Temporarily set the TZ environment variable to the passed string
	35	value and call THUNK."
	36	(let ((old-tz #f))
	37	(dynamic-wind
	38	(lambda ()
	39	(set! old-tz (getenv "TZ"))
	40	(putenv (format "TZ=~A" tz)))
	41	thunk
	42	(lambda ()
	43	(if old-tz
	44	(putenv (format "TZ=~A" old-tz))
	45	(putenv "TZ"))))))
	46
	47	(defmacro with-tz (tz . body)
	48	`(with-tz* ,tz (lambda () ,@body)))
	49
	50	(define (test-integral-time-structure date->time)
	51	"Test whether the given DATE->TIME procedure creates a time
	52	structure with integral seconds. (The seconds shall be maintained as
	53	integers, or precision may go away silently. The SRFI-19 reference
	54	implementation was not OK for Guile in this respect because of Guile's
	55	incomplete numerical tower implementation.)"
	56	(pass-if (format "~A makes integer seconds"
	57	date->time)
	58	(exact? (time-second
176d0e0b	59	(date->time (make-date 0 0 0 12 1 6 2001 0))))))
025f75b4 MV	60
	61	(define (test-time->date time->date date->time)
	62	(pass-if (format "~A works"
	63	time->date)
	64	(begin
	65	(time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
	66	#t)))
	67
	68	(define (test-dst time->date date->time)
	69	(pass-if (format "~A respects local DST if no TZ-OFFSET given"
	70	time->date)
	71	(let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
957f3c2b KR	72	;; on 2001-06-01, there should be 4 hours zone offset
957f3c2b KR	73	;; between EST (EDT) and GMT
025f75b4	74	(= (date-zone-offset
957f3c2b	75	(with-tz "EST5EDT"
025f75b4	76	(time->date time)))
957f3c2b	77	-14400))))
025f75b4 MV	78
	79	(define-macro (test-time-conversion a b)
	80	(let* ((a->b-sym (symbol-append a '-> b))
	81	(b->a-sym (symbol-append b '-> a)))
	82	`(pass-if (format "~A and ~A work and are inverses of each other"
	83	',a->b-sym ',b->a-sym)
	84	(let ((time (make-time ,a 12345 67890123)))
	85	(time=? time (,b->a-sym (,a->b-sym time)))))))
	86
176d0e0b TTN	87	(define (test-time-comparison cmp a b)
	88	(pass-if (format #f "~A works" cmp)
	89	(cmp a b)))
	90
	91	(define (test-time-arithmetic op a b res)
	92	(pass-if (format #f "~A works" op)
	93	(time=? (op a b) res)))
	94
c992cc96 KR	95	;; return true if time objects X and Y are equal
	96	(define (time-equal? x y)
	97	(and (eq? (time-type x) (time-type y))
	98	(eqv? (time-second x) (time-second y))
	99	(eqv? (time-nanosecond x) (time-nanosecond y))))
	100
025f75b4 MV	101	(with-test-prefix "SRFI date/time library"
	102	;; check for typos and silly errors
	103	(pass-if "date-zone-offset is defined"
	104	(and (defined? 'date-zone-offset)
	105	date-zone-offset
176d0e0b	106	#t))
025f75b4 MV	107	(pass-if "add-duration is defined"
	108	(and (defined? 'add-duration)
	109	add-duration
	110	#t))
	111	(pass-if "(current-time time-tai) works"
a7db5522 LC	112	(time? (current-time time-tai)))
	113	(pass-if "(current-time time-process) works"
	114	(time? (current-time time-process)))
025f75b4 MV	115	(test-time-conversion time-utc time-tai)
	116	(test-time-conversion time-utc time-monotonic)
	117	(test-time-conversion time-tai time-monotonic)
	118	(pass-if "string->date works"
	119	(begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
	120	#t))
	121	;; check for code paths where reals were passed to quotient, which
	122	;; doesn't work in Guile (and is unspecified in R5RS)
	123	(test-time->date time-utc->date date->time-utc)
	124	(test-time->date time-tai->date date->time-tai)
	125	(test-time->date time-monotonic->date date->time-monotonic)
	126	(pass-if "Fractional nanoseconds are handled"
	127	(begin (make-time time-duration 1000000000.5 0) #t))
	128	;; the seconds in a time shall be maintained as integers, or
	129	;; precision may silently go away
	130	(test-integral-time-structure date->time-utc)
	131	(test-integral-time-structure date->time-tai)
	132	(test-integral-time-structure date->time-monotonic)
	133	;; check for DST and zone related problems
	134	(pass-if "date->time-utc is the inverse of time-utc->date"
	135	(let ((time (date->time-utc
	136	(make-date 0 0 0 14 1 6 2001 7200))))
	137	(time=? time
	138	(date->time-utc (time-utc->date time 7200)))))
	139	(test-dst time-utc->date date->time-utc)
	140	(test-dst time-tai->date date->time-tai)
	141	(test-dst time-monotonic->date date->time-monotonic)
	142	(test-dst julian-day->date date->julian-day)
	143	(test-dst modified-julian-day->date date->modified-julian-day)
	144	(pass-if "string->date respects local DST if no time zone is read"
	145	(time=? (date->time-utc
957f3c2b KR	146	(with-tz "EST5EDT"
957f3c2b KR	147	(string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
025f75b4	148	(date->time-utc
176d0e0b	149	(make-date 0 0 0 12 1 6 2001 0))))
a2f00b9b LC	150	(pass-if "string->date understands days and months"
	151	(time=? (let ((d (string->date "Saturday, December 9, 2006"
	152	"~A, ~B ~d, ~Y")))
	153	(date->time-utc (make-date (date-nanosecond d)
	154	(date-second d)
	155	(date-minute d)
	156	(date-hour d)
	157	(date-day d)
	158	(date-month d)
	159	(date-year d)
	160	0)))
	161	(date->time-utc
	162	(make-date 0 0 0 0 9 12 2006 0))))
176d0e0b TTN	163	;; check time comparison procedures
	164	(let* ((time1 (make-time time-monotonic 0 0))
	165	(time2 (make-time time-monotonic 0 0))
	166	(time3 (make-time time-monotonic 385907 998360432))
	167	(time4 (make-time time-monotonic 385907 998360432)))
	168	(test-time-comparison time<=? time1 time3)
	169	(test-time-comparison time<? time1 time3)
	170	(test-time-comparison time=? time1 time2)
	171	(test-time-comparison time>=? time3 time3)
	172	(test-time-comparison time>? time3 time2))
	173	;; check time arithmetic procedures
	174	(let* ((time1 (make-time time-monotonic 0 0))
	175	(time2 (make-time time-monotonic 385907 998360432))
	176	(diff (time-difference time2 time1)))
	177	(test-time-arithmetic add-duration time1 diff time2)
01dbf76f KR	178	(test-time-arithmetic subtract-duration time2 diff time1))
01dbf76f KR	179
c992cc96 KR	180	(with-test-prefix "date->time-tai"
	181	;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
	182	;; seconds of TAI in date->time-tai
	183	(pass-if "31dec98 23:59:59"
	184	(time-equal? (make-time time-tai 0 915148830)
	185	(date->time-tai (make-date 0 59 59 23 31 12 1998 0))))
	186	(pass-if "1jan99 0:00:00"
	187	(time-equal? (make-time time-tai 0 915148832)
	188	(date->time-tai (make-date 0 0 0 0 1 1 1999 0))))
	189
	190	;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2
	191	;; seconds of TAI in date->time-tai
	192	(pass-if "31dec05 23:59:59"
	193	(time-equal? (make-time time-tai 0 1136073631)
	194	(date->time-tai (make-date 0 59 59 23 31 12 2005 0))))
	195	(pass-if "1jan06 0:00:00"
	196	(time-equal? (make-time time-tai 0 1136073633)
	197	(date->time-tai (make-date 0 0 0 0 1 1 2006 0)))))
	198
01dbf76f KR	199	(with-test-prefix "date-week-number"
	200	(pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
	201	(pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))
	202	(pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))))
	203
025f75b4 MV	204
	205	;; Local Variables:
	206	;; eval: (put 'with-tz 'scheme-indent-function 1)
	207	;; End: