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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a HPND-style license.
* See the file MLton-LICENSE for details.
*)
structure Time: TIME_EXTRA =
struct
structure Prim = PrimitiveFFI.Time
(* A time is represented as a number of nanoseconds. *)
val ticksPerSecond: LargeInt.int = 1000000000
datatype time = T of LargeInt.int
val fromTicks = T
exception Time
val zeroTime = T 0
fun fromReal r =
T (LargeReal.toLargeInt IEEEReal.TO_NEAREST
(LargeReal.* (r, LargeReal.fromLargeInt ticksPerSecond)))
handle Overflow => raise Time
fun toReal (T i) =
LargeReal./ (LargeReal.fromLargeInt i,
LargeReal.fromLargeInt ticksPerSecond)
local
fun make ticksPer =
let
val d = LargeInt.quot (ticksPerSecond, ticksPer)
in
(fn i => T (LargeInt.* (i, d)),
fn T i => LargeInt.quot (i, d))
end
in
val (fromSeconds, toSeconds) = make 1
val (fromMilliseconds, toMilliseconds) = make 1000
val (fromMicroseconds, toMicroseconds) = make 1000000
val (fromNanoseconds, toNanoseconds) = make 1000000000
end
local
fun make f (T i, T i') = f (i, i')
in
val compare = make LargeInt.compare
val op < = make LargeInt.<
val op <= = make LargeInt.<=
val op > = make LargeInt.>
val op >= = make LargeInt.>=
end
local
fun make f (T i, T i') = T (f (i, i'))
in
val timeAdd = make LargeInt.+
val timeSub = make LargeInt.-
end
(* There's a mess here to work around a bug in vmware virtual machines
* that may return a decreasing(!) sequence of time values. This will
* cause some programs to raise Time exceptions where it should be
* impossible.
*)
local
fun getNow (): time =
let
val sec = ref (C_Time.castFromFixedInt 0)
val usec = ref (C_SUSeconds.castFromFixedInt 0)
in
if ~1 = Prim.getTimeOfDay (sec, usec)
then raise Fail "Time.now"
else timeAdd(fromSeconds (C_Time.toLargeInt (! sec)),
fromMicroseconds (C_SUSeconds.toLargeInt (! usec)))
end
val prev = ref (getNow ())
in
fun now (): time =
let
val old = !prev
val t = getNow ()
in
case compare (old, t) of
GREATER => old
| _ => (prev := t; t)
end
end
val fmt: int -> time -> string =
fn n => (LargeReal.fmt (StringCvt.FIX (SOME n))) o toReal
val toString = fmt 3
(* Adapted from the ML Kit 4.1.4; basislib/Time.sml
* by mfluet@acm.org on 2005-11-10 based on
* by mfluet@acm.org on 2005-8-10 based on
* adaptations from the ML Kit 3 Version; basislib/Time.sml
* by sweeks@research.nj.nec.com on 1999-1-3.
*)
fun scan getc src =
let
val charToDigit = StringCvt.charToDigit StringCvt.DEC
fun pow10 0 = 1
| pow10 n = 10 * pow10 (n-1)
fun mkTime sign intv fracv decs =
let
val nsec =
LargeInt.div (LargeInt.+ (LargeInt.* (Int.toLarge (pow10 (10 - decs)),
Int.toLarge fracv),
5),
10)
val t =
LargeInt.+ (LargeInt.* (Int.toLarge intv, ticksPerSecond),
nsec)
val t = if sign then t else LargeInt.~ t
in
T t
end
fun frac' sign intv fracv decs src =
if Int.>= (decs, 7)
then SOME (mkTime sign intv fracv decs,
StringCvt.dropl Char.isDigit getc src)
else case getc src of
NONE => SOME (mkTime sign intv fracv decs, src)
| SOME (c, rest) =>
(case charToDigit c of
NONE => SOME (mkTime sign intv fracv decs, src)
| SOME d => frac' sign intv (10 * fracv + d) (decs + 1) rest)
fun frac sign intv src =
case getc src of
NONE => NONE
| SOME (c, rest) =>
(case charToDigit c of
NONE => NONE
| SOME d => frac' sign intv d 1 rest)
fun int' sign intv src =
case getc src of
NONE => SOME (mkTime sign intv 0 7, src)
| SOME (#".", rest) => frac sign intv rest
| SOME (c, rest) =>
(case charToDigit c of
NONE => SOME (mkTime sign intv 0 7, src)
| SOME d => int' sign (10 * intv + d) rest)
fun int sign src =
case getc src of
NONE => NONE
| SOME (#".", rest) => frac sign 0 rest
| SOME (c, rest) =>
(case charToDigit c of
NONE => NONE
| SOME d => int' sign d rest)
in
case getc (StringCvt.skipWS getc src) of
NONE => NONE
| SOME (#"+", rest) => int true rest
| SOME (#"~", rest) => int false rest
| SOME (#"-", rest) => int false rest
| SOME (#".", rest) => frac true 0 rest
| SOME (c, rest) =>
(case charToDigit c of
NONE => NONE
| SOME d => int' true d rest)
end
handle Overflow => raise Time
val fromString = StringCvt.scanString scan
val op + = timeAdd
val op - = timeSub
end
|
