Changeset 38130 in project


Ignore:
Timestamp:
01/19/20 01:05:21 (5 weeks ago)
Author:
Kon Lovett
Message:

use test (already have dep), finer grain tests (TBD), tz params do not accept #f

Location:
release/5/srfi-19/trunk
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • release/5/srfi-19/trunk/srfi-19-common.scm

    r38082 r38130  
    1 ;;;; srfi-19-common.scm
     1;;;; srfi-19-common.scm  -*- Scheme -*-
    22
    33;; -- Miscellaneous Constants.
  • release/5/srfi-19/trunk/srfi-19-core.scm

    r38112 r38130  
    1 ;;;; srfi-19.scm
     1;;;; srfi-19.scm  -*- Scheme -*-
    22
    33(module srfi-19-core ()
  • release/5/srfi-19/trunk/srfi-19-date.scm

    r38129 r38130  
    1 ;;;; srfi-19-date.scm
     1;;;; srfi-19-date.scm  -*- Scheme -*-
    22;;;; Chicken port, Kon Lovett, Dec '05
    33
     
    199199
    200200(define (make-date ns sec min hr dy mn yr . args)
    201   (let-optionals args ((tzo (timezone-locale-offset)) (tzn #f) (dstf make-date-unique))
    202     (let ((no-dstf (eq? make-date-unique dstf)))
     201  (let-optionals args (
     202    (tzo (timezone-locale-offset))
     203    (tzn #f)
     204    (dstf make-date-unique) )
     205    (let (
     206      (no-dstf (eq? make-date-unique dstf)) )
    203207      (cond
    204208        ((timezone-components? tzo)
  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38112 r38130  
    1 ;;;; srfi-19-io.scm
     1;;;; srfi-19-io.scm  -*- Scheme -*-
    22;;;; Chicken port, Kon Lovett, Dec '05
    33
  • release/5/srfi-19/trunk/srfi-19-period.scm

    r38129 r38130  
    1 ;;;; srfi-19-period.scm
     1;;;; srfi-19-period.scm  -*- Scheme -*-
    22;;;; Chicken port, Kon Lovett, Apr '07
    33
  • release/5/srfi-19/trunk/srfi-19-support.scm

    r38126 r38130  
    1 ;;;; srfi-19-support.scm
     1;;;; srfi-19-support.scm  -*- Scheme -*-
    22;;;; Chicken port, Kon Lovett, Dec '05
    33
  • release/5/srfi-19/trunk/srfi-19-time.scm

    r38129 r38130  
    1 ;;;; srfi-19-time.scm
     1;;;; srfi-19-time.scm  -*- Scheme -*-
    22;;;; Chicken port, Kon Lovett, Dec '05
    33
  • release/5/srfi-19/trunk/srfi-19-timezone.scm

    r38126 r38130  
    1 ;;;;srfi-19-timezone.scm
     1;;;;srfi-19-timezone.scm  -*- Scheme -*-
    22
    33;;Issues
     
    4444;;
    4545
    46 (define-parameter local-timezone-locale #f
     46(define-parameter local-timezone-locale #t
    4747  (lambda (x)
    4848    (cond
    49       ((or (not x) (timezone-components? x))
     49      ((timezone-components? x)
    5050        x )
     51      ((and x (boolean? x))
     52        (current-timezone-components) )
    5153      (else
    5254        (warning-argument-type 'local-timezone-locale x 'timezone-components)
    5355        (local-timezone-locale) ) ) ) )
    5456
    55 (define-parameter utc-timezone-locale (make-utc-timezone)
     57(define-parameter utc-timezone-locale #t
    5658  (lambda (x)
    5759    (cond
    5860      ((timezone-components? x)
    5961        x )
     62      ((and x (boolean? x))
     63        (make-utc-timezone) )
    6064      (else
    6165        (warning-argument-type 'utc-timezone-locale x 'timezone-components)
    6266        (utc-timezone-locale) ) ) ) )
    63 
    64 ;;
    65 
    66 ;delay initializing `local-timezone-locale'
    67 (define (local-timezone-locale*)
    68   (or
    69     (local-timezone-locale)
    70     (begin
    71       (local-timezone-locale (current-timezone-components))
    72       (local-timezone-locale))) )
    7367
    7468;;
     
    8579    (tzc
    8680      (check-timezone-components 'timezone-locale-name
    87         (optional tzc (local-timezone-locale*))))
     81        (optional tzc (local-timezone-locale))))
    8882    (tzn
    8983      (timezone-components-ref/dst? tzc 'dst-name 'std-name)) )
     
    9892    (tzc
    9993      (check-timezone-components 'timezone-locale-offset
    100         (optional tzc (local-timezone-locale*))))
     94        (optional tzc (local-timezone-locale))))
    10195    (tzo
    10296      (timezone-components-ref/dst? tzc 'dst-offset 'std-offset)) )
     
    107101  (timezone-component-ref
    108102    (check-timezone-components 'timezone-locale-dst?
    109       (optional tzc (local-timezone-locale*)))
     103      (optional tzc (local-timezone-locale)))
    110104    'dst?) )
    111105
     
    123117  (cond
    124118    ((not tzi)                    (utc-timezone-locale))
    125     ((boolean? tzi)               (local-timezone-locale*))
     119    ((boolean? tzi)               (local-timezone-locale))
    126120    ((timezone-components? tzi)   tzi)
    127121    ((timezone-offset? tzi)       tzi)
  • release/5/srfi-19/trunk/srfi-19.egg

    r38126 r38130  
    22
    33((synopsis "Time Data Types and Procedures")
    4  (version "4.1.2")
     4 (version "4.2.0")
    55 (category data)
    66 (author "Will Fitzgerald (for Chicken by [[/users/kon-lovett]])")
  • release/5/srfi-19/trunk/srfi-19.scm

    r38112 r38130  
    1 ;;;; srfi-19.scm
     1;;;; srfi-19.scm  -*- Scheme -*-
    22
    33(module srfi-19 ()
  • release/5/srfi-19/trunk/tests/srfi-19-test.scm

    r38126 r38130  
    1 ;;; simple test procedures
     1;;;; srfi-19-test.scm  -*- Scheme -*-
     2
     3(import test)
     4
     5(test-begin "SRFI 19")
     6
     7;;;
    28
    39(import srfi-19)
    4 (import locale)    ;To force a locale
     10#;(import locale)    ;To force a locale
    511(import srfi-1)    ;For current-date w/o tz-locale test
    612(import format)    ;For conversion test
     
    915
    1016#; ;Unused
    11 (define (with-locale locstr thunk)
    12   (let ((curloc (current-locale)))
    13     (dynamic-wind
    14       (lambda () (current-locale locstr))
    15       thunk
    16       (lambda () (current-locale curloc))) ) )
     17(define-syntax with-locale
     18  (syntax-rules ()
     19    ((with-locale ?loc ?thunk)
     20      (let (
     21        (curloc (current-locale)) )
     22        (dynamic-wind
     23          (lambda () (current-locale ?loc))
     24          ?thunk
     25          (lambda () (current-locale curloc))) ) ) ) )
    1726
    1827;;
    1928
    20 (define (display! x #!optional (p (current-output-port)))
    21   (display x p)
    22   (flush-output p) )
    23 
    24 (define (newline! #!optional (p (current-output-port)))
    25   (newline p)
    26   (flush-output p) )
    27 
    28 (define s19-tests (list))
    29 
    30 (define (define-s19-test! name thunk)
    31   (let ((name (if (symbol? name) name (string->symbol name)))
    32         (pr (assoc name s19-tests)))
    33     (if pr
    34         (set-cdr! pr thunk)
    35         (set! s19-tests (append s19-tests (list (cons name thunk)))))))
    36 
    37 (define (run-s19-test-thunk thunk)
    38   (handle-exceptions #;as exn #;with exn #;for (thunk) ) )
    39 
    40 (define (run-s19-test name thunk verbose)
    41   (if verbose (begin (display! ";;; Running ") (display! name)))
    42   (let ((result (run-s19-test-thunk thunk)))
    43     (if verbose (begin (display! ": ") (display! (not (not result))) (newline!)))
    44     result ) )
    45 
    46 (define (run-s19-tests . verbose)
    47   (let ((runs 0) (goods 0) (bads 0) (verbose (and (not (null? verbose)) (car verbose))))
    48     (for-each (lambda (pr)
    49                 (set! runs (+ runs 1))
    50                 (if (run-s19-test (car pr) (cdr pr) verbose)
    51                     (set! goods (+ goods 1))
    52                     (set! bads (+ bads 1))))
    53               s19-tests)
    54     (if verbose
    55         (begin
    56           (display! ";;; Results: Runs: ")
    57           (display! runs)
    58           (display! "; Goods: ")
    59           (display! goods)
    60           (display! "; Bads: ")
    61           (display! bads)
    62           (if (> runs 0)
    63               (begin
    64                 (display! "; Pass rate: ")
    65                 (display! (/ goods runs)))
    66               (display! "; No tests."))
    67           (newline!)))
    68     (values runs goods bads)))
    69 
    70 ;;
    71 
    72 (define-s19-test! "Creating time structures"
    73   (lambda ()
    74     (not (null? (list (current-time time-tai)
    75                       (current-time time-utc)
    76                       (current-time time-monotonic)
    77                       (current-time time-thread)
    78                       (current-time time-process))))))
    79 
    80 (define-s19-test! "Testing time resolutions"
    81   (lambda ()
    82     (not (null? (list (time-resolution time-tai)
    83                       (time-resolution time-utc)
    84                       (time-resolution time-monotonic)
    85                       (time-resolution time-thread)
    86                       (time-resolution time-process))))))
    87 
    88 (define-s19-test! "Time nanos positive"
    89   (lambda ()
    90     (and-let* ((ct (current-time))
    91                ((time? ct)) )
    92       (not (negative? (time-nanosecond ct))) ) ) )
    93 
    94 (define-s19-test! "Time comparisons (time=?, etc.)"
    95   (lambda ()
    96     (let ((t1 (make-time time-utc 0 1))
    97           (t2 (make-time time-utc 0 1))
    98           (t3 (make-time time-utc 0 2))
    99           (t11 (make-time time-utc 1001 1))
    100           (t12 (make-time time-utc 1001 1))
    101           (t13 (make-time time-utc 1001 2)))
    102       (and (time=? t1 t2)
    103            (time>? t3 t2)
    104            (time<? t2 t3)
    105            (time>=? t1 t2)
    106            (time>=? t3 t2)
    107            (time<=? t1 t2)
    108            (time<=? t2 t3)
    109            (time=? t11 t12)
    110            (time>? t13 t12)
    111            (time<? t12 t13)
    112            (time>=? t11 t12)
    113            (time>=? t13 t12)
    114            (time<=? t11 t12)
    115            (time<=? t12 t13)
    116            ))))
    117 
    118 (define-s19-test! "Time difference"
    119   (lambda ()
    120     (let ((t1 (make-time time-utc 0 3000))
    121           (t2 (make-time time-utc 0 1000))
    122           (t3 (make-time time-duration 0 2000))
    123           (t4 (make-time time-duration 0 -2000)))
    124       (and
    125        (time=? t3 (time-difference t1 t2))
    126        (time=? t4 (time-difference t2 t1))))))
     29(test-assert "Creating time (current-time time-tai)" (current-time time-tai))
     30(test-assert "Creating time (current-time time-utc)" (current-time time-utc))
     31(test-assert "Creating time (current-time time-monotonic)" (current-time time-monotonic))
     32(test-assert "Creating time (current-time time-thread)" (current-time time-thread))
     33(test-assert "Creating time (current-time time-process)" (current-time time-process))
     34
     35(test-assert "Testing time (time-resolution time-tai)" (time-resolution time-tai))
     36(test-assert "Testing time (time-resolution time-utc)" (time-resolution time-utc))
     37(test-assert "Testing time (time-resolution time-monotonic)" (time-resolution time-monotonic))
     38(test-assert "Testing time (time-resolution time-thread)" (time-resolution time-thread))
     39(test-assert "Testing time (time-resolution time-process)" (time-resolution time-process))
     40
     41(test-assert "Time nanos positive"
     42  (and-let* (
     43    (ct (current-time))
     44    ((time? ct)) )
     45    (not (negative? (time-nanosecond ct)))))
     46
     47(let (
     48  (t1 (make-time time-utc 0 1))
     49  (t2 (make-time time-utc 0 1))
     50  (t3 (make-time time-utc 0 2))
     51  (t11 (make-time time-utc 1001 1))
     52  (t12 (make-time time-utc 1001 1))
     53  (t13 (make-time time-utc 1001 2)))
     54  (test-assert "Time comparison (time=? t1 t2)" (time=? t1 t2))
     55  (test-assert "Time comparison (time>? t3 t2)" (time>? t3 t2))
     56  (test-assert "Time comparison (time<? t2 t3)" (time<? t2 t3))
     57  (test-assert "Time comparison (time>=? t1 t2)" (time>=? t1 t2))
     58  (test-assert "Time comparison (time>=? t3 t2)" (time>=? t3 t2))
     59  (test-assert "Time comparison (time<=? t1 t2)" (time<=? t1 t2))
     60  (test-assert "Time comparison (time<=? t2 t3)" (time<=? t2 t3))
     61  (test-assert "Time comparison (time=? t11 t12)" (time=? t11 t12))
     62  (test-assert "Time comparison (time>? t13 t12)" (time>? t13 t12))
     63  (test-assert "Time comparison (time<? t12 t13)" (time<? t12 t13))
     64  (test-assert "Time comparison (time>=? t11 t12)" (time>=? t11 t12))
     65  (test-assert "Time comparison (time>=? t13 t12)" (time>=? t13 t12))
     66  (test-assert "Time comparison (time<=? t11 t12)" (time<=? t11 t12))
     67  (test-assert "Time comparison (time<=? t12 t13)" (time<=? t12 t13)) )
     68
     69(let (
     70  (t1 (make-time time-utc 0 3000))
     71  (t2 (make-time time-utc 0 1000))
     72  (t3 (make-time time-duration 0 2000))
     73  (t4 (make-time time-duration 0 -2000)))
     74  (test-assert "Time difference 1" (time=? t3 (time-difference t1 t2)))
     75  (test-assert "Time difference 2" (time=? t4 (time-difference t2 t1))) )
    12776
    12877(define (test-one-utc-tai-edge utc tai-diff tai-last-diff)
    12978  (let* (;; right on the edge they should be the same
    130          (utc-basic (make-time time-utc 0 utc))
    131          (tai-basic (make-time time-tai 0 (+ utc tai-diff)))
    132          (utc->tai-basic (time-utc->time-tai utc-basic))
    133          (tai->utc-basic (time-tai->time-utc tai-basic))
    134          ;; a second before they should be the old diff
    135          (utc-basic-1 (make-time time-utc 0 (- utc 1)))
    136          (tai-basic-1 (make-time time-tai 0 (- (+ utc tai-last-diff) 1)))
    137          (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
    138          (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
    139          ;; a second later they should be the new diff
    140          (utc-basic+1 (make-time time-utc 0 (+ utc 1)))
    141          (tai-basic+1 (make-time time-tai 0 (+ (+ utc tai-diff) 1)))
    142          (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
    143          (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
    144          ;; ok, let's move the clock half a month or so plus half a second
    145          (shy (* 15 24 60 60))
    146          (hs (/ (expt 10 9) 2))
    147          ;; a second later they should be the new diff
    148          (utc-basic+2 (make-time time-utc hs (+ utc shy)))
    149          (tai-basic+2 (make-time time-tai hs (+ (+ utc tai-diff) shy)))
    150          (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
    151          (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))
    152          )
    153     (and (time=? utc-basic tai->utc-basic)
    154          (time=? tai-basic utc->tai-basic)
    155          (time=? utc-basic-1 tai->utc-basic-1)
    156          (time=? tai-basic-1 utc->tai-basic-1)
    157          (time=? utc-basic+1 tai->utc-basic+1)
    158          (time=? tai-basic+1 utc->tai-basic+1)
    159          (time=? utc-basic+2 tai->utc-basic+2)
    160          (time=? tai-basic+2 utc->tai-basic+2)
    161          )))
    162 
    163 (define-s19-test! "TAI-UTC Conversions"
    164   (lambda ()
     79    (utc-basic (make-time time-utc 0 utc))
     80    (tai-basic (make-time time-tai 0 (+ utc tai-diff)))
     81    (utc->tai-basic (time-utc->time-tai utc-basic))
     82    (tai->utc-basic (time-tai->time-utc tai-basic))
     83    ;; a second before they should be the old diff
     84    (utc-basic-1 (make-time time-utc 0 (- utc 1)))
     85    (tai-basic-1 (make-time time-tai 0 (- (+ utc tai-last-diff) 1)))
     86    (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
     87    (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
     88    ;; a second later they should be the new diff
     89    (utc-basic+1 (make-time time-utc 0 (+ utc 1)))
     90    (tai-basic+1 (make-time time-tai 0 (+ (+ utc tai-diff) 1)))
     91    (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
     92    (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
     93    ;; ok, let's move the clock half a month or so plus half a second
     94    (shy (* 15 24 60 60))
     95    (hs (/ (expt 10 9) 2))
     96    ;; a second later they should be the new diff
     97    (utc-basic+2 (make-time time-utc hs (+ utc shy)))
     98    (tai-basic+2 (make-time time-tai hs (+ (+ utc tai-diff) shy)))
     99    (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
     100    (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)))
    165101    (and
    166      (test-one-utc-tai-edge 915148800  32 31)
    167      (test-one-utc-tai-edge 867715200  31 30)
    168      (test-one-utc-tai-edge 820454400  30 29)
    169      (test-one-utc-tai-edge 773020800  29 28)
    170      (test-one-utc-tai-edge 741484800  28 27)
    171      (test-one-utc-tai-edge 709948800  27 26)
    172      (test-one-utc-tai-edge 662688000  26 25)
    173      (test-one-utc-tai-edge 631152000  25 24)
    174      (test-one-utc-tai-edge 567993600  24 23)
    175      (test-one-utc-tai-edge 489024000  23 22)
    176      (test-one-utc-tai-edge 425865600  22 21)
    177      (test-one-utc-tai-edge 394329600  21 20)
    178      (test-one-utc-tai-edge 362793600  20 19)
    179      (test-one-utc-tai-edge 315532800  19 18)
    180      (test-one-utc-tai-edge 283996800  18 17)
    181      (test-one-utc-tai-edge 252460800  17 16)
    182      (test-one-utc-tai-edge 220924800  16 15)
    183      (test-one-utc-tai-edge 189302400  15 14)
    184      (test-one-utc-tai-edge 157766400  14 13)
    185      (test-one-utc-tai-edge 126230400  13 12)
    186      (test-one-utc-tai-edge 94694400   12 11)
    187      (test-one-utc-tai-edge 78796800   11 10)
    188      (test-one-utc-tai-edge 63072000   10 0)
    189      (test-one-utc-tai-edge 0          0  0) ;; at the epoch
    190      (test-one-utc-tai-edge 10         0  0) ;; close to it ...
    191      (test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
    192      )))
     102      (time=? utc-basic tai->utc-basic)
     103      (time=? tai-basic utc->tai-basic)
     104      (time=? utc-basic-1 tai->utc-basic-1)
     105      (time=? tai-basic-1 utc->tai-basic-1)
     106      (time=? utc-basic+1 tai->utc-basic+1)
     107      (time=? tai-basic+1 utc->tai-basic+1)
     108      (time=? utc-basic+2 tai->utc-basic+2)
     109      (time=? tai-basic+2 utc->tai-basic+2))))
     110
     111(test-assert "TAI-UTC Conversions"
     112  (and
     113    (test-one-utc-tai-edge 915148800  32 31)
     114    (test-one-utc-tai-edge 867715200  31 30)
     115    (test-one-utc-tai-edge 820454400  30 29)
     116    (test-one-utc-tai-edge 773020800  29 28)
     117    (test-one-utc-tai-edge 741484800  28 27)
     118    (test-one-utc-tai-edge 709948800  27 26)
     119    (test-one-utc-tai-edge 662688000  26 25)
     120    (test-one-utc-tai-edge 631152000  25 24)
     121    (test-one-utc-tai-edge 567993600  24 23)
     122    (test-one-utc-tai-edge 489024000  23 22)
     123    (test-one-utc-tai-edge 425865600  22 21)
     124    (test-one-utc-tai-edge 394329600  21 20)
     125    (test-one-utc-tai-edge 362793600  20 19)
     126    (test-one-utc-tai-edge 315532800  19 18)
     127    (test-one-utc-tai-edge 283996800  18 17)
     128    (test-one-utc-tai-edge 252460800  17 16)
     129    (test-one-utc-tai-edge 220924800  16 15)
     130    (test-one-utc-tai-edge 189302400  15 14)
     131    (test-one-utc-tai-edge 157766400  14 13)
     132    (test-one-utc-tai-edge 126230400  13 12)
     133    (test-one-utc-tai-edge 94694400   12 11)
     134    (test-one-utc-tai-edge 78796800   11 10)
     135    (test-one-utc-tai-edge 63072000   10 0)
     136    (test-one-utc-tai-edge 0          0  0) ;; at the epoch
     137    (test-one-utc-tai-edge 10         0  0) ;; close to it ...
     138    (test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
     139    ))
    193140
    194141(define (tm:date= d1 d2)
    195   (and (= (date-year d1) (date-year d2))
    196        (= (date-month d1) (date-month d2))
    197        (= (date-day d1) (date-day d2))
    198        (= (date-hour d1) (date-hour d2))
    199        (= (date-second d1) (date-second d2))
    200        (= (date-nanosecond d1) (date-nanosecond d2))
    201        (= (date-zone-offset d1) (date-zone-offset d2))))
    202 
    203 (define-s19-test! "TAI-Date Conversions"
    204   (lambda ()
     142  (and
     143    (= (date-year d1) (date-year d2))
     144    (= (date-month d1) (date-month d2))
     145    (= (date-day d1) (date-day d2))
     146    (= (date-hour d1) (date-hour d2))
     147    (= (date-second d1) (date-second d2))
     148    (= (date-nanosecond d1) (date-nanosecond d2))
     149    (= (date-zone-offset d1) (date-zone-offset d2))))
     150
     151(test-assert "TAI-Date Conversions"
     152  (and
     153    (tm:date=
     154      (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
     155      (make-date 0 58 59 23 31 12 1998 0))
     156    (tm:date=
     157      (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
     158      (make-date 0 59 59 23 31 12 1998 0))
     159    (tm:date=
     160      (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
     161      (make-date 0 60 59 23 31 12 1998 0))
     162    (tm:date=
     163      (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
     164      (make-date 0 0 0 0 1 1 1999 0))))
     165
     166(test-assert "Date-UTC Conversions"
     167  (and
     168    (time=?
     169      (make-time time-utc 0 (- 915148800 2))
     170      (date->time-utc (make-date 0 58 59 23 31 12 1998 0)))
     171    (time=?
     172      (make-time time-utc 0 (- 915148800 1))
     173      (date->time-utc (make-date 0 59 59 23 31 12 1998 0)))
     174     ;; yes, I think this is acutally right.
     175    (time=?
     176      (make-time time-utc 0 (- 915148800 0))
     177      (date->time-utc (make-date 0 60 59 23 31 12 1998 0)))
     178    (time=?
     179      (make-time time-utc 0 (- 915148800 0))
     180      (date->time-utc (make-date 0 0 0 0 1 1 1999 0)))
     181    (time=?
     182      (make-time time-utc 0 (+ 915148800 1))
     183      (date->time-utc (make-date 0 1 0 0 1 1 1999 0)))))
     184
     185(test-assert "TZ Offset conversions"
     186  (let (
     187    (ct-utc (make-time time-utc 6320000 1045944859))
     188    (ct-tai (make-time time-tai 6320000 1045944891))
     189    (cd (make-date 6320000 19 14 15 22 2 2003 -18000)))
    205190    (and
    206      (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
    207                (make-date 0 58 59 23 31 12 1998 0))
    208      (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
    209                (make-date 0 59 59 23 31 12 1998 0))
    210      (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
    211                (make-date 0 60 59 23 31 12 1998 0))
    212      (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
    213                (make-date 0 0 0 0 1 1 1999 0)))))
    214 
    215 (define-s19-test! "Date-UTC Conversions"
    216   (lambda ()
     191       (time=? ct-utc (date->time-utc cd))
     192       (time=? ct-tai (date->time-tai cd)))))
     193
     194(test-assert "date->string conversions"
     195  (equal? "~.Tue.Tuesday.Jun.June.Tue Jun 05 04:03:02-0200 2007.05.06/05/07. 5,02.000001,Jun.04"
     196    (date->string
     197      (make-date 1000 2 3 4 5 6 2007 -7200)
     198      "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H")))
     199
     200(test-assert "local-timezone-locale"
     201  (local-timezone-locale))
     202
     203(test-assert "string->date conversions"
     204  (equal?
     205    (make-date 0 53 4 0 19 10 2006 (local-timezone-locale))
     206    (string->date "2006/10/19 00:04:53" "~Y/~m/~d ~H:~M:~S")))
     207
     208(test-assert "date<->julian-day conversions"
     209  (let (
     210    (test-date (make-date 0 0 0 0 1 1 2003 -7200)))
    217211    (and
    218      (time=? (make-time time-utc 0 (- 915148800 2))
    219              (date->time-utc (make-date 0 58 59 23 31 12 1998 0)))
    220      (time=? (make-time time-utc 0 (- 915148800 1))
    221              (date->time-utc (make-date 0 59 59 23 31 12 1998 0)))
    222      ;; yes, I think this is acutally right.
    223      (time=? (make-time time-utc 0 (- 915148800 0))
    224              (date->time-utc (make-date 0 60 59 23 31 12 1998 0)))
    225      (time=? (make-time time-utc 0 (- 915148800 0))
    226              (date->time-utc (make-date 0 0 0 0 1 1 1999 0)))
    227      (time=? (make-time time-utc 0 (+ 915148800 1))
    228              (date->time-utc (make-date 0 1 0 0 1 1 1999 0))))))
    229 
    230 (define-s19-test! "TZ Offset conversions"
    231   (lambda ()
    232     (let ((ct-utc (make-time time-utc 6320000 1045944859))
    233           (ct-tai (make-time time-tai 6320000 1045944891))
    234           (cd (make-date 6320000 19 14 15 22 2 2003 -18000)))
    235       (and
    236        (time=? ct-utc (date->time-utc cd))
    237        (time=? ct-tai (date->time-tai cd))))))
    238 
    239 (define-s19-test! "date->string conversions"
    240   (lambda ()
    241     (equal? "~.Tue.Tuesday.Jun.June.Tue Jun 05 04:03:02-0200 2007.05.06/05/07. 5,02.000001,Jun.04"
    242              (date->string (make-date 1000 2 3 4 5 6 2007 -7200)
    243                                        "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H"))))
    244 
    245 (define-s19-test! "string->date conversions"
    246   (lambda ()
    247     (equal? (make-date 0 53 4 0 19 10 2006 (local-timezone-locale))
    248             (string->date "2006/10/19 00:04:53" "~Y/~m/~d ~H:~M:~S"))))
    249 
    250 (define-s19-test! "date<->julian-day conversions"
    251   (lambda ()
    252    (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
    253      (and (tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))
    254           (= 365
    255              (- (date->julian-day (make-date 0 0 0 0 1 1 2004 0))
    256                 (date->julian-day (make-date 0 0 0 0 1 1 2003 0))))))))
    257 
    258 (define-s19-test! "date->modified-julian-day conversions"
    259   (lambda ()
    260     (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
    261       (and (tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))
    262            (= 365
    263               (- (date->modified-julian-day (make-date 0 0 0 0 1 1 2004 0))
    264                  (date->modified-julian-day (make-date 0 0 0 0 1 1 2003 0))))))))
    265 
    266 (define-s19-test! "Time -> Date"
    267   (lambda ()
    268     (time->date (current-time))))
    269 
    270 (define-s19-test! "date-year-day [2.5 bad argument type for car]"
    271   (lambda ()
    272     (= 1 (date-year-day (make-date 0 0 0 0 1 1 2007 0)))))
    273 
    274 (define-s19-test! "~1 date->string [2.5 ISO-8601 conversion]"
    275   (lambda ()
    276     (equal? "2007-01-01" (date->string (string->date "2007-01-01" "~Y-~m-~d") "~1"))))
    277 
    278 (define-s19-test! "milliseconds->time [2.6.1 was using NS/S for conversion!]"
    279   (lambda ()
    280     (let ([tim (milliseconds->time 10000)])
    281       (and (= 10 (time-second tim))
    282            (= 0 (time-nanosecond tim))))))
    283 
    284 (define-s19-test! "Only one minute [2.6.1 current-date w/o tz-locale was doing dst conversion!]"
    285   (lambda ()
    286     (let ([lst
    287             (delete-duplicates
    288               (fold
    289                 (lambda (n acc)
    290                   (cons (date-minute (current-date)) acc))
    291                 '()
    292                 ;This number needs to be low enough that the fold completes
    293                 ;in sub-minute time (easy to achieve).
    294                 (iota 2000)))])
    295       (= 1 (length lst)))))
    296 
    297 (define-s19-test! "Conversion"
    298   (lambda ()
    299 
    300     (define (vector->date1 vec)
    301       (make-date
    302         0 0 0 0
    303         (vector-ref vec 2)
    304         (vector-ref vec 1)
    305         (vector-ref vec 0)
    306         0))
    307 
    308     (define (vector->date2 vec)
    309       (string->date
    310         (format "~4,48D~2,48D~2,48DZ" ; ZULU timezone!
    311                 (vector-ref vec 0)
    312                 (vector-ref vec 1)
    313                 (vector-ref vec 2))
    314         "~Y~m~d~z"))
    315 
    316     (define (to-time obj ->date)
    317       (cond
    318         ((time? obj)   obj)
    319         ((date? obj)   (date->time-utc obj))
    320         ((vector? obj) (date->time-utc (->date obj)))))
    321 
    322     (define (distance-of-time ->date from to)
    323       (let* ((from-time (to-time from ->date))
    324              (to-time (to-time to ->date))
    325              (diff (time-difference from-time to-time))
    326              (distance-in-seconds (time-second diff)))
    327         distance-in-seconds))
    328 
    329     (define vec1 (vector 2006 12 21))
    330     (define vec2 (vector 2006 12 19))
    331     (define vec3 (vector 2006 12 20))
    332 
    333     (define tod (current-date))
    334 
    335     (let ([d1-1 (distance-of-time vector->date1 vec1 tod)]
    336           [d1-2 (distance-of-time vector->date1 vec1 vec2)]
    337           [d1-3 (distance-of-time vector->date1 vec3 tod)]
    338           [d2-1 (distance-of-time vector->date2 vec1 tod)]
    339           [d2-2 (distance-of-time vector->date2 vec1 vec2)]
    340           [d2-3 (distance-of-time vector->date2 vec3 tod)])
    341       (and (= d1-1 d2-1) (= d1-2 d2-2) (= d1-3 d2-3)))))
    342 
    343 (define-s19-test! "date-week-number"
    344   (lambda ()
    345     (and (eqv? 0 (date-week-number (make-date 0 0 0 0 1 1 2007 0) 0))
    346          (eqv? 51 (date-week-number (make-date 0 0 0 0 27 12 2006 0) 1)))))
    347 
    348 (define-s19-test! "date-week-day"
    349   (lambda ()
    350     (and (eqv? 1 (date-week-day (make-date 0 0 0 0 1 1 2007 0)))
    351          (eqv? 3 (date-week-day (make-date 0 0 0 0 27 12 2006 0))))))
    352 
    353 (define-s19-test! "2010 leap seconds"
    354   (lambda ()
    355     (and (= 1230768032
    356             (time-second
    357              (date->time-tai (make-date 0 59 59 23 31 12 2008 0))))
    358          (= 1230768033
    359             (time-second
    360              (date->time-tai (make-date 0 60 59 23 31 12 2008 0))))
    361          (= 1230768034
    362             (time-second
    363              (date->time-tai (make-date 0 0 0 0 1 1 2009 0))))) ) )
     212      (tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))
     213      (=
     214        365
     215        (- (date->julian-day (make-date 0 0 0 0 1 1 2004 0))
     216        (date->julian-day (make-date 0 0 0 0 1 1 2003 0)))))))
     217
     218(test-assert "date->modified-julian-day conversions"
     219  (let (
     220    (test-date (make-date 0 0 0 0 1 1 2003 -7200)))
     221    (and
     222      (tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))
     223      (=
     224        365
     225        (-
     226          (date->modified-julian-day (make-date 0 0 0 0 1 1 2004 0))
     227          (date->modified-julian-day (make-date 0 0 0 0 1 1 2003 0)))))))
     228
     229(test-assert "Time -> Date"
     230  (time->date (current-time)))
     231
     232(test-assert "date-year-day [2.5 bad argument type for car]"
     233  (= 1 (date-year-day (make-date 0 0 0 0 1 1 2007 0))))
     234
     235(test-assert "~1 date->string [2.5 ISO-8601 conversion]"
     236  (equal? "2007-01-01" (date->string (string->date "2007-01-01" "~Y-~m-~d") "~1")))
     237
     238(test-assert "milliseconds->time [2.6.1 was using NS/S for conv!]"
     239  (let (
     240    (tim (milliseconds->time 10000)) )
     241  (and
     242    (= 10 (time-second tim))
     243    (= 0 (time-nanosecond tim)))))
     244
     245(test-assert "Only one minute [2.6.1 current-date w/o tz-locale doing dst conv!]"
     246  (let (
     247    (lst
     248      (delete-duplicates
     249        (fold
     250          (lambda (n acc)
     251            (cons (date-minute (current-date)) acc))
     252          '()
     253          ;This number needs to be low enough that the fold completes
     254          ;in sub-minute time (easy to achieve).
     255          (iota 2000)))) )
     256    (= 1 (length lst))))
     257
     258(let ()
     259
     260  (define (vector->date1 vec)
     261    (make-date
     262      0 0 0 0
     263      (vector-ref vec 2)
     264      (vector-ref vec 1)
     265      (vector-ref vec 0)
     266      0))
     267
     268  (define (vector->date2 vec)
     269    (string->date
     270      (format "~4,48D~2,48D~2,48DZ" ; ZULU timezone!
     271              (vector-ref vec 0)
     272              (vector-ref vec 1)
     273              (vector-ref vec 2))
     274      "~Y~m~d~z"))
     275
     276  (define (to-time obj ->date)
     277    (cond
     278      ((time? obj)   obj)
     279      ((date? obj)   (date->time-utc obj))
     280      ((vector? obj) (date->time-utc (->date obj)))))
     281
     282  (define (distance-of-time ->date from to)
     283    (let* (
     284      (from-time (to-time from ->date))
     285      (to-time (to-time to ->date))
     286      (diff (time-difference from-time to-time))
     287      (distance-in-seconds (time-second diff)))
     288      distance-in-seconds))
     289
     290  (define vec1 (vector 2006 12 21))
     291  (define vec2 (vector 2006 12 19))
     292  (define vec3 (vector 2006 12 20))
     293
     294  (define tod (current-date))
     295
     296  (test-assert "Conversion"
     297    (let (
     298      (d1-1 (distance-of-time vector->date1 vec1 tod))
     299      (d1-2 (distance-of-time vector->date1 vec1 vec2))
     300      (d1-3 (distance-of-time vector->date1 vec3 tod))
     301      (d2-1 (distance-of-time vector->date2 vec1 tod))
     302      (d2-2 (distance-of-time vector->date2 vec1 vec2))
     303      (d2-3 (distance-of-time vector->date2 vec3 tod)))
     304      (and (= d1-1 d2-1) (= d1-2 d2-2) (= d1-3 d2-3)))) )
     305
     306(test-assert "date-week-number"
     307  (and
     308    (eqv? 0 (date-week-number (make-date 0 0 0 0 1 1 2007 0) 0))
     309    (eqv? 51 (date-week-number (make-date 0 0 0 0 27 12 2006 0) 1))))
     310
     311(test-assert "date-week-day"
     312  (and
     313    (eqv? 1 (date-week-day (make-date 0 0 0 0 1 1 2007 0)))
     314  (eqv? 3 (date-week-day (make-date 0 0 0 0 27 12 2006 0)))))
     315
     316(test-assert "2010 leap seconds"
     317  (and
     318    (=
     319      1230768032
     320      (time-second
     321      (date->time-tai (make-date 0 59 59 23 31 12 2008 0))))
     322    (=
     323      1230768033
     324      (time-second
     325      (date->time-tai (make-date 0 60 59 23 31 12 2008 0))))
     326    (=
     327      1230768034
     328      (time-second
     329      (date->time-tai (make-date 0 0 0 0 1 1 2009 0))))))
    364330
    365331;BUG 121
     
    372338;Duplicate short & long month name keys (`may')
    373339#; ;FIXME Needs method of swapping i18n bundles
    374 (define-s19-test! "Valid month of may"
    375   (lambda ()
    376     (with-locale "es_AR.utf8"
    377       (lambda ()
    378         (date=? (string->date "16 de Mayo de 2007" "~d de ~B de ~Y")
    379                 (make-date 0 0 0 0 16 5 2007)))) ) )
    380 
    381 (define-s19-test! "Date Add Duration"
    382   (lambda ()
    383     (let ((dt (make-date 0 59 59 23 31 12 2008 0))
    384           (dr (make-duration days: 3)) )
    385       (let ((tdt (date-add-duration dt dr)))
    386         (date=? tdt (make-date 0 59 59 23 3 1 2009 0)) ) ) ) )
    387 
    388 (define-s19-test! "Date Subtract Duration"
    389   (lambda ()
    390     (let ((dt (make-date 0 59 59 23 31 12 2008 0))
    391           (dr (make-duration days: 3)) )
    392       (let ((tdt (date-subtract-duration dt dr)))
    393         (date=? tdt (make-date 0 59 59 23 28 12 2008 0)) ) ) ) )
    394 
    395 (define-s19-test! "#966 does not recognise the first item in abbreviation vectors for any language"
    396   (lambda ()
    397     (date=? (scan-date "Mon, 12 Jan 2014 03:46:09 +0100" "~a, ~d ~b ~Y ~H:~M:~S ~z")
    398             (make-date 0 9 46 3 12 1 2014 3600))
    399     (date=? (scan-date "Sun, 12 Jan 2014 03:46:09 +0100" "~a, ~d ~b ~Y ~H:~M:~S ~z")
    400             (make-date 0 9 46 3 12 1 2014 3600)) ) )
    401 
    402 (define-s19-test! "date-adjust-last-day"
    403   (lambda ()
    404     (let ((jan31 (make-date 0 0 0 0 31 1 2010 3600))
    405           (feb28 (make-date 0 0 0 0 28 2 2010 3600)) )
     340(test-assert "Valid month of may"
     341  (with-locale "es_AR.utf8"
     342    (lambda ()
    406343      (date=?
    407         feb28
    408         (date-adjust jan31 1 'months)) ) ) )
    409 
    410 (define-s19-test! "date-adjust-dst-dys-fixed"
    411   (lambda ()
    412     (let ((m (make-date 0 0 0 5 12 3 2011)))
    413       (= (date-hour m) (date-hour (date-adjust m 1 'days))) ) ) )
    414 
    415 (define-s19-test! "date-adjust-dst-dys-day"
    416   (lambda ()
    417     (let ((m (make-date 0 0 0 5 12 3 2011)))
    418       (= (+ 1 (date-day m)) (date-day (date-adjust m 1 'days))) ) ) )
    419 
    420 (define-s19-test! "date-adjust-dst-hrs-fixed"
    421   (lambda ()
    422     (let ((m (make-date 0 0 0 5 12 3 2011)))
    423       (= (date-hour m) (date-hour (date-adjust m 24 'hours))) ) ) )
    424 
    425 (define-s19-test! "date-adjust-dst-hrs-day"
    426   (lambda ()
    427     (let ((m (make-date 0 0 0 5 12 3 2011)))
    428       (= (+ 1 (date-day m)) (date-day (date-adjust m 24 'hours))) ) ) )
     344        (string->date "16 de Mayo de 2007" "~d de ~B de ~Y")
     345        (make-date 0 0 0 0 16 5 2007)))))
     346
     347(test-assert "Date Add Duration"
     348  (let (
     349    (dt (make-date 0 59 59 23 31 12 2008 0))
     350    (dr (make-duration days: 3)) )
     351    (let (
     352      (tdt (date-add-duration dt dr)))
     353      (date=? tdt (make-date 0 59 59 23 3 1 2009 0)))))
     354
     355(test-assert "Date Subtract Duration"
     356  (let (
     357    (dt (make-date 0 59 59 23 31 12 2008 0))
     358    (dr (make-duration days: 3)) )
     359    (let (
     360      (tdt (date-subtract-duration dt dr)))
     361      (date=? tdt (make-date 0 59 59 23 28 12 2008 0)))))
     362
     363(test-assert "#966 does not recognise the first item in abbrev vectors for any lang"
     364  (and
     365    (date=?
     366      (scan-date "Mon, 12 Jan 2014 03:46:09 +0100" "~a, ~d ~b ~Y ~H:~M:~S ~z")
     367      (make-date 0 9 46 3 12 1 2014 3600))
     368    (date=?
     369      (scan-date "Sun, 12 Jan 2014 03:46:09 +0100" "~a, ~d ~b ~Y ~H:~M:~S ~z")
     370      (make-date 0 9 46 3 12 1 2014 3600))))
     371
     372(test-assert "date-adjust-last-day"
     373  (let (
     374    (jan31 (make-date 0 0 0 0 31 1 2010 3600))
     375    (feb28 (make-date 0 0 0 0 28 2 2010 3600)) )
     376    (date=?
     377      feb28
     378      (date-adjust jan31 1 'months))))
     379
     380(test-assert "date-adjust-dst-dys-fixed"
     381  (let (
     382    (m (make-date 0 0 0 5 12 3 2011)))
     383    (= (date-hour m) (date-hour (date-adjust m 1 'days)))))
     384
     385(test-assert "date-adjust-dst-dys-day"
     386  (let (
     387    (m (make-date 0 0 0 5 12 3 2011)))
     388    (= (+ 1 (date-day m)) (date-day (date-adjust m 1 'days)))))
     389
     390(test-assert "date-adjust-dst-hrs-fixed"
     391  (let (
     392    (m (make-date 0 0 0 5 12 3 2011)))
     393    (= (date-hour m) (date-hour (date-adjust m 24 'hours)))))
     394
     395(test-assert "date-adjust-dst-hrs-day"
     396  (let (
     397    (m (make-date 0 0 0 5 12 3 2011)))
     398    (= (+ 1 (date-day m)) (date-day (date-adjust m 24 'hours)))))
    429399
    430400;NOTE MomentJS says:
     
    437407
    438408#;
    439 (define-s19-test! "date-adjust-dst-hrs"
    440   (lambda ()
    441     (let ((m (make-date 0 0 0 5 12 3 2011)))
    442       (= (+ 1 (date-hour m)) (date-hour (date-adjust m 24 'hours))) ) ) )
     409(test-assert "date-adjust-dst-hrs"
     410  (let (
     411    (m (make-date 0 0 0 5 12 3 2011)))
     412    (= (+ 1 (date-hour m)) (date-hour (date-adjust m 24 'hours)))))
    443413
    444414;BUG #1000
    445 (define-s19-test! "srfi-18-time-works"
    446   (lambda ()
    447     (let ((m (make-date 0 0 0 0 21 3 2013)))
    448       (let ((tim (date->time m)))
    449         (time=? tim (srfi-18-time->time (time->srfi-18-time tim))) ) ) ) )
    450 
    451 (define-s19-test! "seconds 0 <-> date"
    452   (lambda ()
    453     (= 0 (date->seconds (seconds->date 0))) ) )
     415(test-assert "srfi-18-time-works"
     416  (let (
     417    (m (make-date 0 0 0 0 21 3 2013)))
     418    (let (
     419      (tim (date->time m)))
     420      (time=?
     421        tim
     422        (add-duration
     423          (zero-time 'utc')
     424          (srfi-18-time->time (time->srfi-18-time tim)))))))
     425
     426(test-assert "seconds 0 <-> date"
     427  (= 0 (date->seconds (seconds->date 0))))
    454428
    455429;reported by tokyo_jesus on #chicken irc
    456 (define-s19-test! "(seconds->date 250.0) failed due to flonum seconds->utc-time argument"
    457   (lambda ()
    458     (seconds->date 250.0) ))
    459 
    460 (define-s19-test! "(seconds->date 250) failed"
    461   (lambda ()
    462     (seconds->date 250) ))
    463 
    464 (define-s19-test! "(current-date) failed"
    465   (lambda ()
    466     (current-date) ))
     430(test-assert "(seconds->date 250.0) failed due to flonum seconds->utc-time argument"
     431  (seconds->date 250.0))
     432
     433(test-assert "(seconds->date 250) failed"
     434  (seconds->date 250))
     435
     436(test-assert "(current-date) failed"
     437  (current-date))
    467438
    468439; Duration
     
    474445(import srfi-19-period)
    475446
    476 ;;
    477 
    478 (newline)
    479 (let-values (((runs goods bads) (run-s19-tests #t)))
    480   (exit (if (zero? bads) 0 1)) )
    481 
     447;;;
     448
     449(test-end "SRFI 19")
     450
     451(test-exit)
Note: See TracChangeset for help on using the changeset viewer.