mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 20:20:24 +02:00
Code Activity

SRFI-19: Minor refactor of leap second table lookups.

Browse source 
* 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.
This commit is contained in:
Mark H Weaver 2018-10-22 20:19:39 -04:00
parent ac1fa8dba4
commit 9f285187fe
1 changed files with 21 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

48
module/srfi/srfi-19.scm
View file

@ -237,23 +237,23 @@
(set! leap-second-table (read-tai-utc-data filename))) (set! leap-second-table (read-tai-utc-data filename)))
(define (leap-second-delta utc-seconds) (define (utc->tai utc-seconds)
(letrec ((lsd (lambda (table) (let loop ((table leap-second-table))
(cond ((>= utc-seconds (caar table)) (cond ((null? table)
(cdar table)) utc-seconds)
(else (lsd (cdr table))))))) ((>= utc-seconds (caar table))
(if (< utc-seconds (* (- 1972 1970) 365 sid)) 0 (+ utc-seconds (cdar table)))
(lsd leap-second-table)))) (else
(loop (cdr table))))))
;; going from tai seconds to utc seconds ... (define (tai->utc tai-seconds)
(define (leap-second-neg-delta tai-seconds) (let loop ((table leap-second-table))
(letrec ((lsd (lambda (table) (cond ((null? table)
(cond ((null? table) 0) tai-seconds)
((>= tai-seconds (+ (caar table) (cdar table))) ((>= tai-seconds (+ (caar table) (cdar table)))
(cdar table)) (- tai-seconds (cdar table)))
(else (lsd (cdr table)))))) ) (else
(if (< tai-seconds (* (- 1972 1970) 365 sid)) 0 (loop (cdr table))))))
(lsd leap-second-table))))
;;; the TIME structure; creates the accessors, too. ;;; the TIME structure; creates the accessors, too.
@ -311,7 +311,7 @@
(usec (cdr tod))) (usec (cdr tod)))
(make-time time-tai (make-time time-tai
(* usec 1000) (* usec 1000)
(+ (car tod) (leap-second-delta sec))))) (utc->tai sec))))
;;(define (current-time-ms-time time-type proc) ;;(define (current-time-ms-time time-type proc)
;; (let ((current-ms (proc))) ;; (let ((current-ms (proc)))
@ -462,9 +462,7 @@
(time-error caller 'incompatible-time-types time-in)) (time-error caller 'incompatible-time-types time-in))
(set-time-type! time-out time-utc) (set-time-type! time-out time-utc)
(set-time-nanosecond! time-out (time-nanosecond time-in)) (set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (- (time-second time-in) (set-time-second! time-out (tai->utc (time-second time-in)))
(leap-second-neg-delta
(time-second time-in))))
time-out) time-out)
(define (time-tai->time-utc time-in) (define (time-tai->time-utc time-in)
@ -479,9 +477,7 @@
(time-error caller 'incompatible-time-types time-in)) (time-error caller 'incompatible-time-types time-in))
(set-time-type! time-out time-tai) (set-time-type! time-out time-tai)
(set-time-nanosecond! time-out (time-nanosecond time-in)) (set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (+ (time-second time-in) (set-time-second! time-out (utc->tai (time-second time-in)))
(leap-second-delta
(time-second time-in))))
time-out) time-out)
(define (time-utc->time-tai time-in) (define (time-utc->time-tai time-in)
@ -811,8 +807,7 @@
(define (time-tai->julian-day time) (define (time-tai->julian-day time)
(if (not (eq? (time-type time) time-tai)) (if (not (eq? (time-type time) time-tai))
(time-error 'time-tai->julian-day 'incompatible-time-types time)) (time-error 'time-tai->julian-day 'incompatible-time-types time))
(+ (/ (+ (- (time-second time) (+ (/ (+ (tai->utc (time-second time))
(leap-second-neg-delta (time-second time)))
(/ (time-nanosecond time) nano)) (/ (time-nanosecond time) nano))
sid) sid)
tai-epoch-in-jd)) tai-epoch-in-jd))
@ -825,8 +820,7 @@
(define (time-monotonic->julian-day time) (define (time-monotonic->julian-day time)
(if (not (eq? (time-type time) time-monotonic)) (if (not (eq? (time-type time) time-monotonic))
(time-error 'time-monotonic->julian-day 'incompatible-time-types time)) (time-error 'time-monotonic->julian-day 'incompatible-time-types time))
(+ (/ (+ (- (time-second time) (+ (/ (+ (tai->utc (time-second time))
(leap-second-neg-delta (time-second time)))
(/ (time-nanosecond time) nano)) (/ (time-nanosecond time) nano))
sid) sid)
tai-epoch-in-jd)) tai-epoch-in-jd))