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