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-2023, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 package body Types is
  27
  28    -----------------------
  29    -- Local Subprograms --
  30    -----------------------
  31
  32    function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat;
  33    --  Extract two decimal digit value from time stamp
  34
  35    ---------
  36    -- "<" --
  37    ---------
  38
  39    function "<" (Left, Right : Time_Stamp_Type) return Boolean is
  40    begin
  41       return not (Left = Right) and then String (Left) < String (Right);
  42    end "<";
  43
  44    ----------
  45    -- "<=" --
  46    ----------
  47
  48    function "<=" (Left, Right : Time_Stamp_Type) return Boolean is
  49    begin
  50       return not (Left > Right);
  51    end "<=";
  52
  53    ---------
  54    -- "=" --
  55    ---------
  56
  57    function "=" (Left, Right : Time_Stamp_Type) return Boolean is
  58       Sleft  : Nat;
  59       Sright : Nat;
  60
  61    begin
  62       if String (Left) = String (Right) then
  63          return True;
  64
  65       elsif Left (1) = ' ' or else Right (1) = ' ' then
  66          return False;
  67       end if;
  68
  69       --  In the following code we check for a difference of 2 seconds or less
  70
  71       --  Recall that the time stamp format is:
  72
  73       --     Y  Y  Y  Y  M  M  D  D  H  H  M  M  S  S
  74       --    01 02 03 04 05 06 07 08 09 10 11 12 13 14
  75
  76       --  Note that we do not bother to worry about shifts in the day.
  77       --  It seems unlikely that such shifts could ever occur in practice
  78       --  and even if they do we err on the safe side, i.e., we say that the
  79       --  time stamps are different.
  80
  81       Sright := V (Right, 13) + 60 * (V (Right, 11) + 60 * V (Right, 09));
  82       Sleft  := V (Left,  13) + 60 * (V (Left,  11) + 60 * V (Left,  09));
  83
  84       --  So the check is: dates must be the same, times differ 2 sec at most
  85
  86       return abs (Sleft - Sright) <= 2
  87          and then String (Left (1 .. 8)) = String (Right (1 .. 8));
  88    end "=";
  89
  90    ---------
  91    -- ">" --
  92    ---------
  93
  94    function ">" (Left, Right : Time_Stamp_Type) return Boolean is
  95    begin
  96       return not (Left = Right) and then String (Left) > String (Right);
  97    end ">";
  98
  99    ----------
 100    -- ">=" --
 101    ----------
 102
 103    function ">=" (Left, Right : Time_Stamp_Type) return Boolean is
 104    begin
 105       return not (Left < Right);
 106    end ">=";
 107
 108    -------------------
 109    -- Get_Char_Code --
 110    -------------------
 111
 112    function Get_Char_Code (C : Character) return Char_Code is
 113    begin
 114       return Char_Code'Val (Character'Pos (C));
 115    end Get_Char_Code;
 116
 117    -------------------
 118    -- Get_Character --
 119    -------------------
 120
 121    function Get_Character (C : Char_Code) return Character is
 122    begin
 123       pragma Assert (C <= 255);
 124       return Character'Val (C);
 125    end Get_Character;
 126
 127    --------------------
 128    -- Get_Hex_String --
 129    --------------------
 130
 131    subtype Wordh is Word range 0 .. 15;
 132    Hex : constant array (Wordh) of Character := "0123456789abcdef";
 133
 134    function Get_Hex_String (W : Word) return Word_Hex_String is
 135       X  : Word := W;
 136       WS : Word_Hex_String;
 137
 138    begin
 139       for J in reverse 1 .. 8 loop
 140          WS (J) := Hex (X mod 16);
 141          X := X / 16;
 142       end loop;
 143
 144       return WS;
 145    end Get_Hex_String;
 146
 147    ------------------------
 148    -- Get_Wide_Character --
 149    ------------------------
 150
 151    function Get_Wide_Character (C : Char_Code) return Wide_Character is
 152    begin
 153       pragma Assert (C <= 65535);
 154       return Wide_Character'Val (C);
 155    end Get_Wide_Character;
 156
 157    ------------------------
 158    -- In_Character_Range --
 159    ------------------------
 160
 161    function In_Character_Range (C : Char_Code) return Boolean is
 162    begin
 163       return (C <= 255);
 164    end In_Character_Range;
 165
 166    -----------------------------
 167    -- In_Wide_Character_Range --
 168    -----------------------------
 169
 170    function In_Wide_Character_Range (C : Char_Code) return Boolean is
 171    begin
 172       return (C <= 65535);
 173    end In_Wide_Character_Range;
 174
 175    ---------------------
 176    -- Make_Time_Stamp --
 177    ---------------------
 178
 179    procedure Make_Time_Stamp
 180      (Year    : Nat;
 181       Month   : Nat;
 182       Day     : Nat;
 183       Hour    : Nat;
 184       Minutes : Nat;
 185       Seconds : Nat;
 186       TS      : out Time_Stamp_Type)
 187    is
 188       Z : constant := Character'Pos ('0');
 189
 190    begin
 191       TS (01) := Character'Val (Z + Year / 1000);
 192       TS (02) := Character'Val (Z + (Year / 100) mod 10);
 193       TS (03) := Character'Val (Z + (Year / 10) mod 10);
 194       TS (04) := Character'Val (Z + Year mod 10);
 195       TS (05) := Character'Val (Z + Month / 10);
 196       TS (06) := Character'Val (Z + Month mod 10);
 197       TS (07) := Character'Val (Z + Day / 10);
 198       TS (08) := Character'Val (Z + Day mod 10);
 199       TS (09) := Character'Val (Z + Hour / 10);
 200       TS (10) := Character'Val (Z + Hour mod 10);
 201       TS (11) := Character'Val (Z + Minutes / 10);
 202       TS (12) := Character'Val (Z + Minutes mod 10);
 203       TS (13) := Character'Val (Z + Seconds / 10);
 204       TS (14) := Character'Val (Z + Seconds mod 10);
 205    end Make_Time_Stamp;
 206
 207    ----------------------------
 208    -- Null_Source_Buffer_Ptr --
 209    ----------------------------
 210
 211    function Null_Source_Buffer_Ptr (X : Source_Buffer_Ptr) return Boolean is
 212    begin
 213       return Source_Buffer_Ptr_Equal (X, null);
 214    end Null_Source_Buffer_Ptr;
 215
 216    ----------------------
 217    -- Split_Time_Stamp --
 218    ----------------------
 219
 220    procedure Split_Time_Stamp
 221      (TS      : Time_Stamp_Type;
 222       Year    : out Nat;
 223       Month   : out Nat;
 224       Day     : out Nat;
 225       Hour    : out Nat;
 226       Minutes : out Nat;
 227       Seconds : out Nat)
 228    is
 229
 230    begin
 231       --     Y  Y  Y  Y  M  M  D  D  H  H  M  M  S  S
 232       --    01 02 03 04 05 06 07 08 09 10 11 12 13 14
 233
 234       Year    := 100 * V (TS, 01) + V (TS, 03);
 235       Month   := V (TS, 05);
 236       Day     := V (TS, 07);
 237       Hour    := V (TS, 09);
 238       Minutes := V (TS, 11);
 239       Seconds := V (TS, 13);
 240    end Split_Time_Stamp;
 241
 242    -------
 243    -- V --
 244    -------
 245
 246    function V (T : Time_Stamp_Type; X : Time_Stamp_Index) return Nat is
 247    begin
 248       return 10 * (Character'Pos (T (X))     - Character'Pos ('0')) +
 249                    Character'Pos (T (X + 1)) - Character'Pos ('0');
 250    end V;
 251
 252 end Types;