Changeset 15750 in project


Ignore:
Timestamp:
09/06/09 04:13:57 (10 years ago)
Author:
kon
Message:

Save

Location:
release/4/srfi-19/trunk
Files:
2 added
8 edited

Legend:

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

    r15738 r15750  
    99(define-constant MuS/S 1000000)
    1010(define-constant NS/S  1000000000)
     11(define-constant -NS/S  -1000000000)
    1112
    1213(define-constant SEC/DY   86400)    ; seconds in a day
     
    4041
    4142;; ##sys#double->number
    42 ;; returns a fixnum for the flonum iff x isa integer in fixnum-range
    43 ;; otherwise the flonum
     43;; returns a fixnum for the flonum x iff x isa integer in fixnum-range
     44;; otherwise the flonum x
    4445
    4546; When domain is integer and range is fixnum
    4647; Number MUST be a fixnum or flonum
    4748
    48 (define-inline (number->maybe-fixnum x)
     49(define-inline (gennum->?fixnum x)
    4950  (if (fixnum? x) x (##sys#double->number x)) )
    5051
     
    5354; Others returned
    5455
    55 (define-inline (maybe-integer->maybe-fixnum x)
    56   (if (##sys#integer? x) (number->maybe-fixnum x) x) )
     56(define-inline (?genint->?fixnum x)
     57  (if (##sys#integer? x) (gennum->?fixnum x) x) )
  • release/4/srfi-19/trunk/srfi-19-core.scm

    r15738 r15750  
    11;;;; srfi-19-core.scm
    22;;;; Chicken port, Kon Lovett, Dec '05
    3 
    4 ;; Issues
    5 ;;
    6 ;; - The 'date-dst?' field is problimatic. It is only valid on certain
    7 ;; platforms & only when current. A past or future date will not have this
    8 ;; field correct!
    9 ;;
    10 ;; - Time -> Date conversion takes account of the CURRENT daylight saving time state,
    11 ;; NOT the state of the converted date.
    12 ;;
    13 ;; - Gregorian calendar only.
    14 ;;
    15 ;; - Initialization is scattered throughout the code, so converting to a module will
    16 ;; involve some search.
    17 ;;
    18 ;; - SRFI-18 current-time & time? procedure identifier conflict
    19 ;;
    20 ;; - Knowledge of SRFI-18 time object representation
    21 ;;
    22 ;; - Uses a SRFI-18 procedure - (seconds->time)
    23 ;;
    24 ;; - Some errors have incorrect procedure labels (not the top-level loc)
    25 
    26 ;; Notes
    27 ;;
    28 ;; - There is no year zero. So when converting from a BCE year on the sign of the year
    29 ;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713!
    30 ;;
    31 ;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from
    32 ;; UTC & a subtracted offset is "towards" UTC.
    33 ;;
    34 ;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every
    35 ;; conversion procedure.
    36 ;;
    37 ;; - Time has sign ONLY on the seconds, the nanoseconds is always positive.
    38 ;; However the original implementation did not always enforce.
    39 
    40 ;; To Do
    41 ;;
    42 ;; - Time -> Date conversion takes account of the state of the converted date
    43 ;; daylight saving time state.
    44 ;;
    45 ;; - Date/Time field minimums & maximums (useful for UI)
    46 ;;
    47 ;; - epoch access (?)
    48 ;;
    49 ;; - +inf, -inf, nan times & dates
    50 ;;
    51 ;; - add/roll date field; +/- some field, such as "next week"
    52 ;;
    53 ;; - date-iterator; +/- some increment per call
    54 ;;
    55 ;; - relative-date; such as "last thursday in june"
    56 ;;
    57 ;; - Plugable calendar systems
    583
    594;; SRFI-19: Time Data Types and Procedures.
     
    8328;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
    8429
    85 (include "chicken-primitive-object-inlines")
    86 
    87 (declare
    88   (not usual-integrations
    89     + - * /
    90     remainder quotient modulo
    91     expt
    92     abs
    93     round floor truncate
    94     number? integer? inexact?
    95     zero? negative? positive?
    96     = <= >= < >
    97     inexact->exact exact->inexact
    98     char-alphabetic? char-numeric?
    99     number->string string->number
    100     string-length string-append
    101     string->list list->string)
    102   (inline)
    103   (generic)
    104   (no-procedure-checks)
    105   (import
    106     ; SRFI-18 - This is a hack, works because Unit srfi-18 is part of the Chicken core.
    107     seconds->time)
    108   (bound-to-procedure
    109     ##sys#slot
    110     seconds->time
    111     ##sys#check-structure)
    112   (export
    113     ; SRFI-19
    114     time-tai
    115     time-utc
    116     time-monotonic
    117     time-thread
    118     time-process
    119     time-duration
    120     time-gc
    121     current-date
    122     current-julian-day
    123     current-modified-julian-day
    124     current-time
    125     time-resolution
    126     make-time time?
    127     time-type
    128     time-nanosecond
    129     time-second
    130     set-time-type!
    131     set-time-nanosecond!
    132     set-time-second!
    133     copy-time
    134     time<=?
    135     time<?
    136     time=?
    137     time>=?
    138     time>?
    139     time-difference
    140     time-difference!
    141     add-duration
    142     add-duration!
    143     subtract-duration
    144     subtract-duration!
    145     make-date
    146     date?
    147     date-nanosecond
    148     date-second
    149     date-minute
    150     date-hour
    151     date-day
    152     date-month
    153     date-year
    154     date-zone-offset
    155     leap-year? ; Actually part of SRFI 19 but not in original document
    156     date-year-day
    157     date-week-day
    158     date-week-number
    159     date->julian-day
    160     date->modified-julian-day
    161     date->time-monotonic
    162     date->time-tai
    163     date->time-utc
    164     julian-day->date
    165     julian-day->time-monotonic
    166     julian-day->time-tai
    167     julian-day->time-utc
    168     modified-julian-day->date
    169     modified-julian-day->time-monotonic
    170     modified-julian-day->time-tai
    171     modified-julian-day->time-utc
    172     time-monotonic->date
    173     time-monotonic->julian-day
    174     time-monotonic->modified-julian-day
    175     time-monotonic->time-tai
    176     time-monotonic->time-tai!
    177     time-monotonic->time-utc
    178     time-monotonic->time-utc!
    179     time-tai->date
    180     time-tai->julian-day
    181     time-tai->modified-julian-day
    182     time-tai->time-monotonic
    183     time-tai->time-monotonic!
    184     time-tai->time-utc
    185     time-tai->time-utc!
    186     time-utc->date
    187     time-utc->julian-day
    188     time-utc->modified-julian-day
    189     time-utc->time-monotonic
    190     time-utc->time-monotonic!
    191     time-utc->time-tai
    192     time-utc->time-tai!
    193     ; Extensions
    194     ONE-SECOND-DURATION
    195     ONE-NANOSECOND-DURATION
    196     time-type?
    197     make-duration
    198     divide-duration
    199     divide-duration!
    200     multiply-duration
    201     multiply-duration!
    202     srfi-19:current-time
    203     srfi-19:time?
    204     time->srfi-18-time
    205     srfi-18-time->time
    206     time-max
    207     time-min
    208     time-negative?
    209     time-positive?
    210     time-zero?
    211     time-abs
    212     time-abs!
    213     time-negate
    214     time-negate!
    215     seconds->time/type
    216     seconds->date/type
    217     time->nanoseconds
    218     nanoseconds->time
    219     nanoseconds->seconds
    220     read-leap-second-table
    221     time->milliseconds
    222     milliseconds->time
    223     milliseconds->seconds
    224     time->date
    225     make-timezone-locale
    226     timezone-locale?
    227     timezone-locale-name
    228     timezone-locale-offset
    229     timezone-locale-dst?
    230     local-timezone-locale
    231     utc-timezone-locale
    232     default-date-clock-type
    233     date-zone-name
    234     date-dst?
    235     copy-date
    236     date->time
    237     date-difference
    238     date-add-duration
    239     date-subtract-duration
    240     date=?
    241     date>?
    242     date<?
    243     date>=?
    244     date<=?
    245     time->julian-day
    246     time->modified-julian-day
    247     date-compare
    248     time-compare
    249     ; Internal API, for srfi-19-io & srfi-19-period
    250     tm:date-day-set!
    251     tm:date-hour-set!
    252     tm:date-minute-set!
    253     tm:date-month-set!
    254     tm:date-nanosecond-set!
    255     tm:date-second-set!
    256     tm:date-year-set!
    257     tm:date-zone-offset-set!
    258     tm:make-incomplete-date
    259     tm:check-date
    260     tm:check-exploded-date
    261     tm:time-type
    262     tm:check-time
    263     tm:make-empty-time
    264     tm:as-empty-time
    265     tm:time-monotonic->time-tai
    266     tm:time-utc->time-tai
    267     tm:time-tai->time-monotonic
    268     tm:time-utc->time-monotonic
    269     tm:time-monotonic->time-utc
    270     tm:time-tai->time-utc
    271     tm:week-day
    272     tm:days-before-first-week
    273     tm:subtract-duration
    274     tm:add-duration
    275     tm:time=?
    276     tm:time<?
    277     tm:time>?
    278     tm:time<=?
    279     tm:time>=?
    280     tm:time-max
    281     tm:time-min
    282     tm:check-duration
    283     tm:time-difference) )
    284 
    285 (require-extension #;srfi-6 #;srfi-8 #;srfi-9 posix miscmacros numbers locale srfi-9-ext type-checks type-errors)
    286 
    287 (register-feature! 'srfi-19)
    288 
    289 ; Re-defining a macro symbol!
    290 (eval-when (compile)
    291   (undefine-macro! 'time) )
    292 
    293 (include "srfi-19-common")
     30(module srfi-19-core (;export
     31  ; SRFI-19
     32  time-tai
     33  time-utc
     34  time-monotonic
     35  time-thread
     36  time-process
     37  time-duration
     38  time-gc
     39  current-date
     40  current-julian-day
     41  current-modified-julian-day
     42  current-time
     43  time-resolution
     44  make-time
     45  time?
     46  time-type
     47  time-nanosecond
     48  time-second
     49  set-time-type!
     50  set-time-nanosecond!
     51  set-time-second!
     52  copy-time
     53  time<=?
     54  time<?
     55  time=?
     56  time>=?
     57  time>?
     58  time-difference
     59  time-difference!
     60  add-duration
     61  add-duration!
     62  subtract-duration
     63  subtract-duration!
     64  make-date
     65  date?
     66  date-nanosecond
     67  date-second
     68  date-minute
     69  date-hour
     70  date-day
     71  date-month
     72  date-year
     73  date-zone-offset
     74  leap-year? ; Actually part of SRFI 19 but not in original document
     75  date-year-day
     76  date-week-day
     77  date-week-number
     78  date->julian-day
     79  date->modified-julian-day
     80  date->time-monotonic
     81  date->time-tai
     82  date->time-utc
     83  julian-day->date
     84  julian-day->time-monotonic
     85  julian-day->time-tai
     86  julian-day->time-utc
     87  modified-julian-day->date
     88  modified-julian-day->time-monotonic
     89  modified-julian-day->time-tai
     90  modified-julian-day->time-utc
     91  time-monotonic->date
     92  time-monotonic->julian-day
     93  time-monotonic->modified-julian-day
     94  time-monotonic->time-tai
     95  time-monotonic->time-tai!
     96  time-monotonic->time-utc
     97  time-monotonic->time-utc!
     98  time-tai->date
     99  time-tai->julian-day
     100  time-tai->modified-julian-day
     101  time-tai->time-monotonic
     102  time-tai->time-monotonic!
     103  time-tai->time-utc
     104  time-tai->time-utc!
     105  time-utc->date
     106  time-utc->julian-day
     107  time-utc->modified-julian-day
     108  time-utc->time-monotonic
     109  time-utc->time-monotonic!
     110  time-utc->time-tai
     111  time-utc->time-tai!
     112  ; Extensions
     113  one-second-duration
     114  one-nanosecond-duration
     115  zero-time
     116  time-type?
     117  make-duration
     118  divide-duration
     119  divide-duration!
     120  multiply-duration
     121  multiply-duration!
     122  time->srfi-18-time
     123  srfi-18-time->time
     124  time-max
     125  time-min
     126  time-negative?
     127  time-positive?
     128  time-zero?
     129  time-abs
     130  time-abs!
     131  time-negate
     132  time-negate!
     133  seconds->time/type
     134  seconds->date/type
     135  time->nanoseconds
     136  nanoseconds->time
     137  nanoseconds->seconds
     138  read-leap-second-table
     139  time->milliseconds
     140  milliseconds->time
     141  milliseconds->seconds
     142  time->date
     143  make-timezone-locale
     144  timezone-locale?
     145  timezone-locale-name
     146  timezone-locale-offset
     147  timezone-locale-dst?
     148  local-timezone-locale
     149  utc-timezone-locale
     150  default-date-clock-type
     151  date-zone-name
     152  date-dst?
     153  copy-date
     154  date->time
     155  date-difference
     156  date-add-duration
     157  date-subtract-duration
     158  date=?
     159  date>?
     160  date<?
     161  date>=?
     162  date<=?
     163  date-max
     164  date-min
     165  time->julian-day
     166  time->modified-julian-day
     167  date-compare
     168  time-compare)
     169
     170  (import (except scheme zero? negative? positive? real?)
     171          chicken
     172          #;srfi-8
     173          (only srfi-18 seconds->time time->seconds)
     174          (prefix srfi-18 srfi-18:)
     175          (only numbers zero? negative? positive? real?)
     176          miscmacros
     177          type-checks type-errors
     178          srfi-19-timezone srfi-19-support)
     179
     180  (require-library scheme chicken #;srfi-8
     181                   srfi-18
     182                   numbers
     183                   miscmacros
     184                   srfi-19-timezone srfi-19-support)
    294185
    295186;;;
    296187
    297 (define (error-invalid-type loc typ obj)
    298   (error loc (string-append "invalid " typ) obj) )
    299 
    300 (define (error-invalid-clock-type loc obj)
    301   (error-invalid-type loc "clock type" obj) )
    302 
    303 (define (error-invalid-time-type loc obj)
    304   (error-invalid-type loc "time type" obj) )
    305 
    306 (define (error-invalid-timezone-offset loc obj)
    307   (error-invalid-type loc "timezone offset" obj) )
    308 
    309 (define (error-invalid-nanoseconds loc obj)
    310   (error-invalid-type loc "nanoseconds" obj) )
    311 
    312 (define (error-invalid-seconds loc obj)
    313   (error-invalid-type loc "seconds" obj) )
    314 
    315 (define (error-invalid-minutes loc obj)
    316   (error-invalid-type loc "minutes" obj) )
    317 
    318 (define (error-invalid-hours loc obj)
    319   (error-invalid-type loc "hours" obj) )
    320 
    321 (define (error-invalid-day loc obj)
    322   (error-invalid-type loc "day" obj) )
    323 
    324 (define (error-invalid-month loc obj)
    325   (error-invalid-type loc "month" obj) )
    326 
    327 (define (error-invalid-year loc obj)
    328   (error-invalid-type loc "year" obj) )
    329 
    330 (define (error-invalid-timezone-components loc obj)
    331   (error-invalid-type loc "timezone components" obj) )
    332 
    333 (define (error-invalid-timezone-name loc obj)
    334   (error-invalid-type loc "timezone name" obj) )
    335 
    336 (define (error-incompatible-time-types loc timtyp1 timtyp2)
    337   (error loc "incompatible time types" timtyp1 timtyp2) )
    338 
    339 (define (error-compare-dates-w-diff-tz loc dat1 dat2)
    340   (error loc "cannot compare dates from different time-zones" dat1 dat2) )
    341 
    342 ;;
    343 
    344 (define-inline (%check-number loc obj nam)
    345   (unless (or (fixnum? obj) (flonum? obj))
    346     (error-invalid-type loc nam obj) ) )
    347 
    348 ;;; Timing Routines
    349 
    350 ;; Provide system timing reporting procedures
    351 
    352 (define total-gc-milliseconds
    353   (let ((accum-ms 0))
    354     (lambda ()
    355       (set! accum-ms (fx+ accum-ms (current-gc-milliseconds)))
    356       accum-ms ) ) )
    357 
    358 (define (current-process-milliseconds) (receive (ums sms) (cpu-time) (+ ums sms)))
    359 
    360 ;FIXME needs srfi-18 extension
    361 (define current-thread-milliseconds current-process-milliseconds)
    362 
    363 ;;; Constants
    364 
    365 ;; TAI-EPOCH: 1 January 1970 CE at 00:00:00 UTC
    366 
    367 (define-constant TAI-EPOCH-YEAR 1970)
    368 
    369 ;(Chicken reader doesn't grok ratios w/o numbers egg at compile time.)
    370 
    371 ;; Used in julian calculation
    372 
    373 (define ONE-HALF (string->number "1/2"))
    374 
    375 ;; Julian Day 0 = 1 January 4713 BCE at 12:00:00 UTC (Julian proleptic calendar)
    376 ;; Julian Day 0 = 24 November 4714 BCE at 12:00:00 UTC (Gregorian proleptic calendar)
    377 
    378 (define TAI-EPOCH-IN-JD (string->number "4881175/2"))
    379 
    380 ;; Modified Julian Day 0 = 17 Nov 1858 CE at 00:00:00 UTC
    381 ;; Number of days less than a julian day.
    382 
    383 (define TAI-EPOCH-IN-MODIFIED-JD (string->number "4800001/2"))
    384 
    385 ;;; Leap Seconds
    386 
    387 ;; First leap year after epoch
    388 
    389 (define-constant FIRST-LEAP-YEAR 1972)
    390 
    391 ;; Number of seconds after epoch of first leap year
    392 
    393 (define LEAP-START (fx* (fx- FIRST-LEAP-YEAR TAI-EPOCH-YEAR) (fx* DY/YR SEC/DY)))
    394 
    395 ;; A table of leap seconds
    396 ;; See "ftp://maia.usno.navy.mil/ser7/tai-utc.dat" and update as necessary.
    397 ;; Each entry is (utc seconds since epoch . # seconds to add for tai)
    398 ;; Note they go higher (2009) to lower (1972).
    399 
    400 (define tm:leap-second-table
    401   '((1230768000 . 34)
    402                 (1136073600 . 33)
    403                 (915148800 . 32)
    404                 (867715200 . 31)
    405                 (820454400 . 30)
    406                 (773020800 . 29)
    407                 (741484800 . 28)
    408                 (709948800 . 27)
    409                 (662688000 . 26)
    410                 (631152000 . 25)
    411                 (567993600 . 24)
    412                 (489024000 . 23)
    413                 (425865600 . 22)
    414                 (394329600 . 21)
    415                 (362793600 . 20)
    416                 (315532800 . 19)
    417                 (283996800 . 18)
    418                 (252460800 . 17)
    419                 (220924800 . 16)
    420                 (189302400 . 15)
    421                 (157766400 . 14)
    422                 (126230400 . 13)
    423                 (94694400 . 12)
    424                 (78796800 . 11)
    425                 (63072000 . 10)
    426     #;(-60480000 . 4.21317)   ; Before 1972
    427     #;(-126230400 . 4.31317)
    428     #;(-136771200 . 3.84013)
    429     #;(-142128000 . 3.74013)
    430     #;(-152668800 . 3.64013)
    431     #;(-157766400 . 3.54013)
    432     #;(-168307200 . 3.44013)
    433     #;(-181526400 . 3.34013)
    434     #;(-189388800 . 3.24013)
    435     #;(-194659200 . 1.945858)
    436     #;(-252460800 . 1.845858)
    437     #;(-265680000 . 1.372818)
    438     #;(-283996800 . 1.422818) ) )
    439 
    440 ;; This procedure reads the file in the
    441 ;; ftp://maia.usno.navy.mil/ser7/tai-utc.dat format and
    442 ;; creates a leap second table
    443 
    444 (define (tm:read-tai-utc-data flnm)
    445 
    446   (define (convert-jd jd) (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))
    447 
    448   (define (convert-sec sec) (inexact->exact sec))
    449 
    450   (define (read-data)
    451     (let loop ((ls '()))
    452        (let ((line (read-line)))
    453          (if (eof-object? line) ls
    454              (let ((data (with-input-from-string (conc #\( line #\)) read)))
    455                (let ((year (car data))
    456                      (jd   (cadddr (cdr data)))
    457                      (secs (cadddr (cdddr data))))
    458                  (loop (if (< year FIRST-LEAP-YEAR) ls
    459                            (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )
    460 
    461       (with-input-from-port (open-input-file flnm) read-data) )
    462 
    463 ;; Table of cummulative seconds, one second before the leap second.
    464 
    465 (define (tm:calc-second-before-leap-second-table table)
    466   (let loop ((inlst table) (outlst '()))
    467     (if (null? inlst) (reverse outlst) ;keep input order anyway
    468         (let ((itm (car inlst)))
    469           (loop (cdr inlst) (cons (- (+ (car itm) (cdr itm)) 1) outlst)))) ) )
    470 
    471 (define tm:second-before-leap-second-table
    472   (tm:calc-second-before-leap-second-table tm:leap-second-table))
    473 
    474 ;; Read a leap second table file in U.S. Naval Observatory format
     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;;
    475199
    476200(define (read-leap-second-table flnm)
    477   (set! tm:leap-second-table (tm:read-tai-utc-data flnm))
    478   (set! tm:second-before-leap-second-table
    479         (tm:calc-second-before-leap-second-table tm:leap-second-table)) )
    480 
    481 ;; Macros to inline the leap-second-delta algorithm
    482 
    483 ; 'leap-second-item' is like the 'it' in the anaphoric 'if'
    484 (define-macro ($find-leap-second-delta ?secs ?ls ?tst)
    485   (let ((lsvar (gensym)))
    486     `(let loop ((,lsvar ,?ls))
    487        (if (null? ,lsvar) 0
    488            (let ((leap-second-item (car ,lsvar)))
    489              (if ,?tst (cdr leap-second-item)
    490                  (loop (cdr ,lsvar)) ) ) ) ) ) )
    491 
    492 (define-macro ($leap-second-delta ?secs ?tst)
    493   `(if (< ,?secs LEAP-START) 0
    494        ($find-leap-second-delta ,?secs tm:leap-second-table ,?tst) ) )
    495 
    496 ;; Going from utc seconds ...
    497 
    498 (define-inline (%leap-second-delta utc-seconds)
    499   ($leap-second-delta utc-seconds (<= (car leap-second-item) utc-seconds)) )
    500 
    501 ;; Going from tai seconds to utc seconds ...
    502 
    503 (define-inline (%leap-second-neg-delta tai-seconds)
    504   ($leap-second-delta tai-seconds (<= (cdr leap-second-item) (- tai-seconds (car leap-second-item)))) )
    505 
    506 ;;; Time Object (Public Mutable)
    507 
    508 ;; Clock Type Constants
    509 ;; (Not used internally)
    510 
    511 (define time-duration 'time-duration)
    512 (define time-gc 'time-gc)
    513 (define time-monotonic 'time-monotonic)
    514 (define time-process 'time-process)
    515 (define time-tai 'time-tai)
    516 (define time-thread 'time-thread)
    517 (define time-utc 'time-utc)
    518 
    519 ;;
    520 
    521 (define-inline (%memq? obj ls) (->boolean (memq obj ls)))
    522 
    523 (define (time-type? obj)
    524   (%memq? obj '(time-monotonic time-utc time-tai time-gc time-duration time-process time-thread)) )
    525 
    526 (define (clock-time-type? obj)
    527   (%memq? obj '(time-monotonic time-tai time-utc)) )
    528 
    529 ;;
    530 
    531 (define-parameter default-date-clock-type 'time-utc
    532   (lambda (obj)
    533     (cond ((clock-time-type? obj) obj)
    534           (else
    535            (warning 'default-date-clock-type "bad argument type - expected clock-time-type" obj)
    536            (default-date-clock-type) ) ) ) )
    537 
    538 (define (tm:check-time-type loc obj)
    539   (unless (time-type? obj)
    540     (error-invalid-time-type loc obj) ) )
    541 
    542 ;; There are 3 kinds of time record procedures:
    543 ;; %...   - generated (these are inline!)
    544 ;; tm:... - argument processing then %...
    545 ;; ...    - argument checking then tm:...
    546 
    547 (define-record-type/primitive time
    548   (%make-time timtyp ns sec)
    549   %time?
    550   (timtyp %time-type        %set-time-type!)
    551   (ns     %time-nanosecond  %set-time-nanosecond!)
    552   (sec    %time-second      %set-time-second!) )
    553 
    554 (define-inline (%check-time loc obj) (##sys#check-structure obj 'time loc))
    555 
    556 ;;
    557 
    558 (define tm:time-type %time-type)
    559 
    560 (define (tm:make-time timtyp ns sec)
    561   (%make-time timtyp (number->maybe-fixnum ns) (maybe-integer->maybe-fixnum sec)) )
    562 
    563 (define (tm:set-time-nanosecond! tim ns)
    564   (%set-time-nanosecond! tim (number->maybe-fixnum ns)) )
    565 
    566 (define (tm:set-time-second! tim sec)
    567   (%set-time-second! tim (maybe-integer->maybe-fixnum sec)) )
    568 
    569 ;;
    570 
    571 (define-record-printer (time tim out)
    572   (format out "#,(time ~A ~A ~A)" (%time-type tim) (%time-nanosecond tim) (%time-second tim)) )
    573 
    574 (define-reader-ctor 'time tm:make-time)
    575 
    576 ;; Time Constants
    577 
    578 (define ONE-SECOND-DURATION (%make-time 'time-duration 0 1))
    579 
    580 (define ONE-NANOSECOND-DURATION (%make-time 'time-duration 1 0))
    581 
    582 (define (tm:make-empty-time timtyp) (%make-time timtyp 0 0))
    583 
    584 (define (tm:as-empty-time tim) (tm:make-empty-time (%time-type tim)))
    585 
    586 ;; Time Parameter Checking
    587 
    588 (define (tm:check-time-has-type loc tim timtyp)
    589   (unless (eq? timtyp (%time-type tim))
    590     (error-incompatible-time-types loc (%time-type tim) timtyp) ) )
    591 
    592 (define (tm:check-time-and-type loc tim timtyp)
    593   (%check-time loc tim)
    594   (tm:check-time-has-type loc tim timtyp) )
    595 
    596 (define tm:check-time %check-time)
    597 
    598 (define (tm:check-duration loc obj) (tm:check-time-and-type loc obj 'time-duration))
    599 
    600 (define (tm:check-time-nanoseconds loc obj)
    601   (unless (and (fixnum? obj) (fx<= 0 obj) (fx< obj NS/S))
    602     (error-invalid-nanoseconds loc obj)  ) )
    603 
    604 (define (tm:check-time-seconds loc obj) (%check-number loc obj "seconds"))
    605 
    606 (define (tm:check-time-elements loc obj1 obj2 obj3)
    607   (tm:check-time-type loc obj1)
    608   (tm:check-time-nanoseconds loc obj2)
    609   (tm:check-time-seconds loc obj3) )
    610 
    611 (define (tm:check-times loc objs) (for-each (cut tm:check-time loc <>) objs))
    612 
    613 (define (tm:time-binop-check loc obj1 obj2)
    614   (%check-time loc obj1)
    615   (%check-time loc obj2) )
    616 
    617 (define (tm:time-compare-check loc obj1 obj2)
    618   (tm:time-binop-check loc obj1 obj2)
    619   (tm:check-time-has-type loc obj1 (%time-type obj2)) )
    620 
    621 (define (tm:time-aritmetic-check loc tim dur)
    622   (%check-time loc tim)
    623   (tm:check-duration loc dur) )
    624 
    625 ;; Rem & Quo of nanoseconds per second
    626 
    627 (define (tm:split-nanoseconds nanos) (values (abs (remainder nanos NS/S)) (quotient nanos NS/S)))
    628 
    629 ;; Time CTOR
    630 
    631 (define (make-time timtyp ns sec)
    632   (tm:check-time-elements 'make-time timtyp ns sec)
    633   (tm:make-time timtyp ns sec) )
     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) )
    634223
    635224(define (make-duration
     
    637226                (hours 0) (minutes 0) (seconds 0)
    638227                (milliseconds 0) (microseconds 0) (nanoseconds 0))
    639   #;(%check-number 'make-duration days "days")
    640   #;(%check-number 'make-duration hours "hours")
    641   #;(%check-number 'make-duration minutes "minutes")
    642   #;(%check-number 'make-duration seconds "seconds")
    643   #;(%check-number 'make-duration milliseconds "milliseconds")
    644   #;(%check-number 'make-duration microseconds "microseconds")
    645   #;(%check-number 'make-duration nanoseconds "nanoseconds")
    646   (let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
    647         (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)))
    648     (receive (ns sec) (tm:split-nanoseconds nanos)
    649       (let ((sec (+ secs sec)))
    650         (tm:check-time-elements 'make-duration 'time-duration ns sec)
    651         (tm:make-time 'time-duration ns sec) ) ) ) )
    652 
    653 (define (copy-time tim) (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)))
     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) )
    654244
    655245;; Converts a seconds value, may be fractional, into a time type.
    656 ;; The type of time default is 'time-duration.
     246;; The type of time default is time-duration.
    657247
    658248(define (seconds->time/type sec . args)
    659   (let-optionals args ((timtyp 'time-duration))
    660     (let* ((tsec (truncate sec))
    661            (ns (round (abs (* (- (exact->inexact sec) tsec) NS/S)))) )
    662       (tm:check-time-elements 'seconds->time/type timtyp ns tsec)
    663       (tm:make-time timtyp ns tsec) ) ) )
     249  (check-raw-seconds 'seconds->time/type sec)
     250  (let-optionals args ((tt 'duration))
     251    (check-time-type 'seconds->time/type tt)
     252    (receive (ns sec)
     253        (tm:seconds->time-values sec)
     254      (check-time-elements 'seconds->time/type tt ns tsec)
     255      (*make-time tt ns tsec) ) ) )
    664256
    665257;; Time record-type operations
    666258
    667 (define time? %time?)
    668 
    669259(define (time-type tim)
    670   (%check-time 'time-type tim)
    671   (%time-type tim) )
     260  (check-time 'time-type tim)
     261  (tm:time-type tim) )
    672262
    673263(define (time-nanosecond tim)
    674   (%check-time 'time-nanosecond tim)
    675   (%time-nanosecond tim) )
     264  (check-time 'time-nanosecond tim)
     265  (tm:time-nanosecond tim) )
    676266
    677267(define (time-second tim)
    678   (%check-time 'time-second tim)
    679   (%time-second tim) )
    680 
    681 (define (set-time-type! tim timtyp)
    682   (%check-time 'set-time-type! tim)
    683   (tm:check-time-type 'set-time-type! timtyp)
    684   (%set-time-type! tim timtyp) )
     268  (check-time 'time-second tim)
     269  (tm:time-second tim) )
     270
     271(define (set-time-type! tim tt)
     272  (check-time 'set-time-type! tim)
     273  (check-time-type 'set-time-type! tt)
     274  (tm:time-type-set! tim tt) )
    685275
    686276(define (set-time-nanosecond! tim ns)
    687   (%check-time 'set-time-nanosecond! tim)
    688   (tm:check-time-nanoseconds 'set-time-nanosecond! ns)
    689   (tm:set-time-nanosecond! tim ns) )
     277  (check-time 'set-time-nanosecond! tim)
     278  (check-time-nanoseconds 'set-time-nanosecond! ns)
     279  (tm:time-nanosecond-set! tim ns) )
    690280
    691281(define (set-time-second! tim sec)
    692   (%check-time 'set-time-second! tim)
    693   (tm:check-time-seconds 'set-time-second! sec)
    694   (tm:set-time-second! tim sec) )
     282  (check-time 'set-time-second! tim)
     283  (check-time-seconds 'set-time-second! sec)
     284  (tm:time-second-set! tim sec) )
    695285
    696286;; Seconds Conversion
    697287
     288(define (nanoseconds->time ns . args)
     289  (let-optionals args ((tt 'duration))
     290    (receive (ns sec)
     291        (tm:nanoseconds->time-values ns)
     292      (check-time-elements 'nanoseconds->time tt ns sec)
     293      (tm:make-time tt ns sec) ) ) )
     294
     295(define (nanoseconds->seconds ns)
     296  #;(check-real 'nanoseconds->seconds ns)
     297  (tm:nanoseconds->seconds ns) )
     298
     299(define (milliseconds->time ms . args)
     300  (check-raw-milliseconds 'milliseconds->time ms)
     301  (let-optionals args ((tt 'duration))
     302    (receive (ns sec)
     303        (tm:milliseconds->time-values ms)
     304      (check-time-elements 'milliseconds->time tt ns sec)
     305      (tm:make-time tt ns sec) ) ) )
     306
     307(define (milliseconds->seconds ms)
     308  (check-raw-milliseconds 'milliseconds->seconds ms)
     309  (tm:milliseconds->seconds ms) )
     310
    698311(define (time->nanoseconds tim)
    699   (%check-time 'time->nanoseconds tim)
    700   (+ (%time-nanosecond tim) (* (%time-second tim) NS/S)) )
    701 
    702 (define (nanoseconds->time ns . args)
    703   (let-optionals args ((timtyp 'time-duration))
    704     (receive (ns sec) (tm:split-nanoseconds ns)
    705       (tm:check-time-elements 'nanoseconds->time timtyp ns sec)
    706       (tm:make-time timtyp ns sec) ) ) )
    707 
    708 (define (nanoseconds->seconds ns) (/ ns NS/S))
     312  (check-time 'time->nanoseconds tim)
     313  (tm:time->nanoseconds tim) )
    709314
    710315(define (time->milliseconds tim)
    711   (%check-time 'time->milliseconds tim)
    712   (+ (/ (%time-nanosecond tim) NS/MS) (* (%time-second tim) MS/S)) )
    713 
    714 (define (milliseconds->time ms . args)
    715   (let-optionals args ((timtyp 'time-duration))
    716     (let ((ns (fx* (remainder ms MS/S) NS/MS))
    717           (sec (quotient ms MS/S)) )
    718       (tm:check-time-elements 'milliseconds->time timtyp ns sec)
    719       (tm:make-time timtyp ns sec) ) ) )
    720 
    721 (define (milliseconds->seconds ms) (/ (exact->inexact ms) MS/S))
     316  (check-time 'time->milliseconds tim)
     317  (tm:time->milliseconds tim) )
     318
     319(define (time->seconds tim)
     320  (check-time 'time->seconds tim)
     321  (tm:time->seconds tim) )
    722322
    723323;; Current time routines
    724324
    725 ; Throw away everything but the sub-second bit.
    726 ; Chicken 'current-milliseconds' within positive fixnum range
    727 (define (tm:current-sub-milliseconds) (fxmod (current-milliseconds) MS/S))
    728 
    729 (define (tm:current-nanoseconds) (* (tm:current-sub-milliseconds) NS/MS))
    730 
    731 ;Use the 'official' seconds & nanoseconds values
    732 (define (tm:current-time-values) (values (tm:current-nanoseconds) (current-seconds)))
    733 
    734 (define (tm:current-time-utc)
    735   (receive (ns sec) (tm:current-time-values)
    736     (tm:make-time 'time-utc ns sec)) )
    737 
    738 (define (tm:current-time-tai)
    739   (receive (ns sec) (tm:current-time-values)
    740     (tm:make-time 'time-tai ns (+ sec (%leap-second-delta sec))) ) )
    741 
    742 (define (tm:current-time-monotonic)
    743   (let ((tim (tm:current-time-tai)))
    744     (%set-time-type! tim 'time-monotonic)
    745     tim ) )
    746 
    747 (define (tm:current-time-thread)
    748   (milliseconds->time (current-thread-milliseconds) 'time-thread) )
    749 
    750 (define (tm:current-time-process)
    751   (milliseconds->time (current-process-milliseconds) 'time-process) )
    752 
    753 (define (tm:current-time-gc)
    754   (milliseconds->time (total-gc-milliseconds) 'time-gc) )
    755 
    756 ;;
    757 
    758 (define (current-time . timtyp)
    759   (let ((timtyp (optional timtyp 'time-utc)))
    760     (tm:check-time-type 'current-time timtyp)
    761     (case timtyp
    762       ((time-monotonic) (tm:current-time-monotonic))
    763       ((time-utc)       (tm:current-time-utc))
    764       ((time-tai)       (tm:current-time-tai))
    765       ((time-gc)        (tm:current-time-gc))
    766       ((time-process)   (tm:current-time-process))
    767       ((time-thread)    (tm:current-time-thread))) ) )
    768 
    769 ;; SRFI-18 Routines
    770 ;; Coupling here
    771 
    772 (define (srfi-18-time->time srfi-18-tim)
    773   (tm:make-time 'time-duration (* (##sys#slot srfi-18-tim 3) NS/MS) (##sys#slot srfi-18-tim 2)) )
    774 
    775 (define (time->srfi-18-time tim)
    776   (%check-time 'time->srfi-18-time tim)
    777   (seconds->time (nanoseconds->seconds (time->nanoseconds tim))) )
    778 
    779 (define srfi-19:time? time?)
    780 
    781 (define srfi-19:current-time current-time)
     325(define (current-time . args)
     326  (let-optionals args ((tt 'utc))
     327    (case tt
     328      ((monotonic) (tm:current-time-monotonic))
     329      ((utc)       (tm:current-time-utc))
     330      ((tai)       (tm:current-time-tai))
     331      ((gc)        (tm:current-time-gc))
     332      ((process)   (tm:current-time-process))
     333      ((thread)    (tm:current-time-thread))
     334      (else
     335        (error-time-type 'current-time tt)) ) ) )
    782336
    783337;; -- Time Resolution
     
    785339;; This will be implementation specific.
    786340
    787 (define (time-resolution . timtyp)
    788   (tm:check-time-type 'time-resolution (optional timtyp 'time-utc))
    789   NS/MS )
     341(define (time-resolution . args)
     342  (let-optionals args ((tt 'utc))
     343    (check-time-type 'time-resolution tt)
     344    (tm:time-resolution tt) ) )
     345
     346;; SRFI-18 Routines
     347
     348(define (srfi-18-time->time srfi-18-tim)
     349  (seconds->time/type (srfi-18:time->seconds srfi-18-tim) 'duration) )
     350
     351(define (time->srfi-18-time tim)
     352  (check-time 'time->srfi-18-time tim)
     353  (srfi-18:seconds->time (tm:time->seconds tim)) )
    790354
    791355;; Time Comparison
    792356
    793 (define (tm:time-compare tim1 tim2)
    794   (let ((dif (- (%time-second tim1) (%time-second tim2))))
    795     (if (not (zero? dif)) dif
    796         (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
    797 
    798 (define (tm:time=? tim1 tim2)
    799   (and (= (%time-second tim1) (%time-second tim2))
    800        (fx= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
    801 
    802 (define (tm:time<? tim1 tim2)
    803   (or (< (%time-second tim1) (%time-second tim2))
    804       (and (= (%time-second tim1) (%time-second tim2))
    805            (fx< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    806 
    807 (define (tm:time<=? tim1 tim2)
    808   (or (< (%time-second tim1) (%time-second tim2))
    809       (and (= (%time-second tim1) (%time-second tim2))
    810            (fx<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    811 
    812 (define (tm:time>? tim1 tim2)
    813   (or (> (%time-second tim1) (%time-second tim2))
    814       (and (= (%time-second tim1) (%time-second tim2))
    815            (fx> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    816 
    817 (define (tm:time>=? tim1 tim2)
    818   (or (> (%time-second tim1) (%time-second tim2))
    819       (and (= (%time-second tim1) (%time-second tim2))
    820            (fx>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    821 
    822 (define (tm:time-max tim . rest)
    823   (let loop ((acc tim) (ls rest))
    824     (if (null? ls) acc
    825         (let ((tim (car ls)))
    826           (loop (if (tm:time<? acc tim) tim acc) (cdr ls)))) ) )
    827 
    828 (define (tm:time-min tim . rest)
    829   (let loop ((acc tim) (ls rest))
    830     (if (null? ls) acc
    831         (let ((tim (car ls)))
    832           (loop (if (tm:time>? acc tim) tim acc) (cdr ls)))) ) )
    833 
    834357(define (time-compare tim1 tim2)
    835   (tm:time-compare-check 'time-compare tim1 tim2)
     358  (check-time-compare 'time-compare tim1 tim2)
    836359  (let ((dif (tm:time-compare tim1 tim2)))
    837360    (cond ((negative? dif)  -1)
     
    840363
    841364(define (time=? tim1 tim2)
    842   (tm:time-compare-check 'time=? tim1 tim2)
     365  (check-time-compare 'time=? tim1 tim2)
    843366  (tm:time=? tim1 tim2) )
    844367
    845368(define (time>? tim1 tim2)
    846   (tm:time-compare-check 'time>? tim1 tim2)
     369  (check-time-compare 'time>? tim1 tim2)
    847370  (tm:time>? tim1 tim2) )
    848371
    849372(define (time<? tim1 tim2)
    850   (tm:time-compare-check 'time<? tim1 tim2)
     373  (check-time-compare 'time<? tim1 tim2)
    851374  (tm:time<? tim1 tim2) )
    852375
    853376(define (time>=? tim1 tim2)
    854   (tm:time-compare-check 'time>=? tim1 tim2)
     377  (check-time-compare 'time>=? tim1 tim2)
    855378  (tm:time>=? tim1 tim2) )
    856379
    857380(define (time<=? tim1 tim2)
    858   (tm:time-compare-check 'time<=? tim1 tim2)
     381  (check-time-compare 'time<=? tim1 tim2)
    859382  (tm:time<=? tim1 tim2) )
    860383
    861384(define (time-max tim1 . rest)
    862   (tm:check-times 'time-max (cons tim1 rest))
    863   (apply tm:time-max tim1 rest) )
     385  (check-time 'time-max tim1)
     386  (let ((tt (tm:time-type tim1)))
     387    (let loop ((acc tim1) (ls rest))
     388      (if (null? ls) acc
     389          (let ((tim (car ls)))
     390            (check-time-and-type 'time-max tim tt)
     391            (loop (if (tm:time<? acc tim) tim acc) (cdr ls)) ) ) ) ) )
    864392
    865393(define (time-min tim1 . rest)
    866   (tm:check-times 'time-min (cons tim1 rest))
    867   (apply tm:time-min tim1 rest) )
     394  (check-time 'time-min tim1)
     395  (let ((tt (tm:time-type tim1)))
     396    (let loop ((acc tim1) (ls rest))
     397      (if (null? ls) acc
     398          (let ((tim (car ls)))
     399            (check-time-and-type 'time-min tim tt)
     400            (loop (if (tm:time>? acc tim) tim acc) (cdr ls)) ) ) ) ) )
    868401
    869402;; Time Arithmetic
    870403
    871 (define (tm:time-difference tim1 tim2 tim3)
    872   (%set-time-type! tim3 'time-duration)
    873   (cond ((tm:time=? tim1 tim2)
    874          (tm:set-time-second! tim3 0)
    875          (tm:set-time-nanosecond! tim3 0) )
    876         (else
    877          (receive (ns sec)
    878              (tm:split-nanoseconds (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
    879            (tm:set-time-second! tim3 sec)
    880            (tm:set-time-nanosecond! tim3 ns) ) ) )
    881   tim3 )
    882 
    883 (define (tm:add-duration tim1 dur tim3)
    884   (let ((sec-plus (+ (%time-second tim1) (%time-second dur)))
    885         (nsec-plus (+ (%time-nanosecond tim1) (%time-nanosecond dur))))
    886     (tm:set-time-second! tim3 (+ sec-plus (quotient nsec-plus NS/S)))
    887     (tm:set-time-nanosecond! tim3 (remainder nsec-plus NS/S))
    888     tim3 ) )
    889 
    890 (define (tm:subtract-duration tim1 dur tim3)
    891   (let ((sec-minus (- (%time-second tim1) (%time-second dur)))
    892         (nsec-minus (fx- (%time-nanosecond tim1) (%time-nanosecond dur))))
    893     (let ((r (fxmod nsec-minus NS/S))
    894           (secs (- sec-minus (fx/ nsec-minus NS/S))))
    895       (cond ((fx< r 0)
    896              (tm:set-time-second! tim3 (- secs 1))
    897              (tm:set-time-nanosecond! tim3 (fx+ NS/S r)) )
    898             (else
    899              (tm:set-time-second! tim3 secs)
    900              (tm:set-time-nanosecond! tim3 r) ) )
    901       tim3 ) ) )
    902 
    903 (define (tm:divide-duration dur1 num dur3)
    904   (receive (ns sec)
    905       (tm:split-nanoseconds (/ (time->nanoseconds dur1) num))
    906     (tm:set-time-nanosecond! dur3 ns)
    907     (tm:set-time-second! dur3 sec)
    908     dur3 ) )
    909 
    910 (define (tm:multiply-duration dur1 num dur3)
    911   (receive (ns sec)
    912       (tm:split-nanoseconds (* (time->nanoseconds dur1) num))
    913     (tm:set-time-nanosecond! dur3 ns)
    914     (tm:set-time-second! dur3 sec)
    915     dur3 ) )
    916 
    917 (define (tm:time-abs tim1 tim3)
    918   (tm:set-time-second! tim3 (abs (%time-second tim1)))
    919   tim3 )
    920 
    921 (define (tm:time-negate tim1 tim3)
    922   (tm:set-time-second! tim3 (- (%time-second tim1)))
    923   tim3 )
    924 
    925 ;;
    926 
    927404(define (time-difference tim1 tim2)
    928   (tm:time-compare-check 'time-difference tim1 tim2)
    929   (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) )
     405  (check-time-compare 'time-difference tim1 tim2)
     406  (tm:time-difference tim1 tim2 (tm:some-time 'duration)) )
     407
     408(define (add-duration tim dur)
     409  (check-time-aritmetic 'add-duration tim dur)
     410  (tm:add-duration tim dur (tm:as-some-time tim)) )
     411
     412(define (subtract-duration tim dur)
     413  (check-time-aritmetic 'subtract-duration tim dur)
     414  (tm:subtract-duration tim dur (tm:as-some-time tim)) )
     415
     416(define (divide-duration dur num)
     417  (check-duration 'divide-duration dur)
     418  (tm:divide-duration dur num (tm:some-time 'duration)) )
     419
     420(define (multiply-duration dur num)
     421  (check-duration 'multiply-duration dur)
     422  (tm:multiply-duration dur num (tm:some-time 'duration)) )
     423
     424(define (time-abs tim)
     425  (check-time 'time-abs tim)
     426  (tm:time-abs tim (tm:as-some-time tim)) )
     427
     428(define (time-negate tim)
     429  (check-time 'time-negate tim)
     430  (tm:time-negate tim (tm:as-some-time tim)) )
     431
     432;;
    930433
    931434(define (time-difference! tim1 tim2)
    932   (tm:time-compare-check 'time-difference! tim1 tim2)
     435  (check-time-compare 'time-difference! tim1 tim2)
    933436  (tm:time-difference tim1 tim2 tim1) )
    934437
    935 (define (add-duration tim dur)
    936   (tm:time-aritmetic-check 'add-duration tim dur)
    937   (tm:add-duration tim dur (tm:as-empty-time tim)) )
    938 
    939438(define (add-duration! tim dur)
    940   (tm:time-aritmetic-check 'add-duration! tim dur)
     439  (check-time-aritmetic 'add-duration! tim dur)
    941440  (tm:add-duration tim dur tim) )
    942441
    943 (define (subtract-duration tim dur)
    944   (tm:time-aritmetic-check 'subtract-duration tim dur)
    945   (tm:subtract-duration tim dur (tm:as-empty-time tim)) )
    946 
    947442(define (subtract-duration! tim dur)
    948   (tm:time-aritmetic-check 'subtract-duration! tim dur)
     443  (check-time-aritmetic 'subtract-duration! tim dur)
    949444  (tm:subtract-duration tim dur tim) )
    950445
    951 (define (divide-duration dur num)
    952   (tm:check-duration 'divide-duration dur)
    953   (tm:divide-duration dur num (tm:as-empty-time dur)) )
    954 
    955446(define (divide-duration! dur num)
    956   (tm:check-duration 'divide-duration! dur)
     447  (check-duration 'divide-duration! dur)
    957448  (tm:divide-duration dur num dur) )
    958449
    959 (define (multiply-duration dur num)
    960   (tm:check-duration 'multiply-duration dur)
    961   (tm:multiply-duration dur num (tm:as-empty-time dur)) )
    962 
    963450(define (multiply-duration! dur num)
    964   (tm:check-duration 'multiply-duration! dur)
     451  (check-duration 'multiply-duration! dur)
    965452  (tm:multiply-duration dur num dur) )
    966453
     454(define (time-abs! tim)
     455  (check-time 'time-abs! tim)
     456  (tm:time-abs tim tim) )
     457
     458(define (time-negate! tim)
     459  (check-time 'time-negate! tim)
     460  (tm:time-negate tim tim) )
     461
     462;;
     463
    967464(define (time-negative? tim)
    968   (%check-time 'time-negative? tim)
    969   (negative? (%time-second tim)) )
     465  (check-time 'time-negative? tim)
     466  ;nanoseconds irrelevant
     467  (negative? (tm:time-second tim)) )
    970468
    971469(define (time-positive? tim)
    972   (%check-time 'time-positive? tim)
    973   (positive? (%time-second tim)) )
     470  (check-time 'time-positive? tim)
     471  ;nanoseconds irrelevant
     472  (positive? (tm:time-second tim)) )
    974473
    975474(define (time-zero? tim)
    976   (%check-time 'time-zero? tim)
    977   (and (zero? (%time-nanosecond tim))
    978        (zero? (%time-second tim))) )
    979 
    980 (define (time-abs tim)
    981   (%check-time 'time-abs tim)
    982   (tm:time-abs tim (tm:as-empty-time tim)) )
    983 
    984 (define (time-abs! tim)
    985   (%check-time 'time-abs! tim)
    986   (tm:time-abs tim tim) )
    987 
    988 (define (time-negate tim)
    989   (%check-time 'time-negate tim)
    990   (tm:time-negate tim (tm:as-empty-time tim)) )
    991 
    992 (define (time-negate! tim)
    993   (%check-time 'time-negate! tim)
    994   (tm:time-negate tim tim) )
    995 
    996 ;; Time Type Converters
    997 
    998 (define (tm:time-tai->time-utc tim-in tim-out)
    999   (%set-time-type! tim-out 'time-utc)
    1000   (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
    1001   (tm:set-time-second! tim-out
    1002    (- (%time-second tim-in) (%leap-second-neg-delta (%time-second tim-in))))
    1003   tim-out )
    1004 
    1005 (define (tm:time-utc->time-tai tim-in tim-out)
    1006   (%set-time-type! tim-out 'time-tai)
    1007   (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
    1008   (tm:set-time-second! tim-out
    1009    (+ (%time-second tim-in) (%leap-second-delta (%time-second tim-in))))
    1010   tim-out )
    1011 
    1012 (define (tm:time-monotonic->time-tai tim-in tim-out)
    1013   (%set-time-type! tim-out 'time-tai)
    1014   (unless (eq? tim-in tim-out)
    1015     (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
    1016     (tm:set-time-second! tim-out (%time-second tim-in)))
    1017   tim-out )
    1018 
    1019 (define (tm:time-tai->time-monotonic tim-in tim-out)
    1020   (%set-time-type! tim-out 'time-monotonic)
    1021   (unless (eq? tim-in tim-out)
    1022     (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
    1023     (tm:set-time-second! tim-out (%time-second tim-in)))
    1024   tim-out )
    1025 
    1026 (define (tm:time-monotonic->time-utc tim-in tim-out)
    1027   (%set-time-type! tim-in 'time-tai) ; fool converter (unnecessary)
    1028   (tm:time-tai->time-utc tim-in tim-out) )
    1029 
    1030 (define (tm:time-utc->time-monotonic tim-in tim-out)
    1031   (let ((ntim (tm:time-utc->time-tai tim-in tim-out)))
    1032     (%set-time-type! ntim 'time-monotonic)
    1033     ntim ) )
     475  (check-time 'time-zero? tim)
     476  (and (zero? (tm:time-nanosecond tim))
     477       (zero? (tm:time-second tim))) )
    1034478
    1035479;; Time Type Conversion
    1036480
     481;;
     482
    1037483(define (time-tai->time-utc tim)
    1038   (tm:check-time-and-type 'time-tai->time-utc tim 'time-tai)
    1039   (tm:time-tai->time-utc tim (tm:as-empty-time tim)) )
     484  (check-time-and-type 'time-tai->time-utc tim 'tai)
     485  (tm:time-tai->time-utc tim (tm:any-time)) )
     486
     487(define (time-tai->time-monotonic tim)
     488  (check-time-and-type 'time-tai->time-monotonic tim 'tai)
     489  (tm:time-tai->time-monotonic tim (tm:any-time)) )
     490
     491(define (time-utc->time-tai tim)
     492  (check-time-and-type 'time-utc->time-tai tim 'utc)
     493  (tm:time-utc->time-tai tim (tm:any-time)) )
     494
     495(define (time-utc->time-monotonic tim)
     496  (check-time-and-type 'time-utc->time-monotonic tim 'utc)
     497  (tm:time-utc->time-monotonic tim (tm:any-time)) )
     498
     499(define (time-monotonic->time-utc tim)
     500  (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic)
     501  (let ((ntim (tm:copy-time tim)))
     502    (tm:time-monotonic->time-utc ntim ntim) ) )
     503
     504(define (time-monotonic->time-tai tim)
     505  (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic)
     506  (tm:time-monotonic->time-tai tim (tm:any-time)) )
     507
     508;;
    1040509
    1041510(define (time-tai->time-utc! tim)
    1042   (tm:check-time-and-type 'time-tai->time-utc! tim 'time-tai)
     511  (check-time-and-type 'time-tai->time-utc! tim 'tai)
    1043512  (tm:time-tai->time-utc tim tim) )
    1044513
    1045 (define (time-tai->time-monotonic tim)
    1046   (tm:check-time-and-type 'time-tai->time-monotonic tim 'time-tai)
    1047   (tm:time-tai->time-monotonic tim (tm:as-empty-time tim)) )
    1048 
    1049514(define (time-tai->time-monotonic! tim)
    1050   (tm:check-time-and-type 'time-tai->time-monotonic! tim 'time-tai)
     515  (check-time-and-type 'time-tai->time-monotonic! tim 'tai)
    1051516  (tm:time-tai->time-monotonic tim tim) )
    1052517
    1053 (define (time-utc->time-tai tim)
    1054   (tm:check-time-and-type 'time-utc->time-tai tim 'time-utc)
    1055   (tm:time-utc->time-tai tim (tm:as-empty-time tim)) )
    1056 
    1057518(define (time-utc->time-tai! tim)
    1058   (tm:check-time-and-type 'time-utc->time-tai! tim 'time-utc)
     519  (check-time-and-type 'time-utc->time-tai! tim 'utc)
    1059520  (tm:time-utc->time-tai tim tim) )
    1060521
    1061 (define (time-utc->time-monotonic tim)
    1062   (tm:check-time-and-type 'time-utc->time-monotonic tim 'time-utc)
    1063   (tm:time-utc->time-monotonic tim (tm:as-empty-time tim)) )
    1064 
    1065522(define (time-utc->time-monotonic! tim)
    1066   (tm:check-time-and-type 'time-utc->time-monotonic! tim 'time-utc)
     523  (check-time-and-type 'time-utc->time-monotonic! tim 'utc)
    1067524  (tm:time-utc->time-monotonic tim tim) )
    1068525
    1069 (define (time-monotonic->time-utc tim)
    1070   (tm:check-time-and-type 'time-monotoinc->time-utc tim 'time-monotonic)
    1071   (let ((ntim (copy-time tim)))
    1072     (tm:time-monotonic->time-utc ntim ntim) ) )
    1073 
    1074526(define (time-monotonic->time-utc! tim)
    1075   (tm:check-time-and-type 'time-monotoinc->time-utc! tim 'time-monotonic)
     527  (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic)
    1076528  (tm:time-monotonic->time-utc tim tim) )
    1077529
    1078 (define (time-monotonic->time-tai tim)
    1079   (tm:check-time-and-type 'time-monotoinc->time-tai tim 'time-monotonic)
    1080   (tm:time-monotonic->time-tai tim (tm:as-empty-time tim)) )
    1081 
    1082530(define (time-monotonic->time-tai! tim)
    1083   (tm:check-time-and-type 'time-monotoinc->time-tai! tim 'time-monotonic)
     531  (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic)
    1084532  (tm:time-monotonic->time-tai tim tim) )
    1085533
    1086 ;;; Timezone Locale Object (Public Immutable, but not enforced)
    1087 
    1088 (define-inline (%make-utc-timezone)
    1089   (let ((tz (make-timezone-components "UTC0" BUILTIN-SOURCE)))
    1090     (update-timezone-components! tz 'std-name "UTC" 'std-offset 0) ) )
    1091 
    1092 (define-inline (%timezone-components-ref/dst? tzc a b)
    1093   (timezone-component-ref tzc (if (timezone-component-ref tzc 'dst?) a b)) )
    1094 
    1095 (define (warning-timezone-components loc obj)
    1096   (warning loc "bad argument type - expected a timezone-components object" obj) )
    1097 
    1098 ;;
    1099 
    1100 ;DEPRECATED
    1101 (define (make-timezone-locale dstf tzc)
    1102   (unless (timezone-components? tzc)
    1103     (error-invalid-timezone-components 'make-timezone-locale tzc) )
    1104   (set-timezone-component! tzc 'dst? (->boolean dstf))
    1105   tzc )
    1106 
    1107 ;DEPRECATED
    1108 (define timezone-locale? timezone-components?)
    1109 
    1110 ;;
    1111 
    1112 (define-parameter local-timezone-locale (current-timezone-components)
     534
     535;;; Date Object (Public Immutable)
     536
     537;;
     538
     539(define-parameter default-date-clock-type 'utc
    1113540  (lambda (obj)
    1114     (cond ((timezone-components? obj) obj)
     541    (cond ((clock-type? obj) obj)
    1115542          (else
    1116            (warning-timezone-components 'local-timezone-locale obj)
    1117            (local-timezone-locale) ) ) ) )
    1118 
    1119 (define-parameter utc-timezone-locale (%make-utc-timezone)
    1120   (lambda (obj)
    1121     (cond ((timezone-components? obj) obj)
    1122           (else
    1123            (warning-timezone-components 'utc-timezone-locale obj)
    1124            (utc-timezone-locale) ) ) ) )
    1125 
    1126 ;;
    1127 
    1128 (define (timezone-locale-name . tzc)
    1129   (let ((tzc (optional tzc (local-timezone-locale))))
    1130     (check-timezone-components 'timezone-locale-name tzc)
    1131     (let ((tzn (%timezone-components-ref/dst? tzc 'dst-name 'std-name)))
    1132       ; TZ may not be set
    1133       (and (not (eq? UNKNOWN-LOCAL-TZ-NAME tzn))
    1134            tzn ) ) ) )
    1135 
    1136 (define (timezone-locale-offset . tzc)
    1137   (let ((tzc (optional tzc (local-timezone-locale))))
    1138     (check-timezone-components 'timezone-locale-offset tzc)
    1139     (let ((tzo (%timezone-components-ref/dst? tzc 'dst-offset 'std-offset)))
    1140       ; TZ may not be set but if it is then convert to ISO 8601
    1141       (if tzo (fxneg tzo)
    1142           0 ) ) ) )
    1143 
    1144 (define (timezone-locale-dst? . tzc)
    1145   (let ((tzc (optional tzc (local-timezone-locale))))
    1146     (check-timezone-components 'timezone-locale-offset tzc)
    1147     (timezone-component-ref tzc 'dst?) ) )
    1148 
    1149 ;;; Date Object (Public Immutable)
    1150 
    1151 (define-record-type/primitive date
    1152   (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    1153   %date?
    1154   (ns     %date-nanosecond  %date-nanosecond-set!)
    1155   (sec    %date-second      %date-second-set!)
    1156   (min    %date-minute      %date-minute-set!)
    1157   (hr     %date-hour        %date-hour-set!)
    1158   (dy     %date-day         %date-day-set!)
    1159   (mn     %date-month       %date-month-set!)
    1160   (yr     %date-year        %date-year-set!)
    1161   (tzo    %date-zone-offset %date-zone-offset-set!)
    1162   ;; non-srfi extn
    1163   (tzn    %date-zone-name)
    1164   (dstf   %date-dst?)
    1165   (wdy    %date-wday        %date-wday-set!)
    1166   (ydy    %date-yday        %date-yday-set!)
    1167   (jdy    %date-jday        %date-jday-set!) )
    1168 
    1169 ;;
    1170 
    1171 (define-inline (%check-date loc obj) (##sys#check-structure obj 'date loc))
    1172 
    1173 ;;
    1174 
    1175 (define (tm:date-nanosecond-set! dat x) (%date-nanosecond-set! dat (number->maybe-fixnum x)))
    1176 
    1177 (define (tm:date-second-set! dat x) (%date-second-set! dat (number->maybe-fixnum x)))
    1178 
    1179 (define (tm:date-minute-set! dat x) (%date-minute-set! dat (number->maybe-fixnum x)))
    1180 
    1181 (define (tm:date-hour-set! dat x) (%date-hour-set! dat (number->maybe-fixnum x)))
    1182 
    1183 (define (tm:date-day-set! dat x) (%date-day-set! dat (number->maybe-fixnum x)))
    1184 
    1185 (define (tm:date-month-set! dat x) (%date-month-set! dat (number->maybe-fixnum x)))
    1186 
    1187 (define (tm:date-year-set! dat x) (%date-year-set! dat (number->maybe-fixnum x)))
    1188 
    1189 (define (tm:date-zone-offset-set! dat x) (%date-zone-offset-set! dat (number->maybe-fixnum x)))
    1190 
    1191 ;; Leap Year Test
    1192 
    1193 ;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
    1194 ;; The Journal of the Royal Astronomical Society of Canada.
    1195 ;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
    1196 ;; Part II, volume 58, number 2, pages 79-87 (April 1964).
    1197 
    1198 (define (tm:leap-year? year)
    1199   (and (not (fx= (fxmod year 4000) 0)) ;Not officially adopted!
    1200        (or (fx= (fxmod year 400) 0)
    1201                 (and (fx= (fxmod year 4) 0)
    1202                      (not (fx= (fxmod year 100) 0))))) )
    1203 
    1204 ;; Days per Month
    1205 
    1206 (define tm:dys/mn '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
    1207 
    1208 (define tm:leap-year-dys/mn '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
    1209 
    1210 (define (tm:days-in-month mn yr)
    1211   (vector-ref (if (tm:leap-year? yr) tm:leap-year-dys/mn tm:dys/mn) mn) )
    1212 
    1213 (define tm:cumulative-month-days '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
    1214 
    1215 ;; Returns an invalid date record (for use by 'scan-date')
    1216 
    1217 (define (tm:make-incomplete-date)
    1218   (%make-date
    1219    0
    1220    0 0 0
    1221    #f #f #f
    1222    (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
    1223    #f #f #f) )
    1224 
    1225 ;; Internal Date CTOR
    1226 
    1227 (define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    1228   (%make-date
    1229    (number->maybe-fixnum ns)
    1230    (number->maybe-fixnum sec) (number->maybe-fixnum min) (number->maybe-fixnum hr)
    1231    (number->maybe-fixnum dy) (number->maybe-fixnum mn) (number->maybe-fixnum yr)
    1232    (number->maybe-fixnum tzo) tzn dstf
    1233    wdy ydy jdy) )
    1234 
    1235 ;; Parameter Checking
    1236 
    1237 (define tm:check-date %check-date)
    1238 
    1239 ; No year 0!
    1240 (define (tm:check-year loc yr)
    1241   (unless (and (fixnum? yr) (not (fx= 0 yr)))
    1242     (error-invalid-year loc yr) ) )
    1243 
    1244 ; Months in [1 12]
    1245 (define (tm:check-month loc mn)
    1246   (unless (and (fixnum? mn) (fx<= 1 mn) (fx<= mn 12))
    1247     (error-invalid-month loc mn) ) )
    1248 
    1249 ; Days in [1 28/29/30/31] - depending on month & year
    1250 (define (tm:check-day loc dy mn yr)
    1251   (unless (and (fixnum? dy) (fx<= 1 dy) (fx<= dy (tm:days-in-month mn yr)))
    1252     (error-invalid-day loc dy) ) )
    1253 
    1254 (define (tm:check-exploded-date loc ns sec min hr dy mn yr tzo tzn)
    1255 
    1256   ; Same as time object
    1257   (tm:check-time-nanoseconds loc ns)
    1258 
    1259   ; Seconds in [0 60] ; 60 legal due to leap second
    1260   (unless (and (fixnum? sec) (fx<= 0 sec) (fx<= sec 60))
    1261     (error-invalid-seconds loc sec))
    1262 
    1263   ; Minutes in [0 59]
    1264   (unless (and (fixnum? min) (and (fx<= 0 min) (fx< min 60)))
    1265     (error-invalid-minutes loc min)  )
    1266 
    1267   ; Hours in [0 23]
    1268   (unless (and (fixnum? hr) (and (<= 0 hr) (< hr 24)))
    1269     (error-invalid-hours loc hr) )
    1270 
    1271   ; Year, Month & Day within limits
    1272   (tm:check-year loc yr)
    1273   (tm:check-month loc mn)
    1274   (tm:check-day loc dy mn yr)
    1275 
    1276   ; Timezone offset in (-SEC/DY +SEC/DY)
    1277   (unless (and (fixnum? tzo) (let ((atzo (fxabs tzo))) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
    1278     (error-invalid-timezone-offset loc tzo))
    1279 
    1280   ; Timezone not specified or a string
    1281   (unless (or (not tzn) (string? tzn))
    1282     (error-invalid-timezone-name loc tzn)  ) )
    1283 
    1284 ;; Date Syntax
    1285 
    1286 (define-record-printer (date dat out)
    1287   (format out
    1288    "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
    1289    (%date-nanosecond dat)
    1290    (%date-second dat) (%date-minute dat) (%date-hour dat)
    1291    (%date-day dat) (%date-month dat) (%date-year dat)
    1292    (%date-zone-offset dat)
    1293    (%date-zone-name dat) (%date-dst? dat)
    1294    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
    1295 
    1296 (define-reader-ctor 'date
    1297   (lambda (ns sec min hr dy mn yr tzo . rest)
    1298     (let-optionals rest ((tzn #f) (dstf #f) (wdy #f) (ydy #f) (jdy #f))
    1299       (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy))))
     543           (warning-argument-type 'default-date-clock-type obj 'clock-type)
     544           (default-date-clock-type) ) ) ) )
    1300545
    1301546;; Date CTOR
    1302547
    1303 (define (make-date ns sec min hr dy mn yr tzo . rest)
    1304   (let-optionals rest ((tzn #f) (dstf (void)))
     548(define (make-date ns sec min hr dy mn yr tzo . args)
     549  (let-optionals args ((tzn #f) (dstf (void)))
    1305550    (cond ((timezone-components? tzo)
    1306551           ; Supplied parameters override
     
    1310555          (else
    1311556           (when (eq? (void) dstf) (set! dstf #f)) ) )
    1312     (tm:check-exploded-date 'make-date ns sec min hr dy mn yr tzo tzn)
     557    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
    1313558    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
    1314559
    1315560(define (copy-date dat)
    1316   (%make-date
    1317    (%date-nanosecond dat)
    1318    (%date-second dat) (%date-minute dat) (%date-hour dat)
    1319    (%date-day dat) (%date-month dat) (%date-year dat)
    1320    (%date-zone-offset dat)
    1321    (%date-zone-name dat) (%date-dst? dat)
    1322    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
     561  (check-date 'copy-date dat)
     562  (tm:copy-date dat) )
    1323563
    1324564;; Converts a seconds value, may be fractional, into a date type.
     
    1328568
    1329569(define (seconds->date/type sec . tzc)
    1330   (unless (number? sec)
    1331     (error-invalid-seconds 'seconds->date/type sec) )
     570  (check-raw-seconds 'seconds->date/type sec)
    1332571  (let ((tzc (optional tzc #f)))
    1333572    (if (boolean? tzc)
    1334573        (set! tzc ((if tzc local-timezone-locale utc-timezone-locale)))
    1335         (unless (timezone-components? tzc)
    1336           (error-invalid-timezone-components 'seconds->date/type tzc) ) )
    1337     (let* ((fsec (exact->inexact sec))
    1338            (isec (truncate fsec))
    1339            (tzo (timezone-locale-offset tzc))
    1340            (tv (seconds->utc-time (+ isec tzo))))
    1341       (tm:make-date
    1342        (round (* (- fsec isec) NS/S))
    1343        (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
    1344        (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
    1345        tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
    1346        (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) ) )
    1347 
    1348 (define (current-date . tzc) (apply time-utc->date (tm:current-time-utc) tzc))
    1349 
    1350 ;;
    1351 
    1352 (define date? %date?)
     574        (check-timezone-components 'seconds->date/type tzc) )
     575    (tm:seconds->date/type sec tzc) ) )
     576
     577(define (current-date . tzi)
     578  (tm:time-utc->date (tm:current-time-utc)
     579                     (checked-optional-timezone-info 'current-date (optional tzi #f))) )
    1353580
    1354581;;
    1355582
    1356583(define (date-nanosecond dat)
    1357         (%check-date 'date-nanosecond dat)
    1358         (%date-nanosecond dat) )
     584        (check-date 'date-nanosecond dat)
     585        (tm:date-nanosecond dat) )
    1359586
    1360587(define (date-second dat)
    1361         (%check-date 'date-second dat)
    1362         (%date-second dat) )
     588        (check-date 'date-second dat)
     589        (tm:date-second dat) )
    1363590
    1364591(define (date-minute dat)
    1365         (%check-date 'date-minute dat)
    1366         (%date-minute dat) )
     592        (check-date 'date-minute dat)
     593        (tm:date-minute dat) )
    1367594
    1368595(define (date-hour dat)
    1369         (%check-date 'date-hour dat)
    1370         (%date-hour dat) )
     596        (check-date 'date-hour dat)
     597        (tm:date-hour dat) )
    1371598
    1372599(define (date-day dat)
    1373         (%check-date 'date-day dat)
    1374         (%date-day dat) )
     600        (check-date 'date-day dat)
     601        (tm:date-day dat) )
    1375602
    1376603(define (date-month dat)
    1377         (%check-date 'date-month dat)
    1378         (%date-month dat) )
     604        (check-date 'date-month dat)
     605        (tm:date-month dat) )
    1379606
    1380607(define (date-year dat)
    1381         (%check-date 'date-year dat)
    1382         (%date-year dat) )
     608        (check-date 'date-year dat)
     609        (tm:date-year dat) )
    1383610
    1384611(define (date-dst? dat)
    1385         (%check-date 'date-dst? dat)
    1386         (%date-dst? dat) )
     612        (check-date 'date-dst? dat)
     613        (tm:date-dst? dat) )
    1387614
    1388615(define (date-zone-offset dat)
    1389         (%check-date 'date-zone-offset dat)
    1390         (%date-zone-offset dat) )
     616        (check-date 'date-zone-offset dat)
     617        (tm:date-zone-offset dat) )
    1391618
    1392619(define (date-zone-name dat)
    1393         (%check-date 'date-zone-name dat)
    1394         (%date-zone-name dat) )
     620        (check-date 'date-zone-name dat)
     621        (tm:date-zone-name dat) )
    1395622
    1396623;; Date Comparison
    1397624
    1398 (define (tm:date-compare loc dat1 dat2)
    1399   (%check-date loc dat1)
    1400   (%check-date loc dat2)
    1401   (if (not (fx= (%date-zone-offset dat1) (%date-zone-offset dat2)))
    1402       (error-compare-dates-w-diff-tz loc dat1 dat2)
    1403       (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
    1404         (if (not (fx= 0 dif)) dif
    1405             (let ((dif (fx- (%date-month dat1) (%date-month dat2))))
    1406               (if (not (fx= 0 dif)) dif
    1407                   (let ((dif (fx- (%date-day dat1) (%date-day dat2))))
    1408                     (if (not (fx= 0 dif)) dif
    1409                         (let ((dif (fx- (%date-hour dat1) (%date-hour dat2))))
    1410                           (if (not (fx= 0 dif)) dif
    1411                               (let ((dif (fx- (%date-minute dat1) (%date-minute dat2))))
    1412                                 (if (not (fx= 0 dif)) dif
    1413                                     (let ((dif (fx- (%date-second dat1) (%date-second dat2))))
    1414                                       (if (not (fx= 0 dif)) dif
    1415                                           (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
     625(define (checked-date-compare loc dat1 dat2)
     626  (check-date loc dat1)
     627  (check-date loc dat2)
     628  (check-compatible-timezone-offsets loc dat1 dat2)
     629  (tm:date-compare dat1 dat2) )
     630
     631;;
    1416632
    1417633(define (date-compare dat1 dat2)
    1418   (let ((dif (tm:date-compare 'date-compare dat1 dat2)))
     634  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
    1419635    (cond ((fx> 0 dif)  -1)
    1420636          ((fx< 0 dif)  1)
     
    1422638
    1423639(define (date=? dat1 dat2)
    1424   (fx= 0 (tm:date-compare 'date=? dat1 dat2)) )
     640  (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )
    1425641
    1426642(define (date<? dat1 dat2)
    1427   (fx> 0 (tm:date-compare 'date<? dat1 dat2)) )
     643  (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )
    1428644
    1429645(define (date<=? dat1 dat2)
    1430   (fx>= 0 (tm:date-compare 'date<=? dat1 dat2)) )
     646  (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
    1431647
    1432648(define (date>? dat1 dat2)
    1433   (fx< 0 (tm:date-compare 'date>? dat1 dat2)) )
     649  (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )
    1434650
    1435651(define (date>=? dat1 dat2)
    1436   (fx<= 0 (tm:date-compare 'date>=? dat1 dat2)) )
     652  (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
     653
     654(define (date-max dat1 . rest)
     655  (check-date 'date-max dat1)
     656  (let loop ((acc dat1) (ls rest))
     657    (if (null? ls) acc
     658        (let ((dat (car ls)))
     659          (check-date 'date-max dat)
     660          (check-compatible-timezone-offsets 'date-max acc dat)
     661          (loop (if (fx> 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
     662
     663(define (date-min dat1 . rest)
     664  (check-date 'date-min dat1)
     665  (let loop ((acc dat1) (ls rest))
     666    (if (null? ls) acc
     667        (let ((dat (car ls)))
     668          (check-date 'date-min dat)
     669          (check-compatible-timezone-offsets 'date-min acc dat)
     670          (loop (if (fx< 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )
    1437671
    1438672;; Date Arithmetic
    1439673
    1440 (define (date-difference dat1 dat2 . timtyp)
    1441   (%check-date 'date-difference dat1)
    1442   (%check-date 'date-difference dat2)
    1443   (let ((tim1 (apply date->time dat1 timtyp))
    1444         (tim2 (apply date->time dat2 timtyp)))
    1445     (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) ) )
    1446 
    1447 (define (date-add-duration dat dur . timtyp)
    1448   (%check-date 'date-add-duration dat)
    1449   (tm:check-duration 'date-add-duration dur)
    1450   (let ((tim (apply date->time dat timtyp)))
    1451     (time->date (tm:add-duration tim dur (tm:as-empty-time tim))) ) )
    1452 
    1453 (define (date-subtract-duration dat dur . timtyp)
    1454   (%check-date 'date-subtract-duration dat)
    1455   (tm:check-duration 'date-subtract-duration dur)
    1456   (let ((tim (apply date->time dat timtyp)))
    1457     (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
     674(define (date-difference dat1 dat2 . args)
     675  (check-date 'date-difference dat1)
     676  (check-date 'date-difference dat2)
     677  (let-optionals args ((tt (default-date-clock-type)))
     678    (let ((tim1 (tm:date->time dat1 tt))
     679          (tim2 (tm:date->time dat2 tt)) )
     680      (unless tim1 (error-clock-type 'date-difference dat1))
     681      (unless tim2 (error-clock-type 'date-difference dat2))
     682      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
     683
     684(define (date-add-duration dat dur . args)
     685  (check-date 'date-add-duration dat)
     686  (check-duration 'date-add-duration dur)
     687  (let-optionals args ((tt (default-date-clock-type)))
     688    (let ((tim (tm:date->time dat tt)))
     689      (unless tim (error-clock-type 'date-add-duration dat))
     690      (time->date (tm:add-duration tim dur (tm:as-some-time tim))) ) ) )
     691
     692(define (date-subtract-duration dat dur . args)
     693  (check-date 'date-subtract-duration dat)
     694  (check-duration 'date-subtract-duration dur)
     695  (let-optionals args ((tt (default-date-clock-type)))
     696    (let ((tim (tm:date->time dat tt)))
     697      (unless tim (error-clock-type 'date-subtract-duration dat))
     698      (time->date (tm:subtract-duration tim dur (tm:as-some-time tim))) ) ) )
    1458699
    1459700;; Time to Date
    1460701
    1461 ;; Gives the seconds/day/month/year
    1462 
    1463 (define (tm:decode-julian-day-number jdn)
    1464   (let* ((dys (number->maybe-fixnum (truncate jdn)))
    1465          (a (fx+ dys 32044))
    1466          (b (fx/ (fx+ (fx* 4 a) 3) 146097))
    1467          (c (fx- a (fx/ (fx* 146097 b) 4)))
    1468          (d (fx/ (fx+ (fx* 4 c) 3) 1461))
    1469          (e (fx- c (fx/ (fx* 1461 d) 4)))
    1470          (m (fx/ (fx+ (fx* 5 e) 2) 153))
    1471          (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))))
    1472     (values
    1473       (number->maybe-fixnum (floor (* (- jdn dys) SEC/DY)))  ; seconds
    1474       (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1) ; day
    1475       (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))      ; month
    1476       (if (fx<= y 0) (fx- y 1) y)) ) )            ; year
    1477 
    1478 ;; Gives the Julian day number - rounds up to the nearest day
    1479 
    1480 (define (tm:seconds->julian-day-number sec tzo)
    1481   (+ TAI-EPOCH-IN-JD
    1482      ; Round to day boundary
    1483      (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
    1484 
    1485 ;; Is the time object one second before a leap second?
    1486 
    1487 (define (tm:tai-before-leap-second? tim)
    1488   (let ((sec (%time-second tim)))
    1489     (let loop ((ls tm:second-before-leap-second-table))
    1490       (and (not (null? ls))
    1491            (or (= sec (car ls))
    1492                (loop (cdr ls)) ) ) ) ) )
    1493 
    1494 (define (tm:time->date loc tim tzc)
    1495   ; The tz-info is caller's rest parameter
    1496   (let ((tzo (optional tzc (local-timezone-locale)))
    1497         (tzn #f)
    1498         (dstf #f))
    1499       (when (timezone-components? tzo)
    1500         (set! dstf (timezone-locale-dst? tzo))
    1501         (set! tzn (timezone-locale-name tzo))
    1502         (set! tzo (timezone-locale-offset tzo)))
    1503       (unless (fixnum? tzo)
    1504         (error-invalid-timezone-offset loc tzo) )
    1505       (receive (secs dy mn yr)
    1506           (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo))
    1507         (let ((hr (fx/ secs SEC/HR))
    1508               (rsecs (fxmod secs SEC/HR)))
    1509           (let ((min (fx/ rsecs SEC/MIN))
    1510                 (sec (fxmod rsecs SEC/MIN)))
    1511             (tm:make-date (%time-nanosecond tim) sec min hr dy mn yr tzo tzn dstf #f #f #f) ) ) ) ) )
    1512 
    1513 (define (tm:time-tai->date loc tim tzc)
    1514   (let ((tm-utc (tm:time-tai->time-utc tim (tm:as-empty-time tim))))
    1515     (if (not (tm:tai-before-leap-second? tim)) (tm:time->date loc tm-utc tzc)
    1516         ; else time is *right* before the leap, we need to pretend to subtract a second ...
    1517         (let ((dat (tm:time->date loc (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzc)))
    1518           (%date-second-set! dat SEC/MIN) ; Note full minute!
    1519           dat ) ) ) )
    1520 
    1521 (define (time-tai->date tim . tzc)
    1522   (tm:check-time-and-type 'time-tai->date tim 'time-tai)
    1523   (tm:time-tai->date 'time-tai->date tim tzc) )
    1524 
    1525 (define (time-utc->date tim . tzc)
    1526   (tm:check-time-and-type 'time-utc->date tim 'time-utc)
    1527   (tm:time->date 'time-utc->date tim tzc) )
    1528 
    1529 (define (time-monotonic->date tim . tzc)
    1530   (tm:check-time-and-type 'time-monotonic->date tim 'time-monotonic)
    1531   (tm:time->date 'time-monotonic->date tim tzc) )
    1532 
    1533 (define (time->date tim . tzc)
    1534   (%check-time 'time->date tim)
    1535   (case (%time-type tim)
    1536     ((time-monotonic) (tm:time->date 'time->date tim tzc))
    1537     ((time-utc)       (tm:time->date 'time->date tim tzc))
    1538     ((time-tai)       (tm:time-tai->date 'time->date tim tzc))
    1539     (else ; This shouldn't happen
    1540      (error-invalid-clock-type 'time->date tim))) )
     702(define (time-tai->date tim . tzi)
     703  (check-time-and-type 'time-tai->date tim 'tai)
     704  (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #f))) )
     705
     706(define (time-utc->date tim . tzi)
     707  (check-time-and-type 'time-utc->date tim 'utc)
     708  (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #f))) )
     709
     710(define (time-monotonic->date tim . tzi)
     711  (check-time-and-type 'time-monotonic->date tim 'monotonic)
     712  (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #f))) )
     713
     714(define (time->date tim . tzi)
     715  (check-time 'time->date tim)
     716  (let ((tzi (checked-optional-timezone-info 'time->date (optional tzi #f))))
     717    (or (tm:time->date tim tzi)
     718        ; This shouldn't happen
     719        (error-clock-type 'time->date tim)) ) )
    1541720
    1542721;; Date to Time
    1543722
    1544 ;; Gives the Julian day number - Gregorian proleptic calendar
    1545 
    1546 (define (tm:encode-julian-day-number dy mn yr)
    1547   (let* ((a (fx/ (fx- 14 mn) MN/YR))
    1548          (b (fx- (fx+ yr 4800) a))
    1549          (y (if (negative? yr) (fx+ b 1) b)) ; BCE?
    1550          (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
    1551     (+ dy
    1552        (fx/ (fx+ (fx* 153 m) 2) 5)
    1553        (fx* y DY/YR)
    1554        (fx/ y 4)
    1555        (fx/ y -100)
    1556        (fx/ y 400)
    1557        -32045) ) )
    1558 
    1559 (define (tm:date->time-utc loc dat)
    1560   (let ((ns (%date-nanosecond dat))
    1561         (sec (%date-second dat))
    1562         (min (%date-minute dat))
    1563         (hr (%date-hour dat))
    1564         (dy (%date-day dat))
    1565         (mn (%date-month dat))
    1566         (yr (%date-year dat))
    1567         (tzo (%date-zone-offset dat)))
    1568     (let ((jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
    1569           (secs (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo))))
    1570       (tm:make-time 'time-utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
    1571 
    1572 (define (tm:date->time-tai loc dat)
    1573   (let* ((tm-utc (tm:date->time-utc loc dat))
    1574          (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
    1575     (if (not (fx= 60 (%date-second dat))) tm-tai
    1576         (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )
    1577 
    1578 (define (tm:date->time-monotonic loc dat)
    1579   (let ((tim-utc (tm:date->time-utc loc dat)))
    1580     (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
    1581 
    1582723(define (date->time-utc dat)
    1583   (%check-date 'date->time-utc dat)
    1584   (tm:date->time-utc 'date->time-utc dat) )
     724  (check-date 'date->time-utc dat)
     725  (tm:date->time-utc dat) )
    1585726
    1586727(define (date->time-tai dat)
    1587   (%check-date 'date->time-tai dat)
    1588   (tm:date->time-tai 'date->time-tai dat) )
     728  (check-date 'date->time-tai dat)
     729  (tm:date->time-tai dat) )
    1589730
    1590731(define (date->time-monotonic dat)
    1591   (%check-date 'date->time-monotonic dat)
    1592   (tm:date->time-monotonic 'date->time-monotonic dat) )
    1593 
    1594 (define (date->time dat . timtyp)
    1595   (%check-date 'date->time dat)
    1596   (case (optional timtyp (default-date-clock-type))
    1597     ((time-monotonic) (tm:date->time-monotonic  'date->time dat))
    1598     ((time-utc)       (tm:date->time-utc 'date->time dat))
    1599     ((time-tai)       (tm:date->time-tai 'date->time dat))
    1600     (else
    1601      (error-invalid-clock-type 'date->time timtyp))) )
     732  (check-date 'date->time-monotonic dat)
     733  (tm:date->time-monotonic dat) )
     734
     735(define (date->time dat . args)
     736  (check-date 'date->time dat)
     737  (let-optionals args ((tt (default-date-clock-type)))
     738    (or (tm:date->time dat tt)
     739        (error-clock-type 'date->time tt) ) ) )
     740
     741;; Given a 'two digit' number, find the year within 50 years +/-
     742
     743(define (natural-year n)
     744  (check-date-year 'natural-year n)
     745  (tm:natural-year n) )
    1602746
    1603747;; Leap Year
    1604748
    1605749(define (leap-year? dat)
    1606   (%check-date 'date-leap-year? dat)
    1607   (tm:leap-year? (%date-year dat)) )
     750  (check-date 'date-leap-year? dat)
     751  (tm:leap-year? (tm:date-year dat)) )
    1608752
    1609753;; Day of Year
    1610754
    1611 (define (tm:year-day dy mn yr)
    1612   (let ((yrdy (fx+ dy (vector-ref tm:cumulative-month-days mn))))
    1613     (if (and (tm:leap-year? yr) (fx< 2 mn)) (fx+ yrdy 1)
    1614         yrdy ) ) )
    1615 
    1616755(define (date-year-day dat)
    1617   (%check-date 'date-year-day dat)
    1618   (or (%date-yday dat)
    1619       (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
    1620         (%date-yday-set! dat yrdy)
    1621         yrdy ) ) )
     756  (check-date 'date-year-day dat)
     757  (or (tm:date-yday dat)
     758      (tm:cache-date-year-day dat) ) )
     759
     760(define (month-days yr mn)
     761  (check-date-year 'month-days yr)
     762  (check-date-month 'month-days mn)
     763  (tm:days-in-month yr mn) )
    1622764
    1623765;; Week Day
    1624766
    1625 ;; Using Gregorian Calendar (from Calendar FAQ)
    1626 
    1627 (define (tm:week-day dy mn yr)
    1628   (let* ((a (fx/ (fx- 14 mn) MN/YR))
    1629          (y (fx- yr a))
    1630          (m (fx- (fx+ mn (fx* a MN/YR)) 2)))
    1631     (fxmod (fx+ (fx+ dy y)
    1632                 (fx+ (fx- (fx/ y 4) (fx/ y 100))
    1633                      (fx+ (fx/ y 400)
    1634                           (fx/ (fx* m DY/MN) MN/YR))))
    1635            DY/WK) ) )
    1636 
    1637 (define (tm:days-before-first-week dat day-of-week-starting-week)
    1638   (fxmod (fx- day-of-week-starting-week (tm:week-day 1 1 (%date-year dat))) DY/WK) )
    1639 
    1640767(define (date-week-day dat)
    1641   (%check-date 'date-week-day dat)
    1642   (or (%date-wday dat)
    1643       (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
    1644         (%date-wday-set! dat wdy)
    1645         wdy ) ) )
     768  (check-date 'date-week-day dat)
     769  (or (tm:date-wday dat)
     770      (tm:cache-date-week-day dat) ) )
     771
     772;;
    1646773
    1647774(define (date-week-number dat . args)
    1648   (%check-date 'date-week-number dat)
     775  (check-date 'date-week-number dat)
    1649776  (let ((day-of-week-starting-week (optional args 0)))
    1650     (fx/ (fx- (date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
    1651          DY/WK) ) )
     777    (check-week-day 'date-week-numbe day-of-week-starting-week)
     778    (tm:date-week-number dat day-of-week-starting-week) ) )
    1652779
    1653780;; Julian-day Operations
    1654781
    1655 ;; Date to Julian-day
    1656 
    1657 ; Does the nanoseconds value contribute anything to the julian day?
    1658 ; The range is < 1 second here (but not in the reference).
    1659 
    1660 (define (tm:julian-day ns sec min hr dy mn yr tzo)
    1661   (+ (- (tm:encode-julian-day-number dy mn yr) ONE-HALF)
    1662      (/ (+ (fx+ (fx+ (fx* hr SEC/HR)
    1663                      (fx+ (fx* min SEC/MIN) sec))
    1664                 (fxneg tzo))
    1665            (/ ns NS/S))
    1666         SEC/DY)) )
    1667 
    1668 #; ; inexact version
    1669 (define (tm:julian-day ns sec min hr dy mn yr tzo)
    1670   (fp+ (fp- (exact->inexact (tm:encode-julian-day-number dy mn yr)) iONE-HALF)
    1671        (fp/ (fp+ (exact->inexact (fx+ (fx+ (fx* hr SEC/HR)
    1672                                            (fx+ (fx* min SEC/MIN) sec))
    1673                                       (fxneg tzo)))
    1674                  (fp/ (exact->inexact ns) iNS/S))
    1675             iSEC/DY)) )
    1676 
    1677 (define (tm:date->julian-day loc dat)
    1678   (%check-date loc dat)
    1679   (or (%date-jday dat)
    1680       (let ((jdn
    1681              (tm:julian-day
    1682               (%date-nanosecond dat)
    1683               (%date-second dat) (%date-minute dat) (%date-hour dat)
    1684               (%date-day dat) (%date-month dat) (%date-year dat)
    1685               (%date-zone-offset dat))))
    1686         (%date-jday-set! dat jdn)
    1687         jdn ) ) )
    1688 
    1689 (define (date->julian-day dat) (tm:date->julian-day 'date->julian-day dat))
     782(define (date->julian-day dat)
     783  (check-date 'date->julian-day dat)
     784  (tm:date->julian-day dat) )
    1690785
    1691786(define (date->modified-julian-day dat)
    1692   (- (tm:date->julian-day 'date->modified-julian-day dat) TAI-EPOCH-IN-MODIFIED-JD) )
     787  (check-date 'date->modified-julian-day dat)
     788  (tm:julian-day->modified-julian-day (tm:date->julian-day dat)) )
    1693789
    1694790;; Time to Julian-day
    1695791
    1696 (define (tm:seconds->julian-day ns sec) (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)))
    1697 
    1698 (define-inline (%time-tai->julian-day tim)
    1699   (let ((sec (%time-second tim)))
    1700     (tm:seconds->julian-day (%time-nanosecond tim) (- sec (%leap-second-delta sec))) ) )
    1701 
    1702 (define (tm:time-utc->julian-day tim)
    1703   (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
    1704 
    1705 (define (tm:time-tai->julian-day tim) (%time-tai->julian-day tim))
    1706 
    1707 (define (tm:time-monotonic->julian-day tim) (%time-tai->julian-day tim))
    1708 
    1709792(define (time-utc->julian-day tim)
    1710   (tm:check-time-and-type 'time-utc->julian-day tim 'time-utc)
     793  (check-time-and-type 'time-utc->julian-day tim 'utc)
    1711794  (tm:time-utc->julian-day tim) )
    1712795
    1713796(define (time-tai->julian-day tim)
    1714   (tm:check-time-and-type 'time-tai->julian-day tim 'time-tai)
     797  (check-time-and-type 'time-tai->julian-day tim 'tai)
    1715798  (tm:time-tai->julian-day tim) )
    1716799
    1717800(define (time-monotonic->julian-day tim)
    1718   (tm:check-time-and-type 'time-monotonic->julian-day tim 'time-monotonic)
     801  (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
    1719802  (tm:time-monotonic->julian-day tim) )
    1720803
    1721804(define (time->julian-day tim)
    1722   (%check-time 'time->julian-day tim)
    1723   (case (%time-type tim)
    1724     ((time-monotonic) (tm:time-monotonic->julian-day tim))
    1725     ((time-utc)       (tm:time-utc->julian-day tim))
    1726     ((time-tai)       (tm:time-tai->julian-day tim))
    1727     (else
    1728      (error-invalid-clock-type 'time->julian-day tim))) )
    1729 
    1730 (define (tm:time-utc->modified-julian-day tim)
    1731   (- (tm:time-utc->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
    1732 
    1733 (define (tm:time-tai->modified-julian-day tim)
    1734   (- (tm:time-tai->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
    1735 
    1736 (define (tm:time-monotonic->modified-julian-day tim)
    1737   (- (tm:time-monotonic->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
     805  (check-time 'time->julian-day tim)
     806  (or (tm:time->julian-day tim)
     807      (error-clock-type 'time->julian-day tim) ) )
    1738808
    1739809(define (time-utc->modified-julian-day tim)
    1740   (tm:check-time-and-type 'time-utc->modified-julian-day tim 'time-utc)
     810  (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
    1741811  (tm:time-utc->modified-julian-day tim) )
    1742812
    1743813(define (time-tai->modified-julian-day tim)
    1744   (tm:check-time-and-type 'time-tai->modified-julian-day tim 'time-tai)
     814  (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
    1745815  (tm:time-tai->modified-julian-day tim) )
    1746816
    1747817(define (time-monotonic->modified-julian-day tim)
    1748   (tm:check-time-and-type 'time-monotonic->modified-julian-day tim 'time-monotonic)
     818  (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
    1749819  (tm:time-monotonic->modified-julian-day tim) )
    1750820
    1751821(define (time->modified-julian-day tim)
    1752   (%check-time 'time->modified-julian-day tim)
    1753   (case (%time-type tim)
    1754     ((time-monotonic) (tm:time-monotonic->modified-julian-day tim))
    1755     ((time-utc)       (tm:time-utc->modified-julian-day tim))
    1756     ((time-tai)       (tm:time-tai->modified-julian-day tim))
    1757     (else
    1758      (error-invalid-clock-type 'time->modified-julian-day tim))) )
     822  (check-time 'time->modified-julian-day tim)
     823  (or (tm:time->modified-julian-day tim)
     824      (error-clock-type 'time->modified-julian-day tim) ) )
    1759825
    1760826;; Julian-day to Time
    1761827
    1762828(define (julian-day->time-utc jdn)
    1763   (receive (ns sec)
    1764       (tm:split-nanoseconds (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S))
    1765     (tm:make-time 'time-utc ns sec) ) )
     829  (check-julian-day 'julian-day->time-utc jdn)
     830  (tm:julian-day->time-utc jdn) )
    1766831
    1767832(define (julian-day->time-tai jdn)
    1768   (time-utc->time-tai! (julian-day->time-utc jdn)) )
     833  (check-julian-day 'julian-day->time-tai jdn)
     834  (let ((tim (tm:julian-day->time-utc jdn)))
     835    (tm:time-utc->time-tai tim tim) ) )
    1769836
    1770837(define (julian-day->time-monotonic jdn)
    1771   (time-utc->time-monotonic! (julian-day->time-utc jdn)) )
    1772 
    1773 (define (julian-day->date jdn . tzc)
    1774   (apply time-utc->date (julian-day->time-utc jdn) tzc) )
     838  (check-julian-day 'julian-day->time-monotonic jdn)
     839  (let ((tim (julian-day->time-utc jdn)))
     840    (tm:time-utc->time-monotonic tim tim) ) )
     841
     842(define (julian-day->date jdn . tzi)
     843  (check-julian-day 'julian-day->date jdn)
     844  (tm:time-utc->date (tm:julian-day->time-utc jdn)
     845                     (checked-optional-timezone-info 'julian-day->date (optional tzi #f))) )
    1775846
    1776847(define (modified-julian-day->time-utc mjdn)
    1777   (julian-day->time-utc (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
     848  (check-julian-day 'modified-julian-day->time-utc mjdn)
     849  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
    1778850
    1779851(define (modified-julian-day->time-tai mjdn)
    1780   (julian-day->time-tai (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
     852  (check-julian-day 'modified-julian-day->time-tai mjdn)
     853  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
     854    (tm:time-utc->time-tai tim tim) ) )
    1781855
    1782856(define (modified-julian-day->time-monotonic mjdn)
    1783   (julian-day->time-monotonic (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
    1784 
    1785 (define (modified-julian-day->date mjdn . tzc)
    1786   (apply julian-day->date (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) tzc) )
     857  (check-julian-day 'modified-julian-day->time-monotonic mjdn)
     858  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
     859    (tm:time-utc->time-monotonic tim tim) ) )
     860
     861(define (modified-julian-day->date mjdn . tzi)
     862  (check-julian-day 'modified-julian-day->date mjdn)
     863  (tm:time-utc->date (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))
     864                     (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #f))) )
    1787865
    1788866;; The Julian-day
    1789867
    1790868(define (current-julian-day)
    1791   (time-utc->julian-day (tm:current-time-utc)) )
     869  (tm:time-utc->julian-day (tm:current-time-utc)) )
    1792870
    1793871(define (current-modified-julian-day)
    1794   (time-utc->modified-julian-day (tm:current-time-utc)) )
     872  (tm:time-utc->modified-julian-day (tm:current-time-utc)) )
     873
     874) ;module srfi-19-core
  • release/4/srfi-19/trunk/srfi-19-io.scm

    r15727 r15750  
    2828;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
    2929
    30 (eval-when (compile)
    31   (declare
    32     (not usual-integrations
    33       + - * /
    34       remainder quotient modulo
    35       expt
    36       abs
    37       round floor truncate
    38       number? integer? inexact?
    39       zero? negative? positive?
    40       = <= >= < >
    41       inexact->exact exact->inexact
    42       char-alphabetic? char-numeric?
    43       number->string string->number
    44       string-length string-append
    45       string->list list->string)
    46     (inline)
    47     (generic)
    48     (no-procedure-checks)
    49     (no-bound-checks)
    50     (export
    51       ;; SRFI-19 extensions
    52       format-date
    53       scan-date
    54       ;; SRFI-19
    55       date->string
    56       string->date) ) )
    57 
    58 (use srfi-1 srfi-13 srfi-29 locale numbers srfi-19-core)
     30(module srfi-19-io (;export
     31  ;; SRFI-19
     32  date->string
     33  string->date
     34  ;; SRFI-19 extensions
     35  format-date
     36  scan-date)
     37
     38  (import (except scheme / number->string)
     39          chicken
     40          #;srfi-1
     41          #;srfi-6
     42          (only srfi-13 string-pad)
     43          (only numbers / number->string)
     44          srfi-29
     45          #;srfi-19-core
     46          srfi-19-support)
     47
     48  (require-library srfi-1 #;srfi-6 srfi-13 srfi-29 locale numbers
     49                   #;srfi-19-core srfi-19-support)
    5950
    6051;;;
     
    8172(define LOCALE-ABRV-WEEKDAYS '#(sun mon tue wed thu fri sat))
    8273(define LOCALE-LONG-WEEKDAYS '#(sunday monday tuesday wednesday thursday friday saturday))
    83 (define LOCALE-ABRV-MONTHS '#(|| jan feb mar apr may jun jul aug sep oct nov dec))
    84 (define LOCALE-LONG-MONTHS '#(|| january february march april may june july august september october november december))
     74(define LOCALE-ABRV-MONTHS '#(#f jan feb mar apr may jun jul aug sep oct nov dec))
     75(define LOCALE-LONG-MONTHS '#(#f january february march april may june july august september october november december))
    8576
    8677(define LOCALE-PM 'pm)
     
    10091;; SRFI-29 Helper
    10192
    102 (define-inline (%item@ key) (localized-template/default 'srfi-19 key))
     93(define-inline (item@ key) (localized-template/default 'srfi-19 key))
    10394
    10495;;; Date & Time Formatted I/O
    105 
    106 ;; Given a 'two digit' number, find the year within 50 years +/-
    107 
    108 (define (tm:natural-year n)
    109   (if (or (fx< n 0) (fx>= n 100)) n
    110       (let* ((current-year (date-year (current-date)))
    111              (current-century (fx* (fx/ current-year 100) 100)))
    112         (if (fx<= (fx- (fx+ current-century n) current-year) 50) (fx+ current-century n)
    113             (fx+ (fx- current-century 100) n) ) ) ) )
    11496
    11597;; Return a string representing the decimal expansion of the fractional
    11698;; portion of a number, limited by a specified precision
    11799
    118 (define (tm:decimal-expansion r precision)
    119   (let loop ((num (- r (round r)))
    120              (p precision)
    121              (ls '()))
    122     (if (or (fx= 0 p) (zero? num)) (apply string-append (reverse! ls))
    123         (let* ((num-times-10 (* 10 num))
    124                (round-num-times-10 (round num-times-10)))
    125           (loop (- num-times-10 round-num-times-10)
    126                 (fx- p 1)
    127                 (cons (number->string (inexact->exact round-num-times-10)) ls)) ) ) ) )
     100(define (decimal-expansion r prec)
     101  (cond-expand
     102    (chicken
     103      (parameterize ((flonum-print-precision prec)) (number->string r)) )
     104    (else
     105      (let loop ((num (- r (round r)))
     106                 (p prec)
     107                 (ls '()))
     108        (if (or (fx= 0 p) (zero? num)) (apply string-append (reverse! ls))
     109            (let* ((num-times-10 (* 10 num))
     110                   (round-num-times-10 (round num-times-10)))
     111              (loop (- num-times-10 round-num-times-10)
     112                    (fx- p 1)
     113                    (cons (number->string (inexact->exact round-num-times-10)) ls)) ) ) ) ) ) )
    128114
    129115;; Returns a string rep. of number N, of minimum LENGTH,
     
    132118;; if string is longer than LENGTH, it's as if number->string was used.
    133119
    134 (define-inline (%trailing-dotzero? str len)
    135   (and (fx>= len 2)
    136        (char=? #\. (string-ref str (fx- len 2)))
    137        (char=? #\0 (string-ref str (fx- len 1))) ) )
    138 
    139 (define (tm:padding n pad-with length)
     120(define (padding n pad-with length)
     121  (define (trailing-dotzero? str len)
     122    (and (fx>= len 2)
     123         (char=? #\. (string-ref str (fx- len 2)))
     124         (char=? #\0 (string-ref str (fx- len 1))) ) )
    140125  (let* ((str (number->string n))
    141126         (len (string-length str)))
    142127    (let ((str
    143            (if (not (%trailing-dotzero? str len)) str
     128           (if (not (trailing-dotzero? str len)) str
    144129               (substring str 0 (fx- len 2)) ) ) )
    145130      (if (or (not pad-with) (fx> len length)) str
    146131          (string-pad str length pad-with)) ) ) )
    147132
    148 (define (tm:last-n-digits i n) (abs (remainder i (expt 10 n))))
    149 
    150 (define (tm:locale-abbr-weekday n) (%item@ (vector-ref LOCALE-ABRV-WEEKDAYS n)))
    151 
    152 (define (tm:locale-long-weekday n) (%item@ (vector-ref LOCALE-LONG-WEEKDAYS n)))
    153 
    154 (define (tm:locale-abbr-month n) (%item@ (vector-ref LOCALE-ABRV-MONTHS n)))
    155 
    156 (define (tm:locale-long-month n) (%item@ (vector-ref LOCALE-LONG-MONTHS n)))
    157 
    158 (define (tm:locale-find-string str vec)
     133(define fxtake-right-digits
     134  (let ((nth (vector 0 10 100 1000 100000 1000000 10000000 100000000 1000000000)))
     135    (lambda (i n)
     136      (fxmod (fxabs i) (vector-ref nth n)) ) ) )
     137
     138(define (locale-abbr-weekday n) (item@ (vector-ref LOCALE-ABRV-WEEKDAYS n)))
     139(define (locale-long-weekday n) (item@ (vector-ref LOCALE-LONG-WEEKDAYS n)))
     140(define (locale-abbr-month n) (item@ (vector-ref LOCALE-ABRV-MONTHS n)))
     141(define (locale-long-month n) (item@ (vector-ref LOCALE-LONG-MONTHS n)))
     142
     143(define (locale-find-string str vec)
    159144  (let loop ((idx (fx- (vector-length vec) 1)))
    160145    (and (fx< 0 idx)
    161          (or (and (string=? str (%item@ (vector-ref vec idx)))
     146         (or (and (string=? str (item@ (vector-ref vec idx)))
    162147                  idx)
    163148             (loop (fx- idx 1))) ) ) )
    164149
    165 (define (tm:locale-abbr-weekday->index str) (tm:locale-find-string str LOCALE-ABRV-WEEKDAYS))
    166 
    167 (define (tm:locale-long-weekday->index str) (tm:locale-find-string str LOCALE-LONG-WEEKDAYS))
    168 
    169 (define (tm:locale-abbr-month->index str) (tm:locale-find-string str LOCALE-ABRV-MONTHS))
    170 
    171 (define (tm:locale-long-month->index str) (tm:locale-find-string str LOCALE-LONG-MONTHS))
     150(define (locale-abbr-weekday->index str) (locale-find-string str LOCALE-ABRV-WEEKDAYS))
     151(define (locale-long-weekday->index str) (locale-find-string str LOCALE-LONG-WEEKDAYS))
     152(define (locale-abbr-month->index str) (locale-find-string str LOCALE-ABRV-MONTHS))
     153(define (locale-long-month->index str) (locale-find-string str LOCALE-LONG-MONTHS))
    172154
    173155;; There is no unique way to map a timezone offset to a political timezone!
    174156
    175 (define (tm:locale-print-time-zone date port)
    176   (when (date-zone-name date)
    177     (display (date-zone-name date) port)) )
     157(define (locale-print-time-zone date port)
     158  (when (tm:date-zone-name date)
     159    (display (tm:date-zone-name date) port)) )
    178160
    179161;; Again, locale specific.
    180162
    181 (define (tm:locale-am/pm hr) (%item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)))
    182 
    183 (define (tm:tz-printer offset port)
    184   (if (= offset 0) (display "Z" port)
     163(define (locale-am/pm hr) (item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)))
     164
     165(define (tz-printer offset port)
     166  (if (fx= 0 offset) (display "Z" port)
    185167      (let ((isneg (fx< offset 0)))
    186168        (display (if isneg #\- #\+) port)
    187169        (let ((offset (if isneg (fxneg offset) offset)))
    188           (display (tm:padding (quotient offset SEC/HR) #\0 2) port)
    189           (display (tm:padding (quotient (remainder offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
     170          (display (padding (fx/ offset SEC/HR) #\0 2) port)
     171          (display (padding (fx/ (fxmod offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
    190172
    191173;; A table of output formatting directives.
     
    202184    (cons #\a
    203185      (lambda (date pad-with port)
    204         (display (tm:locale-abbr-weekday (date-week-day date)) port)))
     186        (display (locale-abbr-weekday (tm:date-week-day date)) port)))
    205187
    206188    (cons #\A
    207189      (lambda (date pad-with port)
    208         (display (tm:locale-long-weekday (date-week-day date)) port)))
     190        (display (locale-long-weekday (tm:date-week-day date)) port)))
    209191
    210192    (cons #\b
    211193      (lambda (date pad-with port)
    212         (display (tm:locale-abbr-month (date-month date)) port)))
     194        (display (locale-abbr-month (tm:date-month date)) port)))
    213195
    214196    (cons #\B
    215197      (lambda (date pad-with port)
    216         (display (tm:locale-long-month (date-month date)) port)))
     198        (display (locale-long-month (tm:date-month date)) port)))
    217199
    218200    (cons #\c
    219201      (lambda (date pad-with port)
    220         (display (date->string date (%item@ LOCALE-DATE-TIME-FORMAT)) port)))
     202        (display (date->string date (item@ LOCALE-DATE-TIME-FORMAT)) port)))
    221203
    222204    (cons #\d
    223205      (lambda (date pad-with port)
    224         (display (tm:padding (date-day date) #\0 2) port)))
     206        (display (padding (tm:date-day date) #\0 2) port)))
    225207
    226208    (cons #\D
     
    230212    (cons #\e
    231213      (lambda (date pad-with port)
    232         (display (tm:padding (date-day date) #\space 2) port)))
     214        (display (padding (tm:date-day date) #\space 2) port)))
    233215
    234216    (cons #\f
    235217      (lambda (date pad-with port)
    236         (let ((ns (date-nanosecond date)) (sec (date-second date)))
    237           (if (> ns NS/S) ; This shouldn't happen!
    238               (display (tm:padding (+ sec 1) pad-with 2) port)
    239               (display (tm:padding sec pad-with 2) port))
    240           (let ((f (tm:decimal-expansion (/ ns NS/S) 6)))
    241             (when (fx> (string-length f) 0)
    242               (display (%item@ LOCALE-NUMBER-SEPARATOR) port)
     218        (let ((ns (tm:date-nanosecond date))
     219              (sec (tm:date-second date)))
     220          (let ((f (decimal-expansion (/ ns NS/S) 6)))
     221            (when (fx< 0 (string-length f))
     222              (display (item@ LOCALE-NUMBER-SEPARATOR) port)
    243223              (display f port))))))
    244224
     
    249229    (cons #\H
    250230      (lambda (date pad-with port)
    251         (display (tm:padding (date-hour date) pad-with 2) port)))
     231        (display (padding (tm:date-hour date) pad-with 2) port)))
    252232
    253233    (cons #\I
    254234      (lambda (date pad-with port)
    255         (let ((hr (date-hour date)))
     235        (let ((hr (tm:date-hour date)))
    256236          (if (fx> hr 12)
    257               (display (tm:padding (fx- hr 12) pad-with 2) port)
    258               (display (tm:padding hr pad-with 2) port)))))
     237              (display (padding (fx- hr 12) pad-with 2) port)
     238              (display (padding hr pad-with 2) port)))))
    259239
    260240    (cons #\j
    261241      (lambda (date pad-with port)
    262         (display (tm:padding (date-year-day date) pad-with 3) port)))
     242        (display (padding (tm:date-year-day date) pad-with 3) port)))
    263243
    264244    (cons #\k
    265245      (lambda (date pad-with port)
    266         (display (tm:padding (date-hour date) #\space 2) port)))
     246        (display (padding (tm:date-hour date) #\space 2) port)))
    267247
    268248    (cons #\l
    269249      (lambda (date pad-with port)
    270         (let ((hr (date-hour date)))
    271           (display (tm:padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port))))
     250        (let ((hr (tm:date-hour date)))
     251          (display (padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port))))
    272252
    273253    (cons #\m
    274254      (lambda (date pad-with port)
    275         (display (tm:padding (date-month date) pad-with 2) port)))
     255        (display (padding (tm:date-month date) pad-with 2) port)))
    276256
    277257    (cons #\M
    278258      (lambda (date pad-with port)
    279         (display (tm:padding (date-minute date) pad-with 2) port)))
     259        (display (padding (tm:date-minute date) pad-with 2) port)))
    280260
    281261    (cons #\n
     
    285265    (cons #\N
    286266      (lambda (date pad-with port)
    287         (display (tm:padding (date-nanosecond date) pad-with 7) port)))
     267        (display (padding (tm:date-nanosecond date) pad-with 7) port)))
    288268
    289269    (cons #\p
    290270      (lambda (date pad-with port)
    291         (display (tm:locale-am/pm (date-hour date)) port)))
     271        (display (locale-am/pm (tm:date-hour date)) port)))
    292272
    293273    (cons #\r
     
    297277    (cons #\s
    298278      (lambda (date pad-with port)
    299         (display (time-second (date->time-utc date)) port)))
     279        (display (time-second (tm:date->time-utc date)) port)))
    300280
    301281    (cons #\S
    302282      (lambda (date pad-with port)
    303         (let ((sec (date-second date)))
    304           (if (> (date-nanosecond date) NS/S) ; This shouldn't happen!
    305               (display (tm:padding (+ sec 1) pad-with 2) port)
    306               (display (tm:padding sec pad-with 2) port)))))
     283        (let ((sec (tm:date-second date)))
     284          (display (padding sec pad-with 2) port))))
    307285
    308286    (cons #\t
     
    316294    (cons #\U
    317295      (lambda (date pad-with port)
    318         (let ((wkno (date-week-number date 0)))
     296        (let ((wkno (tm:date-week-number date 0)))
    319297          (if (fx> (tm:days-before-first-week date 0) 0)
    320               (display (tm:padding (fx+ wkno 1) #\0 2) port)
    321               (display (tm:padding wkno #\0 2) port)))))
     298              (display (padding (fx+ wkno 1) #\0 2) port)
     299              (display (padding wkno #\0 2) port)))))
    322300
    323301    (cons #\V
    324302      (lambda (date pad-with port)
    325         (display (tm:padding (date-week-number date 1) #\0 2) port)))
     303        (display (padding (tm:date-week-number date 1) #\0 2) port)))
    326304
    327305    (cons #\w
    328306      (lambda (date pad-with port)
    329         (display (date-week-day date) port)))
     307        (display (tm:date-week-day date) port)))
    330308
    331309    (cons #\W
    332310      (lambda (date pad-with port)
    333         (let ((wkno (date-week-number date 1)))
     311        (let ((wkno (tm:date-week-number date 1)))
    334312          (if (fx> (tm:days-before-first-week date 1) 0)
    335               (display (tm:padding (fx+ wkno 1) #\0 2) port)
    336               (display (tm:padding wkno #\0 2) port)))))
     313              (display (padding (fx+ wkno 1) #\0 2) port)
     314              (display (padding wkno #\0 2) port)))))
    337315
    338316    (cons #\x
    339317      (lambda (date pad-with port)
    340         (display (date->string date (%item@ LOCALE-SHORT-DATE-FORMAT)) port)))
     318        (display (date->string date (item@ LOCALE-SHORT-DATE-FORMAT)) port)))
    341319
    342320    (cons #\X
    343321      (lambda (date pad-with port)
    344         (display (date->string date (%item@ LOCALE-TIME-FORMAT)) port)))
     322        (display (date->string date (item@ LOCALE-TIME-FORMAT)) port)))
    345323
    346324    (cons #\y
    347325      (lambda (date pad-with port)
    348         (display
    349           (tm:padding (tm:last-n-digits (date-year date) 2) pad-with 2) port)))
     326        (display (padding (fxtake-right-digits (tm:date-year date) 2) pad-with 2) port)))
    350327
    351328    (cons #\Y
    352329      (lambda (date pad-with port)
    353         (display (date-year date) port)))
     330        (display (tm:date-year date) port)))
    354331
    355332    (cons #\z
    356333      (lambda (date pad-with port)
    357         (tm:tz-printer (date-zone-offset date) port)))
     334        (tz-printer (tm:date-zone-offset date) port)))
    358335
    359336    (cons #\Z
    360337      (lambda (date pad-with port)
    361         (tm:locale-print-time-zone date port)))
     338        (locale-print-time-zone date port)))
    362339
    363340    (cons #\1
     
    381358        (display (date->string date "~Y-~m-~dT~H:~M:~S") port))) ) )
    382359
    383 (define (tm:date-printer loc date format-rem len-rem port)
     360(define (date-printer loc date format-rem len-rem port)
    384361  (when (fx< 0 len-rem)
    385362    (let ((current-char (car format-rem))
     
    390367      (cond ((not (char=? current-char #\~))
    391368             (display current-char port)
    392              (tm:date-printer loc date (cdr format-rem) (fx- len-rem 1) port))
     369             (date-printer loc date (cdr format-rem) (fx- len-rem 1) port))
    393370            ((fx< len-rem 2)
    394371             (error-bad-date-format loc (list->string format-rem)))
     
    403380                                (begin
    404381                                  (formatter date #f port)
    405                                   (tm:date-printer loc date (cdddr format-rem)
    406                                                    (fx- len-rem 3) port))))))
     382                                  (date-printer loc date (cdddr format-rem) (fx- len-rem 3) port))))))
    407383                      ((char=? pad-ch #\_)
    408384                       (if (fx< len-rem 3)
     
    413389                                 (begin
    414390                                   (formatter date #\space port)
    415                                    (tm:date-printer loc date (cdddr format-rem)
    416                                                      (fx- len-rem 3) port))))))
     391                                   (date-printer loc date (cdddr format-rem) (fx- len-rem 3) port))))))
    417392                      (else
    418393                       (let ((formatter (get-formatter pad-ch)))
     
    421396                             (begin
    422397                               (formatter date #\0 port)
    423                                (tm:date-printer loc date (cddr format-rem)
    424                                                 (fx- len-rem 2) port))))))))) )) )
     398                               (date-printer loc date (cddr format-rem) (fx- len-rem 2) port))))))))) )) )
    425399
    426400(define (format-date dest fmt-str . r)
     
    435409          (else
    436410            (set! port (current-output-port))))
    437     (tm:date-printer 'display-date date (string->list fmt-str) (string-length fmt-str) port)
     411    (date-printer 'display-date date (string->list fmt-str) (string-length fmt-str) port)
    438412    (or dest
    439413        (not (string? dest)))
     
    445419;;; Input
    446420
    447 (define (tm:digit->int ch)
     421(define (digit->int ch)
    448422  (case ch
    449423    ((#\0) 0)
     
    463437;; upto -> #f if any length
    464438
    465 (define (tm:integer-reader upto port)
     439(define (integer-reader upto port)
    466440  (let loop ((accum 0) (nchars 0))
    467441    (let ((ch (peek-char port)))
     
    470444              (and upto (fx>= nchars upto)))
    471445          accum
    472           (loop (fx+ (fx* accum 10) (tm:digit->int (read-char port))) (fx+ nchars 1))) ) ) )
    473 
    474 (define (tm:make-integer-reader upto)
     446          (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1))) ) ) )
     447
     448(define (make-integer-reader upto)
    475449  (lambda (port)
    476     (tm:integer-reader upto port) ) )
     450    (integer-reader upto port) ) )
    477451
    478452;; read *exactly* n characters and convert to integer; could be padded
    479453
    480 (define (tm:integer-reader-exact n port)
     454(define (integer-reader-exact n port)
    481455  (let ((padding-ok #t))
    482456    (let loop ((accum 0) (nchars 0))
     
    488462              ((char-numeric? ch)
    489463               (set! padding-ok #f)
    490                (loop (fx+ (fx* accum 10) (tm:digit->int (read-char port))) (fx+ nchars 1)))
     464               (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1)))
    491465              (padding-ok
    492466               (read-char port)    ; consume padding
     
    495469               (error-bad-date-template 'string->date "non-numeric characters in integer read" ch))) ) ) ) )
    496470
    497 (define (tm:make-integer-exact-reader n)
     471(define (make-integer-exact-reader n)
    498472  (lambda (port)
    499     (tm:integer-reader-exact n port)) )
    500 
    501 (define (tm:zone-reader port)
     473    (integer-reader-exact n port)) )
     474
     475(define (zone-reader port)
    502476  (let ((offset 0)
    503477        (is-pos #t)
     
    514488            (when (eof-object? ch)
    515489              (error-bad-date-template 'string->date "invalid time zone number" 'eof-object))
    516             (set! offset (fx* (tm:digit->int ch) (fx* 10 SEC/HR))))
     490            (set! offset (fx* (digit->int ch) (fx* 10 SEC/HR))))
    517491          ;; non-existing values are considered zero
    518492          (let ((ch (read-char port)))
    519493            (unless (eof-object? ch)
    520               (set! offset (fx+ offset (fx* (tm:digit->int ch) SEC/HR)))))
     494              (set! offset (fx+ offset (fx* (digit->int ch) SEC/HR)))))
    521495          (let ((ch (read-char port)))
    522496            (unless (eof-object? ch)
    523               (set! offset (fx+ offset (fx* (tm:digit->int ch) 600)))))
     497              (set! offset (fx+ offset (fx* (digit->int ch) 600)))))
    524498          (let ((ch (read-char port)))
    525499            (unless (eof-object? ch)
    526               (set! offset (fx+ offset (fx* (tm:digit->int ch) 60)))))
     500              (set! offset (fx+ offset (fx* (digit->int ch) 60)))))
    527501          (if is-pos offset (fxneg offset)))) ) )
    528502
    529503;; Looking at a char, read the char string, run thru indexer, return index
    530504
    531 (define (tm:locale-reader port indexer)
     505(define (locale-reader port indexer)
    532506  (letrec (
    533507    (read-char-string
     
    543517      index ) ) )
    544518
    545 (define (tm:make-locale-reader indexer)
     519(define (make-locale-reader indexer)
    546520  (lambda (port)
    547     (tm:locale-reader port indexer)) )
    548 
    549 (define (tm:make-char-id-reader char)
     521    (locale-reader port indexer)) )
     522
     523(define (make-char-id-reader char)
    550524  (lambda (port)
    551525    (let ((rch (read-char port)))
     
    566540
    567541(define tm:read-directives
    568   (let ((ireader4 (tm:make-integer-reader 4))
    569         (ireader2 (tm:make-integer-reader 2))
    570         (ireader7 (tm:make-integer-reader 7))
    571         (ireaderf (tm:make-integer-reader #f))
    572         (eireader2 (tm:make-integer-exact-reader 2))
    573         (eireader4 (tm:make-integer-exact-reader 4))
    574         (locale-reader-abbr-weekday (tm:make-locale-reader tm:locale-abbr-weekday->index))
    575         (locale-reader-long-weekday (tm:make-locale-reader tm:locale-long-weekday->index))
    576         (locale-reader-abbr-month   (tm:make-locale-reader tm:locale-abbr-month->index))
    577         (locale-reader-long-month   (tm:make-locale-reader tm:locale-long-month->index))
     542  (let ((ireader4 (make-integer-reader 4))
     543        (ireader2 (make-integer-reader 2))
     544        (ireader7 (make-integer-reader 7))
     545        (ireaderf (make-integer-reader #f))
     546        (eireader2 (make-integer-exact-reader 2))
     547        (eireader4 (make-integer-exact-reader 4))
     548        (locale-reader-abbr-weekday (make-locale-reader tm:locale-abbr-weekday->index))
     549        (locale-reader-long-weekday (make-locale-reader tm:locale-long-weekday->index))
     550        (locale-reader-abbr-month   (make-locale-reader tm:locale-abbr-month->index))
     551        (locale-reader-long-month   (make-locale-reader tm:locale-long-month->index))
    578552        (char-fail (lambda (ch) #t))
    579553        (do-nothing noop #;(lambda (val object) (void))))
    580554
    581555    (list
    582       (list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing)
     556      (list #\~ char-fail (make-char-id-reader #\~) do-nothing)
    583557
    584558      (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
     
    636610          (tm:date-zone-offset-set! object val))) ) ) )
    637611
    638 (define (tm:date-reader date format-rem len-rem port)
     612(define (date-reader date format-rem len-rem port)
    639613  (let loop ((format-rem format-rem) (len-rem len-rem))
    640614    (let ((skip-until
     
    675649  (let ((port #f)
    676650        (newdate (tm:make-incomplete-date)))
    677     (let ((date-compl?
     651    (let ((date-complete?
    678652           (lambda ()
    679              (and (date-nanosecond newdate)
    680                   (date-second newdate) (date-minute newdate) (date-hour newdate)
    681                   (date-day newdate) (date-month newdate) (date-year newdate)
    682                   (date-zone-offset newdate))))
     653             (and (tm:date-nanosecond newdate)
     654                  (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
     655                  (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
     656                  (tm:date-zone-offset newdate))))
    683657          (date-ok
    684658           (lambda ()
    685              (tm:check-exploded-date
     659             (check-date-elements
    686660               'scan-date
    687                (date-nanosecond newdate)
    688                (date-second newdate) (date-minute newdate) (date-hour newdate)
    689                (date-day newdate) (date-month newdate) (date-year newdate)
    690                (date-zone-offset newdate)
    691                (date-zone-name newdate)))))
     661               (tm:date-nanosecond newdate)
     662               (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
     663               (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
     664               (tm:date-zone-offset newdate)
     665               (tm:date-zone-name newdate)))))
    692666      (cond ((string? src)  (set! port (open-input-string src)))
    693667            ((port? src)    (set! port src))
    694668            (src            (set! port (current-input-port))))
    695669      (tm:date-reader newdate (string->list template-string) (string-length template-string) port)
    696       (unless (date-compl?)
     670      (unless (date-complete?)
    697671        (error-bad-date-template 'scan-date "date read incomplete" template-string newdate))
    698672      (date-ok)
     
    700674
    701675(define (string->date src . template-string)
    702   (scan-date src (optional template-string (%item@ LOCALE-DATE-TIME-FORMAT))) )
     676  (scan-date src (optional template-string (item@ LOCALE-DATE-TIME-FORMAT))) )
     677
     678) ;module srfi-19-io
     679
  • release/4/srfi-19/trunk/srfi-19-period.scm

    r15738 r15750  
    3535  (import scheme
    3636          chicken
    37           (only extras fprintf)
    38           srfi-19-support
    39           srfi-9-ext type-checks type-errors)
    40   (require-library #;srfi-8
    41                    srfi-19-support
    42                    srfi-9-ext type-checks type-errors)
    43 
    44   (declare
    45     (not usual-integrations
    46       - * /
    47       remainder quotient modulo
    48       expt
    49       abs
    50       round floor truncate
    51       number? integer? inexact?
    52       zero? negative? positive?
    53       = <= >= < >
    54       inexact->exact exact->inexact
    55       char-alphabetic? char-numeric?)
    56     (inline)
    57     (generic)
    58     (no-procedure-checks) )
     37          (only extras format)
     38          srfi-9-ext
     39          type-checks
     40          type-errors
     41          #;srfi-19-core
     42          srfi-19-support)
     43
     44  (require-library #;srfi-8 srfi-9-ext type-checks type-errors #;srfi-19-core srfi-19-support)
    5945
    6046;;;
     
    6450;;;
    6551
    66 (define (error-invalid-clock-type loc obj)
    67   (error-invalid-type loc "clock type" obj) )
    68 
    69 (define (error-invalid-time-object loc obj)
    70   (error-invalid-type loc "time object" obj) )
     52(define ONE-NANOSECOND-DURATION (one-nanosecond-duration))
     53
     54;;;
     55
     56(define (error-time-object loc obj)
     57  (error-argument-type loc obj "time object") )
    7158
    7259(define (error-incompatible-clock-type loc obj)
    73   (error loc "incompatible clock type" obj) )
     60  (signal-type-error loc "incompatible clock type" obj) )
    7461
    7562(define (error-incompatible-clock-types loc obj1 obj2)
    76   (error loc "incompatible clock types" obj1 obj2) )
     63  (signal-type-error loc "incompatible clock types" obj1 obj2) )
    7764
    7865;;; Time Period
     
    8774
    8875(define-record-printer (time-period per out)
    89   (fprintf out "#,(time-period ~A ~A)" (*time-period-begin per) (*time-period-end per)) )
     76  (format out "#,(time-period ~A ~A)" (*time-period-begin per) (*time-period-end per)) )
    9077
    9178(define-reader-ctor 'time-period *make-time-period)
    9279
    93 (define (tm:time-period-binop-check loc obj1 obj2)
     80(define (check-time-period-binop loc obj1 obj2)
    9481  (check-time-period loc obj1)
    9582  (check-time-period loc obj2) )
     
    9986(define (tm:time-period-null? per) (tm:time<=? (*time-period-end per) (*time-period-begin per)))
    10087
    101 (define (tm:as-empty-time-period per)
    102   (*make-time-period
    103    (tm:as-empty-time (*time-period-begin per))
    104    (tm:as-empty-time (*time-period-end per))) )
     88(define (tm:make-time-period-zero obj)
     89  (let ((tt (if (time-period? obj) (tm:time-period-type obj) obj)))
     90    (*make-time-period (zero-time tt) (zero-time tt)) ) )
    10591
    10692(define (tm:ensure-compatible-time loc t1 t2)
    10793  (let ((tt1 (tm:time-type t1))
    108         (tt2 (tm:time-type t2))
    109         (errtt (lambda () (error-incompatible-clock-types loc t1 t2))))
     94        (tt2 (tm:time-type t2)))
     95    (define (errtt) (error-incompatible-clock-types loc t1 t2))
    11096    (if (eq? tt1 tt2) t2
    111         (let ((ntime (tm:as-empty-time t1)))
     97        (let ((ntime (tm:any-time)))
    11298          (case tt1
    113             ((time-tai)
     99            ((tai)
    114100              (case tt2
    115                 ((time-utc)       (tm:time-utc->time-tai t2 ntime))
    116                 ((time-monotonic) (tm:time-monotonic->time-tai t2 ntime))
     101                ((utc)        (tm:time-utc->time-tai t2 ntime))
     102                ((monotonic) (tm:time-monotonic->time-tai t2 ntime))
    117103                (else
    118104                 (errtt))))
    119             ((time-utc)
     105            ((utc)
    120106              (case tt2
    121                 ((time-tai)       (tm:time-tai->time-utc t2 ntime))
    122                 ((time-monotonic) (tm:time-monotonic->time-utc t2 ntime))
     107                ((tai)        (tm:time-tai->time-utc t2 ntime))
     108                ((monotonic) (tm:time-monotonic->time-utc t2 ntime))
    123109                (else
    124110                 (errtt))))
    125             ((time-monotonic)
     111            ((monotonic)
    126112              (case tt2
    127                 ((time-utc) (tm:time-utc->time-monotonic t2 ntime))
    128                 ((time-tai) (tm:time-tai->time-monotonic t2 ntime))
     113                ((utc)        (tm:time-utc->time-monotonic t2 ntime))
     114                ((tai)        (tm:time-tai->time-monotonic t2 ntime))
    129115                (else
    130116                 (errtt))))
    131117            (else
    132              (errtt))))) ) )
    133 
    134 (define (tm:ensure-compatible-date tim dat loc)
     118             (errtt)) ) ) ) ) )
     119
     120(define (tm:ensure-compatible-time-period-begin loc per1 per2)
     121  (tm:ensure-compatible-time loc (*time-period-begin per1) (*time-period-begin per2)) )
     122
     123(define (tm:ensure-compatible-time-period-end loc per1 per2)
     124  (tm:ensure-compatible-time loc (*time-period-end per1) (*time-period-end per2)) )
     125
     126(define (tm:ensure-compatible-date loc tim dat)
    135127  (case (tm:time-type tim)
    136     ((time-utc)       (date->time-utc dat))
    137     ((time-tai)       (date->time-tai dat))
    138     ((time-monotonic) (date->time-monotonic dat))
     128    ((utc)       (date->time-utc dat))
     129    ((tai)       (date->time-tai dat))
     130    ((monotonic) (date->time-monotonic dat))
    139131    (else
    140132     (error-incompatible-clock-type loc tim))) )
     133
     134(define (tm:time-period-type=? per1 per2)
     135  (eq? (tm:time-period-type per1) (tm:time-period-type per2)) )
    141136
    142137(define (tm:time-period=? per1 per2)
     
    151146  (and (not (tm:time-period-null? per1))
    152147       (let ((tper
    153               (if (eq? (tm:time-period-type per1) (tm:time-period-type per2)) per2
    154                   (*make-time-period
    155                    (tm:ensure-compatible-time loc (*time-period-begin per1) (*time-period-begin per2))
    156                    (tm:ensure-compatible-time loc (*time-period-end per1) (*time-period-end per2))))))
    157          (tm:time-points-within?
    158           (*time-period-begin per1) (*time-period-end per1)
    159           (*time-period-begin tper) (*time-period-end tper)) ) ) )
     148              (if (tm:time-period-type=? per1 per2) per2
     149                  (*make-time-period (tm:ensure-compatible-time-period-begin loc per1 per2)
     150                                     (tm:ensure-compatible-time-period-end loc per1 per2)) ) ) )
     151         (tm:time-points-within? (*time-period-begin per1) (*time-period-end per1)
     152                                 (*time-period-begin tper) (*time-period-end tper)) ) ) )
    160153
    161154(define (tm:time-period-contains/time? loc per tim)
     
    165158
    166159(define (tm:time-period-contains/date? loc per dat)
    167   (tm:time-period-contains/time?
    168     loc per (tm:ensure-compatible-date loc (*time-period-begin per) dat)) )
     160  (tm:time-period-contains/time? loc
     161                                 per
     162                                 (tm:ensure-compatible-date loc (*time-period-begin per) dat)) )
    169163
    170164(define (tm:time-point-intersection b1 e1 b2 e2)
     
    182176           (tm:time-point-intersection b1 e1 b2 e2) ) ) ) )
    183177
    184 (define (tm:time-period-shift per-in dur per-out)
    185   (tm:add-duration (*time-period-begin per-in) dur (*time-period-begin per-out))
    186   (tm:add-duration (*time-period-end per-in) dur (*time-period-end per-out))
    187   per-out )
     178(define (tm:time-period-shift perin dur perout)
     179  (tm:add-duration (*time-period-begin perin) dur (*time-period-begin perout))
     180  (tm:add-duration (*time-period-end perin) dur (*time-period-end perout))
     181  perout )
    188182
    189183;FIXME - should take into account span
     
    206200(define (make-null-time-period . args)
    207201  (let-optionals args ((timtyp (default-date-clock-type)))
    208     (tm:as-empty-time-period (tm:make-empty-time timtyp)) ) )
     202    (tm:make-time-period-zero timtyp) ) )
    209203
    210204(define (make-time-period beg end . args)
    211205  (let-optionals args ((timtyp (default-date-clock-type)))
    212     (cond ((number? beg)
    213            (set! beg (seconds->time/type beg timtyp)) )
    214           ((date? beg)
    215            (set! beg (date->time beg timtyp)) ) )
    216     (tm:check-time 'make-time-period beg)
    217     (when (eq? 'time-duration (tm:time-type beg))
    218       (error-invalid-clock-type 'make-time-period beg))
    219     (cond ((number? end)
    220            (set! end (seconds->time/type end 'time-duration)) )
    221           ((date? end)
    222            (set! end (tm:ensure-compatible-date 'make-time-period beg end)) ) )
    223     (tm:check-time 'make-time-period end)
    224     (when (eq? 'time-duration (tm:time-type end))
    225       (set! end (tm:add-duration beg end (tm:as-empty-time beg))))
     206    ;
     207    (cond ((real? beg)  (set! beg (seconds->time/type beg timtyp)) )
     208          ((date? beg)  (set! beg (date->time beg timtyp)) ) )
     209    (check-time 'make-time-period beg 'begin)
     210    (when (tm:time-has-type? (tm:time-type beg) 'duration)
     211      (error-clock-type 'make-time-period beg 'begin))
     212    ;
     213    (cond ((real? end)  (set! end (seconds->time/type end 'duration)) )
     214          ((date? end)  (set! end (tm:ensure-compatible-date 'make-time-period beg end)) ) )
     215    (check-time 'make-time-period end 'end)
     216    (when (tm:time-has-type? (tm:time-type end) 'duration)
     217      (set! end (tm:add-duration beg end (tm:as-some-time beg))))
     218    ;
    226219    (*make-time-period beg (tm:ensure-compatible-time 'make-time-period beg end)) ) )
    227220
     
    240233#;
    241234(define (time-period-compare per1 per2)
    242   (tm:time-period-binop-check 'time-period-compare per1 per2)
     235  (check-time-period-binop 'time-period-compare per1 per2)
    243236  (let ((diff (tm:time-period-subtract per1 per2)))
    244237    (cond ((negative? diff) -1)
     
    247240
    248241(define (time-period=? per1 per2)
    249   (tm:time-period-binop-check 'time-period=? per1 per2)
     242  (check-time-period-binop 'time-period=? per1 per2)
    250243  (tm:time-period=? per1 per2) )
    251244
    252245(define (time-period<? per1 per2)
    253   (tm:time-period-binop-check 'time-period<? per1 per2)
     246  (check-time-period-binop 'time-period<? per1 per2)
    254247  (tm:time<? (*time-period-end per1) (*time-period-begin per2)) )
    255248
    256249(define (time-period>? per1 per2)
    257   (tm:time-period-binop-check 'time-period>? per1 per2)
     250  (check-time-period-binop 'time-period>? per1 per2)
    258251  (tm:time>? (*time-period-begin per1) (*time-period-end per2)) )
    259252
    260253(define (time-period<=? per1 per2)
    261   (tm:time-period-binop-check 'time-period<=? per1 per2)
     254  (check-time-period-binop 'time-period<=? per1 per2)
    262255  (tm:time<=? (*time-period-end per1) (*time-period-begin per2)) )
    263256
    264257(define (time-period>=? per1 per2)
    265   (tm:time-period-binop-check 'time-period>=? per1 per2)
     258  (check-time-period-binop 'time-period>=? per1 per2)
    266259  (tm:time>=? (*time-period-begin per1) (*time-period-end per2)) )
    267260
    268261(define (time-period-preceding per1 per2)
    269   (tm:time-period-binop-check 'time-period-preceding per1 per2)
     262  (check-time-period-binop 'time-period-preceding per1 per2)
    270263  (and (tm:time<=? (*time-period-begin per1) (*time-period-begin per2))
    271264       (make-time-period (*time-period-begin per1) (*time-period-begin per2)) ) )
    272265
    273266(define (time-period-succeeding per1 per2)
    274   (tm:time-period-binop-check 'time-period-succeeding per1 per2)
     267  (check-time-period-binop 'time-period-succeeding per1 per2)
    275268  (and (tm:time>=? (*time-period-end per1) (*time-period-end per2))
    276269       (make-time-period (*time-period-end per2) (*time-period-end per1)) ) )
     
    279272  (check-time-period 'time-period-last per)
    280273  (let ((end (*time-period-end per)))
    281     (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-empty-time end)) ) )
     274    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-some-time end)) ) )
    282275
    283276(define (time-period-length per)
    284277  (check-time-period 'time-period-length per)
    285   (let ((dur (tm:make-empty-time time-duration)))
     278  (let ((dur (zero-time 'duration)))
    286279    (if (tm:time-period-null? per) dur
    287280        (tm:time-difference (*time-period-begin per) (*time-period-end per) dur)) ) )
     
    294287(define (time-period-contains/time? per tim)
    295288  (check-time-period 'time-period-contains/time? per)
    296   (tm:check-time 'time-period-contains/time? tim)
     289  (check-time 'time-period-contains/time? tim)
    297290  (tm:time-period-contains/time? 'time-period-contains/time? per tim) )
    298291
    299292(define (time-period-contains/date? per dat)
    300293  (check-time-period 'time-period-contains/date? per)
    301   (tm:check-date 'time-period-contains/date? dat)
     294  (check-date 'time-period-contains/date? dat)
    302295  (tm:time-period-contains/date? 'time-period-contains/date? per dat) )
    303296
     
    311304         (tm:time-period-contains/date? 'time-period-contains? per obj))
    312305        (else
    313          (error-invalid-time-object 'time-period-contains? obj))) )
     306         (error-time-object 'time-period-contains? obj))) )
    314307
    315308(define (time-period-intersects? per1 per2)
     
    350343(define (time-period-shift per dur)
    351344  (check-time-period 'time-period-shift per)
    352   (tm:check-duration 'time-period-shift dur)
    353   (tm:time-period-shift per dur (tm:as-empty-time-period per)) )
     345  (check-duration 'time-period-shift dur)
     346  (tm:time-period-shift per dur (tm:make-time-period-zero per)) )
    354347
    355348(define (time-period-shift! per dur)
    356349  (check-time-period 'time-period-shift! per)
    357   (tm:check-duration 'time-period-shift! dur)
     350  (check-duration 'time-period-shift! dur)
    358351  (tm:time-period-shift per dur per) )
    359352
  • release/4/srfi-19/trunk/srfi-19-support.scm

    r15738 r15750  
    11;;;; srfi-19-support.scm
    22;;;; Chicken port, Kon Lovett, Dec '05
    3 
    4 ;; Issues
    5 ;;
    6 ;; - The 'date-dst?' field is problimatic. It is only valid on certain
    7 ;; platforms & only when current. A past or future date will not have this
    8 ;; field correct!
    9 ;;
    10 ;; - Time -> Date conversion takes account of the CURRENT daylight saving time state,
    11 ;; NOT the state of the converted date.
    12 ;;
    13 ;; - Gregorian calendar only.
    14 ;;
    15 ;; - Initialization is scattered throughout the code, so converting to a module will
    16 ;; involve some search.
    17 ;;
    18 ;; - Some errors have incorrect procedure labels (not the top-level loc)
    19 
    20 ;; Notes
    21 ;;
    22 ;; - There is no year zero. So when converting from a BCE year on the sign of the year
    23 ;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713!
    24 ;;
    25 ;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from
    26 ;; UTC & a subtracted offset is "towards" UTC.
    27 ;;
    28 ;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every
    29 ;; conversion procedure.
    30 ;;
    31 ;; - Time has sign ONLY on the seconds, the nanoseconds is always positive.
    32 ;; However the original implementation did not always enforce.
    33 
    34 ;; To Do
    35 ;;
    36 ;; - Time -> Date conversion takes account of the state of the converted date
    37 ;; daylight saving time state.
    38 ;;
    39 ;; - Date/Time field minimums & maximums (useful for UI)
    40 ;;
    41 ;; - epoch access (?)
    42 ;;
    43 ;; - +inf, -inf, nan times & dates
    44 ;;
    45 ;; - add/roll date field; +/- some field, such as "next week"
    46 ;;
    47 ;; - date-iterator; +/- some increment per call
    48 ;;
    49 ;; - relative-date; such as "last thursday in june"
    50 ;;
    51 ;; - Plugable calendar systems
    523
    534;; SRFI-19: Time Data Types and Procedures.
     
    7728;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
    7829
     30;; Issues
     31;;
     32;; - Gregorian calendar only.
     33;;
     34;; - Initialization is scattered throughout the code, so converting to a module will
     35;; involve some search.
     36;;
     37;; - Some errors have incorrect procedure labels (not the top-level loc)
     38
     39;; Bugs
     40;;
     41;; - The 'date-dst?' field is problimatic. It is only valid on certain
     42;; platforms & only when current. A past or future date will not have this
     43;; field correct!
     44;;
     45;; - Time -> Date conversion takes account of the CURRENT daylight saving time state,
     46;; NOT the state of the converted date.
     47
     48;; Notes
     49;;
     50;; - There is no year zero. So when converting from a BCE year on the sign of the year
     51;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713!
     52;;
     53;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from
     54;; UTC & a subtracted offset is "towards" UTC.
     55;;
     56;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every
     57;; conversion procedure.
     58
    7959(include "chicken-primitive-object-inlines")
    8060
    8161(module srfi-19-support (;export
    8262  ;
     63  time?
     64  time-type?
     65  time-seconds?
     66  time-nanoseconds?
     67  clock-type?
     68  date?
     69  date-nanoseconds?
     70  date-seconds?
     71  date-minutes?
     72  date-hours?
     73  date-day?
     74  date-month?
     75  date-year?
     76  timezone-name?
     77  timezone-info?
     78  julian-day?
     79  ;
    8380  check-time
     81  check-time-type
     82  check-time-seconds
     83  check-time-nanoseconds
     84  check-time-has-type
     85  check-time-and-type
    8486  check-duration
     87  check-time-elements
     88  #;check-times
     89  check-time-binop
     90  check-time-compare
     91  check-time-aritmetic
     92  check-clock-type
     93  check-date
     94  check-date-nanoseconds
     95  check-date-seconds
     96  check-date-minutes
     97  check-date-hours
     98  check-date-day
     99  check-date-month
     100  check-date-year
     101  check-timezone-name
     102  check-timezone-info
     103  check-date-elements
     104  check-compatible-timezone-offsets
     105  check-julian-day
    85106  ;
     107  error-time
     108  error-time-type
     109  error-time-seconds
     110  error-time-nanoseconds
     111  error-incompatible-time-types
     112  error-clock-type
     113  error-date
     114  error-date-nanoseconds
     115  error-date-seconds
     116  error-date-minutes
     117  error-date-hours
     118  error-date-day
     119  error-date-month
     120  error-date-year
     121  error-timezone-name
     122  error-timezone-info
     123  error-incompatible-timezone
     124  error-julian-day
     125  ;
     126  tm:read-tai-utc-data
     127  tm:calc-second-before-leap-second-table
     128  tm:read-leap-second-table
     129  tm:any-time
     130  tm:some-time
     131  tm:as-some-time
     132  tm:time-nanosecond-set!
     133  tm:time-second-set!
    86134  tm:make-time
    87   tm:time-type
    88   tm:time-second
    89   tm:time-nanosecond
    90   tm:make-empty-time
    91   tm:as-empty-time
     135  tm:copy-time
     136  tm:time-has-type?
     137  tm:nanoseconds->time-values
     138  tm:time->nanoseconds
     139  tm:time->milliseconds
     140  tm:nanoseconds->seconds
     141  tm:milliseconds->seconds
     142  tm:time->seconds
     143  tm:duration-elements->time-values
     144  tm:milliseconds->time-values
     145  tm:seconds->time-values
     146  tm:current-sub-milliseconds
     147  tm:current-nanoseconds
     148  tm:current-time-values
     149  tm:current-time-utc
     150  tm:current-time-tai
     151  tm:current-time-monotonic
     152  tm:current-time-thread
     153  tm:current-time-process
     154  tm:current-time-gc
     155  tm:time-resolution
     156  tm:time-compare
     157  tm:time=?
     158  tm:time<?
     159  tm:time<=?
     160  tm:time>?
     161  tm:time>=?
     162  #;tm:time-max
     163  #;tm:time-min
     164  tm:time-difference
     165  tm:add-duration
     166  tm:subtract-duration
     167  tm:divide-duration
     168  tm:multiply-duration
     169  tm:time-abs
     170  tm:time-negate
     171  tm:time-tai->time-utc
     172  tm:time-tai->time-monotonic
     173  tm:time-utc->time-tai
     174  tm:time-utc->time-monotonic
    92175  tm:time-monotonic->time-tai
    93   tm:time-utc->time-tai
    94   tm:time-tai->time-monotonic
    95   tm:time-utc->time-monotonic
    96176  tm:time-monotonic->time-utc
    97   tm:time-tai->time-utc
     177  tm:leap-year?
     178  tm:days-in-month
     179  tm:date-nanosecond-set!
     180  tm:date-second-set!
     181  tm:date-minute-set!
     182  tm:date-hour-set!
     183  tm:date-day-set!
     184  tm:date-month-set!
     185  tm:date-year-set!
     186  tm:date-zone-offset-set!
     187  tm:make-incomplete-date
     188  tm:make-date
     189  tm:copy-date
     190  tm:seconds->date/type
     191  tm:date-compare
     192  tm:decode-julian-day-number
     193  tm:decode-julian-day-number
     194  tm:seconds->julian-day-number
     195  tm:tai-before-leap-second?
     196  tm:time-utc->date
     197  tm:time-utc->date
     198  tm:time-tai->date
     199  tm:time->date
     200  tm:encode-julian-day-number
     201  tm:encode-julian-day-number
     202  tm:date->time-utc
     203  tm:date->time-utc
     204  tm:date->time-tai
     205  tm:date->time-monotonic
     206  tm:date->time
     207  tm:natural-year
     208  tm:year-day
     209  tm:cache-date-year-day
    98210  tm:week-day
    99211  tm:days-before-first-week
    100   tm:subtract-duration
    101   tm:add-duration
    102   tm:time=?
    103   tm:time<?
    104   tm:time>?
    105   tm:time<=?
    106   tm:time>=?
    107   tm:time-max
    108   tm:time-min
    109   tm:time-difference
    110   ;
    111   check-date
    112   check-exploded-date
    113   ;
    114   tm:date-day-set!
    115   tm:date-hour-set!
    116   tm:date-minute-set!
    117   tm:date-month-set!
    118   tm:date-nanosecond-set!
    119   tm:date-second-set!
    120   tm:date-year-set!
    121   tm:date-zone-offset-set!
    122   tm:make-incomplete-date)
    123 
    124   (import (except scheme + - * /
    125                          remainder quotient modulo
    126                          expt
    127                          abs
    128                          round floor truncate
    129                          real? integer? inexact?
    130                          zero? negative? positive?
     212  tm:cache-date-week-day
     213  tm:date-week-number
     214  tm:julian-day->modified-julian-day
     215  tm:julian-day
     216  tm:julian-day
     217  tm:date->julian-day
     218  tm:seconds->julian-day
     219  tm:time-utc->julian-day
     220  tm:time-tai->julian-day
     221  tm:time-monotonic->julian-day
     222  tm:time->julian-day
     223  tm:time-utc->modified-julian-day
     224  tm:time-tai->modified-julian-day
     225  tm:time-monotonic->modified-julian-day
     226  tm:time->modified-julian-day
     227  tm:julian-day->nanoseconds
     228  tm:julian-day->time-values
     229  tm:modified-julian-day->julian-day
     230  tm:julian-day->time-utc)
     231
     232  (import (except scheme + - * / remainder quotient
     233                         abs round floor truncate
     234                         real? integer? inexact? zero? negative? positive?
    131235                         = <= >= < >
    132236                         inexact->exact exact->inexact
    133237                         string->number)
    134           chicken
    135           #;srfi-6 #;srfi-8 #;srfi-9
    136           (only srfi-18 seconds->time time->seconds)
    137           (prefix srfi-18 srfi-18:)
    138           #;posix
    139           miscmacros
    140           numbers locale srfi-9-ext type-checks type-errors)
    141 
    142   (require-library #;srfi-6 #;srfi-8 #;srfi-9
    143                    #;posix
    144                    miscmacros numbers locale srfi-9-ext type-checks type-errors)
     238          (except chicken time)
     239          #;srfi-8
     240          (only extras format read-line)
     241          (only ports with-input-from-port)
     242          (only numbers + - * / remainder quotient
     243                        abs round floor truncate
     244                        real? integer? inexact? zero? negative? positive?
     245                        = <= >= < >
     246                       inexact->exact exact->inexact
     247                       string->number)
     248          locale
     249          srfi-9-ext
     250          type-checks type-errors
     251          (only srfi-19-timezone timezone-locale-name timezone-locale-offset timezone-locale-dst?))
     252
     253  (require-library scheme chicken #;srfi-8 srfi-18 extras ports
     254                   numbers locale srfi-9-ext type-checks type-errors
     255                   srfi-19-timezone)
    145256
    146257;;;
     
    155266  (let ((accum-ms 0))
    156267    (lambda ()
    157       (set! accum-ms (fx+ accum-ms (current-gc-milliseconds)))
     268      (set! accum-ms (+ accum-ms (current-gc-milliseconds)))
    158269      accum-ms ) ) )
    159270
    160271(define (current-process-milliseconds) (receive (ums sms) (cpu-time) (+ ums sms)))
    161272
    162 ;FIXME needs srfi-18 extension
     273;FIXME needs a srfi-18 extension
    163274(define current-thread-milliseconds current-process-milliseconds)
    164275
     
    184295
    185296(define TAI-EPOCH-IN-MODIFIED-JD (string->number "4800001/2"))
     297
     298;; Julian conversion base century
     299
     300(define-constant JDYR 4800)
    186301
    187302;;; Leap Seconds
     
    245360
    246361(define (tm:read-tai-utc-data flnm)
    247 
    248362  (define (convert-jd jd) (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))
    249 
    250363  (define (convert-sec sec) (inexact->exact sec))
    251 
    252364  (define (read-data)
    253365    (let loop ((ls '()))
     
    260372                 (loop (if (< year FIRST-LEAP-YEAR) ls
    261373                           (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )
    262 
    263       (with-input-from-port (open-input-file flnm) read-data) )
     374  (with-input-from-port (open-input-file flnm) read-data) )
    264375
    265376;; Table of cummulative seconds, one second before the leap second.
     
    276387;; Read a leap second table file in U.S. Naval Observatory format
    277388
    278 (define (read-leap-second-table flnm)
     389(define (tm:read-leap-second-table flnm)
    279390  (set! tm:leap-second-table (tm:read-tai-utc-data flnm))
    280391  (set! tm:second-before-leap-second-table
     
    284395
    285396; 'leap-second-item' is like the 'it' in the anaphoric 'if'
    286 
     397;
    287398(define-syntax find-leap-second-delta*
    288399  (lambda (form r c)
     
    329440;;; Time Object (Public Mutable)
    330441
    331 ;; Clock Type Constants
    332 ;; (Not used internally)
    333 
    334 (define time-duration     'time-duration)
    335 (define time-gc           'time-gc)
    336 (define time-monotonic    'time-monotonic)
    337 (define time-process      'time-process)
    338 (define time-tai          'time-tai)
    339 (define time-thread       'time-thread)
    340 (define time-utc          'time-utc)
    341 
    342 (define (clock-time-type? obj) (memq? obj '(time-monotonic time-tai time-utc)))
    343 
    344 (define-check+error-type clock-type)
    345 
    346 ;;
    347 
    348 (define-parameter default-date-clock-type 'time-utc
    349   (lambda (obj)
    350     (cond ((clock-time-type? obj) obj)
    351           (else
    352            (warning-argument-type 'default-date-clock-type obj 'clock-time-type)
    353            (default-date-clock-type) ) ) ) )
    354 
    355442;; There are 3 kinds of time record procedures:
    356443;; *...   - generated
    357 ;; tm:... - argument processing then %...
     444;; tm:... - argument processing then *...
    358445;; ...    - argument checking then tm:...
    359446
     
    365452  (sec  *time-second      *time-second-set!) )
    366453
    367 (define (time-type? obj)
    368   (memq? obj '(time-monotonic time-utc time-tai time-gc time-duration time-process time-thread)) )
     454;;
     455
     456(define-record-printer (time tim out)
     457  (format out "#,(time ~A ~A ~A)" (*time-type tim) (*time-nanosecond tim) (*time-second tim)) )
     458
     459(define-reader-ctor 'time *make-time)
     460
     461;;
     462
     463(define (time-type? obj) (memq? obj '(monotonic utc tai gc duration process thread)))
    369464(define (time-seconds? obj) (integer? obj))
    370 (define (time-nanoseconds? obj) (and (fixnum? obj) (fx<= 0 obj) (fx< obj NS/S)))
     465(define (time-nanoseconds? obj) (and (fixnum? obj) (fx< -NS/S obj) (fx< obj NS/S)))
     466
     467;;
    371468
    372469(define-check+error-type time)
     
    375472(define-check+error-type time-nanoseconds)
    376473
     474;; Output Argument CTORs
     475
     476;Used to create an output time record where all fields will be set later
     477;
     478(define (tm:any-time) (*make-time #f #f #f))
     479
     480;Used to create a time record where ns & sec fields will be set later
     481;
     482(define (tm:some-time tt) (*make-time tt #f #f))
     483
     484;Used to create a time record where ns & sec fields will be set later
     485;
     486(define (tm:as-some-time tim) (*make-time (*time-type tim) #f #f))
     487
    377488;;
    378489
     
    381492(define tm:time-nanosecond *time-nanosecond)
    382493
    383 (define (tm:make-time tt ns sec)
    384   (*make-time tt (number->maybe-fixnum ns) (maybe-integer->maybe-fixnum sec)) )
    385 
    386 (define (tm:time-nanosecond-set! tim ns)
    387   (*time-nanosecond-set! tim (number->maybe-fixnum ns)) )
    388 
    389 (define (tm:time-second-set! tim sec)
    390   (*time-second-set! tim (maybe-integer->maybe-fixnum sec)) )
    391 
    392 ;;
    393 
    394 (define-record-printer (time tim out)
    395   (format out "#,(time ~A ~A ~A)" (*time-type tim) (*time-nanosecond tim) (*time-second tim)) )
    396 
    397 (define-reader-ctor 'time tm:make-time)
    398 
    399 ;; Time Constants
    400 
    401 (define ONE-SECOND-DURATION (*make-time 'time-duration 0 1))
    402 
    403 (define ONE-NANOSECOND-DURATION (*make-time 'time-duration 1 0))
    404 
    405 (define (tm:make-empty-time tt) (*make-time tt 0 0))
    406 
    407 (define (tm:as-empty-time tim) (tm:make-empty-time (*time-type tim)))
    408 
    409 ;; Time Parameter Checking
     494(define tm:time-type-set! *time-type-set!)
     495(define (tm:time-nanosecond-set! tim ns) (*time-nanosecond-set! tim (gennum->?fixnum ns)))
     496(define (tm:time-second-set! tim sec) (*time-second-set! tim (?genint->?fixnum sec)))
     497
     498(define (tm:make-time tt ns sec) (*make-time tt (gennum->?fixnum ns) (?genint->?fixnum sec)))
     499
     500(define (tm:copy-time tim) (*make-time (*time-type tim) (*time-second tim) (*time-nanosecond tim)))
     501
     502(define (tm:time-has-type? tim tt) (eq? tt (*time-type tim)))
     503
     504;; Rem & Quo of nanoseconds per second
     505
     506(define (tm:nanoseconds->time-values nanos) (values (remainder nanos NS/S) (quotient nanos NS/S)))
     507
     508;; Seconds Conversion
     509
     510(define (tm:time->nanoseconds tim) (+ (*time-nanosecond tim) (* (*time-second tim) NS/S)))
     511(define (tm:time->milliseconds tim) (+ (/ (*time-nanosecond tim) NS/MS) (* (*time-second tim) MS/S)))
     512(define (tm:nanoseconds->seconds ns) (/ ns NS/S))
     513(define (tm:milliseconds->seconds ms) (/ (exact->inexact ms) MS/S))
     514(define (tm:time->seconds tim) (tm:nanoseconds->seconds (tm:time->nanoseconds tim)))
     515
     516(define (tm:duration-elements->time-values days hours minutes seconds milliseconds microseconds nanoseconds)
     517  (let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
     518        (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
     519    (receive (ns sec) (tm:nanoseconds->time-values nanos)
     520      (values ns (+ secs sec)) ) ) )
     521
     522(define (tm:seconds->time-values sec)
     523  (let* ((tsec (?genint->?fixnum (truncate sec)))
     524         (ns (gennum->?fixnum (round (abs (* (- (exact->inexact sec) tsec) NS/S))))) )
     525      (values ns tsec) ) )
     526
     527(define (tm:milliseconds->time-values ms)
     528  (let ((ns (fx* (gennum->?fixnum (remainder ms MS/S)) NS/MS))
     529        (sec (quotient ms MS/S)) )
     530    (values ns sec) ) )
     531
     532;; Current time routines
     533
     534; Throw away everything but the sub-second bit.
     535; Chicken 'current-milliseconds' within positive fixnum range
     536;
     537(define (tm:current-sub-milliseconds) (fxmod (current-milliseconds) MS/S))
     538(define (tm:current-nanoseconds) (* (tm:current-sub-milliseconds) NS/MS))
     539
     540;Use the 'official' seconds & nanoseconds values
     541;
     542(define (tm:current-time-values) (values (tm:current-nanoseconds) (current-seconds)))
     543
     544(define (tm:current-time-utc)
     545  (receive (ns sec) (tm:current-time-values)
     546    (tm:make-time 'utc ns sec)) )
     547
     548(define (tm:current-time-tai)
     549  (receive (ns sec) (tm:current-time-values)
     550    (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) )
     551
     552(define (tm:current-time-monotonic)
     553  (let ((tim (tm:current-time-tai)))
     554    ;time-monotonic is time-tai
     555    (*time-type-set! tim 'monotonic)
     556    tim ) )
     557
     558(define (tm:current-time-thread)
     559  (milliseconds->time (current-thread-milliseconds) 'thread) )
     560
     561(define (tm:current-time-process)
     562  (milliseconds->time (current-process-milliseconds) 'process) )
     563
     564(define (tm:current-time-gc)
     565  (milliseconds->time (total-gc-milliseconds) 'gc) )
     566
     567;; -- Time Resolution
     568;; This is the resolution of the clock in nanoseconds.
     569;; This will be implementation specific.
     570
     571(define (tm:time-resolution tt)
     572  NS/MS )
     573
     574;; Specialized Time Parameter Checking
    410575
    411576(define (error-incompatible-time-types loc tt1 tt2)
     
    413578
    414579(define (check-time-has-type loc tim tt)
    415   (unless (eq? tt (*time-type tim))
     580  (unless (tm:time-has-type? tim tt)
    416581    (error-incompatible-time-types loc (*time-type tim) tt) ) )
    417582
     
    420585  (check-time-has-type loc tim tt) )
    421586
    422 (define (check-duration loc obj) (check-time-and-type loc obj 'time-duration))
    423 
    424 (define-check+error-type time-seconds)
     587(define (check-duration loc obj) (check-time-and-type loc obj 'duration))
    425588
    426589(define (check-time-elements loc obj1 obj2 obj3)
     
    429592  (check-time-seconds loc obj3) )
    430593
     594#; ;UNUSED
    431595(define (check-times loc objs) (for-each (cut check-time loc <>) objs))
    432596
    433 (define (tm:time-binop-check loc obj1 obj2)
     597(define (check-time-binop loc obj1 obj2)
    434598  (check-time loc obj1)
    435599  (check-time loc obj2) )
    436600
    437 (define (tm:time-compare-check loc obj1 obj2)
    438   (tm:time-binop-check loc obj1 obj2)
     601(define (check-time-compare loc obj1 obj2)
     602  (check-time-binop loc obj1 obj2)
    439603  (check-time-has-type loc obj1 (*time-type obj2)) )
    440604
    441 (define (tm:time-aritmetic-check loc tim dur)
     605(define (check-time-aritmetic loc tim dur)
    442606  (check-time loc tim)
    443607  (check-duration loc dur) )
    444 
    445 ;; Rem & Quo of nanoseconds per second
    446 
    447 (define (tm:split-nanoseconds nanos) (values (abs (remainder nanos NS/S)) (quotient nanos NS/S)))
    448 
    449 ;; Time CTOR
    450 
    451 (define (make-time tt ns sec)
    452   (check-time-elements 'make-time tt ns sec)
    453   (tm:make-time tt ns sec) )
    454 
    455 (define (make-duration
    456           #!key (days 0)
    457                 (hours 0) (minutes 0) (seconds 0)
    458                 (milliseconds 0) (microseconds 0) (nanoseconds 0))
    459   #;(%check-number 'make-duration days "days")
    460   #;(%check-number 'make-duration hours "hours")
    461   #;(%check-number 'make-duration minutes "minutes")
    462   #;(%check-number 'make-duration seconds "seconds")
    463   #;(%check-number 'make-duration milliseconds "milliseconds")
    464   #;(%check-number 'make-duration microseconds "microseconds")
    465   #;(%check-number 'make-duration nanoseconds "nanoseconds")
    466   (let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
    467         (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)))
    468     (receive (ns sec) (tm:split-nanoseconds nanos)
    469       (let ((sec (+ secs sec)))
    470         (check-time-elements 'make-duration 'time-duration ns sec)
    471         (tm:make-time 'time-duration ns sec) ) ) ) )
    472 
    473 (define (copy-time tim) (*make-time (*time-type tim) (*time-second tim) (*time-nanosecond tim)))
    474 
    475 ;; Converts a seconds value, may be fractional, into a time type.
    476 ;; The type of time default is 'time-duration.
    477 
    478 (define (seconds->time/type sec . args)
    479   (let-optionals args ((tt 'time-duration))
    480     (let* ((tsec (truncate sec))
    481            (ns (round (abs (* (- (exact->inexact sec) tsec) NS/S)))) )
    482       (check-time-elements 'seconds->time/type tt ns tsec)
    483       (tm:make-time tt ns tsec) ) ) )
    484 
    485 ;; Time record-type operations
    486 
    487 (define (time-type tim)
    488   (check-time 'time-type tim)
    489   (*time-type tim) )
    490 
    491 (define (time-nanosecond tim)
    492   (check-time 'time-nanosecond tim)
    493   (*time-nanosecond tim) )
    494 
    495 (define (time-second tim)
    496   (check-time 'time-second tim)
    497   (*time-second tim) )
    498 
    499 (define (time-type-set! tim tt)
    500   (check-time 'time-type-set! tim)
    501   (check-time-type 'time-type-set! tt)
    502   (*time-type-set! tim tt) )
    503 
    504 (define (time-nanosecond-set! tim ns)
    505   (check-time 'time-nanosecond-set! tim)
    506   (check-time-nanoseconds 'time-nanosecond-set! ns)
    507   (tm:time-nanosecond-set! tim ns) )
    508 
    509 (define (time-second-set! tim sec)
    510   (check-time 'time-second-set! tim)
    511   (check-time-seconds 'time-second-set! sec)
    512   (tm:time-second-set! tim sec) )
    513 
    514 ;; Seconds Conversion
    515 
    516 (define (time->nanoseconds tim)
    517   (check-time 'time->nanoseconds tim)
    518   (+ (*time-nanosecond tim) (* (*time-second tim) NS/S)) )
    519 
    520 (define (nanoseconds->time ns . args)
    521   (let-optionals args ((tt 'time-duration))
    522     (receive (ns sec) (tm:split-nanoseconds ns)
    523       (check-time-elements 'nanoseconds->time tt ns sec)
    524       (tm:make-time tt ns sec) ) ) )
    525 
    526 (define (nanoseconds->seconds ns) (/ ns NS/S))
    527 
    528 (define (time->milliseconds tim)
    529   (check-time 'time->milliseconds tim)
    530   (+ (/ (*time-nanosecond tim) NS/MS) (* (*time-second tim) MS/S)) )
    531 
    532 (define (milliseconds->time ms . args)
    533   (let-optionals args ((tt 'time-duration))
    534     (let ((ns (fx* (remainder ms MS/S) NS/MS))
    535           (sec (quotient ms MS/S)) )
    536       (check-time-elements 'milliseconds->time tt ns sec)
    537       (tm:make-time tt ns sec) ) ) )
    538 
    539 (define (milliseconds->seconds ms) (/ (exact->inexact ms) MS/S))
    540 
    541 ;; Current time routines
    542 
    543 ; Throw away everything but the sub-second bit.
    544 ; Chicken 'current-milliseconds' within positive fixnum range
    545 (define (tm:current-sub-milliseconds) (fxmod (current-milliseconds) MS/S))
    546 
    547 (define (tm:current-nanoseconds) (* (tm:current-sub-milliseconds) NS/MS))
    548 
    549 ;Use the 'official' seconds & nanoseconds values
    550 (define (tm:current-time-values) (values (tm:current-nanoseconds) (current-seconds)))
    551 
    552 (define (tm:current-time-utc)
    553   (receive (ns sec) (tm:current-time-values)
    554     (tm:make-time 'time-utc ns sec)) )
    555 
    556 (define (tm:current-time-tai)
    557   (receive (ns sec) (tm:current-time-values)
    558     (tm:make-time 'time-tai ns (+ sec (leap-second-delta sec))) ) )
    559 
    560 (define (tm:current-time-monotonic)
    561   (let ((tim (tm:current-time-tai)))
    562     (*time-type-set! tim 'time-monotonic)
    563     tim ) )
    564 
    565 (define (tm:current-time-thread)
    566   (milliseconds->time (current-thread-milliseconds) 'time-thread) )
    567 
    568 (define (tm:current-time-process)
    569   (milliseconds->time (current-process-milliseconds) 'time-process) )
    570 
    571 (define (tm:current-time-gc)
    572   (milliseconds->time (total-gc-milliseconds) 'time-gc) )
    573 
    574 ;;
    575 
    576 (define (current-time . args)
    577   (let-optionals args ((tt 'time-utc))
    578     (check-time-type 'current-time tt)
    579     (case tt
    580       ((time-monotonic) (tm:current-time-monotonic))
    581       ((time-utc)       (tm:current-time-utc))
    582       ((time-tai)       (tm:current-time-tai))
    583       ((time-gc)        (tm:current-time-gc))
    584       ((time-process)   (tm:current-time-process))
    585       ((time-thread)    (tm:current-time-thread))) ) )
    586 
    587 ;; SRFI-18 Routines
    588 
    589 (define (srfi-18-time->time srfi-18-tim)
    590   (seconds->time/type (srfi-18:time->seconds srfi-18-tim) 'time-duration) )
    591 
    592 (define (time->srfi-18-time tim)
    593   (check-time 'time->srfi-18-time tim)
    594   (srfi-18:seconds->time (nanoseconds->seconds (time->nanoseconds tim))) )
    595 
    596 ;; -- Time Resolution
    597 ;; This is the resolution of the clock in nanoseconds.
    598 ;; This will be implementation specific.
    599 
    600 (define (time-resolution . args)
    601   (let-optionals args ((tt 'time-utc))
    602     (check-time-type 'time-resolution tt)
    603     NS/MS ) )
    604608
    605609;; Time Comparison
     
    634638           (fx>= (*time-nanosecond tim1) (*time-nanosecond tim2)))) )
    635639
    636 (define (tm:time-max tim . rest)
    637   (let loop ((acc tim) (ls rest))
    638     (if (null? ls) acc
    639         (let ((tim (car ls)))
    640           (loop (if (tm:time<? acc tim) tim acc) (cdr ls)))) ) )
    641 
    642 (define (tm:time-min tim . rest)
    643   (let loop ((acc tim) (ls rest))
    644     (if (null? ls) acc
    645         (let ((tim (car ls)))
    646           (loop (if (tm:time>? acc tim) tim acc) (cdr ls)))) ) )
    647 
    648 (define (time-compare tim1 tim2)
    649   (tm:time-compare-check 'time-compare tim1 tim2)
    650   (let ((dif (tm:time-compare tim1 tim2)))
    651     (cond ((negative? dif)  -1)
    652           ((positive? dif)  1)
    653           (else             0) ) ) )
    654 
    655 (define (time=? tim1 tim2)
    656   (tm:time-compare-check 'time=? tim1 tim2)
    657   (tm:time=? tim1 tim2) )
    658 
    659 (define (time>? tim1 tim2)
    660   (tm:time-compare-check 'time>? tim1 tim2)
    661   (tm:time>? tim1 tim2) )
    662 
    663 (define (time<? tim1 tim2)
    664   (tm:time-compare-check 'time<? tim1 tim2)
    665   (tm:time<? tim1 tim2) )
    666 
    667 (define (time>=? tim1 tim2)
    668   (tm:time-compare-check 'time>=? tim1 tim2)
    669   (tm:time>=? tim1 tim2) )
    670 
    671 (define (time<=? tim1 tim2)
    672   (tm:time-compare-check 'time<=? tim1 tim2)
    673   (tm:time<=? tim1 tim2) )
    674 
    675 (define (time-max tim1 . rest)
    676   (check-times 'time-max (cons tim1 rest))
    677   (apply tm:time-max tim1 rest) )
    678 
    679 (define (time-min tim1 . rest)
    680   (check-times 'time-min (cons tim1 rest))
    681   (apply tm:time-min tim1 rest) )
     640#; ;UNUSED
     641(define (tm:time-max acc ls)
     642  (if (null? ls) acc
     643      (let ((tim (car ls)))
     644        (tm:time-max (if (tm:time<? acc tim) tim acc) (cdr ls)))) )
     645
     646#; ;UNUSED
     647(define (tm:time-min acc ls)
     648  (if (null? ls) acc
     649      (let ((tim (car ls)))
     650        (tm:time-min (if (tm:time>? acc tim) tim acc) (cdr ls)))) )
    682651
    683652;; Time Arithmetic
    684653
    685 (define (tm:time-difference tim1 tim2 tim3)
    686   (*time-type-set! tim3 'time-duration)
     654(define (tm:time-difference tim1 tim2 timout)
    687655  (cond ((tm:time=? tim1 tim2)
    688          (tm:time-second-set! tim3 0)
    689          (tm:time-nanosecond-set! tim3 0) )
     656         (tm:time-second-set! timout 0)
     657         (tm:time-nanosecond-set! timout 0) )
    690658        (else
    691659         (receive (ns sec)
    692              (tm:split-nanoseconds (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
    693            (tm:time-second-set! tim3 sec)
    694            (tm:time-nanosecond-set! tim3 ns) ) ) )
    695   tim3 )
    696 
    697 (define (tm:add-duration tim1 dur tim3)
     660             (tm:nanoseconds->time-values (- (tm:time->nanoseconds tim1)
     661                                             (tm:time->nanoseconds tim2)))
     662           (tm:time-second-set! timout sec)
     663           (tm:time-nanosecond-set! timout ns) ) ) )
     664  timout )
     665
     666(define (tm:add-duration tim1 dur timout)
    698667  (let ((sec-plus (+ (*time-second tim1) (*time-second dur)))
    699         (nsec-plus (+ (*time-nanosecond tim1) (*time-nanosecond dur))))
    700     (tm:time-second-set! tim3 (+ sec-plus (quotient nsec-plus NS/S)))
    701     (tm:time-nanosecond-set! tim3 (remainder nsec-plus NS/S))
    702     tim3 ) )
    703 
    704 (define (tm:subtract-duration tim1 dur tim3)
     668        (nsec-plus (+ (*time-nanosecond tim1) (*time-nanosecond dur))) )
     669    (let ((rem (remainder nsec-plus NS/S))
     670          (secs (+ sec-plus (quotient nsec-plus NS/S))) )
     671      (cond ((negative? rem)
     672              (tm:time-second-set! timout (+ secs -1))
     673              (tm:time-nanosecond-set! timout (+ rem NS/S)) )
     674            (else
     675              (tm:time-second-set! timout secs)
     676              (tm:time-nanosecond-set! timout rem) ) )
     677      timout ) ) )
     678
     679(define (tm:subtract-duration tim1 dur timout)
    705680  (let ((sec-minus (- (*time-second tim1) (*time-second dur)))
    706         (nsec-minus (fx- (*time-nanosecond tim1) (*time-nanosecond dur))))
    707     (let ((r (fxmod nsec-minus NS/S))
    708           (secs (- sec-minus (fx/ nsec-minus NS/S))))
    709       (cond ((fx< r 0)
    710              (tm:time-second-set! tim3 (- secs 1))
    711              (tm:time-nanosecond-set! tim3 (fx+ NS/S r)) )
     681        (nsec-minus (- (*time-nanosecond tim1) (*time-nanosecond dur))) )
     682    (let ((rem (remainder nsec-minus NS/S))
     683          (secs (- sec-minus (quotient nsec-minus NS/S))) )
     684      (cond ((negative? rem)
     685              (tm:time-second-set! timout (- secs 1))
     686              (tm:time-nanosecond-set! timout (+ rem NS/S)) )
    712687            (else
    713              (tm:time-second-set! tim3 secs)
    714              (tm:time-nanosecond-set! tim3 r) ) )
    715       tim3 ) ) )
    716 
    717 (define (tm:divide-duration dur1 num dur3)
     688              (tm:time-second-set! timout secs)
     689              (tm:time-nanosecond-set! timout rem) ) )
     690      timout ) ) )
     691
     692(define (tm:divide-duration dur1 num durout)
    718693  (receive (ns sec)
    719       (tm:split-nanoseconds (/ (time->nanoseconds dur1) num))
    720     (tm:time-nanosecond-set! dur3 ns)
    721     (tm:time-second-set! dur3 sec)
    722     dur3 ) )
    723 
    724 (define (tm:multiply-duration dur1 num dur3)
     694      (tm:nanoseconds->time-values (/ (tm:time->nanoseconds dur1) num))
     695    (tm:time-nanosecond-set! durout ns)
     696    (tm:time-second-set! durout sec)
     697    durout ) )
     698
     699(define (tm:multiply-duration dur1 num durout)
    725700  (receive (ns sec)
    726       (tm:split-nanoseconds (* (time->nanoseconds dur1) num))
    727     (tm:time-nanosecond-set! dur3 ns)
    728     (tm:time-second-set! dur3 sec)
    729     dur3 ) )
    730 
    731 (define (tm:time-abs tim1 tim3)
    732   (tm:time-second-set! tim3 (abs (*time-second tim1)))
    733   tim3 )
    734 
    735 (define (tm:time-negate tim1 tim3)
    736   (tm:time-second-set! tim3 (- (*time-second tim1)))
    737   tim3 )
    738 
    739 ;;
    740 
    741 (define (time-difference tim1 tim2)
    742   (tm:time-compare-check 'time-difference tim1 tim2)
    743   (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) )
    744 
    745 (define (time-difference! tim1 tim2)
    746   (tm:time-compare-check 'time-difference! tim1 tim2)
    747   (tm:time-difference tim1 tim2 tim1) )
    748 
    749 (define (add-duration tim dur)
    750   (tm:time-aritmetic-check 'add-duration tim dur)
    751   (tm:add-duration tim dur (tm:as-empty-time tim)) )
    752 
    753 (define (add-duration! tim dur)
    754   (tm:time-aritmetic-check 'add-duration! tim dur)
    755   (tm:add-duration tim dur tim) )
    756 
    757 (define (subtract-duration tim dur)
    758   (tm:time-aritmetic-check 'subtract-duration tim dur)
    759   (tm:subtract-duration tim dur (tm:as-empty-time tim)) )
    760 
    761 (define (subtract-duration! tim dur)
    762   (tm:time-aritmetic-check 'subtract-duration! tim dur)
    763   (tm:subtract-duration tim dur tim) )
    764 
    765 (define (divide-duration dur num)
    766   (check-duration 'divide-duration dur)
    767   (tm:divide-duration dur num (tm:as-empty-time dur)) )
    768 
    769 (define (divide-duration! dur num)
    770   (check-duration 'divide-duration! dur)
    771   (tm:divide-duration dur num dur) )
    772 
    773 (define (multiply-duration dur num)
    774   (check-duration 'multiply-duration dur)
    775   (tm:multiply-duration dur num (tm:as-empty-time dur)) )
    776 
    777 (define (multiply-duration! dur num)
    778   (check-duration 'multiply-duration! dur)
    779   (tm:multiply-duration dur num dur) )
    780 
    781 (define (time-negative? tim)
    782   (check-time 'time-negative? tim)
    783   (negative? (*time-second tim)) )
    784 
    785 (define (time-positive? tim)
    786   (check-time 'time-positive? tim)
    787   (positive? (*time-second tim)) )
    788 
    789 (define (time-zero? tim)
    790   (check-time 'time-zero? tim)
    791   (and (zero? (*time-nanosecond tim))
    792        (zero? (*time-second tim))) )
    793 
    794 (define (time-abs tim)
    795   (check-time 'time-abs tim)
    796   (tm:time-abs tim (tm:as-empty-time tim)) )
    797 
    798 (define (time-abs! tim)
    799   (check-time 'time-abs! tim)
    800   (tm:time-abs tim tim) )
    801 
    802 (define (time-negate tim)
    803   (check-time 'time-negate tim)
    804   (tm:time-negate tim (tm:as-empty-time tim)) )
    805 
    806 (define (time-negate! tim)
    807   (check-time 'time-negate! tim)
    808   (tm:time-negate tim tim) )
     701      (tm:nanoseconds->time-values (* (tm:time->nanoseconds dur1) num))
     702    (tm:time-nanosecond-set! durout ns)
     703    (tm:time-second-set! durout sec)
     704    durout ) )
     705
     706(define (tm:time-abs tim1 timout)
     707  (tm:time-second-set! timout (abs (*time-second tim1)))
     708  timout )
     709
     710(define (tm:time-negate tim1 timout)
     711  (tm:time-second-set! timout (- (*time-second tim1)))
     712  timout )
    809713
    810714;; Time Type Converters
    811715
    812 (define (tm:time-tai->time-utc tim-in tim-out)
    813   (*time-type-set! tim-out 'time-utc)
    814   (tm:time-nanosecond-set! tim-out (*time-nanosecond tim-in))
    815   (tm:time-second-set! tim-out
    816    (- (*time-second tim-in) (leap-second-neg-delta (*time-second tim-in))))
    817   tim-out )
    818 
    819 (define (tm:time-utc->time-tai tim-in tim-out)
    820   (*time-type-set! tim-out 'time-tai)
    821   (tm:time-nanosecond-set! tim-out (*time-nanosecond tim-in))
    822   (tm:time-second-set! tim-out
    823    (+ (*time-second tim-in) (leap-second-delta (*time-second tim-in))))
    824   tim-out )
    825 
    826 (define (tm:time-monotonic->time-tai tim-in tim-out)
    827   (*time-type-set! tim-out 'time-tai)
    828   (unless (eq? tim-in tim-out)
    829     (tm:time-nanosecond-set! tim-out (*time-nanosecond tim-in))
    830     (tm:time-second-set! tim-out (*time-second tim-in)))
    831   tim-out )
    832 
    833 (define (tm:time-tai->time-monotonic tim-in tim-out)
    834   (*time-type-set! tim-out 'time-monotonic)
    835   (unless (eq? tim-in tim-out)
    836     (tm:time-nanosecond-set! tim-out (*time-nanosecond tim-in))
    837     (tm:time-second-set! tim-out (*time-second tim-in)))
    838   tim-out )
    839 
    840 (define (tm:time-monotonic->time-utc tim-in tim-out)
    841   (*time-type-set! tim-in 'time-tai) ; fool converter (unnecessary)
    842   (tm:time-tai->time-utc tim-in tim-out) )
    843 
    844 (define (tm:time-utc->time-monotonic tim-in tim-out)
    845   (let ((ntim (tm:time-utc->time-tai tim-in tim-out)))
    846     (*time-type-set! ntim 'time-monotonic)
     716(define (tm:time-tai->time-utc timin timout)
     717  (*time-type-set! timout 'utc)
     718  (tm:time-nanosecond-set! timout (*time-nanosecond timin))
     719  (tm:time-second-set! timout
     720                       (- (*time-second timin)
     721                          (leap-second-neg-delta (*time-second timin))))
     722  timout )
     723
     724(define (tm:time-tai->time-monotonic timin timout)
     725  (*time-type-set! timout 'monotonic)
     726  (unless (eq? timin timout)
     727    (tm:time-nanosecond-set! timout (*time-nanosecond timin))
     728    (tm:time-second-set! timout (*time-second timin)))
     729  timout )
     730
     731(define (tm:time-utc->time-tai timin timout)
     732  (*time-type-set! timout 'tai)
     733  (tm:time-nanosecond-set! timout (*time-nanosecond timin))
     734  (tm:time-second-set! timout
     735                       (+ (*time-second timin)
     736                          (leap-second-delta (*time-second timin))))
     737  timout )
     738
     739(define (tm:time-utc->time-monotonic timin timout)
     740  (let ((ntim (tm:time-utc->time-tai timin timout)))
     741    (*time-type-set! ntim 'monotonic)
    847742    ntim ) )
    848743
    849 ;; Time Type Conversion
    850 
    851 (define (time-tai->time-utc tim)
    852   (check-time-and-type 'time-tai->time-utc tim 'time-tai)
    853   (tm:time-tai->time-utc tim (tm:as-empty-time tim)) )
    854 
    855 (define (time-tai->time-utc! tim)
    856   (check-time-and-type 'time-tai->time-utc! tim 'time-tai)
    857   (tm:time-tai->time-utc tim tim) )
    858 
    859 (define (time-tai->time-monotonic tim)
    860   (check-time-and-type 'time-tai->time-monotonic tim 'time-tai)
    861   (tm:time-tai->time-monotonic tim (tm:as-empty-time tim)) )
    862 
    863 (define (time-tai->time-monotonic! tim)
    864   (check-time-and-type 'time-tai->time-monotonic! tim 'time-tai)
    865   (tm:time-tai->time-monotonic tim tim) )
    866 
    867 (define (time-utc->time-tai tim)
    868   (check-time-and-type 'time-utc->time-tai tim 'time-utc)
    869   (tm:time-utc->time-tai tim (tm:as-empty-time tim)) )
    870 
    871 (define (time-utc->time-tai! tim)
    872   (check-time-and-type 'time-utc->time-tai! tim 'time-utc)
    873   (tm:time-utc->time-tai tim tim) )
    874 
    875 (define (time-utc->time-monotonic tim)
    876   (check-time-and-type 'time-utc->time-monotonic tim 'time-utc)
    877   (tm:time-utc->time-monotonic tim (tm:as-empty-time tim)) )
    878 
    879 (define (time-utc->time-monotonic! tim)
    880   (check-time-and-type 'time-utc->time-monotonic! tim 'time-utc)
    881   (tm:time-utc->time-monotonic tim tim) )
    882 
    883 (define (time-monotonic->time-utc tim)
    884   (check-time-and-type 'time-monotoinc->time-utc tim 'time-monotonic)
    885   (let ((ntim (copy-time tim)))
    886     (tm:time-monotonic->time-utc ntim ntim) ) )
    887 
    888 (define (time-monotonic->time-utc! tim)
    889   (check-time-and-type 'time-monotoinc->time-utc! tim 'time-monotonic)
    890   (tm:time-monotonic->time-utc tim tim) )
    891 
    892 (define (time-monotonic->time-tai tim)
    893   (check-time-and-type 'time-monotoinc->time-tai tim 'time-monotonic)
    894   (tm:time-monotonic->time-tai tim (tm:as-empty-time tim)) )
    895 
    896 (define (time-monotonic->time-tai! tim)
    897   (check-time-and-type 'time-monotoinc->time-tai! tim 'time-monotonic)
    898   (tm:time-monotonic->time-tai tim tim) )
    899 
    900 
    901 ;;; Timezone Locale Object (Public Immutable, but not enforced)
    902 
    903 (define-inline (make-utc-timezone)
    904   (let ((tz (make-timezone-components "UTC0" builtin-source-name)))
    905     (update-timezone-components! tz 'std-name "UTC" 'std-offset 0) ) )
    906 
    907 (define-inline (timezone-components-ref/dst? tzc a b)
    908   (timezone-component-ref tzc (if (timezone-component-ref tzc 'dst?) a b)) )
    909 
    910 ;;
    911 
    912 (define-parameter local-timezone-locale (current-timezone-components)
    913   (lambda (obj)
    914     (cond ((timezone-components? obj) obj)
    915           (else
    916            (warning-argument-type 'local-timezone-locale obj 'timezone-components)
    917            (local-timezone-locale) ) ) ) )
    918 
    919 (define-parameter utc-timezone-locale (make-utc-timezone)
    920   (lambda (obj)
    921     (cond ((timezone-components? obj) obj)
    922           (else
    923            (warning-argument-type 'utc-timezone-locale obj 'timezone-components)
    924            (utc-timezone-locale) ) ) ) )
    925 
    926 ;;
    927 
    928 (define (timezone-locale-name . tzc)
    929   (let ((tzc (optional tzc (local-timezone-locale))))
    930     (check-timezone-components 'timezone-locale-name tzc)
    931     (let ((tzn (timezone-components-ref/dst? tzc 'dst-name 'std-name)))
    932       ; TZ may not be set
    933       (and (not (unknown-timezone-name? tzn))
    934            tzn ) ) ) )
    935 
    936 (define (timezone-locale-offset . tzc)
    937   (let ((tzc (optional tzc (local-timezone-locale))))
    938     (check-timezone-components 'timezone-locale-offset tzc)
    939     (let ((tzo (timezone-components-ref/dst? tzc 'dst-offset 'std-offset)))
    940       ; TZ may not be set but if it is then convert to ISO 8601
    941       (if tzo (fxneg tzo)
    942           0 ) ) ) )
    943 
    944 (define (timezone-locale-dst? . tzc)
    945   (let ((tzc (optional tzc (local-timezone-locale))))
    946     (check-timezone-components 'timezone-locale-offset tzc)
    947     (timezone-component-ref tzc 'dst?) ) )
     744(define (tm:time-monotonic->time-tai timin timout)
     745  (*time-type-set! timout 'tai)
     746  (unless (eq? timin timout)
     747    (tm:time-nanosecond-set! timout (*time-nanosecond timin))
     748    (tm:time-second-set! timout (*time-second timin)))
     749  timout )
     750
     751(define (tm:time-monotonic->time-utc timin timout)
     752  #;(*time-type-set! timin 'tai) ; fool converter (unnecessary)
     753  (tm:time-tai->time-utc timin timout) )
    948754
    949755
    950756;;; Date Object (Public Immutable)
     757
     758;;
     759
     760(define (clock-type? obj) (memq? obj '(monotonic tai utc)))
    951761
    952762;; Leap Year Test
     
    965775;; Days per Month
    966776
    967 (define tm:dys/mn '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
    968 
    969 (define tm:leap-year-dys/mn '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
    970 
    971 (define (tm:days-in-month mn yr)
    972   (vector-ref (if (tm:leap-year? yr) tm:leap-year-dys/mn tm:dys/mn) mn) )
    973 
    974 (define tm:cumulative-month-days '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
     777(define +year-dys/mn+      '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
     778(define +leap-year-dys/mn+ '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
     779
     780(define (tm:days-in-month yr mn)
     781  (vector-ref (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+) mn) )
    975782
    976783;;
     
    996803;;
    997804
     805(define-record-printer (date dat out)
     806  (format out
     807   "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
     808   (*date-nanosecond dat)
     809   (*date-second dat) (*date-minute dat) (*date-hour dat)
     810   (*date-day dat) (*date-month dat) (*date-year dat)
     811   (*date-zone-offset dat)
     812   (*date-zone-name dat) (*date-dst? dat)
     813   (*date-wday dat) (*date-yday dat) (*date-jday dat)) )
     814
     815(define-reader-ctor 'date *make-date)
     816
     817; Nanoseconds in [0 NS/S-1]
     818(define (date-nanoseconds? obj) (and (fixnum? obj) (fx<= 0 obj) (fx< obj NS/S)))
     819
     820; Seconds in [0 SEC/MIN] ; SEC/MIN legal due to leap second
     821(define (date-seconds? obj) (and (fixnum? obj) (fx<= 0 obj) (fx<= obj SEC/MIN)))
     822
     823; Minutes in [0 SEC/MIN-1]
     824(define (date-minutes? obj) (and (fixnum? obj) (and (fx<= 0 obj) (fx< obj SEC/MIN))))
     825
     826; Hours in [0 HR/DY-1]
     827(define (date-hours? obj) (and (fixnum? obj) (and (fx<= 0 obj) (fx< obj HR/DY))))
     828
     829; Days in [1 28/29/30/31] - depending on month & year
     830(define (date-day? obj mn yr) (and (fixnum? obj) (fx<= 1 obj) (fx<= obj (tm:days-in-month yr mn))))
     831
     832; Months in [1 MN/YR]
     833(define (date-month? obj) (and (fixnum? obj) (fx<= 1 obj) (fx<= obj MN/YR)))
     834
     835; No year 0!
     836(define (date-year? obj) (and (fixnum? obj) (not (fx= 0 obj))))
     837
     838(define (timezone-name? obj) (or (not obj) (string? obj)))
     839
     840(define (timezone-info? obj)
     841  (or (timezone-components? obj)
     842      (timezone-offset? obj) ) )
     843
     844;;
     845
     846(define-check+error-type date-nanoseconds)
     847(define-check+error-type date-seconds)
     848(define-check+error-type date-minutes)
     849(define-check+error-type date-hours)
     850(define-check+error-type date-day)
     851(define-check+error-type date-month)
     852(define-check+error-type date-year)
     853
     854(define-check+error-type timezone-name)
     855(define-check+error-type timezone-info)
     856
     857(define (check-date-elements loc ns sec min hr dy mn yr tzo tzn)
     858  (check-date-nanoseconds loc ns)
     859  (check-date-seconds loc sec)
     860  (check-date-minutes loc sec)
     861  (check-date-hours loc sec)
     862  (check-date-year loc yr)
     863  (check-date-month loc mn)
     864  (check-date-day loc dy mn yr)
     865  (check-timezone-offset loc tzo "date-timezone-offset")
     866  (check-timezone-name loc tzn "date-timezone-name") )
     867
     868;;
     869
     870(define-check+error-type clock-type)
     871(define-check+error-type date)
     872
     873;;
     874
    998875(define tm:date-nanosecond *date-nanosecond)
    999876(define tm:date-second *date-second)
     
    1010887(define tm:date-jday *date-jday)
    1011888
    1012 ; Same as time
    1013 (define (date-nanoseconds? obj) (time-nanoseconds? obj))
    1014 ; Seconds in [0 60] ; 60 legal due to leap second
    1015 (define (date-seconds? obj) (and (fixnum? obj) (fx<= 0 obj) (fx<= obj 60)))
    1016 ; Minutes in [0 59]
    1017 (define (date-minutes? obj) (and (fixnum? obj) (and (fx<= 0 obj) (fx< obj 60))))
    1018 ; Hours in [0 23]
    1019 (define (date-hours? obj) (and (fixnum? obj) (and (<= 0 obj) (< obj 24))))
    1020 ; Days in [1 28/29/30/31] - depending on month & year
    1021 (define (date-day? obj mn yr) (and (fixnum? obj) (fx<= 1 obj) (fx<= obj (tm:days-in-month mn yr))))
    1022 ; Months in [1 12]
    1023 (define (date-month? obj) (and (fixnum? obj) (fx<= 1 obj) (fx<= obj 12)))
    1024 ; No year 0!
    1025 (define (date-year? obj) (and (fixnum? obj) (not (fx= 0 obj))))
    1026 
    1027 (define-check+error-type date)
    1028 (define-check+error-type date-nanoseconds)
    1029 (define-check+error-type date-seconds)
    1030 (define-check+error-type date-minutes)
    1031 (define-check+error-type date-hours)
    1032 (define-check+error-type date-day)
    1033 (define-check+error-type date-month)
    1034 (define-check+error-type date-year)
    1035 
    1036 (define (timezone-name? obj) (or (not obj) (string? obj)))
    1037 (define-check+error-type timezone-name)
    1038 
    1039 (define (check-exploded-date loc ns sec min hr dy mn yr tzo tzn)
    1040   (check-date-nanoseconds loc ns)
    1041   (check-date-seconds loc sec)
    1042   (check-date-minutes loc sec)
    1043   (check-date-hours loc sec)
    1044   (check-date-year loc yr)
    1045   (check-date-month loc mn)
    1046   (check-date-day loc dy mn yr)
    1047   (check-timezone-offset loc tzo "date-timezone-offset")
    1048   (check-timezone-name loc tzn "date-timezone-name") )
    1049 
    1050 ;;
    1051 
    1052 (define (tm:date-nanosecond-set! dat x) (*date-nanosecond-set! dat (number->maybe-fixnum x)))
    1053 (define (tm:date-second-set! dat x) (*date-second-set! dat (number->maybe-fixnum x)))
    1054 (define (tm:date-minute-set! dat x) (*date-minute-set! dat (number->maybe-fixnum x)))
    1055 (define (tm:date-hour-set! dat x) (*date-hour-set! dat (number->maybe-fixnum x)))
    1056 (define (tm:date-day-set! dat x) (*date-day-set! dat (number->maybe-fixnum x)))
    1057 (define (tm:date-month-set! dat x) (*date-month-set! dat (number->maybe-fixnum x)))
    1058 (define (tm:date-year-set! dat x) (*date-year-set! dat (number->maybe-fixnum x)))
    1059 (define (tm:date-zone-offset-set! dat x) (*date-zone-offset-set! dat (number->maybe-fixnum x)))
     889(define (tm:date-nanosecond-set! dat x) (*date-nanosecond-set! dat (gennum->?fixnum x)))
     890(define (tm:date-second-set! dat x) (*date-second-set! dat (gennum->?fixnum x)))
     891(define (tm:date-minute-set! dat x) (*date-minute-set! dat (gennum->?fixnum x)))
     892(define (tm:date-hour-set! dat x) (*date-hour-set! dat (gennum->?fixnum x)))
     893(define (tm:date-day-set! dat x) (*date-day-set! dat (gennum->?fixnum x)))
     894(define (tm:date-month-set! dat x) (*date-month-set! dat (gennum->?fixnum x)))
     895(define (tm:date-year-set! dat x) (*date-year-set! dat (gennum->?fixnum x)))
     896(define (tm:date-zone-offset-set! dat x) (*date-zone-offset-set! dat (gennum->?fixnum x)))
    1060897
    1061898;; Returns an invalid date record (for use by 'scan-date')
     
    1073910(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    1074911  (*make-date
    1075    (number->maybe-fixnum ns)
    1076    (number->maybe-fixnum sec) (number->maybe-fixnum min) (number->maybe-fixnum hr)
    1077    (number->maybe-fixnum dy) (number->maybe-fixnum mn) (number->maybe-fixnum yr)
    1078    (number->maybe-fixnum tzo) tzn dstf
     912   (gennum->?fixnum ns)
     913   (gennum->?fixnum sec) (gennum->?fixnum min) (gennum->?fixnum hr)
     914   (gennum->?fixnum dy) (gennum->?fixnum mn) (gennum->?fixnum yr)
     915   (gennum->?fixnum tzo) tzn dstf
    1079916   wdy ydy jdy) )
    1080917
    1081 ;; Parameter Checking
    1082 ;; Date Syntax
    1083 
    1084 (define-record-printer (date dat out)
    1085   (format out
    1086    "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
    1087    (*date-nanosecond dat)
    1088    (*date-second dat) (*date-minute dat) (*date-hour dat)
    1089    (*date-day dat) (*date-month dat) (*date-year dat)
    1090    (*date-zone-offset dat)
    1091    (*date-zone-name dat) (*date-dst? dat)
    1092    (*date-wday dat) (*date-yday dat) (*date-jday dat)) )
    1093 
    1094 (define-reader-ctor 'date
    1095   (lambda (ns sec min hr dy mn yr tzo . rest)
    1096     (let-optionals rest ((tzn #f) (dstf #f) (wdy #f) (ydy #f) (jdy #f))
    1097       (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy))))
    1098 
    1099 ;; Date CTOR
    1100 
    1101 (define (make-date ns sec min hr dy mn yr tzo . args)
    1102   (let-optionals args ((tzn #f) (dstf (void)))
    1103     (cond ((timezone-components? tzo)
    1104            ; Supplied parameters override
    1105            (set! dstf (if (eq? (void) dstf) (timezone-locale-dst? tzo) dstf))
    1106            (set! tzn (or tzn (timezone-locale-name tzo)))
    1107            (set! tzo (timezone-locale-offset tzo)) )
    1108           (else
    1109            (when (eq? (void) dstf) (set! dstf #f)) ) )
    1110     (check-exploded-date 'make-date ns sec min hr dy mn yr tzo tzn)
    1111     (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
    1112 
    1113 (define (copy-date dat)
     918(define (tm:copy-date dat)
    1114919  (*make-date
    1115920   (*date-nanosecond dat)
     
    1120925   (*date-wday dat) (*date-yday dat) (*date-jday dat)) )
    1121926
    1122 ;; Converts a seconds value, may be fractional, into a date type.
    1123 ;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
    1124 ;; A local (#t), utc (#f), or other (timezone-components) date depending on
    1125 ;; the optional 2nd argument. The default is #f.
    1126 
    1127 (define (seconds->date/type sec . tzc)
    1128   (unless (real? sec)
    1129     (error-time-seconds 'seconds->date/type sec) )
    1130   (let ((tzc (optional tzc #f)))
    1131     (if (boolean? tzc)
    1132         (set! tzc ((if tzc local-timezone-locale utc-timezone-locale)))
    1133         (check-timezone-components 'seconds->date/type tzc) )
    1134     (let* ((fsec (exact->inexact sec))
    1135            (isec (truncate fsec))
    1136            (tzo (timezone-locale-offset tzc))
    1137            (tv (seconds->utc-time (+ isec tzo))))
    1138       (tm:make-date
    1139        (round (* (- fsec isec) NS/S))
    1140        (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
    1141        (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
    1142        tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
    1143        (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) ) )
    1144 
    1145 (define (current-date . tzc) (apply time-utc->date (tm:current-time-utc) tzc))
    1146 
    1147 ;;
    1148 
    1149 (define (date-nanosecond dat)
    1150         (check-date 'date-nanosecond dat)
    1151         (tm:date-nanosecond dat) )
    1152 
    1153 (define (date-second dat)
    1154         (check-date 'date-second dat)
    1155         (tm:date-second dat) )
    1156 
    1157 (define (date-minute dat)
    1158         (check-date 'date-minute dat)
    1159         (tm:date-minute dat) )
    1160 
    1161 (define (date-hour dat)
    1162         (check-date 'date-hour dat)
    1163         (tm:date-hour dat) )
    1164 
    1165 (define (date-day dat)
    1166         (check-date 'date-day dat)
    1167         (tm:date-day dat) )
    1168 
    1169 (define (date-month dat)
    1170         (check-date 'date-month dat)
    1171         (tm:date-month dat) )
    1172 
    1173 (define (date-year dat)
    1174         (check-date 'date-year dat)
    1175         (tm:date-year dat) )
    1176 
    1177 (define (date-dst? dat)
    1178         (check-date 'date-dst? dat)
    1179         (tm:date-dst? dat) )
    1180 
    1181 (define (date-zone-offset dat)
    1182         (check-date 'date-zone-offset dat)
    1183         (tm:date-zone-offset dat) )
    1184 
    1185 (define (date-zone-name dat)
    1186         (check-date 'date-zone-name dat)
    1187         (tm:date-zone-name dat) )
     927(define (tm:seconds->date/type sec tzc)
     928  (let* ((fsec (exact->inexact sec))
     929         (isec (truncate fsec))
     930         (tzo (timezone-locale-offset tzc))
     931         (tv (seconds->utc-time (+ isec tzo))))
     932    (tm:make-date
     933     (round (* (- fsec isec) NS/S))
     934     (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
     935     (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
     936     tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
     937     (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) )
    1188938
    1189939;; Date Comparison
    1190940
    1191 (define (error-compare-dates-w-diff-tz loc dat1 dat2)
    1192   (signal-type-error loc "cannot compare dates from different timezones" dat1 dat2) )
    1193 
    1194 (define (tm:date-compare loc dat1 dat2)
    1195   (check-date loc dat1)
    1196   (check-date loc dat2)
    1197   (if (not (fx= (*date-zone-offset dat1) (*date-zone-offset dat2)))
    1198       (error-compare-dates-w-diff-tz loc dat1 dat2)
    1199       (let ((dif (fx- (*date-year dat1) (*date-year dat2))))
    1200         (if (not (fx= 0 dif)) dif
    1201             (let ((dif (fx- (*date-month dat1) (*date-month dat2))))
    1202               (if (not (fx= 0 dif)) dif
    1203                   (let ((dif (fx- (*date-day dat1) (*date-day dat2))))
    1204                     (if (not (fx= 0 dif)) dif
    1205                         (let ((dif (fx- (*date-hour dat1) (*date-hour dat2))))
    1206                           (if (not (fx= 0 dif)) dif
    1207                               (let ((dif (fx- (*date-minute dat1) (*date-minute dat2))))
    1208                                 (if (not (fx= 0 dif)) dif
    1209                                     (let ((dif (fx- (*date-second dat1) (*date-second dat2))))
    1210                                       (if (not (fx= 0 dif)) dif
    1211                                           (fx- (*date-nanosecond dat1) (*date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
    1212 
    1213 (define (date-compare dat1 dat2)
    1214   (let ((dif (tm:date-compare 'date-compare dat1 dat2)))
    1215     (cond ((fx> 0 dif)  -1)
    1216           ((fx< 0 dif)  1)
    1217           (else         0) ) ) )
    1218 
    1219 (define (date=? dat1 dat2)
    1220   (fx= 0 (tm:date-compare 'date=? dat1 dat2)) )
    1221 
    1222 (define (date<? dat1 dat2)
    1223   (fx> 0 (tm:date-compare 'date<? dat1 dat2)) )
    1224 
    1225 (define (date<=? dat1 dat2)
    1226   (fx>= 0 (tm:date-compare 'date<=? dat1 dat2)) )
    1227 
    1228 (define (date>? dat1 dat2)
    1229   (fx< 0 (tm:date-compare 'date>? dat1 dat2)) )
    1230 
    1231 (define (date>=? dat1 dat2)
    1232   (fx<= 0 (tm:date-compare 'date>=? dat1 dat2)) )
    1233 
    1234 ;; Date Arithmetic
    1235 
    1236 (define (date-difference dat1 dat2 . args)
    1237   (check-date 'date-difference dat1)
    1238   (check-date 'date-difference dat2)
    1239   (let ((tim1 (apply date->time dat1 args))
    1240         (tim2 (apply date->time dat2 args)))
    1241     (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) ) )
    1242 
    1243 (define (date-add-duration dat dur . args)
    1244   (check-date 'date-add-duration dat)
    1245   (check-duration 'date-add-duration dur)
    1246   (let ((tim (apply date->time dat args)))
    1247     (time->date (tm:add-duration tim dur (tm:as-empty-time tim))) ) )
    1248 
    1249 (define (date-subtract-duration dat dur . args)
    1250   (check-date 'date-subtract-duration dat)
    1251   (check-duration 'date-subtract-duration dur)
    1252   (let ((tim (apply date->time dat args)))
    1253     (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
     941;;
     942
     943(define (error-incompatible-timezone loc dat1 dat2)
     944  (signal-type-error loc "incompatible timezone" dat1 dat2) )
     945
     946(define (check-compatible-timezone-offsets loc dat1 dat2)
     947  (unless (fx= (*date-zone-offset dat1) (*date-zone-offset dat2))
     948    (error-compatible-timezone loc dat1 dat2) ) )
     949
     950;;
     951
     952(define (tm:date-compare dat1 dat2)
     953  (let ((dif (fx- (*date-year dat1) (*date-year dat2))))
     954    (if (not (fx= 0 dif)) dif
     955        (let ((dif (fx- (*date-month dat1) (*date-month dat2))))
     956          (if (not (fx= 0 dif)) dif
     957              (let ((dif (fx- (*date-day dat1) (*date-day dat2))))
     958                (if (not (fx= 0 dif)) dif
     959                    (let ((dif (fx- (*date-hour dat1) (*date-hour dat2))))
     960                      (if (not (fx= 0 dif)) dif
     961                          (let ((dif (fx- (*date-minute dat1) (*date-minute dat2))))
     962                            (if (not (fx= 0 dif)) dif
     963                                (let ((dif (fx- (*date-second dat1) (*date-second dat2))))
     964                                  (if (not (fx= 0 dif)) dif
     965                                      (fx- (*date-nanosecond dat1) (*date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) )
    1254966
    1255967;; Time to Date
    1256968
     969(define ONE-NANOSECOND-DURATION (*make-time 'duration 1 0))
     970
    1257971;; Gives the seconds/day/month/year
    1258972
     973#; ;Original
    1259974(define (tm:decode-julian-day-number jdn)
    1260   (let* ((dys (number->maybe-fixnum (truncate jdn)))
     975  (let* ((days (truncate jdn))
     976         (a (+ days 32044))
     977         (b (quotient (+ (* 4 a) 3) 146097))
     978         (c (- a (quotient (* 146097 b) 4)))
     979         (d (quotient (+ (* 4 c) 3) 1461))
     980         (e (- c (quotient (* 1461 d) 4)))
     981         (m (quotient (+ (* 5 e) 2) 153))
     982         (y (+ (* 100 b) d -4800 (quotient m 10))))
     983    (values ; seconds date month year
     984     (* (- jdn days) tm:sid)
     985     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
     986     (+ m 3 (* -12 (quotient m 10)))
     987     (if (>= 0 y) (- y 1) y)) ) )
     988
     989(define (tm:decode-julian-day-number jdn)
     990  (let* ((dys (gennum->?fixnum (truncate jdn)))
    1261991         (a (fx+ dys 32044))
    1262992         (b (fx/ (fx+ (fx* 4 a) 3) 146097))
     
    1265995         (e (fx- c (fx/ (fx* 1461 d) 4)))
    1266996         (m (fx/ (fx+ (fx* 5 e) 2) 153))
    1267          (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))))
    1268     (values (number->maybe-fixnum (floor (* (- jdn dys) SEC/DY)))   ; seconds
    1269             (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)             ; day
    1270             (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))                  ; month
    1271             (if (fx<= y 0) (fx- y 1) y)) ) )                        ; year
     997         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))))
     998    (values ; seconds date month year
     999      (gennum->?fixnum (floor (* (- jdn dys) SEC/DY)))
     1000      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
     1001      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
     1002      (if (fx<= y 0) (fx- y 1) y)) ) )
    12721003
    12731004;; Gives the Julian day number - rounds up to the nearest day
    12741005
    12751006(define (tm:seconds->julian-day-number sec tzo)
    1276   (+ TAI-EPOCH-IN-JD
    1277      ; Round to day boundary
    1278      (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
     1007  (+ TAI-EPOCH-IN-JD (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
    12791008
    12801009;; Is the time object one second before a leap second?
     
    12871016               (loop (cdr ls)) ) ) ) ) )
    12881017
    1289 (define (tm:time->date loc tim tzc)
     1018#; ;Original
     1019(define (tm:time-utc->date tim tzi)
    12901020  ; The tz-info is caller's rest parameter
    1291   (let ((tzo (optional tzc (local-timezone-locale)))
     1021  (let ((tzo tzi)
    12921022        (tzn #f)
    12931023        (dstf #f))
     
    12961026        (set! tzn (timezone-locale-name tzo))
    12971027        (set! tzo (timezone-locale-offset tzo)) )
    1298       (check-timezone-offset loc tzo)
     1028      (receive (secs dy mn yr)
     1029          (tm:decode-julian-day-number (tm:seconds->julian-day-number (*time-second tim) tzo))
     1030        (let ((hr (quotient secs (* 60 60)))
     1031              (rem (remainder secs (* 60 60))))
     1032          (let ((min (quotient rem 60))
     1033                (sec (remainder rem 60)))
     1034            (tm:make-date (*time-nanosecond tim) sec min hr dy mn yr tzo tzn dstf #f #f #f) ) ) ) ) )
     1035
     1036(define (tm:time-utc->date tim tzi)
     1037  ; The tz-info is caller's rest parameter
     1038  (let ((tzo tzi)
     1039        (tzn #f)
     1040        (dstf #f))
     1041      (when (timezone-components? tzo)
     1042        (set! dstf (timezone-locale-dst? tzo))
     1043        (set! tzn (timezone-locale-name tzo))
     1044        (set! tzo (timezone-locale-offset tzo)) )
    12991045      (receive (secs dy mn yr)
    13001046          (tm:decode-julian-day-number (tm:seconds->julian-day-number (*time-second tim) tzo))
    13011047        (let ((hr (fx/ secs SEC/HR))
    1302               (rsecs (fxmod secs SEC/HR)))
    1303           (let ((min (fx/ rsecs SEC/MIN))
    1304                 (sec (fxmod rsecs SEC/MIN)))
     1048              (rem (fxmod secs SEC/HR)))
     1049          (let ((min (fx/ rem SEC/MIN))
     1050                (sec (fxmod rem SEC/MIN)))
    13051051            (tm:make-date (*time-nanosecond tim) sec min hr dy mn yr tzo tzn dstf #f #f #f) ) ) ) ) )
    13061052
    1307 (define (tm:time-tai->date loc tim tzc)
    1308   (let ((tm-utc (tm:time-tai->time-utc tim (tm:as-empty-time tim))))
    1309     (if (not (tm:tai-before-leap-second? tim)) (tm:time->date loc tm-utc tzc)
     1053(define (tm:time-tai->date tim tzi)
     1054  (let ((tm-utc (tm:time-tai->time-utc tim (tm:any-time))))
     1055    (if (not (tm:tai-before-leap-second? tim)) (tm:time-utc->date tm-utc tzi)
    13101056        ; else time is *right* before the leap, we need to pretend to subtract a second ...
    1311         (let ((dat (tm:time->date loc (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzc)))
     1057        (let ((dat (tm:time-utc->date (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)))
    13121058          (*date-second-set! dat SEC/MIN) ; Note full minute!
    13131059          dat ) ) ) )
    13141060
    1315 (define (time-tai->date tim . tzc)
    1316   (check-time-and-type 'time-tai->date tim 'time-tai)
    1317   (tm:time-tai->date 'time-tai->date tim tzc) )
    1318 
    1319 (define (time-utc->date tim . tzc)
    1320   (check-time-and-type 'time-utc->date tim 'time-utc)
    1321   (tm:time->date 'time-utc->date tim tzc) )
    1322 
    1323 (define (time-monotonic->date tim . tzc)
    1324   (check-time-and-type 'time-monotonic->date tim 'time-monotonic)
    1325   (tm:time->date 'time-monotonic->date tim tzc) )
    1326 
    1327 (define (time->date tim . tzc)
    1328   (check-time 'time->date tim)
     1061(define (tm:time->date tim tzi)
    13291062  (case (*time-type tim)
    1330     ((time-monotonic) (tm:time->date 'time->date tim tzc))
    1331     ((time-utc)       (tm:time->date 'time->date tim tzc))
    1332     ((time-tai)       (tm:time-tai->date 'time->date tim tzc))
    1333     (else ; This shouldn't happen
    1334      (error-clock-type 'time->date tim))) )
     1063    ((monotonic) (tm:time-utc->date tim tzi))
     1064    ((utc)       (tm:time-utc->date tim tzi))
     1065    ((tai)       (tm:time-tai->date tim tzi))
     1066    (else        #f)) )
    13351067
    13361068;; Date to Time
    13371069
    13381070;; Gives the Julian day number - Gregorian proleptic calendar
     1071
     1072#; ;Original
     1073(define (tm:encode-julian-day-number day month year)
     1074  (let* ((a (quotient (- 14 month) 12))
     1075         (y (- (- (+ year 4800) a) (if (negative? year) -1 0)))
     1076         (m (- (+ month (* 12 a)) 3)))
     1077    (+ day
     1078       (quotient (+ (* 153 m) 2) 5)
     1079       (* 365 y)
     1080       (quotient y 4)
     1081       (- (quotient y 100))
     1082       (quotient y 400)
     1083       -32045)))
    13391084
    13401085(define (tm:encode-julian-day-number dy mn yr)
    13411086  (let* ((a (fx/ (fx- 14 mn) MN/YR))
    1342          (b (fx- (fx+ yr 4800) a))
    1343          (y (if (negative? yr) (fx+ b 1) b)) ; BCE?
     1087         (b (fx- (fx+ yr JDYR) a))
     1088         (y (if (fx< yr 0) (fx+ b 1) b)) ; BCE?
    13441089         (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
    13451090    (+ dy
     
    13511096       -32045) ) )
    13521097
    1353 (define (tm:date->time-utc loc dat)
     1098#; ;Original
     1099(define (tm:date->time-utc dat)
    13541100  (let ((ns (*date-nanosecond dat))
    13551101        (sec (*date-second dat))
     
    13591105        (mn (*date-month dat))
    13601106        (yr (*date-year dat))
    1361         (tzo (*date-zone-offset dat)))
     1107        (tzo (*date-zone-offset dat)) )
     1108    (let ((jdays (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
     1109          (secs (+ (* hr 60 60) (* min 60) sec (- tzo))) )
     1110      (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) 24 60 60) secs)) ) ) )
     1111
     1112(define (tm:date->time-utc dat)
     1113  (let ((ns (*date-nanosecond dat))
     1114        (sec (*date-second dat))
     1115        (min (*date-minute dat))
     1116        (hr (*date-hour dat))
     1117        (dy (*date-day dat))
     1118        (mn (*date-month dat))
     1119        (yr (*date-year dat))
     1120        (tzo (*date-zone-offset dat)) )
    13621121    (let ((jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
    1363           (secs (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo))))
    1364       (tm:make-time 'time-utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
    1365 
    1366 (define (tm:date->time-tai loc dat)
    1367   (let* ((tm-utc (tm:date->time-utc loc dat))
     1122          (secs (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo))) )
     1123      (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
     1124
     1125(define (tm:date->time-tai dat)
     1126  (let* ((tm-utc (tm:date->time-utc dat))
    13681127         (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
    1369     (if (not (fx= 60 (*date-second dat))) tm-tai
     1128    (if (not (fx= SEC/MIN (*date-second dat))) tm-tai
    13701129        (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )
    13711130
    1372 (define (tm:date->time-monotonic loc dat)
    1373   (let ((tim-utc (tm:date->time-utc loc dat)))
     1131(define (tm:date->time-monotonic dat)
     1132  (let ((tim-utc (tm:date->time-utc dat)))
    13741133    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
    13751134
    1376 (define (date->time-utc dat)
    1377   (check-date 'date->time-utc dat)
    1378   (tm:date->time-utc 'date->time-utc dat) )
    1379 
    1380 (define (date->time-tai dat)
    1381   (check-date 'date->time-tai dat)
    1382   (tm:date->time-tai 'date->time-tai dat) )
    1383 
    1384 (define (date->time-monotonic dat)
    1385   (check-date 'date->time-monotonic dat)
    1386   (tm:date->time-monotonic 'date->time-monotonic dat) )
    1387 
    1388 (define (date->time dat . args)
    1389   (let-optionals args ((tt (default-date-clock-type)))
    1390     (check-date 'date->time dat)
    1391     (case tt
    1392       ((time-monotonic) (tm:date->time-monotonic  'date->time dat))
    1393       ((time-utc)       (tm:date->time-utc 'date->time dat))
    1394       ((time-tai)       (tm:date->time-tai 'date->time dat))
    1395       (else
    1396        (error-clock-type 'date->time tt)) ) ) )
    1397 
    1398 ;; Leap Year
    1399 
    1400 (define (leap-year? dat)
    1401   (check-date 'date-leap-year? dat)
    1402   (tm:leap-year? (*date-year dat)) )
     1135(define (tm:date->time dat tt)
     1136  (case tt
     1137    ((monotonic)  (tm:date->time-monotonic dat))
     1138    ((utc)        (tm:date->time-utc dat))
     1139    ((tai)        (tm:date->time-tai dat))
     1140    (else         #f) ) )
     1141
     1142;; Given a 'two digit' number, find the year within 50 years +/-
     1143
     1144(define (tm:natural-year n)
     1145  (if (or (fx< n 0) (fx>= n 100)) n
     1146      (let* ((current-year (date-year (current-date)))
     1147             (current-century (fx* (fx/ current-year 100) 100)))
     1148        (if (fx<= (fx- (fx+ current-century n) current-year) 50) (fx+ current-century n)
     1149            (fx+ (fx- current-century 100) n) ) ) ) )
    14031150
    14041151;; Day of Year
    14051152
     1153(define +cumulative-month-days+ '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
     1154
    14061155(define (tm:year-day dy mn yr)
    1407   (let ((yrdy (fx+ dy (vector-ref tm:cumulative-month-days mn))))
     1156  (let ((yrdy (fx+ dy (vector-ref +cumulative-month-days+ mn))))
    14081157    (if (and (tm:leap-year? yr) (fx< 2 mn)) (fx+ yrdy 1)
    14091158        yrdy ) ) )
    14101159
    1411 (define (date-year-day dat)
    1412   (check-date 'date-year-day dat)
    1413   (or (*date-yday dat)
    1414       (let ((yrdy (tm:year-day (*date-day dat) (*date-month dat) (*date-year dat))))
    1415         (*date-yday-set! dat yrdy)
    1416         yrdy ) ) )
     1160(define (tm:cache-date-year-day dat)
     1161  (let ((yrdy (tm:year-day (*date-day dat) (*date-month dat) (*date-year dat))))
     1162    (*date-yday-set! dat yrdy)
     1163    yrdy ) )
    14171164
    14181165;; Week Day
     
    14301177           DY/WK) ) )
    14311178
     1179(define (tm:cache-date-week-day dat)
     1180  (let ((wdy (tm:week-day (*date-day dat) (*date-month dat) (*date-year dat))))
     1181    (*date-wday-set! dat wdy)
     1182    wdy ) )
     1183
    14321184(define (tm:days-before-first-week dat day-of-week-starting-week)
    14331185  (fxmod (fx- day-of-week-starting-week (tm:week-day 1 1 (*date-year dat))) DY/WK) )
    14341186
    1435 (define (date-week-day dat)
    1436   (check-date 'date-week-day dat)
    1437   (or (*date-wday dat)
    1438       (let ((wdy (tm:week-day (*date-day dat) (*date-month dat) (*date-year dat))))
    1439         (*date-wday-set! dat wdy)
    1440         wdy ) ) )
    1441 
    1442 (define (date-week-number dat . args)
    1443   (check-date 'date-week-number dat)
    1444   (let ((day-of-week-starting-week (optional args 0)))
    1445     (fx/ (fx- (date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
    1446          DY/WK) ) )
     1187(define (tm:date-week-number dat day-of-week-starting-week)
     1188  (fx/ (fx- (date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
     1189        DY/WK) )
    14471190
    14481191;; Julian-day Operations
     1192
     1193(define (julian-day? obj) (real? obj))
     1194
     1195(define-check+error-type julian-day)
    14491196
    14501197(define (tm:julian-day->modified-julian-day mjdn) (- mjdn TAI-EPOCH-IN-MODIFIED-JD))
     
    14721219            iSEC/DY)) )
    14731220
    1474 (define (tm:date->julian-day loc dat)
    1475   (check-date loc dat)
     1221(define (tm:date->julian-day dat)
    14761222  (or (*date-jday dat)
    14771223      (let ((jdn
     
    14841230        jdn ) ) )
    14851231
    1486 (define (date->julian-day dat) (tm:date->julian-day 'date->julian-day dat))
    1487 
    1488 (define (date->modified-julian-day dat)
    1489   (tm:julian-day->modified-julian-day (tm:date->julian-day 'date->modified-julian-day dat)) )
    1490 
    14911232;; Time to Julian-day
    14921233
     
    15041245(define (tm:time-monotonic->julian-day tim) (*time-tai->julian-day tim))
    15051246
    1506 (define (time-utc->julian-day tim)
    1507   (check-time-and-type 'time-utc->julian-day tim 'time-utc)
    1508   (tm:time-utc->julian-day tim) )
    1509 
    1510 (define (time-tai->julian-day tim)
    1511   (check-time-and-type 'time-tai->julian-day tim 'time-tai)
    1512   (tm:time-tai->julian-day tim) )
    1513 
    1514 (define (time-monotonic->julian-day tim)
    1515   (check-time-and-type 'time-monotonic->julian-day tim 'time-monotonic)
    1516   (tm:time-monotonic->julian-day tim) )
    1517 
    1518 (define (time->julian-day tim)
    1519   (check-time 'time->julian-day tim)
     1247(define (tm:time->julian-day tim)
    15201248  (case (*time-type tim)
    1521     ((time-monotonic) (tm:time-monotonic->julian-day tim))
    1522     ((time-utc)       (tm:time-utc->julian-day tim))
    1523     ((time-tai)       (tm:time-tai->julian-day tim))
    1524     (else
    1525      (error-clock-type 'time->julian-day tim))) )
     1249    ((monotonic) (tm:time-monotonic->julian-day tim))
     1250    ((utc)       (tm:time-utc->julian-day tim))
     1251    ((tai)       (tm:time-tai->julian-day tim))
     1252    (else        #f)) )
    15261253
    15271254(define (tm:time-utc->modified-julian-day tim)
     
    15341261  (tm:julian-day->modified-julian-day (tm:time-monotonic->julian-day tim)) )
    15351262
    1536 (define (time-utc->modified-julian-day tim)
    1537   (check-time-and-type 'time-utc->modified-julian-day tim 'time-utc)
    1538   (tm:time-utc->modified-julian-day tim) )
    1539 
    1540 (define (time-tai->modified-julian-day tim)
    1541   (check-time-and-type 'time-tai->modified-julian-day tim 'time-tai)
    1542   (tm:time-tai->modified-julian-day tim) )
    1543 
    1544 (define (time-monotonic->modified-julian-day tim)
    1545   (check-time-and-type 'time-monotonic->modified-julian-day tim 'time-monotonic)
    1546   (tm:time-monotonic->modified-julian-day tim) )
    1547 
    1548 (define (time->modified-julian-day tim)
    1549   (check-time 'time->modified-julian-day tim)
     1263(define (tm:time->modified-julian-day tim)
    15501264  (case (*time-type tim)
    1551     ((time-monotonic) (tm:time-monotonic->modified-julian-day tim))
    1552     ((time-utc)       (tm:time-utc->modified-julian-day tim))
    1553     ((time-tai)       (tm:time-tai->modified-julian-day tim))
    1554     (else
    1555      (error-clock-type 'time->modified-julian-day tim))) )
     1265    ((monotonic) (tm:time-monotonic->modified-julian-day tim))
     1266    ((utc)       (tm:time-utc->modified-julian-day tim))
     1267    ((tai)       (tm:time-tai->modified-julian-day tim))
     1268    (else        #f)) )
    15561269
    15571270;; Julian-day to Time
    15581271
    1559 (define (tm:split-julian-day jdn) (tm:split-nanoseconds (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S)))
    1560 
    1561 (define (julian-day->time-utc jdn)
    1562   (receive (ns sec) (tm:split-julian-day jdn)
     1272(define (tm:julian-day->nanoseconds jdn) (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S))
     1273(define (tm:julian-day->time-values jdn) (tm:nanoseconds->time-values (tm:julian-day->nanoseconds jdn)))
     1274(define (tm:modified-julian-day->julian-day mjdn) (+ mjdn TAI-EPOCH-IN-MODIFIED-JD))
     1275
     1276(define (tm:julian-day->time-utc jdn)
     1277  (receive (ns sec) (tm:julian-day->time-values jdn)
    15631278    (tm:make-time 'time-utc ns sec) ) )
    15641279
    1565 (define (julian-day->time-tai jdn)
    1566   (time-utc->time-tai! (julian-day->time-utc jdn)) )
    1567 
    1568 (define (julian-day->time-monotonic jdn)
    1569   (time-utc->time-monotonic! (julian-day->time-utc jdn)) )
    1570 
    1571 (define (julian-day->date jdn . tzc)
    1572   (apply time-utc->date (julian-day->time-utc jdn) tzc) )
    1573 
    1574 (define (tm:modified-julian-day->julian-day mjdn) (+ mjdn TAI-EPOCH-IN-MODIFIED-JD))
    1575 
    1576 (define (modified-julian-day->time-utc mjdn)
    1577   (julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
    1578 
    1579 (define (modified-julian-day->time-tai mjdn)
    1580   (julian-day->time-tai (tm:modified-julian-day->julian-day mjdn)) )
    1581 
    1582 (define (modified-julian-day->time-monotonic mjdn)
    1583   (julian-day->time-monotonic (tm:modified-julian-day->julian-day mjdn)) )
    1584 
    1585 (define (modified-julian-day->date mjdn . tzc)
    1586   (apply julian-day->date (tm:modified-julian-day->julian-day mjdn) tzc) )
    1587 
    1588 ;; The Julian-day
    1589 
    1590 (define (current-julian-day)
    1591   (time-utc->julian-day (tm:current-time-utc)) )
    1592 
    1593 (define (current-modified-julian-day)
    1594   (time-utc->modified-julian-day (tm:current-time-utc)) )
    1595 
    15961280) ;module srfi-19-support
  • release/4/srfi-19/trunk/srfi-19.meta

    r15727 r15750  
    77 (doc-from-wiki)
    88 (synopsis "Time Data Types and Procedures")
    9  (needs setup-helper numbers miscmacros locale srfi-29)
     9 (needs setup-helper numbers miscmacros locale srfi-29 check-errors srfi-9-ext)
    1010 (files
    1111  "tests"
    1212        "srfi-19.scm"
    1313        "srfi-19-common.scm"
     14        "srfi-19-support.scm"
    1415        "srfi-19-core.scm"
    1516        "srfi-19-io.scm"
  • release/4/srfi-19/trunk/srfi-19.scm

    r15727 r15750  
    11;;;; srfi-19.scm
    22
    3 (use srfi-19-core srfi-19-io srfi-19-period)
     3(module srfi-19 (;export
     4  ;; SRFI-19
     5  time-tai
     6  time-utc
     7  time-monotonic
     8  time-thread
     9  time-process
     10  time-duration
     11  time-gc
     12  current-date
     13  current-julian-day
     14  current-modified-julian-day
     15  current-time
     16  time-resolution
     17  make-time
     18  time?
     19  time-type
     20  time-nanosecond
     21  time-second
     22  set-time-type!
     23  set-time-nanosecond!
     24  set-time-second!
     25  copy-time
     26  time<=?
     27  time<?
     28  time=?
     29  time>=?
     30  time>?
     31  time-difference
     32  time-difference!
     33  add-duration
     34  add-duration!
     35  subtract-duration
     36  subtract-duration!
     37  make-date
     38  date?
     39  date-nanosecond
     40  date-second
     41  date-minute
     42  date-hour
     43  date-day
     44  date-month
     45  date-year
     46  date-zone-offset
     47  leap-year? ; Actually part of SRFI 19 but not in original document
     48  date-year-day
     49  date-week-day
     50  date-week-number
     51  date->julian-day
     52  date->modified-julian-day
     53  date->time-monotonic
     54  date->time-tai
     55  date->time-utc
     56  julian-day->date
     57  julian-day->time-monotonic
     58  julian-day->time-tai
     59  julian-day->time-utc
     60  modified-julian-day->date
     61  modified-julian-day->time-monotonic
     62  modified-julian-day->time-tai
     63  modified-julian-day->time-utc
     64  time-monotonic->date
     65  time-monotonic->julian-day
     66  time-monotonic->modified-julian-day
     67  time-monotonic->time-tai
     68  time-monotonic->time-tai!
     69  time-monotonic->time-utc
     70  time-monotonic->time-utc!
     71  time-tai->date
     72  time-tai->julian-day
     73  time-tai->modified-julian-day
     74  time-tai->time-monotonic
     75  time-tai->time-monotonic!
     76  time-tai->time-utc
     77  time-tai->time-utc!
     78  time-utc->date
     79  time-utc->julian-day
     80  time-utc->modified-julian-day
     81  time-utc->time-monotonic
     82  time-utc->time-monotonic!
     83  time-utc->time-tai
     84  time-utc->time-tai!
     85  ;; SRFI-19 extensions
     86  one-second-duration
     87  one-nanosecond-duration
     88  zero-time
     89  time-type?
     90  make-duration
     91  divide-duration
     92  divide-duration!
     93  multiply-duration
     94  multiply-duration!
     95  time->srfi-18-time
     96  srfi-18-time->time
     97  time-max
     98  time-min
     99  time-negative?
     100  time-positive?
     101  time-zero?
     102  time-abs
     103  time-abs!
     104  time-negate
     105  time-negate!
     106  seconds->time/type
     107  seconds->date/type
     108  time->nanoseconds
     109  nanoseconds->time
     110  nanoseconds->seconds
     111  read-leap-second-table
     112  time->milliseconds
     113  milliseconds->time
     114  milliseconds->seconds
     115  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
     123  default-date-clock-type
     124  date-zone-name
     125  date-dst?
     126  copy-date
     127  date->time
     128  date-difference
     129  date-add-duration
     130  date-subtract-duration
     131  date=?
     132  date>?
     133  date<?
     134  date>=?
     135  date<=?
     136  date-max
     137  date-min
     138  time->julian-day
     139  time->modified-julian-day
     140  date-compare
     141  time-compare
     142  ;; SRFI-19
     143  date->string
     144  string->date
     145  ;; SRFI-19 extensions
     146  format-date
     147  scan-date
     148  ;; SRFI-19 extensions
     149  local-timezone-locale
     150  utc-timezone-locale
     151  timezone-locale-name
     152  timezone-locale-offset
     153  timezone-locale-dst?)
     154
     155  (import scheme chicken srfi-19-timezone srfi-19-core srfi-19-io)
     156 
     157  (require-library srfi-19-timezone srfi-19-core srfi-19-io)
     158
     159) ;module srfi-19
  • release/4/srfi-19/trunk/srfi-19.setup

    r15738 r15750  
    99  'locale              "0.6.2")
    1010
    11 (setup-shared-extension-module (extension-name) (extension-version "0.0.0"))
     11(setup-shared-extension-module 'srfi-19-timezone (extension-version "3.0.0")
     12  #:compile-options '(-inline -local -inline-global -no-procedure-checks))
     13
     14(setup-shared-extension-module 'srfi-19-support (extension-version "3.0.0")
     15  ;#:inline? #t
     16  #:compile-options '(-optimize-level 4 -debug-level 0 -inline -local -inline-global))
     17
     18(setup-shared-extension-module 'srfi-19-core (extension-version "3.0.0")
     19  #:compile-options '(-inline -local -inline-global -no-procedure-checks))
     20
     21(setup-shared-extension-module 'srfi-19-io (extension-version "3.0.0")
     22  #:compile-options '(-inline -local -inline-global -no-procedure-checks))
     23
     24(setup-shared-extension-module 'srfi-19-period (extension-version "3.0.0")
     25  #:compile-options '(-inline -local -inline-global -no-procedure-checks))
     26
     27(setup-shared-extension-module 'srfi-19 (extension-version "3.0.0")
     28  #:compile-options '(-inline -local -inline-global -no-procedure-checks))
Note: See TracChangeset for help on using the changeset viewer.