1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . I M G _ R E A L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2014, 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.Img_LLU; use System.Img_LLU; 33with System.Img_Uns; use System.Img_Uns; 34with System.Powten_Table; use System.Powten_Table; 35with System.Unsigned_Types; use System.Unsigned_Types; 36with System.Float_Control; 37 38package body System.Img_Real is 39 40 -- The following defines the maximum number of digits that we can convert 41 -- accurately. This is limited by the precision of Long_Long_Float, and 42 -- also by the number of digits we can hold in Long_Long_Unsigned, which 43 -- is the integer type we use as an intermediate for the result. 44 45 -- We assume that in practice, the limitation will come from the digits 46 -- value, rather than the integer value. This is true for typical IEEE 47 -- implementations, and at worst, the only loss is for some precision 48 -- in very high precision floating-point output. 49 50 -- Note that in the following, the "-2" accounts for the sign and one 51 -- extra digits, since we need the maximum number of 9's that can be 52 -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width 53 -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits, 54 -- but the maximum number of 9's that can be supported is 19. 55 56 Maxdigs : constant := 57 Natural'Min 58 (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits); 59 60 Unsdigs : constant := Unsigned'Width - 2; 61 -- Number of digits that can be converted using type Unsigned 62 -- See above for the explanation of the -2. 63 64 Maxscaling : constant := 5000; 65 -- Max decimal scaling required during conversion of floating-point 66 -- numbers to decimal. This is used to defend against infinite 67 -- looping in the conversion, as can be caused by erroneous executions. 68 -- The largest exponent used on any current system is 2**16383, which 69 -- is approximately 10**4932, and the highest number of decimal digits 70 -- is about 35 for 128-bit floating-point formats, so 5000 leaves 71 -- enough room for scaling such values 72 73 function Is_Negative (V : Long_Long_Float) return Boolean; 74 pragma Import (Intrinsic, Is_Negative); 75 76 -------------------------- 77 -- Image_Floating_Point -- 78 -------------------------- 79 80 procedure Image_Floating_Point 81 (V : Long_Long_Float; 82 S : in out String; 83 P : out Natural; 84 Digs : Natural) 85 is 86 pragma Assert (S'First = 1); 87 88 begin 89 -- Decide whether a blank should be prepended before the call to 90 -- Set_Image_Real. We generate a blank for positive values, and 91 -- also for positive zeroes. For negative zeroes, we generate a 92 -- space only if Signed_Zeroes is True (the RM only permits the 93 -- output of -0.0 on targets where this is the case). We can of 94 -- course still see a -0.0 on a target where Signed_Zeroes is 95 -- False (since this attribute refers to the proper handling of 96 -- negative zeroes, not to their existence). We do not generate 97 -- a blank for positive infinity, since we output an explicit +. 98 99 if (not Is_Negative (V) and then V <= Long_Long_Float'Last) 100 or else (not Long_Long_Float'Signed_Zeros and then V = -0.0) 101 then 102 S (1) := ' '; 103 P := 1; 104 else 105 P := 0; 106 end if; 107 108 Set_Image_Real (V, S, P, 1, Digs - 1, 3); 109 end Image_Floating_Point; 110 111 -------------------------------- 112 -- Image_Ordinary_Fixed_Point -- 113 -------------------------------- 114 115 procedure Image_Ordinary_Fixed_Point 116 (V : Long_Long_Float; 117 S : in out String; 118 P : out Natural; 119 Aft : Natural) 120 is 121 pragma Assert (S'First = 1); 122 123 begin 124 -- Output space at start if non-negative 125 126 if V >= 0.0 then 127 S (1) := ' '; 128 P := 1; 129 else 130 P := 0; 131 end if; 132 133 Set_Image_Real (V, S, P, 1, Aft, 0); 134 end Image_Ordinary_Fixed_Point; 135 136 -------------------- 137 -- Set_Image_Real -- 138 -------------------- 139 140 procedure Set_Image_Real 141 (V : Long_Long_Float; 142 S : out String; 143 P : in out Natural; 144 Fore : Natural; 145 Aft : Natural; 146 Exp : Natural) 147 is 148 NFrac : constant Natural := Natural'Max (Aft, 1); 149 Sign : Character; 150 X : aliased Long_Long_Float; 151 -- This is declared aliased because the expansion of X'Valid passes 152 -- X by access and JGNAT requires all access parameters to be aliased. 153 -- The Valid attribute probably needs to be handled via a different 154 -- expansion for JGNAT, and this use of aliased should be removed 155 -- once Valid is handled properly. ??? 156 Scale : Integer; 157 Expon : Integer; 158 159 Field_Max : constant := 255; 160 -- This should be the same value as Ada.[Wide_]Text_IO.Field'Last. 161 -- It is not worth dragging in Ada.Text_IO to pick up this value, 162 -- since it really should never be necessary to change it. 163 164 Digs : String (1 .. 2 * Field_Max + 16); 165 -- Array used to hold digits of converted integer value. This is a 166 -- large enough buffer to accommodate ludicrous values of Fore and Aft. 167 168 Ndigs : Natural; 169 -- Number of digits stored in Digs (and also subscript of last digit) 170 171 procedure Adjust_Scale (S : Natural); 172 -- Adjusts the value in X by multiplying or dividing by a power of 173 -- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes 174 -- adding 0.5 to round the result, readjusting if the rounding causes 175 -- the result to wander out of the range. Scale is adjusted to reflect 176 -- the power of ten used to divide the result (i.e. one is added to 177 -- the scale value for each division by 10.0, or one is subtracted 178 -- for each multiplication by 10.0). 179 180 procedure Convert_Integer; 181 -- Takes the value in X, outputs integer digits into Digs. On return, 182 -- Ndigs is set to the number of digits stored. The digits are stored 183 -- in Digs (1 .. Ndigs), 184 185 procedure Set (C : Character); 186 -- Sets character C in output buffer 187 188 procedure Set_Blanks_And_Sign (N : Integer); 189 -- Sets leading blanks and minus sign if needed. N is the number of 190 -- positions to be filled (a minus sign is output even if N is zero 191 -- or negative, but for a positive value, if N is non-positive, then 192 -- the call has no effect). 193 194 procedure Set_Digs (S, E : Natural); 195 -- Set digits S through E from Digs buffer. No effect if S > E 196 197 procedure Set_Special_Fill (N : Natural); 198 -- After outputting +Inf, -Inf or NaN, this routine fills out the 199 -- rest of the field with * characters. The argument is the number 200 -- of characters output so far (either 3 or 4) 201 202 procedure Set_Zeros (N : Integer); 203 -- Set N zeros, no effect if N is negative 204 205 pragma Inline (Set); 206 pragma Inline (Set_Digs); 207 pragma Inline (Set_Zeros); 208 209 ------------------ 210 -- Adjust_Scale -- 211 ------------------ 212 213 procedure Adjust_Scale (S : Natural) is 214 Lo : Natural; 215 Hi : Natural; 216 Mid : Natural; 217 XP : Long_Long_Float; 218 219 begin 220 -- Cases where scaling up is required 221 222 if X < Powten (S - 1) then 223 224 -- What we are looking for is a power of ten to multiply X by 225 -- so that the result lies within the required range. 226 227 loop 228 XP := X * Powten (Maxpow); 229 exit when XP >= Powten (S - 1) or else Scale < -Maxscaling; 230 X := XP; 231 Scale := Scale - Maxpow; 232 end loop; 233 234 -- The following exception is only raised in case of erroneous 235 -- execution, where a number was considered valid but still 236 -- fails to scale up. One situation where this can happen is 237 -- when a system which is supposed to be IEEE-compliant, but 238 -- has been reconfigured to flush denormals to zero. 239 240 if Scale < -Maxscaling then 241 raise Constraint_Error; 242 end if; 243 244 -- Here we know that we must multiply by at least 10**1 and that 245 -- 10**Maxpow takes us too far: binary search to find right one. 246 247 -- Because of roundoff errors, it is possible for the value 248 -- of XP to be just outside of the interval when Lo >= Hi. In 249 -- that case we adjust explicitly by a factor of 10. This 250 -- can only happen with a value that is very close to an 251 -- exact power of 10. 252 253 Lo := 1; 254 Hi := Maxpow; 255 256 loop 257 Mid := (Lo + Hi) / 2; 258 XP := X * Powten (Mid); 259 260 if XP < Powten (S - 1) then 261 262 if Lo >= Hi then 263 Mid := Mid + 1; 264 XP := XP * 10.0; 265 exit; 266 267 else 268 Lo := Mid + 1; 269 end if; 270 271 elsif XP >= Powten (S) then 272 273 if Lo >= Hi then 274 Mid := Mid - 1; 275 XP := XP / 10.0; 276 exit; 277 278 else 279 Hi := Mid - 1; 280 end if; 281 282 else 283 exit; 284 end if; 285 end loop; 286 287 X := XP; 288 Scale := Scale - Mid; 289 290 -- Cases where scaling down is required 291 292 elsif X >= Powten (S) then 293 294 -- What we are looking for is a power of ten to divide X by 295 -- so that the result lies within the required range. 296 297 loop 298 XP := X / Powten (Maxpow); 299 exit when XP < Powten (S) or else Scale > Maxscaling; 300 X := XP; 301 Scale := Scale + Maxpow; 302 end loop; 303 304 -- The following exception is only raised in case of erroneous 305 -- execution, where a number was considered valid but still 306 -- fails to scale up. One situation where this can happen is 307 -- when a system which is supposed to be IEEE-compliant, but 308 -- has been reconfigured to flush denormals to zero. 309 310 if Scale > Maxscaling then 311 raise Constraint_Error; 312 end if; 313 314 -- Here we know that we must divide by at least 10**1 and that 315 -- 10**Maxpow takes us too far, binary search to find right one. 316 317 Lo := 1; 318 Hi := Maxpow; 319 320 loop 321 Mid := (Lo + Hi) / 2; 322 XP := X / Powten (Mid); 323 324 if XP < Powten (S - 1) then 325 326 if Lo >= Hi then 327 XP := XP * 10.0; 328 Mid := Mid - 1; 329 exit; 330 331 else 332 Hi := Mid - 1; 333 end if; 334 335 elsif XP >= Powten (S) then 336 337 if Lo >= Hi then 338 XP := XP / 10.0; 339 Mid := Mid + 1; 340 exit; 341 342 else 343 Lo := Mid + 1; 344 end if; 345 346 else 347 exit; 348 end if; 349 end loop; 350 351 X := XP; 352 Scale := Scale + Mid; 353 354 -- Here we are already scaled right 355 356 else 357 null; 358 end if; 359 360 -- Round, readjusting scale if needed. Note that if a readjustment 361 -- occurs, then it is never necessary to round again, because there 362 -- is no possibility of such a second rounding causing a change. 363 364 X := X + 0.5; 365 366 if X >= Powten (S) then 367 X := X / 10.0; 368 Scale := Scale + 1; 369 end if; 370 371 end Adjust_Scale; 372 373 --------------------- 374 -- Convert_Integer -- 375 --------------------- 376 377 procedure Convert_Integer is 378 begin 379 -- Use Unsigned routine if possible, since on many machines it will 380 -- be significantly more efficient than the Long_Long_Unsigned one. 381 382 if X < Powten (Unsdigs) then 383 Ndigs := 0; 384 Set_Image_Unsigned 385 (Unsigned (Long_Long_Float'Truncation (X)), 386 Digs, Ndigs); 387 388 -- But if we want more digits than fit in Unsigned, we have to use 389 -- the Long_Long_Unsigned routine after all. 390 391 else 392 Ndigs := 0; 393 Set_Image_Long_Long_Unsigned 394 (Long_Long_Unsigned (Long_Long_Float'Truncation (X)), 395 Digs, Ndigs); 396 end if; 397 end Convert_Integer; 398 399 --------- 400 -- Set -- 401 --------- 402 403 procedure Set (C : Character) is 404 begin 405 P := P + 1; 406 S (P) := C; 407 end Set; 408 409 ------------------------- 410 -- Set_Blanks_And_Sign -- 411 ------------------------- 412 413 procedure Set_Blanks_And_Sign (N : Integer) is 414 begin 415 if Sign = '-' then 416 for J in 1 .. N - 1 loop 417 Set (' '); 418 end loop; 419 420 Set ('-'); 421 422 else 423 for J in 1 .. N loop 424 Set (' '); 425 end loop; 426 end if; 427 end Set_Blanks_And_Sign; 428 429 -------------- 430 -- Set_Digs -- 431 -------------- 432 433 procedure Set_Digs (S, E : Natural) is 434 begin 435 for J in S .. E loop 436 Set (Digs (J)); 437 end loop; 438 end Set_Digs; 439 440 ---------------------- 441 -- Set_Special_Fill -- 442 ---------------------- 443 444 procedure Set_Special_Fill (N : Natural) is 445 F : Natural; 446 447 begin 448 F := Fore + 1 + Aft - N; 449 450 if Exp /= 0 then 451 F := F + Exp + 1; 452 end if; 453 454 for J in 1 .. F loop 455 Set ('*'); 456 end loop; 457 end Set_Special_Fill; 458 459 --------------- 460 -- Set_Zeros -- 461 --------------- 462 463 procedure Set_Zeros (N : Integer) is 464 begin 465 for J in 1 .. N loop 466 Set ('0'); 467 end loop; 468 end Set_Zeros; 469 470 -- Start of processing for Set_Image_Real 471 472 begin 473 -- We call the floating-point processor reset routine so that we can 474 -- be sure the floating-point processor is properly set for conversion 475 -- calls. This is notably need on Windows, where calls to the operating 476 -- system randomly reset the processor into 64-bit mode. 477 478 System.Float_Control.Reset; 479 480 Scale := 0; 481 482 -- Deal with invalid values first, 483 484 if not V'Valid then 485 486 -- Note that we're taking our chances here, as V might be 487 -- an invalid bit pattern resulting from erroneous execution 488 -- (caused by using uninitialized variables for example). 489 490 -- No matter what, we'll at least get reasonable behaviour, 491 -- converting to infinity or some other value, or causing an 492 -- exception to be raised is fine. 493 494 -- If the following test succeeds, then we definitely have 495 -- an infinite value, so we print Inf. 496 497 if V > Long_Long_Float'Last then 498 Set ('+'); 499 Set ('I'); 500 Set ('n'); 501 Set ('f'); 502 Set_Special_Fill (4); 503 504 -- In all other cases we print NaN 505 506 elsif V < Long_Long_Float'First then 507 Set ('-'); 508 Set ('I'); 509 Set ('n'); 510 Set ('f'); 511 Set_Special_Fill (4); 512 513 else 514 Set ('N'); 515 Set ('a'); 516 Set ('N'); 517 Set_Special_Fill (3); 518 end if; 519 520 return; 521 end if; 522 523 -- Positive values 524 525 if V > 0.0 then 526 X := V; 527 Sign := '+'; 528 529 -- Negative values 530 531 elsif V < 0.0 then 532 X := -V; 533 Sign := '-'; 534 535 -- Zero values 536 537 elsif V = 0.0 then 538 if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then 539 Sign := '-'; 540 else 541 Sign := '+'; 542 end if; 543 544 Set_Blanks_And_Sign (Fore - 1); 545 Set ('0'); 546 Set ('.'); 547 Set_Zeros (NFrac); 548 549 if Exp /= 0 then 550 Set ('E'); 551 Set ('+'); 552 Set_Zeros (Natural'Max (1, Exp - 1)); 553 end if; 554 555 return; 556 557 else 558 -- It should not be possible for a NaN to end up here. 559 -- Either the 'Valid test has failed, or we have some form 560 -- of erroneous execution. Raise Constraint_Error instead of 561 -- attempting to go ahead printing the value. 562 563 raise Constraint_Error; 564 end if; 565 566 -- X and Sign are set here, and X is known to be a valid, 567 -- non-zero floating-point number. 568 569 -- Case of non-zero value with Exp = 0 570 571 if Exp = 0 then 572 573 -- First step is to multiply by 10 ** Nfrac to get an integer 574 -- value to be output, an then add 0.5 to round the result. 575 576 declare 577 NF : Natural := NFrac; 578 579 begin 580 loop 581 -- If we are larger than Powten (Maxdigs) now, then 582 -- we have too many significant digits, and we have 583 -- not even finished multiplying by NFrac (NF shows 584 -- the number of unaccounted-for digits). 585 586 if X >= Powten (Maxdigs) then 587 588 -- In this situation, we only to generate a reasonable 589 -- number of significant digits, and then zeroes after. 590 -- So first we rescale to get: 591 592 -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs 593 594 -- and then convert the resulting integer 595 596 Adjust_Scale (Maxdigs); 597 Convert_Integer; 598 599 -- If that caused rescaling, then add zeros to the end 600 -- of the number to account for this scaling. Also add 601 -- zeroes to account for the undone multiplications 602 603 for J in 1 .. Scale + NF loop 604 Ndigs := Ndigs + 1; 605 Digs (Ndigs) := '0'; 606 end loop; 607 608 exit; 609 610 -- If multiplication is complete, then convert the resulting 611 -- integer after rounding (note that X is non-negative) 612 613 elsif NF = 0 then 614 X := X + 0.5; 615 Convert_Integer; 616 exit; 617 618 -- Otherwise we can go ahead with the multiplication. If it 619 -- can be done in one step, then do it in one step. 620 621 elsif NF < Maxpow then 622 X := X * Powten (NF); 623 NF := 0; 624 625 -- If it cannot be done in one step, then do partial scaling 626 627 else 628 X := X * Powten (Maxpow); 629 NF := NF - Maxpow; 630 end if; 631 end loop; 632 end; 633 634 -- If number of available digits is less or equal to NFrac, 635 -- then we need an extra zero before the decimal point. 636 637 if Ndigs <= NFrac then 638 Set_Blanks_And_Sign (Fore - 1); 639 Set ('0'); 640 Set ('.'); 641 Set_Zeros (NFrac - Ndigs); 642 Set_Digs (1, Ndigs); 643 644 -- Normal case with some digits before the decimal point 645 646 else 647 Set_Blanks_And_Sign (Fore - (Ndigs - NFrac)); 648 Set_Digs (1, Ndigs - NFrac); 649 Set ('.'); 650 Set_Digs (Ndigs - NFrac + 1, Ndigs); 651 end if; 652 653 -- Case of non-zero value with non-zero Exp value 654 655 else 656 -- If NFrac is less than Maxdigs, then all the fraction digits are 657 -- significant, so we can scale the resulting integer accordingly. 658 659 if NFrac < Maxdigs then 660 Adjust_Scale (NFrac + 1); 661 Convert_Integer; 662 663 -- Otherwise, we get the maximum number of digits available 664 665 else 666 Adjust_Scale (Maxdigs); 667 Convert_Integer; 668 669 for J in 1 .. NFrac - Maxdigs + 1 loop 670 Ndigs := Ndigs + 1; 671 Digs (Ndigs) := '0'; 672 Scale := Scale - 1; 673 end loop; 674 end if; 675 676 Set_Blanks_And_Sign (Fore - 1); 677 Set (Digs (1)); 678 Set ('.'); 679 Set_Digs (2, Ndigs); 680 681 -- The exponent is the scaling factor adjusted for the digits 682 -- that we output after the decimal point, since these were 683 -- included in the scaled digits that we output. 684 685 Expon := Scale + NFrac; 686 687 Set ('E'); 688 Ndigs := 0; 689 690 if Expon >= 0 then 691 Set ('+'); 692 Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs); 693 else 694 Set ('-'); 695 Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs); 696 end if; 697 698 Set_Zeros (Exp - Ndigs - 1); 699 Set_Digs (1, Ndigs); 700 end if; 701 702 end Set_Image_Real; 703 704end System.Img_Real; 705