;; Copyright (c) 2012 Alan Watson. All rights reserved. BSD-style
;; license: http://synthcode.com/license.txt
;; This library implements procedures that give the TAI to UTC offset a
;; specified instant in the UTC or TAI timescales.
(define-library (scheme time tai-to-utc-offset)
(export tai-to-utc-offset-at-utc-day
tai-to-utc-offset-at-tai-second
set-open-leap-seconds-list-port!
set-update-exception-handler!)
(import (scheme base))
(import (scheme file))
(import (scheme read))
(import (scheme process-context))
(cond-expand
(threads
(import (srfi 18)))
(else
(begin
(define (make-thread thunk name) #f)
(define (thread-start! th) #f)
(define (thread-sleep! secs) #f))))
(cond-expand
(chibi
(begin
(define *file-name-environment-variable* "SEXP_LEAP_SECONDS_LIST_FILE")))
(else
(begin
(error "Need to define *file-name-environment-variable*."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cond-expand
;; We ensure thread-safe atomic access to mutated bindings using
;; atomic boxes.
(chibi
(begin
;; This implementation relies on record accessors and mutators
;; being atomic in Chibi Scheme.
(define-record-type atomic-box-record-type
(make-atomic-box value)
atomic-box?
(value atomic-box-value atomic-box-value-set!))))
(else
(begin
;; This implementation uses SRFI-18 mutexes.
(define (make-atomic-box value)
(let ((mutex (make-mutex)))
(mutex-specific-set! mutex value)
mutex))
(define atomic-box? mutex?)
(define (atomic-box-value mutex)
(mutex-lock! mutex)
(let ((value (mutex-specific mutex)))
(mutex-unlock! mutex)
value))
(define (atomic-box-value-set! mutex value)
(mutex-lock! mutex)
(mutex-specific-set! mutex value)
(mutex-unlock! mutex)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(begin
(define seconds-per-day 86400)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; First, a remark on timescales.
;;
;; The TAI timescale used in this library has an epoch of 1970-01-01
;; 00:00:00 TAI. The epoch used by the current-second procedure in
;; the draft R7RS (scheme time) library is the "TAI-10" timescale
;; with an epoch of 1970-01-01 00:00:10 TAI.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The library maintains a cache of values derived from the leap
;; seconds list.
;;
;; The first cached value is the utc-day-alist. This is an alist
;; whose cars are the UTC days since 1970-01-01 00:00:00 UTC and
;; whose cdrs are the corresponding TAI to UTC offsets.
;;
;; The second cached value is the tai-second-alist. This is an alist
;; whose cars are the TAI seconds since 1970-01-01 00:00:00 TAI and
;; whose cdrs are the corresponding TAI to UTC offsets.
(define-record-type cache-record-type
(make-cache utc-day-alist tai-second-alist)
cache?
(utc-day-alist cache-utc-day-alist)
(tai-second-alist cache-tai-second-alist))
(define (make-cache-from-port port)
(let ((utc-day-alist (read-leap-seconds-list port)))
(make-cache utc-day-alist
(utc-day-alist->tai-second-alist utc-day-alist))))
;; The utc-day-alist->tai-second-alist procedure converts an alist
;; indexed by the number of UTC day since 1970-01-01 00:00:00 UTC
;; into an equivalent alist indexed by the number of TAI seconds
;; since 1970-01-01 00:00:00 TAI.
;;
;; This procedure does not have to worry about the complications of
;; transforming UTC dates prior to 1972-01-01 00:00:00 UTC to TAI,
;; since there were no leap seconds prior to this date.
(define (utc-day-alist->tai-second-alist utc-day-alist)
(map
(lambda (p)
(let* ((utc-day (car p))
(leap-seconds (cdr p))
(tai-second (+ (* utc-day seconds-per-day) leap-seconds)))
(cons tai-second leap-seconds)))
utc-day-alist))
;; The library updates the cache: when the library is loaded; when
;; the set-open-leap-seconds-list-port! is called; and once per day.
;; These automatic periodic updates are useful in long-running
;; programs.
;;
;; The choice of daily updates is motivated by the following
;; considerations. ITU-R TF.460-6, which contains the current
;; definition of UTC, requires that the IERS should announce leap
;; seconds with at least eight weeks in advance. However, NIST,
;; which maintains the leap-seconds.list file, only guarantees one
;; month. Recently the IERS and NIST have managed six months of
;; notice, but we should not rely on this.
;;
;; During updates, we install the update-exception-handler.
(define *cache-lifetime* (* 1 seconds-per-day))
(define (update-cache! open-port)
(with-exception-handler
(update-exception-handler)
(lambda ()
(let ((port (open-port)))
(when port
(set-cache! (make-cache-from-port port)))))))
(thread-start!
(make-thread
(lambda ()
(let loop ()
(thread-sleep! *cache-lifetime*)
(update-cache! (open-leap-seconds-list-port))
(loop)))
"leap-second-update-poll"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The read-leap-seconds-list procedure reads text from the port
;; argument. The text must follow the format of a NIST leap seconds
;; file, for example,
;;
;; ftp://time.nist.gov/pub/leap-seconds.list
;;
;; The procedure returns an alist. The cars of the pairs are the
;; number of whole UTC days since 1970-01-01 00:00:00 UTC and the
;; cdrs of the pairs are the corresponding TAI to UTC offset. The
;; alist is ordered by decreasing car. The cars and cdrs are exact
;; integers.
;;
;; TODO: Do not rely on the input file being correctly ordered. Do
;; not rely on the input data being exact integers.
;;
;; TODO: Check known leap seconds.
(define (read-leap-seconds-list port)
(define (ntp-second->utc-day ntp-second)
;; The NTP initial epoch is 1900-01-01 00:00:00 UTC. The UTC
;; initial epoch is 1970-01-01 00:00:00 UTC. There are 70 years,
;; containing 17 leap days, between these epochs.
(- (quotient ntp-second seconds-per-day) (* 70 365) 17))
(define (leap-seconds-line->pair line)
(let* ((line-port (open-input-string line))
(ntp-second (read line-port))
(tai-to-utc-offset (read line-port))
(utc-day (ntp-second->utc-day ntp-second))
(leap-seconds tai-to-utc-offset))
(cons utc-day leap-seconds)))
(define (leap-seconds-comment-line? line)
(char=? #\# (string-ref line 0)))
(define (read-leap-seconds-line port)
(let ((line (read-line port)))
(cond
((eof-object? line) line)
((leap-seconds-comment-line? line) (read-leap-seconds-line port))
(else line))))
(let loop ((alist '()))
(let ((line (read-leap-seconds-line port)))
(if (eof-object? line)
alist
(loop (cons (leap-seconds-line->pair line) alist))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (set-open-leap-seconds-list-port! p)
;;
;; The set-open-leap-seconds-list-port! procedure sets the value of
;; procedure called to obtain the leap second list is read to its
;; argument p and then performs a cache update. The procedure should
;; return either #f, signifying that no leap second list is
;; available, or an input port, from which a leap-second list,
;; following the format of the NIST leap-second list, will be read.
;; The NIST leap-second file can be found here:
;;
;; ftp://time.nist.gov/pub/leap-seconds.list
;;
;; The default procedure attempts to open the file named by the
;; environment variable SEXP_LEAP_SECOND_LIST_FILE and returns the
;; port. If the environment variable is not set or if the file does
;; not exist, it return #f.
(define *open-leap-seconds-list-port*
(make-atomic-box
(lambda ()
(when *file-name-environment-variable*
(let ((file-name
(get-environment-variable *file-name-environment-variable*)))
(if file-name
(open-input-file file-name)
#f))))))
(define (open-leap-seconds-list-port)
(atomic-box-value *open-leap-seconds-list-port*))
(define (set-open-leap-seconds-list-port! p)
(atomic-box-value-set! *open-leap-seconds-list-port* p)
(update-cache! (open-leap-seconds-list-port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (set-update-exception-handler! p)
;;
;; The set-update-exception-handler! procedure sets the value of the
;; error handler installed during cache updates. The default error
;; handler simply raises the exception again.
(define *update-exception-handler*
(make-atomic-box raise))
(define (update-exception-handler)
(atomic-box-value *update-exception-handler*))
(define (set-update-exception-handler! p)
(atomic-box-value-set! *update-exception-handler* p))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *cache*
(make-atomic-box #f))
(define (cache)
(atomic-box-value *cache*))
(define (set-cache! value)
(atomic-box-value-set! *cache* value))
(update-cache!
(lambda ()
(open-input-string
(string-append
;; These strings are lines extracted from:
;;
;; ftp://time.nist.gov/pub/leap-seconds.3535228800
;;
;; The original file contains extensive comments on the format
;; and provenance of the data, which have been removed from
;; this version.
"2272060800 10 # 1 Jan 1972\n"
"2287785600 11 # 1 Jul 1972\n"
"2303683200 12 # 1 Jan 1973\n"
"2335219200 13 # 1 Jan 1974\n"
"2366755200 14 # 1 Jan 1975\n"
"2398291200 15 # 1 Jan 1976\n"
"2429913600 16 # 1 Jan 1977\n"
"2461449600 17 # 1 Jan 1978\n"
"2492985600 18 # 1 Jan 1979\n"
"2524521600 19 # 1 Jan 1980\n"
"2571782400 20 # 1 Jul 1981\n"
"2603318400 21 # 1 Jul 1982\n"
"2634854400 22 # 1 Jul 1983\n"
"2698012800 23 # 1 Jul 1985\n"
"2776982400 24 # 1 Jan 1988\n"
"2840140800 25 # 1 Jan 1990\n"
"2871676800 26 # 1 Jan 1991\n"
"2918937600 27 # 1 Jul 1992\n"
"2950473600 28 # 1 Jul 1993\n"
"2982009600 29 # 1 Jul 1994\n"
"3029443200 30 # 1 Jan 1996\n"
"3076704000 31 # 1 Jul 1997\n"
"3124137600 32 # 1 Jan 1999\n"
"3345062400 33 # 1 Jan 2006\n"
"3439756800 34 # 1 Jan 2009\n"
"3550089600 35 # 1 Jul 2012\n"))))
(update-cache! (open-leap-seconds-list-port))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (tai-to-utc-offset-at-utc-day utc-day)
;;
;; The tai-to-utc-offset-at-utc-day procedure returns the TAI to UTC
;; offset at the instant specified by its argument utc-day. The
;; instant is specified by the number of UTC days since 1970-01-01
;; 00:00:00 UTC.
;;
;; To convert a UTC time since 1972-01-01 00:00:00 UTC to number of
;; TAI seconds since 1972-01-01 00:00:00 TAI, first find the number
;; of whole UTC days D since 1970-01-01 00:00:00 UTC and the number
;; of UTC seconds S since the start of the current day. The number
;; of TAI seconds since 1972-01-01 00:00:00 TAI is then
;;
;; (+ (* D 86400) S (tai-to-utc-offset-at-utc-day D))
;;
;; This implementation does not return the correct result for
;; instants prior to 1972-01-01 00:00:00 UTC.
;;
;; Converting a UTC time prior to 1972-01-01 00:00:00 UTC to TAI is
;; more involved, since prior to this date UTC and TAI seconds were
;; not equal. See,
;;
;; http://hpiers.obspm.fr/eop-pc/index.php?index=TAI-UTC_tab
(define (tai-to-utc-offset-at-utc-day-loop utc-day alist)
(cond ((null? alist) 10)
((>= utc-day (caar alist)) (cdar alist))
(else (tai-to-utc-offset-at-utc-day-loop utc-day (cdr alist)))))
(define (tai-to-utc-offset-at-utc-day utc-day)
(tai-to-utc-offset-at-utc-day-loop
utc-day
(cache-utc-day-alist (cache))))
;; (tai-to-utc-offset-at-tai-second tai-second)
;;
;; The tai-to-utc-offset-at-tai-second procedure returns TAI to UTC
;; offset at the instant specified by its argument tai-second. The
;; instant is specified by the number of TAI seconds since
;; 1970-01-01 00:00:00 TAI.
;;
;; This implementation does not return the correct result for
;; instants prior to 1972-01-01 00:00:00 UTC.
(define (tai-to-utc-offset-at-tai-second-loop tai-second alist)
(cond
((null? alist) 10)
((>= tai-second (caar alist)) (cdar alist))
(else (tai-to-utc-offset-at-tai-second-loop tai-second (cdr alist)))))
(define (tai-to-utc-offset-at-tai-second tai-second)
(tai-to-utc-offset-at-tai-second-loop
tai-second
(cache-tai-second-alist (cache))))))