Changeset 38153 in project


Ignore:
Timestamp:
01/30/20 03:12:59 (3 weeks ago)
Author:
Kon Lovett
Message:

no "hidden" public export of tm: & % APIs

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

Legend:

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

    r38130 r38153  
    1010(import srfi-19-date)
    1111(reexport srfi-19-timezone)
    12 (reexport srfi-19-support)  ;Argh
     12(reexport srfi-19-support)
    1313(reexport srfi-19-time)
    1414(reexport srfi-19-date)
  • release/5/srfi-19/trunk/srfi-19-date.scm

    r38130 r38153  
    118118(import type-errors)
    119119(import srfi-19-timezone)
     120(import srfi-19-tm)
    120121(import srfi-19-support)
    121122
  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38130 r38153  
    4848(import srfi-29)
    4949(import type-checks)
     50(import srfi-19-timezone)
     51(import srfi-19-tm)
    5052(import srfi-19-support)
    51 (import srfi-19-timezone)
    5253
    5354;;;
  • release/5/srfi-19/trunk/srfi-19-period.scm

    r38130 r38153  
    4949(import type-checks)
    5050(import type-errors)
     51(import srfi-19-tm)
    5152(import srfi-19-core)
    5253
  • release/5/srfi-19/trunk/srfi-19-support.scm

    r38130 r38153  
    9494  error-incompatible-time-types
    9595  error-convert
    96   error-date-compatible-timezone
    97   ;;Private
    98   tm:read-tai-utc-data
    99   tm:calc-second-before-leap-second-table
    100   tm:read-leap-second-table
    101   (tm:any-time %make-time)
    102   (tm:some-time %make-time)
    103   (tm:as-some-time %time-type %make-time)
    104   (tm:time-type %time-type)
    105   (tm:time-nanosecond %time-second)
    106   (tm:time-second %time-nanosecond)
    107   (tm:time-type-set! %time-type-set!)
    108   (tm:time-nanosecond-set! %time-nanosecond-set!)
    109   (tm:time-second-set! %time-second-set!)
    110   tm:make-time
    111   (tm:copy-time %make-time)
    112   (tm:time-has-type? %time-type)
    113   tm:nanoseconds->time-values
    114   tm:time->nanoseconds
    115   tm:time->milliseconds
    116   tm:nanoseconds->seconds
    117   tm:milliseconds->seconds
    118   tm:time->seconds
    119   tm:duration-elements->time-values
    120   tm:milliseconds->time-values
    121   tm:seconds->time-values
    122   tm:seconds->time
    123   (tm:current-time-values tm:current-nanoseconds)
    124   tm:current-time-utc
    125   (tm:current-time-tai leap-second-delta)
    126   tm:current-time-monotonic
    127   (tm:current-time-thread current-thread-milliseconds)
    128   (tm:current-time-process current-process-milliseconds)
    129   (tm:current-time-gc current-gc-milliseconds total-gc-milliseconds)
    130   tm:time-resolution
    131   tm:time-compare
    132   tm:time=?
    133   tm:time<?
    134   tm:time<=?
    135   tm:time>?
    136   tm:time>=?
    137   tm:time-max
    138   tm:time-min
    139   tm:time-difference
    140   tm:add-duration
    141   tm:subtract-duration
    142   tm:divide-duration
    143   tm:multiply-duration
    144   tm:time-abs
    145   tm:time-negate
    146   tm:time-zero? tm:time-positive? tm:time-negative?
    147   (tm:time-tai->time-utc leap-second-neg-delta)
    148   tm:time-tai->time-monotonic
    149   tm:time-utc->time-tai
    150   tm:time-utc->time-monotonic
    151   tm:time-monotonic->time-tai
    152   tm:time-monotonic->time-utc
    153   tm:leap-year?
    154   (tm:leap-day? +leap-year-dys/mn+)
    155   (tm:days-in-month +leap-year-dys/mn+ +year-dys/mn+)
    156   (tm:date-nanosecond %date-nanosecond)
    157   (tm:date-second %date-second)
    158   (tm:date-minute %date-minute)
    159   (tm:date-hour %date-hour)
    160   (tm:date-day %date-day)
    161   (tm:date-month %date-month)
    162   (tm:date-year %date-year)
    163   (tm:date-zone-offset %date-zone-offset)
    164   (tm:date-zone-name %date-zone-name)
    165   (tm:date-dst? %date-dst?)
    166   tm:date-wday
    167   tm:date-yday
    168   tm:date-jday
    169   (tm:date-timezone-info %make-date-timezone-info)
    170   (tm:date-nanosecond-set! %date-nanosecond-set!)
    171   (tm:date-second-set! %date-second-set!)
    172   (tm:date-minute-set! %date-minute-set!)
    173   (tm:date-hour-set! %date-hour-set!)
    174   (tm:date-day-set! %date-day-set!)
    175   (tm:date-month-set! %date-month-set!)
    176   (tm:date-year-set! %date-year-set!)
    177   (tm:date-zone-offset-set! %date-zone-offset-set!)
    178   (tm:make-incomplete-date %make-date)
    179   (tm:make-date %make-date)
    180   (tm:copy-date %date-nanosecond %date-second %date-minute %date-hour
    181     %date-day %date-month %date-year
    182     %date-zone-offset %date-zone-name
    183     %date-jday %date-yday %date-wday
    184     %make-date)
    185   tm:seconds->date/type
    186   tm:current-date
    187   (tm:date-compare %date-nanosecond %date-second %date-minute %date-hour
    188     %date-day %date-month %date-year)
    189   tm:decode-julian-day-number
    190   tm:seconds->julian-day-number
    191   tm:tai-before-leap-second?
    192   tm:time-utc->date
    193   tm:time-tai->date
    194   tm:time->date
    195   tm:encode-julian-day-number
    196   tm:date->time-utc
    197   tm:date->time-tai
    198   tm:date->time-monotonic
    199   tm:date->time
    200   tm:natural-year
    201   tm:year-day
    202   tm:date-year-day
    203   tm:week-day
    204   tm:days-before-first-week
    205   tm:date-week-day
    206   tm:date-week-number
    207   tm:julian-day->modified-julian-day
    208   tm:julian-day
    209   (tm:date->julian-day %date-nanosecond %date-second %date-minute %date-hour
    210     %date-day %date-month %date-year
    211     %date-zone-offset
    212     %date-jday %date-jday-set!)
    213   tm:seconds->julian-day
    214   tm:time-utc->julian-day
    215   tm:time-tai->julian-day
    216   tm:time-monotonic->julian-day
    217   tm:time->julian-day
    218   tm:time-utc->modified-julian-day
    219   tm:time-tai->modified-julian-day
    220   tm:time-monotonic->modified-julian-day
    221   tm:time->modified-julian-day
    222   tm:julian-day->nanoseconds
    223   tm:julian-day->time-values
    224   tm:modified-julian-day->julian-day
    225   tm:julian-day->time-utc
    226   tm:modified-julian-day->time-utc
    227   tm:default-date-adjust-integer)
     96  error-date-compatible-timezone)
    22897
    22998(import scheme)
     
    244113(import type-checks)
    245114(import type-errors)
     115(import srfi-19-tm)
    246116(import srfi-19-timezone)
    247117
     
    252122;;;NOTE the use of syntax for inlining is an experiment. no procedure w/
    253123;;;arithmetic can be exported as syntax.
    254 ;;
     124
    255125;; For storage savings since some aritmetic routines do not
    256126;; return fixnums when possible.
     
    266136          (inexact->exact (floor x)) ) ) ) ) )
    267137
    268 ;;; Timing Routines
    269 
    270 ;; Provide system timing reporting procedures
    271 
    272 (define total-gc-milliseconds
    273   (let ((accum-ms 0))
    274     (lambda ()
    275       (set! accum-ms (+ accum-ms (current-gc-milliseconds)))
    276       accum-ms ) ) )
    277 
    278 (define (current-process-milliseconds)
    279   (let-values (((ums sms) (cpu-time)))
    280     (+ ums sms) ) )
    281 
    282 ;FIXME needs a srfi-18 extension
    283 (define current-thread-milliseconds current-process-milliseconds)
    284 
    285 ;;; Constants
    286 
    287 ;; TAI-EPOCH: 1 January 1970 CE at 00:00:00 UTC
    288 
    289 (define-constant TAI-EPOCH-YEAR 1970)
    290 
    291 ;(Chicken reader doesn't grok ratios w/o numbers egg at compile time.)
    292 
    293 ;; Used in julian calculation
    294 
    295 (define ONE-HALF (string->number "1/2"))
    296 
    297 ;; Julian Day 0 = 1 January 4713 BCE at 12:00:00 UTC (Julian proleptic calendar)
    298 ;; Julian Day 0 = 24 November 4714 BCE at 12:00:00 UTC (Gregorian proleptic calendar)
    299 
    300 (define TAI-EPOCH-IN-JD (string->number "4881175/2"))
    301 
    302 ;; Modified Julian Day 0 = 17 Nov 1858 CE at 00:00:00 UTC
    303 ;; Number of days less than a julian day.
    304 
    305 (define TAI-EPOCH-IN-MODIFIED-JD (string->number "4800001/2"))
    306 
    307 ;; Julian conversion base century
    308 
    309 (define-constant JDYR 4800)
    310 
    311 ;;; Leap Seconds
    312 
    313 ;; First leap year after epoch
    314 
    315 (define-constant FIRST-LEAP-YEAR 1972)
    316 
    317 ;; Number of seconds after epoch of first leap year
    318 
    319 (define LEAP-START (fx* (fx- FIRST-LEAP-YEAR TAI-EPOCH-YEAR) SEC/YR))
    320 
    321 ;; A table of leap seconds
    322 ;; See "ftp://maia.usno.navy.mil/ser7/tai-utc.dat" and update as necessary.
    323 ;; See "https://www.ietf.org/timezones/data/leap-seconds.list"
    324 ;; seconds since 1900 - seconds since 1972 = 2208988800
    325 ;; Each entry is (utc seconds since epoch . # seconds to add for tai)
    326 ;; Note they go higher (2009) to lower (1972).
    327 
    328 (define tm:leap-second-table
    329   '((1483228800 . 37)
    330     (1435708800 . 36)
    331     (1341100800 . 35)
    332     (1230768000 . 34)
    333     (1136073600 . 33)
    334     (915148800 . 32)
    335     (867715200 . 31)
    336     (820454400 . 30)
    337     (773020800 . 29)
    338     (741484800 . 28)
    339     (709948800 . 27)
    340     (662688000 . 26)
    341     (631152000 . 25)
    342     (567993600 . 24)
    343     (489024000 . 23)
    344     (425865600 . 22)
    345     (394329600 . 21)
    346     (362793600 . 20)
    347     (315532800 . 19)
    348     (283996800 . 18)
    349     (252460800 . 17)
    350     (220924800 . 16)
    351     (189302400 . 15)
    352     (157766400 . 14)
    353     (126230400 . 13)
    354     (94694400 . 12)
    355     (78796800 . 11)
    356     (63072000 . 10)
    357     #;(-60480000 . 4.21317)   ;Before 1972
    358     #;(-126230400 . 4.31317)
    359     #;(-136771200 . 3.84013)
    360     #;(-142128000 . 3.74013)
    361     #;(-152668800 . 3.64013)
    362     #;(-157766400 . 3.54013)
    363     #;(-168307200 . 3.44013)
    364     #;(-181526400 . 3.34013)
    365     #;(-189388800 . 3.24013)
    366     #;(-194659200 . 1.945858)
    367     #;(-252460800 . 1.845858)
    368     #;(-265680000 . 1.372818)
    369     #;(-283996800 . 1.422818) ) )
    370 
    371 ;; This procedure reads the file in the
    372 ;; ftp://maia.usno.navy.mil/ser7/tai-utc.dat format and
    373 ;; creates a leap second table
    374 
    375 (define (tm:read-tai-utc-data flnm)
    376   ;
    377   (define (convert-jd jd)
    378     (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))
    379   ;
    380   (define (convert-sec sec)
    381     (inexact->exact sec))
    382   ;
    383   (define (read-data)
    384     (let loop ((ls '()))
    385       (let ((line (read-line)))
    386         (if (eof-object? line)
    387           ls
    388           (let ((data (with-input-from-string (string-append "(" line ")") read)))
    389             (let ((year (car data))
    390                   (jd   (cadddr (cdr data)))
    391                   (secs (cadddr (cdddr data))))
    392               (loop
    393                 (if (< year FIRST-LEAP-YEAR) ls
    394                 (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )
    395   ;
    396   (with-input-from-port (open-input-file flnm) read-data) )
    397 
    398 ;; Table of cummulative seconds, one second before the leap second.
    399 
    400 (define (tm:calc-second-before-leap-second-table table)
    401   (let loop ((inlst table) (outlst '()))
    402     (if (null? inlst)
    403       (reverse outlst) ;keep input order anyway
    404       (let ((itm (car inlst)))
    405         (loop (cdr inlst) (cons (- (+ (car itm) (cdr itm)) 1) outlst)))) ) )
    406 
    407 (define tm:second-before-leap-second-table
    408   (tm:calc-second-before-leap-second-table tm:leap-second-table))
    409 
    410 ;; Read a leap second table file in U.S. Naval Observatory format
    411 
    412 (define (tm:read-leap-second-table flnm)
    413   (set! tm:leap-second-table (tm:read-tai-utc-data flnm))
    414   (set!
    415     tm:second-before-leap-second-table
    416     (tm:calc-second-before-leap-second-table tm:leap-second-table)) )
    417 
    418 ;; leap-second-delta algorithm
    419 
    420 ; 'leap-second-item' is like the 'it' in the anaphoric 'if'
    421 ;
    422 (define-syntax find-leap-second-delta*
    423   (er-macro-transformer
    424     (lambda (form r c)
    425       (let ((_let (r 'let))
    426             (_if (r 'if))
    427             (_null? (r 'null?))
    428             (_car (r 'car))
    429             (_cdr (r 'cdr))
    430             (_leap-second-item (r 'leap-second-item)) )
    431         (let ((?secs (cadr form))
    432               (?ls (caddr form))
    433               (?tst (cadddr form)) )
    434           `(,_let loop ((lsvar ,?ls))
    435               (,_if (,_null? lsvar) 0
    436                 (,_let ((leap-second-item (,_car lsvar)))
    437                     (,_if ,?tst
    438                         (,_cdr leap-second-item)
    439                         (loop (,_cdr lsvar)) ) ) ) ) ) ) ) ) )
    440 
    441 (define-syntax leap-second-delta*
    442   (er-macro-transformer
    443     (lambda (form r c)
    444       (let ((_let (r 'let))
    445             (_if (r 'if))
    446             (_< (r '<))
    447             (_tm:leap-second-table (r 'tm:leap-second-table))
    448             (_LEAP-START (r 'LEAP-START))
    449             (_find-leap-second-delta* (r 'find-leap-second-delta*)) )
    450         (let ((?secs (cadr form))
    451               (?tst (caddr form)) )
    452           `(,_if (,_< ,?secs ,_LEAP-START)
    453               0
    454               (,_find-leap-second-delta* ,?secs ,_tm:leap-second-table ,?tst) ) ) ) ) ) )
    455 
    456 ;; Going from utc seconds ...
    457 
    458 (define (leap-second-delta utc-seconds)
    459   (leap-second-delta*
    460     utc-seconds
    461     (<= (car leap-second-item) utc-seconds)) )
    462 
    463 ;; Going from tai seconds to utc seconds ...
    464 
    465 (define (leap-second-neg-delta tai-seconds)
    466   (leap-second-delta*
    467     tai-seconds
    468     (<= (cdr leap-second-item) (- tai-seconds (car leap-second-item)))) )
    469 
    470 ;;; Time Object (Public Mutable)
    471 
    472 ;; There are 3 kinds of time record procedures:
    473 ;; *...   - generated
    474 ;; tm:... - argument processing then *...
    475 ;; ...    - argument checking then tm:...
    476 
    477 ;#| ;dependency
    478 (define-constant srfi-19-time 'srfi-19-time)
    479 (define-record-type-variant srfi-19-time (unchecked #;inline unsafe)
    480   (%make-time tt ns sec)
    481   %time?
    482   (tt   %time-type        %time-type-set!)
    483   (ns   %time-nanosecond  %time-nanosecond-set!)
    484   (sec  %time-second      %time-second-set!) )
    485 ;|#
    486 #; ;no (define-record-type srfi-19-time
    487 (define-record-type srfi-19-time
    488   (%make-time tt ns sec)
    489   %time?
    490   (tt   %time-type        %time-type-set!)
    491   (ns   %time-nanosecond  %time-nanosecond-set!)
    492   (sec  %time-second      %time-second-set!) )
     138;;; Time Object
    493139
    494140(define (time? obj)
     
    496142
    497143;; Time to Date
    498 
    499 (define ONE-SECOND-DURATION (%make-time 'duration 0 1))
    500 
    501 ;;
    502 
    503 ;; <time-unit-value> -> <ns sec>
    504 
    505 (define-inline (normalize-timeval t t/t+1)
    506   (values (remainder t t/t+1) (quotient t t/t+1)) )
    507 
    508 (define (normalize-nanoseconds ns)
    509   (normalize-timeval ns NS/S) )
    510 
    511 ; <ns sec min hr> -> <ns sec min hr dy>
    512 ;
    513 #; ;UNUSED
    514 (define (normalize-time ns sec min hr)
    515   (let*-values (
    516     ((ns ns-sec)    (normalize-nanoseconds ns))
    517     ((sec sec-min)  (normalize-timeval (+ sec ns-sec) SEC/MIN))
    518     ((min min-hr)   (normalize-timeval (+ min sec-min) MIN/HR))
    519     ((hr hr-dy)     (normalize-timeval (+ hr min-hr) HR/DY)) )
    520     (values ns sec min hr (+ dy hr-dy)) ) )
    521144
    522145;;
     
    569192(define-check+error-type time-nanoseconds)
    570193
    571 ;; Output Argument CTORs
    572 
    573 ;Used to create an output time record where all fields will be set later
    574 ;
    575 (define-syntax tm:any-time
    576         (syntax-rules ()
    577                 ((_)
    578       (%make-time #f #f #f) ) ) )
    579 
    580 ;Used to create a time record where ns & sec fields will be set later
    581 ;
    582 (define-syntax tm:some-time
    583         (syntax-rules ()
    584                 ((_ ?tt)
    585                   (let ((tt ?tt))
    586         (%make-time tt #f #f) ) ) ) )
    587 
    588 ;Used to create a time record where ns & sec fields will be set later
    589 ;
    590 (define-syntax tm:as-some-time
    591         (syntax-rules ()
    592                 ((_ ?tim)
    593                   (let ((tim ?tim))
    594         (%make-time (%time-type tim) #f #f) ) ) ) )
    595 
    596 ;;
    597 
    598 (define-syntax tm:time-type
    599         (syntax-rules ()
    600                 ((_ ?tim)
    601                   (let ((tim ?tim))
    602         (%time-type tim) ) ) ) )
    603 
    604 (define-syntax tm:time-second
    605         (syntax-rules ()
    606                 ((_ ?tim)
    607                   (let ((tim ?tim))
    608         (%time-second tim) ) ) ) )
    609 
    610 (define-syntax tm:time-nanosecond
    611         (syntax-rules ()
    612                 ((_ ?tim)
    613                   (let ((tim ?tim))
    614         (%time-nanosecond tim) ) ) ) )
    615 
    616 (define-syntax tm:time-type-set!
    617         (syntax-rules ()
    618                 ((_ ?tim ?typ)
    619                   (let ((tim ?tim) (typ ?typ))
    620         (%time-type-set! tim typ) ) ) ) )
    621 
    622 (define-syntax tm:time-nanosecond-set!
    623         (syntax-rules ()
    624                 ((_ ?tim ?ns)
    625                   (let ((tim ?tim) (ns ?ns))
    626         (%time-nanosecond-set! tim (number->genint ns)) ) ) ) )
    627 
    628 (define-syntax tm:time-second-set!
    629         (syntax-rules ()
    630                 ((_ ?tim ?sec)
    631                   (let ((tim ?tim) (sec ?sec))
    632         (%time-second-set! tim (number->genint sec)) ) ) ) )
    633 
    634 (define (tm:make-time tt ns sec)
    635   (let-values (((ns ns-sec) (normalize-nanoseconds ns)))
    636     (%make-time tt (number->genint ns) (number->genint (+ sec ns-sec))) ) )
    637 
    638 (define-syntax tm:copy-time
    639         (syntax-rules ()
    640                 ((_ ?tim)
    641                   (let ((tim ?tim))
    642         (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) ) ) ) )
    643 
    644 (define-syntax tm:time-has-type?
    645         (syntax-rules ()
    646                 ((_ ?tim ?tt)
    647                   (let ((tim ?tim) (tt ?tt))
    648         (eq? tt (%time-type tim)) ) ) ) )
    649 
    650 ;; Rem & Quo of nanoseconds per second
    651 
    652 (define (tm:nanoseconds->time-values nanos)
    653   (values (remainder nanos NS/S) (quotient nanos NS/S)) )
    654 
    655194;; Seconds Conversion
    656195
     
    658197
    659198(define (check-raw-milliseconds loc obj) (check-real loc obj 'milliseconds))
    660 
    661 ;;
    662 
    663 (define (tm:time->nanoseconds tim)
    664   (+ (%time-nanosecond tim) (* (%time-second tim) NS/S)) )
    665 
    666 (define (tm:time->milliseconds tim)
    667   (+ (/ (%time-nanosecond tim) NS/MS) (* (%time-second tim) MS/S)) )
    668 
    669 (define (tm:nanoseconds->seconds ns)
    670   (/ ns NS/S) )
    671 
    672 (define (tm:milliseconds->seconds ms)
    673   (/ ms #;(exact->inexact ms) MS/S) )
    674 
    675 (define-syntax tm:time->seconds
    676         (syntax-rules ()
    677                 ((_ ?tim)
    678                   (let ((tim ?tim))
    679                     (tm:nanoseconds->seconds (tm:time->nanoseconds tim)) ) ) ) )
    680 
    681 (define (tm:duration-elements->time-values
    682           days
    683           hours minutes seconds
    684           milliseconds microseconds nanoseconds)
    685         (let (
    686           (nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
    687     (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
    688     (let-values (
    689       ((ns-ns ns-secs)
    690         (normalize-nanoseconds (+ nanos (* (- secs (floor secs)) NS/S)))) )
    691       (values ns-ns (+ (floor secs) ns-secs)) ) ) )
    692 
    693 (define (tm:seconds->time-values sec)
    694   (let* (
    695     (tsec (number->genint sec))
    696     (ns (number->genint (round (* (- sec tsec) NS/S)))) )
    697     (values ns tsec) ) )
    698 
    699 (define (tm:milliseconds->time-values ms)
    700   (let (
    701     (ns (fx* (number->genint (remainder ms MS/S)) NS/MS))
    702     (sec (quotient ms MS/S)) )
    703     (values ns sec) ) )
    704 
    705 (define-syntax tm:milliseconds->time
    706         (syntax-rules ()
    707                 ((_ ?ms ?tt)
    708                   (let ((ms ?ms) (tt ?tt))
    709         (let-values (((ns sec) (tm:milliseconds->time-values ms)))
    710           (tm:make-time tt ns sec) ) ) ) ) )
    711 
    712 (define-syntax tm:seconds->time
    713         (syntax-rules ()
    714                 ((_ ?sec ?tt)
    715                   (let ((sec ?sec) (tt ?tt))
    716         (let-values (((ns sec) (tm:seconds->time-values sec)))
    717           (tm:make-time tt ns sec) ) ) ) ) )
    718 
    719 ;; Current time routines
    720 
    721 ; Throw away everything but the sub-second bit.
    722 ;
    723 (define (tm:current-sub-milliseconds)
    724         (inexact->exact (remainder (current-milliseconds) MS/S)) )
    725 
    726 (define (tm:current-nanoseconds)
    727   (fx* (tm:current-sub-milliseconds) NS/MS) )
    728 
    729 ;Use the 'official' seconds & nanoseconds values
    730 ;
    731 (define-syntax tm:current-time-values
    732         (syntax-rules ()
    733                 ((_)
    734       (values (tm:current-nanoseconds) (current-seconds)) ) ) )
    735 
    736 (define-syntax tm:current-time-utc
    737         (syntax-rules ()
    738                 ((_)
    739                   (let-values (((ns sec) (tm:current-time-values)))
    740         (tm:make-time 'utc ns sec) ) ) ) )
    741 
    742 (define-syntax tm:current-time-tai
    743         (syntax-rules ()
    744                 ((_)
    745       (let-values (((ns sec) (tm:current-time-values)))
    746         (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) ) ) )
    747 
    748 (define-syntax tm:current-time-monotonic
    749         (syntax-rules ()
    750                 ((_)
    751       (let ((tim (tm:current-time-tai)))
    752         ;time-monotonic is time-tai
    753         (%time-type-set! tim 'monotonic)
    754         tim ) ) ) )
    755 
    756 (define-syntax tm:current-time-thread
    757         (syntax-rules ()
    758                 ((_)
    759       (tm:milliseconds->time (current-thread-milliseconds) 'thread) ) ) )
    760 
    761 (define-syntax tm:current-time-process
    762         (syntax-rules ()
    763                 ((_)
    764       (tm:milliseconds->time (current-process-milliseconds) 'process) ) ) )
    765 
    766 (define-syntax tm:current-time-gc
    767         (syntax-rules ()
    768                 ((_)
    769       (tm:milliseconds->time (total-gc-milliseconds) 'gc) ) ) )
    770 
    771 ;; -- Time Resolution
    772 ;; This is the resolution of the clock in nanoseconds.
    773 ;; This will be implementation specific.
    774 
    775 (define (tm:time-resolution tt)
    776   NS/MS )
    777199
    778200;; Specialized Time Parameter Checking
     
    812234  (check-duration loc dur) )
    813235
    814 ;; Time Comparison
    815 
    816 (define (tm:time-compare tim1 tim2)
    817   (let ((dif (- (%time-second tim1) (%time-second tim2))))
    818     (if (not (zero? dif))
    819       dif
    820       (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
    821 
    822 (define (tm:time=? tim1 tim2)
    823   (and
    824     (= (%time-second tim1) (%time-second tim2))
    825     (fx= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
    826 
    827 (define (tm:time<? tim1 tim2)
    828   (or
    829     (< (%time-second tim1) (%time-second tim2))
    830     (and
    831       (= (%time-second tim1) (%time-second tim2))
    832       (fx< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    833 
    834 (define (tm:time<=? tim1 tim2)
    835   (or
    836     (< (%time-second tim1) (%time-second tim2))
    837     (and
    838       (= (%time-second tim1) (%time-second tim2))
    839       (fx<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    840 
    841 (define (tm:time>? tim1 tim2)
    842   (or
    843     (> (%time-second tim1) (%time-second tim2))
    844     (and
    845       (= (%time-second tim1) (%time-second tim2))
    846       (fx> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    847 
    848 (define (tm:time>=? tim1 tim2)
    849   (or
    850     (> (%time-second tim1) (%time-second tim2))
    851     (and
    852       (= (%time-second tim1) (%time-second tim2))
    853       (fx>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    854 
    855 (define-syntax tm:time-max
    856         (syntax-rules ()
    857                 ((_ ?tim1 ?tim2)
    858                   (let ((tim1 ?tim1) (tim2 ?tim2))
    859         (if (tm:time>? tim1 tim2) tim1 tim2) ) ) ) )
    860 
    861 (define-syntax tm:time-min
    862         (syntax-rules ()
    863                 ((_ ?tim1 ?tim2)
    864                   (let ((tim1 ?tim1) (tim2 ?tim2))
    865         (if (tm:time<? tim1 tim2) tim1 tim2) ) ) ) )
    866 
    867 ;; Time Arithmetic
    868 
    869 (define (tm:add-duration tim1 dur timout)
    870         (let-values (((ns sec)
    871                 (tm:nanoseconds->time-values
    872                   (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    873     (let ((secs (+ (%time-second tim1) (%time-second dur) sec)))
    874       (cond
    875         ((negative? ns) ;Borrow
    876           ;Should never happen
    877           (tm:time-second-set! timout (+ secs -1))
    878           (tm:time-nanosecond-set! timout (+ ns NS/S)) )
    879         (else
    880           (tm:time-second-set! timout secs)
    881           (tm:time-nanosecond-set! timout ns) ) )
    882       timout ) ) )
    883 
    884 (define (tm:subtract-duration tim1 dur timout)
    885   (let-values (((ns sec)
    886                 (tm:nanoseconds->time-values
    887                   (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    888     #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
    889     (let ((secs (- (%time-second tim1) (%time-second dur) sec)))
    890       (cond
    891         ((negative? ns) ;Borrow
    892           (tm:time-second-set! timout (- secs 1))
    893           (tm:time-nanosecond-set! timout (+ ns NS/S)) )
    894         (else
    895           (tm:time-second-set! timout secs)
    896           (tm:time-nanosecond-set! timout ns) ) )
    897       timout ) ) )
    898 
    899 (define (tm:divide-duration dur1 num durout)
    900   (let-values (((ns sec)
    901                 (tm:nanoseconds->time-values
    902                   (/ (tm:time->nanoseconds dur1) num))) )
    903     (tm:time-nanosecond-set! durout ns)
    904     (tm:time-second-set! durout sec)
    905     durout ) )
    906 
    907 (define (tm:multiply-duration dur1 num durout)
    908         (let-values (((ns sec)
    909                 (tm:nanoseconds->time-values
    910                   (* (tm:time->nanoseconds dur1) num))) )
    911     (tm:time-nanosecond-set! durout ns)
    912     (tm:time-second-set! durout sec)
    913     durout ) )
    914 
    915 (define (tm:time-difference tim1 tim2 timout)
    916   (let-values (((ns sec)
    917                 (tm:nanoseconds->time-values
    918                   (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
    919     (tm:time-second-set! timout sec)
    920     (tm:time-nanosecond-set! timout ns)
    921     timout ) )
    922 
    923 (define-syntax tm:time-abs
    924         (syntax-rules ()
    925                 ((_ ?tim1 ?timout)
    926                   (let ((tim1 ?tim1)
    927                         (timout ?timout))
    928         (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
    929         (tm:time-second-set! timout (abs (%time-second tim1)))
    930         timout ) ) ) )
    931 
    932 (define (tm:time-negate tim1 timout )
    933   (tm:time-nanosecond-set! timout (- (%time-nanosecond tim1)))
    934   (tm:time-second-set! timout (- (%time-second tim1)))
    935   timout )
    936 
    937 (define (tm:time-negative? tim)
    938   ;nanoseconds irrelevant
    939   (negative? (tm:time-second tim)) )
    940 
    941 (define (tm:time-positive? tim)
    942   ;nanoseconds irrelevant
    943   (positive? (tm:time-second tim)) )
    944 
    945 (define (tm:time-zero? tim)
    946   (and
    947     (zero? (tm:time-nanosecond tim))
    948     (zero? (tm:time-second tim))) )
    949 
    950 ;; Time Type Converters
    951 
    952 (define (tm:time-tai->time-utc timin timout)
    953   (%time-type-set! timout 'utc)
    954   (tm:time-nanosecond-set! timout (%time-nanosecond timin))
    955   (tm:time-second-set!
    956     timout
    957     (-
    958       (%time-second timin)
    959       (leap-second-neg-delta (%time-second timin))))
    960   timout )
    961 
    962 (define-syntax tm:time-tai->time-monotonic
    963         (syntax-rules ()
    964                 ((_ ?timin ?timout)
    965                   (let ((timin ?timin)
    966                         (timout ?timout))
    967         (%time-type-set! timout 'monotonic)
    968         (unless (eq? timin timout)
    969           (tm:time-nanosecond-set! timout (%time-nanosecond timin))
    970           (tm:time-second-set! timout (%time-second timin)))
    971         timout ) ) ) )
    972 
    973 (define (tm:time-utc->time-tai timin timout)
    974   (%time-type-set! timout 'tai)
    975   (tm:time-nanosecond-set! timout (%time-nanosecond timin))
    976   (tm:time-second-set!
    977     timout
    978     (+
    979       (%time-second timin)
    980       (leap-second-delta (%time-second timin))))
    981   timout )
    982 
    983 (define-syntax tm:time-utc->time-monotonic
    984         (syntax-rules ()
    985                 ((_ ?timin ?timout)
    986                   (let ((timin ?timin)
    987                         (timout ?timout))
    988         (let ((ntim (tm:time-utc->time-tai timin timout)))
    989           (%time-type-set! ntim 'monotonic)
    990           ntim ) ) ) ) )
    991 
    992 (define-syntax tm:time-monotonic->time-tai
    993         (syntax-rules ()
    994                 ((_ ?timin ?timout)
    995                   (let ((timin ?timin)
    996                         (timout ?timout))
    997         (%time-type-set! timout 'tai)
    998         (unless (eq? timin timout)
    999           (tm:time-nanosecond-set! timout (%time-nanosecond timin))
    1000           (tm:time-second-set! timout (%time-second timin)))
    1001         timout ) ) ) )
    1002 
    1003 (define-syntax tm:time-monotonic->time-utc
    1004         (syntax-rules ()
    1005                 ((_ ?timin ?timout)
    1006                   (let ((timin ?timin)
    1007                         (timout ?timout))
    1008         #;(%time-type-set! timin 'tai) ;fool converter (unnecessary)
    1009         (tm:time-tai->time-utc timin timout) ) ) ) )
    1010 
    1011 ;;; Date Object (Public Immutable)
    1012 
    1013 ;; Leap Year Test
    1014 
    1015 ;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
    1016 ;; The Journal of the Royal Astronomical Society of Canada.
    1017 ;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
    1018 ;; Part II, volume 58, number 2, pages 79-87 (April 1964).
    1019 
    1020 (define-syntax tm:leap-year?
    1021         (syntax-rules ()
    1022                 ((_ ?yr)
    1023                   (let ((yr ?yr))
    1024         (and
    1025           #; ;!NOT Officially Adopted!
    1026           (not (fx= (fxmod yr 4000) 0))
    1027           (or
    1028             (fx= (fxmod yr 400) 0)
    1029             (and
    1030               (fx= (fxmod yr 4) 0)
    1031               (not (fx= (fxmod yr 100) 0))))) ) ) ) )
    1032 
    1033 ;; Days per Month
    1034 
    1035 ;Month range 1..12 so dys/mn range 0..12
    1036 (define      +year-dys/mn+ '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
    1037 (define +leap-year-dys/mn+ '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
    1038 
    1039 (define-syntax tm:leap-day?
    1040         (syntax-rules ()
    1041                 ((_ ?dy ?mn)
    1042                   (let ((dy ?dy) (mn ?mn))
    1043         (fx= dy (vector-ref +leap-year-dys/mn+ mn)) ) ) ) )
    1044 
    1045 (define-syntax tm:days-in-month
    1046         (syntax-rules ()
    1047                 ((_ ?yr ?mn)
    1048                   (let ((yr ?yr) (mn ?mn))
    1049         (vector-ref
    1050           (if (tm:leap-year? yr) +leap-year-dys/mn+ +year-dys/mn+)
    1051           mn) ) ) ) )
    1052 
    1053 ;;
    1054 
    1055 ;#| ;dependency
    1056 (define-constant srfi-19-date 'srfi-19-date)
    1057 (define-record-type-variant srfi-19-date (unchecked #;inline unsafe)
    1058   (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    1059   %date?
    1060   (ns     %date-nanosecond  %date-nanosecond-set!)
    1061   (sec    %date-second      %date-second-set!)
    1062   (min    %date-minute      %date-minute-set!)
    1063   (hr     %date-hour        %date-hour-set!)
    1064   (dy     %date-day         %date-day-set!)
    1065   (mn     %date-month       %date-month-set!)
    1066   (yr     %date-year        %date-year-set!)
    1067   (tzo    %date-zone-offset %date-zone-offset-set!)
    1068   ;; non-srfi extn
    1069   (tzn    %date-zone-name   %date-zone-name-set!)
    1070   (dstf   %date-dst?        %date-dst-set!)
    1071   (wdy    %date-wday        %date-wday-set!)
    1072   (ydy    %date-yday        %date-yday-set!)
    1073   (jdy    %date-jday        %date-jday-set!) )
    1074 ;|#
    1075 #; ;no dependency
    1076 (define-record-type srfi-19-date
    1077   (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    1078   %date?
    1079   (ns     %date-nanosecond  %date-nanosecond-set!)
    1080   (sec    %date-second      %date-second-set!)
    1081   (min    %date-minute      %date-minute-set!)
    1082   (hr     %date-hour        %date-hour-set!)
    1083   (dy     %date-day         %date-day-set!)
    1084   (mn     %date-month       %date-month-set!)
    1085   (yr     %date-year        %date-year-set!)
    1086   (tzo    %date-zone-offset %date-zone-offset-set!)
    1087   ;; non-srfi extn
    1088   (tzn    %date-zone-name   %date-zone-name-set!)
    1089   (dstf   %date-dst?        %date-dst-set!)
    1090   (wdy    %date-wday        %date-wday-set!)
    1091   (ydy    %date-yday        %date-yday-set!)
    1092   (jdy    %date-jday        %date-jday-set!) )
     236;;
    1093237
    1094238(define (date? obj)
     
    1238382(define-check+error-type date %date?)
    1239383
    1240 ;;
    1241 
    1242 ;;; Getters
    1243 
    1244 (define-syntax tm:date-nanosecond
    1245         (syntax-rules ()
    1246                 ((_ ?dat)
    1247                   (let ((dat ?dat))
    1248         (%date-nanosecond dat) ) ) ) )
    1249 
    1250 (define-syntax tm:date-second
    1251         (syntax-rules ()
    1252                 ((_ ?dat)
    1253                   (let ((dat ?dat))
    1254         (%date-second dat) ) ) ) )
    1255 
    1256 (define-syntax tm:date-minute
    1257         (syntax-rules ()
    1258                 ((_ ?dat)
    1259                   (let ((dat ?dat))
    1260         (%date-minute dat) ) ) ) )
    1261 
    1262 (define-syntax tm:date-hour
    1263         (syntax-rules ()
    1264                 ((_ ?dat)
    1265                   (let ((dat ?dat))
    1266         (%date-hour dat) ) ) ) )
    1267 
    1268 (define-syntax tm:date-day
    1269         (syntax-rules ()
    1270                 ((_ ?dat)
    1271                   (let ((dat ?dat))
    1272         (%date-day dat) ) ) ) )
    1273 
    1274 (define-syntax tm:date-month
    1275         (syntax-rules ()
    1276                 ((_ ?dat)
    1277                   (let ((dat ?dat))
    1278         (%date-month dat) ) ) ) )
    1279 
    1280 (define-syntax tm:date-year
    1281         (syntax-rules ()
    1282                 ((_ ?dat)
    1283                   (let ((dat ?dat))
    1284         (%date-year dat) ) ) ) )
    1285 
    1286 (define-syntax tm:date-zone-offset
    1287         (syntax-rules ()
    1288                 ((_ ?dat)
    1289                   (let ((dat ?dat))
    1290         (%date-zone-offset dat) ) ) ) )
    1291 
    1292 (define-syntax tm:date-zone-name
    1293         (syntax-rules ()
    1294                 ((_ ?dat)
    1295                   (let ((dat ?dat))
    1296         (%date-zone-name dat) ) ) ) )
    1297 
    1298 (define-syntax tm:date-dst?
    1299         (syntax-rules ()
    1300                 ((_ ?dat)
    1301                   (let ((dat ?dat))
    1302         (%date-dst? dat) ) ) ) )
    1303 
    1304 (define-syntax tm:date-wday
    1305         (syntax-rules ()
    1306                 ((_ ?dat)
    1307                   (let ((dat ?dat))
    1308         (%date-wday dat) ) ) ) )
    1309 
    1310 (define-syntax tm:date-yday
    1311         (syntax-rules ()
    1312                 ((_ ?dat)
    1313                   (let ((dat ?dat))
    1314         (%date-yday dat) ) ) ) )
    1315 
    1316 (define-syntax tm:date-jday
    1317         (syntax-rules ()
    1318                 ((_ ?dat)
    1319                   (let ((dat ?dat))
    1320         (%date-jday dat) ) ) ) )
    1321 
    1322 ;;; Setters
    1323 
    1324 (define-syntax tm:date-nanosecond-set!
    1325         (syntax-rules ()
    1326                 ((_ ?dat ?x)
    1327                   (let ((dat ?dat) (x ?x))
    1328         (%date-nanosecond-set! dat (number->genint x)) ) ) ) )
    1329 
    1330 (define-syntax tm:date-second-set!
    1331         (syntax-rules ()
    1332                 ((_ ?dat ?x)
    1333                   (let ((dat ?dat) (x ?x))
    1334         (%date-second-set! dat (number->genint x)) ) ) ) )
    1335 
    1336 (define-syntax tm:date-minute-set!
    1337         (syntax-rules ()
    1338                 ((_ ?dat ?x)
    1339                   (let ((dat ?dat) (x ?x))
    1340         (%date-minute-set! dat (number->genint x)) ) ) ) )
    1341 
    1342 (define-syntax tm:date-hour-set!
    1343         (syntax-rules ()
    1344                 ((_ ?dat ?x)
    1345                   (let ((dat ?dat) (x ?x))
    1346         (%date-hour-set! dat (number->genint x)) ) ) ) )
    1347 
    1348 (define-syntax tm:date-day-set!
    1349         (syntax-rules ()
    1350                 ((_ ?dat ?x)
    1351                   (let ((dat ?dat) (x ?x))
    1352         (%date-day-set! dat (number->genint x)) ) ) ) )
    1353 
    1354 (define-syntax tm:date-month-set!
    1355         (syntax-rules ()
    1356                 ((_ ?dat ?x)
    1357                   (let ((dat ?dat) (x ?x))
    1358         (%date-month-set! dat (number->genint x)) ) ) ) )
    1359 
    1360 (define-syntax tm:date-year-set!
    1361         (syntax-rules ()
    1362                 ((_ ?dat ?x)
    1363                   (let ((dat ?dat) (x ?x))
    1364         (%date-year-set! dat (number->genint x)) ) ) ) )
    1365 
    1366 (define-syntax tm:date-zone-offset-set!
    1367         (syntax-rules ()
    1368                 ((_ ?dat ?x)
    1369                   (let ((dat ?dat) (x ?x))
    1370         (%date-zone-offset-set! dat (number->genint x)) ) ) ) )
    1371 
    1372384;; Date TZ information extract
    1373 
    1374 ;Belongs in srfi-19-timezone
    1375 ;but won't fit since needs srfi-19-support (%date-*)
    1376 
    1377 ;#\ ;dependency
    1378 (define-constant date-timezone-info 'date-timezone-info)
    1379 (define-record-type-variant date-timezone-info (unchecked #;inline unsafe)
    1380   (%make-date-timezone-info n o d)
    1381   %date-timezone-info?
    1382   (n %date-timezone-info-name)
    1383   (o %date-timezone-info-offset)
    1384   (d %date-timezone-info-dst?) )
    1385 ;|#
    1386 #; ;no dependency
    1387 (define-record-type date-timezone-info
    1388   (%make-date-timezone-info n o d)
    1389   %date-timezone-info?
    1390   (n %date-timezone-info-name)
    1391   (o %date-timezone-info-offset)
    1392   (d %date-timezone-info-dst?) )
    1393385
    1394386(define (date-timezone-info? obj)
    1395387  (%date-timezone-info? obj) )
    1396388
    1397 (define-syntax tm:date-timezone-info
    1398         (syntax-rules ()
    1399                 ((_ ?dat)
    1400                   (let ((dat ?dat))
    1401         #;(make-timezone-locale (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat))
    1402         (%make-date-timezone-info
    1403           (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) ) ) ) )
    1404 
    1405 ;; Returns an invalid date record (for use by 'scan-date')
    1406 
    1407 (define-syntax tm:make-incomplete-date
    1408         (syntax-rules ()
    1409                 ((_)
    1410       (%make-date
    1411         0
    1412         0 0 0
    1413         #f #f #f
    1414         (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
    1415         #f #f #f) ) ) )
    1416 
    1417 ;; Internal Date CTOR
    1418 
    1419 (define-syntax tm:make-date
    1420         (syntax-rules ()
    1421                 ((_ ?ns ?sec ?min ?hr ?dy ?mn ?yr ?tzo ?tzn ?dstf ?wdy ?ydy ?jdy)
    1422                   (let ((ns ?ns) (sec ?sec) (min ?min) (hr ?hr) (dy ?dy) (mn ?mn) (yr ?yr) (tzo ?tzo) (tzn ?tzn) (dstf ?dstf) (wdy ?wdy) (ydy ?ydy) (jdy ?jdy))
    1423         (%make-date
    1424           (number->genint ns)
    1425           (number->genint sec) (number->genint min) (number->genint hr)
    1426           (number->genint dy) (number->genint mn) (number->genint yr)
    1427           (number->genint tzo) tzn dstf
    1428           wdy ydy jdy) ) ) ) )
    1429 
    1430 (define-syntax tm:copy-date
    1431         (syntax-rules ()
    1432                 ((_ ?dat)
    1433                   (let ((dat ?dat))
    1434         (%make-date
    1435           (%date-nanosecond dat)
    1436           (%date-second dat) (%date-minute dat) (%date-hour dat)
    1437           (%date-day dat) (%date-month dat) (%date-year dat)
    1438           (%date-zone-offset dat)
    1439           (%date-zone-name dat) (%date-dst? dat)
    1440           (%date-wday dat) (%date-yday dat) (%date-jday dat)) ) ) ) )
    1441 
    1442 (define (tm:seconds->date/type sec tzc)
    1443   (let* (
    1444     (isec (number->genint sec))
    1445     (tzo (timezone-locale-offset tzc))
    1446     (tv (seconds->utc-time (+ isec tzo))) )
    1447     (tm:make-date
    1448       (round (* (- sec isec) NS/S))
    1449       (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
    1450       (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
    1451       tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
    1452       (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) )
    1453 
    1454 (define-syntax tm:current-date
    1455         (syntax-rules ()
    1456                 ((_ ?tzi)
    1457                   (let ((tzi ?tzi))
    1458                     (tm:time-utc->date (tm:current-time-utc) tzi)) ) ) )
    1459 
    1460 ;; Date Comparison
    1461 
    1462 (define-syntax tm:date-compare
    1463         (syntax-rules ()
    1464                 ((_ ?dat1 ?dat2)
    1465                   (let ((dat1 ?dat1) (dat2 ?dat2))
    1466         (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
    1467           (if (not (fxzero? dif))
    1468             dif
    1469             (let ((dif (fx- (%date-month dat1) (%date-month dat2))))
    1470               (if (not (fxzero? dif))
    1471                 dif
    1472                 (let ((dif (fx- (%date-day dat1) (%date-day dat2))))
    1473                   (if (not (fxzero? dif))
    1474                     dif
    1475                     (let ((dif (fx- (%date-hour dat1) (%date-hour dat2))))
    1476                       (if (not (fxzero? dif))
    1477                         dif
    1478                         (let ((dif (fx- (%date-minute dat1) (%date-minute dat2))))
    1479                           (if (not (fxzero? dif))
    1480                             dif
    1481                             (let ((dif (fx- (%date-second dat1) (%date-second dat2))))
    1482                               (if (not (fxzero? dif))
    1483                                 dif
    1484                                 (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
    1485 
    1486 ;; Gives the seconds/day/month/year
    1487 
    1488 #; ;original
    1489 (define (tm:decode-julian-day-number jdn)
    1490   (let* (
    1491     (days (floor jdn))
    1492     (a (+ days 32044))
    1493     (b (quotient (+ (* 4 a) 3) 146097))
    1494     (c (- a (quotient (* 146097 b) 4)))
    1495     (d (quotient (+ (* 4 c) 3) 1461))
    1496     (e (- c (quotient (* 1461 d) 4)))
    1497     (m (quotient (+ (* 5 e) 2) 153))
    1498     (y (+ (* 100 b) d -4800 (quotient m 10))))
    1499     (values ;seconds date month year
    1500      (* (- jdn days) tm:sid)
    1501      (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
    1502      (+ m 3 (* -12 (quotient m 10)))
    1503      (if (>= 0 y) (- y 1) y)) ) )
    1504 (define (tm:decode-julian-day-number jdn)
    1505   (let* (
    1506     (dys (number->genint jdn))
    1507     (a (fx+ dys 32044))
    1508     (b (fx/ (fx+ (fx* 4 a) 3) 146097))
    1509     (c (fx- a (fx/ (fx* 146097 b) 4)))
    1510     (d (fx/ (fx+ (fx* 4 c) 3) 1461))
    1511     (e (fx- c (fx/ (fx* 1461 d) 4)))
    1512     (m (fx/ (fx+ (fx* 5 e) 2) 153))
    1513     (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))) )
    1514     (values ;seconds date month year
    1515       (number->genint (* (- jdn dys) SEC/DY))
    1516       (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
    1517       (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
    1518       (if (fx<= y 0) (fx- y 1) y)) ) )
    1519 
    1520 ;; Gives the Julian day number - rounds up to the nearest day
    1521 
    1522 (define (tm:seconds->julian-day-number sec tzo)
    1523   (+ TAI-EPOCH-IN-JD (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
    1524 
    1525 ;; Is the time object one second before a leap second?
    1526 
    1527 (define (tm:tai-before-leap-second? tim)
    1528   (let ((sec (%time-second tim)))
    1529     (let loop ((ls tm:second-before-leap-second-table))
    1530       (and
    1531         (not (null? ls))
    1532         (or
    1533           (= sec (car ls))
    1534           (loop (cdr ls)) ) ) ) ) )
    1535 
    1536 (define (tm:time-utc->date tim tzi)
    1537   (let (
    1538     (tzo tzi) ;assume an offset
    1539     (tzn #f)
    1540     (dstf #f) )
    1541     (cond
    1542       ((%date-timezone-info? tzi)
    1543         (set! dstf (%date-timezone-info-dst? tzi))
    1544         (set! tzn (%date-timezone-info-name tzi))
    1545         (set! tzo (%date-timezone-info-offset tzi)) )
    1546       ((timezone-components? tzi)
    1547         (set! dstf (timezone-locale-dst? tzi))
    1548         (set! tzn (timezone-locale-name tzi))
    1549         (set! tzo (timezone-locale-offset tzi)) ) )
    1550     (let-values (
    1551       ((secs dy mn yr)
    1552         (tm:decode-julian-day-number
    1553           (tm:seconds->julian-day-number (%time-second tim) tzo))) )
    1554       (let* (
    1555         (hr (fx/ secs SEC/HR))
    1556         (rem (fxmod secs SEC/HR))
    1557         (min (fx/ rem SEC/MIN))
    1558         (sec (fxmod rem SEC/MIN)) )
    1559         (tm:make-date
    1560           (%time-nanosecond tim)
    1561           sec min hr
    1562           dy mn yr
    1563           tzo tzn dstf
    1564           #f #f #f) ) ) ) )
    1565 
    1566 (define (tm:time-tai->date tim tzi)
    1567   (let (
    1568     (tm-utc (tm:time-tai->time-utc tim (tm:any-time))) )
    1569     (if (not (tm:tai-before-leap-second? tim))
    1570       (tm:time-utc->date tm-utc tzi)
    1571       ;else time is *right* before the leap,
    1572       ;we need to pretend to subtract a second ...
    1573       (let (
    1574         (dat
    1575           (tm:time-utc->date
    1576             (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)) )
    1577         (%date-second-set! dat SEC/MIN) ;Note full minute!
    1578         dat ) ) ) )
    1579 
    1580 (define (tm:time->date tim tzi)
    1581   (case (%time-type tim)
    1582     ((utc)       (tm:time-utc->date tim tzi))
    1583     ((tai)       (tm:time-tai->date tim tzi))
    1584     ((monotonic) (tm:time-utc->date tim tzi))
    1585     (else        #f)) )
    1586 
    1587 ;; Date to Time
    1588 
    1589 ;; Gives the Julian day number - Gregorian proleptic calendar
    1590 
    1591 (define (tm:encode-julian-day-number dy mn yr)
    1592   (let* (
    1593     (a (fx/ (fx- 14 mn) MN/YR))
    1594     (b (fx- (fx+ yr JDYR) a))
    1595     (y (if (fx< yr 0) (fx+ b 1) b)) ;BCE?
    1596     (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
    1597     (+ dy
    1598       (fx/ (fx+ (fx* 153 m) 2) 5)
    1599       (fx* y DY/YR)
    1600       (fx/ y 4)
    1601       (fx/ y -100)
    1602       (fx/ y 400)
    1603       -32045) ) )
    1604 
    1605 (define (tm:date->time-utc dat)
    1606   (let (
    1607     (ns (%date-nanosecond dat))
    1608     (sec (%date-second dat))
    1609     (min (%date-minute dat))
    1610     (hr (%date-hour dat))
    1611     (dy (%date-day dat))
    1612     (mn (%date-month dat))
    1613     (yr (%date-year dat))
    1614     (tzo (%date-zone-offset dat)) )
    1615     (let (
    1616       (jdys
    1617         (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
    1618       (secs
    1619         (fx+
    1620           (fx+
    1621             (fx* hr SEC/HR)
    1622             (fx+
    1623               (fx* min SEC/MIN)
    1624               sec))
    1625           (fxneg tzo))) )
    1626       (tm:make-time 'utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
    1627 
    1628 (define (tm:date->time-tai dat)
    1629   (let* (
    1630     (tm-utc (tm:date->time-utc dat))
    1631     (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
    1632     (if (not (fx= SEC/MIN (%date-second dat)))
    1633       tm-tai
    1634       (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai) ) ) )
    1635 
    1636 (define (tm:date->time-monotonic dat)
    1637   (let ((tim-utc (tm:date->time-utc dat)))
    1638     (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
    1639 
    1640 (define (tm:date->time dat tt)
    1641   (case tt
    1642     ((utc)        (tm:date->time-utc dat))
    1643     ((tai)        (tm:date->time-tai dat))
    1644     ((monotonic)  (tm:date->time-monotonic dat))
    1645     (else         #f) ) )
    1646 
    1647 ;; Given a 'two digit' number, find the year within 50 years +/-
    1648 
    1649 (define (tm:natural-year n tzi)
    1650   ;propagate the error
    1651   (if (or (fx< n 0) (fx>= n 100))
    1652     n
    1653     (let* (
    1654       (current-year     (%date-year (tm:current-date tzi)) )
    1655       (current-century  (fx* (fx/ current-year 100) 100) )
    1656       (X                (fx- (fx+ current-century n) current-year) ) )
    1657       (if (fx<= X 50)
    1658         (fx+ current-century n)
    1659         (fx+ (fx- current-century 100) n) ) ) ) )
    1660 
    1661 ;; Day of Year
    1662 
    1663 (define +cumulative-month-days+ '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
    1664 
    1665 (define (tm:year-day dy mn yr)
    1666   (let ((yrdy (fx+ dy (vector-ref +cumulative-month-days+ mn))))
    1667     (if (and (tm:leap-year? yr) (fx< 2 mn))
    1668       (fx+ yrdy 1)
    1669       yrdy ) ) )
    1670 
    1671 (define (tm:cache-date-year-day dat)
    1672   (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
    1673     (%date-yday-set! dat yrdy)
    1674     yrdy ) )
    1675 
    1676 (define (tm:date-year-day dat)
    1677   (or
    1678     (%date-yday dat)
    1679     (tm:cache-date-year-day dat) ) )
    1680 
    1681389;; Week Day
    1682390
     
    1686394(define-check+error-type week-day)
    1687395
    1688 ;; Using Gregorian Calendar (from Calendar FAQ)
    1689 
    1690 (: tm:week-day (fixnum fixnum fixnum --> fixnum))
    1691 
    1692 ;Tomohiko Sakamoto algorithm
    1693 ;Determination of the day of the week
    1694 ;
    1695 ;Jan 1st 1 AD is a Monday in Gregorian calendar.
    1696 ;So Jan 0th 1 AD is a Sunday [It does not exist technically].
    1697 ;
    1698 ;Every 4 years we have a leap year. But xy00 cannot be a leap unless xy divides 4 with remainder 0.
    1699 ;y/4 - y/100 + y/400 : this gives the number of leap years from 1AD to the
    1700 ;given year. As each year has 365 days (divides 7 with remainder 1), unless it
    1701 ;is a leap year or the date is in Jan or Feb, the day of a given date changes
    1702 ;by 1 each year. In other cases it increases by 2.
    1703 ;y -= m<3 : If the month is not Jan or Feb, we do not count the 29th Feb (if
    1704 ;it exists) of the given year.
    1705 ;So y + y/4 - y/100 + y/400  gives the day of Jan 0th (Dec 31st of prev year)
    1706 ;of the year. (This gives the remainder with 7 of  the number of days passed
    1707 ;before the given year began.)
    1708 ;
    1709 ;Array t:  Number of days passed before the month 'm+1' begins.
    1710 ;
    1711 ;So t[m-1]+d is the number of days passed in year 'y' up to the given date.
    1712 ;(y + y/4 - y/100 + y/400 + t[m-1] + d) % 7 is remainder of the number of days
    1713 ;from Jan 0 1AD to the given date which will be the day (0=Sunday,6=Saturday).
    1714 ;
    1715 ;Description credits: Sai Teja Pratap (quora.com/How-does-Tomohiko-Sakamotos-Algorithm-work).
    1716 (define tm:week-day
    1717   (let (
    1718     (t #(0 3 2 5 0 3 5 1 4 6 2 4)) )
    1719     (lambda (dy mn yr)
    1720       (let (
    1721         (yr (if (< mn 3) (fx- yr 1) yr)) )
    1722         (modulo (+ yr (/ yr 4) (/ yr -100) (vector-ref t (- mn 1)) dy) DY/WK) ) ) ) )
    1723 
    1724 (define (tm:week-day dy mn yr)
    1725   (let* ((a (fx/ (fx- 14 mn) MN/YR))
    1726          (y (fx- yr a))
    1727          (m (fx- (fx+ mn (fx* a MN/YR)) 2)))
    1728     (fxmod
    1729       (fx+
    1730         (fx+ dy y)
    1731         (fx+
    1732           (fx-
    1733             (fx/ y 4)
    1734             (fx/ y 100))
    1735           (fx+
    1736             (fx/ y 400)
    1737             (fx/ (fx* m DY/MN) MN/YR))))
    1738       DY/WK) ) )
    1739 
    1740 (define (tm:cache-date-week-day dat)
    1741   (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
    1742     (%date-wday-set! dat wdy)
    1743     wdy ) )
    1744 
    1745 (define (tm:date-week-day dat)
    1746   (or
    1747     (%date-wday dat)
    1748     (tm:cache-date-week-day dat) ) )
    1749 
    1750 (define (tm:days-before-first-week dat 1st-weekday)
    1751   (fxmod (fx- 1st-weekday (tm:week-day 1 1 (%date-year dat))) DY/WK) )
    1752 
    1753 (define (tm:date-week-number dat 1st-weekday)
    1754   (fx/
    1755     (fx- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday))
    1756     DY/WK) )
    1757 
    1758396;; Julian-day Operations
    1759397
     
    1763401(define-check+error-type julian-day)
    1764402
    1765 (define (tm:julian-day->modified-julian-day mjdn)
    1766   (- mjdn TAI-EPOCH-IN-MODIFIED-JD) )
    1767 
    1768 ;; Date to Julian-day
    1769 
    1770 (define (tm:jd-time->seconds ns sec min hr tzo)
    1771   (+
    1772     (fx+
    1773       (fx+
    1774         (fx* hr SEC/HR)
    1775         (fx+ (fx* min SEC/MIN) sec))
    1776       (fxneg tzo))
    1777     (/ ns NS/S)) )
    1778 
    1779 ; Does the nanoseconds value contribute anything to the julian day?
    1780 ; The range is < 1 second here (but not in the reference).
    1781 
    1782 (define (tm:julian-day ns sec min hr dy mn yr tzo)
    1783   (let (
    1784     (jdn
    1785       (tm:encode-julian-day-number dy mn yr))
    1786     (timsecs
    1787       (tm:jd-time->seconds ns sec min hr tzo)) )
    1788     (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )
    1789 #; ;inexact version
    1790 (define (tm:julian-day ns sec min hr dy mn yr tzo)
    1791   (let (
    1792     (time-seconds
    1793       (fx+
    1794         (fx+
    1795           (fx* hr SEC/HR)
    1796           (fx+ (fx* min SEC/MIN) sec))
    1797           (fxneg tzo)) ) )
    1798     (fp+
    1799       (fp-
    1800         (exact->inexact (tm:encode-julian-day-number dy mn yr))
    1801         (exact->inexact ONE-HALF))
    1802       (fp/
    1803         (fp+
    1804           (exact->inexact time-seconds)
    1805           (fp/ (exact->inexact ns) (exact->inexact NS/S)))
    1806         (exact->inexact SEC/DY))) ) )
    1807 
    1808 (define-syntax tm:date->julian-day
    1809         (syntax-rules ()
    1810                 ((_ ?dat)
    1811                   (let ((dat ?dat))
    1812         (or
    1813           (%date-jday dat)
    1814           (let (
    1815             (jdn
    1816               (tm:julian-day
    1817                 (%date-nanosecond dat)
    1818                 (%date-second dat) (%date-minute dat) (%date-hour dat)
    1819                 (%date-day dat) (%date-month dat) (%date-year dat)
    1820                 (%date-zone-offset dat))))
    1821             (%date-jday-set! dat jdn)
    1822             jdn ) ) ) ) ) )
    1823 
    1824 ;; Time to Julian-day
    1825 
    1826 (define (tm:seconds->julian-day ns sec)
    1827   (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
    1828 
    1829 (define (tm:time-utc->julian-day tim)
    1830   (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
    1831 
    1832 (define (tm:time-tai->julian-day tim)
    1833   (let ((sec (%time-second tim)))
    1834     (tm:seconds->julian-day
    1835       (%time-nanosecond tim)
    1836       (- sec (leap-second-delta sec))) ) )
    1837 
    1838 (define tm:time-monotonic->julian-day tm:time-tai->julian-day)
    1839 
    1840 (define (tm:time->julian-day tim)
    1841   (case (%time-type tim)
    1842     ((utc)        (tm:time-utc->julian-day tim))
    1843     ((tai)        (tm:time-tai->julian-day tim))
    1844     ((monotonic)  (tm:time-monotonic->julian-day tim))
    1845     (else         #f)) )
    1846 
    1847 (define (tm:time-utc->modified-julian-day tim)
    1848   (tm:julian-day->modified-julian-day (tm:time-utc->julian-day tim)) )
    1849 
    1850 (define (tm:time-tai->modified-julian-day tim)
    1851   (tm:julian-day->modified-julian-day (tm:time-tai->julian-day tim)) )
    1852 
    1853 (define (tm:time-monotonic->modified-julian-day tim)
    1854   (tm:julian-day->modified-julian-day (tm:time-monotonic->julian-day tim)) )
    1855 
    1856 (define (tm:time->modified-julian-day tim)
    1857   (case (%time-type tim)
    1858     ((utc)        (tm:time-utc->modified-julian-day tim))
    1859     ((tai)        (tm:time-tai->modified-julian-day tim))
    1860     ((monotonic)  (tm:time-monotonic->modified-julian-day tim))
    1861     (else         #f)) )
    1862 
    1863 ;; Julian-day to Time
    1864 
    1865 (define (tm:julian-day->nanoseconds jdn)
    1866   (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S) )
    1867 
    1868 (define (tm:julian-day->time-values jdn)
    1869   (tm:nanoseconds->time-values (tm:julian-day->nanoseconds jdn)) )
    1870 
    1871 (define (tm:modified-julian-day->julian-day mjdn)
    1872   (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) )
    1873 
    1874 (define-syntax tm:julian-day->time-utc
    1875         (syntax-rules ()
    1876                 ((_ ?jdn)
    1877                   (let ((jdn ?jdn))
    1878         (let-values (((ns sec) (tm:julian-day->time-values jdn)))
    1879           (tm:make-time 'time-utc ns sec) ) ) ) ) )
    1880 
    1881 (define (tm:modified-julian-day->time-utc mjdn)
    1882   (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
    1883 
    1884 (define (tm:default-date-adjust-integer amt)
    1885   (round amt) )
    1886 
    1887403) ;module srfi-19-support
  • release/5/srfi-19/trunk/srfi-19-time.scm

    r38130 r38153  
    110110(import type-checks)
    111111(import type-errors)
     112(import srfi-19-tm)
    112113(import srfi-19-support)
    113114
  • release/5/srfi-19/trunk/srfi-19.egg

    r38149 r38153  
    2626    (types-file)
    2727    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    28   (extension srfi-19-support
     28  (extension srfi-19-tm
    2929    #;(inline-file)
    3030    (types-file)
    3131    (component-dependencies srfi-19-timezone)
    3232    (csc-options "-O4" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks" "-no-argc-checks"))
     33  (extension srfi-19-support
     34    #;(inline-file)
     35    (types-file)
     36    (component-dependencies srfi-19-timezone srfi-19-tm)
     37    (csc-options "-O4" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks" "-no-argc-checks"))
    3338  (extension srfi-19-time
    3439    #;(inline-file)
    3540    (types-file)
    36     (component-dependencies srfi-19-support)
     41    (component-dependencies srfi-19-support srfi-19-tm)
    3742    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    3843  (extension srfi-19-date
    3944    #;(inline-file)
    4045    (types-file)
    41     (component-dependencies srfi-19-support srfi-19-timezone)
     46    (component-dependencies srfi-19-support srfi-19-tm srfi-19-timezone)
    4247    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    4348  (extension srfi-19-io
    4449    #;(inline-file)
    4550    (types-file)
    46     (component-dependencies srfi-19-support srfi-19-timezone)
     51    (component-dependencies srfi-19-support srfi-19-tm srfi-19-timezone)
    4752    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    4853  (extension srfi-19-period
    4954    #;(inline-file)
    5055    (types-file)
    51     (component-dependencies srfi-19-support srfi-19-time srfi-19-date)
     56    (component-dependencies srfi-19-tm srfi-19-core)
    5257    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks"))
    5358  (extension srfi-19-core
Note: See TracChangeset for help on using the changeset viewer.