1------------------------------------------------------------------------------ 2-- -- 3-- Matreshka Project -- 4-- -- 5-- Localization, Internationalization, Globalization for Ada -- 6-- -- 7-- Runtime Library Component -- 8-- -- 9------------------------------------------------------------------------------ 10-- -- 11-- Copyright © 2011-2013, Vadim Godunko <vgodunko@gmail.com> -- 12-- All rights reserved. -- 13-- -- 14-- Redistribution and use in source and binary forms, with or without -- 15-- modification, are permitted provided that the following conditions -- 16-- are met: -- 17-- -- 18-- * Redistributions of source code must retain the above copyright -- 19-- notice, this list of conditions and the following disclaimer. -- 20-- -- 21-- * Redistributions in binary form must reproduce the above copyright -- 22-- notice, this list of conditions and the following disclaimer in the -- 23-- documentation and/or other materials provided with the distribution. -- 24-- -- 25-- * Neither the name of the Vadim Godunko, IE nor the names of its -- 26-- contributors may be used to endorse or promote products derived from -- 27-- this software without specific prior written permission. -- 28-- -- 29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- 30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- 31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- 32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- 33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- 34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- 35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- 36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- 37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- 38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- 39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- 40-- -- 41------------------------------------------------------------------------------ 42-- $Revision: 3663 $ $Date: 2013-01-20 22:32:29 +0400 (Sun, 20 Jan 2013) $ 43------------------------------------------------------------------------------ 44 45package body Matreshka.Internals.Calendars.Times is 46 47 X_Open_Epoch : constant := 2_299_161; 48 -- Julian day number of start of X/Open representation 49 -- October, 15, 1582 50 51 Ticks_In_Day : constant := 24 * 60 * 60 * 10_000_000; 52 Ticks_In_Hour : constant := 60 * 60 * 10_000_000; 53 Ticks_In_Minute : constant := 60 * 10_000_000; 54 Ticks_In_Second : constant := 10_000_000; 55 56 type Leap_Second_Information is record 57 Julian_Day : Julian_Day_Number; 58 Stamp : Absolute_Time; 59 Correction : Absolute_Time; 60 end record; 61 62 Leaps : constant array (Positive range <>) of Leap_Second_Information 63 := ((2456109, 135603936240000000, 250000000), -- 2012-06-30 64 (2454832, 134500608230000000, 240000000), -- 2008-12-31 65 (2453736, 133553664220000000, 230000000), -- 2005-12-31 66 (2451179, 131344416210000000, 220000000), -- 1998-12-31 67 (2450630, 130870080200000000, 210000000), -- 1997-06-30 68 (2450083, 130397472190000000, 200000000), -- 1995-12-31 69 (2449534, 129923136180000000, 190000000), -- 1994-06-30 70 (2449169, 129607776170000000, 180000000), -- 1993-06-30 71 (2448804, 129292416160000000, 170000000), -- 1992-06-30 72 (2448257, 128819808150000000, 160000000), -- 1990-12-31 73 (2447892, 128504448140000000, 150000000), -- 1989-12-31 74 (2447161, 127872864130000000, 140000000), -- 1987-12-31 75 (2446247, 127083168120000000, 130000000), -- 1985-06-30 76 (2445516, 126451584110000000, 120000000), -- 1983-06-30 77 (2445151, 126136224100000000, 110000000), -- 1982-06-30 78 (2444786, 125820864090000000, 100000000), -- 1981-06-30 79 (2444239, 125348256080000000, 90000000), -- 1979-12-31 80 (2443874, 125032896070000000, 80000000), -- 1978-12-31 81 (2443509, 124717536060000000, 70000000), -- 1977-12-31 82 (2443144, 124402176050000000, 60000000), -- 1976-12-31 83 (2442778, 124085952040000000, 50000000), -- 1975-12-31 84 (2442413, 123770592030000000, 40000000), -- 1974-12-31 85 (2442048, 123455232020000000, 30000000), -- 1973-12-31 86 (2441683, 123139872010000000, 20000000), -- 1972-12-31 87 (2441499, 122980896000000000, 10000000)); -- 1972-06-30 88 89 ------------ 90 -- Create -- 91 ------------ 92 93 function Create 94 (Zone : not null Time_Zone_Access; 95 Julian_Day : Julian_Day_Number; 96 Hour : Hour_Number; 97 Minute : Minute_Number; 98 Second : Second_Number; 99 Nano_100 : Nano_Second_100_Number) return Absolute_Time 100 is 101 pragma Unreferenced (Zone); 102 -- XXX Time zone is not supported yet. 103 104 Stamp : Absolute_Time; 105 Row : Natural := 0; 106 -- Number of row in correction table to obtain nearset next leap second 107 -- day. 108 109 begin 110 -- Construct absolute time from all components except second and its 111 -- fraction. Resulted absolute time will never be inside nearest next 112 -- leap second. 113 114 Stamp := 115 Absolute_Time (Julian_Day - X_Open_Epoch) * Ticks_In_Day 116 + Absolute_Time (Hour) * Ticks_In_Hour 117 + Absolute_Time (Minute) * Ticks_In_Minute; 118 119 -- Looking for leap second correction and correct absolute time when 120 -- necessary. 121 122 for J in Leaps'Range loop 123 if Stamp > Leaps (J).Stamp - Leaps (J).Correction + 10_000_000 then 124 Stamp := Stamp + Leaps (J).Correction; 125 Row := J - 1; 126 127 exit; 128 end if; 129 end loop; 130 131 -- Check whether leap second can be used. 132 133 if Second = 60 134 and then (Row not in Leaps'Range 135 or else Leaps (Row).Julian_Day /= Julian_Day) 136 then 137 raise Constraint_Error; 138 end if; 139 140 -- Add second and its fraction components. 141 142 return 143 Stamp 144 + Absolute_Time (Second) * Ticks_In_Second 145 + Absolute_Time (Nano_100); 146 end Create; 147 148 ---------- 149 -- Hour -- 150 ---------- 151 152 function Hour 153 (Stamp : Absolute_Time; 154 Zone : not null Time_Zone_Access) return Hour_Number 155 is 156 Julian_Day : Julian_Day_Number; 157 Time : Relative_Time; 158 Leap : Relative_Time; 159 160 begin 161 Split (Zone, Stamp, Julian_Day, Time, Leap); 162 163 return Hour_Number (Time / Ticks_In_Hour); 164 end Hour; 165 166 ---------- 167 -- Hour -- 168 ---------- 169 170 function Hour (Time : Relative_Time) return Hour_Number is 171 begin 172 return Hour_Number (Time / Ticks_In_Hour); 173 end Hour; 174 175 ---------------- 176 -- Julian_Day -- 177 ---------------- 178 179 function Julian_Day 180 (Stamp : Absolute_Time; 181 Zone : not null Time_Zone_Access) return Julian_Day_Number 182 is 183 Julian_Day : Julian_Day_Number; 184 Time : Relative_Time; 185 Leap : Relative_Time; 186 187 begin 188 Split (Zone, Stamp, Julian_Day, Time, Leap); 189 190 return Julian_Day; 191 end Julian_Day; 192 193 ------------ 194 -- Minute -- 195 ------------ 196 197 function Minute 198 (Stamp : Absolute_Time; 199 Zone : not null Time_Zone_Access) return Minute_Number 200 is 201 Julian_Day : Julian_Day_Number; 202 Time : Relative_Time; 203 Leap : Relative_Time; 204 205 begin 206 Split (Zone, Stamp, Julian_Day, Time, Leap); 207 208 return Minute_Number ((Time mod Ticks_In_Hour) / Ticks_In_Minute); 209 end Minute; 210 211 ------------ 212 -- Minute -- 213 ------------ 214 215 function Minute (Time : Relative_Time) return Minute_Number is 216 begin 217 return Minute_Number ((Time mod Ticks_In_Hour) / Ticks_In_Minute); 218 end Minute; 219 220 -------------------- 221 -- Nanosecond_100 -- 222 -------------------- 223 224 function Nanosecond_100 225 (Stamp : Absolute_Time; 226 Zone : not null Time_Zone_Access) return Nano_Second_100_Number 227 is 228 Julian_Day : Julian_Day_Number; 229 Time : Relative_Time; 230 Leap : Relative_Time; 231 232 begin 233 Split (Zone, Stamp, Julian_Day, Time, Leap); 234 235 return 236 Nano_Second_100_Number 237 ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute) 238 mod Ticks_In_Second); 239 end Nanosecond_100; 240 241 -------------------- 242 -- Nanosecond_100 -- 243 -------------------- 244 245 function Nanosecond_100 246 (Time : Relative_Time; 247 Leap : Relative_Time) return Nano_Second_100_Number is 248 begin 249 return 250 Nano_Second_100_Number 251 ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute) 252 mod Ticks_In_Second); 253 end Nanosecond_100; 254 255 ------------ 256 -- Second -- 257 ------------ 258 259 function Second 260 (Stamp : Absolute_Time; 261 Zone : not null Time_Zone_Access) return Second_Number 262 is 263 Julian_Day : Julian_Day_Number; 264 Time : Relative_Time; 265 Leap : Relative_Time; 266 267 begin 268 Split (Zone, Stamp, Julian_Day, Time, Leap); 269 270 return 271 Second_Number 272 ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute) 273 / Ticks_In_Second); 274 end Second; 275 276 ------------ 277 -- Second -- 278 ------------ 279 280 function Second 281 (Time : Relative_Time; Leap : Relative_Time) return Second_Number is 282 begin 283 return 284 Second_Number 285 ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute) 286 / Ticks_In_Second); 287 end Second; 288 289 ----------- 290 -- Split -- 291 ----------- 292 293 procedure Split 294 (Zone : not null Time_Zone_Access; 295 Stamp : Absolute_Time; 296 Julian_Day : out Julian_Day_Number; 297 Time : out Relative_Time; 298 Leap : out Relative_Time) 299 is 300 pragma Unreferenced (Zone); 301 -- XXX Timezone is not supported. 302 303 Corrected_Stamp : Absolute_Time := Stamp; 304 305 begin 306 -- Compensate leap seconds and extract leap second duration when 307 -- necessary. 308 309 Leap := 0; 310 311 -- Going through list of leap seconds. 312 313 for J in Leaps'Range loop 314 if Stamp >= Leaps (J).Stamp + 10_000_000 then 315 -- Stamp is larger than current leap second and outside of leap 316 -- second range. 317 318 Corrected_Stamp := Stamp - Leaps (J).Correction; 319 320 exit; 321 322 elsif Stamp >= Leaps (J).Stamp then 323 -- Stamp is inside leap second range. 324 325 Corrected_Stamp := 326 Leaps (J).Stamp - Leaps (J).Correction + 10_000_000 - 1; 327 Leap := Relative_Time (Stamp - Leaps (J).Stamp + 1); 328 329 exit; 330 end if; 331 end loop; 332 333 -- Compute julian day number and relative time. 334 335 Julian_Day := 336 Julian_Day_Number (Corrected_Stamp / (Ticks_In_Day)) + X_Open_Epoch; 337 Time := Relative_Time (Corrected_Stamp mod (Ticks_In_Day)); 338 end Split; 339 340 ----------- 341 -- Split -- 342 ----------- 343 344 procedure Split 345 (Zone : not null Time_Zone_Access; 346 Stamp : Absolute_Time; 347 Julian_Day : out Julian_Day_Number; 348 Hour : out Hour_Number; 349 Minute : out Minute_Number; 350 Second : out Second_Number; 351 Nanosecond_100 : out Nano_Second_100_Number) 352 is 353 Leap : Relative_Time; 354 Time : Relative_Time; 355 Corrected_Stamp : Absolute_Time := Stamp; 356 357 begin 358 -- Compensate leap seconds and extract leap second duration when 359 -- necessary. 360 361 Leap := 0; 362 363 -- Going through list of leap seconds. 364 365 for J in Leaps'Range loop 366 if Stamp >= Leaps (J).Stamp + 10_000_000 then 367 -- Stamp is larger than current leap second and outside of leap 368 -- second range. 369 370 Corrected_Stamp := Stamp - Leaps (J).Correction; 371 372 exit; 373 374 elsif Stamp >= Leaps (J).Stamp then 375 -- Stamp is inside leap second range. 376 377 Corrected_Stamp := 378 Leaps (J).Stamp - Leaps (J).Correction + 10_000_000 - 1; 379 Leap := Relative_Time (Stamp - Leaps (J).Stamp + 1); 380 381 exit; 382 end if; 383 end loop; 384 385 -- Apply timezone offset. 386 387 for J in Zone.Data'Range loop 388 if Corrected_Stamp >= Zone.Data (J).From then 389 Corrected_Stamp := 390 Corrected_Stamp + Absolute_Time (Zone.Data (J).Offset); 391 392 exit; 393 end if; 394 end loop; 395 396 -- Compute julian day number and relative time. 397 398 Julian_Day := 399 Julian_Day_Number (Corrected_Stamp / (Ticks_In_Day)) + X_Open_Epoch; 400 Time := Relative_Time (Corrected_Stamp mod (Ticks_In_Day)); 401 402 Hour := Hour_Number (Time / Ticks_In_Hour); 403 Minute := Minute_Number ((Time mod Ticks_In_Hour) / Ticks_In_Minute); 404 Second := 405 Second_Number 406 ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute) 407 / Ticks_In_Second); 408 Nanosecond_100 := 409 Nano_Second_100_Number 410 ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute) 411 mod Ticks_In_Second); 412 end Split; 413 414end Matreshka.Internals.Calendars.Times; 415