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