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