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