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