123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485 |
- (define-module (srfi srfi-19)
- :use-module (srfi srfi-6)
- :use-module (srfi srfi-8)
- :use-module (srfi srfi-9)
- :autoload (ice-9 rdelim) (read-line)
- :use-module (ice-9 i18n)
- :replace (current-time)
- :export (
- time-duration
- time-monotonic
- time-process
- time-tai
- time-thread
- time-utc
-
- current-date
- current-julian-day
- current-modified-julian-day
- time-resolution
-
- make-time
- time?
- time-type
- time-nanosecond
- time-second
- set-time-type!
- set-time-nanosecond!
- set-time-second!
- copy-time
-
- time<=?
- time<?
- time=?
- time>=?
- time>?
-
- time-difference
- time-difference!
- add-duration
- add-duration!
- subtract-duration
- subtract-duration!
-
- make-date
- date?
- date-nanosecond
- date-second
- date-minute
- date-hour
- date-day
- date-month
- date-year
- date-zone-offset
- date-year-day
- date-week-day
- date-week-number
-
- date->julian-day
- date->modified-julian-day
- date->time-monotonic
- date->time-tai
- date->time-utc
- julian-day->date
- julian-day->time-monotonic
- julian-day->time-tai
- julian-day->time-utc
- modified-julian-day->date
- modified-julian-day->time-monotonic
- modified-julian-day->time-tai
- modified-julian-day->time-utc
- time-monotonic->date
- time-monotonic->julian-day
- time-monotonic->modified-julian-day
- time-monotonic->time-tai
- time-monotonic->time-tai!
- time-monotonic->time-utc
- time-monotonic->time-utc!
- time-tai->date
- time-tai->julian-day
- time-tai->modified-julian-day
- time-tai->time-monotonic
- time-tai->time-monotonic!
- time-tai->time-utc
- time-tai->time-utc!
- time-utc->date
- time-utc->julian-day
- time-utc->modified-julian-day
- time-utc->time-monotonic
- time-utc->time-monotonic!
- time-utc->time-tai
- time-utc->time-tai!
-
- date->string
- string->date))
- (cond-expand-provide (current-module) '(srfi-19))
- (define time-tai 'time-tai)
- (define time-utc 'time-utc)
- (define time-monotonic 'time-monotonic)
- (define time-thread 'time-thread)
- (define time-process 'time-process)
- (define time-duration 'time-duration)
- (define locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
- (define locale-short-date-format "~m/~d/~y")
- (define locale-time-format "~H:~M:~S")
- (define iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
- (define nano 1000000000)
- (define sid 86400)
- (define sihd 43200)
- (define tai-epoch-in-jd 4881175/2)
- (define (time-error caller type value)
- (if value
- (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
- (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))
- (define (read-tai-utc-data filename)
- (define (convert-jd jd)
- (* (- (inexact->exact jd) tai-epoch-in-jd) sid))
- (define (convert-sec sec)
- (inexact->exact sec))
- (let ((port (open-input-file filename))
- (table '()))
- (let loop ((line (read-line port)))
- (if (not (eof-object? line))
- (begin
- (let* ((data (read (open-input-string
- (string-append "(" line ")"))))
- (year (car data))
- (jd (cadddr (cdr data)))
- (secs (cadddr (cdddr data))))
- (if (>= year 1972)
- (set! table (cons
- (cons (convert-jd jd) (convert-sec secs))
- table)))
- (loop (read-line port))))))
- table))
- (define leap-second-table
- '((1341100800 . 35)
- (1230768000 . 34)
- (1136073600 . 33)
- (915148800 . 32)
- (867715200 . 31)
- (820454400 . 30)
- (773020800 . 29)
- (741484800 . 28)
- (709948800 . 27)
- (662688000 . 26)
- (631152000 . 25)
- (567993600 . 24)
- (489024000 . 23)
- (425865600 . 22)
- (394329600 . 21)
- (362793600 . 20)
- (315532800 . 19)
- (283996800 . 18)
- (252460800 . 17)
- (220924800 . 16)
- (189302400 . 15)
- (157766400 . 14)
- (126230400 . 13)
- (94694400 . 12)
- (78796800 . 11)
- (63072000 . 10)))
- (define (read-leap-second-table filename)
- (set! leap-second-table (read-tai-utc-data filename)))
- (define (leap-second-delta utc-seconds)
- (letrec ((lsd (lambda (table)
- (cond ((>= utc-seconds (caar table))
- (cdar table))
- (else (lsd (cdr table)))))))
- (if (< utc-seconds (* (- 1972 1970) 365 sid)) 0
- (lsd leap-second-table))))
- (define-record-type time
- (make-time-unnormalized type nanosecond second)
- time?
- (type time-type set-time-type!)
- (nanosecond time-nanosecond set-time-nanosecond!)
- (second time-second set-time-second!))
- (define (copy-time time)
- (make-time (time-type time) (time-nanosecond time) (time-second time)))
- (define (split-real r)
- (if (integer? r)
- (values (inexact->exact r) 0)
- (let ((l (truncate r)))
- (values (inexact->exact l) (- r l)))))
- (define (time-normalize! t)
- (if (>= (abs (time-nanosecond t)) 1000000000)
- (receive (int frac)
- (split-real (time-nanosecond t))
- (set-time-second! t (+ (time-second t)
- (quotient int 1000000000)))
- (set-time-nanosecond! t (+ (remainder int 1000000000)
- frac))))
- (if (and (positive? (time-second t))
- (negative? (time-nanosecond t)))
- (begin
- (set-time-second! t (- (time-second t) 1))
- (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
- (if (and (negative? (time-second t))
- (positive? (time-nanosecond t)))
- (begin
- (set-time-second! t (+ (time-second t) 1))
- (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
- t)
- (define (make-time type nanosecond second)
- (time-normalize! (make-time-unnormalized type nanosecond second)))
- (define (date->broken-down-time date)
- (let ((result (mktime 0)))
-
-
- (set-tm:sec result (date-second date))
- (set-tm:min result (date-minute date))
- (set-tm:hour result (date-hour date))
-
- (set-tm:mday result (date-day date))
- (set-tm:mon result (- (date-month date) 1))
-
- (set-tm:year result (+ 1900 (date-year date)))
- (set-tm:isdst result -1)
- (set-tm:gmtoff result (- (date-zone-offset date)))
- result))
- (define (current-time-utc)
-
- (let ((tod (gettimeofday)))
- (make-time time-utc (* (cdr tod) 1000) (car tod))))
- (define (current-time-tai)
-
- (let* ((tod (gettimeofday))
- (sec (car tod))
- (usec (cdr tod)))
- (make-time time-tai
- (* usec 1000)
- (+ (car tod) (leap-second-delta sec)))))
- (define (current-time-monotonic)
-
- (current-time-tai))
- (define (current-time-thread)
- (time-error 'current-time 'unsupported-clock-type 'time-thread))
- (define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
- (define (current-time-process)
- (let ((run-time (get-internal-run-time)))
- (make-time
- time-process
- (* (remainder run-time internal-time-units-per-second)
- ns-per-guile-tick)
- (quotient run-time internal-time-units-per-second))))
- (define (current-time . clock-type)
- (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
- (cond
- ((eq? clock-type time-tai) (current-time-tai))
- ((eq? clock-type time-utc) (current-time-utc))
- ((eq? clock-type time-monotonic) (current-time-monotonic))
- ((eq? clock-type time-thread) (current-time-thread))
- ((eq? clock-type time-process) (current-time-process))
-
- (else (time-error 'current-time 'invalid-clock-type clock-type)))))
- (define (time-resolution . clock-type)
- (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
- (case clock-type
- ((time-tai) 1000)
- ((time-utc) 1000)
- ((time-monotonic) 1000)
- ((time-process) ns-per-guile-tick)
-
-
- (else (time-error 'time-resolution 'invalid-clock-type clock-type)))))
- (define (time=? t1 t2)
-
-
- (and (= (time-second t1) (time-second t2))
- (= (time-nanosecond t1) (time-nanosecond t2))
- (eq? (time-type t1) (time-type t2))))
- (define (time>? t1 t2)
- (or (> (time-second t1) (time-second t2))
- (and (= (time-second t1) (time-second t2))
- (> (time-nanosecond t1) (time-nanosecond t2)))))
- (define (time<? t1 t2)
- (or (< (time-second t1) (time-second t2))
- (and (= (time-second t1) (time-second t2))
- (< (time-nanosecond t1) (time-nanosecond t2)))))
- (define (time>=? t1 t2)
- (or (> (time-second t1) (time-second t2))
- (and (= (time-second t1) (time-second t2))
- (>= (time-nanosecond t1) (time-nanosecond t2)))))
- (define (time<=? t1 t2)
- (or (< (time-second t1) (time-second t2))
- (and (= (time-second t1) (time-second t2))
- (<= (time-nanosecond t1) (time-nanosecond t2)))))
- (define (time-difference! time1 time2)
- (let ((sec-diff (- (time-second time1) (time-second time2)))
- (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
- (set-time-type! time1 time-duration)
- (set-time-second! time1 sec-diff)
- (set-time-nanosecond! time1 nsec-diff)
- (time-normalize! time1)))
- (define (time-difference time1 time2)
- (let ((result (copy-time time1)))
- (time-difference! result time2)))
- (define (add-duration! t duration)
- (if (not (eq? (time-type duration) time-duration))
- (time-error 'add-duration 'not-duration duration)
- (let ((sec-plus (+ (time-second t) (time-second duration)))
- (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
- (set-time-second! t sec-plus)
- (set-time-nanosecond! t nsec-plus)
- (time-normalize! t))))
- (define (add-duration t duration)
- (let ((result (copy-time t)))
- (add-duration! result duration)))
- (define (subtract-duration! t duration)
- (if (not (eq? (time-type duration) time-duration))
- (time-error 'add-duration 'not-duration duration)
- (let ((sec-minus (- (time-second t) (time-second duration)))
- (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
- (set-time-second! t sec-minus)
- (set-time-nanosecond! t nsec-minus)
- (time-normalize! t))))
- (define (subtract-duration time1 duration)
- (let ((result (copy-time time1)))
- (subtract-duration! result duration)))
- (define (priv:time-tai->time-utc! time-in time-out caller)
- (if (not (eq? (time-type time-in) time-tai))
- (time-error caller 'incompatible-time-types time-in))
- (set-time-type! time-out time-utc)
- (set-time-nanosecond! time-out (time-nanosecond time-in))
- (set-time-second! time-out (- (time-second time-in)
- (leap-second-delta
- (time-second time-in))))
- time-out)
- (define (time-tai->time-utc time-in)
- (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))
- (define (time-tai->time-utc! time-in)
- (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))
- (define (priv:time-utc->time-tai! time-in time-out caller)
- (if (not (eq? (time-type time-in) time-utc))
- (time-error caller 'incompatible-time-types time-in))
- (set-time-type! time-out time-tai)
- (set-time-nanosecond! time-out (time-nanosecond time-in))
- (set-time-second! time-out (+ (time-second time-in)
- (leap-second-delta
- (time-second time-in))))
- time-out)
- (define (time-utc->time-tai time-in)
- (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))
- (define (time-utc->time-tai! time-in)
- (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))
- (define (time-monotonic->time-utc time-in)
- (if (not (eq? (time-type time-in) time-monotonic))
- (time-error 'time-monotonic->time-utc
- 'incompatible-time-types time-in))
- (let ((ntime (copy-time time-in)))
- (set-time-type! ntime time-tai)
- (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
- (define (time-monotonic->time-utc! time-in)
- (if (not (eq? (time-type time-in) time-monotonic))
- (time-error 'time-monotonic->time-utc!
- 'incompatible-time-types time-in))
- (set-time-type! time-in time-tai)
- (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
- (define (time-monotonic->time-tai time-in)
- (if (not (eq? (time-type time-in) time-monotonic))
- (time-error 'time-monotonic->time-tai
- 'incompatible-time-types time-in))
- (let ((ntime (copy-time time-in)))
- (set-time-type! ntime time-tai)
- ntime))
- (define (time-monotonic->time-tai! time-in)
- (if (not (eq? (time-type time-in) time-monotonic))
- (time-error 'time-monotonic->time-tai!
- 'incompatible-time-types time-in))
- (set-time-type! time-in time-tai)
- time-in)
- (define (time-utc->time-monotonic time-in)
- (if (not (eq? (time-type time-in) time-utc))
- (time-error 'time-utc->time-monotonic
- 'incompatible-time-types time-in))
- (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
- 'time-utc->time-monotonic)))
- (set-time-type! ntime time-monotonic)
- ntime))
- (define (time-utc->time-monotonic! time-in)
- (if (not (eq? (time-type time-in) time-utc))
- (time-error 'time-utc->time-monotonic!
- 'incompatible-time-types time-in))
- (let ((ntime (priv:time-utc->time-tai! time-in time-in
- 'time-utc->time-monotonic!)))
- (set-time-type! ntime time-monotonic)
- ntime))
- (define (time-tai->time-monotonic time-in)
- (if (not (eq? (time-type time-in) time-tai))
- (time-error 'time-tai->time-monotonic
- 'incompatible-time-types time-in))
- (let ((ntime (copy-time time-in)))
- (set-time-type! ntime time-monotonic)
- ntime))
- (define (time-tai->time-monotonic! time-in)
- (if (not (eq? (time-type time-in) time-tai))
- (time-error 'time-tai->time-monotonic!
- 'incompatible-time-types time-in))
- (set-time-type! time-in time-monotonic)
- time-in)
- (define-record-type date
- (make-date nanosecond second minute
- hour day month
- year
- zone-offset)
- date?
- (nanosecond date-nanosecond set-date-nanosecond!)
- (second date-second set-date-second!)
- (minute date-minute set-date-minute!)
- (hour date-hour set-date-hour!)
- (day date-day set-date-day!)
- (month date-month set-date-month!)
- (year date-year set-date-year!)
- (zone-offset date-zone-offset set-date-zone-offset!))
- (define (encode-julian-day-number day month year)
- (let* ((a (quotient (- 14 month) 12))
- (y (- (+ year 4800) a (if (negative? year) -1 0)))
- (m (- (+ month (* 12 a)) 3)))
- (+ day
- (quotient (+ (* 153 m) 2) 5)
- (* 365 y)
- (quotient y 4)
- (- (quotient y 100))
- (quotient y 400)
- -32045)))
- (define (decode-julian-day-number jdn)
- (let* ((days (inexact->exact (truncate jdn)))
- (a (+ days 32044))
- (b (quotient (+ (* 4 a) 3) 146097))
- (c (- a (quotient (* 146097 b) 4)))
- (d (quotient (+ (* 4 c) 3) 1461))
- (e (- c (quotient (* 1461 d) 4)))
- (m (quotient (+ (* 5 e) 2) 153))
- (y (+ (* 100 b) d -4800 (quotient m 10))))
- (values
- (* (- jdn days) sid)
- (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
- (+ m 3 (* -12 (quotient m 10)))
- (if (>= 0 y) (- y 1) y))))
- (define (local-tz-offset utc-time)
-
- (- (tm:gmtoff (localtime (time-second utc-time)))))
- (define (time->julian-day-number seconds tz-offset)
- (+ (/ (+ seconds tz-offset sihd)
- sid)
- tai-epoch-in-jd))
- (define (leap-second? second)
- (and (assoc second leap-second-table) #t))
- (define (time-utc->date time . tz-offset)
- (if (not (eq? (time-type time) time-utc))
- (time-error 'time->date 'incompatible-time-types time))
- (let* ((offset (if (null? tz-offset)
- (local-tz-offset time)
- (car tz-offset)))
- (leap-second? (leap-second? (+ offset (time-second time))))
- (jdn (time->julian-day-number (if leap-second?
- (- (time-second time) 1)
- (time-second time))
- offset)))
- (call-with-values (lambda () (decode-julian-day-number jdn))
- (lambda (secs date month year)
-
-
- (let* ((int-secs (inexact->exact (round secs)))
- (hours (quotient int-secs (* 60 60)))
- (rem (remainder int-secs (* 60 60)))
- (minutes (quotient rem 60))
- (seconds (remainder rem 60)))
- (make-date (time-nanosecond time)
- (if leap-second? (+ seconds 1) seconds)
- minutes
- hours
- date
- month
- year
- offset))))))
- (define (time-tai->date time . tz-offset)
- (if (not (eq? (time-type time) time-tai))
- (time-error 'time->date 'incompatible-time-types time))
- (let* ((offset (if (null? tz-offset)
- (local-tz-offset (time-tai->time-utc time))
- (car tz-offset)))
- (seconds (- (time-second time)
- (leap-second-delta (time-second time))))
- (leap-second? (leap-second? (+ offset seconds)))
- (jdn (time->julian-day-number (if leap-second?
- (- seconds 1)
- seconds)
- offset)))
- (call-with-values (lambda () (decode-julian-day-number jdn))
- (lambda (secs date month year)
-
-
-
- (let* ((int-secs (inexact->exact (round secs)))
- (hours (quotient int-secs (* 60 60)))
- (rem (remainder int-secs (* 60 60)))
- (minutes (quotient rem 60))
- (seconds (remainder rem 60)))
- (make-date (time-nanosecond time)
- (if leap-second? (+ seconds 1) seconds)
- minutes
- hours
- date
- month
- year
- offset))))))
- (define (time-monotonic->date time . tz-offset)
- (if (not (eq? (time-type time) time-monotonic))
- (time-error 'time->date 'incompatible-time-types time))
- (let* ((offset (if (null? tz-offset)
- (local-tz-offset (time-monotonic->time-utc time))
- (car tz-offset)))
- (seconds (- (time-second time)
- (leap-second-delta (time-second time))))
- (leap-second? (leap-second? (+ offset seconds)))
- (jdn (time->julian-day-number (if leap-second?
- (- seconds 1)
- seconds)
- offset)))
- (call-with-values (lambda () (decode-julian-day-number jdn))
- (lambda (secs date month year)
-
-
-
- (let* ((int-secs (inexact->exact (round secs)))
- (hours (quotient int-secs (* 60 60)))
- (rem (remainder int-secs (* 60 60)))
- (minutes (quotient rem 60))
- (seconds (remainder rem 60)))
- (make-date (time-nanosecond time)
- (if leap-second? (+ seconds 1) seconds)
- minutes
- hours
- date
- month
- year
- offset))))))
- (define (date->time-utc date)
- (let* ((jdays (- (encode-julian-day-number (date-day date)
- (date-month date)
- (date-year date))
- tai-epoch-in-jd))
-
- (jdays-1/2 (inexact->exact (- jdays 1/2))))
- (make-time
- time-utc
- (date-nanosecond date)
- (+ (* jdays-1/2 24 60 60)
- (* (date-hour date) 60 60)
- (* (date-minute date) 60)
- (date-second date)
- (- (date-zone-offset date))))))
- (define (date->time-tai date)
- (time-utc->time-tai! (date->time-utc date)))
- (define (date->time-monotonic date)
- (time-utc->time-monotonic! (date->time-utc date)))
- (define (leap-year? year)
- (or (= (modulo year 400) 0)
- (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
- (define month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90)
- (5 . 120) (6 . 151) (7 . 181) (8 . 212)
- (9 . 243) (10 . 273) (11 . 304) (12 . 334)))
- (define (year-day day month year)
- (let ((days-pr (assoc month month-assoc)))
- (if (not days-pr)
- (time-error 'date-year-day 'invalid-month-specification month))
- (if (and (leap-year? year) (> month 2))
- (+ day (cdr days-pr) 1)
- (+ day (cdr days-pr)))))
- (define (date-year-day date)
- (year-day (date-day date) (date-month date) (date-year date)))
- (define (week-day day month year)
- (let* ((a (quotient (- 14 month) 12))
- (y (- year a))
- (m (+ month (* 12 a) -2)))
- (modulo (+ day
- y
- (quotient y 4)
- (- (quotient y 100))
- (quotient y 400)
- (quotient (* 31 m) 12))
- 7)))
- (define (date-week-day date)
- (week-day (date-day date) (date-month date) (date-year date)))
- (define (days-before-first-week date day-of-week-starting-week)
- (let* ((first-day (make-date 0 0 0 0
- 1
- 1
- (date-year date)
- #f))
- (fdweek-day (date-week-day first-day)))
- (modulo (- day-of-week-starting-week fdweek-day)
- 7)))
- (define (date-week-number date day-of-week-starting-week)
- (quotient (- (date-year-day date)
- 1
- (days-before-first-week date day-of-week-starting-week))
- 7))
- (define (current-date . tz-offset)
- (let ((time (current-time time-utc)))
- (time-utc->date
- time
- (if (null? tz-offset)
- (local-tz-offset time)
- (car tz-offset)))))
- (define (natural-year n)
- (let* ((current-year (date-year (current-date)))
- (current-century (* (quotient current-year 100) 100)))
- (cond
- ((>= n 100) n)
- ((< n 0) n)
- ((<= (- (+ current-century n) current-year) 50) (+ current-century n))
- (else (+ (- current-century 100) n)))))
- (define (date->julian-day date)
- (let ((nanosecond (date-nanosecond date))
- (second (date-second date))
- (minute (date-minute date))
- (hour (date-hour date))
- (day (date-day date))
- (month (date-month date))
- (year (date-year date))
- (offset (date-zone-offset date)))
- (+ (encode-julian-day-number day month year)
- (- 1/2)
- (+ (/ (+ (- offset)
- (* hour 60 60)
- (* minute 60)
- second
- (/ nanosecond nano))
- sid)))))
- (define (date->modified-julian-day date)
- (- (date->julian-day date)
- 4800001/2))
- (define (time-utc->julian-day time)
- (if (not (eq? (time-type time) time-utc))
- (time-error 'time->date 'incompatible-time-types time))
- (+ (/ (+ (time-second time) (/ (time-nanosecond time) nano))
- sid)
- tai-epoch-in-jd))
- (define (time-utc->modified-julian-day time)
- (- (time-utc->julian-day time)
- 4800001/2))
- (define (time-tai->julian-day time)
- (if (not (eq? (time-type time) time-tai))
- (time-error 'time->date 'incompatible-time-types time))
- (+ (/ (+ (- (time-second time)
- (leap-second-delta (time-second time)))
- (/ (time-nanosecond time) nano))
- sid)
- tai-epoch-in-jd))
- (define (time-tai->modified-julian-day time)
- (- (time-tai->julian-day time)
- 4800001/2))
- (define (time-monotonic->julian-day time)
- (if (not (eq? (time-type time) time-monotonic))
- (time-error 'time->date 'incompatible-time-types time))
- (+ (/ (+ (- (time-second time)
- (leap-second-delta (time-second time)))
- (/ (time-nanosecond time) nano))
- sid)
- tai-epoch-in-jd))
- (define (time-monotonic->modified-julian-day time)
- (- (time-monotonic->julian-day time)
- 4800001/2))
- (define (julian-day->time-utc jdn)
- (let ((secs (* sid (- jdn tai-epoch-in-jd))))
- (receive (seconds parts)
- (split-real secs)
- (make-time time-utc
- (* parts nano)
- seconds))))
- (define (julian-day->time-tai jdn)
- (time-utc->time-tai! (julian-day->time-utc jdn)))
- (define (julian-day->time-monotonic jdn)
- (time-utc->time-monotonic! (julian-day->time-utc jdn)))
- (define (julian-day->date jdn . tz-offset)
- (let* ((time (julian-day->time-utc jdn))
- (offset (if (null? tz-offset)
- (local-tz-offset time)
- (car tz-offset))))
- (time-utc->date time offset)))
- (define (modified-julian-day->date jdn . tz-offset)
- (apply julian-day->date (+ jdn 4800001/2)
- tz-offset))
- (define (modified-julian-day->time-utc jdn)
- (julian-day->time-utc (+ jdn 4800001/2)))
- (define (modified-julian-day->time-tai jdn)
- (julian-day->time-tai (+ jdn 4800001/2)))
- (define (modified-julian-day->time-monotonic jdn)
- (julian-day->time-monotonic (+ jdn 4800001/2)))
- (define (current-julian-day)
- (time-utc->julian-day (current-time time-utc)))
- (define (current-modified-julian-day)
- (time-utc->modified-julian-day (current-time time-utc)))
- (define (padding n pad-with length)
- (let* ((str (number->string n))
- (str-len (string-length str)))
- (if (or (>= str-len length)
- (not pad-with))
- str
- (string-append (make-string (- length str-len) pad-with) str))))
- (define (last-n-digits i n)
- (abs (remainder i (expt 10 n))))
- (define (locale-abbr-weekday n) (locale-day-short (+ 1 n)))
- (define (locale-long-weekday n) (locale-day (+ 1 n)))
- (define locale-abbr-month locale-month-short)
- (define locale-long-month locale-month)
- (define (date-reverse-lookup needle haystack-ref haystack-len
- same?)
-
-
-
- (let loop ((index 1))
- (cond ((> index haystack-len) #f)
- ((same? needle (haystack-ref index))
- index)
- (else (loop (+ index 1))))))
- (define (locale-abbr-weekday->index string)
- (date-reverse-lookup string locale-day-short 7 string=?))
- (define (locale-long-weekday->index string)
- (date-reverse-lookup string locale-day 7 string=?))
- (define (locale-abbr-month->index string)
- (date-reverse-lookup string locale-abbr-month 12 string=?))
- (define (locale-long-month->index string)
- (date-reverse-lookup string locale-long-month 12 string=?))
- (define (locale-print-time-zone date port)
- (tz-printer (date-zone-offset date) port))
- (define (locale-am-string/pm hr)
- (if (> hr 11) (locale-pm-string) (locale-am-string)))
- (define (tz-printer offset port)
- (cond
- ((= offset 0) (display "Z" port))
- ((negative? offset) (display "-" port))
- (else (display "+" port)))
- (if (not (= offset 0))
- (let ((hours (abs (quotient offset (* 60 60))))
- (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
- (display (padding hours #\0 2) port)
- (display (padding minutes #\0 2) port))))
- (define directives
- (list
- (cons #\~ (lambda (date pad-with port)
- (display #\~ port)))
- (cons #\a (lambda (date pad-with port)
- (display (locale-abbr-weekday (date-week-day date))
- port)))
- (cons #\A (lambda (date pad-with port)
- (display (locale-long-weekday (date-week-day date))
- port)))
- (cons #\b (lambda (date pad-with port)
- (display (locale-abbr-month (date-month date))
- port)))
- (cons #\B (lambda (date pad-with port)
- (display (locale-long-month (date-month date))
- port)))
- (cons #\c (lambda (date pad-with port)
- (display (date->string date locale-date-time-format) port)))
- (cons #\d (lambda (date pad-with port)
- (display (padding (date-day date)
- #\0 2)
- port)))
- (cons #\D (lambda (date pad-with port)
- (display (date->string date "~m/~d/~y") port)))
- (cons #\e (lambda (date pad-with port)
- (display (padding (date-day date)
- #\Space 2)
- port)))
- (cons #\f (lambda (date pad-with port)
- (if (> (date-nanosecond date)
- nano)
- (display (padding (+ (date-second date) 1)
- pad-with 2)
- port)
- (display (padding (date-second date)
- pad-with 2)
- port))
- (receive (i f)
- (split-real (/
- (date-nanosecond date)
- nano 1.0))
- (let* ((ns (number->string f))
- (le (string-length ns)))
- (if (> le 2)
- (begin
- (display (locale-decimal-point) port)
- (display (substring ns 2 le) port)))))))
- (cons #\h (lambda (date pad-with port)
- (display (date->string date "~b") port)))
- (cons #\H (lambda (date pad-with port)
- (display (padding (date-hour date)
- pad-with 2)
- port)))
- (cons #\I (lambda (date pad-with port)
- (let ((hr (date-hour date)))
- (if (> hr 12)
- (display (padding (- hr 12)
- pad-with 2)
- port)
- (display (padding hr
- pad-with 2)
- port)))))
- (cons #\j (lambda (date pad-with port)
- (display (padding (date-year-day date)
- pad-with 3)
- port)))
- (cons #\k (lambda (date pad-with port)
- (display (padding (date-hour date)
- #\Space 2)
- port)))
- (cons #\l (lambda (date pad-with port)
- (let ((hr (if (> (date-hour date) 12)
- (- (date-hour date) 12) (date-hour date))))
- (display (padding hr #\Space 2)
- port))))
- (cons #\m (lambda (date pad-with port)
- (display (padding (date-month date)
- pad-with 2)
- port)))
- (cons #\M (lambda (date pad-with port)
- (display (padding (date-minute date)
- pad-with 2)
- port)))
- (cons #\n (lambda (date pad-with port)
- (newline port)))
- (cons #\N (lambda (date pad-with port)
- (display (padding (date-nanosecond date)
- pad-with 7)
- port)))
- (cons #\p (lambda (date pad-with port)
- (display (locale-am-string/pm (date-hour date)) port)))
- (cons #\r (lambda (date pad-with port)
- (display (date->string date "~I:~M:~S ~p") port)))
- (cons #\s (lambda (date pad-with port)
- (display (time-second (date->time-utc date)) port)))
- (cons #\S (lambda (date pad-with port)
- (if (> (date-nanosecond date)
- nano)
- (display (padding (+ (date-second date) 1)
- pad-with 2)
- port)
- (display (padding (date-second date)
- pad-with 2)
- port))))
- (cons #\t (lambda (date pad-with port)
- (display #\Tab port)))
- (cons #\T (lambda (date pad-with port)
- (display (date->string date "~H:~M:~S") port)))
- (cons #\U (lambda (date pad-with port)
- (if (> (days-before-first-week date 0) 0)
- (display (padding (+ (date-week-number date 0) 1)
- #\0 2) port)
- (display (padding (date-week-number date 0)
- #\0 2) port))))
- (cons #\V (lambda (date pad-with port)
- (display (padding (date-week-number date 1)
- #\0 2) port)))
- (cons #\w (lambda (date pad-with port)
- (display (date-week-day date) port)))
- (cons #\x (lambda (date pad-with port)
- (display (date->string date locale-short-date-format) port)))
- (cons #\X (lambda (date pad-with port)
- (display (date->string date locale-time-format) port)))
- (cons #\W (lambda (date pad-with port)
- (if (> (days-before-first-week date 1) 0)
- (display (padding (+ (date-week-number date 1) 1)
- #\0 2) port)
- (display (padding (date-week-number date 1)
- #\0 2) port))))
- (cons #\y (lambda (date pad-with port)
- (display (padding (last-n-digits
- (date-year date) 2)
- pad-with
- 2)
- port)))
- (cons #\Y (lambda (date pad-with port)
- (display (date-year date) port)))
- (cons #\z (lambda (date pad-with port)
- (tz-printer (date-zone-offset date) port)))
- (cons #\Z (lambda (date pad-with port)
- (locale-print-time-zone date port)))
- (cons #\1 (lambda (date pad-with port)
- (display (date->string date "~Y-~m-~d") port)))
- (cons #\2 (lambda (date pad-with port)
- (display (date->string date "~H:~M:~S~z") port)))
- (cons #\3 (lambda (date pad-with port)
- (display (date->string date "~H:~M:~S") port)))
- (cons #\4 (lambda (date pad-with port)
- (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
- (cons #\5 (lambda (date pad-with port)
- (display (date->string date "~Y-~m-~dT~H:~M:~S") port)))))
- (define (get-formatter char)
- (let ((associated (assoc char directives)))
- (if associated (cdr associated) #f)))
- (define (date-printer date index format-string str-len port)
- (if (< index str-len)
- (let ((current-char (string-ref format-string index)))
- (if (not (char=? current-char #\~))
- (begin
- (display current-char port)
- (date-printer date (+ index 1) format-string str-len port))
- (if (= (+ index 1) str-len)
- (time-error 'date-printer 'bad-date-format-string
- format-string)
- (let ((pad-char? (string-ref format-string (+ index 1))))
- (cond
- ((char=? pad-char? #\-)
- (if (= (+ index 2) str-len)
- (time-error 'date-printer
- 'bad-date-format-string
- format-string)
- (let ((formatter (get-formatter
- (string-ref format-string
- (+ index 2)))))
- (if (not formatter)
- (time-error 'date-printer
- 'bad-date-format-string
- format-string)
- (begin
- (formatter date #f port)
- (date-printer date
- (+ index 3)
- format-string
- str-len
- port))))))
- ((char=? pad-char? #\_)
- (if (= (+ index 2) str-len)
- (time-error 'date-printer
- 'bad-date-format-string
- format-string)
- (let ((formatter (get-formatter
- (string-ref format-string
- (+ index 2)))))
- (if (not formatter)
- (time-error 'date-printer
- 'bad-date-format-string
- format-string)
- (begin
- (formatter date #\Space port)
- (date-printer date
- (+ index 3)
- format-string
- str-len
- port))))))
- (else
- (let ((formatter (get-formatter
- (string-ref format-string
- (+ index 1)))))
- (if (not formatter)
- (time-error 'date-printer
- 'bad-date-format-string
- format-string)
- (begin
- (formatter date #\0 port)
- (date-printer date
- (+ index 2)
- format-string
- str-len
- port))))))))))))
- (define (date->string date . format-string)
- (let ((str-port (open-output-string))
- (fmt-str (if (null? format-string) "~c" (car format-string))))
- (date-printer date 0 fmt-str (string-length fmt-str) str-port)
- (get-output-string str-port)))
- (define (char->int ch)
- (case ch
- ((#\0) 0)
- ((#\1) 1)
- ((#\2) 2)
- ((#\3) 3)
- ((#\4) 4)
- ((#\5) 5)
- ((#\6) 6)
- ((#\7) 7)
- ((#\8) 8)
- ((#\9) 9)
- (else (time-error 'char->int 'bad-date-template-string
- (list "Non-integer character" ch)))))
- (define (integer-reader upto port)
- (let loop ((accum 0) (nchars 0))
- (let ((ch (peek-char port)))
- (if (or (eof-object? ch)
- (not (char-numeric? ch))
- (and upto (>= nchars upto)))
- accum
- (loop (+ (* accum 10) (char->int (read-char port)))
- (+ nchars 1))))))
- (define (make-integer-reader upto)
- (lambda (port)
- (integer-reader upto port)))
- (define (integer-reader-exact n port)
- (let ((padding-ok #t))
- (define (accum-int port accum nchars)
- (let ((ch (peek-char port)))
- (cond
- ((>= nchars n) accum)
- ((eof-object? ch)
- (time-error 'string->date 'bad-date-template-string
- "Premature ending to integer read."))
- ((char-numeric? ch)
- (set! padding-ok #f)
- (accum-int port
- (+ (* accum 10) (char->int (read-char port)))
- (+ nchars 1)))
- (padding-ok
- (read-char port)
- (accum-int port accum (+ nchars 1)))
- (else
- (time-error 'string->date 'bad-date-template-string
- "Non-numeric characters in integer read.")))))
- (accum-int port 0 0)))
- (define (make-integer-exact-reader n)
- (lambda (port)
- (integer-reader-exact n port)))
- (define (zone-reader port)
- (let ((offset 0)
- (positive? #f))
- (let ((ch (read-char port)))
- (if (eof-object? ch)
- (time-error 'string->date 'bad-date-template-string
- (list "Invalid time zone +/-" ch)))
- (if (or (char=? ch #\Z) (char=? ch #\z))
- 0
- (begin
- (cond
- ((char=? ch #\+) (set! positive? #t))
- ((char=? ch #\-) (set! positive? #f))
- (else
- (time-error 'string->date 'bad-date-template-string
- (list "Invalid time zone +/-" ch))))
- (let ((ch (read-char port)))
- (if (eof-object? ch)
- (time-error 'string->date 'bad-date-template-string
- (list "Invalid time zone number" ch)))
- (set! offset (* (char->int ch)
- 10 60 60)))
- (let ((ch (read-char port)))
- (if (eof-object? ch)
- (time-error 'string->date 'bad-date-template-string
- (list "Invalid time zone number" ch)))
- (set! offset (+ offset (* (char->int ch)
- 60 60))))
- (let ((ch (read-char port)))
- (if (eof-object? ch)
- (time-error 'string->date 'bad-date-template-string
- (list "Invalid time zone number" ch)))
- (set! offset (+ offset (* (char->int ch)
- 10 60))))
- (let ((ch (read-char port)))
- (if (eof-object? ch)
- (time-error 'string->date 'bad-date-template-string
- (list "Invalid time zone number" ch)))
- (set! offset (+ offset (* (char->int ch)
- 60))))
- (if positive? offset (- offset)))))))
- (define (locale-reader port indexer)
- (define (read-char-string result)
- (let ((ch (peek-char port)))
- (if (char-alphabetic? ch)
- (read-char-string (cons (read-char port) result))
- (list->string (reverse! result)))))
- (let* ((str (read-char-string '()))
- (index (indexer str)))
- (if index index (time-error 'string->date
- 'bad-date-template-string
- (list "Invalid string for " indexer)))))
- (define (make-locale-reader indexer)
- (lambda (port)
- (locale-reader port indexer)))
- (define (make-char-id-reader char)
- (lambda (port)
- (if (char=? char (read-char port))
- char
- (time-error 'string->date
- 'bad-date-template-string
- "Invalid character match."))))
- (define read-directives
- (let ((ireader4 (make-integer-reader 4))
- (ireader2 (make-integer-reader 2))
- (eireader2 (make-integer-exact-reader 2))
- (locale-reader-abbr-weekday (make-locale-reader
- locale-abbr-weekday->index))
- (locale-reader-long-weekday (make-locale-reader
- locale-long-weekday->index))
- (locale-reader-abbr-month (make-locale-reader
- locale-abbr-month->index))
- (locale-reader-long-month (make-locale-reader
- locale-long-month->index))
- (char-fail (lambda (ch) #t)))
- (list
- (list #\~ char-fail (make-char-id-reader #\~) #f)
- (list #\a char-alphabetic? locale-reader-abbr-weekday #f)
- (list #\A char-alphabetic? locale-reader-long-weekday #f)
- (list #\b char-alphabetic? locale-reader-abbr-month
- (lambda (val object)
- (set-date-month! object val)))
- (list #\B char-alphabetic? locale-reader-long-month
- (lambda (val object)
- (set-date-month! object val)))
- (list #\d char-numeric? ireader2 (lambda (val object)
- (set-date-day!
- object val)))
- (list #\e char-fail eireader2 (lambda (val object)
- (set-date-day! object val)))
- (list #\h char-alphabetic? locale-reader-abbr-month
- (lambda (val object)
- (set-date-month! object val)))
- (list #\H char-numeric? ireader2 (lambda (val object)
- (set-date-hour! object val)))
- (list #\k char-fail eireader2 (lambda (val object)
- (set-date-hour! object val)))
- (list #\m char-numeric? ireader2 (lambda (val object)
- (set-date-month! object val)))
- (list #\M char-numeric? ireader2 (lambda (val object)
- (set-date-minute!
- object val)))
- (list #\S char-numeric? ireader2 (lambda (val object)
- (set-date-second! object val)))
- (list #\y char-fail eireader2
- (lambda (val object)
- (set-date-year! object (natural-year val))))
- (list #\Y char-numeric? ireader4 (lambda (val object)
- (set-date-year! object val)))
- (list #\z (lambda (c)
- (or (char=? c #\Z)
- (char=? c #\z)
- (char=? c #\+)
- (char=? c #\-)))
- zone-reader (lambda (val object)
- (set-date-zone-offset! object val))))))
- (define (priv:string->date date index format-string str-len port template-string)
- (define (skip-until port skipper)
- (let ((ch (peek-char port)))
- (if (eof-object? ch)
- (time-error 'string->date 'bad-date-format-string template-string)
- (if (not (skipper ch))
- (begin (read-char port) (skip-until port skipper))))))
- (if (< index str-len)
- (let ((current-char (string-ref format-string index)))
- (if (not (char=? current-char #\~))
- (let ((port-char (read-char port)))
- (if (or (eof-object? port-char)
- (not (char=? current-char port-char)))
- (time-error 'string->date
- 'bad-date-format-string template-string))
- (priv:string->date date
- (+ index 1)
- format-string
- str-len
- port
- template-string))
-
- (if (> (+ index 1) str-len)
- (time-error 'string->date
- 'bad-date-format-string template-string)
- (let* ((format-char (string-ref format-string (+ index 1)))
- (format-info (assoc format-char read-directives)))
- (if (not format-info)
- (time-error 'string->date
- 'bad-date-format-string template-string)
- (begin
- (let ((skipper (cadr format-info))
- (reader (caddr format-info))
- (actor (cadddr format-info)))
- (skip-until port skipper)
- (let ((val (reader port)))
- (if (eof-object? val)
- (time-error 'string->date
- 'bad-date-format-string
- template-string)
- (if actor (actor val date))))
- (priv:string->date date
- (+ index 2)
- format-string
- str-len
- port
- template-string))))))))))
- (define (string->date input-string template-string)
- (define (date-ok? date)
- (and (date-nanosecond date)
- (date-second date)
- (date-minute date)
- (date-hour date)
- (date-day date)
- (date-month date)
- (date-year date)
- (date-zone-offset date)))
- (let ((newdate (make-date 0 0 0 0 #f #f #f #f)))
- (priv:string->date newdate
- 0
- template-string
- (string-length template-string)
- (open-input-string input-string)
- template-string)
- (if (not (date-zone-offset newdate))
- (begin
-
-
-
- (set-date-zone-offset! newdate
- (local-tz-offset
- (make-time time-utc 0 0)))
- (set-date-zone-offset! newdate
- (local-tz-offset
- (date->time-utc newdate)))))
- (if (date-ok? newdate)
- newdate
- (time-error
- 'string->date
- 'bad-date-format-string
- (list "Incomplete date read. " newdate template-string)))))
|