diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/a-calend-vms.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/a-calend-vms.adb | 361 |
1 files changed, 361 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/a-calend-vms.adb b/gcc-4.2.1/gcc/ada/a-calend-vms.adb new file mode 100644 index 000000000..2a5c70f6b --- /dev/null +++ b/gcc-4.2.1/gcc/ada/a-calend-vms.adb @@ -0,0 +1,361 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version + +with System.Aux_DEC; use System.Aux_DEC; + +package body Ada.Calendar is + + ------------------------------ + -- Use of Pragma Unsuppress -- + ------------------------------ + + -- This implementation of Calendar takes advantage of the permission in + -- Ada 95 of using arithmetic overflow checks to check for out of bounds + -- time values. This means that we must catch the constraint error that + -- results from arithmetic overflow, so we use pragma Unsuppress to make + -- sure that overflow is enabled, using software overflow checking if + -- necessary. That way, compiling Calendar with options to suppress this + -- checking will not affect its correctness. + + ------------------------ + -- Local Declarations -- + ------------------------ + + Ada_Year_Min : constant := 1901; + Ada_Year_Max : constant := 2099; + + -- Some basic constants used throughout + + function To_Relative_Time (D : Duration) return Time; + + function To_Relative_Time (D : Duration) return Time is + begin + return Time (Long_Integer'Integer_Value (D) / 100); + end To_Relative_Time; + + --------- + -- "+" -- + --------- + + function "+" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return (Left + To_Relative_Time (Right)); + + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + function "+" (Left : Duration; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); + begin + return (To_Relative_Time (Left) + Right); + + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Left - To_Relative_Time (Right); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + function "-" (Left : Time; Right : Time) return Duration is + pragma Unsuppress (Overflow_Check); + begin + return Duration'Fixed_Value + ((Long_Integer (Left) - Long_Integer (Right)) * 100); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) < Long_Integer (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) <= Long_Integer (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) > Long_Integer (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) >= Long_Integer (Right); + end ">="; + + ----------- + -- Clock -- + ----------- + + -- The Ada.Calendar.Clock function gets the time. + -- Note that on other targets a soft-link is used to get a different clock + -- depending whether tasking is used or not. On VMS this isn't needed + -- since all clock calls end up using SYS$GETTIM, so call the + -- OS_Primitives version for efficiency. + + function Clock return Time is + begin + return Time (OSP.OS_Clock); + end Clock; + + --------- + -- Day -- + --------- + + function Day (Date : Time) return Day_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DD; + end Day; + + ----------- + -- Month -- + ----------- + + function Month (Date : Time) return Month_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DM; + end Month; + + ------------- + -- Seconds -- + ------------- + + function Seconds (Date : Time) return Day_Duration is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DS; + end Seconds; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration) + is + procedure Numtim ( + Status : out Unsigned_Longword; + Timbuf : out Unsigned_Word_Array; + Timadr : in Time); + + pragma Interface (External, Numtim); + + pragma Import_Valued_Procedure (Numtim, "SYS$NUMTIM", + (Unsigned_Longword, Unsigned_Word_Array, Time), + (Value, Reference, Reference)); + + Status : Unsigned_Longword; + Timbuf : Unsigned_Word_Array (1 .. 7); + + Subsecs : constant Time := Date mod 10_000_000; + Date_Secs : constant Time := Date - Subsecs; + + begin + Numtim (Status, Timbuf, Date_Secs); + + if Status mod 2 /= 1 + or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max + then + raise Time_Error; + end if; + + Seconds := Day_Duration (Timbuf (6) + + 60 * (Timbuf (5) + 60 * Timbuf (4))) + + Duration (Subsecs) / 10_000_000.0; + + Day := Integer (Timbuf (3)); + Month := Integer (Timbuf (2)); + Year := Integer (Timbuf (1)); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) + return Time + is + + procedure Cvt_Vectim ( + Status : out Unsigned_Longword; + Input_Time : in Unsigned_Word_Array; + Resultant_Time : out Time); + + pragma Interface (External, Cvt_Vectim); + + pragma Import_Valued_Procedure (Cvt_Vectim, "LIB$CVT_VECTIM", + (Unsigned_Longword, Unsigned_Word_Array, Time), + (Value, Reference, Reference)); + + Status : Unsigned_Longword; + Timbuf : Unsigned_Word_Array (1 .. 7); + Date : Time; + Int_Secs : Integer; + Day_Hack : Boolean := False; + Subsecs : Day_Duration; + + begin + -- The following checks are redundant with respect to the constraint + -- error checks that should normally be made on parameters, but we + -- decide to raise Constraint_Error in any case if bad values come + -- in (as a result of checks being off in the caller, or for other + -- erroneous or bounded error cases). + + if not Year 'Valid + or else not Month 'Valid + or else not Day 'Valid + or else not Seconds'Valid + then + raise Constraint_Error; + end if; + + -- Truncate seconds value by subtracting 0.5 and rounding, + -- but be careful with 0.0 since that will give -1.0 unless + -- it is treated specially. + + if Seconds > 0.0 then + Int_Secs := Integer (Seconds - 0.5); + else + Int_Secs := Integer (Seconds); + end if; + + Subsecs := Seconds - Day_Duration (Int_Secs); + + -- Cvt_Vectim barfs on the largest Day_Duration, so trick it by + -- setting it to zero and then adding the difference after conversion. + + if Int_Secs = 86_400 then + Int_Secs := 0; + Day_Hack := True; + end if; + + Timbuf (7) := 0; + Timbuf (6) := Unsigned_Word (Int_Secs mod 60); + Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60); + Timbuf (4) := Unsigned_Word (Int_Secs / 3600); + Timbuf (3) := Unsigned_Word (Day); + Timbuf (2) := Unsigned_Word (Month); + Timbuf (1) := Unsigned_Word (Year); + + Cvt_Vectim (Status, Timbuf, Date); + + if Status mod 2 /= 1 then + raise Time_Error; + end if; + + if Day_Hack then + Date := Date + 10_000_000 * 86_400; + end if; + + Date := Date + Time (10_000_000.0 * Subsecs); + return Date; + end Time_Of; + + ---------- + -- Year -- + ---------- + + function Year (Date : Time) return Year_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DY; + end Year; + +end Ada.Calendar; |