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