1 (* Copyright (C
) 1999-2006 Henry Cejtin
, Matthew Fluet
, Suresh
2 * Jagannathan
, and Stephen Weeks
.
3 * Copyright (C
) 1997-2000 NEC Research Institute
.
5 * MLton is released under a BSD
-style license
.
6 * See the file MLton
-LICENSE for details
.
9 structure Time
: TIME_EXTRA
=
12 structure Prim
= PrimitiveFFI
.Time
14 (* A time is represented
as a number
of nanoseconds
. *)
15 val ticksPerSecond
: LargeInt
.int = 1000000000
17 datatype time
= T
of LargeInt
.int
26 T (LargeReal
.toLargeInt IEEEReal
.TO_NEAREST
27 (LargeReal
.* (r
, LargeReal
.fromLargeInt ticksPerSecond
)))
28 handle Overflow
=> raise Time
31 LargeReal
./ (LargeReal
.fromLargeInt i
,
32 LargeReal
.fromLargeInt ticksPerSecond
)
37 val d
= LargeInt
.quot (ticksPerSecond
, ticksPer
)
39 (fn i
=> T (LargeInt
.* (i
, d
)),
40 fn T i
=> LargeInt
.quot (i
, d
))
43 val (fromSeconds
, toSeconds
) = make
1
44 val (fromMilliseconds
, toMilliseconds
) = make
1000
45 val (fromMicroseconds
, toMicroseconds
) = make
1000000
46 val (fromNanoseconds
, toNanoseconds
) = make
1000000000
50 fun make
f (T i
, T i
') = f (i
, i
')
52 val compare
= make LargeInt
.compare
53 val op < = make LargeInt
.<
54 val op <= = make LargeInt
.<=
55 val op > = make LargeInt
.>
56 val op >= = make LargeInt
.>=
59 fun make
f (T i
, T i
') = T (f (i
, i
'))
61 val timeAdd
= make LargeInt
.+
62 val timeSub
= make LargeInt
.-
65 (* There
's a mess here to work around a bug
in vmware virtual machines
66 * that may return a
decreasing(!) sequence
of time values
. This will
67 * cause some programs to
raise Time exceptions
where it should be
73 val sec
= ref (C_Time
.castFromFixedInt
0)
74 val usec
= ref (C_SUSeconds
.castFromFixedInt
0)
76 if ~
1 = Prim
.getTimeOfDay (sec
, usec
)
77 then raise Fail
"Time.now"
78 else timeAdd(fromSeconds (C_Time
.toLargeInt (! sec
)),
79 fromMicroseconds (C_SUSeconds
.toLargeInt (! usec
)))
81 val prev
= ref (getNow ())
88 case compare (old
, t
) of
94 val fmt
: int -> time
-> string =
95 fn n
=> (LargeReal
.fmt (StringCvt.FIX (SOME n
))) o toReal
99 (* Adapted from the ML Kit
4.1.4; basislib
/Time
.sml
100 * by mfluet@acm
.org on
2005-11-10 based on
101 * by mfluet@acm
.org on
2005-8-10 based on
102 * adaptations from the ML Kit
3 Version
; basislib
/Time
.sml
103 * by sweeks@research
.nj
.nec
.com on
1999-1-3.
107 val charToDigit
= StringCvt.charToDigit
StringCvt.DEC
109 | pow10 n
= 10 * pow10 (n
-1)
110 fun mkTime sign intv fracv decs
=
113 LargeInt
.div (LargeInt
.+ (LargeInt
.* (Int.toLarge (pow10 (10 - decs
)),
118 LargeInt
.+ (LargeInt
.* (Int.toLarge intv
, ticksPerSecond
),
120 val t
= if sign
then t
else LargeInt
.~ t
124 fun frac
' sign intv fracv decs src
=
126 then SOME (mkTime sign intv fracv decs
,
127 StringCvt.dropl
Char.isDigit getc src
)
128 else case getc src
of
129 NONE
=> SOME (mkTime sign intv fracv decs
, src
)
131 (case charToDigit c
of
132 NONE
=> SOME (mkTime sign intv fracv decs
, src
)
133 | SOME d
=> frac
' sign
intv (10 * fracv
+ d
) (decs
+ 1) rest
)
134 fun frac sign intv src
=
138 (case charToDigit c
of
140 | SOME d
=> frac
' sign intv d
1 rest
)
141 fun int' sign intv src
=
143 NONE
=> SOME (mkTime sign intv
0 7, src
)
144 |
SOME (#
".", rest
) => frac sign intv rest
146 (case charToDigit c
of
147 NONE
=> SOME (mkTime sign intv
0 7, src
)
148 | SOME d
=> int' sign (10 * intv
+ d
) rest
)
152 |
SOME (#
".", rest
) => frac sign
0 rest
154 (case charToDigit c
of
156 | SOME d
=> int' sign d rest
)
158 case getc (StringCvt.skipWS getc src
) of
160 |
SOME (#
"+", rest
) => int true rest
161 |
SOME (#
"~", rest
) => int false rest
162 |
SOME (#
"-", rest
) => int false rest
163 |
SOME (#
".", rest
) => frac
true 0 rest
165 (case charToDigit c
of
167 | SOME d
=> int' true d rest
)
169 handle Overflow
=> raise Time
171 val fromString
= StringCvt.scanString scan