1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
(*---------------------------------------------------------------------------*
IMPLEMENTATION cf_tai64.ml
Copyright (c) 2003-2006, James H. Woodyatt
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
OF THE POSSIBILITY OF SUCH DAMAGE.
*---------------------------------------------------------------------------*)
type t
exception Range_error
exception Label_error
external compare: t -> t -> int = "cf_tai64_compare"
external now: unit -> t = "cf_tai64_now"
external epoch_: unit -> t = "cf_tai64_epoch"
external first_: unit -> t = "cf_tai64_first"
external last_: unit -> t = "cf_tai64_last"
external mjd_epoch_: unit -> t = "cf_tai64_mjd_epoch"
external set_current_offset_: int -> unit = "cf_tai64_set_current_offset"
external to_unix_time: t -> float = "cf_tai64_to_unix_time"
external of_unix_time: float -> t = "cf_tai64_of_unix_time"
external to_label: t -> string = "cf_tai64_to_label"
external of_label: string -> t = "cf_tai64_of_label"
external add: t -> int -> t = "cf_tai64_add_int"
external add_int32: t -> int32 -> t = "cf_tai64_add_int32"
external add_int64: t -> int64 -> t = "cf_tai64_add_int64"
external sub: t -> t -> int64 = "cf_tai64_sub"
;;
external init_: unit -> unit = "cf_tai64_init";;
let _ = Callback.register_exception "Cf_tai64.Range_error" Range_error;;
init_ ();;
let epoch = epoch_ ()
let first = first_ ()
let last = last_ ()
let mjd_epoch = mjd_epoch_ ()
type archive_t = {
a_current_: int;
a_history_: (t * int) list;
a_expires_: t;
}
(*---
This data is copied manually copied from the NIST leap seconds archive.
<ftp://time.nist.gov/pub/leap-seconds.3331497600>
Yes, this really shouldn't be hard-coded. Perhaps, there is a way to
retrieve this information from an NTP client application.
---*)
let embedded_ = "3360441600", [
"2272060800", 10; (* 1 Jan 1972 *)
"2287785600", 11; (* 1 Jul 1972 *)
"2303683200", 12; (* 1 Jan 1973 *)
"2335219200", 13; (* 1 Jan 1974 *)
"2366755200", 14; (* 1 Jan 1975 *)
"2398291200", 15; (* 1 Jan 1976 *)
"2429913600", 16; (* 1 Jan 1977 *)
"2461449600", 17; (* 1 Jan 1978 *)
"2492985600", 18; (* 1 Jan 1979 *)
"2524521600", 19; (* 1 Jan 1980 *)
"2571782400", 20; (* 1 Jul 1981 *)
"2603318400", 21; (* 1 Jul 1982 *)
"2634854400", 22; (* 1 Jul 1983 *)
"2698012800", 23; (* 1 Jul 1985 *)
"2776982400", 24; (* 1 Jan 1988 *)
"2840140800", 25; (* 1 Jan 1990 *)
"2871676800", 26; (* 1 Jan 1991 *)
"2918937600", 27; (* 1 Jul 1992 *)
"2950473600", 28; (* 1 Jul 1993 *)
"2982009600", 29; (* 1 Jul 1994 *)
"3029443200", 30; (* 1 Jan 1996 *)
"3076704000", 31; (* 1 Jul 1997 *)
"3124137600", 32; (* 1 Jan 1999 *)
"3345062400", 33; (* 1 Jan 2006 *)
]
let archive_ =
let tai64_1900 = Int64.of_string "0x3fffffff7c55818a" in
let tai64_1900 = add_int64 first tai64_1900 in
let rec loop dt0 adj acc = function
| (_, dt) :: tl when dt0 = dt ->
loop dt0 adj acc tl
| (secs, dt) :: tl ->
let secs = Int64.of_string secs in
let tai64 = add_int64 tai64_1900 secs in
let tai64 = add tai64 adj in
loop dt (adj + (dt - dt0)) ((tai64, dt0) :: acc) tl
| [] ->
dt0, acc
in
let expires, history = embedded_ in
let current, history = loop 10 0 [] history in
let expires = add_int64 tai64_1900 (Int64.of_string expires) in
let expires = add expires current in
set_current_offset_ current;
ref {
a_current_ = current;
a_history_ = history;
a_expires_ = expires;
}
let leapsec_add =
let rec loop mark hit dt = function
| (tai, dt') :: tl ->
let mark' = add mark (10 - dt') in
let cmp = compare tai mark' in
if cmp < 0 || hit && cmp = 0 then
loop mark hit dt' tl
else
dt
| _ ->
dt
in
fun mark hit ->
let a = !archive_ in
let dt = loop mark hit a.a_current_ a.a_history_ in
add mark (dt - 10)
let leapsec_sub =
let rec loop mark dt = function
| (tai, dt) :: tl when (compare tai mark < 0) ->
loop mark dt tl
| (tai, _) :: _ when (compare tai mark = 0) ->
true, dt
| _ ->
false, dt
in
fun mark ->
let a = !archive_ in
let leap, dt = loop mark a.a_current_ a.a_history_ in
leap, add mark (10 - dt)
(*--- End of File [ cf_tai64.ml ] ---*)
|
