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