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