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