]>
Commit | Line | Data |
---|---|---|
818ab71a | 1 | /* Copyright (C) 2007-2016 Free Software Foundation, Inc. |
7b71bedf JD |
2 | Contributed by Andy Vaught |
3 | Write float code factoring to this file by Jerry DeLisle | |
10256cbe | 4 | F2003 I/O support contributed by Jerry DeLisle |
7b71bedf | 5 | |
bb408e87 | 6 | This file is part of the GNU Fortran runtime library (libgfortran). |
7b71bedf JD |
7 | |
8 | Libgfortran is free software; you can redistribute it and/or modify | |
9 | it under the terms of the GNU General Public License as published by | |
748086b7 | 10 | the Free Software Foundation; either version 3, or (at your option) |
7b71bedf JD |
11 | any later version. |
12 | ||
7b71bedf JD |
13 | Libgfortran is distributed in the hope that it will be useful, |
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | GNU General Public License for more details. | |
17 | ||
748086b7 JJ |
18 | Under Section 7 of GPL version 3, you are granted additional |
19 | permissions described in the GCC Runtime Library Exception, version | |
20 | 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/>. */ | |
7b71bedf JD |
26 | |
27 | #include "config.h" | |
28 | ||
29 | typedef enum | |
10256cbe | 30 | { S_NONE, S_MINUS, S_PLUS } |
7b71bedf JD |
31 | sign_t; |
32 | ||
33 | /* Given a flag that indicates if a value is negative or not, return a | |
34 | sign_t that gives the sign that we need to produce. */ | |
35 | ||
36 | static sign_t | |
37 | calculate_sign (st_parameter_dt *dtp, int negative_flag) | |
38 | { | |
10256cbe | 39 | sign_t s = S_NONE; |
7b71bedf JD |
40 | |
41 | if (negative_flag) | |
10256cbe | 42 | s = S_MINUS; |
7b71bedf JD |
43 | else |
44 | switch (dtp->u.p.sign_status) | |
45 | { | |
10256cbe JD |
46 | case SIGN_SP: /* Show sign. */ |
47 | s = S_PLUS; | |
7b71bedf | 48 | break; |
10256cbe JD |
49 | case SIGN_SS: /* Suppress sign. */ |
50 | s = S_NONE; | |
7b71bedf | 51 | break; |
10256cbe | 52 | case SIGN_S: /* Processor defined. */ |
d7445152 | 53 | case SIGN_UNSPECIFIED: |
10256cbe | 54 | s = options.optional_plus ? S_PLUS : S_NONE; |
7b71bedf JD |
55 | break; |
56 | } | |
57 | ||
58 | return s; | |
59 | } | |
60 | ||
61 | ||
37b659dd JB |
62 | /* Determine the precision except for EN format. For G format, |
63 | determines an upper bound to be used for sizing the buffer. */ | |
64 | ||
65 | static int | |
66 | determine_precision (st_parameter_dt * dtp, const fnode * f, int len) | |
67 | { | |
68 | int precision = f->u.real.d; | |
69 | ||
70 | switch (f->format) | |
71 | { | |
72 | case FMT_F: | |
73 | case FMT_G: | |
74 | precision += dtp->u.p.scale_factor; | |
75 | break; | |
76 | case FMT_ES: | |
77 | /* Scale factor has no effect on output. */ | |
78 | break; | |
79 | case FMT_E: | |
80 | case FMT_D: | |
81 | /* See F2008 10.7.2.3.3.6 */ | |
82 | if (dtp->u.p.scale_factor <= 0) | |
83 | precision += dtp->u.p.scale_factor - 1; | |
84 | break; | |
85 | default: | |
86 | return -1; | |
87 | } | |
88 | ||
89 | /* If the scale factor has a large negative value, we must do our | |
90 | own rounding? Use ROUND='NEAREST', which should be what snprintf | |
91 | is using as well. */ | |
92 | if (precision < 0 && | |
93 | (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED | |
94 | || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED)) | |
95 | dtp->u.p.current_unit->round_status = ROUND_NEAREST; | |
96 | ||
97 | /* Add extra guard digits up to at least full precision when we do | |
98 | our own rounding. */ | |
99 | if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED | |
100 | && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED) | |
101 | { | |
102 | precision += 2 * len + 4; | |
103 | if (precision < 0) | |
104 | precision = 0; | |
105 | } | |
106 | ||
107 | return precision; | |
108 | } | |
109 | ||
110 | ||
5b0e27a7 | 111 | /* Build a real number according to its format which is FMT_G free. */ |
7b71bedf | 112 | |
5b0e27a7 JD |
113 | static void |
114 | build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer, | |
115 | size_t size, int nprinted, int precision, int sign_bit, | |
116 | bool zero_flag, int npad, char *result, size_t *len) | |
7b71bedf | 117 | { |
5b0e27a7 | 118 | char *put; |
7b71bedf | 119 | char *digits; |
7c4f44cd | 120 | int e, w, d, p, i; |
379924dd | 121 | char expchar, rchar; |
7b71bedf | 122 | format_token ft; |
7b71bedf JD |
123 | /* Number of digits before the decimal point. */ |
124 | int nbefore; | |
125 | /* Number of zeros after the decimal point. */ | |
126 | int nzero; | |
127 | /* Number of digits after the decimal point. */ | |
128 | int nafter; | |
7b71bedf JD |
129 | int leadzero; |
130 | int nblanks; | |
37b659dd | 131 | int ndigits, edigits; |
7b71bedf JD |
132 | sign_t sign; |
133 | ||
134 | ft = f->format; | |
135 | w = f->u.real.w; | |
136 | d = f->u.real.d; | |
7c4f44cd | 137 | p = dtp->u.p.scale_factor; |
7b71bedf | 138 | |
379924dd | 139 | rchar = '5'; |
7b71bedf JD |
140 | |
141 | /* We should always know the field width and precision. */ | |
142 | if (d < 0) | |
143 | internal_error (&dtp->common, "Unspecified precision"); | |
144 | ||
7b71bedf | 145 | sign = calculate_sign (dtp, sign_bit); |
302b150e | 146 | |
37b659dd JB |
147 | /* Calculate total number of digits. */ |
148 | if (ft == FMT_F) | |
149 | ndigits = nprinted - 2; | |
150 | else | |
151 | ndigits = precision + 1; | |
7b71bedf JD |
152 | |
153 | /* Read the exponent back in. */ | |
37b659dd JB |
154 | if (ft != FMT_F) |
155 | e = atoi (&buffer[ndigits + 3]) + 1; | |
156 | else | |
157 | e = 0; | |
7b71bedf JD |
158 | |
159 | /* Make sure zero comes out as 0.0e0. */ | |
160 | if (zero_flag) | |
0eac6ca5 | 161 | e = 0; |
7b71bedf JD |
162 | |
163 | /* Normalize the fractional component. */ | |
37b659dd JB |
164 | if (ft != FMT_F) |
165 | { | |
166 | buffer[2] = buffer[1]; | |
167 | digits = &buffer[2]; | |
168 | } | |
169 | else | |
170 | digits = &buffer[1]; | |
7b71bedf JD |
171 | |
172 | /* Figure out where to place the decimal point. */ | |
173 | switch (ft) | |
174 | { | |
175 | case FMT_F: | |
37b659dd JB |
176 | nbefore = ndigits - precision; |
177 | /* Make sure the decimal point is a '.'; depending on the | |
178 | locale, this might not be the case otherwise. */ | |
179 | digits[nbefore] = '.'; | |
37b659dd | 180 | if (p != 0) |
7b71bedf | 181 | { |
37b659dd JB |
182 | if (p > 0) |
183 | { | |
37b659dd JB |
184 | memmove (digits + nbefore, digits + nbefore + 1, p); |
185 | digits[nbefore + p] = '.'; | |
186 | nbefore += p; | |
37b659dd | 187 | nafter = d; |
4e185d7c | 188 | nzero = 0; |
37b659dd JB |
189 | } |
190 | else /* p < 0 */ | |
191 | { | |
192 | if (nbefore + p >= 0) | |
193 | { | |
194 | nzero = 0; | |
195 | memmove (digits + nbefore + p + 1, digits + nbefore + p, -p); | |
196 | nbefore += p; | |
197 | digits[nbefore] = '.'; | |
198 | nafter = d; | |
199 | } | |
200 | else | |
201 | { | |
202 | nzero = -(nbefore + p); | |
203 | memmove (digits + 1, digits, nbefore); | |
e0876e21 DH |
204 | nafter = d - nzero; |
205 | if (nafter == 0 && d > 0) | |
206 | { | |
207 | /* This is needed to get the correct rounding. */ | |
208 | memmove (digits + 1, digits, ndigits - 1); | |
209 | digits[1] = '0'; | |
210 | nafter = 1; | |
211 | nzero = d - 1; | |
212 | } | |
213 | else if (nafter < 0) | |
214 | { | |
215 | /* Reset digits to 0 in order to get correct rounding | |
216 | towards infinity. */ | |
217 | for (i = 0; i < ndigits; i++) | |
218 | digits[i] = '0'; | |
219 | digits[ndigits - 1] = '1'; | |
220 | nafter = d; | |
221 | nzero = 0; | |
222 | } | |
37b659dd JB |
223 | nbefore = 0; |
224 | } | |
37b659dd | 225 | } |
7b71bedf JD |
226 | } |
227 | else | |
228 | { | |
4e185d7c | 229 | nzero = 0; |
7b71bedf JD |
230 | nafter = d; |
231 | } | |
37b659dd | 232 | |
789ebabf JB |
233 | while (digits[0] == '0' && nbefore > 0) |
234 | { | |
235 | digits++; | |
236 | nbefore--; | |
237 | ndigits--; | |
238 | } | |
239 | ||
7b71bedf | 240 | expchar = 0; |
37b659dd JB |
241 | /* If we need to do rounding ourselves, get rid of the dot by |
242 | moving the fractional part. */ | |
243 | if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED | |
244 | && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED) | |
245 | memmove (digits + nbefore, digits + nbefore + 1, ndigits - nbefore); | |
7b71bedf JD |
246 | break; |
247 | ||
248 | case FMT_E: | |
249 | case FMT_D: | |
250 | i = dtp->u.p.scale_factor; | |
7c4f44cd | 251 | if (d <= 0 && p == 0) |
50a932e0 JD |
252 | { |
253 | generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not " | |
254 | "greater than zero in format specifier 'E' or 'D'"); | |
5b0e27a7 | 255 | return; |
50a932e0 | 256 | } |
7c4f44cd | 257 | if (p <= -d || p >= d + 2) |
50a932e0 JD |
258 | { |
259 | generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor " | |
260 | "out of range in format specifier 'E' or 'D'"); | |
5b0e27a7 | 261 | return; |
50a932e0 JD |
262 | } |
263 | ||
7b71bedf | 264 | if (!zero_flag) |
7c4f44cd JD |
265 | e -= p; |
266 | if (p < 0) | |
7b71bedf JD |
267 | { |
268 | nbefore = 0; | |
7c4f44cd JD |
269 | nzero = -p; |
270 | nafter = d + p; | |
7b71bedf | 271 | } |
7c4f44cd | 272 | else if (p > 0) |
7b71bedf | 273 | { |
7c4f44cd | 274 | nbefore = p; |
7b71bedf | 275 | nzero = 0; |
7c4f44cd | 276 | nafter = (d - p) + 1; |
7b71bedf | 277 | } |
7c4f44cd | 278 | else /* p == 0 */ |
7b71bedf JD |
279 | { |
280 | nbefore = 0; | |
281 | nzero = 0; | |
282 | nafter = d; | |
283 | } | |
284 | ||
285 | if (ft == FMT_E) | |
286 | expchar = 'E'; | |
287 | else | |
288 | expchar = 'D'; | |
289 | break; | |
290 | ||
291 | case FMT_EN: | |
292 | /* The exponent must be a multiple of three, with 1-3 digits before | |
293 | the decimal point. */ | |
294 | if (!zero_flag) | |
295 | e--; | |
296 | if (e >= 0) | |
297 | nbefore = e % 3; | |
298 | else | |
299 | { | |
300 | nbefore = (-e) % 3; | |
301 | if (nbefore != 0) | |
302 | nbefore = 3 - nbefore; | |
303 | } | |
304 | e -= nbefore; | |
305 | nbefore++; | |
306 | nzero = 0; | |
307 | nafter = d; | |
308 | expchar = 'E'; | |
309 | break; | |
310 | ||
311 | case FMT_ES: | |
312 | if (!zero_flag) | |
313 | e--; | |
314 | nbefore = 1; | |
315 | nzero = 0; | |
316 | nafter = d; | |
317 | expchar = 'E'; | |
318 | break; | |
319 | ||
320 | default: | |
321 | /* Should never happen. */ | |
322 | internal_error (&dtp->common, "Unexpected format token"); | |
323 | } | |
324 | ||
bc7409a8 JD |
325 | if (zero_flag) |
326 | goto skip; | |
d6b872ad | 327 | |
37b659dd | 328 | /* Round the value. The value being rounded is an unsigned magnitude. */ |
379924dd JD |
329 | switch (dtp->u.p.current_unit->round_status) |
330 | { | |
37b659dd JB |
331 | /* For processor defined and unspecified rounding we use |
332 | snprintf to print the exact number of digits needed, and thus | |
333 | let snprintf handle the rounding. On system claiming support | |
334 | for IEEE 754, this ought to be round to nearest, ties to | |
335 | even, corresponding to the Fortran ROUND='NEAREST'. */ | |
336 | case ROUND_PROCDEFINED: | |
337 | case ROUND_UNSPECIFIED: | |
379924dd JD |
338 | case ROUND_ZERO: /* Do nothing and truncation occurs. */ |
339 | goto skip; | |
340 | case ROUND_UP: | |
341 | if (sign_bit) | |
342 | goto skip; | |
d6b872ad | 343 | goto updown; |
379924dd JD |
344 | case ROUND_DOWN: |
345 | if (!sign_bit) | |
346 | goto skip; | |
d6b872ad | 347 | goto updown; |
379924dd JD |
348 | case ROUND_NEAREST: |
349 | /* Round compatible unless there is a tie. A tie is a 5 with | |
350 | all trailing zero's. */ | |
0e8fc185 | 351 | i = nafter + nbefore; |
379924dd JD |
352 | if (digits[i] == '5') |
353 | { | |
354 | for(i++ ; i < ndigits; i++) | |
355 | { | |
356 | if (digits[i] != '0') | |
357 | goto do_rnd; | |
358 | } | |
d6b872ad | 359 | /* It is a tie so round to even. */ |
0e8fc185 | 360 | switch (digits[nafter + nbefore - 1]) |
379924dd JD |
361 | { |
362 | case '1': | |
363 | case '3': | |
364 | case '5': | |
365 | case '7': | |
366 | case '9': | |
367 | /* If odd, round away from zero to even. */ | |
368 | break; | |
369 | default: | |
370 | /* If even, skip rounding, truncate to even. */ | |
371 | goto skip; | |
372 | } | |
373 | } | |
37b659dd JB |
374 | /* Fall through. */ |
375 | /* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */ | |
379924dd JD |
376 | case ROUND_COMPATIBLE: |
377 | rchar = '5'; | |
d6b872ad JD |
378 | goto do_rnd; |
379 | } | |
380 | ||
381 | updown: | |
382 | ||
383 | rchar = '0'; | |
4e185d7c | 384 | if (ft != FMT_F && w > 0 && d == 0 && p == 0) |
d6b872ad JD |
385 | nbefore = 1; |
386 | /* Scan for trailing zeros to see if we really need to round it. */ | |
387 | for(i = nbefore + nafter; i < ndigits; i++) | |
388 | { | |
389 | if (digits[i] != '0') | |
390 | goto do_rnd; | |
379924dd | 391 | } |
d6b872ad | 392 | goto skip; |
379924dd JD |
393 | |
394 | do_rnd: | |
395 | ||
7b71bedf | 396 | if (nbefore + nafter == 0) |
32aeb94a | 397 | /* Handle the case Fw.0 and value < 1.0 */ |
7b71bedf JD |
398 | { |
399 | ndigits = 0; | |
91d45414 | 400 | if (digits[0] >= rchar) |
379924dd JD |
401 | { |
402 | /* We rounded to zero but shouldn't have */ | |
32aeb94a JD |
403 | nbefore = 1; |
404 | digits--; | |
379924dd JD |
405 | digits[0] = '1'; |
406 | ndigits = 1; | |
407 | } | |
7b71bedf JD |
408 | } |
409 | else if (nbefore + nafter < ndigits) | |
410 | { | |
a3f02fe4 | 411 | i = ndigits = nbefore + nafter; |
379924dd | 412 | if (digits[i] >= rchar) |
7b71bedf JD |
413 | { |
414 | /* Propagate the carry. */ | |
415 | for (i--; i >= 0; i--) | |
416 | { | |
417 | if (digits[i] != '9') | |
418 | { | |
419 | digits[i]++; | |
420 | break; | |
421 | } | |
422 | digits[i] = '0'; | |
423 | } | |
424 | ||
425 | if (i < 0) | |
426 | { | |
379924dd JD |
427 | /* The carry overflowed. Fortunately we have some spare |
428 | space at the start of the buffer. We may discard some | |
429 | digits, but this is ok because we already know they are | |
430 | zero. */ | |
7b71bedf JD |
431 | digits--; |
432 | digits[0] = '1'; | |
433 | if (ft == FMT_F) | |
434 | { | |
435 | if (nzero > 0) | |
436 | { | |
437 | nzero--; | |
438 | nafter++; | |
439 | } | |
440 | else | |
441 | nbefore++; | |
442 | } | |
443 | else if (ft == FMT_EN) | |
444 | { | |
445 | nbefore++; | |
446 | if (nbefore == 4) | |
447 | { | |
448 | nbefore = 1; | |
449 | e += 3; | |
450 | } | |
451 | } | |
452 | else | |
453 | e++; | |
454 | } | |
455 | } | |
456 | } | |
457 | ||
379924dd JD |
458 | skip: |
459 | ||
7b71bedf | 460 | /* Calculate the format of the exponent field. */ |
80f6181e | 461 | if (expchar && !(dtp->u.p.g0_no_blanks && e == 0)) |
7b71bedf JD |
462 | { |
463 | edigits = 1; | |
464 | for (i = abs (e); i >= 10; i /= 10) | |
465 | edigits++; | |
466 | ||
467 | if (f->u.real.e < 0) | |
468 | { | |
469 | /* Width not specified. Must be no more than 3 digits. */ | |
470 | if (e > 999 || e < -999) | |
471 | edigits = -1; | |
472 | else | |
473 | { | |
474 | edigits = 4; | |
475 | if (e > 99 || e < -99) | |
476 | expchar = ' '; | |
477 | } | |
478 | } | |
479 | else | |
480 | { | |
481 | /* Exponent width specified, check it is wide enough. */ | |
482 | if (edigits > f->u.real.e) | |
483 | edigits = -1; | |
484 | else | |
485 | edigits = f->u.real.e + 2; | |
486 | } | |
487 | } | |
488 | else | |
489 | edigits = 0; | |
490 | ||
0eac6ca5 JD |
491 | /* Scan the digits string and count the number of zeros. If we make it |
492 | all the way through the loop, we know the value is zero after the | |
493 | rounding completed above. */ | |
eb3119f9 JB |
494 | int hasdot = 0; |
495 | for (i = 0; i < ndigits + hasdot; i++) | |
7b71bedf | 496 | { |
eb3119f9 JB |
497 | if (digits[i] == '.') |
498 | hasdot = 1; | |
499 | else if (digits[i] != '0') | |
7b71bedf JD |
500 | break; |
501 | } | |
0eac6ca5 JD |
502 | |
503 | /* To format properly, we need to know if the rounded result is zero and if | |
504 | so, we set the zero_flag which may have been already set for | |
505 | actual zero. */ | |
eb3119f9 | 506 | if (i == ndigits + hasdot) |
7b71bedf | 507 | { |
0eac6ca5 | 508 | zero_flag = true; |
7b71bedf JD |
509 | /* The output is zero, so set the sign according to the sign bit unless |
510 | -fno-sign-zero was specified. */ | |
511 | if (compile_options.sign_zero == 1) | |
512 | sign = calculate_sign (dtp, sign_bit); | |
513 | else | |
514 | sign = calculate_sign (dtp, 0); | |
515 | } | |
516 | ||
0eac6ca5 JD |
517 | /* Pick a field size if none was specified, taking into account small |
518 | values that may have been rounded to zero. */ | |
50220190 | 519 | if (w <= 0) |
9e762886 | 520 | { |
0eac6ca5 JD |
521 | if (zero_flag) |
522 | w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0); | |
523 | else | |
524 | { | |
525 | w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1); | |
526 | w = w == 1 ? 2 : w; | |
527 | } | |
9e762886 | 528 | } |
ba67259c | 529 | |
7b71bedf JD |
530 | /* Work out how much padding is needed. */ |
531 | nblanks = w - (nbefore + nzero + nafter + edigits + 1); | |
10256cbe | 532 | if (sign != S_NONE) |
7b71bedf JD |
533 | nblanks--; |
534 | ||
ba67259c JD |
535 | /* See if we have space for a zero before the decimal point. */ |
536 | if (nbefore == 0 && nblanks > 0) | |
537 | { | |
538 | leadzero = 1; | |
539 | nblanks--; | |
540 | } | |
541 | else | |
542 | leadzero = 0; | |
543 | ||
50220190 JD |
544 | if (dtp->u.p.g0_no_blanks) |
545 | { | |
546 | w -= nblanks; | |
547 | nblanks = 0; | |
548 | } | |
549 | ||
5b0e27a7 JD |
550 | /* Create the final float string. */ |
551 | *len = w + npad; | |
552 | put = result; | |
50220190 | 553 | |
7b71bedf | 554 | /* Check the value fits in the specified field width. */ |
9e762886 | 555 | if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE)) |
7b71bedf | 556 | { |
5b0e27a7 JD |
557 | star_fill (put, *len); |
558 | return; | |
7b71bedf JD |
559 | } |
560 | ||
7b71bedf | 561 | /* Pad to full field width. */ |
7b71bedf JD |
562 | if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank) |
563 | { | |
5b0e27a7 JD |
564 | memset (put, ' ', nblanks); |
565 | put += nblanks; | |
7b71bedf JD |
566 | } |
567 | ||
5b0e27a7 | 568 | /* Set the initial sign (if any). */ |
10256cbe | 569 | if (sign == S_PLUS) |
5b0e27a7 | 570 | *(put++) = '+'; |
10256cbe | 571 | else if (sign == S_MINUS) |
5b0e27a7 | 572 | *(put++) = '-'; |
7b71bedf | 573 | |
5b0e27a7 | 574 | /* Set an optional leading zero. */ |
7b71bedf | 575 | if (leadzero) |
5b0e27a7 | 576 | *(put++) = '0'; |
7b71bedf | 577 | |
5b0e27a7 | 578 | /* Set the part before the decimal point, padding with zeros. */ |
7b71bedf JD |
579 | if (nbefore > 0) |
580 | { | |
581 | if (nbefore > ndigits) | |
582 | { | |
583 | i = ndigits; | |
5b0e27a7 | 584 | memcpy (put, digits, i); |
7b71bedf JD |
585 | ndigits = 0; |
586 | while (i < nbefore) | |
5b0e27a7 | 587 | put[i++] = '0'; |
7b71bedf JD |
588 | } |
589 | else | |
590 | { | |
591 | i = nbefore; | |
5b0e27a7 | 592 | memcpy (put, digits, i); |
7b71bedf JD |
593 | ndigits -= i; |
594 | } | |
595 | ||
596 | digits += i; | |
5b0e27a7 | 597 | put += nbefore; |
7b71bedf | 598 | } |
50220190 | 599 | |
5b0e27a7 JD |
600 | /* Set the decimal point. */ |
601 | *(put++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ','; | |
37b659dd JB |
602 | if (ft == FMT_F |
603 | && (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED | |
604 | || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED)) | |
605 | digits++; | |
7b71bedf | 606 | |
5b0e27a7 | 607 | /* Set leading zeros after the decimal point. */ |
7b71bedf JD |
608 | if (nzero > 0) |
609 | { | |
610 | for (i = 0; i < nzero; i++) | |
5b0e27a7 | 611 | *(put++) = '0'; |
7b71bedf JD |
612 | } |
613 | ||
5b0e27a7 | 614 | /* Set digits after the decimal point, padding with zeros. */ |
7b71bedf JD |
615 | if (nafter > 0) |
616 | { | |
617 | if (nafter > ndigits) | |
618 | i = ndigits; | |
619 | else | |
620 | i = nafter; | |
621 | ||
5b0e27a7 | 622 | memcpy (put, digits, i); |
7b71bedf | 623 | while (i < nafter) |
5b0e27a7 | 624 | put[i++] = '0'; |
7b71bedf JD |
625 | |
626 | digits += i; | |
627 | ndigits -= i; | |
5b0e27a7 | 628 | put += nafter; |
7b71bedf JD |
629 | } |
630 | ||
5b0e27a7 | 631 | /* Set the exponent. */ |
94ce26f1 | 632 | if (expchar && !(dtp->u.p.g0_no_blanks && e == 0)) |
7b71bedf JD |
633 | { |
634 | if (expchar != ' ') | |
635 | { | |
5b0e27a7 | 636 | *(put++) = expchar; |
7b71bedf JD |
637 | edigits--; |
638 | } | |
7b71bedf | 639 | snprintf (buffer, size, "%+0*d", edigits, e); |
5b0e27a7 JD |
640 | memcpy (put, buffer, edigits); |
641 | put += edigits; | |
7b71bedf | 642 | } |
50220190 | 643 | |
7b71bedf JD |
644 | if (dtp->u.p.no_leading_blank) |
645 | { | |
5b0e27a7 | 646 | memset (put , ' ' , nblanks); |
7b71bedf | 647 | dtp->u.p.no_leading_blank = 0; |
5b0e27a7 JD |
648 | put += nblanks; |
649 | } | |
650 | ||
651 | if (npad > 0 && !dtp->u.p.g0_no_blanks) | |
652 | { | |
653 | memset (put , ' ' , npad); | |
654 | put += npad; | |
7b71bedf | 655 | } |
50220190 | 656 | |
5b0e27a7 JD |
657 | /* NULL terminate the string. */ |
658 | *put = '\0'; | |
659 | ||
660 | return; | |
7b71bedf JD |
661 | } |
662 | ||
663 | ||
664 | /* Write "Infinite" or "Nan" as appropriate for the given format. */ | |
665 | ||
666 | static void | |
5b0e27a7 JD |
667 | build_infnan_string (st_parameter_dt *dtp, const fnode *f, int isnan_flag, |
668 | int sign_bit, char *p, size_t *len) | |
7b71bedf | 669 | { |
5b0e27a7 | 670 | char fin; |
7b71bedf | 671 | int nb = 0; |
6e0576ee JD |
672 | sign_t sign; |
673 | int mark; | |
7b71bedf JD |
674 | |
675 | if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z) | |
676 | { | |
6e0576ee JD |
677 | sign = calculate_sign (dtp, sign_bit); |
678 | mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7; | |
679 | ||
c7421e06 | 680 | nb = f->u.real.w; |
5b0e27a7 | 681 | *len = nb; |
0b0a0c94 | 682 | |
c7421e06 JD |
683 | /* If the field width is zero, the processor must select a width |
684 | not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */ | |
685 | ||
0b0a0c94 | 686 | if ((nb == 0) || dtp->u.p.g0_no_blanks) |
6e0576ee JD |
687 | { |
688 | if (isnan_flag) | |
689 | nb = 3; | |
690 | else | |
691 | nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3; | |
5b0e27a7 | 692 | *len = nb; |
6e0576ee | 693 | } |
5b0e27a7 JD |
694 | |
695 | p[*len] = '\0'; | |
c7421e06 JD |
696 | if (nb < 3) |
697 | { | |
5b0e27a7 | 698 | memset (p, '*', nb); |
c7421e06 JD |
699 | return; |
700 | } | |
7b71bedf | 701 | |
5b0e27a7 | 702 | memset(p, ' ', nb); |
7b71bedf | 703 | |
c7421e06 JD |
704 | if (!isnan_flag) |
705 | { | |
706 | if (sign_bit) | |
707 | { | |
708 | /* If the sign is negative and the width is 3, there is | |
709 | insufficient room to output '-Inf', so output asterisks */ | |
710 | if (nb == 3) | |
711 | { | |
5b0e27a7 | 712 | memset (p, '*', nb); |
c7421e06 JD |
713 | return; |
714 | } | |
715 | /* The negative sign is mandatory */ | |
716 | fin = '-'; | |
717 | } | |
718 | else | |
719 | /* The positive sign is optional, but we output it for | |
720 | consistency */ | |
721 | fin = '+'; | |
722 | ||
6e0576ee | 723 | if (nb > mark) |
c7421e06 JD |
724 | /* We have room, so output 'Infinity' */ |
725 | memcpy(p + nb - 8, "Infinity", 8); | |
726 | else | |
727 | /* For the case of width equals 8, there is not enough room | |
728 | for the sign and 'Infinity' so we go with 'Inf' */ | |
729 | memcpy(p + nb - 3, "Inf", 3); | |
730 | ||
6e0576ee JD |
731 | if (sign == S_PLUS || sign == S_MINUS) |
732 | { | |
733 | if (nb < 9 && nb > 3) | |
734 | p[nb - 4] = fin; /* Put the sign in front of Inf */ | |
735 | else if (nb > 8) | |
736 | p[nb - 9] = fin; /* Put the sign in front of Infinity */ | |
737 | } | |
c7421e06 JD |
738 | } |
739 | else | |
5b0e27a7 | 740 | memcpy(p + nb - 3, "NaN", 3); |
7b71bedf | 741 | } |
c7421e06 | 742 | } |
7b71bedf JD |
743 | |
744 | ||
745 | /* Returns the value of 10**d. */ | |
746 | ||
747 | #define CALCULATE_EXP(x) \ | |
992b0aa1 | 748 | static GFC_REAL_ ## x \ |
7b71bedf JD |
749 | calculate_exp_ ## x (int d)\ |
750 | {\ | |
751 | int i;\ | |
752 | GFC_REAL_ ## x r = 1.0;\ | |
753 | for (i = 0; i< (d >= 0 ? d : -d); i++)\ | |
754 | r *= 10;\ | |
755 | r = (d >= 0) ? r : 1.0 / r;\ | |
756 | return r;\ | |
757 | } | |
758 | ||
759 | CALCULATE_EXP(4) | |
760 | ||
761 | CALCULATE_EXP(8) | |
762 | ||
763 | #ifdef HAVE_GFC_REAL_10 | |
764 | CALCULATE_EXP(10) | |
765 | #endif | |
766 | ||
767 | #ifdef HAVE_GFC_REAL_16 | |
768 | CALCULATE_EXP(16) | |
769 | #endif | |
770 | #undef CALCULATE_EXP | |
771 | ||
37b659dd | 772 | |
5b0e27a7 | 773 | /* Define macros to build code for format_float. */ |
37b659dd JB |
774 | |
775 | /* Note: Before output_float is called, snprintf is used to print to buffer the | |
776 | number in the format +D.DDDDe+ddd. | |
777 | ||
778 | # The result will always contain a decimal point, even if no | |
779 | digits follow it | |
780 | ||
781 | - The converted value is to be left adjusted on the field boundary | |
782 | ||
783 | + A sign (+ or -) always be placed before a number | |
784 | ||
785 | * prec is used as the precision | |
786 | ||
787 | e format: [-]d.ddde±dd where there is one digit before the | |
788 | decimal-point character and the number of digits after it is | |
789 | equal to the precision. The exponent always contains at least two | |
790 | digits; if the value is zero, the exponent is 00. */ | |
791 | ||
792 | ||
793 | #define TOKENPASTE(x, y) TOKENPASTE2(x, y) | |
794 | #define TOKENPASTE2(x, y) x ## y | |
795 | ||
796 | #define DTOA(suff,prec,val) TOKENPASTE(DTOA2,suff)(prec,val) | |
797 | ||
5b0e27a7 | 798 | #define DTOA2(prec,val) \ |
37b659dd JB |
799 | snprintf (buffer, size, "%+-#.*e", (prec), (val)) |
800 | ||
5b0e27a7 | 801 | #define DTOA2L(prec,val) \ |
37b659dd JB |
802 | snprintf (buffer, size, "%+-#.*Le", (prec), (val)) |
803 | ||
804 | ||
805 | #if defined(GFC_REAL_16_IS_FLOAT128) | |
5b0e27a7 | 806 | #define DTOA2Q(prec,val) \ |
9df47e83 | 807 | quadmath_snprintf (buffer, size, "%+-#.*Qe", (prec), (val)) |
37b659dd JB |
808 | #endif |
809 | ||
810 | #define FDTOA(suff,prec,val) TOKENPASTE(FDTOA2,suff)(prec,val) | |
811 | ||
812 | /* For F format, we print to the buffer with f format. */ | |
5b0e27a7 | 813 | #define FDTOA2(prec,val) \ |
37b659dd JB |
814 | snprintf (buffer, size, "%+-#.*f", (prec), (val)) |
815 | ||
5b0e27a7 | 816 | #define FDTOA2L(prec,val) \ |
37b659dd JB |
817 | snprintf (buffer, size, "%+-#.*Lf", (prec), (val)) |
818 | ||
819 | ||
820 | #if defined(GFC_REAL_16_IS_FLOAT128) | |
5b0e27a7 | 821 | #define FDTOA2Q(prec,val) \ |
9df47e83 | 822 | quadmath_snprintf (buffer, size, "%+-#.*Qf", \ |
37b659dd JB |
823 | (prec), (val)) |
824 | #endif | |
825 | ||
826 | ||
37b659dd JB |
827 | /* EN format is tricky since the number of significant digits depends |
828 | on the magnitude. Solve it by first printing a temporary value and | |
829 | figure out the number of significant digits from the printed | |
4e185d7c DH |
830 | exponent. Values y, 0.95*10.0**e <= y <10.0**e, are rounded to |
831 | 10.0**e even when the final result will not be rounded to 10.0**e. | |
832 | For these values the exponent returned by atoi has to be decremented | |
833 | by one. The values y in the ranges | |
834 | (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1)) | |
835 | (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2) | |
836 | (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1) | |
837 | are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)), | |
838 | 100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0 | |
839 | represents d zeroes, by the lines 279 to 297. */ | |
37b659dd JB |
840 | #define EN_PREC(x,y)\ |
841 | {\ | |
4e185d7c DH |
842 | volatile GFC_REAL_ ## x tmp, one = 1.0;\ |
843 | tmp = * (GFC_REAL_ ## x *)source;\ | |
5cdf54b7 | 844 | if (isfinite (tmp))\ |
4e185d7c DH |
845 | {\ |
846 | nprinted = DTOA(y,0,tmp);\ | |
847 | int e = atoi (&buffer[4]);\ | |
848 | if (buffer[1] == '1')\ | |
849 | {\ | |
850 | tmp = (calculate_exp_ ## x (-e)) * tmp;\ | |
5b0e27a7 | 851 | tmp = one - (tmp < 0 ? -tmp : tmp);\ |
4e185d7c DH |
852 | if (tmp > 0)\ |
853 | e = e - 1;\ | |
854 | }\ | |
855 | nbefore = e%3;\ | |
856 | if (nbefore < 0)\ | |
857 | nbefore = 3 + nbefore;\ | |
858 | }\ | |
37b659dd JB |
859 | else\ |
860 | nprinted = -1;\ | |
861 | }\ | |
302b150e | 862 | |
37b659dd JB |
863 | static int |
864 | determine_en_precision (st_parameter_dt *dtp, const fnode *f, | |
865 | const char *source, int len) | |
866 | { | |
867 | int nprinted; | |
868 | char buffer[10]; | |
869 | const size_t size = 10; | |
4e185d7c | 870 | int nbefore; /* digits before decimal point - 1. */ |
302b150e | 871 | |
37b659dd JB |
872 | switch (len) |
873 | { | |
874 | case 4: | |
875 | EN_PREC(4,) | |
876 | break; | |
302b150e | 877 | |
37b659dd JB |
878 | case 8: |
879 | EN_PREC(8,) | |
880 | break; | |
7b71bedf | 881 | |
37b659dd JB |
882 | #ifdef HAVE_GFC_REAL_10 |
883 | case 10: | |
884 | EN_PREC(10,L) | |
885 | break; | |
886 | #endif | |
887 | #ifdef HAVE_GFC_REAL_16 | |
888 | case 16: | |
889 | # ifdef GFC_REAL_16_IS_FLOAT128 | |
890 | EN_PREC(16,Q) | |
891 | # else | |
892 | EN_PREC(16,L) | |
893 | # endif | |
894 | break; | |
895 | #endif | |
896 | default: | |
897 | internal_error (NULL, "bad real kind"); | |
898 | } | |
7b71bedf | 899 | |
37b659dd JB |
900 | if (nprinted == -1) |
901 | return -1; | |
7b71bedf | 902 | |
37b659dd JB |
903 | int prec = f->u.real.d + nbefore; |
904 | if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED | |
905 | && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED) | |
906 | prec += 2 * len + 4; | |
907 | return prec; | |
908 | } | |
909 | ||
1ec601bf | 910 | |
5b0e27a7 JD |
911 | /* Generate corresponding I/O format. and output. |
912 | The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran | |
913 | LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is: | |
914 | ||
915 | Data Magnitude Equivalent Conversion | |
916 | 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee] | |
917 | m = 0 F(w-n).(d-1), n' ' | |
918 | 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' ' | |
919 | 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' ' | |
920 | 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' ' | |
921 | ................ .......... | |
922 | 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ') | |
923 | m >= 10**d-0.5 Ew.d[Ee] | |
924 | ||
925 | notes: for Gw.d , n' ' means 4 blanks | |
926 | for Gw.dEe, n' ' means e+2 blanks | |
927 | for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2 | |
928 | the asm volatile is required for 32-bit x86 platforms. */ | |
929 | #define FORMAT_FLOAT(x,y)\ | |
7b71bedf | 930 | {\ |
5b0e27a7 JD |
931 | int npad = 0;\ |
932 | GFC_REAL_ ## x m;\ | |
933 | m = * (GFC_REAL_ ## x *)source;\ | |
934 | sign_bit = signbit (m);\ | |
935 | if (!isfinite (m))\ | |
936 | { \ | |
937 | build_infnan_string (dtp, f, isnan (m), sign_bit, result, res_len);\ | |
938 | return;\ | |
939 | }\ | |
940 | m = sign_bit ? -m : m;\ | |
941 | zero_flag = (m == 0.0);\ | |
942 | if (f->format == FMT_G)\ | |
943 | {\ | |
944 | int e = f->u.real.e;\ | |
945 | int d = f->u.real.d;\ | |
946 | int w = f->u.real.w;\ | |
947 | fnode newf;\ | |
948 | GFC_REAL_ ## x exp_d, r = 0.5, r_sc;\ | |
949 | int low, high, mid;\ | |
950 | int ubound, lbound;\ | |
951 | int save_scale_factor;\ | |
952 | volatile GFC_REAL_ ## x temp;\ | |
953 | save_scale_factor = dtp->u.p.scale_factor;\ | |
954 | switch (dtp->u.p.current_unit->round_status)\ | |
955 | {\ | |
956 | case ROUND_ZERO:\ | |
957 | r = sign_bit ? 1.0 : 0.0;\ | |
958 | break;\ | |
959 | case ROUND_UP:\ | |
960 | r = 1.0;\ | |
961 | break;\ | |
962 | case ROUND_DOWN:\ | |
963 | r = 0.0;\ | |
964 | break;\ | |
965 | default:\ | |
966 | break;\ | |
967 | }\ | |
968 | exp_d = calculate_exp_ ## x (d);\ | |
969 | r_sc = (1 - r / exp_d);\ | |
970 | temp = 0.1 * r_sc;\ | |
971 | if ((m > 0.0 && ((m < temp) || (r >= (exp_d - m))))\ | |
972 | || ((m == 0.0) && !(compile_options.allow_std\ | |
973 | & (GFC_STD_F2003 | GFC_STD_F2008)))\ | |
974 | || d == 0)\ | |
975 | { \ | |
976 | newf.format = FMT_E;\ | |
977 | newf.u.real.w = w;\ | |
978 | newf.u.real.d = d - comp_d;\ | |
979 | newf.u.real.e = e;\ | |
980 | npad = 0;\ | |
981 | precision = determine_precision (dtp, &newf, x);\ | |
982 | nprinted = DTOA(y,precision,m);\ | |
983 | }\ | |
984 | else \ | |
985 | {\ | |
986 | mid = 0;\ | |
987 | low = 0;\ | |
988 | high = d + 1;\ | |
989 | lbound = 0;\ | |
990 | ubound = d + 1;\ | |
991 | while (low <= high)\ | |
992 | {\ | |
993 | mid = (low + high) / 2;\ | |
994 | temp = (calculate_exp_ ## x (mid - 1) * r_sc);\ | |
995 | if (m < temp)\ | |
996 | { \ | |
997 | ubound = mid;\ | |
998 | if (ubound == lbound + 1)\ | |
999 | break;\ | |
1000 | high = mid - 1;\ | |
1001 | }\ | |
1002 | else if (m > temp)\ | |
1003 | { \ | |
1004 | lbound = mid;\ | |
1005 | if (ubound == lbound + 1)\ | |
1006 | { \ | |
1007 | mid ++;\ | |
1008 | break;\ | |
1009 | }\ | |
1010 | low = mid + 1;\ | |
1011 | }\ | |
1012 | else\ | |
1013 | {\ | |
1014 | mid++;\ | |
1015 | break;\ | |
1016 | }\ | |
1017 | }\ | |
1018 | npad = e <= 0 ? 4 : e + 2;\ | |
1019 | npad = npad >= w ? w - 1 : npad;\ | |
1020 | npad = dtp->u.p.g0_no_blanks ? 0 : npad;\ | |
1021 | newf.format = FMT_F;\ | |
1022 | newf.u.real.w = w - npad;\ | |
1023 | newf.u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\ | |
1024 | dtp->u.p.scale_factor = 0;\ | |
1025 | precision = determine_precision (dtp, &newf, x);\ | |
1026 | nprinted = FDTOA(y,precision,m);\ | |
1027 | }\ | |
1028 | build_float_string (dtp, &newf, buffer, size, nprinted, precision,\ | |
1029 | sign_bit, zero_flag, npad, result, res_len);\ | |
1030 | dtp->u.p.scale_factor = save_scale_factor;\ | |
1031 | }\ | |
1032 | else\ | |
1033 | {\ | |
1034 | if (f->format == FMT_F)\ | |
1035 | nprinted = FDTOA(y,precision,m);\ | |
1036 | else\ | |
1037 | nprinted = DTOA(y,precision,m);\ | |
1038 | build_float_string (dtp, f, buffer, size, nprinted, precision,\ | |
1039 | sign_bit, zero_flag, npad, result, res_len);\ | |
1040 | }\ | |
7b71bedf JD |
1041 | }\ |
1042 | ||
1043 | /* Output a real number according to its format. */ | |
1044 | ||
5b0e27a7 | 1045 | |
7b71bedf | 1046 | static void |
5b0e27a7 JD |
1047 | get_float_string (st_parameter_dt *dtp, const fnode *f, const char *source, |
1048 | int kind, int comp_d, char *buffer, int precision, | |
1049 | size_t size, char *result, size_t *res_len) | |
7b71bedf | 1050 | { |
37b659dd | 1051 | int sign_bit, nprinted; |
7b71bedf | 1052 | bool zero_flag; |
7b71bedf | 1053 | |
5b0e27a7 | 1054 | switch (kind) |
7b71bedf JD |
1055 | { |
1056 | case 4: | |
5b0e27a7 | 1057 | FORMAT_FLOAT(4,) |
7b71bedf JD |
1058 | break; |
1059 | ||
1060 | case 8: | |
5b0e27a7 | 1061 | FORMAT_FLOAT(8,) |
7b71bedf JD |
1062 | break; |
1063 | ||
1064 | #ifdef HAVE_GFC_REAL_10 | |
1065 | case 10: | |
5b0e27a7 | 1066 | FORMAT_FLOAT(10,L) |
7b71bedf JD |
1067 | break; |
1068 | #endif | |
1069 | #ifdef HAVE_GFC_REAL_16 | |
1070 | case 16: | |
1ec601bf | 1071 | # ifdef GFC_REAL_16_IS_FLOAT128 |
5b0e27a7 | 1072 | FORMAT_FLOAT(16,Q) |
1ec601bf | 1073 | # else |
5b0e27a7 | 1074 | FORMAT_FLOAT(16,L) |
1ec601bf | 1075 | # endif |
7b71bedf JD |
1076 | break; |
1077 | #endif | |
1078 | default: | |
1079 | internal_error (NULL, "bad real kind"); | |
1080 | } | |
5b0e27a7 | 1081 | return; |
7b71bedf | 1082 | } |