[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 25/55: SRFI-19: Minor refactor of leap second table look
From: |
Andy Wingo |
Subject: |
[Guile-commits] 25/55: SRFI-19: Minor refactor of leap second table lookups. |
Date: |
Thu, 23 May 2019 11:52:40 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit f13e2cb8ada7f027b517e74094ee170ed127c8b3
Author: Mark H Weaver <address@hidden>
Date: Mon Oct 22 20:19:39 2018 -0400
SRFI-19: Minor refactor of leap second table lookups.
* module/srfi/srfi-19.scm (leap-second-delta): Replace with ...
(utc->tai): ... this.
(leap-second-neg-delta): Replace with ...
(tai->utc): ... this.
(current-time-tai, priv:time-tai->time-utc!, priv:time-utc->time-tai!)
(time-tai->julian-day, time-monotonic->julian-day): Adapt accordingly.
---
module/srfi/srfi-19.scm | 50 ++++++++++++++++++++++---------------------------
1 file changed, 22 insertions(+), 28 deletions(-)
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index 5ab5d89..46de91a 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -237,23 +237,23 @@
(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))))
-
-;; going from tai seconds to utc seconds ...
-(define (leap-second-neg-delta tai-seconds)
- (letrec ((lsd (lambda (table)
- (cond ((null? table) 0)
- ((>= tai-seconds (+ (caar table) (cdar table)))
- (cdar table))
- (else (lsd (cdr table)))))) )
- (if (< tai-seconds (* (- 1972 1970) 365 sid)) 0
- (lsd leap-second-table))))
+(define (utc->tai utc-seconds)
+ (let loop ((table leap-second-table))
+ (cond ((null? table)
+ utc-seconds)
+ ((>= utc-seconds (caar table))
+ (+ utc-seconds (cdar table)))
+ (else
+ (loop (cdr table))))))
+
+(define (tai->utc tai-seconds)
+ (let loop ((table leap-second-table))
+ (cond ((null? table)
+ tai-seconds)
+ ((>= tai-seconds (+ (caar table) (cdar table)))
+ (- tai-seconds (cdar table)))
+ (else
+ (loop (cdr table))))))
;;; the TIME structure; creates the accessors, too.
@@ -311,7 +311,7 @@
(usec (cdr tod)))
(make-time time-tai
(* usec 1000)
- (+ (car tod) (leap-second-delta sec)))))
+ (utc->tai sec))))
;;(define (current-time-ms-time time-type proc)
;; (let ((current-ms (proc)))
@@ -462,9 +462,7 @@
(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-neg-delta
- (time-second time-in))))
+ (set-time-second! time-out (tai->utc (time-second time-in)))
time-out)
(define (time-tai->time-utc time-in)
@@ -479,9 +477,7 @@
(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))))
+ (set-time-second! time-out (utc->tai (time-second time-in)))
time-out)
(define (time-utc->time-tai time-in)
@@ -811,8 +807,7 @@
(define (time-tai->julian-day time)
(if (not (eq? (time-type time) time-tai))
(time-error 'time-tai->julian-day 'incompatible-time-types time))
- (+ (/ (+ (- (time-second time)
- (leap-second-neg-delta (time-second time)))
+ (+ (/ (+ (tai->utc (time-second time))
(/ (time-nanosecond time) nano))
sid)
tai-epoch-in-jd))
@@ -825,8 +820,7 @@
(define (time-monotonic->julian-day time)
(if (not (eq? (time-type time) time-monotonic))
(time-error 'time-monotonic->julian-day 'incompatible-time-types time))
- (+ (/ (+ (- (time-second time)
- (leap-second-neg-delta (time-second time)))
+ (+ (/ (+ (tai->utc (time-second time))
(/ (time-nanosecond time) nano))
sid)
tai-epoch-in-jd))
- [Guile-commits] 44/55: Avoid passing NULL to 'memcpy' and 'memcmp'., (continued)
- [Guile-commits] 44/55: Avoid passing NULL to 'memcpy' and 'memcmp'., Andy Wingo, 2019/05/23
- [Guile-commits] 14/55: Fix typos, indentation and error reporting in SRFI-19., Andy Wingo, 2019/05/23
- [Guile-commits] 54/55: Strings, i18n: Limit the use of alloca to approximately 8 kilobytes., Andy Wingo, 2019/05/23
- [Guile-commits] 49/55: Fix typo in comment., Andy Wingo, 2019/05/23
- [Guile-commits] 47/55: Reimplement SCM_MAKE_CHAR to evaluate its argument only once., Andy Wingo, 2019/05/23
- [Guile-commits] 51/55: Avoid 'with-latin1-locale' in binary I/O tests., Andy Wingo, 2019/05/23
- [Guile-commits] 15/55: Use 'scm_from_utf8_{string, symbol, keyword}' for C string literals., Andy Wingo, 2019/05/23
- [Guile-commits] 23/55: SRFI-19: Check for incompatible types in time comparisons., Andy Wingo, 2019/05/23
- [Guile-commits] 34/55: Don't mutate read-only string in ports test, Andy Wingo, 2019/05/23
- [Guile-commits] 36/55: Fix strftime compile with null threads, Andy Wingo, 2019/05/23
- [Guile-commits] 25/55: SRFI-19: Minor refactor of leap second table lookups.,
Andy Wingo <=
- [Guile-commits] 45/55: Update user-visible copyright years., Andy Wingo, 2019/05/23
- [Guile-commits] 46/55: Fix gc.test "after-gc-hook gets called" failures., Andy Wingo, 2019/05/23
- [Guile-commits] 55/55: Update iconv.m4 from gnulib., Andy Wingo, 2019/05/23
- [Guile-commits] 50/55: Fix indentation in scm_sum., Andy Wingo, 2019/05/23
- [Guile-commits] 48/55: Add 'scm_c_make_char' and use it where appropriate., Andy Wingo, 2019/05/23
- [Guile-commits] 07/55: Improve the documentation for 'nil?'., Andy Wingo, 2019/05/23
- [Guile-commits] 17/55: Fix typo in strings.h., Andy Wingo, 2019/05/23
- [Guile-commits] 18/55: scm_seed_to_random_state: Support wide string arguments., Andy Wingo, 2019/05/23
- [Guile-commits] 35/55: Remove redefinition of when & unless in snarf-check-and-output-texi, Andy Wingo, 2019/05/23
- [Guile-commits] 41/55: Make locale monetary conversion tests be less strict on terminal whitespace, Andy Wingo, 2019/05/23