test-suite/tests/srfi-19.test

   1 ;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
   2 ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
   3 ;;;;
   4 ;;;;    Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc.
   5 ;;;;
   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.
  10 ;;;;
  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.
  15 ;;;;
  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
  18 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  19 ;;;; Boston, MA 02111-1307 USA
  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)
  25   :use-module (test-suite lib)
  26   :use-module (srfi srfi-19)
  27   :use-module (ice-9 format))
  28
  29 (define (with-tz* tz thunk)
  30   "Temporarily set the TZ environment variable to the passed string
  31 value and call THUNK."
  32   (let ((old-tz #f))
  33     (dynamic-wind
  34         (lambda ()
  35           (set! old-tz (getenv "TZ"))
  36           (putenv (format "TZ=~A" tz)))
  37         thunk
  38         (lambda ()
  39           (if old-tz
  40               (putenv (format "TZ=~A" old-tz))
  41               (putenv "TZ"))))))
  42
  43 (defmacro with-tz (tz . body)
  44   `(with-tz* ,tz (lambda () ,@body)))
  45
  46 (define (test-integral-time-structure date->time)
  47   "Test whether the given DATE->TIME procedure creates a time
  48 structure with integral seconds.  (The seconds shall be maintained as
  49 integers, or precision may go away silently.  The SRFI-19 reference
  50 implementation was not OK for Guile in this respect because of Guile's
  51 incomplete numerical tower implementation.)"
  52   (pass-if (format "~A makes integer seconds"
  53                    date->time)
  54            (exact? (time-second
  55                     (date->time (make-date 0 0 0 12 1 6 2001 0))))))
  56
  57 (define (test-time->date time->date date->time)
  58   (pass-if (format "~A works"
  59                    time->date)
  60            (begin
  61              (time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
  62              #t)))
  63
  64 (define (test-dst time->date date->time)
  65   (pass-if (format "~A respects local DST if no TZ-OFFSET given"
  66                    time->date)
  67            (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
  68              ;; on 2001-06-01, there should be 4 hours zone offset
  69              ;; between EST (EDT) and GMT
  70              (= (date-zone-offset
  71                  (with-tz "EST5EDT"
  72                    (time->date time)))
  73                 -14400))))
  74
  75 (define-macro (test-time-conversion a b)
  76   (let* ((a->b-sym (symbol-append a '-> b))
  77          (b->a-sym (symbol-append b '-> a)))
  78     `(pass-if (format "~A and ~A work and are inverses of each other"
  79                       ',a->b-sym ',b->a-sym)
  80               (let ((time (make-time ,a 12345 67890123)))
  81                 (time=? time (,b->a-sym (,a->b-sym time)))))))
  82
  83 (define (test-time-comparison cmp a b)
  84   (pass-if (format #f "~A works" cmp)
  85            (cmp a b)))
  86
  87 (define (test-time-arithmetic op a b res)
  88   (pass-if (format #f "~A works" op)
  89            (time=? (op a b) res)))
  90
  91 (with-test-prefix "SRFI date/time library"
  92   ;; check for typos and silly errors
  93   (pass-if "date-zone-offset is defined"
  94            (and (defined? 'date-zone-offset)
  95                 date-zone-offset
  96                 #t))
  97   (pass-if "add-duration is defined"
  98            (and (defined? 'add-duration)
  99                 add-duration
 100                 #t))
 101   (pass-if "(current-time time-tai) works"
 102            (begin (current-time time-tai) #t))
 103   (test-time-conversion time-utc time-tai)
 104   (test-time-conversion time-utc time-monotonic)
 105   (test-time-conversion time-tai time-monotonic)
 106   (pass-if "string->date works"
 107            (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
 108                   #t))
 109   ;; check for code paths where reals were passed to quotient, which
 110   ;; doesn't work in Guile (and is unspecified in R5RS)
 111   (test-time->date time-utc->date date->time-utc)
 112   (test-time->date time-tai->date date->time-tai)
 113   (test-time->date time-monotonic->date date->time-monotonic)
 114   (pass-if "Fractional nanoseconds are handled"
 115            (begin (make-time time-duration 1000000000.5 0) #t))
 116   ;; the seconds in a time shall be maintained as integers, or
 117   ;; precision may silently go away
 118   (test-integral-time-structure date->time-utc)
 119   (test-integral-time-structure date->time-tai)
 120   (test-integral-time-structure date->time-monotonic)
 121   ;; check for DST and zone related problems
 122   (pass-if "date->time-utc is the inverse of time-utc->date"
 123            (let ((time (date->time-utc
 124                         (make-date 0 0 0 14 1 6 2001 7200))))
 125              (time=? time
 126                      (date->time-utc (time-utc->date time 7200)))))
 127   (test-dst time-utc->date date->time-utc)
 128   (test-dst time-tai->date date->time-tai)
 129   (test-dst time-monotonic->date date->time-monotonic)
 130   (test-dst julian-day->date date->julian-day)
 131   (test-dst modified-julian-day->date date->modified-julian-day)
 132   (pass-if "string->date respects local DST if no time zone is read"
 133            (time=? (date->time-utc
 134                     (with-tz "EST5EDT"
 135                       (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
 136                    (date->time-utc
 137                     (make-date 0 0 0 12 1 6 2001 0))))
 138   ;; check time comparison procedures
 139   (let* ((time1 (make-time time-monotonic 0 0))
 140          (time2 (make-time time-monotonic 0 0))
 141          (time3 (make-time time-monotonic 385907 998360432))
 142          (time4 (make-time time-monotonic 385907 998360432)))
 143     (test-time-comparison time<=? time1 time3)
 144     (test-time-comparison time<?  time1 time3)
 145     (test-time-comparison time=?  time1 time2)
 146     (test-time-comparison time>=? time3 time3)
 147     (test-time-comparison time>?  time3 time2))
 148   ;; check time arithmetic procedures
 149   (let* ((time1 (make-time time-monotonic 0 0))
 150          (time2 (make-time time-monotonic 385907 998360432))
 151          (diff (time-difference time2 time1)))
 152     (test-time-arithmetic add-duration time1 diff time2)
 153     (test-time-arithmetic subtract-duration time2 diff time1))
 154
 155   (with-test-prefix "date-week-number"
 156     (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
 157     (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))
 158     (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))))
 159
 160
 161 ;; Local Variables:
 162 ;; eval: (put 'with-tz 'scheme-indent-function 1)
 163 ;; End: