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