gcc/ada/libgnat/s-valrea.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                      S Y S T E M . V A L _ R E A L                       --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2019, 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.Val_Util;      use System.Val_Util;
  33 with System.Float_Control;
  34
  35 package body System.Val_Real is
  36
  37    procedure Scan_Integral_Digits
  38       (Str            : String;
  39        Index          : in out Integer;
  40        Max            : Integer;
  41        Value          : out Long_Long_Integer;
  42        Scale          : out Integer;
  43        Base_Violation : in out Boolean;
  44        Base           : Long_Long_Integer := 10;
  45        Base_Specified : Boolean := False);
  46    --  Scan the integral part of a real (i.e: before decimal separator)
  47    --
  48    --  The string parsed is Str (Index .. Max), and after the call Index will
  49    --  point to the first non parsed character.
  50    --
  51    --  For each digit parsed either value := value * base + digit, or scale
  52    --  is incremented by 1.
  53    --
  54    --  Base_Violation will be set to True a digit found is not part of the Base
  55
  56    procedure Scan_Decimal_Digits
  57       (Str            : String;
  58        Index          : in out Integer;
  59        Max            : Integer;
  60        Value          : in out Long_Long_Integer;
  61        Scale          : in out Integer;
  62        Base_Violation : in out Boolean;
  63        Base           : Long_Long_Integer := 10;
  64        Base_Specified : Boolean := False);
  65    --  Scan the decimal part of a real (i.e: after decimal separator)
  66    --
  67    --  The string parsed is Str (Index .. Max), and after the call Index will
  68    --  point to the first non parsed character.
  69    --
  70    --  For each digit parsed value = value * base + digit and scale is
  71    --  decremented by 1. If precision limit is reached remaining digits are
  72    --  still parsed but ignored.
  73    --
  74    --  Base_Violation will be set to True a digit found is not part of the Base
  75
  76    subtype Char_As_Digit is Long_Long_Integer range -2 .. 15;
  77    subtype Valid_Digit is Char_As_Digit range 0 .. Char_As_Digit'Last;
  78    Underscore : constant Char_As_Digit := -2;
  79    E_Digit : constant Char_As_Digit := 14;
  80
  81    function As_Digit (C : Character) return Char_As_Digit;
  82    --  Given a character return the digit it represent. If the character is
  83    --  not a digit then a negative value is returned, -2 for underscore and
  84    --  -1 for any other character.
  85
  86    Precision_Limit : constant Long_Long_Integer :=
  87       2 ** (Long_Long_Float'Machine_Mantissa - 1) - 1;
  88    --  This is an upper bound for the number of bits used to represent the
  89    --  mantissa. Beyond that number, any digits parsed are useless.
  90
  91    --------------
  92    -- As_Digit --
  93    --------------
  94
  95    function As_Digit (C : Character) return Char_As_Digit is
  96    begin
  97       case C is
  98          when '0' .. '9' =>
  99             return Character'Pos (C) - Character'Pos ('0');
 100          when 'a' .. 'f' =>
 101             return Character'Pos (C) - (Character'Pos ('a') - 10);
 102          when 'A' .. 'F' =>
 103             return Character'Pos (C) - (Character'Pos ('A') - 10);
 104          when '_' =>
 105             return Underscore;
 106          when others =>
 107             return -1;
 108       end case;
 109    end As_Digit;
 110
 111    -------------------------
 112    -- Scan_Decimal_Digits --
 113    -------------------------
 114
 115    procedure Scan_Decimal_Digits
 116       (Str            : String;
 117        Index          : in out Integer;
 118        Max            : Integer;
 119        Value          : in out Long_Long_Integer;
 120        Scale          : in out Integer;
 121        Base_Violation : in out Boolean;
 122        Base           : Long_Long_Integer := 10;
 123        Base_Specified : Boolean := False)
 124
 125    is
 126       Precision_Limit_Reached : Boolean := False;
 127       --  Set to True if addition of a digit will cause Value to be superior
 128       --  to Precision_Limit.
 129
 130       Digit : Char_As_Digit;
 131       --  The current digit.
 132
 133       Trailing_Zeros : Natural := 0;
 134       --  Number of trailing zeros at a given point.
 135
 136    begin
 137       pragma Assert (Base in 2 .. 16);
 138
 139       --  If initial Scale is not 0 then it means that Precision_Limit was
 140       --  reached during integral part scanning.
 141       if Scale > 0 then
 142          Precision_Limit_Reached := True;
 143       end if;
 144
 145       --  The function precondition is that the first character is a valid
 146       --  digit.
 147       Digit := As_Digit (Str (Index));
 148
 149       loop
 150          --  Check if base is correct. If the base is not specified the digit
 151          --  E or e cannot be considered as a base violation as it can be used
 152          --  for exponentiation.
 153          if Digit >= Base then
 154             if Base_Specified then
 155                Base_Violation := True;
 156             elsif Digit = E_Digit then
 157                return;
 158             else
 159                Base_Violation := True;
 160             end if;
 161          end if;
 162
 163          --  If precision limit has been reached just ignore any remaining
 164          --  digits for the computation of Value and Scale. The scanning
 165          --  should continue only to assess the validity of the string
 166          if not Precision_Limit_Reached then
 167             if Digit = 0 then
 168                --  Trailing '0' digits are ignored unless a non-zero digit is
 169                --  found.
 170                Trailing_Zeros := Trailing_Zeros + 1;
 171             else
 172
 173                --  Handle accumulated zeros.
 174                for J in 1 .. Trailing_Zeros loop
 175                   if Value > Precision_Limit / Base then
 176                      Precision_Limit_Reached := True;
 177                      exit;
 178                   else
 179                      Value := Value * Base;
 180                      Scale := Scale - 1;
 181                   end if;
 182                end loop;
 183
 184                --  Reset trailing zero counter
 185                Trailing_Zeros := 0;
 186
 187                --  Handle current non zero digit
 188                if Value > (Precision_Limit - Digit) / Base then
 189                   Precision_Limit_Reached := True;
 190                else
 191                   Value := Value * Base + Digit;
 192                   Scale := Scale - 1;
 193                end if;
 194             end if;
 195          end if;
 196
 197          --  Check next character
 198          Index := Index + 1;
 199
 200          if Index > Max then
 201             return;
 202          end if;
 203
 204          Digit := As_Digit (Str (Index));
 205
 206          if Digit < 0 then
 207             if Digit = Underscore and Index + 1 <= Max then
 208                --  Underscore is only allowed if followed by a digit
 209                Digit := As_Digit (Str (Index + 1));
 210                if Digit in Valid_Digit then
 211                   Index := Index + 1;
 212                else
 213                   return;
 214                end if;
 215             else
 216                --  Neither a valid underscore nor a digit.
 217                return;
 218             end if;
 219          end if;
 220       end loop;
 221    end Scan_Decimal_Digits;
 222
 223    --------------------------
 224    -- Scan_Integral_Digits --
 225    --------------------------
 226
 227    procedure Scan_Integral_Digits
 228       (Str            : String;
 229        Index          : in out Integer;
 230        Max            : Integer;
 231        Value          : out Long_Long_Integer;
 232        Scale          : out Integer;
 233        Base_Violation : in out Boolean;
 234        Base           : Long_Long_Integer := 10;
 235        Base_Specified : Boolean := False)
 236    is
 237       Precision_Limit_Reached : Boolean := False;
 238       --  Set to True if addition of a digit will cause Value to be superior
 239       --  to Precision_Limit.
 240
 241       Digit : Char_As_Digit;
 242       --  The current digit
 243    begin
 244
 245       --  Initialize Scale and Value
 246       Value := 0;
 247       Scale := 0;
 248
 249       --  The function precondition is that the first character is a valid
 250       --  digit.
 251       Digit := As_Digit (Str (Index));
 252
 253       loop
 254          --  Check if base is correct. If the base is not specified the digit
 255          --  E or e cannot be considered as a base violation as it can be used
 256          --  for exponentiation.
 257          if Digit >= Base then
 258             if Base_Specified then
 259                Base_Violation := True;
 260             elsif Digit = E_Digit then
 261                return;
 262             else
 263                Base_Violation := True;
 264             end if;
 265          end if;
 266
 267          if Precision_Limit_Reached then
 268             --  Precision limit has been reached so just update the exponent
 269             Scale := Scale + 1;
 270          else
 271             pragma Assert (Base /= 0);
 272
 273             if Value > (Precision_Limit - Digit) / Base then
 274                --  Updating Value will overflow so ignore this digit and any
 275                --  following ones. Only update the scale
 276                Precision_Limit_Reached := True;
 277                Scale := Scale + 1;
 278             else
 279                Value := Value * Base + Digit;
 280             end if;
 281          end if;
 282
 283          --  Look for the next character
 284          Index := Index + 1;
 285          if Index > Max then
 286             return;
 287          end if;
 288
 289          Digit := As_Digit (Str (Index));
 290
 291          if Digit not in Valid_Digit then
 292             --  Next character is not a digit. In that case stop scanning
 293             --  unless the next chracter is an underscore followed by a digit.
 294             if Digit = Underscore and Index + 1 <= Max then
 295                Digit := As_Digit (Str (Index + 1));
 296                if Digit in Valid_Digit then
 297                   Index := Index + 1;
 298                else
 299                   return;
 300                end if;
 301             else
 302                return;
 303             end if;
 304          end if;
 305       end loop;
 306
 307    end Scan_Integral_Digits;
 308
 309    ---------------
 310    -- Scan_Real --
 311    ---------------
 312
 313    function Scan_Real
 314       (Str : String;
 315        Ptr : not null access Integer;
 316        Max : Integer)
 317       return Long_Long_Float
 318
 319    is
 320       Start : Positive;
 321       --  Position of starting non-blank character
 322
 323       Minus : Boolean;
 324       --  Set to True if minus sign is present, otherwise to False
 325
 326       Index : Integer;
 327       --  Local copy of string pointer
 328
 329       Int_Value : Long_Long_Integer := -1;
 330       --  Mantissa as an Integer
 331
 332       Int_Scale : Integer := 0;
 333       --  Exponent value
 334
 335       Base_Violation : Boolean := False;
 336       --  If True some digits where not in the base. The float is still scan
 337       --  till the end even if an error will be raised.
 338
 339       Uval : Long_Long_Float := 0.0;
 340       --  Contain the final value at the end of the function
 341
 342       After_Point : Boolean := False;
 343       --  True if a decimal should be parsed
 344
 345       Base : Long_Long_Integer := 10;
 346       --  Current base (default: 10)
 347
 348       Base_Char : Character := ASCII.NUL;
 349       --  Character used to set the base. If Nul this means that default
 350       --  base is used.
 351
 352    begin
 353       --  We do not tolerate strings with Str'Last = Positive'Last
 354
 355       if Str'Last = Positive'Last then
 356          raise Program_Error with
 357            "string upper bound is Positive'Last, not supported";
 358       end if;
 359
 360       --  We call the floating-point processor reset routine so that we can
 361       --  be sure the floating-point processor is properly set for conversion
 362       --  calls. This is notably need on Windows, where calls to the operating
 363       --  system randomly reset the processor into 64-bit mode.
 364
 365       System.Float_Control.Reset;
 366
 367       --  Scan the optional sign
 368       Scan_Sign (Str, Ptr, Max, Minus, Start);
 369       Index := Ptr.all;
 370       Ptr.all := Start;
 371
 372       --  First character can be either a decimal digit or a dot.
 373       if Str (Index) in '0' .. '9' then
 374          pragma Annotate
 375            (CodePeer, Intentional,
 376             "test always true", "defensive code below");
 377
 378          --  If this is a digit it can indicates either the float decimal
 379          --  part or the base to use
 380          Scan_Integral_Digits
 381             (Str,
 382              Index,
 383              Max            => Max,
 384              Value          => Int_Value,
 385              Scale          => Int_Scale,
 386              Base_Violation => Base_Violation,
 387              Base           => 10);
 388       elsif Str (Index) = '.' and then
 389          --  A dot is only allowed if followed by a digit.
 390          Index < Max and then
 391          Str (Index + 1) in '0' .. '9'
 392       then
 393          --  Initial point, allowed only if followed by digit (RM 3.5(47))
 394          After_Point := True;
 395          Index := Index + 1;
 396          Int_Value := 0;
 397       else
 398          Bad_Value (Str);
 399       end if;
 400
 401       --  Check if the first number encountered is a base
 402       if Index < Max and then
 403          (Str (Index) = '#' or else Str (Index) = ':')
 404       then
 405          Base_Char := Str (Index);
 406          Base := Int_Value;
 407
 408          --  Reset Int_Value to indicate that parsing of integral value should
 409          --  be done
 410          Int_Value := -1;
 411          if Base < 2 or else Base > 16 then
 412             Base_Violation := True;
 413             Base := 16;
 414          end if;
 415
 416          Index := Index + 1;
 417
 418          if Str (Index) = '.' and then
 419             Index < Max and then
 420             As_Digit (Str (Index + 1)) in Valid_Digit
 421          then
 422             After_Point := True;
 423             Index := Index + 1;
 424             Int_Value := 0;
 425          end if;
 426       end if;
 427
 428       --  Does scanning of integral part needed
 429       if Int_Value < 0 then
 430          if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then
 431             Bad_Value (Str);
 432          end if;
 433
 434          Scan_Integral_Digits
 435             (Str,
 436              Index,
 437              Max => Max,
 438              Value => Int_Value,
 439              Scale => Int_Scale,
 440              Base_Violation => Base_Violation,
 441              Base => Base,
 442              Base_Specified => Base_Char /= ASCII.NUL);
 443       end if;
 444
 445       --  Do we have a dot ?
 446       if not After_Point and then
 447          Index <= Max and then
 448          Str (Index) = '.'
 449       then
 450          --  At this stage if After_Point was not set, this means that an
 451          --  integral part has been found. Thus the dot is valid even if not
 452          --  followed by a digit.
 453          if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then
 454             After_Point := True;
 455          end if;
 456
 457          Index := Index + 1;
 458       end if;
 459
 460       if After_Point then
 461          --  Parse decimal part
 462          Scan_Decimal_Digits
 463             (Str,
 464              Index,
 465              Max => Max,
 466              Value => Int_Value,
 467              Scale => Int_Scale,
 468              Base_Violation => Base_Violation,
 469              Base => Base,
 470              Base_Specified => Base_Char /= ASCII.NUL);
 471       end if;
 472
 473       --  If an explicit base was specified ensure that the delimiter is found
 474       if Base_Char /= ASCII.NUL then
 475          if Index > Max or else Str (Index) /= Base_Char then
 476             Bad_Value (Str);
 477          else
 478             Index := Index + 1;
 479          end if;
 480       end if;
 481
 482       --  Compute the final value
 483       Uval := Long_Long_Float (Int_Value);
 484
 485       --  Update pointer and scan exponent.
 486       Ptr.all := Index;
 487
 488       Int_Scale := Int_Scale + Scan_Exponent (Str,
 489                                               Ptr,
 490                                               Max,
 491                                               Real => True);
 492
 493       Uval := Uval * Long_Long_Float (Base) ** Int_Scale;
 494
 495       --  Here is where we check for a bad based number
 496       if Base_Violation then
 497          Bad_Value (Str);
 498
 499       --  If OK, then deal with initial minus sign, note that this processing
 500       --  is done even if Uval is zero, so that -0.0 is correctly interpreted.
 501       else
 502          if Minus then
 503             return -Uval;
 504          else
 505             return Uval;
 506          end if;
 507       end if;
 508
 509    end Scan_Real;
 510
 511    ----------------
 512    -- Value_Real --
 513    ----------------
 514
 515    function Value_Real (Str : String) return Long_Long_Float is
 516    begin
 517       --  We have to special case Str'Last = Positive'Last because the normal
 518       --  circuit ends up setting P to Str'Last + 1 which is out of bounds. We
 519       --  deal with this by converting to a subtype which fixes the bounds.
 520
 521       if Str'Last = Positive'Last then
 522          declare
 523             subtype NT is String (1 .. Str'Length);
 524          begin
 525             return Value_Real (NT (Str));
 526          end;
 527
 528       --  Normal case where Str'Last < Positive'Last
 529
 530       else
 531          declare
 532             V : Long_Long_Float;
 533             P : aliased Integer := Str'First;
 534          begin
 535             V := Scan_Real (Str, P'Access, Str'Last);
 536             Scan_Trailing_Blanks (Str, P);
 537             return V;
 538          end;
 539       end if;
 540    end Value_Real;
 541
 542 end System.Val_Real;