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