Incorporating Alan Watson's TAI time library.

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

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

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

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 <chibi/eval.h>
@@ -10,20 +11,85 @@
 typedef long time_t;
 #endif
 
-/* TODO: Check a leap second table file at appropriate intervals. */
+#if SEXP_USE_NTP_GETTIME
-static time_t leap_seconds_since_epoch = 24;
+#include <sys/timex.h>
 
-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
+  return sexp_make_flonum(ctx, tv.tv_sec + tv.tv_usec / 1000000.0);
-                          + leap_seconds_since_epoch);
 #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;
 }

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 current-jiffy current-second)
+      (define clock-type
-    (define (jiffies-per-second) 1)))
+        (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
+    ;; 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)))

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))))))

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))))))