gcc/ada/libgnat/s-valuer.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                      S Y S T E M . V A L U E _ R                         --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2020-2023, 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
  34 package body System.Value_R is
  35
  36    subtype Char_As_Digit is Unsigned range 0 .. 17;
  37    subtype Valid_Digit is Char_As_Digit range 0 .. 15;
  38    E_Digit     : constant Char_As_Digit := 14;
  39    Underscore  : constant Char_As_Digit := 16;
  40    Not_A_Digit : constant Char_As_Digit := 17;
  41
  42    function As_Digit (C : Character) return Char_As_Digit;
  43    --  Given a character return the digit it represents
  44
  45    procedure Round_Extra
  46      (Digit : Char_As_Digit;
  47       Base  : Unsigned;
  48       Value : in out Uns;
  49       Scale : in out Integer;
  50       Extra : in out Char_As_Digit);
  51    --  Round the triplet (Value, Scale, Extra) according to Digit in Base
  52
  53    procedure Scan_Decimal_Digits
  54       (Str            : String;
  55        Index          : in out Integer;
  56        Max            : Integer;
  57        Base           : Unsigned;
  58        Base_Specified : Boolean;
  59        Value          : in out Value_Array;
  60        Scale          : in out Scale_Array;
  61        N              : in out Positive;
  62        Extra          : in out Char_As_Digit;
  63        Base_Violation : in out Boolean);
  64    --  Scan the decimal part of a real (i.e. after decimal separator)
  65    --
  66    --  The string parsed is Str (Index .. Max) and after the call Index will
  67    --  point to the first non-parsed character.
  68    --
  69    --  For each digit parsed, Value = Value * Base + Digit and Scale is
  70    --  decremented by 1. If precision limit is reached, remaining digits are
  71    --  still parsed but ignored, except for the first which is stored in Extra.
  72    --
  73    --  Base_Violation is set to True if a digit found is not part of the Base
  74    --
  75    --  If Base_Specified is set, then the base was specified in the real
  76
  77    procedure Scan_Integral_Digits
  78       (Str            : String;
  79        Index          : in out Integer;
  80        Max            : Integer;
  81        Base           : Unsigned;
  82        Base_Specified : Boolean;
  83        Value          : out Value_Array;
  84        Scale          : out Scale_Array;
  85        N              : out Positive;
  86        Extra          : out Char_As_Digit;
  87        Base_Violation : in out Boolean);
  88    --  Scan the integral part of a real (i.e. before decimal separator)
  89    --
  90    --  The string parsed is Str (Index .. Max) and after the call Index will
  91    --  point to the first non-parsed character.
  92    --
  93    --  For each digit parsed, either Value := Value * Base + Digit or Scale
  94    --  is incremented by 1 if precision limit is reached, in which case the
  95    --  remaining digits are still parsed but ignored, except for the first
  96    --  which is stored in Extra.
  97    --
  98    --  Base_Violation is set to True if a digit found is not part of the Base
  99    --
 100    --  If Base_Specified is set, then the base was specified in the real
 101
 102    --------------
 103    -- As_Digit --
 104    --------------
 105
 106    function As_Digit (C : Character) return Char_As_Digit is
 107    begin
 108       case C is
 109          when '0' .. '9' =>
 110             return Character'Pos (C) - Character'Pos ('0');
 111          when 'a' .. 'f' =>
 112             return Character'Pos (C) - (Character'Pos ('a') - 10);
 113          when 'A' .. 'F' =>
 114             return Character'Pos (C) - (Character'Pos ('A') - 10);
 115          when '_' =>
 116             return Underscore;
 117          when others =>
 118             return Not_A_Digit;
 119       end case;
 120    end As_Digit;
 121
 122    -----------------
 123    -- Round_Extra --
 124    -----------------
 125
 126    procedure Round_Extra
 127      (Digit : Char_As_Digit;
 128       Base  : Unsigned;
 129       Value : in out Uns;
 130       Scale : in out Integer;
 131       Extra : in out Char_As_Digit)
 132    is
 133       pragma Assert (Base in 2 .. 16);
 134
 135       B : constant Uns := Uns (Base);
 136
 137    begin
 138       if Digit >= Base / 2 then
 139
 140          --  If Extra is maximum, round Value
 141
 142          if Extra = Base - 1 then
 143
 144             --  If Value is maximum, scale it up
 145
 146             if Value = Precision_Limit then
 147                Extra := Char_As_Digit (Value mod B);
 148                Value := Value / B;
 149                Scale := Scale + 1;
 150                Round_Extra (Digit, Base, Value, Scale, Extra);
 151
 152             else
 153                Extra := 0;
 154                Value := Value + 1;
 155             end if;
 156
 157          else
 158             Extra := Extra + 1;
 159          end if;
 160       end if;
 161    end Round_Extra;
 162
 163    -------------------------
 164    -- Scan_Decimal_Digits --
 165    -------------------------
 166
 167    procedure Scan_Decimal_Digits
 168       (Str            : String;
 169        Index          : in out Integer;
 170        Max            : Integer;
 171        Base           : Unsigned;
 172        Base_Specified : Boolean;
 173        Value          : in out Value_Array;
 174        Scale          : in out Scale_Array;
 175        N              : in out Positive;
 176        Extra          : in out Char_As_Digit;
 177        Base_Violation : in out Boolean)
 178
 179    is
 180       pragma Assert (Base in 2 .. 16);
 181       pragma Assert (Index in Str'Range);
 182       pragma Assert (Max <= Str'Last);
 183
 184       Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base);
 185       --  Max value which cannot overflow on accumulating next digit
 186
 187       UmaxB : constant Uns := Precision_Limit / Uns (Base);
 188       --  Numbers bigger than UmaxB overflow if multiplied by base
 189
 190       Precision_Limit_Reached : Boolean;
 191       --  Set to True if addition of a digit will cause Value to be superior
 192       --  to Precision_Limit.
 193
 194       Precision_Limit_Just_Reached : Boolean;
 195       --  Set to True if Precision_Limit_Reached was just set to True, but only
 196       --  used when Round is True.
 197
 198       Digit : Char_As_Digit;
 199       --  The current digit
 200
 201       Temp : Uns;
 202       --  Temporary
 203
 204       Trailing_Zeros : Natural;
 205       --  Number of trailing zeros at a given point
 206
 207    begin
 208       --  If initial Scale is not 0 then it means that Precision_Limit was
 209       --  reached during scanning of the integral part.
 210
 211       if Scale (Data_Index'Last) > 0 then
 212          Precision_Limit_Reached := True;
 213       else
 214          Extra := 0;
 215          Precision_Limit_Reached := False;
 216       end if;
 217
 218       if Round then
 219          Precision_Limit_Just_Reached := False;
 220       end if;
 221
 222       --  Initialize trailing zero counter
 223
 224       Trailing_Zeros := 0;
 225
 226       --  The function precondition is that the first character is a valid
 227       --  digit.
 228
 229       Digit := As_Digit (Str (Index));
 230
 231       loop
 232          --  Check if base is correct. If the base is not specified, the digit
 233          --  E or e cannot be considered as a base violation as it can be used
 234          --  for exponentiation.
 235
 236          if Digit >= Base then
 237             if Base_Specified then
 238                Base_Violation := True;
 239             elsif Digit = E_Digit then
 240                return;
 241             else
 242                Base_Violation := True;
 243             end if;
 244          end if;
 245
 246          --  If precision limit has been reached, just ignore any remaining
 247          --  digits for the computation of Value and Scale, but store the
 248          --  first in Extra and use the second to round Extra. The scanning
 249          --  should continue only to assess the validity of the string.
 250
 251          if Precision_Limit_Reached then
 252             if Round and then Precision_Limit_Just_Reached then
 253                Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
 254                Precision_Limit_Just_Reached := False;
 255             end if;
 256
 257          else
 258             --  Trailing '0' digits are ignored until a non-zero digit is found
 259
 260             if Digit = 0 then
 261                Trailing_Zeros := Trailing_Zeros + 1;
 262
 263             else
 264                --  Handle accumulated zeros
 265
 266                for J in 1 .. Trailing_Zeros loop
 267                   if Value (N) <= UmaxB then
 268                      Value (N) := Value (N) * Uns (Base);
 269                      Scale (N) := Scale (N) - 1;
 270
 271                   elsif Parts > 1 and then N < Data_Index'Last then
 272                      N := N + 1;
 273                      Scale (N) := Scale (N - 1) - 1;
 274
 275                   else
 276                      Extra := 0;
 277                      Precision_Limit_Reached := True;
 278                      if Round and then J = Trailing_Zeros then
 279                         Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
 280                      end if;
 281
 282                      exit;
 283                   end if;
 284                end loop;
 285
 286                --  Reset trailing zero counter
 287
 288                Trailing_Zeros := 0;
 289
 290                --  Handle current non zero digit
 291
 292                Temp := Value (N) * Uns (Base) + Uns (Digit);
 293
 294                --  Precision_Limit_Reached may have been set above
 295
 296                if Precision_Limit_Reached then
 297                   null;
 298
 299                --  Check if Temp is larger than Precision_Limit, taking into
 300                --  account that Temp may wrap around when Precision_Limit is
 301                --  equal to the largest integer.
 302
 303                elsif Value (N) <= Umax
 304                  or else (Value (N) <= UmaxB
 305                            and then ((Precision_Limit < Uns'Last
 306                                        and then Temp <= Precision_Limit)
 307                                      or else (Precision_Limit = Uns'Last
 308                                                and then Temp >= Uns (Base))))
 309                then
 310                   Value (N) := Temp;
 311                   Scale (N) := Scale (N) - 1;
 312
 313                elsif Parts > 1 and then N < Data_Index'Last then
 314                   N := N + 1;
 315                   Value (N) := Uns (Digit);
 316                   Scale (N) := Scale (N - 1) - 1;
 317
 318                else
 319                   Extra := Digit;
 320                   Precision_Limit_Reached := True;
 321                   if Round then
 322                      Precision_Limit_Just_Reached := True;
 323                   end if;
 324                end if;
 325             end if;
 326          end if;
 327
 328          --  Check next character
 329
 330          Index := Index + 1;
 331
 332          if Index > Max then
 333             return;
 334          end if;
 335
 336          Digit := As_Digit (Str (Index));
 337
 338          if Digit not in Valid_Digit then
 339
 340             --  Underscore is only allowed if followed by a digit
 341
 342             if Digit = Underscore and Index + 1 <= Max then
 343
 344                Digit := As_Digit (Str (Index + 1));
 345                if Digit in Valid_Digit then
 346                   Index := Index + 1;
 347                else
 348                   return;
 349                end if;
 350
 351             --  Neither a valid underscore nor a digit
 352
 353             else
 354                return;
 355             end if;
 356          end if;
 357       end loop;
 358    end Scan_Decimal_Digits;
 359
 360    --------------------------
 361    -- Scan_Integral_Digits --
 362    --------------------------
 363
 364    procedure Scan_Integral_Digits
 365       (Str            : String;
 366        Index          : in out Integer;
 367        Max            : Integer;
 368        Base           : Unsigned;
 369        Base_Specified : Boolean;
 370        Value          : out Value_Array;
 371        Scale          : out Scale_Array;
 372        N              : out Positive;
 373        Extra          : out Char_As_Digit;
 374        Base_Violation : in out Boolean)
 375    is
 376       pragma Assert (Base in 2 .. 16);
 377
 378       Umax : constant Uns := (Precision_Limit - Uns (Base) + 1) / Uns (Base);
 379       --  Max value which cannot overflow on accumulating next digit
 380
 381       UmaxB : constant Uns := Precision_Limit / Uns (Base);
 382       --  Numbers bigger than UmaxB overflow if multiplied by base
 383
 384       Precision_Limit_Reached : Boolean;
 385       --  Set to True if addition of a digit will cause Value to be superior
 386       --  to Precision_Limit.
 387
 388       Precision_Limit_Just_Reached : Boolean;
 389       --  Set to True if Precision_Limit_Reached was just set to True, but only
 390       --  used when Round is True.
 391
 392       Digit : Char_As_Digit;
 393       --  The current digit
 394
 395       Temp : Uns;
 396       --  Temporary
 397
 398    begin
 399       --  Initialize N, Value, Scale and Extra
 400
 401       N := 1;
 402       Value := (others => 0);
 403       Scale := (others => 0);
 404       Extra := 0;
 405
 406       Precision_Limit_Reached := False;
 407
 408       if Round then
 409          Precision_Limit_Just_Reached := False;
 410       end if;
 411
 412       pragma Assert (Max <= Str'Last);
 413
 414       --  The function precondition is that the first character is a valid
 415       --  digit.
 416
 417       Digit := As_Digit (Str (Index));
 418
 419       loop
 420          --  Check if base is correct. If the base is not specified, the digit
 421          --  E or e cannot be considered as a base violation as it can be used
 422          --  for exponentiation.
 423
 424          if Digit >= Base then
 425             if Base_Specified then
 426                Base_Violation := True;
 427             elsif Digit = E_Digit then
 428                return;
 429             else
 430                Base_Violation := True;
 431             end if;
 432          end if;
 433
 434          --  If precision limit has been reached, just ignore any remaining
 435          --  digits for the computation of Value and Scale, but store the
 436          --  first in Extra and use the second to round Extra. The scanning
 437          --  should continue only to assess the validity of the string.
 438
 439          if Precision_Limit_Reached then
 440             Scale (N) := Scale (N) + 1;
 441
 442             if Round and then Precision_Limit_Just_Reached then
 443                Round_Extra (Digit, Base, Value (N), Scale (N), Extra);
 444                Precision_Limit_Just_Reached := False;
 445             end if;
 446
 447          else
 448             Temp := Value (N) * Uns (Base) + Uns (Digit);
 449
 450             --  Check if Temp is larger than Precision_Limit, taking into
 451             --  account that Temp may wrap around when Precision_Limit is
 452             --  equal to the largest integer.
 453
 454             if Value (N) <= Umax
 455               or else (Value (N) <= UmaxB
 456                         and then ((Precision_Limit < Uns'Last
 457                                     and then Temp <= Precision_Limit)
 458                                   or else (Precision_Limit = Uns'Last
 459                                             and then Temp >= Uns (Base))))
 460             then
 461                Value (N) := Temp;
 462
 463             elsif Parts > 1 and then N < Data_Index'Last then
 464                N := N + 1;
 465                Value (N) := Uns (Digit);
 466
 467             else
 468                Extra := Digit;
 469                Precision_Limit_Reached := True;
 470                if Round then
 471                   Precision_Limit_Just_Reached := True;
 472                end if;
 473                Scale (N) := Scale (N) + 1;
 474             end if;
 475          end if;
 476
 477          --  Every parsed digit also scales the previous parts
 478
 479          for J in 1 .. N - 1 loop
 480             Scale (J) := Scale (J) + 1;
 481          end loop;
 482
 483          --  Look for the next character
 484
 485          Index := Index + 1;
 486          if Index > Max then
 487             return;
 488          end if;
 489
 490          Digit := As_Digit (Str (Index));
 491
 492          if Digit not in Valid_Digit then
 493
 494             --  Next character is not a digit. In that case stop scanning
 495             --  unless the next chracter is an underscore followed by a digit.
 496
 497             if Digit = Underscore and Index + 1 <= Max then
 498                Digit := As_Digit (Str (Index + 1));
 499                if Digit in Valid_Digit then
 500                   Index := Index + 1;
 501                else
 502                   return;
 503                end if;
 504             else
 505                return;
 506             end if;
 507          end if;
 508       end loop;
 509    end Scan_Integral_Digits;
 510
 511    -------------------
 512    -- Scan_Raw_Real --
 513    -------------------
 514
 515    function Scan_Raw_Real
 516      (Str   : String;
 517       Ptr   : not null access Integer;
 518       Max   : Integer;
 519       Base  : out Unsigned;
 520       Scale : out Scale_Array;
 521       Extra : out Unsigned;
 522       Minus : out Boolean) return Value_Array
 523    is
 524       pragma Assert (Max <= Str'Last);
 525
 526       After_Point : Boolean;
 527       --  True if a decimal should be parsed
 528
 529       Base_Char : Character;
 530       --  Character used to set the base. If it is Nul, this means that default
 531       --  base is used.
 532
 533       Base_Violation : Boolean;
 534       --  If True some digits where not in the base. The real is still scanned
 535       --  till the end even if an error will be raised.
 536
 537       N : Positive;
 538       --  Index number of the current part
 539
 540       Expon : Integer;
 541       --  Exponent as an integer
 542
 543       Index : Integer;
 544       --  Local copy of string pointer
 545
 546       Start : Positive;
 547       --  Index of the first non-blank character
 548
 549       Value : Value_Array;
 550       --  Mantissa as an array of integers
 551
 552    begin
 553       --  The default base is 10
 554
 555       Base           := 10;
 556       Base_Char      := ASCII.NUL;
 557       Base_Violation := False;
 558
 559       --  We do not tolerate strings with Str'Last = Positive'Last
 560
 561       if Str'Last = Positive'Last then
 562          raise Program_Error with
 563            "string upper bound is Positive'Last, not supported";
 564       end if;
 565
 566       --  Scan the optional sign
 567
 568       Scan_Sign (Str, Ptr, Max, Minus, Start);
 569       Index := Ptr.all;
 570
 571       pragma Assert (Index >= Str'First);
 572
 573       pragma Annotate (CodePeer, Modified, Str (Index));
 574
 575       --  First character can be either a decimal digit or a dot and for some
 576       --  reason CodePeer incorrectly thinks it is always a digit.
 577
 578       if Str (Index) in '0' .. '9' then
 579          After_Point := False;
 580
 581          --  If this is a digit it can indicates either the float decimal
 582          --  part or the base to use.
 583
 584          Scan_Integral_Digits
 585            (Str, Index, Max, Base, False, Value, Scale, N,
 586             Char_As_Digit (Extra), Base_Violation);
 587
 588       --  A dot is allowed only if followed by a digit (RM 3.5(47))
 589
 590       elsif Str (Index) = '.'
 591         and then Index < Max
 592         and then Str (Index + 1) in '0' .. '9'
 593       then
 594          After_Point := True;
 595          Index := Index + 1;
 596          N := 1;
 597          Value := (others => 0);
 598          Scale := (others => 0);
 599          Extra := 0;
 600
 601       else
 602          Bad_Value (Str);
 603       end if;
 604
 605       --  Check if the first number encountered is a base
 606
 607       pragma Assert (Index >= Str'First);
 608
 609       if Index < Max
 610         and then (Str (Index) = '#' or else Str (Index) = ':')
 611       then
 612          Base_Char := Str (Index);
 613
 614          if N = 1 and then Value (1) in 2 .. 16 then
 615             Base := Unsigned (Value (1));
 616          else
 617             Base_Violation := True;
 618             Base := 16;
 619          end if;
 620
 621          Index := Index + 1;
 622
 623          if Str (Index) = '.'
 624            and then Index < Max
 625            and then As_Digit (Str (Index + 1)) in Valid_Digit
 626          then
 627             After_Point := True;
 628             Index := Index + 1;
 629             Value := (others => 0);
 630          end if;
 631       end if;
 632
 633       --  Scan the integral part if still necessary
 634
 635       if Base_Char /= ASCII.NUL and then not After_Point then
 636          if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then
 637             Bad_Value (Str);
 638          end if;
 639
 640          Scan_Integral_Digits
 641            (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
 642             N, Char_As_Digit (Extra), Base_Violation);
 643       end if;
 644
 645       --  Do we have a dot?
 646
 647       pragma Assert (Index >= Str'First);
 648
 649       if not After_Point and then Index <= Max and then Str (Index) = '.' then
 650
 651          --  At this stage if After_Point was not set, this means that an
 652          --  integral part has been found. Thus the dot is valid even if not
 653          --  followed by a digit.
 654
 655          if Index < Max and then As_Digit (Str (Index + 1)) in Valid_Digit then
 656             After_Point := True;
 657          end if;
 658
 659          Index := Index + 1;
 660       end if;
 661
 662       --  Scan the decimal part
 663
 664       if After_Point then
 665          pragma Assert (Index <= Max);
 666
 667          Scan_Decimal_Digits
 668            (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale,
 669             N, Char_As_Digit (Extra), Base_Violation);
 670       end if;
 671
 672       --  If an explicit base was specified ensure that the delimiter is found
 673
 674       if Base_Char /= ASCII.NUL then
 675          pragma Assert (Index > Max or else Index in Str'Range);
 676
 677          if Index > Max or else Str (Index) /= Base_Char then
 678             Bad_Value (Str);
 679          else
 680             Index := Index + 1;
 681          end if;
 682       end if;
 683
 684       --  Update pointer and scan exponent
 685
 686       Ptr.all := Index;
 687       Scan_Exponent (Str, Ptr, Max, Expon, Real => True);
 688
 689       --  Handle very large exponents like Scan_Exponent
 690
 691       if Expon < Integer'First / 10 or else Expon > Integer'Last / 10 then
 692          Scale (1) := Expon;
 693          for J in 2 .. Data_Index'Last loop
 694             Value (J) := 0;
 695          end loop;
 696
 697       else
 698          for J in Data_Index'Range loop
 699             Scale (J) := Scale (J) + Expon;
 700          end loop;
 701       end if;
 702
 703       --  Here is where we check for a bad based number
 704
 705       if Base_Violation then
 706          Bad_Value (Str);
 707       else
 708          return Value;
 709       end if;
 710    end Scan_Raw_Real;
 711
 712    --------------------
 713    -- Value_Raw_Real --
 714    --------------------
 715
 716    function Value_Raw_Real
 717      (Str   : String;
 718       Base  : out Unsigned;
 719       Scale : out Scale_Array;
 720       Extra : out Unsigned;
 721       Minus : out Boolean) return Value_Array
 722    is
 723       P : aliased Integer;
 724       V : Value_Array;
 725
 726    begin
 727       --  We have to special case Str'Last = Positive'Last because the normal
 728       --  circuit ends up setting P to Str'Last + 1 which is out of bounds. We
 729       --  deal with this by converting to a subtype which fixes the bounds.
 730
 731       if Str'Last = Positive'Last then
 732          declare
 733             subtype NT is String (1 .. Str'Length);
 734          begin
 735             return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus);
 736          end;
 737       end if;
 738
 739       --  Normal case
 740
 741       P := Str'First;
 742       V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra, Minus);
 743       Scan_Trailing_Blanks (Str, P);
 744
 745       return V;
 746    end Value_Raw_Real;
 747
 748 end System.Value_R;