[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: SRFI-19: Minor refactor of leap second table look
From: |
Mark H. Weaver |
Subject: |
[Guile-commits] 02/02: SRFI-19: Minor refactor of leap second table lookups. |
Date: |
Wed, 24 Oct 2018 01:16:15 -0400 (EDT) |
mhw pushed a commit to branch stable-2.2
in repository guile.
commit 9f285187fe228563abaf44774c61b461cc12559a
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))