From adfcb5ee624d457a8dae33e8e122cbff6d4a1428 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2018 00:42:12 -0400 Subject: [PATCH 2/2] SRFI-19: Implement correct TAI<->UTC conversions for 1961-1971. * module/srfi/srfi-19.scm (tai-utc-1961-1971-table): New variable. (pre-1972-utc->tai, pre-1972-tai->utc): New procedures. (utc->tai, tai->utc): Use the new procedures. --- module/srfi/srfi-19.scm | 58 +++++++++++++++++++++++++++++++++++++++-- 1 file changed, 56 insertions(+), 2 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index f653b1bc3..d4afa1931 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -240,7 +240,7 @@ (define (utc->tai ns utc-seconds) (let loop ((table leap-second-table)) (cond ((null? table) - (values ns utc-seconds)) + (pre-1972-utc->tai ns utc-seconds)) ((>= utc-seconds (caar table)) (values ns (+ utc-seconds (cdar table)))) (else @@ -249,13 +249,67 @@ (define (tai->utc ns tai-seconds) (let loop ((table leap-second-table)) (cond ((null? table) - (values ns tai-seconds)) + (pre-1972-tai->utc ns tai-seconds)) ((>= tai-seconds (+ (caar table) (cdar table))) (values ns (- tai-seconds (cdar table)))) (else (loop (cdr table)))))) +(define tai-utc-1961-1971-table + ;; UTC start delta@start slope + ;; (ns) (ns) (ns/s) + '(( -60480000000000000 6185682000 30) + (-126230400000000000 4313170000 30) + (-136771200000000000 4155058000 15) + (-142128000000000000 3974706000 15) + (-152668800000000000 3716594000 15) + (-157766400000000000 3540130000 15) + (-168307200000000000 3282018000 15) + (-181526400000000000 2983730000 15) + (-189388800000000000 2765794000 15) + (-194659200000000000 2697278800 13) + (-252460800000000000 1845858000 13) + (-265680000000000000 1647570000 15) + (-283996800000000000 1422818000 15))) + +(define (pre-1972-utc->tai ns utc-seconds) + (let ((utc-ns (+ ns (* nano utc-seconds)))) + (let loop ((table tai-utc-1961-1971-table)) + (cond ((null? table) + (values ns utc-seconds)) + ((>= utc-ns (caar table)) + (apply (lambda (utc-start delta@start slope) + (let ((tai-ns (+ utc-ns + delta@start + (round-quotient (* slope (- utc-ns + utc-start)) + nano)))) + (values (truncate-remainder tai-ns nano) + (truncate-quotient tai-ns nano)))) + (car table))) + (else + (loop (cdr table))))))) + +(define (pre-1972-tai->utc ns tai-seconds) + (let ((tai-ns (+ ns (* nano tai-seconds)))) + (let loop ((table tai-utc-1961-1971-table)) + (cond ((null? table) + (values ns tai-seconds)) + ((>= tai-ns (+ (caar table) (cadar table))) + (apply (lambda (utc-start delta@start slope) + (let ((utc-ns (+ utc-start + (round-quotient (* nano (- tai-ns + utc-start + delta@start)) + (+ nano slope))))) + (values (truncate-remainder utc-ns nano) + (truncate-quotient utc-ns nano)))) + (car table))) + (else + (loop (cdr table))))))) + + ;;; the TIME structure; creates the accessors, too. (define-record-type time -- 2.19.1