Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/PervEnv/Basis/date.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/PervEnv/Basis/date.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 89 - (view) (download)

1 : monnier 89 (* date.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     *)
6 :    
7 :     structure Date : DATE =
8 :     struct
9 :    
10 :    
11 :     (* the run-time system indexes the year off this *)
12 :     val baseYear = 1900
13 :    
14 :     exception Date
15 :    
16 :     datatype weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun
17 :    
18 :     datatype month
19 :     = Jan | Feb | Mar | Apr | May | Jun
20 :     | Jul | Aug | Sep | Oct | Nov | Dec
21 :    
22 :     datatype date = DATE of {
23 :     year : int,
24 :     month : month,
25 :     day : int,
26 :     hour : int,
27 :     minute : int,
28 :     second : int,
29 :     offset : Time.time option,
30 :     wday : weekday,
31 :     yday : int,
32 :     isDst : bool option
33 :     }
34 :    
35 :     (* tables for mapping integers to days/months *)
36 :     val dayTbl = #[Sun, Mon, Tue, Wed, Thu, Fri, Sat]
37 :     val monthTbl = #[Jan, Feb, Mar, Apr, May, Jun, Jul,
38 :     Aug, Sep, Oct, Nov, Dec]
39 :    
40 :     fun dayToInt (d) = (case d
41 :     of Sun => 0 | Mon => 1 | Tue => 2 | Wed => 3
42 :     | Thu => 4 | Fri => 5 | Sat => 6
43 :     (* end case *))
44 :    
45 :     (* careful about this: the month numbers are 0-11 *)
46 :     fun monthToInt m = (case m
47 :     of Jan => 0 | Feb => 1 | Mar => 2 | Apr => 3 | May => 4 | Jun => 5
48 :     | Jul => 6 | Aug => 7 | Sep => 8 | Oct => 9 | Nov => 10 | Dec => 11
49 :     (* end case *))
50 :    
51 :     (* the tuple type used to communicate with C; this 9-tuple has the fields:
52 :     * tm_sec, tm_min, tm_hour, tm_mday, tm_mon, tm_year, tm_wday, tm_yday,
53 :     * and tm_isdst.
54 :     *)
55 :     type tm = (int * int * int * int * int * int * int * int * int)
56 :    
57 :     (* wrap a C function call with a handler that maps SysErr exception into
58 :     * Date exceptions.
59 :     *)
60 :     fun wrap f x = (f x) handle _ => raise Date
61 :    
62 :     (* note: mkTime assumes the tm structure passed to it reflects
63 :     * the local time zone
64 :     *)
65 :     val ascTime : tm -> string
66 :     = wrap (CInterface.c_function "SMLNJ-Date" "ascTime")
67 :     val localTime : Int32.int -> tm
68 :     = wrap (CInterface.c_function "SMLNJ-Date" "localTime")
69 :     val gmTime : Int32.int -> tm
70 :     = wrap (CInterface.c_function "SMLNJ-Date" "gmTime")
71 :     val mkTime : tm -> Int32.int
72 :     = wrap (CInterface.c_function "SMLNJ-Date" "mkTime")
73 :     val strfTime : (string * tm) -> string
74 :     = wrap (CInterface.c_function "SMLNJ-Date" "strfTime")
75 :    
76 :     fun year (DATE{year, ...}) = year
77 :     fun month (DATE{month, ...}) = month
78 :     fun day (DATE{day, ...}) = day
79 :     fun hour (DATE{hour, ...}) = hour
80 :     fun minute (DATE{minute, ...}) = minute
81 :     fun second (DATE{second, ...}) = second
82 :     fun weekDay (DATE{wday, ...}) = wday
83 :     fun yearDay (DATE{yday, ...}) = yday
84 :     fun isDst (DATE{isDst, ...}) = isDst
85 :     fun offset (DATE{offset,...}) = offset
86 :    
87 :    
88 :     (*
89 :     * This code is taken from Reingold's paper
90 :     *)
91 :     local
92 :     val quot = Int.quot
93 :     val not = Bool.not
94 :     fun sum (f,k,p) =
95 :     let fun loop (f,i,p,acc) = if (not(p(i))) then acc
96 :     else loop(f,i+1,p,acc+f(i))
97 :     in
98 :     loop (f,k,p,0)
99 :     end
100 :     fun lastDayOfGregorianMonth (month,year) =
101 :     if ((month=1) andalso
102 :     (Int.mod (year,4) = 0) andalso
103 :     not (Int.mod (year,400) = 100) andalso
104 :     not (Int.mod (year,400) = 200) andalso
105 :     not (Int.mod (year,400) = 300))
106 :     then 29
107 :     else List.nth ([31,28,31,30,31,30,31,31,30,31,30,31],month)
108 :     in
109 :     fun toAbsolute (month, day, year) =
110 :     day
111 :     + sum (fn (m) => lastDayOfGregorianMonth(m,year),0,
112 :     fn (m) => (m<month))
113 :     + 365 * (year -1)
114 :     + quot (year-1,4)
115 :     - quot (year-1,100)
116 :     + quot (year-1,400)
117 :     fun fromAbsolute (abs) =
118 :     let val approx = quot (abs,366)
119 :     val year = (approx + sum(fn(_)=>1, approx,
120 :     fn(y)=> (abs >= toAbsolute(0,1,y+1))))
121 :     val month = (sum (fn(_)=>1, 0,
122 :     fn(m)=> (abs > toAbsolute(m,lastDayOfGregorianMonth(m,year),year))))
123 :     val day = (abs - toAbsolute(month,1,year) + 1)
124 :     in
125 :     (month, day, year)
126 :     end
127 :     fun wday (month,day,year) =
128 :     let val abs = toAbsolute (month,day,year)
129 :     in
130 :     InlineT.PolyVector.sub (dayTbl, Int.mod(abs,7))
131 :     end
132 :     fun yday (month, day, year) =
133 :     let val abs = toAbsolute (month, day, year)
134 :     val daysPrior =
135 :     365 * (year -1)
136 :     + quot (year-1,4)
137 :     - quot (year-1,100)
138 :     + quot (year-1,400)
139 :     in
140 :     abs - daysPrior - 1 (* to conform to ISO standard *)
141 :     end
142 :     end
143 :    
144 :     (*
145 :     * this function should also canonicalize the time (hours, etc...)
146 :     *)
147 :     fun canonicalizeDate (DATE d) =
148 :     let val args = (monthToInt(#month d), #day d, #year d)
149 :     val (monthC,dayC,yearC) = fromAbsolute (toAbsolute (args))
150 :     val yday = yday (args)
151 :     val wday = wday (args)
152 :     in
153 :     DATE {year = yearC,
154 :     month = InlineT.PolyVector.sub (monthTbl,monthC),
155 :     day = dayC,
156 :     hour = #hour d,
157 :     minute = #minute d,
158 :     second = #second d,
159 :     offset = #offset d,
160 :     isDst = NONE,
161 :     yday = yday,
162 :     wday = wday}
163 :     end
164 :    
165 :     fun toTM (DATE d) = (
166 :     #second d, (* tm_sec *)
167 :     #minute d, (* tm_min *)
168 :     #hour d, (* tm_hour *)
169 :     #day d, (* tm_mday *)
170 :     monthToInt(#month d), (* tm_mon *)
171 :     #year d - baseYear, (* tm_year *)
172 :     dayToInt(#wday d), (* tm_wday *)
173 :     0, (* tm_yday *)
174 :     case (#isDst d) (* tm_isdst *)
175 :     of NONE => ~1
176 :     | (SOME false) => 0
177 :     | (SOME true) => 1
178 :     (* end case *)
179 :     )
180 :    
181 :     fun fromTM (
182 :     tm_sec, tm_min, tm_hour, tm_mday, tm_mon,
183 :     tm_year, tm_wday, tm_yday, tm_isdst
184 :     ) offset = DATE{
185 :     year = baseYear + tm_year,
186 :     month = InlineT.PolyVector.sub(monthTbl, tm_mon),
187 :     day = tm_mday,
188 :     hour = tm_hour,
189 :     minute = tm_min,
190 :     second = tm_sec,
191 :     wday = InlineT.PolyVector.sub(dayTbl, tm_wday),
192 :     yday = tm_yday,
193 :     isDst = if (tm_isdst < 0) then NONE else SOME(tm_isdst <> 0),
194 :     offset = offset
195 :     }
196 :    
197 :     (* takes two tm's and returns the second tm with
198 :     * its dst flag set to the first one's.
199 :     * Used to compute local offsets
200 :     *)
201 :     fun toSameDstTM ((tm_sec, tm_min, tm_hour, tm_mday, tm_mon,
202 :     tm_year, tm_wday, tm_yday, tm_isdst),
203 :     (tm_sec', tm_min', tm_hour', tm_mday', tm_mon',
204 :     tm_year', tm_wday', tm_yday', tm_isdst')) =
205 :     (tm_sec', tm_min', tm_hour', tm_mday', tm_mon',
206 :     tm_year', tm_wday', tm_yday', tm_isdst)
207 :    
208 :     (* a diff is +/- seconds between local time and gmt
209 :     * what to add to local time to get gmt
210 :     *)
211 :    
212 :     val secInDay = Int32.fromInt(60 * 60 * 24)
213 :     val secInHDay = Int32.fromInt(30 * 30 * 24)
214 :     (*
215 :     fun diffToOffset (d) =
216 :     if (d<0) then Time.fromSeconds (secInDay+d)
217 :     else Time.fromSeconds(d)
218 :     *)
219 :     fun offsetToDiff (off) =
220 :     let val s = Time.toSeconds (off)
221 :     in
222 :     if (s>secInHDay) then secInHDay-s else s
223 :     end
224 :    
225 :     (*
226 :     * this function is meant as an analogue to
227 :     * mkTime, but constructs UTC time instead of localtime
228 :     * idea: mkTime (localtime(t))= t
229 :     * mkGMTime (gmtime(t))= t
230 :     *)
231 :    
232 :     fun localDiff (tm) =
233 :     let val t = mkTime (tm)
234 :     val loc = localTime (t)
235 :     val gmt = gmTime (t)
236 :     in
237 :     mkTime (toSameDstTM(loc,gmt)) - mkTime(loc)
238 :     end
239 :    
240 :     fun mkGMTime (tm) = mkTime (toSameDstTM (localTime(mkTime(tm)),tm)) -
241 :     localDiff (tm)
242 :    
243 :     fun toSeconds (d) =
244 :     let val tm = toTM (d)
245 :     in
246 :     case (offset d) of
247 :     NONE => mkTime (tm)
248 :     | SOME (offsetV) => mkGMTime (tm) + offsetToDiff (offsetV)
249 :     end
250 :    
251 :     val toTime = Time.fromSeconds o toSeconds
252 :    
253 :     fun fromTimeLocal (t) =
254 :     fromTM (localTime (Time.toSeconds (t))) NONE
255 :    
256 :     fun fromTimeOffset (t, offset) =
257 :     fromTM (gmTime (Time.toSeconds (t) - Time.toSeconds(offset)))
258 :     (SOME offset)
259 :    
260 :     fun fromTimeUniv (t) = fromTimeOffset (t,Time.zeroTime)
261 :    
262 :     fun date {year,month,day,hour,minute,second,offset} =
263 :     let val d = DATE {second = second,
264 :     minute = minute,
265 :     hour = hour,
266 :     year = year,
267 :     month = month,
268 :     day = day,
269 :     offset = offset,
270 :     isDst = NONE,
271 :     yday = 0,
272 :     wday = Mon}
273 :     val canonicalDate = canonicalizeDate (d)
274 :     fun internalDate () =
275 :     (case (offset) of
276 :     NONE => fromTimeLocal (toTime canonicalDate)
277 :     | SOME (offsetV) => fromTimeOffset (toTime canonicalDate,
278 :     offsetV))
279 :     in
280 :     internalDate () handle Date => d
281 :     end
282 :    
283 :     fun toString d = ascTime (toTM d)
284 :    
285 :     fun fmt fmtStr d = strfTime (fmtStr, toTM d)
286 :    
287 :     (**
288 :     val fromString : string -> date option
289 :     val scan : (getc : (char, 'a) StringCvt.reader) -> 'a -> (date * 'a) option
290 :     **)
291 :    
292 :    
293 :     (* comparison does not take into account the offset
294 :     * thus, it does not compare dates in different time zones
295 :     *)
296 :     fun compare (DATE d1, DATE d2) = let
297 :     fun cmp (i1::r1, i2::r2) =
298 :     if (i1 < i2) then LESS
299 :     else if (i1 = i2) then cmp (r1, r2)
300 :     else GREATER
301 :     | cmp _ = EQUAL
302 :     in
303 :     cmp (
304 :     [#year d1, monthToInt(#month d1), #day d1, #hour d1, #minute d1, #second d1],
305 :     [#year d2, monthToInt(#month d2), #day d2, #hour d2, #minute d2, #second d2])
306 :     end
307 :    
308 :     end;
309 :    
310 :     (*
311 :     * $Log: date.sml,v $
312 :     * Revision 1.1.1.1 1998/04/08 18:40:05 george
313 :     * Version 110.5
314 :     *
315 :     *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0