]>
Commit | Line | Data |
---|---|---|
c32d0452 | 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 -- | |
c32d0452 | 8 | -- -- |
9dfe12ae | 9 | -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- |
c32d0452 | 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. -- | |
e78e8c8e | 30 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
c32d0452 | 31 | -- -- |
32 | ------------------------------------------------------------------------------ | |
33 | ||
34 | with System.Img_LLU; use System.Img_LLU; | |
35 | with System.Img_Uns; use System.Img_Uns; | |
36 | with System.Powten_Table; use System.Powten_Table; | |
37 | with System.Unsigned_Types; use System.Unsigned_Types; | |
38 | ||
39 | package 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 | |
9dfe12ae | 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 | |
c32d0452 | 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 | |
da253936 | 170 | -- large enough buffer to accommodate ludicrous values of Fore and Aft. |
c32d0452 | 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 | ||
9dfe12ae | 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 | ||
c32d0452 | 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; | |
c32d0452 | 554 | |
9dfe12ae | 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. | |
c32d0452 | 560 | |
9dfe12ae | 561 | raise Constraint_Error; |
562 | end if; | |
c32d0452 | 563 | |
9dfe12ae | 564 | -- X and Sign are set here, and X is known to be a valid, |
565 | -- non-zero floating-point number. | |
c32d0452 | 566 | |
567 | -- Case of non-zero value with Exp = 0 | |
568 | ||
9dfe12ae | 569 | if Exp = 0 then |
c32d0452 | 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 | ||
702 | end System.Img_Real; |