diff --git a/Makefile.detect b/Makefile.detect index 00236460..8fe57bc5 100644 --- a/Makefile.detect +++ b/Makefile.detect @@ -95,3 +95,14 @@ ifeq ($(PLATFORM),unix) #RLDFLAGS=-rpath $(LIBDIR) RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR) endif + +######################################################################## +# Check for NTP (who needs autoconf?) + +ifndef $(SEXP_USE_NTP_GETTIME) +SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0) +endif + +ifeq ($(SEXP_USE_NTP_GETTIME),1) +CPPFLAGS += -DSEXP_USE_NTPGETTIME +endif diff --git a/eval.c b/eval.c index 62bf6348..e03d9cb0 100644 --- a/eval.c +++ b/eval.c @@ -1999,6 +1999,9 @@ static const char* sexp_initial_features[] = { #if SEXP_USE_GREEN_THREADS "threads", #endif +#if SEXP_USE_NTP_GETTIME + "ntp", +#endif #if SEXP_USE_AUTO_FORCE "auto-force", #endif diff --git a/include/chibi/features.h b/include/chibi/features.h index 2d1f2248..abaaabf2 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -563,6 +563,10 @@ #define SEXP_PORT_BUFFER_SIZE 4096 #endif +#ifndef SEXP_USE_NTP_GETTIME +#define SEXP_USE_NTP_GETTIME 0 +#endif + #ifndef SEXP_USE_2010_EPOCH #define SEXP_USE_2010_EPOCH ! SEXP_USE_NO_FEATURES #endif diff --git a/lib/scheme/time.c b/lib/scheme/time.c index 899d1202..1a8a6ab6 100644 --- a/lib/scheme/time.c +++ b/lib/scheme/time.c @@ -1,5 +1,6 @@ /* time.c -- R7RS time routines */ /* Copyright (c) 2011-2012 Alex Shinn. All rights reserved. */ +/* Copyright (c) 2012 Alan Watson. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ #include @@ -10,20 +11,85 @@ typedef long time_t; #endif -/* TODO: Check a leap second table file at appropriate intervals. */ -static time_t leap_seconds_since_epoch = 24; +#if SEXP_USE_NTP_GETTIME +#include -static sexp sexp_current_second (sexp ctx, sexp self, sexp_sint_t n) { +/* We can determine the clock resolution by calling ntp_adjtime() and */ +/* seeing if the STA_NANO bit of the status word is set. If it is, we */ +/* have nanosecond resolution, otherwise we have microsecond resolution. */ + +/* The time member of the ntptimeval struct may be either a struct */ +/* timeval (with the fraction in microseconds) or a struct timespec */ +/* (with the fraction in nanoseconds). */ + +/* However, there are systems (e.g., Ubuntu 10.4 on X86_64) that use */ +/* nanosecond resolution but still declare the time member of struct */ +/* ntptimeval to be a struct timeval. Therefore, we explicitly use casts */ +/* to access this member either as a struct timeval or struct timespec */ +/* depending on the resolution. */ + +static double ntp_resolution = 0.0; + +static void determine_ntp_resolution (void) { + struct timex tx; + tx.modes = 0; + if (ntp_adjtime(&tx) < 0) { + ntp_resolution = 0; + } else if (tx.status & STA_NANO) { + ntp_resolution = 1e-9; + } else { + ntp_resolution = 1e-6; + } +} + +static void current_ntp_clock_values (double *second, int *leap_second_indicator) { + struct ntptimeval ntv; + int status = ntp_gettime(&ntv); + if (ntp_resolution != 0 && ( + status == TIME_OK || + status == TIME_INS || + status == TIME_DEL || + status == TIME_OOP || + status == TIME_WAIT)) { + if (ntp_resolution == 1e-6) { + struct timeval *tv = (struct timeval *) &ntv.time; + *second = tv->tv_sec + ntp_resolution * tv->tv_usec; + } else { + struct timespec *ts = (struct timespec *) &ntv.time; + *second = ts->tv_sec + ntp_resolution * ts->tv_nsec; + } + *leap_second_indicator = (status == TIME_OOP); + } else { + *second = current_clock_second(); + *leap_second_indicator = 0; + } +} + +static sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) { + double second; + int leap_second_indicator; + sexp_gc_var3(res, car, cdr); + current_ntp_clock_values (&second, &leap_second_indicator); + sexp_gc_preserve3(ctx, res, car, cdr); + cdr = sexp_make_boolean(leap_second_indicator); + car = sexp_make_flonum(ctx, second); + res = sexp_cons(ctx, car, cdr); + sexp_gc_release3(ctx); + return res; +} + +#endif /* def SEXP_USE_NTP_GETTIME */ + +static sexp sexp_current_clock_second (sexp ctx, sexp self, sexp_sint_t n) { #ifndef PLAN9 struct timeval tv; struct timezone tz; if (gettimeofday(&tv, &tz)) return sexp_user_exception(ctx, self, "couldn't gettimeofday", SEXP_FALSE); - return sexp_make_flonum(ctx, tv.tv_sec + tv.tv_usec / 1000000.0 - + leap_seconds_since_epoch); + return sexp_make_flonum(ctx, tv.tv_sec + tv.tv_usec / 1000000.0); #else time_t res = time(NULL); - return sexp_make_flonum(ctx, res + leap_seconds_since_epoch); + return sexp_make_flonum(ctx, res); #endif } @@ -31,6 +97,10 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char if (!(sexp_version_compatible(ctx, version, sexp_version) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) return sexp_global(ctx, SEXP_G_ABI_ERROR); - sexp_define_foreign(ctx, env, "current-second", 0, sexp_current_second); + sexp_define_foreign(ctx, env, "current-clock-second", 0, sexp_current_clock_second); +#if SEXP_USE_NTP_GETTIME + determine_ntp_resolution(); + sexp_define_foreign(ctx, env, "current-ntp-clock-values", 0, sexp_current_ntp_clock_values); +#endif return SEXP_VOID; } diff --git a/lib/scheme/time.sld b/lib/scheme/time.sld index 1b2bddf1..b6ed8f4b 100644 --- a/lib/scheme/time.sld +++ b/lib/scheme/time.sld @@ -1,8 +1,78 @@ +;; time.sld - (scheme time) library definition +;; +;; Copyright (c) 2012 Alex Shinn. All rights reserved. +;; Copyright (c) 2012 Alan Watson. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt (define-library (scheme time) - (import (scheme)) (export current-second current-jiffy jiffies-per-second) + (import (scheme)) + (import (scheme process-context)) + (import (scheme time tai)) (include-shared "time") + ;; If the environment variable SEXP_CLOCK_TYPE is set, its value + ;; is used for the system clock type. If the environment variable + ;; SEXP_CLOCK_TYPE is not set, then the system clock is ntp-like + ;; if current-ntp-clock-values is a procedure and is posix-like + ;; otherwise. + (cond-expand + (ntp + (begin + (define clock-type + (cond + ((get-environment-variable "SEXP_CLOCK_TYPE") + => (lambda (x) + (let ((type (string->symbol x))) + (case type + ((posix-like tai-like ntp-like) type) + (else + (display "invalid value for SEXP_CLOCK_TYPE: " (current-error-port)) + (write x (current-error-port)) + (display " - expected \"ntp-like\", \"posix-like\" or \"tai-like\"\n" (current-error-port)) + 'ntp-like))))) + (else 'ntp-like))))) + (else + (begin (define clock-type 'posix-like)))) (begin - (define current-jiffy current-second) - (define (jiffies-per-second) 1))) + ;; The value of the environment variable SEXP_CLOCK_EPOCH_OFFSET + ;; specifies the offset of the system clock relative to the + ;; standard epoch (1970-01-01 00:00:00 UTC for posix-like and + ;; ntp-like clocks and 1970-01-01 00:00:00 TAI for tai-like system + ;; clocks). If it not set, the offset is assumed to be zero. In + ;; call-with-current-clock-values, the offset is added to the + ;; current seconds before calling the procedure argument. + (define epoch-offset + (exact->inexact + (string->number + (or (get-environment-variable "SEXP_CLOCK_EPOCH_OFFSET") + "0")))) + + ;; Normally, one does not need to specify either the clock type or + ;; clock epoch explicitly. One case where it might be necessary is + ;; if the system clock runs on the TAI-10 timescale. In this case, + ;; one should set SEXP_CLOCK_TYPE to "tai-like" and + ;; SEXP_CLOCK_EPOCH_OFFSET to -10. + ;; + ;; The call-with-current-clock-values obtains the clock values + ;; from the current-ntp-clock-values procedure, if the system + ;; clock is ntp-like, and from the current-clock-second procedure + ;; otherwise. + (define call-with-current-clock-values + (cond-expand + (ntp + (case clock-type + ((ntp-like) + (lambda (p) + (let ((values-pair (current-ntp-clock-values))) + (p (+ (car values-pair) epoch-offset) (cdr values-pair))))) + (else + (lambda (p) (p (+ (current-clock-second) epoch-offset) #f))))) + (else + (lambda (p) (p (+ (current-clock-second) epoch-offset) #f))))) + + ;; Exported interface. + (define current-second + (make-tai-clock clock-type call-with-current-clock-values)) + (define (current-jiffy) + (inexact->exact (round (* (current-second) (jiffies-per-second))))) + (define (jiffies-per-second) 1000))) diff --git a/lib/scheme/time/tai-to-utc-offset.sld b/lib/scheme/time/tai-to-utc-offset.sld new file mode 100644 index 00000000..f63a0114 --- /dev/null +++ b/lib/scheme/time/tai-to-utc-offset.sld @@ -0,0 +1,372 @@ +;; 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)) + + (import (srfi 18)) + + (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))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; 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)))))) diff --git a/lib/scheme/time/tai.sld b/lib/scheme/time/tai.sld new file mode 100644 index 00000000..7e9034f5 --- /dev/null +++ b/lib/scheme/time/tai.sld @@ -0,0 +1,57 @@ +;; Copyright (c) 2012 Alan Watson. All rights reserved. BSD-style +;; license: http://synthcode.com/license.txt + +;; This library implements TAI clocks with an epoch of 1970-01-01 +;; 00:00:00 TAI. + +(define-library (scheme time tai) + + (export make-tai-clock) + + (import (scheme base)) + (import (scheme time tai-to-utc-offset)) + + (begin + + (define seconds-per-day (* 24.0 60.0 60.0)) + + (define (make-tai-clock-from-tai-like-clock call-with-current-clock-values) + (define (consumer second leap-second-indicator) + second) + (lambda () + (call-with-current-clock-values consumer))) + + (define (make-tai-clock-from-posix-like-clock call-with-current-clock-values) + (define (consumer second leap-second-indicator) + (+ second (tai-to-utc-offset-at-utc-day (/ second seconds-per-day)))) + (lambda () + (call-with-current-clock-values consumer))) + + (define (make-tai-clock-from-ntp-like-clock call-with-current-clock-values) + (define (consumer second leap-second-indicator) + (+ second + (tai-to-utc-offset-at-utc-day (/ second seconds-per-day)) + (if leap-second-indicator 1.0 0.0))) + (lambda () + (call-with-current-clock-values consumer))) + + ;; (make-tai-clock type call-with-current-clock-values) + ;; + ;; The make-tai-clock procedure returns a procedure that, when + ;; called with no arguments, returns an estimate of the number of + ;; TAI seconds since 1970-01-01 00:00:00 TAI. + ;; + ;; The type and call-with-current-clock-values argument should + ;; conform to the descriptions in the documentation of the (clock + ;; system-clock) library. + + (define (make-tai-clock type call-with-current-clock-values) + (case type + ((tai-like) + (make-tai-clock-from-tai-like-clock call-with-current-clock-values)) + ((posix-like) + (make-tai-clock-from-posix-like-clock call-with-current-clock-values)) + ((ntp-like) + (make-tai-clock-from-ntp-like-clock call-with-current-clock-values)) + (else + (error "invalid clock type" type))))))