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