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