gcc/ada/libgnat/s-valuti.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                      S Y S T E M . V A L _ U T I L                       --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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 with System.Case_Util; use System.Case_Util;
  33
  34 package body System.Val_Util is
  35
  36    ---------------
  37    -- Bad_Value --
  38    ---------------
  39
  40    procedure Bad_Value (S : String) is
  41    begin
  42       raise Constraint_Error with "bad input for 'Value: """ & S & '"';
  43    end Bad_Value;
  44
  45    ----------------------
  46    -- Normalize_String --
  47    ----------------------
  48
  49    procedure Normalize_String
  50      (S    : in out String;
  51       F, L : out Integer)
  52    is
  53    begin
  54       F := S'First;
  55       L := S'Last;
  56
  57       --  Scan for leading spaces
  58
  59       while F <= L and then S (F) = ' ' loop
  60          F := F + 1;
  61       end loop;
  62
  63       --  Check for case when the string contained no characters
  64
  65       if F > L then
  66          Bad_Value (S);
  67       end if;
  68
  69       --  Scan for trailing spaces
  70
  71       while S (L) = ' ' loop
  72          L := L - 1;
  73       end loop;
  74
  75       --  Except in the case of a character literal, convert to upper case
  76
  77       if S (F) /= ''' then
  78          for J in F .. L loop
  79             S (J) := To_Upper (S (J));
  80          end loop;
  81       end if;
  82    end Normalize_String;
  83
  84    -------------------
  85    -- Scan_Exponent --
  86    -------------------
  87
  88    function Scan_Exponent
  89      (Str  : String;
  90       Ptr  : not null access Integer;
  91       Max  : Integer;
  92       Real : Boolean := False) return Integer
  93    is
  94       P : Natural := Ptr.all;
  95       M : Boolean;
  96       X : Integer;
  97
  98    begin
  99       if P >= Max
 100         or else (Str (P) /= 'E' and then Str (P) /= 'e')
 101       then
 102          return 0;
 103       end if;
 104
 105       --  We have an E/e, see if sign follows
 106
 107       P := P + 1;
 108
 109       if Str (P) = '+' then
 110          P := P + 1;
 111
 112          if P > Max then
 113             return 0;
 114          else
 115             M := False;
 116          end if;
 117
 118       elsif Str (P) = '-' then
 119          P := P + 1;
 120
 121          if P > Max or else not Real then
 122             return 0;
 123          else
 124             M := True;
 125          end if;
 126
 127       else
 128          M := False;
 129       end if;
 130
 131       if Str (P) not in '0' .. '9' then
 132          return 0;
 133       end if;
 134
 135       --  Scan out the exponent value as an unsigned integer. Values larger
 136       --  than (Integer'Last / 10) are simply considered large enough here.
 137       --  This assumption is correct for all machines we know of (e.g. in the
 138       --  case of 16 bit integers it allows exponents up to 3276, which is
 139       --  large enough for the largest floating types in base 2.)
 140
 141       X := 0;
 142
 143       loop
 144          if X < (Integer'Last / 10) then
 145             X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0'));
 146          end if;
 147
 148          P := P + 1;
 149
 150          exit when P > Max;
 151
 152          if Str (P) = '_' then
 153             Scan_Underscore (Str, P, Ptr, Max, False);
 154          else
 155             exit when Str (P) not in '0' .. '9';
 156          end if;
 157       end loop;
 158
 159       if M then
 160          X := -X;
 161       end if;
 162
 163       Ptr.all := P;
 164       return X;
 165    end Scan_Exponent;
 166
 167    --------------------
 168    -- Scan_Plus_Sign --
 169    --------------------
 170
 171    procedure Scan_Plus_Sign
 172      (Str   : String;
 173       Ptr   : not null access Integer;
 174       Max   : Integer;
 175       Start : out Positive)
 176    is
 177       P : Natural := Ptr.all;
 178
 179    begin
 180       if P > Max then
 181          Bad_Value (Str);
 182       end if;
 183
 184       --  Scan past initial blanks
 185
 186       while Str (P) = ' ' loop
 187          P := P + 1;
 188
 189          if P > Max then
 190             Ptr.all := P;
 191             Bad_Value (Str);
 192          end if;
 193       end loop;
 194
 195       Start := P;
 196
 197       --  Skip past an initial plus sign
 198
 199       if Str (P) = '+' then
 200          P := P + 1;
 201
 202          if P > Max then
 203             Ptr.all := Start;
 204             Bad_Value (Str);
 205          end if;
 206       end if;
 207
 208       Ptr.all := P;
 209    end Scan_Plus_Sign;
 210
 211    ---------------
 212    -- Scan_Sign --
 213    ---------------
 214
 215    procedure Scan_Sign
 216      (Str   : String;
 217       Ptr   : not null access Integer;
 218       Max   : Integer;
 219       Minus : out Boolean;
 220       Start : out Positive)
 221    is
 222       P : Natural := Ptr.all;
 223
 224    begin
 225       --  Deal with case of null string (all blanks). As per spec, we raise
 226       --  constraint error, with Ptr unchanged, and thus > Max.
 227
 228       if P > Max then
 229          Bad_Value (Str);
 230       end if;
 231
 232       --  Scan past initial blanks
 233
 234       while Str (P) = ' ' loop
 235          P := P + 1;
 236
 237          if P > Max then
 238             Ptr.all := P;
 239             Bad_Value (Str);
 240          end if;
 241       end loop;
 242
 243       Start := P;
 244
 245       --  Remember an initial minus sign
 246
 247       if Str (P) = '-' then
 248          Minus := True;
 249          P := P + 1;
 250
 251          if P > Max then
 252             Ptr.all := Start;
 253             Bad_Value (Str);
 254          end if;
 255
 256       --  Skip past an initial plus sign
 257
 258       elsif Str (P) = '+' then
 259          Minus := False;
 260          P := P + 1;
 261
 262          if P > Max then
 263             Ptr.all := Start;
 264             Bad_Value (Str);
 265          end if;
 266
 267       else
 268          Minus := False;
 269       end if;
 270
 271       Ptr.all := P;
 272    end Scan_Sign;
 273
 274    --------------------------
 275    -- Scan_Trailing_Blanks --
 276    --------------------------
 277
 278    procedure Scan_Trailing_Blanks (Str : String; P : Positive) is
 279    begin
 280       for J in P .. Str'Last loop
 281          if Str (J) /= ' ' then
 282             Bad_Value (Str);
 283          end if;
 284       end loop;
 285    end Scan_Trailing_Blanks;
 286
 287    ---------------------
 288    -- Scan_Underscore --
 289    ---------------------
 290
 291    procedure Scan_Underscore
 292      (Str : String;
 293       P   : in out Natural;
 294       Ptr : not null access Integer;
 295       Max : Integer;
 296       Ext : Boolean)
 297    is
 298       C : Character;
 299
 300    begin
 301       P := P + 1;
 302
 303       --  If underscore is at the end of string, then this is an error and we
 304       --  raise Constraint_Error, leaving the pointer past the underscore. This
 305       --  seems a bit strange. It means e.g. that if the field is:
 306
 307       --    345_
 308
 309       --  that Constraint_Error is raised. You might think that the RM in this
 310       --  case would scan out the 345 as a valid integer, leaving the pointer
 311       --  at the underscore, but the ACVC suite clearly requires an error in
 312       --  this situation (see for example CE3704M).
 313
 314       if P > Max then
 315          Ptr.all := P;
 316          Bad_Value (Str);
 317       end if;
 318
 319       --  Similarly, if no digit follows the underscore raise an error. This
 320       --  also catches the case of double underscore which is also an error.
 321
 322       C := Str (P);
 323
 324       if C in '0' .. '9'
 325         or else (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f'))
 326       then
 327          return;
 328       else
 329          Ptr.all := P;
 330          Bad_Value (Str);
 331       end if;
 332    end Scan_Underscore;
 333
 334 end System.Val_Util;