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-2001 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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    -- In_Character_Range --
 157    ------------------------
 158
 159    function In_Character_Range (C : Char_Code) return Boolean is
 160    begin
 161       return (C <= 255);
 162    end In_Character_Range;
 163
 164    ---------------------
 165    -- Make_Time_Stamp --
 166    ---------------------
 167
 168    procedure Make_Time_Stamp
 169      (Year    : Nat;
 170       Month   : Nat;
 171       Day     : Nat;
 172       Hour    : Nat;
 173       Minutes : Nat;
 174       Seconds : Nat;
 175       TS      : out Time_Stamp_Type)
 176    is
 177       Z : constant := Character'Pos ('0');
 178
 179    begin
 180       TS (01) := Character'Val (Z + Year / 1000);
 181       TS (02) := Character'Val (Z + (Year / 100) mod 10);
 182       TS (03) := Character'Val (Z + (Year / 10) mod 10);
 183       TS (04) := Character'Val (Z + Year mod 10);
 184       TS (05) := Character'Val (Z + Month / 10);
 185       TS (06) := Character'Val (Z + Month mod 10);
 186       TS (07) := Character'Val (Z + Day / 10);
 187       TS (08) := Character'Val (Z + Day mod 10);
 188       TS (09) := Character'Val (Z + Hour / 10);
 189       TS (10) := Character'Val (Z + Hour mod 10);
 190       TS (11) := Character'Val (Z + Minutes / 10);
 191       TS (12) := Character'Val (Z + Minutes mod 10);
 192       TS (13) := Character'Val (Z + Seconds / 10);
 193       TS (14) := Character'Val (Z + Seconds mod 10);
 194    end Make_Time_Stamp;
 195
 196    ----------------------
 197    -- Split_Time_Stamp --
 198    ----------------------
 199
 200    procedure Split_Time_Stamp
 201      (TS      : Time_Stamp_Type;
 202       Year    : out Nat;
 203       Month   : out Nat;
 204       Day     : out Nat;
 205       Hour    : out Nat;
 206       Minutes : out Nat;
 207       Seconds : out Nat)
 208    is
 209
 210    begin
 211       --     Y  Y  Y  Y  M  M  D  D  H  H  M  M  S  S
 212       --    01 02 03 04 05 06 07 08 09 10 11 12 13 14
 213
 214       Year    := 100 * V (TS, 01) + V (TS, 03);
 215       Month   := V (TS, 05);
 216       Day     := V (TS, 07);
 217       Hour    := V (TS, 09);
 218       Minutes := V (TS, 11);
 219       Seconds := V (TS, 13);
 220    end Split_Time_Stamp;
 221
 222    -------
 223    -- V --
 224    -------
 225
 226    function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is
 227    begin
 228       return 10 * (Character'Pos (T (X))     - Character'Pos ('0')) +
 229                    Character'Pos (T (X + 1)) - Character'Pos ('0');
 230    end V;
 231
 232 end Types;