Changeset 15754 in project


Ignore:
Timestamp:
09/06/09 19:56:59 (10 years ago)
Author:
Kon Lovett
Message:

Save

Location:
release/4/srfi-19/trunk
Files:
2 added
1 deleted
6 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-19/trunk/srfi-19-core.scm

    r15751 r15754  
    1 ;;;; srfi-19-core.scm
    2 ;;;; Chicken port, Kon Lovett, Dec '05
    3 
    4 ;; SRFI-19: Time Data Types and Procedures.
    5 ;;
    6 ;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
    7 ;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
    8 ;;
    9 ;; This document and translations of it may be copied and furnished to others,
    10 ;; and derivative works that comment on or otherwise explain it or assist in its
    11 ;; implementation may be prepared, copied, published and distributed, in whole or
    12 ;; in part, without restriction of any kind, provided that the above copyright
    13 ;; notice and this paragraph are included on all such copies and derivative works.
    14 ;; However, this document itself may not be modified in any way, such as by
    15 ;; removing the copyright notice or references to the Scheme Request For
    16 ;; Implementation process or editors, except as needed for the purpose of
    17 ;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
    18 ;; process must be followed, or as required to translate it into languages other
    19 ;; than English.
    20 ;;
    21 ;; The limited permissions granted above are perpetual and will not be revoked
    22 ;; by the authors or their successors or assigns.
    23 ;;
    24 ;; This document and the information contained herein is provided on an "AS IS"
    25 ;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
    26 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
    27 ;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
    28 ;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
     1;;;; srfi-19.scm
    292
    303(module srfi-19-core (;export
    31   ; SRFI-19
     4  ;; SRFI-19
    325  time-tai
    336  time-utc
     
    4316  time-resolution
    4417  make-time
     18  time?
    4519  time-type
    4620  time-nanosecond
     
    7347  leap-year? ; Actually part of SRFI 19 but not in original document
    7448  date-year-day
    75   days-in-month/year
    76   natural-year
    7749  date-week-day
    7850  date-week-number
     
    11183  time-utc->time-tai
    11284  time-utc->time-tai!
    113   ; Extensions
     85  ;; SRFI-19 extensions
    11486  one-second-duration
    11587  one-nanosecond-duration
     
    139111  read-leap-second-table
    140112  time->milliseconds
     113  time->seconds
    141114  milliseconds->time
    142115  milliseconds->seconds
    143116  time->date
    144   timezone-locale-name
    145   timezone-locale-offset
    146   timezone-locale-dst?
    147   local-timezone-locale
    148   utc-timezone-locale
    149117  default-date-clock-type
    150118  date-zone-name
     
    165133  time->modified-julian-day
    166134  date-compare
    167   time-compare)
     135  time-compare
     136  ;; SRFI-19 extensions
     137  timezone-name?
     138  timezone-info?
     139  local-timezone-locale
     140  utc-timezone-locale
     141  timezone-locale-name
     142  timezone-locale-offset
     143  timezone-locale-dst?)
    168144
    169   (import (except scheme zero? negative? positive? real?)
    170           chicken
    171           #;srfi-8
    172           (only srfi-18 seconds->time time->seconds)
    173           (rename srfi-18 (seconds->time srfi-18:seconds->time) (time->seconds srfi-18:time->seconds))
    174           (only numbers zero? negative? positive? real?)
    175           miscmacros
    176           (only locale-components check-timezone-components timezone-components?)
    177           type-checks
    178           type-errors
    179           srfi-19-timezone
    180           srfi-19-support)
    181 
    182   (require-library #;srfi-8 srfi-18 numbers miscmacros locale-components
    183                    type-checks type-errors
    184                    srfi-19-timezone srfi-19-support)
    185 
    186 ;;;
    187 
    188 (define (check-real loc obj #!optional argnam)
    189   (unless (real? obj)
    190     (error-argument-type loc "real number" argnam) ) )
    191 
    192 (define (check-raw-seconds loc obj) (check-real loc obj 'seconds))
    193 
    194 (define (check-raw-milliseconds loc obj) (check-real loc obj 'milliseconds))
    195 
    196 ;;
    197 
    198 ;;
    199 
    200 (define (read-leap-second-table flnm)
    201   (check-string 'read-leap-second-table flnm) ;FIXME should be check-pathname
    202   (tm:read-leap-second-table flnm) )
    203 
    204 ;; Time Type Constants (not used internally)
    205 
    206 (define time-duration   'duration)
    207 (define time-gc         'gc)
    208 (define time-monotonic  'monotonic)
    209 (define time-process    'process)
    210 (define time-tai        'tai)
    211 (define time-thread     'thread)
    212 (define time-utc        'utc)
    213 
    214 ;; Time CTORs
    215 
    216 (define (one-second-duration) (tm:make-time 'duration 0 1))
    217 (define (one-nanosecond-duration) (tm:make-time 'duration 1 0))
    218 (define (zero-time tt) (check-time-type 'zero-time tt) (tm:make-time tt 0 0))
    219 
    220 (define (make-time tt ns sec)
    221   (check-time-elements 'make-time tt ns sec)
    222   (tm:make-time tt ns sec) )
    223 
    224 (define (make-duration
    225           #!key (days 0)
    226                 (hours 0) (minutes 0) (seconds 0)
    227                 (milliseconds 0) (microseconds 0) (nanoseconds 0))
    228   (check-real 'make-duration days "days")
    229   (check-real 'make-duration hours "hours")
    230   (check-real 'make-duration minutes "minutes")
    231   (check-real 'make-duration seconds "seconds")
    232   (check-real 'make-duration milliseconds "milliseconds")
    233   (check-real 'make-duration microseconds "microseconds")
    234   (check-real 'make-duration nanoseconds "nanoseconds")
    235   (receive (ns sec)
    236       (tm:duration-elements->time-values days hours minutes seconds
    237                                          milliseconds microseconds nanoseconds)
    238     (check-time-elements 'make-duration 'duration ns sec)
    239     (tm:make-time 'duration ns sec) ) )
    240 
    241 (define (copy-time tim)
    242   (check-time 'copy-time tim)
    243   (tm:copy-time tim) )
    244 
    245 ;; Converts a seconds value, may be fractional, into a time type.
    246 ;; The type of time default is time-duration.
    247 
    248 (define (seconds->time/type sec . args)
    249   (check-raw-seconds 'seconds->time/type sec)
    250   (let-optionals args ((tt 'duration))
    251     (check-time-type 'seconds->time/type tt)
    252     (tm:seconds->time sec tt) ) )
    253 
    254 ;; Time record-type operations
    255 
    256 (define (time-type tim)
    257   (check-time 'time-type tim)
    258   (tm:time-type tim) )
    259 
    260 (define (time-nanosecond tim)
    261   (check-time 'time-nanosecond tim)
    262   (tm:time-nanosecond tim) )
    263 
    264 (define (time-second tim)
    265   (check-time 'time-second tim)
    266   (tm:time-second tim) )
    267 
    268 (define (set-time-type! tim tt)
    269   (check-time 'set-time-type! tim)
    270   (check-time-type 'set-time-type! tt)
    271   (tm:time-type-set! tim tt) )
    272 
    273 (define (set-time-nanosecond! tim ns)
    274   (check-time 'set-time-nanosecond! tim)
    275   (check-time-nanoseconds 'set-time-nanosecond! ns)
    276   (tm:time-nanosecond-set! tim ns) )
    277 
    278 (define (set-time-second! tim sec)
    279   (check-time 'set-time-second! tim)
    280   (check-time-seconds 'set-time-second! sec)
    281   (tm:time-second-set! tim sec) )
    282 
    283 ;; Seconds Conversion
    284 
    285 (define (nanoseconds->time ns . args)
    286   (let-optionals args ((tt 'duration))
    287     (receive (ns sec)
    288         (tm:nanoseconds->time-values ns)
    289       (check-time-elements 'nanoseconds->time tt ns sec)
    290       (tm:make-time tt ns sec) ) ) )
    291 
    292 (define (nanoseconds->seconds ns)
    293   #;(check-real 'nanoseconds->seconds ns)
    294   (tm:nanoseconds->seconds ns) )
    295 
    296 (define (milliseconds->time ms . args)
    297   (check-raw-milliseconds 'milliseconds->time ms)
    298   (let-optionals args ((tt 'duration))
    299     (receive (ns sec)
    300         (tm:milliseconds->time-values ms)
    301       (check-time-elements 'milliseconds->time tt ns sec)
    302       (tm:make-time tt ns sec) ) ) )
    303 
    304 (define (milliseconds->seconds ms)
    305   (check-raw-milliseconds 'milliseconds->seconds ms)
    306   (tm:milliseconds->seconds ms) )
    307 
    308 (define (time->nanoseconds tim)
    309   (check-time 'time->nanoseconds tim)
    310   (tm:time->nanoseconds tim) )
    311 
    312 (define (time->milliseconds tim)
    313   (check-time 'time->milliseconds tim)
    314   (tm:time->milliseconds tim) )
    315 
    316 (define (time->seconds tim)
    317   (check-time 'time->seconds tim)
    318   (tm:time->seconds tim) )
    319 
    320 ;; Current time routines
    321 
    322 (define (current-time . args)
    323   (let-optionals args ((tt 'utc))
    324     (case tt
    325       ((monotonic) (tm:current-time-monotonic))
    326       ((utc)       (tm:current-time-utc))
    327       ((tai)       (tm:current-time-tai))
    328       ((gc)        (tm:current-time-gc))
    329       ((process)   (tm:current-time-process))
    330       ((thread)    (tm:current-time-thread))
    331       (else
    332         (error-time-type 'current-time tt)) ) ) )
    333 
    334 ;; -- Time Resolution
    335 ;; This is the resolution of the clock in nanoseconds.
    336 ;; This will be implementation specific.
    337 
    338 (define (time-resolution . args)
    339   (let-optionals args ((tt 'utc))
    340     (check-time-type 'time-resolution tt)
    341     (tm:time-resolution tt) ) )
    342 
    343 ;; SRFI-18 Routines
    344 
    345 (define (srfi-18-time->time srfi-18-tim)
    346   (seconds->time/type (srfi-18:time->seconds srfi-18-tim) 'duration) )
    347 
    348 (define (time->srfi-18-time tim)
    349   (check-time 'time->srfi-18-time tim)
    350   (srfi-18:seconds->time (tm:time->seconds tim)) )
    351 
    352 ;; Time Comparison
    353 
    354 (define (time-compare tim1 tim2)
    355   (check-time-compare 'time-compare tim1 tim2)
    356   (let ((dif (tm:time-compare tim1 tim2)))
    357     (cond ((negative? dif)  -1)
    358           ((positive? dif)  1)
    359           (else             0) ) ) )
    360 
    361 (define (time=? tim1 tim2)
    362   (check-time-compare 'time=? tim1 tim2)
    363   (tm:time=? tim1 tim2) )
    364 
    365 (define (time>? tim1 tim2)
    366   (check-time-compare 'time>? tim1 tim2)
    367   (tm:time>? tim1 tim2) )
    368 
    369 (define (time<? tim1 tim2)
    370   (check-time-compare 'time<? tim1 tim2)
    371   (tm:time<? tim1 tim2) )
    372 
    373 (define (time>=? tim1 tim2)
    374   (check-time-compare 'time>=? tim1 tim2)
    375   (tm:time>=? tim1 tim2) )
    376 
    377 (define (time<=? tim1 tim2)
    378   (check-time-compare 'time<=? tim1 tim2)
    379   (tm:time<=? tim1 tim2) )
    380 
    381 (define (time-max tim1 . rest)
    382   (check-time 'time-max tim1)
    383   (let ((tt (tm:time-type tim1)))
    384     (let loop ((acc tim1) (ls rest))
    385       (if (null? ls) acc
    386           (let ((tim (car ls)))
    387             (check-time-and-type 'time-max tim tt)
    388             (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )
    389 
    390 (define (time-min tim1 . rest)
    391   (check-time 'time-min tim1)
    392   (let ((tt (tm:time-type tim1)))
    393     (let loop ((acc tim1) (ls rest))
    394       (if (null? ls) acc
    395           (let ((tim (car ls)))
    396             (check-time-and-type 'time-min tim tt)
    397             (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )
    398 
    399 ;; Time Arithmetic
    400 
    401 (define (time-difference tim1 tim2)
    402   (check-time-compare 'time-difference tim1 tim2)
    403   (tm:time-difference tim1 tim2 (tm:some-time 'duration)) )
    404 
    405 (define (add-duration tim dur)
    406   (check-time-aritmetic 'add-duration tim dur)
    407   (tm:add-duration tim dur (tm:as-some-time tim)) )
    408 
    409 (define (subtract-duration tim dur)
    410   (check-time-aritmetic 'subtract-duration tim dur)
    411   (tm:subtract-duration tim dur (tm:as-some-time tim)) )
    412 
    413 (define (divide-duration dur num)
    414   (check-duration 'divide-duration dur)
    415   (tm:divide-duration dur num (tm:some-time 'duration)) )
    416 
    417 (define (multiply-duration dur num)
    418   (check-duration 'multiply-duration dur)
    419   (tm:multiply-duration dur num (tm:some-time 'duration)) )
    420 
    421 (define (time-abs tim)
    422   (check-time 'time-abs tim)
    423   (tm:time-abs tim (tm:as-some-time tim)) )
    424 
    425 (define (time-negate tim)
    426   (check-time 'time-negate tim)
    427   (tm:time-negate tim (tm:as-some-time tim)) )
    428 
    429 ;;
    430 
    431 (define (time-difference! tim1 tim2)
    432   (check-time-compare 'time-difference! tim1 tim2)
    433   (tm:time-difference tim1 tim2 tim1) )
    434 
    435 (define (add-duration! tim dur)
    436   (check-time-aritmetic 'add-duration! tim dur)
    437   (tm:add-duration tim dur tim) )
    438 
    439 (define (subtract-duration! tim dur)
    440   (check-time-aritmetic 'subtract-duration! tim dur)
    441   (tm:subtract-duration tim dur tim) )
    442 
    443 (define (divide-duration! dur num)
    444   (check-duration 'divide-duration! dur)
    445   (tm:divide-duration dur num dur) )
    446 
    447 (define (multiply-duration! dur num)
    448   (check-duration 'multiply-duration! dur)
    449   (tm:multiply-duration dur num dur) )
    450 
    451 (define (time-abs! tim)
    452   (check-time 'time-abs! tim)
    453   (tm:time-abs tim tim) )
    454 
    455 (define (time-negate! tim)
    456   (check-time 'time-negate! tim)
    457   (tm:time-negate tim tim) )
    458 
    459 ;;
    460 
    461 (define (time-negative? tim)
    462   (check-time 'time-negative? tim)
    463   ;nanoseconds irrelevant
    464   (negative? (tm:time-second tim)) )
    465 
    466 (define (time-positive? tim)
    467   (check-time 'time-positive? tim)
    468   ;nanoseconds irrelevant
    469   (positive? (tm:time-second tim)) )
    470 
    471 (define (time-zero? tim)
    472   (check-time 'time-zero? tim)
    473   (and (zero? (tm:time-nanosecond tim))
    474        (zero? (tm:time-second tim))) )
    475 
    476 ;; Time Type Conversion
    477 
    478 ;;
    479 
    480 (define (time-tai->time-utc tim)
    481   (check-time-and-type 'time-tai->time-utc tim 'tai)
    482   (tm:time-tai->time-utc tim (tm:any-time)) )
    483 
    484 (define (time-tai->time-monotonic tim)
    485   (check-time-and-type 'time-tai->time-monotonic tim 'tai)
    486   (tm:time-tai->time-monotonic tim (tm:any-time)) )
    487 
    488 (define (time-utc->time-tai tim)
    489   (check-time-and-type 'time-utc->time-tai tim 'utc)
    490   (tm:time-utc->time-tai tim (tm:any-time)) )
    491 
    492 (define (time-utc->time-monotonic tim)
    493   (check-time-and-type 'time-utc->time-monotonic tim 'utc)
    494   (tm:time-utc->time-monotonic tim (tm:any-time)) )
    495 
    496 (define (time-monotonic->time-utc tim)
    497   (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic)
    498   (let ((ntim (tm:copy-time tim)))
    499     (tm:time-monotonic->time-utc ntim ntim) ) )
    500 
    501 (define (time-monotonic->time-tai tim)
    502   (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic)
    503   (tm:time-monotonic->time-tai tim (tm:any-time)) )
    504 
    505 ;;
    506 
    507 (define (time-tai->time-utc! tim)
    508   (check-time-and-type 'time-tai->time-utc! tim 'tai)
    509   (tm:time-tai->time-utc tim tim) )
    510 
    511 (define (time-tai->time-monotonic! tim)
    512   (check-time-and-type 'time-tai->time-monotonic! tim 'tai)
    513   (tm:time-tai->time-monotonic tim tim) )
    514 
    515 (define (time-utc->time-tai! tim)
    516   (check-time-and-type 'time-utc->time-tai! tim 'utc)
    517   (tm:time-utc->time-tai tim tim) )
    518 
    519 (define (time-utc->time-monotonic! tim)
    520   (check-time-and-type 'time-utc->time-monotonic! tim 'utc)
    521   (tm:time-utc->time-monotonic tim tim) )
    522 
    523 (define (time-monotonic->time-utc! tim)
    524   (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic)
    525   (tm:time-monotonic->time-utc tim tim) )
    526 
    527 (define (time-monotonic->time-tai! tim)
    528   (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic)
    529   (tm:time-monotonic->time-tai tim tim) )
    530 
    531 
    532 ;;; Date Object (Public Immutable)
    533 
    534 ;;
    535 
    536 (define-parameter default-date-clock-type 'utc
    537   (lambda (obj)
    538     (cond ((clock-type? obj) obj)
    539           (else
    540            (warning-argument-type 'default-date-clock-type obj 'clock-type)
    541            (default-date-clock-type) ) ) ) )
    542 
    543 ;; Date CTOR
    544 
    545 (define (make-date ns sec min hr dy mn yr tzo . args)
    546   (let-optionals args ((tzn #f) (dstf (void)))
    547     (cond ((timezone-components? tzo)
    548            ; Supplied parameters override
    549            (set! dstf (if (eq? (void) dstf) (timezone-locale-dst? tzo) dstf))
    550            (set! tzn (or tzn (timezone-locale-name tzo)))
    551            (set! tzo (timezone-locale-offset tzo)) )
    552           (else
    553            (when (eq? (void) dstf) (set! dstf #f)) ) )
    554     (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
    555     (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
    556 
    557 (define (copy-date dat)
    558   (check-date 'copy-date dat)
    559   (tm:copy-date dat) )
    560 
    561 ;; Converts a seconds value, may be fractional, into a date type.
    562 ;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
    563 ;; A local (#t), utc (#f), or other (timezone-components) date depending on
    564 ;; the optional 2nd argument. The default is #f.
    565 
    566 (define (seconds->date/type sec . tzi)
    567   (check-raw-seconds 'seconds->date/type sec)
    568   (let ((tzc (checked-optional-timezone-info 'seconds->date/type (optional tzi #t))))
    569     (check-timezone-components 'seconds->date/type tzc)
    570     (tm:seconds->date/type sec tzc) ) )
    571 
    572 (define (current-date . tzi)
    573   (tm:current-date (checked-optional-timezone-info 'current-date (optional tzi #t))) )
    574 
    575 ;;
    576 
    577 (define (date-nanosecond dat)
    578         (check-date 'date-nanosecond dat)
    579         (tm:date-nanosecond dat) )
    580 
    581 (define (date-second dat)
    582         (check-date 'date-second dat)
    583         (tm:date-second dat) )
    584 
    585 (define (date-minute dat)
    586         (check-date 'date-minute dat)
    587         (tm:date-minute dat) )
    588 
    589 (define (date-hour dat)
    590         (check-date 'date-hour dat)
    591         (tm:date-hour dat) )
    592 
    593 (define (date-day dat)
    594         (check-date 'date-day dat)
    595         (tm:date-day dat) )
    596 
    597 (define (date-month dat)
    598         (check-date 'date-month dat)
    599         (tm:date-month dat) )
    600 
    601 (define (date-year dat)
    602         (check-date 'date-year dat)
    603         (tm:date-year dat) )
    604 
    605 (define (date-dst? dat)
    606         (check-date 'date-dst? dat)
    607         (tm:date-dst? dat) )
    608 
    609 (define (date-zone-offset dat)
    610         (check-date 'date-zone-offset dat)
    611         (tm:date-zone-offset dat) )
    612 
    613 (define (date-zone-name dat)
    614         (check-date 'date-zone-name dat)
    615         (tm:date-zone-name dat) )
    616 
    617 ;; Date Comparison
    618 
    619 (define (checked-date-compare loc dat1 dat2)
    620   (check-date loc dat1)
    621   (check-date loc dat2)
    622   (check-date-compatible-timezone-offsets loc dat1 dat2)
    623   (tm:date-compare dat1 dat2) )
    624 
    625 ;;
    626 
    627 (define (date-compare dat1 dat2)
    628   (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
    629     (cond ((fx> 0 dif)  -1)
    630           ((fx< 0 dif)  1)
    631           (else         0) ) ) )
    632 
    633 (define (date=? dat1 dat2)
    634   (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )
    635 
    636 (define (date<? dat1 dat2)
    637   (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )
    638 
    639 (define (date<=? dat1 dat2)
    640   (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
    641 
    642 (define (date>? dat1 dat2)
    643   (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )
    644 
    645 (define (date>=? dat1 dat2)
    646   (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
    647 
    648 (define (date-max dat1 . rest)
    649   (check-date 'date-max dat1)
    650   (let loop ((acc dat1) (ls rest))
    651     (if (null? ls) acc
    652         (let ((dat (car ls)))
    653           (check-date 'date-max dat)
    654           (check-date-compatible-timezone-offsets 'date-max acc dat)
    655           (loop (if (fx> 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
    656 
    657 (define (date-min dat1 . rest)
    658   (check-date 'date-min dat1)
    659   (let loop ((acc dat1) (ls rest))
    660     (if (null? ls) acc
    661         (let ((dat (car ls)))
    662           (check-date 'date-min dat)
    663           (check-date-compatible-timezone-offsets 'date-min acc dat)
    664           (loop (if (fx< 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
    665 
    666 ;; Date Arithmetic
    667 
    668 (define (date-difference dat1 dat2 . args)
    669   (check-date 'date-difference dat1)
    670   (check-date 'date-difference dat2)
    671   (let-optionals args ((tt (default-date-clock-type)))
    672     (let ((tim1 (tm:date->time dat1 tt))
    673           (tim2 (tm:date->time dat2 tt)) )
    674       (unless tim1 (error-clock-type 'date-difference dat1))
    675       (unless tim2 (error-clock-type 'date-difference dat2))
    676       (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
    677 
    678 (define (date-add-duration dat dur . args)
    679   (check-date 'date-add-duration dat)
    680   (check-duration 'date-add-duration dur)
    681   (let-optionals args ((tt (default-date-clock-type)))
    682     (let ((tim (tm:date->time dat tt)))
    683       (unless tim (error-clock-type 'date-add-duration dat))
    684       (time->date (tm:add-duration tim dur (tm:as-some-time tim))) ) ) )
    685 
    686 (define (date-subtract-duration dat dur . args)
    687   (check-date 'date-subtract-duration dat)
    688   (check-duration 'date-subtract-duration dur)
    689   (let-optionals args ((tt (default-date-clock-type)))
    690     (let ((tim (tm:date->time dat tt)))
    691       (unless tim (error-clock-type 'date-subtract-duration dat))
    692       (time->date (tm:subtract-duration tim dur (tm:as-some-time tim))) ) ) )
    693 
    694 ;; Time to Date
    695 
    696 (define (time-tai->date tim . tzi)
    697   (check-time-and-type 'time-tai->date tim 'tai)
    698   (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #t))) )
    699 
    700 (define (time-utc->date tim . tzi)
    701   (check-time-and-type 'time-utc->date tim 'utc)
    702   (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #t))) )
    703 
    704 (define (time-monotonic->date tim . tzi)
    705   (check-time-and-type 'time-monotonic->date tim 'monotonic)
    706   (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #t))) )
    707 
    708 (define (time->date tim . tzi)
    709   (check-time 'time->date tim)
    710   (or (tm:time->date tim (checked-optional-timezone-info 'time->date (optional tzi #t)))
    711       ; This shouldn't happen
    712       (error-clock-type 'time->date tim)) )
    713 
    714 ;; Date to Time
    715 
    716 (define (date->time-utc dat)
    717   (check-date 'date->time-utc dat)
    718   (tm:date->time-utc dat) )
    719 
    720 (define (date->time-tai dat)
    721   (check-date 'date->time-tai dat)
    722   (tm:date->time-tai dat) )
    723 
    724 (define (date->time-monotonic dat)
    725   (check-date 'date->time-monotonic dat)
    726   (tm:date->time-monotonic dat) )
    727 
    728 (define (date->time dat . args)
    729   (check-date 'date->time dat)
    730   (let-optionals args ((tt (default-date-clock-type)))
    731     (or (tm:date->time dat tt)
    732         (error-clock-type 'date->time tt) ) ) )
    733 
    734 ;; Given a 'two digit' number, find the year within 50 years +/-
    735 
    736 (define (natural-year n . tzi)
    737   (check-date-year 'natural-year n)
    738   (tm:natural-year n (checked-optional-timezone-info 'natural-year (optional tzi #t))) )
    739 
    740 ;; Leap Year
    741 
    742 (define (leap-year? dat)
    743   (check-date 'date-leap-year? dat)
    744   (tm:leap-year? (tm:date-year dat)) )
    745 
    746 ;; Day of Year
    747 
    748 (define (date-year-day dat)
    749   (check-date 'date-year-day dat)
    750   (tm:date-year-day dat) )
    751 
    752 (define (days-in-month/year mn yr)
    753   (check-date-year 'days-in-month/year yr)
    754   (check-date-month 'days-in-month/year mn)
    755   (tm:days-in-month yr mn) )
    756 
    757 ;; Week Day
    758 
    759 (define (date-week-day dat)
    760   (check-date 'date-week-day dat)
    761   (tm:date-week-day dat) )
    762 
    763 ;;
    764 
    765 (define (date-week-number dat . args)
    766   (check-date 'date-week-number dat)
    767   (let ((day-of-week-starting-week (optional args 0)))
    768     (check-week-day 'date-week-number day-of-week-starting-week)
    769     (tm:date-week-number dat day-of-week-starting-week) ) )
    770 
    771 ;; Julian-day Operations
    772 
    773 (define (date->julian-day dat)
    774   (check-date 'date->julian-day dat)
    775   (tm:date->julian-day dat) )
    776 
    777 (define (date->modified-julian-day dat)
    778   (check-date 'date->modified-julian-day dat)
    779   (tm:julian-day->modified-julian-day (tm:date->julian-day dat)) )
    780 
    781 ;; Time to Julian-day
    782 
    783 (define (time-utc->julian-day tim)
    784   (check-time-and-type 'time-utc->julian-day tim 'utc)
    785   (tm:time-utc->julian-day tim) )
    786 
    787 (define (time-tai->julian-day tim)
    788   (check-time-and-type 'time-tai->julian-day tim 'tai)
    789   (tm:time-tai->julian-day tim) )
    790 
    791 (define (time-monotonic->julian-day tim)
    792   (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
    793   (tm:time-monotonic->julian-day tim) )
    794 
    795 (define (time->julian-day tim)
    796   (check-time 'time->julian-day tim)
    797   (or (tm:time->julian-day tim)
    798       (error-clock-type 'time->julian-day tim) ) )
    799 
    800 (define (time-utc->modified-julian-day tim)
    801   (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
    802   (tm:time-utc->modified-julian-day tim) )
    803 
    804 (define (time-tai->modified-julian-day tim)
    805   (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
    806   (tm:time-tai->modified-julian-day tim) )
    807 
    808 (define (time-monotonic->modified-julian-day tim)
    809   (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
    810   (tm:time-monotonic->modified-julian-day tim) )
    811 
    812 (define (time->modified-julian-day tim)
    813   (check-time 'time->modified-julian-day tim)
    814   (or (tm:time->modified-julian-day tim)
    815       (error-clock-type 'time->modified-julian-day tim) ) )
    816 
    817 ;; Julian-day to Time
    818 
    819 (define (julian-day->time-utc jdn)
    820   (check-julian-day 'julian-day->time-utc jdn)
    821   (tm:julian-day->time-utc jdn) )
    822 
    823 (define (julian-day->time-tai jdn)
    824   (check-julian-day 'julian-day->time-tai jdn)
    825   (let ((tim (tm:julian-day->time-utc jdn)))
    826     (tm:time-utc->time-tai tim tim) ) )
    827 
    828 (define (julian-day->time-monotonic jdn)
    829   (check-julian-day 'julian-day->time-monotonic jdn)
    830   (let ((tim (julian-day->time-utc jdn)))
    831     (tm:time-utc->time-monotonic tim tim) ) )
    832 
    833 (define (julian-day->date jdn . tzi)
    834   (check-julian-day 'julian-day->date jdn)
    835   (tm:time-utc->date (tm:julian-day->time-utc jdn)
    836                      (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )
    837 
    838 (define (modified-julian-day->time-utc mjdn)
    839   (check-julian-day 'modified-julian-day->time-utc mjdn)
    840   (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
    841 
    842 (define (modified-julian-day->time-tai mjdn)
    843   (check-julian-day 'modified-julian-day->time-tai mjdn)
    844   (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
    845     (tm:time-utc->time-tai tim tim) ) )
    846 
    847 (define (modified-julian-day->time-monotonic mjdn)
    848   (check-julian-day 'modified-julian-day->time-monotonic mjdn)
    849   (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
    850     (tm:time-utc->time-monotonic tim tim) ) )
    851 
    852 (define (modified-julian-day->date mjdn . tzi)
    853   (check-julian-day 'modified-julian-day->date mjdn)
    854   (tm:time-utc->date (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))
    855                      (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )
    856 
    857 ;; The Julian-day
    858 
    859 (define (current-julian-day)
    860   (tm:time-utc->julian-day (tm:current-time-utc)) )
    861 
    862 (define (current-modified-julian-day)
    863   (tm:time-utc->modified-julian-day (tm:current-time-utc)) )
     145  (import scheme chicken srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
     146 
     147  (require-library srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
    864148
    865149) ;module srfi-19-core
  • release/4/srfi-19/trunk/srfi-19-timezone.scm

    r15751 r15754  
    2626
    2727(define-inline (make-utc-timezone)
    28   (let ((tz (make-timezone-components "UTC0" builtin-source-name)))
     28  (let ((tz (make-timezone-components "UTC0" (builtin-source-name))))
    2929    (update-timezone-components! tz 'std-name "UTC" 'std-offset 0) ) )
    3030
     
    7474
    7575(define (timezone-name? obj) (or (not obj) (string? obj)))
     76(define (timezone-info? obj) (or (timezone-components? obj) (timezone-offset? obj)))
    7677
    7778(define-check+error-type timezone-name)
    78 
    79 (define (timezone-info? obj)
    80   (or (timezone-components? obj)
    81       (timezone-offset? obj) ) )
    82 
    8379(define-check+error-type timezone-info)
    8480
  • release/4/srfi-19/trunk/srfi-19.meta

    r15751 r15754  
    1414        "srfi-19-support.scm"
    1515        "srfi-19-timezone.scm"
    16         "srfi-19-core.scm"
     16        #;"srfi-19-core.scm"
     17        "srfi-19-time.scm"
     18        "srfi-19-date.scm"
    1719        "srfi-19-io.scm"
    1820        "srfi-19-period.scm"
  • release/4/srfi-19/trunk/srfi-19.scm

    r15751 r15754  
    111111  read-leap-second-table
    112112  time->milliseconds
     113  time->seconds
    113114  milliseconds->time
    114115  milliseconds->seconds
    115116  time->date
    116   make-timezone-locale
    117   timezone-locale?
    118   timezone-locale-name
    119   timezone-locale-offset
    120   timezone-locale-dst?
    121   local-timezone-locale
    122   utc-timezone-locale
    123117  default-date-clock-type
    124118  date-zone-name
     
    155149  timezone-locale-dst?)
    156150
    157   (import scheme chicken srfi-19-timezone srfi-19-core srfi-19-io)
     151  (import scheme chicken srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date srfi-19-io)
    158152 
    159   (require-library srfi-19-timezone srfi-19-core srfi-19-io)
     153  (require-library srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date srfi-19-io)
    160154
    161155) ;module srfi-19
  • release/4/srfi-19/trunk/srfi-19.setup

    r15751 r15754  
    66
    77(required-extension-version
     8  'setup-helper        "1.1.1"
    89  'type-errors         "1.4.0"
    910  'locale              "0.6.2")
     11
     12(install-srfi-29-bundle 'srfi-19 'en)
     13(install-srfi-29-bundle 'srfi-19 'es)
     14(install-srfi-29-bundle 'srfi-19 'nl)
     15(install-srfi-29-bundle 'srfi-19 'pt 'br)
    1016
    1117(setup-shared-extension-module 'srfi-19-timezone (extension-version "3.0.0")
     
    1521  #:compile-options '(-optimize-level 4 -debug-level 0))
    1622
    17 (setup-shared-extension-module 'srfi-19-core (extension-version "3.0.0")
     23(setup-shared-extension-module 'srfi-19-time (extension-version "3.0.0")
     24  #:compile-options '(-inline -local -no-procedure-checks))
     25
     26(setup-shared-extension-module 'srfi-19-date (extension-version "3.0.0")
    1827  #:compile-options '(-inline -local -no-procedure-checks))
    1928
     
    2433  #:compile-options '(-inline -local -no-procedure-checks))
    2534
     35#;
     36(setup-shared-extension-module 'srfi-19-core (extension-version "3.0.0")
     37  #:compile-options '(-inline -local -no-procedure-checks))
     38
    2639(setup-shared-extension-module 'srfi-19 (extension-version "3.0.0")
    2740  #:compile-options '(-inline -local -no-procedure-checks))
  • release/4/srfi-19/trunk/tests/run.scm

    r15727 r15754  
     1;;; simple test procedures
     2
     3(use srfi-19)
     4
     5(use numbers) ; Rational results from 'julian-day'
     6
     7(use srfi-1) ; For current-date w/o tz-locale test
     8
     9(use format) ; For conversion test
     10
     11;;
     12
     13(define s19-tests (list))
     14
     15(define (define-s19-test! name thunk)
     16  (let ((name (if (symbol? name) name (string->symbol name)))
     17        (pr (assoc name s19-tests)))
     18    (if pr
     19        (set-cdr! pr thunk)
     20        (set! s19-tests (append s19-tests (list (cons name thunk)))))))
     21
     22(define (run-s19-test name thunk verbose)
     23  (if verbose (begin (display ";;; Running ") (display name)))
     24  (let ((result (thunk)))
     25    (if verbose (begin (display ": ") (display (not (not result))) (newline)))
     26    result))
     27
     28(define (run-s19-tests . verbose)
     29  (let ((runs 0) (goods 0) (bads 0) (verbose (if (cdr verbose) (cdr verbose) #f)))
     30    (for-each (lambda (pr)
     31                (set! runs (+ runs 1))
     32                (if (run-s19-test (car pr) (cdr pr) verbose)
     33                    (set! goods (+ goods 1))
     34                    (set! bads (+ bads 1))))
     35              s19-tests)
     36    (if verbose
     37        (begin
     38          (display ";;; Results: Runs: ")
     39          (display runs)
     40          (display "; Goods: ")
     41          (display goods)
     42          (display "; Bads: ")
     43          (display bads)
     44          (if (> runs 0)
     45              (begin
     46                (display "; Pass rate: ")
     47                (display (/ goods runs)))
     48              (display "; No tests."))
     49          (newline)))
     50    (values runs goods bads)))
     51
     52;;
     53
     54(define-s19-test! "Creating time structures"
     55  (lambda ()
     56    (not (null? (list (current-time 'time-tai)
     57                      (current-time 'time-utc)
     58                      (current-time 'time-monotonic)
     59                      (current-time 'time-thread)
     60                      (current-time 'time-process))))))
     61
     62(define-s19-test! "Testing time resolutions"
     63  (lambda ()
     64    (not (null? (list (time-resolution 'time-tai)
     65                      (time-resolution 'time-utc)
     66                      (time-resolution 'time-monotonic)
     67                      (time-resolution 'time-thread)
     68                      (time-resolution 'time-process))))))
     69
     70(define-s19-test! "Time comparisons (time=?, etc.)"
     71  (lambda ()
     72    (let ((t1 (make-time 'time-utc 0 1))
     73          (t2 (make-time 'time-utc 0 1))
     74          (t3 (make-time 'time-utc 0 2))
     75          (t11 (make-time 'time-utc 1001 1))
     76          (t12 (make-time 'time-utc 1001 1))
     77          (t13 (make-time 'time-utc 1001 2)))
     78      (and (time=? t1 t2)
     79           (time>? t3 t2)
     80           (time<? t2 t3)
     81           (time>=? t1 t2)
     82           (time>=? t3 t2)
     83           (time<=? t1 t2)
     84           (time<=? t2 t3)
     85           (time=? t11 t12)
     86           (time>? t13 t12)
     87           (time<? t12 t13)
     88           (time>=? t11 t12)
     89           (time>=? t13 t12)
     90           (time<=? t11 t12)
     91           (time<=? t12 t13)
     92           ))))
     93
     94(define-s19-test! "Time difference"
     95  (lambda ()
     96    (let ((t1 (make-time 'time-utc 0 3000))
     97          (t2 (make-time 'time-utc 0 1000))
     98          (t3 (make-time 'time-duration 0 2000))
     99          (t4 (make-time 'time-duration 0 -2000)))
     100      (and
     101       (time=? t3 (time-difference t1 t2))
     102       (time=? t4 (time-difference t2 t1))))))
     103
     104(define (test-one-utc-tai-edge utc tai-diff tai-last-diff)
     105  (let* (;; right on the edge they should be the same
     106         (utc-basic (make-time 'time-utc 0 utc))
     107         (tai-basic (make-time 'time-tai 0 (+ utc tai-diff)))
     108         (utc->tai-basic (time-utc->time-tai utc-basic))
     109         (tai->utc-basic (time-tai->time-utc tai-basic))
     110         ;; a second before they should be the old diff
     111         (utc-basic-1 (make-time 'time-utc 0 (- utc 1)))
     112         (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1)))
     113         (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
     114         (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
     115         ;; a second later they should be the new diff
     116         (utc-basic+1 (make-time 'time-utc 0 (+ utc 1)))
     117         (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1)))
     118         (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
     119         (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
     120         ;; ok, let's move the clock half a month or so plus half a second
     121         (shy (* 15 24 60 60))
     122         (hs (/ (expt 10 9) 2))
     123         ;; a second later they should be the new diff
     124         (utc-basic+2 (make-time 'time-utc hs (+ utc shy)))
     125         (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy)))
     126         (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
     127         (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))
     128         )
     129    (and (time=? utc-basic tai->utc-basic)
     130         (time=? tai-basic utc->tai-basic)
     131         (time=? utc-basic-1 tai->utc-basic-1)
     132         (time=? tai-basic-1 utc->tai-basic-1)
     133         (time=? utc-basic+1 tai->utc-basic+1)
     134         (time=? tai-basic+1 utc->tai-basic+1)
     135         (time=? utc-basic+2 tai->utc-basic+2)
     136         (time=? tai-basic+2 utc->tai-basic+2)
     137         )))
     138
     139(define-s19-test! "TAI-UTC Conversions"
     140  (lambda ()
     141    (and
     142     (test-one-utc-tai-edge 915148800  32 31)
     143     (test-one-utc-tai-edge 867715200  31 30)
     144     (test-one-utc-tai-edge 820454400  30 29)
     145     (test-one-utc-tai-edge 773020800  29 28)
     146     (test-one-utc-tai-edge 741484800  28 27)
     147     (test-one-utc-tai-edge 709948800  27 26)
     148     (test-one-utc-tai-edge 662688000  26 25)
     149     (test-one-utc-tai-edge 631152000  25 24)
     150     (test-one-utc-tai-edge 567993600  24 23)
     151     (test-one-utc-tai-edge 489024000  23 22)
     152     (test-one-utc-tai-edge 425865600  22 21)
     153     (test-one-utc-tai-edge 394329600  21 20)
     154     (test-one-utc-tai-edge 362793600  20 19)
     155     (test-one-utc-tai-edge 315532800  19 18)
     156     (test-one-utc-tai-edge 283996800  18 17)
     157     (test-one-utc-tai-edge 252460800  17 16)
     158     (test-one-utc-tai-edge 220924800  16 15)
     159     (test-one-utc-tai-edge 189302400  15 14)
     160     (test-one-utc-tai-edge 157766400  14 13)
     161     (test-one-utc-tai-edge 126230400  13 12)
     162     (test-one-utc-tai-edge 94694400   12 11)
     163     (test-one-utc-tai-edge 78796800   11 10)
     164     (test-one-utc-tai-edge 63072000   10 0)
     165     (test-one-utc-tai-edge 0          0  0) ;; at the epoch
     166     (test-one-utc-tai-edge 10         0  0) ;; close to it ...
     167     (test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
     168     )))
     169
     170(define (tm:date= d1 d2)
     171  (and (= (date-year d1) (date-year d2))
     172       (= (date-month d1) (date-month d2))
     173       (= (date-day d1) (date-day d2))
     174       (= (date-hour d1) (date-hour d2))
     175       (= (date-second d1) (date-second d2))
     176       (= (date-nanosecond d1) (date-nanosecond d2))
     177       (= (date-zone-offset d1) (date-zone-offset d2))))
     178
     179(define-s19-test! "TAI-Date Conversions"
     180  (lambda ()
     181    (and
     182     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
     183               (make-date 0 58 59 23 31 12 1998 0))
     184     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
     185               (make-date 0 59 59 23 31 12 1998 0))
     186     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
     187               (make-date 0 60 59 23 31 12 1998 0))
     188     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
     189               (make-date 0 0 0 0 1 1 1999 0)))))
     190
     191(define-s19-test! "Date-UTC Conversions"
     192  (lambda ()
     193    (and
     194     (time=? (make-time time-utc 0 (- 915148800 2))
     195             (date->time-utc (make-date 0 58 59 23 31 12 1998 0)))
     196     (time=? (make-time time-utc 0 (- 915148800 1))
     197             (date->time-utc (make-date 0 59 59 23 31 12 1998 0)))
     198     ;; yes, I think this is acutally right.
     199     (time=? (make-time time-utc 0 (- 915148800 0))
     200             (date->time-utc (make-date 0 60 59 23 31 12 1998 0)))
     201     (time=? (make-time time-utc 0 (- 915148800 0))
     202             (date->time-utc (make-date 0 0 0 0 1 1 1999 0)))
     203     (time=? (make-time time-utc 0 (+ 915148800 1))
     204             (date->time-utc (make-date 0 1 0 0 1 1 1999 0))))))
     205
     206(define-s19-test! "TZ Offset conversions"
     207  (lambda ()
     208    (let ((ct-utc (make-time time-utc 6320000 1045944859))
     209          (ct-tai (make-time time-tai 6320000 1045944891))
     210          (cd (make-date 6320000 19 14 15 22 2 2003 -18000)))
     211      (and
     212       (time=? ct-utc (date->time-utc cd))
     213       (time=? ct-tai (date->time-tai cd))))))
     214
     215(define-s19-test! "date->string conversions"
     216  (lambda ()
     217    (equal? "~.Tue.Tuesday.Jun.June.Tue Jun 05 04:03:02-0200 2007.05.06/05/07. 5,02.000001,Jun.04"
     218             (date->string (make-date 1000 2 3 4 5 6 2007 -7200)
     219                                       "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H"))))
     220
     221(define-s19-test! "string->date conversions"
     222  (lambda ()
     223    (equal? (make-date 0 53 4 0 19 10 2006 (local-timezone-locale))
     224            (string->date "2006/10/19 00:04:53" "~Y/~m/~d ~H:~M:~S"))))
     225
     226(define-s19-test! "date<->julian-day conversions"
     227  (lambda ()
     228   (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
     229     (and (tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))
     230          (= 365
     231             (- (date->julian-day (make-date 0 0 0 0 1 1 2004 0))
     232                (date->julian-day (make-date 0 0 0 0 1 1 2003 0))))))))
     233
     234(define-s19-test! "date->modified-julian-day conversions"
     235  (lambda ()
     236    (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
     237      (and (tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))
     238           (= 365
     239              (- (date->modified-julian-day (make-date 0 0 0 0 1 1 2004 0))
     240                 (date->modified-julian-day (make-date 0 0 0 0 1 1 2003 0))))))))
     241
     242(define-s19-test! "Time -> Date"
     243  (lambda ()
     244    (time->date (current-time))))
     245
     246(define-s19-test! "date-year-day [2.5 bad argument type for car]"
     247  (lambda ()
     248    (= 1 (date-year-day (make-date 0 0 0 0 1 1 2007 0)))))
     249
     250(define-s19-test! "~1 date->string [2.5 ISO-8601 conversion]"
     251  (lambda ()
     252    (equal? "2007-01-01" (date->string (string->date "2007-01-01" "~Y-~m-~d") "~1"))))
     253
     254(define-s19-test! "milliseconds->time [2.6.1 was using NS/S for conversion!]"
     255  (lambda ()
     256    (let ([tim (milliseconds->time 10000)])
     257      (and (= 10 (time-second tim))
     258           (= 0 (time-nanosecond tim))))))
     259
     260(define-s19-test! "Only one minute [2.6.1 current-date w/o tz-locale was doing dst conversion!]"
     261  (lambda ()
     262    (let ([lst
     263            (delete-duplicates
     264              (fold
     265                (lambda (n acc)
     266                  (cons (date-minute (current-date)) acc))
     267                '()
     268                ;This number needs to be low enough that the fold completes
     269                ;in sub-minute time (easy to achieve).
     270                (iota 2000)))])
     271      (= 1 (length lst)))))
     272
     273(define-s19-test! "Conversion"
     274  (lambda ()
     275   
     276    (define (vector->date1 vec)
     277      (make-date
     278        0 0 0 0
     279        (vector-ref vec 2)
     280        (vector-ref vec 1)
     281        (vector-ref vec 0)
     282        0))
     283   
     284    (define (vector->date2 vec)
     285      (string->date
     286        (format "~4,48D~2,48D~2,48DZ" ; ZULU timezone!
     287                (vector-ref vec 0)
     288                (vector-ref vec 1)
     289                (vector-ref vec 2))
     290        "~Y~m~d~z"))
     291   
     292    (define (to-time obj ->date)
     293      (cond
     294        ((time? obj)   obj)
     295        ((date? obj)   (date->time-utc obj))
     296        ((vector? obj) (date->time-utc (->date obj)))))
     297   
     298    (define (distance-of-time ->date from to)
     299      (let* ((from-time (to-time from ->date))
     300             (to-time (to-time to ->date))
     301             (diff (time-difference from-time to-time))
     302             (distance-in-seconds (time-second diff)))
     303        distance-in-seconds))
     304   
     305    (define vec1 (vector 2006 12 21))
     306    (define vec2 (vector 2006 12 19))
     307    (define vec3 (vector 2006 12 20))
     308   
     309    (define tod (current-date))
     310
     311    (let ([d1-1 (distance-of-time vector->date1 vec1 tod)]
     312          [d1-2 (distance-of-time vector->date1 vec1 vec2)]
     313          [d1-3 (distance-of-time vector->date1 vec3 tod)]
     314          [d2-1 (distance-of-time vector->date2 vec1 tod)]
     315          [d2-2 (distance-of-time vector->date2 vec1 vec2)]
     316          [d2-3 (distance-of-time vector->date2 vec3 tod)])
     317      (and (= d1-1 d2-1) (= d1-2 d2-2) (= d1-3 d2-3)))))
     318
     319(define-s19-test! "date-week-number"
     320  (lambda ()
     321    (and (eqv? 0 (date-week-number (make-date 0 0 0 0 1 1 2007 0) 0))
     322         (eqv? 51 (date-week-number (make-date 0 0 0 0 27 12 2006 0) 1)))))
     323
     324(define-s19-test! "date-week-day"
     325  (lambda ()
     326    (and (eqv? 1 (date-week-day (make-date 0 0 0 0 1 1 2007 0)))
     327         (eqv? 3 (date-week-day (make-date 0 0 0 0 27 12 2006 0))))))
     328
     329; Duration
     330; Time Aritmetic (+ - * /)
     331; Date Comparision
     332; Date Aritmetic
     333; Time Period
     334
     335;;
     336
     337(begin (newline) (run-s19-tests #t))
Note: See TracChangeset for help on using the changeset viewer.