* config/m32c/predicates.md (m32c_psi_scale): New.
[official-gcc.git] / libgfortran / io / write.c
blobd6323f4a695bbb2ba40c4100e7f146e007612504
1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist output contibuted by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 #include "config.h"
32 #include <assert.h>
33 #include <string.h>
34 #include <ctype.h>
35 #include <float.h>
36 #include <stdio.h>
37 #include <stdlib.h>
38 #include "libgfortran.h"
39 #include "io.h"
41 #define star_fill(p, n) memset(p, '*', n)
44 typedef enum
45 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
46 sign_t;
49 void
50 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
52 int wlen;
53 char *p;
55 wlen = f->u.string.length < 0 ? len : f->u.string.length;
57 p = write_block (dtp, wlen);
58 if (p == NULL)
59 return;
61 if (wlen < len)
62 memcpy (p, source, wlen);
63 else
65 memset (p, ' ', wlen - len);
66 memcpy (p + wlen - len, source, len);
70 static GFC_INTEGER_LARGEST
71 extract_int (const void *p, int len)
73 GFC_INTEGER_LARGEST i = 0;
75 if (p == NULL)
76 return i;
78 switch (len)
80 case 1:
82 GFC_INTEGER_1 tmp;
83 memcpy ((void *) &tmp, p, len);
84 i = tmp;
86 break;
87 case 2:
89 GFC_INTEGER_2 tmp;
90 memcpy ((void *) &tmp, p, len);
91 i = tmp;
93 break;
94 case 4:
96 GFC_INTEGER_4 tmp;
97 memcpy ((void *) &tmp, p, len);
98 i = tmp;
100 break;
101 case 8:
103 GFC_INTEGER_8 tmp;
104 memcpy ((void *) &tmp, p, len);
105 i = tmp;
107 break;
108 #ifdef HAVE_GFC_INTEGER_16
109 case 16:
111 GFC_INTEGER_16 tmp;
112 memcpy ((void *) &tmp, p, len);
113 i = tmp;
115 break;
116 #endif
117 default:
118 internal_error (NULL, "bad integer kind");
121 return i;
124 static GFC_UINTEGER_LARGEST
125 extract_uint (const void *p, int len)
127 GFC_UINTEGER_LARGEST i = 0;
129 if (p == NULL)
130 return i;
132 switch (len)
134 case 1:
136 GFC_INTEGER_1 tmp;
137 memcpy ((void *) &tmp, p, len);
138 i = (GFC_UINTEGER_1) tmp;
140 break;
141 case 2:
143 GFC_INTEGER_2 tmp;
144 memcpy ((void *) &tmp, p, len);
145 i = (GFC_UINTEGER_2) tmp;
147 break;
148 case 4:
150 GFC_INTEGER_4 tmp;
151 memcpy ((void *) &tmp, p, len);
152 i = (GFC_UINTEGER_4) tmp;
154 break;
155 case 8:
157 GFC_INTEGER_8 tmp;
158 memcpy ((void *) &tmp, p, len);
159 i = (GFC_UINTEGER_8) tmp;
161 break;
162 #ifdef HAVE_GFC_INTEGER_16
163 case 16:
165 GFC_INTEGER_16 tmp;
166 memcpy ((void *) &tmp, p, len);
167 i = (GFC_UINTEGER_16) tmp;
169 break;
170 #endif
171 default:
172 internal_error (NULL, "bad integer kind");
175 return i;
178 static GFC_REAL_LARGEST
179 extract_real (const void *p, int len)
181 GFC_REAL_LARGEST i = 0;
182 switch (len)
184 case 4:
186 GFC_REAL_4 tmp;
187 memcpy ((void *) &tmp, p, len);
188 i = tmp;
190 break;
191 case 8:
193 GFC_REAL_8 tmp;
194 memcpy ((void *) &tmp, p, len);
195 i = tmp;
197 break;
198 #ifdef HAVE_GFC_REAL_10
199 case 10:
201 GFC_REAL_10 tmp;
202 memcpy ((void *) &tmp, p, len);
203 i = tmp;
205 break;
206 #endif
207 #ifdef HAVE_GFC_REAL_16
208 case 16:
210 GFC_REAL_16 tmp;
211 memcpy ((void *) &tmp, p, len);
212 i = tmp;
214 break;
215 #endif
216 default:
217 internal_error (NULL, "bad real kind");
219 return i;
223 /* Given a flag that indicate if a value is negative or not, return a
224 sign_t that gives the sign that we need to produce. */
226 static sign_t
227 calculate_sign (st_parameter_dt *dtp, int negative_flag)
229 sign_t s = SIGN_NONE;
231 if (negative_flag)
232 s = SIGN_MINUS;
233 else
234 switch (dtp->u.p.sign_status)
236 case SIGN_SP:
237 s = SIGN_PLUS;
238 break;
239 case SIGN_SS:
240 s = SIGN_NONE;
241 break;
242 case SIGN_S:
243 s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
244 break;
247 return s;
251 /* Returns the value of 10**d. */
253 static GFC_REAL_LARGEST
254 calculate_exp (int d)
256 int i;
257 GFC_REAL_LARGEST r = 1.0;
259 for (i = 0; i< (d >= 0 ? d : -d); i++)
260 r *= 10;
262 r = (d >= 0) ? r : 1.0 / r;
264 return r;
268 /* Generate corresponding I/O format for FMT_G output.
269 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
270 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
272 Data Magnitude Equivalent Conversion
273 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
274 m = 0 F(w-n).(d-1), n' '
275 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
276 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
277 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
278 ................ ..........
279 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
280 m >= 10**d-0.5 Ew.d[Ee]
282 notes: for Gw.d , n' ' means 4 blanks
283 for Gw.dEe, n' ' means e+2 blanks */
285 static fnode *
286 calculate_G_format (st_parameter_dt *dtp, const fnode *f,
287 GFC_REAL_LARGEST value, int *num_blank)
289 int e = f->u.real.e;
290 int d = f->u.real.d;
291 int w = f->u.real.w;
292 fnode *newf;
293 GFC_REAL_LARGEST m, exp_d;
294 int low, high, mid;
295 int ubound, lbound;
297 newf = get_mem (sizeof (fnode));
299 /* Absolute value. */
300 m = (value > 0.0) ? value : -value;
302 /* In case of the two data magnitude ranges,
303 generate E editing, Ew.d[Ee]. */
304 exp_d = calculate_exp (d);
305 if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ))
307 newf->format = FMT_E;
308 newf->u.real.w = w;
309 newf->u.real.d = d;
310 newf->u.real.e = e;
311 *num_blank = 0;
312 return newf;
315 /* Use binary search to find the data magnitude range. */
316 mid = 0;
317 low = 0;
318 high = d + 1;
319 lbound = 0;
320 ubound = d + 1;
322 while (low <= high)
324 GFC_REAL_LARGEST temp;
325 mid = (low + high) / 2;
327 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
328 temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
330 if (m < temp)
332 ubound = mid;
333 if (ubound == lbound + 1)
334 break;
335 high = mid - 1;
337 else if (m > temp)
339 lbound = mid;
340 if (ubound == lbound + 1)
342 mid ++;
343 break;
345 low = mid + 1;
347 else
348 break;
351 /* Pad with blanks where the exponent would be. */
352 if (e < 0)
353 *num_blank = 4;
354 else
355 *num_blank = e + 2;
357 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
358 newf->format = FMT_F;
359 newf->u.real.w = f->u.real.w - *num_blank;
361 /* Special case. */
362 if (m == 0.0)
363 newf->u.real.d = d - 1;
364 else
365 newf->u.real.d = - (mid - d - 1);
367 /* For F editing, the scale factor is ignored. */
368 dtp->u.p.scale_factor = 0;
369 return newf;
373 /* Output a real number according to its format which is FMT_G free. */
375 static void
376 output_float (st_parameter_dt *dtp, const fnode *f, GFC_REAL_LARGEST value)
378 /* This must be large enough to accurately hold any value. */
379 char buffer[32];
380 char *out;
381 char *digits;
382 int e;
383 char expchar;
384 format_token ft;
385 int w;
386 int d;
387 int edigits;
388 int ndigits;
389 /* Number of digits before the decimal point. */
390 int nbefore;
391 /* Number of zeros after the decimal point. */
392 int nzero;
393 /* Number of digits after the decimal point. */
394 int nafter;
395 /* Number of zeros after the decimal point, whatever the precision. */
396 int nzero_real;
397 int leadzero;
398 int nblanks;
399 int i;
400 sign_t sign;
401 double abslog;
403 ft = f->format;
404 w = f->u.real.w;
405 d = f->u.real.d;
407 nzero_real = -1;
410 /* We should always know the field width and precision. */
411 if (d < 0)
412 internal_error (&dtp->common, "Unspecified precision");
414 /* Use sprintf to print the number in the format +D.DDDDe+ddd
415 For an N digit exponent, this gives us (32-6)-N digits after the
416 decimal point, plus another one before the decimal point. */
417 sign = calculate_sign (dtp, value < 0.0);
418 if (value < 0)
419 value = -value;
421 /* Printf always prints at least two exponent digits. */
422 if (value == 0)
423 edigits = 2;
424 else
426 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
427 abslog = fabs((double) log10l(value));
428 #else
429 abslog = fabs(log10(value));
430 #endif
431 if (abslog < 100)
432 edigits = 2;
433 else
434 edigits = 1 + (int) log10(abslog);
437 if (ft == FMT_F || ft == FMT_EN
438 || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
440 /* Always convert at full precision to avoid double rounding. */
441 ndigits = 27 - edigits;
443 else
445 /* We know the number of digits, so can let printf do the rounding
446 for us. */
447 if (ft == FMT_ES)
448 ndigits = d + 1;
449 else
450 ndigits = d;
451 if (ndigits > 27 - edigits)
452 ndigits = 27 - edigits;
455 /* # The result will always contain a decimal point, even if no
456 * digits follow it
458 * - The converted value is to be left adjusted on the field boundary
460 * + A sign (+ or -) always be placed before a number
462 * 31 minimum field width
464 * * (ndigits-1) is used as the precision
466 * e format: [-]d.ddde±dd where there is one digit before the
467 * decimal-point character and the number of digits after it is
468 * equal to the precision. The exponent always contains at least two
469 * digits; if the value is zero, the exponent is 00.
471 sprintf (buffer, "%+-#31.*" GFC_REAL_LARGEST_FORMAT "e",
472 ndigits - 1, value);
474 /* Check the resulting string has punctuation in the correct places. */
475 if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
476 internal_error (&dtp->common, "printf is broken");
478 /* Read the exponent back in. */
479 e = atoi (&buffer[ndigits + 3]) + 1;
481 /* Make sure zero comes out as 0.0e0. */
482 if (value == 0.0)
483 e = 0;
485 /* Normalize the fractional component. */
486 buffer[2] = buffer[1];
487 digits = &buffer[2];
489 /* Figure out where to place the decimal point. */
490 switch (ft)
492 case FMT_F:
493 nbefore = e + dtp->u.p.scale_factor;
494 if (nbefore < 0)
496 nzero = -nbefore;
497 nzero_real = nzero;
498 if (nzero > d)
499 nzero = d;
500 nafter = d - nzero;
501 nbefore = 0;
503 else
505 nzero = 0;
506 nafter = d;
508 expchar = 0;
509 break;
511 case FMT_E:
512 case FMT_D:
513 i = dtp->u.p.scale_factor;
514 if (value != 0.0)
515 e -= i;
516 if (i < 0)
518 nbefore = 0;
519 nzero = -i;
520 nafter = d + i;
522 else if (i > 0)
524 nbefore = i;
525 nzero = 0;
526 nafter = (d - i) + 1;
528 else /* i == 0 */
530 nbefore = 0;
531 nzero = 0;
532 nafter = d;
535 if (ft == FMT_E)
536 expchar = 'E';
537 else
538 expchar = 'D';
539 break;
541 case FMT_EN:
542 /* The exponent must be a multiple of three, with 1-3 digits before
543 the decimal point. */
544 if (value != 0.0)
545 e--;
546 if (e >= 0)
547 nbefore = e % 3;
548 else
550 nbefore = (-e) % 3;
551 if (nbefore != 0)
552 nbefore = 3 - nbefore;
554 e -= nbefore;
555 nbefore++;
556 nzero = 0;
557 nafter = d;
558 expchar = 'E';
559 break;
561 case FMT_ES:
562 if (value != 0.0)
563 e--;
564 nbefore = 1;
565 nzero = 0;
566 nafter = d;
567 expchar = 'E';
568 break;
570 default:
571 /* Should never happen. */
572 internal_error (&dtp->common, "Unexpected format token");
575 /* Round the value. */
576 if (nbefore + nafter == 0)
578 ndigits = 0;
579 if (nzero_real == d && digits[0] >= '5')
581 /* We rounded to zero but shouldn't have */
582 nzero--;
583 nafter = 1;
584 digits[0] = '1';
585 ndigits = 1;
588 else if (nbefore + nafter < ndigits)
590 ndigits = nbefore + nafter;
591 i = ndigits;
592 if (digits[i] >= '5')
594 /* Propagate the carry. */
595 for (i--; i >= 0; i--)
597 if (digits[i] != '9')
599 digits[i]++;
600 break;
602 digits[i] = '0';
605 if (i < 0)
607 /* The carry overflowed. Fortunately we have some spare space
608 at the start of the buffer. We may discard some digits, but
609 this is ok because we already know they are zero. */
610 digits--;
611 digits[0] = '1';
612 if (ft == FMT_F)
614 if (nzero > 0)
616 nzero--;
617 nafter++;
619 else
620 nbefore++;
622 else if (ft == FMT_EN)
624 nbefore++;
625 if (nbefore == 4)
627 nbefore = 1;
628 e += 3;
631 else
632 e++;
637 /* Calculate the format of the exponent field. */
638 if (expchar)
640 edigits = 1;
641 for (i = abs (e); i >= 10; i /= 10)
642 edigits++;
644 if (f->u.real.e < 0)
646 /* Width not specified. Must be no more than 3 digits. */
647 if (e > 999 || e < -999)
648 edigits = -1;
649 else
651 edigits = 4;
652 if (e > 99 || e < -99)
653 expchar = ' ';
656 else
658 /* Exponent width specified, check it is wide enough. */
659 if (edigits > f->u.real.e)
660 edigits = -1;
661 else
662 edigits = f->u.real.e + 2;
665 else
666 edigits = 0;
668 /* Pick a field size if none was specified. */
669 if (w <= 0)
670 w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
672 /* Create the ouput buffer. */
673 out = write_block (dtp, w);
674 if (out == NULL)
675 return;
677 /* Zero values always output as positive, even if the value was negative
678 before rounding. */
679 for (i = 0; i < ndigits; i++)
681 if (digits[i] != '0')
682 break;
684 if (i == ndigits)
685 sign = calculate_sign (dtp, 0);
687 /* Work out how much padding is needed. */
688 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
689 if (sign != SIGN_NONE)
690 nblanks--;
692 /* Check the value fits in the specified field width. */
693 if (nblanks < 0 || edigits == -1)
695 star_fill (out, w);
696 return;
699 /* See if we have space for a zero before the decimal point. */
700 if (nbefore == 0 && nblanks > 0)
702 leadzero = 1;
703 nblanks--;
705 else
706 leadzero = 0;
708 /* Pad to full field width. */
711 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
713 memset (out, ' ', nblanks);
714 out += nblanks;
717 /* Output the initial sign (if any). */
718 if (sign == SIGN_PLUS)
719 *(out++) = '+';
720 else if (sign == SIGN_MINUS)
721 *(out++) = '-';
723 /* Output an optional leading zero. */
724 if (leadzero)
725 *(out++) = '0';
727 /* Output the part before the decimal point, padding with zeros. */
728 if (nbefore > 0)
730 if (nbefore > ndigits)
731 i = ndigits;
732 else
733 i = nbefore;
735 memcpy (out, digits, i);
736 while (i < nbefore)
737 out[i++] = '0';
739 digits += i;
740 ndigits -= i;
741 out += nbefore;
743 /* Output the decimal point. */
744 *(out++) = '.';
746 /* Output leading zeros after the decimal point. */
747 if (nzero > 0)
749 for (i = 0; i < nzero; i++)
750 *(out++) = '0';
753 /* Output digits after the decimal point, padding with zeros. */
754 if (nafter > 0)
756 if (nafter > ndigits)
757 i = ndigits;
758 else
759 i = nafter;
761 memcpy (out, digits, i);
762 while (i < nafter)
763 out[i++] = '0';
765 digits += i;
766 ndigits -= i;
767 out += nafter;
770 /* Output the exponent. */
771 if (expchar)
773 if (expchar != ' ')
775 *(out++) = expchar;
776 edigits--;
778 #if HAVE_SNPRINTF
779 snprintf (buffer, 32, "%+0*d", edigits, e);
780 #else
781 sprintf (buffer, "%+0*d", edigits, e);
782 #endif
783 memcpy (out, buffer, edigits);
786 if (dtp->u.p.no_leading_blank)
788 out += edigits;
789 memset( out , ' ' , nblanks );
790 dtp->u.p.no_leading_blank = 0;
795 void
796 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
798 char *p;
799 GFC_INTEGER_LARGEST n;
801 p = write_block (dtp, f->u.w);
802 if (p == NULL)
803 return;
805 memset (p, ' ', f->u.w - 1);
806 n = extract_int (source, len);
807 p[f->u.w - 1] = (n) ? 'T' : 'F';
810 /* Output a real number according to its format. */
812 static void
813 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
815 GFC_REAL_LARGEST n;
816 int nb =0, res, save_scale_factor;
817 char * p, fin;
818 fnode *f2 = NULL;
820 n = extract_real (source, len);
822 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
824 res = isfinite (n);
825 if (res == 0)
827 nb = f->u.real.w;
829 /* If the field width is zero, the processor must select a width
830 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
832 if (nb == 0) nb = 4;
833 p = write_block (dtp, nb);
834 if (p == NULL)
835 return;
836 if (nb < 3)
838 memset (p, '*',nb);
839 return;
842 memset(p, ' ', nb);
843 res = !isnan (n);
844 if (res != 0)
846 if (signbit(n))
849 /* If the sign is negative and the width is 3, there is
850 insufficient room to output '-Inf', so output asterisks */
852 if (nb == 3)
854 memset (p, '*',nb);
855 return;
858 /* The negative sign is mandatory */
860 fin = '-';
862 else
864 /* The positive sign is optional, but we output it for
865 consistency */
867 fin = '+';
869 if (nb > 8)
871 /* We have room, so output 'Infinity' */
873 memcpy(p + nb - 8, "Infinity", 8);
874 else
876 /* For the case of width equals 8, there is not enough room
877 for the sign and 'Infinity' so we go with 'Inf' */
879 memcpy(p + nb - 3, "Inf", 3);
880 if (nb < 9 && nb > 3)
881 p[nb - 4] = fin; /* Put the sign in front of Inf */
882 else if (nb > 8)
883 p[nb - 9] = fin; /* Put the sign in front of Infinity */
885 else
886 memcpy(p + nb - 3, "NaN", 3);
887 return;
891 if (f->format != FMT_G)
892 output_float (dtp, f, n);
893 else
895 save_scale_factor = dtp->u.p.scale_factor;
896 f2 = calculate_G_format (dtp, f, n, &nb);
897 output_float (dtp, f2, n);
898 dtp->u.p.scale_factor = save_scale_factor;
899 if (f2 != NULL)
900 free_mem(f2);
902 if (nb > 0)
904 p = write_block (dtp, nb);
905 if (p == NULL)
906 return;
907 memset (p, ' ', nb);
913 static void
914 write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
915 const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
917 GFC_UINTEGER_LARGEST n = 0;
918 int w, m, digits, nzero, nblank;
919 char *p;
920 const char *q;
921 char itoa_buf[GFC_BTOA_BUF_SIZE];
923 w = f->u.integer.w;
924 m = f->u.integer.m;
926 n = extract_uint (source, len);
928 /* Special case: */
930 if (m == 0 && n == 0)
932 if (w == 0)
933 w = 1;
935 p = write_block (dtp, w);
936 if (p == NULL)
937 return;
939 memset (p, ' ', w);
940 goto done;
943 q = conv (n, itoa_buf, sizeof (itoa_buf));
944 digits = strlen (q);
946 /* Select a width if none was specified. The idea here is to always
947 print something. */
949 if (w == 0)
950 w = ((digits < m) ? m : digits);
952 p = write_block (dtp, w);
953 if (p == NULL)
954 return;
956 nzero = 0;
957 if (digits < m)
958 nzero = m - digits;
960 /* See if things will work. */
962 nblank = w - (nzero + digits);
964 if (nblank < 0)
966 star_fill (p, w);
967 goto done;
971 if (!dtp->u.p.no_leading_blank)
973 memset (p, ' ', nblank);
974 p += nblank;
975 memset (p, '0', nzero);
976 p += nzero;
977 memcpy (p, q, digits);
979 else
981 memset (p, '0', nzero);
982 p += nzero;
983 memcpy (p, q, digits);
984 p += digits;
985 memset (p, ' ', nblank);
986 dtp->u.p.no_leading_blank = 0;
989 done:
990 return;
993 static void
994 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
995 int len,
996 const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
998 GFC_INTEGER_LARGEST n = 0;
999 int w, m, digits, nsign, nzero, nblank;
1000 char *p;
1001 const char *q;
1002 sign_t sign;
1003 char itoa_buf[GFC_BTOA_BUF_SIZE];
1005 w = f->u.integer.w;
1006 m = f->u.integer.m;
1008 n = extract_int (source, len);
1010 /* Special case: */
1012 if (m == 0 && n == 0)
1014 if (w == 0)
1015 w = 1;
1017 p = write_block (dtp, w);
1018 if (p == NULL)
1019 return;
1021 memset (p, ' ', w);
1022 goto done;
1025 sign = calculate_sign (dtp, n < 0);
1026 if (n < 0)
1027 n = -n;
1029 nsign = sign == SIGN_NONE ? 0 : 1;
1030 q = conv (n, itoa_buf, sizeof (itoa_buf));
1032 digits = strlen (q);
1034 /* Select a width if none was specified. The idea here is to always
1035 print something. */
1037 if (w == 0)
1038 w = ((digits < m) ? m : digits) + nsign;
1040 p = write_block (dtp, w);
1041 if (p == NULL)
1042 return;
1044 nzero = 0;
1045 if (digits < m)
1046 nzero = m - digits;
1048 /* See if things will work. */
1050 nblank = w - (nsign + nzero + digits);
1052 if (nblank < 0)
1054 star_fill (p, w);
1055 goto done;
1058 memset (p, ' ', nblank);
1059 p += nblank;
1061 switch (sign)
1063 case SIGN_PLUS:
1064 *p++ = '+';
1065 break;
1066 case SIGN_MINUS:
1067 *p++ = '-';
1068 break;
1069 case SIGN_NONE:
1070 break;
1073 memset (p, '0', nzero);
1074 p += nzero;
1076 memcpy (p, q, digits);
1078 done:
1079 return;
1083 /* Convert unsigned octal to ascii. */
1085 static const char *
1086 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
1088 char *p;
1090 assert (len >= GFC_OTOA_BUF_SIZE);
1092 if (n == 0)
1093 return "0";
1095 p = buffer + GFC_OTOA_BUF_SIZE - 1;
1096 *p = '\0';
1098 while (n != 0)
1100 *--p = '0' + (n & 7);
1101 n >>= 3;
1104 return p;
1108 /* Convert unsigned binary to ascii. */
1110 static const char *
1111 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
1113 char *p;
1115 assert (len >= GFC_BTOA_BUF_SIZE);
1117 if (n == 0)
1118 return "0";
1120 p = buffer + GFC_BTOA_BUF_SIZE - 1;
1121 *p = '\0';
1123 while (n != 0)
1125 *--p = '0' + (n & 1);
1126 n >>= 1;
1129 return p;
1133 void
1134 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1136 write_decimal (dtp, f, p, len, (void *) gfc_itoa);
1140 void
1141 write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1143 write_int (dtp, f, p, len, btoa);
1147 void
1148 write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1150 write_int (dtp, f, p, len, otoa);
1153 void
1154 write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1156 write_int (dtp, f, p, len, xtoa);
1160 void
1161 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1163 write_float (dtp, f, p, len);
1167 void
1168 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1170 write_float (dtp, f, p, len);
1174 void
1175 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1177 write_float (dtp, f, p, len);
1181 void
1182 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1184 write_float (dtp, f, p, len);
1188 void
1189 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1191 write_float (dtp, f, p, len);
1195 /* Take care of the X/TR descriptor. */
1197 void
1198 write_x (st_parameter_dt *dtp, int len, int nspaces)
1200 char *p;
1202 p = write_block (dtp, len);
1203 if (p == NULL)
1204 return;
1206 if (nspaces > 0)
1207 memset (&p[len - nspaces], ' ', nspaces);
1211 /* List-directed writing. */
1214 /* Write a single character to the output. Returns nonzero if
1215 something goes wrong. */
1217 static int
1218 write_char (st_parameter_dt *dtp, char c)
1220 char *p;
1222 p = write_block (dtp, 1);
1223 if (p == NULL)
1224 return 1;
1226 *p = c;
1228 return 0;
1232 /* Write a list-directed logical value. */
1234 static void
1235 write_logical (st_parameter_dt *dtp, const char *source, int length)
1237 write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1241 /* Write a list-directed integer value. */
1243 static void
1244 write_integer (st_parameter_dt *dtp, const char *source, int length)
1246 char *p;
1247 const char *q;
1248 int digits;
1249 int width;
1250 char itoa_buf[GFC_ITOA_BUF_SIZE];
1252 q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
1254 switch (length)
1256 case 1:
1257 width = 4;
1258 break;
1260 case 2:
1261 width = 6;
1262 break;
1264 case 4:
1265 width = 11;
1266 break;
1268 case 8:
1269 width = 20;
1270 break;
1272 default:
1273 width = 0;
1274 break;
1277 digits = strlen (q);
1279 if (width < digits)
1280 width = digits;
1281 p = write_block (dtp, width);
1282 if (p == NULL)
1283 return;
1284 if (dtp->u.p.no_leading_blank)
1286 memcpy (p, q, digits);
1287 memset (p + digits, ' ', width - digits);
1289 else
1291 memset (p, ' ', width - digits);
1292 memcpy (p + width - digits, q, digits);
1297 /* Write a list-directed string. We have to worry about delimiting
1298 the strings if the file has been opened in that mode. */
1300 static void
1301 write_character (st_parameter_dt *dtp, const char *source, int length)
1303 int i, extra;
1304 char *p, d;
1306 switch (dtp->u.p.current_unit->flags.delim)
1308 case DELIM_APOSTROPHE:
1309 d = '\'';
1310 break;
1311 case DELIM_QUOTE:
1312 d = '"';
1313 break;
1314 default:
1315 d = ' ';
1316 break;
1319 if (d == ' ')
1320 extra = 0;
1321 else
1323 extra = 2;
1325 for (i = 0; i < length; i++)
1326 if (source[i] == d)
1327 extra++;
1330 p = write_block (dtp, length + extra);
1331 if (p == NULL)
1332 return;
1334 if (d == ' ')
1335 memcpy (p, source, length);
1336 else
1338 *p++ = d;
1340 for (i = 0; i < length; i++)
1342 *p++ = source[i];
1343 if (source[i] == d)
1344 *p++ = d;
1347 *p = d;
1352 /* Output a real number with default format.
1353 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1354 1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16). */
1356 static void
1357 write_real (st_parameter_dt *dtp, const char *source, int length)
1359 fnode f ;
1360 int org_scale = dtp->u.p.scale_factor;
1361 f.format = FMT_G;
1362 dtp->u.p.scale_factor = 1;
1363 switch (length)
1365 case 4:
1366 f.u.real.w = 14;
1367 f.u.real.d = 7;
1368 f.u.real.e = 2;
1369 break;
1370 case 8:
1371 f.u.real.w = 23;
1372 f.u.real.d = 15;
1373 f.u.real.e = 3;
1374 break;
1375 case 10:
1376 f.u.real.w = 24;
1377 f.u.real.d = 15;
1378 f.u.real.e = 4;
1379 break;
1380 case 16:
1381 f.u.real.w = 40;
1382 f.u.real.d = 31;
1383 f.u.real.e = 4;
1384 break;
1385 default:
1386 internal_error (&dtp->common, "bad real kind");
1387 break;
1389 write_float (dtp, &f, source , length);
1390 dtp->u.p.scale_factor = org_scale;
1394 static void
1395 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1397 if (write_char (dtp, '('))
1398 return;
1399 write_real (dtp, source, kind);
1401 if (write_char (dtp, ','))
1402 return;
1403 write_real (dtp, source + size / 2, kind);
1405 write_char (dtp, ')');
1409 /* Write the separator between items. */
1411 static void
1412 write_separator (st_parameter_dt *dtp)
1414 char *p;
1416 p = write_block (dtp, options.separator_len);
1417 if (p == NULL)
1418 return;
1420 memcpy (p, options.separator, options.separator_len);
1424 /* Write an item with list formatting.
1425 TODO: handle skipping to the next record correctly, particularly
1426 with strings. */
1428 static void
1429 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1430 size_t size)
1432 if (dtp->u.p.current_unit == NULL)
1433 return;
1435 if (dtp->u.p.first_item)
1437 dtp->u.p.first_item = 0;
1438 write_char (dtp, ' ');
1440 else
1442 if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1443 dtp->u.p.current_unit->flags.delim != DELIM_NONE)
1444 write_separator (dtp);
1447 switch (type)
1449 case BT_INTEGER:
1450 write_integer (dtp, p, kind);
1451 break;
1452 case BT_LOGICAL:
1453 write_logical (dtp, p, kind);
1454 break;
1455 case BT_CHARACTER:
1456 write_character (dtp, p, kind);
1457 break;
1458 case BT_REAL:
1459 write_real (dtp, p, kind);
1460 break;
1461 case BT_COMPLEX:
1462 write_complex (dtp, p, kind, size);
1463 break;
1464 default:
1465 internal_error (&dtp->common, "list_formatted_write(): Bad type");
1468 dtp->u.p.char_flag = (type == BT_CHARACTER);
1472 void
1473 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1474 size_t size, size_t nelems)
1476 size_t elem;
1477 char *tmp;
1479 tmp = (char *) p;
1481 /* Big loop over all the elements. */
1482 for (elem = 0; elem < nelems; elem++)
1484 dtp->u.p.item_count++;
1485 list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
1489 /* NAMELIST OUTPUT
1491 nml_write_obj writes a namelist object to the output stream. It is called
1492 recursively for derived type components:
1493 obj = is the namelist_info for the current object.
1494 offset = the offset relative to the address held by the object for
1495 derived type arrays.
1496 base = is the namelist_info of the derived type, when obj is a
1497 component.
1498 base_name = the full name for a derived type, including qualifiers
1499 if any.
1500 The returned value is a pointer to the object beyond the last one
1501 accessed, including nested derived types. Notice that the namelist is
1502 a linear linked list of objects, including derived types and their
1503 components. A tree, of sorts, is implied by the compound names of
1504 the derived type components and this is how this function recurses through
1505 the list. */
1507 /* A generous estimate of the number of characters needed to print
1508 repeat counts and indices, including commas, asterices and brackets. */
1510 #define NML_DIGITS 20
1512 static namelist_info *
1513 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1514 namelist_info * base, char * base_name)
1516 int rep_ctr;
1517 int num;
1518 int nml_carry;
1519 index_type len;
1520 index_type obj_size;
1521 index_type nelem;
1522 index_type dim_i;
1523 index_type clen;
1524 index_type elem_ctr;
1525 index_type obj_name_len;
1526 void * p ;
1527 char cup;
1528 char * obj_name;
1529 char * ext_name;
1530 char rep_buff[NML_DIGITS];
1531 namelist_info * cmp;
1532 namelist_info * retval = obj->next;
1534 /* Write namelist variable names in upper case. If a derived type,
1535 nothing is output. If a component, base and base_name are set. */
1537 if (obj->type != GFC_DTYPE_DERIVED)
1539 #ifdef HAVE_CRLF
1540 write_character (dtp, "\r\n ", 3);
1541 #else
1542 write_character (dtp, "\n ", 2);
1543 #endif
1544 len = 0;
1545 if (base)
1547 len =strlen (base->var_name);
1548 for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1550 cup = toupper (base_name[dim_i]);
1551 write_character (dtp, &cup, 1);
1554 for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1556 cup = toupper (obj->var_name[dim_i]);
1557 write_character (dtp, &cup, 1);
1559 write_character (dtp, "=", 1);
1562 /* Counts the number of data output on a line, including names. */
1564 num = 1;
1566 len = obj->len;
1568 switch (obj->type)
1571 case GFC_DTYPE_REAL:
1572 obj_size = size_from_real_kind (len);
1573 break;
1575 case GFC_DTYPE_COMPLEX:
1576 obj_size = size_from_complex_kind (len);
1577 break;
1579 case GFC_DTYPE_CHARACTER:
1580 obj_size = obj->string_length;
1581 break;
1583 default:
1584 obj_size = len;
1587 if (obj->var_rank)
1588 obj_size = obj->size;
1590 /* Set the index vector and count the number of elements. */
1592 nelem = 1;
1593 for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1595 obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1596 nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1599 /* Main loop to output the data held in the object. */
1601 rep_ctr = 1;
1602 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1605 /* Build the pointer to the data value. The offset is passed by
1606 recursive calls to this function for arrays of derived types.
1607 Is NULL otherwise. */
1609 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1610 p += offset;
1612 /* Check for repeat counts of intrinsic types. */
1614 if ((elem_ctr < (nelem - 1)) &&
1615 (obj->type != GFC_DTYPE_DERIVED) &&
1616 !memcmp (p, (void*)(p + obj_size ), obj_size ))
1618 rep_ctr++;
1621 /* Execute a repeated output. Note the flag no_leading_blank that
1622 is used in the functions used to output the intrinsic types. */
1624 else
1626 if (rep_ctr > 1)
1628 st_sprintf(rep_buff, " %d*", rep_ctr);
1629 write_character (dtp, rep_buff, strlen (rep_buff));
1630 dtp->u.p.no_leading_blank = 1;
1632 num++;
1634 /* Output the data, if an intrinsic type, or recurse into this
1635 routine to treat derived types. */
1637 switch (obj->type)
1640 case GFC_DTYPE_INTEGER:
1641 write_integer (dtp, p, len);
1642 break;
1644 case GFC_DTYPE_LOGICAL:
1645 write_logical (dtp, p, len);
1646 break;
1648 case GFC_DTYPE_CHARACTER:
1649 if (dtp->u.p.nml_delim)
1650 write_character (dtp, &dtp->u.p.nml_delim, 1);
1651 write_character (dtp, p, obj->string_length);
1652 if (dtp->u.p.nml_delim)
1653 write_character (dtp, &dtp->u.p.nml_delim, 1);
1654 break;
1656 case GFC_DTYPE_REAL:
1657 write_real (dtp, p, len);
1658 break;
1660 case GFC_DTYPE_COMPLEX:
1661 dtp->u.p.no_leading_blank = 0;
1662 num++;
1663 write_complex (dtp, p, len, obj_size);
1664 break;
1666 case GFC_DTYPE_DERIVED:
1668 /* To treat a derived type, we need to build two strings:
1669 ext_name = the name, including qualifiers that prepends
1670 component names in the output - passed to
1671 nml_write_obj.
1672 obj_name = the derived type name with no qualifiers but %
1673 appended. This is used to identify the
1674 components. */
1676 /* First ext_name => get length of all possible components */
1678 ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
1679 + (base ? strlen (base->var_name) : 0)
1680 + strlen (obj->var_name)
1681 + obj->var_rank * NML_DIGITS
1682 + 1);
1684 strcpy(ext_name, base_name ? base_name : "");
1685 clen = base ? strlen (base->var_name) : 0;
1686 strcat (ext_name, obj->var_name + clen);
1688 /* Append the qualifier. */
1690 for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1692 strcat (ext_name, dim_i ? "" : "(");
1693 clen = strlen (ext_name);
1694 st_sprintf (ext_name + clen, "%d", (int) obj->ls[dim_i].idx);
1695 strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
1698 /* Now obj_name. */
1700 obj_name_len = strlen (obj->var_name) + 1;
1701 obj_name = get_mem (obj_name_len+1);
1702 strcpy (obj_name, obj->var_name);
1703 strcat (obj_name, "%");
1705 /* Now loop over the components. Update the component pointer
1706 with the return value from nml_write_obj => this loop jumps
1707 past nested derived types. */
1709 for (cmp = obj->next;
1710 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1711 cmp = retval)
1713 retval = nml_write_obj (dtp, cmp,
1714 (index_type)(p - obj->mem_pos),
1715 obj, ext_name);
1718 free_mem (obj_name);
1719 free_mem (ext_name);
1720 goto obj_loop;
1722 default:
1723 internal_error (&dtp->common, "Bad type for namelist write");
1726 /* Reset the leading blank suppression, write a comma and, if 5
1727 values have been output, write a newline and advance to column
1728 2. Reset the repeat counter. */
1730 dtp->u.p.no_leading_blank = 0;
1731 write_character (dtp, ",", 1);
1732 if (num > 5)
1734 num = 0;
1735 #ifdef HAVE_CRLF
1736 write_character (dtp, "\r\n ", 3);
1737 #else
1738 write_character (dtp, "\n ", 2);
1739 #endif
1741 rep_ctr = 1;
1744 /* Cycle through and increment the index vector. */
1746 obj_loop:
1748 nml_carry = 1;
1749 for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1751 obj->ls[dim_i].idx += nml_carry ;
1752 nml_carry = 0;
1753 if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound)
1755 obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1756 nml_carry = 1;
1761 /* Return a pointer beyond the furthest object accessed. */
1763 return retval;
1766 /* This is the entry function for namelist writes. It outputs the name
1767 of the namelist and iterates through the namelist by calls to
1768 nml_write_obj. The call below has dummys in the arguments used in
1769 the treatment of derived types. */
1771 void
1772 namelist_write (st_parameter_dt *dtp)
1774 namelist_info * t1, *t2, *dummy = NULL;
1775 index_type i;
1776 index_type dummy_offset = 0;
1777 char c;
1778 char * dummy_name = NULL;
1779 unit_delim tmp_delim;
1781 /* Set the delimiter for namelist output. */
1783 tmp_delim = dtp->u.p.current_unit->flags.delim;
1784 dtp->u.p.current_unit->flags.delim = DELIM_NONE;
1785 switch (tmp_delim)
1787 case (DELIM_QUOTE):
1788 dtp->u.p.nml_delim = '"';
1789 break;
1791 case (DELIM_APOSTROPHE):
1792 dtp->u.p.nml_delim = '\'';
1793 break;
1795 default:
1796 dtp->u.p.nml_delim = '\0';
1797 break;
1800 write_character (dtp, "&", 1);
1802 /* Write namelist name in upper case - f95 std. */
1804 for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1806 c = toupper (dtp->namelist_name[i]);
1807 write_character (dtp, &c ,1);
1810 if (dtp->u.p.ionml != NULL)
1812 t1 = dtp->u.p.ionml;
1813 while (t1 != NULL)
1815 t2 = t1;
1816 t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1819 #ifdef HAVE_CRLF
1820 write_character (dtp, " /\r\n", 5);
1821 #else
1822 write_character (dtp, " /\n", 4);
1823 #endif
1825 /* Recover the original delimiter. */
1827 dtp->u.p.current_unit->flags.delim = tmp_delim;
1830 #undef NML_DIGITS