New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45950 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 373 insertions, 0 deletions

diff --git a/gcc/ada/4vcalend.adb b/gcc/ada/4vcalend.adb
new file mode 100644
index 00000000000..0c29f602548
--- /dev/null
+++ b/gcc/ada/4vcalend.adb
@@ -0,0 +1,373 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                        GNAT RUN-TIME COMPONENTS                          --
+--                                                                          --
+--                         A D A . C A L E N D A R                          --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--            Copyright (C) 1992-2000 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,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  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
+
+   Days_In_Month : constant array (Month_Number) of Day_Number :=
+                     (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
+
+   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);
+
+   begin
+      Numtim (Status, Timbuf, Date);
+
+      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)))
+           + Day_Duration (Timbuf (7)) / 100.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;
+   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;
+
+      --  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;
+         Timbuf (7) := 0;
+      else
+         Timbuf (7) := Unsigned_Word
+          (100.0 * Duration (Seconds - Day_Duration (Int_Secs)));
+         --  Cvt_Vectim accurate only to within .01 seconds
+      end if;
+
+      --  Similar hack needed for 86399 and 100/100ths, since that gets
+      --  treated as 86400 (largest Day_Duration). This can happen because
+      --  Duration has more accuracy than VMS system time conversion calls
+      --  can handle.
+
+      if Int_Secs = 86_399 and then Timbuf (7) = 100 then
+         Int_Secs := 0;
+         Day_Hack := True;
+         Timbuf (7) := 0;
+      end if;
+
+      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;
+
+      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;