diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/types.adb')
-rw-r--r-- | gcc-4.2.1/gcc/ada/types.adb | 251 |
1 files changed, 251 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/types.adb b/gcc-4.2.1/gcc/ada/types.adb new file mode 100644 index 000000000..978b4121f --- /dev/null +++ b/gcc-4.2.1/gcc/ada/types.adb @@ -0,0 +1,251 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- T Y P E S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package body Types is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat; + -- Extract two decimal digit value from time stamp + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left = Right) and then String (Left) < String (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left > Right); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Time_Stamp_Type) return Boolean is + Sleft : Nat; + Sright : Nat; + + begin + if String (Left) = String (Right) then + return True; + + elsif Left (1) = ' ' or else Right (1) = ' ' then + return False; + end if; + + -- In the following code we check for a difference of 2 seconds or less + + -- Recall that the time stamp format is: + + -- Y Y Y Y M M D D H H M M S S + -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14 + + -- Note that we do not bother to worry about shifts in the day. + -- It seems unlikely that such shifts could ever occur in practice + -- and even if they do we err on the safe side, ie we say that the time + -- stamps are different. + + Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09)); + Sleft := V (Left, 13) + 60 * (V (Left, 11) + 60 * V (Left, 09)); + + -- So the check is: dates must be the same, times differ 2 sec at most + + return abs (Sleft - Sright) <= 2 + and then String (Left (1 .. 8)) = String (Right (1 .. 8)); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left = Right) and then String (Left) > String (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time_Stamp_Type) return Boolean is + begin + return not (Left < Right); + end ">="; + + ------------------- + -- Get_Char_Code -- + ------------------- + + function Get_Char_Code (C : Character) return Char_Code is + begin + return Char_Code'Val (Character'Pos (C)); + end Get_Char_Code; + + ------------------- + -- Get_Character -- + ------------------- + + function Get_Character (C : Char_Code) return Character is + begin + pragma Assert (C <= 255); + return Character'Val (C); + end Get_Character; + + -------------------- + -- Get_Hex_String -- + -------------------- + + subtype Wordh is Word range 0 .. 15; + Hex : constant array (Wordh) of Character := "0123456789abcdef"; + + function Get_Hex_String (W : Word) return Word_Hex_String is + X : Word := W; + WS : Word_Hex_String; + + begin + for J in reverse 1 .. 8 loop + WS (J) := Hex (X mod 16); + X := X / 16; + end loop; + + return WS; + end Get_Hex_String; + + ------------------------ + -- Get_Wide_Character -- + ------------------------ + + function Get_Wide_Character (C : Char_Code) return Wide_Character is + begin + pragma Assert (C <= 65535); + return Wide_Character'Val (C); + end Get_Wide_Character; + + ------------------------ + -- In_Character_Range -- + ------------------------ + + function In_Character_Range (C : Char_Code) return Boolean is + begin + return (C <= 255); + end In_Character_Range; + + ----------------------------- + -- In_Wide_Character_Range -- + ----------------------------- + + function In_Wide_Character_Range (C : Char_Code) return Boolean is + begin + return (C <= 65535); + end In_Wide_Character_Range; + + --------------------- + -- Make_Time_Stamp -- + --------------------- + + procedure Make_Time_Stamp + (Year : Nat; + Month : Nat; + Day : Nat; + Hour : Nat; + Minutes : Nat; + Seconds : Nat; + TS : out Time_Stamp_Type) + is + Z : constant := Character'Pos ('0'); + + begin + TS (01) := Character'Val (Z + Year / 1000); + TS (02) := Character'Val (Z + (Year / 100) mod 10); + TS (03) := Character'Val (Z + (Year / 10) mod 10); + TS (04) := Character'Val (Z + Year mod 10); + TS (05) := Character'Val (Z + Month / 10); + TS (06) := Character'Val (Z + Month mod 10); + TS (07) := Character'Val (Z + Day / 10); + TS (08) := Character'Val (Z + Day mod 10); + TS (09) := Character'Val (Z + Hour / 10); + TS (10) := Character'Val (Z + Hour mod 10); + TS (11) := Character'Val (Z + Minutes / 10); + TS (12) := Character'Val (Z + Minutes mod 10); + TS (13) := Character'Val (Z + Seconds / 10); + TS (14) := Character'Val (Z + Seconds mod 10); + end Make_Time_Stamp; + + ---------------------- + -- Split_Time_Stamp -- + ---------------------- + + procedure Split_Time_Stamp + (TS : Time_Stamp_Type; + Year : out Nat; + Month : out Nat; + Day : out Nat; + Hour : out Nat; + Minutes : out Nat; + Seconds : out Nat) + is + + begin + -- Y Y Y Y M M D D H H M M S S + -- 01 02 03 04 05 06 07 08 09 10 11 12 13 14 + + Year := 100 * V (TS, 01) + V (TS, 03); + Month := V (TS, 05); + Day := V (TS, 07); + Hour := V (TS, 09); + Minutes := V (TS, 11); + Seconds := V (TS, 13); + end Split_Time_Stamp; + + ------- + -- V -- + ------- + + function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is + begin + return 10 * (Character'Pos (T (X)) - Character'Pos ('0')) + + Character'Pos (T (X + 1)) - Character'Pos ('0'); + end V; + +end Types; |