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