gcc/ada/types.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                T Y P E S                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 package body Types is
  35
  36    -----------------------
  37    -- Local Subprograms --
  38    -----------------------
  39
  40    function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat;
  41    --  Extract two decimal digit value from time stamp
  42
  43    ---------
  44    -- "<" --
  45    ---------
  46
  47    function "<" (Left, Right : Time_Stamp_Type) return Boolean is
  48    begin
  49       return not (Left = Right) and then String (Left) < String (Right);
  50    end "<";
  51
  52    ----------
  53    -- "<=" --
  54    ----------
  55
  56    function "<=" (Left, Right : Time_Stamp_Type) return Boolean is
  57    begin
  58       return not (Left > Right);
  59    end "<=";
  60
  61    ---------
  62    -- "=" --
  63    ---------
  64
  65    function "=" (Left, Right : Time_Stamp_Type) return Boolean is
  66       Sleft  : Nat;
  67       Sright : Nat;
  68
  69    begin
  70       if String (Left) = String (Right) then
  71          return True;
  72
  73       elsif Left (1) = ' ' or else Right (1) = ' ' then
  74          return False;
  75       end if;
  76
  77       --  In the following code we check for a difference of 2 seconds or less
  78
  79       --  Recall that the time stamp format is:
  80
  81       --     Y  Y  Y  Y  M  M  D  D  H  H  M  M  S  S
  82       --    01 02 03 04 05 06 07 08 09 10 11 12 13 14
  83
  84       --  Note that we do not bother to worry about shifts in the day.
  85       --  It seems unlikely that such shifts could ever occur in practice
  86       --  and even if they do we err on the safe side, ie we say that the time
  87       --  stamps are different.
  88
  89       Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09));
  90       Sleft  := V (Left,  13) + 60 * (V (Left,  11) + 60 * V (Left,  09));
  91
  92       --  So the check is: dates must be the same, times differ 2 sec at most
  93
  94       return abs (Sleft - Sright) <= 2
  95          and then String (Left (1 .. 8)) = String (Right (1 .. 8));
  96    end "=";
  97
  98    ---------
  99    -- ">" --
 100    ---------
 101
 102    function ">" (Left, Right : Time_Stamp_Type) return Boolean is
 103    begin
 104       return not (Left = Right) and then String (Left) > String (Right);
 105    end ">";
 106
 107    ----------
 108    -- ">=" --
 109    ----------
 110
 111    function ">=" (Left, Right : Time_Stamp_Type) return Boolean is
 112    begin
 113       return not (Left < Right);
 114    end ">=";
 115
 116    -------------------
 117    -- Get_Char_Code --
 118    -------------------
 119
 120    function Get_Char_Code (C : Character) return Char_Code is
 121    begin
 122       return Char_Code'Val (Character'Pos (C));
 123    end Get_Char_Code;
 124
 125    -------------------
 126    -- Get_Character --
 127    -------------------
 128
 129    function Get_Character (C : Char_Code) return Character is
 130    begin
 131       pragma Assert (C <= 255);
 132       return Character'Val (C);
 133    end Get_Character;
 134
 135    --------------------
 136    -- Get_Hex_String --
 137    --------------------
 138
 139    subtype Wordh is Word range 0 .. 15;
 140    Hex : constant array (Wordh) of Character := "0123456789abcdef";
 141
 142    function Get_Hex_String (W : Word) return Word_Hex_String is
 143       X  : Word := W;
 144       WS : Word_Hex_String;
 145
 146    begin
 147       for J in reverse 1 .. 8 loop
 148          WS (J) := Hex (X mod 16);
 149          X := X / 16;
 150       end loop;
 151
 152       return WS;
 153    end Get_Hex_String;
 154
 155    ------------------------
 156    -- Get_Wide_Character --
 157    ------------------------
 158
 159    function Get_Wide_Character (C : Char_Code) return Wide_Character is
 160    begin
 161       pragma Assert (C <= 65535);
 162       return Wide_Character'Val (C);
 163    end Get_Wide_Character;
 164
 165    ------------------------
 166    -- In_Character_Range --
 167    ------------------------
 168
 169    function In_Character_Range (C : Char_Code) return Boolean is
 170    begin
 171       return (C <= 255);
 172    end In_Character_Range;
 173
 174    -----------------------------
 175    -- In_Wide_Character_Range --
 176    -----------------------------
 177
 178    function In_Wide_Character_Range (C : Char_Code) return Boolean is
 179    begin
 180       return (C <= 65535);
 181    end In_Wide_Character_Range;
 182
 183    ---------------------
 184    -- Make_Time_Stamp --
 185    ---------------------
 186
 187    procedure Make_Time_Stamp
 188      (Year    : Nat;
 189       Month   : Nat;
 190       Day     : Nat;
 191       Hour    : Nat;
 192       Minutes : Nat;
 193       Seconds : Nat;
 194       TS      : out Time_Stamp_Type)
 195    is
 196       Z : constant := Character'Pos ('0');
 197
 198    begin
 199       TS (01) := Character'Val (Z + Year / 1000);
 200       TS (02) := Character'Val (Z + (Year / 100) mod 10);
 201       TS (03) := Character'Val (Z + (Year / 10) mod 10);
 202       TS (04) := Character'Val (Z + Year mod 10);
 203       TS (05) := Character'Val (Z + Month / 10);
 204       TS (06) := Character'Val (Z + Month mod 10);
 205       TS (07) := Character'Val (Z + Day / 10);
 206       TS (08) := Character'Val (Z + Day mod 10);
 207       TS (09) := Character'Val (Z + Hour / 10);
 208       TS (10) := Character'Val (Z + Hour mod 10);
 209       TS (11) := Character'Val (Z + Minutes / 10);
 210       TS (12) := Character'Val (Z + Minutes mod 10);
 211       TS (13) := Character'Val (Z + Seconds / 10);
 212       TS (14) := Character'Val (Z + Seconds mod 10);
 213    end Make_Time_Stamp;
 214
 215    ----------------------
 216    -- Split_Time_Stamp --
 217    ----------------------
 218
 219    procedure Split_Time_Stamp
 220      (TS      : Time_Stamp_Type;
 221       Year    : out Nat;
 222       Month   : out Nat;
 223       Day     : out Nat;
 224       Hour    : out Nat;
 225       Minutes : out Nat;
 226       Seconds : out Nat)
 227    is
 228
 229    begin
 230       --     Y  Y  Y  Y  M  M  D  D  H  H  M  M  S  S
 231       --    01 02 03 04 05 06 07 08 09 10 11 12 13 14
 232
 233       Year    := 100 * V (TS, 01) + V (TS, 03);
 234       Month   := V (TS, 05);
 235       Day     := V (TS, 07);
 236       Hour    := V (TS, 09);
 237       Minutes := V (TS, 11);
 238       Seconds := V (TS, 13);
 239    end Split_Time_Stamp;
 240
 241    -------
 242    -- V --
 243    -------
 244
 245    function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is
 246    begin
 247       return 10 * (Character'Pos (T (X))     - Character'Pos ('0')) +
 248                    Character'Pos (T (X + 1)) - Character'Pos ('0');
 249    end V;
 250
 251 end Types;