1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist output contributed 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)
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
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. */
37 #include "libgfortran.h"
40 #define star_fill(p, n) memset(p, '*', n)
44 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
49 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
54 wlen = f->u.string.length < 0 ? len : f->u.string.length;
57 /* If this is formatted STREAM IO convert any embedded line feed characters
58 to CR_LF on systems that use that sequence for newlines. See F2003
59 Standard sections 10.6.3 and 9.9 for further information. */
60 if (is_stream_io (dtp))
62 const char crlf[] = "\r\n";
66 /* Write out any padding if needed. */
69 p = write_block (dtp, wlen - len);
72 memset (p, ' ', wlen - len);
75 /* Scan the source string looking for '\n' and convert it if found. */
76 for (i = 0; i < wlen; i++)
78 if (source[i] == '\n')
80 /* Write out the previously scanned characters in the string. */
83 p = write_block (dtp, bytes);
86 memcpy (p, &source[q], bytes);
91 /* Write out the CR_LF sequence. */
93 p = write_block (dtp, 2);
102 /* Write out any remaining bytes if no LF was found. */
105 p = write_block (dtp, bytes);
108 memcpy (p, &source[q], bytes);
114 p = write_block (dtp, wlen);
119 memcpy (p, source, wlen);
122 memset (p, ' ', wlen - len);
123 memcpy (p + wlen - len, source, len);
130 static GFC_INTEGER_LARGEST
131 extract_int (const void *p, int len)
133 GFC_INTEGER_LARGEST i = 0;
143 memcpy ((void *) &tmp, p, len);
150 memcpy ((void *) &tmp, p, len);
157 memcpy ((void *) &tmp, p, len);
164 memcpy ((void *) &tmp, p, len);
168 #ifdef HAVE_GFC_INTEGER_16
172 memcpy ((void *) &tmp, p, len);
178 internal_error (NULL, "bad integer kind");
184 static GFC_UINTEGER_LARGEST
185 extract_uint (const void *p, int len)
187 GFC_UINTEGER_LARGEST i = 0;
197 memcpy ((void *) &tmp, p, len);
198 i = (GFC_UINTEGER_1) tmp;
204 memcpy ((void *) &tmp, p, len);
205 i = (GFC_UINTEGER_2) tmp;
211 memcpy ((void *) &tmp, p, len);
212 i = (GFC_UINTEGER_4) tmp;
218 memcpy ((void *) &tmp, p, len);
219 i = (GFC_UINTEGER_8) tmp;
222 #ifdef HAVE_GFC_INTEGER_16
226 memcpy ((void *) &tmp, p, len);
227 i = (GFC_UINTEGER_16) tmp;
232 internal_error (NULL, "bad integer kind");
238 static GFC_REAL_LARGEST
239 extract_real (const void *p, int len)
241 GFC_REAL_LARGEST i = 0;
247 memcpy ((void *) &tmp, p, len);
254 memcpy ((void *) &tmp, p, len);
258 #ifdef HAVE_GFC_REAL_10
262 memcpy ((void *) &tmp, p, len);
267 #ifdef HAVE_GFC_REAL_16
271 memcpy ((void *) &tmp, p, len);
277 internal_error (NULL, "bad real kind");
283 /* Given a flag that indicate if a value is negative or not, return a
284 sign_t that gives the sign that we need to produce. */
287 calculate_sign (st_parameter_dt *dtp, int negative_flag)
289 sign_t s = SIGN_NONE;
294 switch (dtp->u.p.sign_status)
303 s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
311 /* Returns the value of 10**d. */
313 static GFC_REAL_LARGEST
314 calculate_exp (int d)
317 GFC_REAL_LARGEST r = 1.0;
319 for (i = 0; i< (d >= 0 ? d : -d); i++)
322 r = (d >= 0) ? r : 1.0 / r;
328 /* Generate corresponding I/O format for FMT_G output.
329 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
330 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
332 Data Magnitude Equivalent Conversion
333 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
334 m = 0 F(w-n).(d-1), n' '
335 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
336 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
337 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
338 ................ ..........
339 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
340 m >= 10**d-0.5 Ew.d[Ee]
342 notes: for Gw.d , n' ' means 4 blanks
343 for Gw.dEe, n' ' means e+2 blanks */
346 calculate_G_format (st_parameter_dt *dtp, const fnode *f,
347 GFC_REAL_LARGEST value, int *num_blank)
353 GFC_REAL_LARGEST m, exp_d;
357 newf = get_mem (sizeof (fnode));
359 /* Absolute value. */
360 m = (value > 0.0) ? value : -value;
362 /* In case of the two data magnitude ranges,
363 generate E editing, Ew.d[Ee]. */
364 exp_d = calculate_exp (d);
365 if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||
366 ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))
368 newf->format = FMT_E;
376 /* Use binary search to find the data magnitude range. */
385 GFC_REAL_LARGEST temp;
386 mid = (low + high) / 2;
388 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
389 temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
394 if (ubound == lbound + 1)
401 if (ubound == lbound + 1)
412 /* Pad with blanks where the exponent would be. */
418 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
419 newf->format = FMT_F;
420 newf->u.real.w = f->u.real.w - *num_blank;
424 newf->u.real.d = d - 1;
426 newf->u.real.d = - (mid - d - 1);
428 /* For F editing, the scale factor is ignored. */
429 dtp->u.p.scale_factor = 0;
434 /* Output a real number according to its format which is FMT_G free. */
437 output_float (st_parameter_dt *dtp, const fnode *f, GFC_REAL_LARGEST value)
439 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
440 # define MIN_FIELD_WIDTH 46
442 # define MIN_FIELD_WIDTH 31
444 #define STR(x) STR1(x)
446 /* This must be large enough to accurately hold any value. */
447 char buffer[MIN_FIELD_WIDTH+1];
457 /* Number of digits before the decimal point. */
459 /* Number of zeros after the decimal point. */
461 /* Number of digits after the decimal point. */
463 /* Number of zeros after the decimal point, whatever the precision. */
478 /* We should always know the field width and precision. */
480 internal_error (&dtp->common, "Unspecified precision");
482 /* Use sprintf to print the number in the format +D.DDDDe+ddd
483 For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits
484 after the decimal point, plus another one before the decimal point. */
485 sign = calculate_sign (dtp, value < 0.0);
486 sign_bit = signbit (value);
490 /* Special case when format specifies no digits after the decimal point. */
491 if (d == 0 && ft == FMT_F)
495 else if (value < 1.0)
499 /* printf pads blanks for us on the exponent so we just need it big enough
500 to handle the largest number of exponent digits expected. */
503 if (ft == FMT_F || ft == FMT_EN
504 || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
506 /* Always convert at full precision to avoid double rounding. */
507 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
511 /* We know the number of digits, so can let printf do the rounding
517 if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
518 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
521 /* # The result will always contain a decimal point, even if no
524 * - The converted value is to be left adjusted on the field boundary
526 * + A sign (+ or -) always be placed before a number
528 * MIN_FIELD_WIDTH minimum field width
530 * * (ndigits-1) is used as the precision
532 * e format: [-]d.ddde±dd where there is one digit before the
533 * decimal-point character and the number of digits after it is
534 * equal to the precision. The exponent always contains at least two
535 * digits; if the value is zero, the exponent is 00.
538 snprintf (buffer, sizeof (buffer), "%+-#" STR(MIN_FIELD_WIDTH) ".*"
539 GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value);
541 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*"
542 GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value);
545 /* Check the resulting string has punctuation in the correct places. */
546 if (d != 0 && (buffer[2] != '.' || buffer[ndigits + 2] != 'e'))
547 internal_error (&dtp->common, "printf is broken");
549 /* Read the exponent back in. */
550 e = atoi (&buffer[ndigits + 3]) + 1;
552 /* Make sure zero comes out as 0.0e0. */
556 if (compile_options.sign_zero == 1)
557 sign = calculate_sign (dtp, sign_bit);
559 sign = calculate_sign (dtp, 0);
562 /* Normalize the fractional component. */
563 buffer[2] = buffer[1];
566 /* Figure out where to place the decimal point. */
570 nbefore = e + dtp->u.p.scale_factor;
590 i = dtp->u.p.scale_factor;
603 nafter = (d - i) + 1;
619 /* The exponent must be a multiple of three, with 1-3 digits before
620 the decimal point. */
629 nbefore = 3 - nbefore;
648 /* Should never happen. */
649 internal_error (&dtp->common, "Unexpected format token");
652 /* Round the value. */
653 if (nbefore + nafter == 0)
656 if (nzero_real == d && digits[0] >= '5')
658 /* We rounded to zero but shouldn't have */
665 else if (nbefore + nafter < ndigits)
667 ndigits = nbefore + nafter;
669 if (digits[i] >= '5')
671 /* Propagate the carry. */
672 for (i--; i >= 0; i--)
674 if (digits[i] != '9')
684 /* The carry overflowed. Fortunately we have some spare space
685 at the start of the buffer. We may discard some digits, but
686 this is ok because we already know they are zero. */
699 else if (ft == FMT_EN)
714 /* Calculate the format of the exponent field. */
718 for (i = abs (e); i >= 10; i /= 10)
723 /* Width not specified. Must be no more than 3 digits. */
724 if (e > 999 || e < -999)
729 if (e > 99 || e < -99)
735 /* Exponent width specified, check it is wide enough. */
736 if (edigits > f->u.real.e)
739 edigits = f->u.real.e + 2;
745 /* Pick a field size if none was specified. */
747 w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
749 /* Create the ouput buffer. */
750 out = write_block (dtp, w);
754 /* Zero values always output as positive, even if the value was negative
756 for (i = 0; i < ndigits; i++)
758 if (digits[i] != '0')
763 /* The output is zero, so set the sign according to the sign bit unless
764 -fno-sign-zero was specified. */
765 if (compile_options.sign_zero == 1)
766 sign = calculate_sign (dtp, sign_bit);
768 sign = calculate_sign (dtp, 0);
771 /* Work out how much padding is needed. */
772 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
773 if (sign != SIGN_NONE)
776 /* Check the value fits in the specified field width. */
777 if (nblanks < 0 || edigits == -1)
783 /* See if we have space for a zero before the decimal point. */
784 if (nbefore == 0 && nblanks > 0)
792 /* Pad to full field width. */
794 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
796 memset (out, ' ', nblanks);
800 /* Output the initial sign (if any). */
801 if (sign == SIGN_PLUS)
803 else if (sign == SIGN_MINUS)
806 /* Output an optional leading zero. */
810 /* Output the part before the decimal point, padding with zeros. */
813 if (nbefore > ndigits)
816 memcpy (out, digits, i);
824 memcpy (out, digits, i);
831 /* Output the decimal point. */
834 /* Output leading zeros after the decimal point. */
837 for (i = 0; i < nzero; i++)
841 /* Output digits after the decimal point, padding with zeros. */
844 if (nafter > ndigits)
849 memcpy (out, digits, i);
858 /* Output the exponent. */
867 snprintf (buffer, sizeof (buffer), "%+0*d", edigits, e);
869 sprintf (buffer, "%+0*d", edigits, e);
871 memcpy (out, buffer, edigits);
874 if (dtp->u.p.no_leading_blank)
877 memset( out , ' ' , nblanks );
878 dtp->u.p.no_leading_blank = 0;
882 #undef MIN_FIELD_WIDTH
887 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
890 GFC_INTEGER_LARGEST n;
892 p = write_block (dtp, f->u.w);
896 memset (p, ' ', f->u.w - 1);
897 n = extract_int (source, len);
898 p[f->u.w - 1] = (n) ? 'T' : 'F';
901 /* Output a real number according to its format. */
904 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
907 int nb =0, res, save_scale_factor;
911 n = extract_real (source, len);
913 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
920 /* If the field width is zero, the processor must select a width
921 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
924 p = write_block (dtp, nb);
940 /* If the sign is negative and the width is 3, there is
941 insufficient room to output '-Inf', so output asterisks */
949 /* The negative sign is mandatory */
955 /* The positive sign is optional, but we output it for
962 /* We have room, so output 'Infinity' */
964 memcpy(p + nb - 8, "Infinity", 8);
967 /* For the case of width equals 8, there is not enough room
968 for the sign and 'Infinity' so we go with 'Inf' */
970 memcpy(p + nb - 3, "Inf", 3);
971 if (nb < 9 && nb > 3)
972 p[nb - 4] = fin; /* Put the sign in front of Inf */
974 p[nb - 9] = fin; /* Put the sign in front of Infinity */
977 memcpy(p + nb - 3, "NaN", 3);
982 if (f->format != FMT_G)
983 output_float (dtp, f, n);
986 save_scale_factor = dtp->u.p.scale_factor;
987 f2 = calculate_G_format (dtp, f, n, &nb);
988 output_float (dtp, f2, n);
989 dtp->u.p.scale_factor = save_scale_factor;
995 p = write_block (dtp, nb);
1005 write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
1006 const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
1008 GFC_UINTEGER_LARGEST n = 0;
1009 int w, m, digits, nzero, nblank;
1012 char itoa_buf[GFC_BTOA_BUF_SIZE];
1017 n = extract_uint (source, len);
1021 if (m == 0 && n == 0)
1026 p = write_block (dtp, w);
1034 q = conv (n, itoa_buf, sizeof (itoa_buf));
1035 digits = strlen (q);
1037 /* Select a width if none was specified. The idea here is to always
1041 w = ((digits < m) ? m : digits);
1043 p = write_block (dtp, w);
1051 /* See if things will work. */
1053 nblank = w - (nzero + digits);
1062 if (!dtp->u.p.no_leading_blank)
1064 memset (p, ' ', nblank);
1066 memset (p, '0', nzero);
1068 memcpy (p, q, digits);
1072 memset (p, '0', nzero);
1074 memcpy (p, q, digits);
1076 memset (p, ' ', nblank);
1077 dtp->u.p.no_leading_blank = 0;
1085 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
1087 const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
1089 GFC_INTEGER_LARGEST n = 0;
1090 int w, m, digits, nsign, nzero, nblank;
1094 char itoa_buf[GFC_BTOA_BUF_SIZE];
1099 n = extract_int (source, len);
1103 if (m == 0 && n == 0)
1108 p = write_block (dtp, w);
1116 sign = calculate_sign (dtp, n < 0);
1120 nsign = sign == SIGN_NONE ? 0 : 1;
1121 q = conv (n, itoa_buf, sizeof (itoa_buf));
1123 digits = strlen (q);
1125 /* Select a width if none was specified. The idea here is to always
1129 w = ((digits < m) ? m : digits) + nsign;
1131 p = write_block (dtp, w);
1139 /* See if things will work. */
1141 nblank = w - (nsign + nzero + digits);
1149 memset (p, ' ', nblank);
1164 memset (p, '0', nzero);
1167 memcpy (p, q, digits);
1174 /* Convert unsigned octal to ascii. */
1177 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
1181 assert (len >= GFC_OTOA_BUF_SIZE);
1186 p = buffer + GFC_OTOA_BUF_SIZE - 1;
1191 *--p = '0' + (n & 7);
1199 /* Convert unsigned binary to ascii. */
1202 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
1206 assert (len >= GFC_BTOA_BUF_SIZE);
1211 p = buffer + GFC_BTOA_BUF_SIZE - 1;
1216 *--p = '0' + (n & 1);
1225 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1227 write_decimal (dtp, f, p, len, (void *) gfc_itoa);
1232 write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1234 write_int (dtp, f, p, len, btoa);
1239 write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1241 write_int (dtp, f, p, len, otoa);
1245 write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1247 write_int (dtp, f, p, len, xtoa);
1252 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1254 write_float (dtp, f, p, len);
1259 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1261 write_float (dtp, f, p, len);
1266 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1268 write_float (dtp, f, p, len);
1273 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1275 write_float (dtp, f, p, len);
1280 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
1282 write_float (dtp, f, p, len);
1286 /* Take care of the X/TR descriptor. */
1289 write_x (st_parameter_dt *dtp, int len, int nspaces)
1293 p = write_block (dtp, len);
1298 memset (&p[len - nspaces], ' ', nspaces);
1302 /* List-directed writing. */
1305 /* Write a single character to the output. Returns nonzero if
1306 something goes wrong. */
1309 write_char (st_parameter_dt *dtp, char c)
1313 p = write_block (dtp, 1);
1323 /* Write a list-directed logical value. */
1326 write_logical (st_parameter_dt *dtp, const char *source, int length)
1328 write_char (dtp, extract_int (source, length) ? 'T' : 'F');
1332 /* Write a list-directed integer value. */
1335 write_integer (st_parameter_dt *dtp, const char *source, int length)
1341 char itoa_buf[GFC_ITOA_BUF_SIZE];
1343 q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
1368 digits = strlen (q);
1372 p = write_block (dtp, width);
1375 if (dtp->u.p.no_leading_blank)
1377 memcpy (p, q, digits);
1378 memset (p + digits, ' ', width - digits);
1382 memset (p, ' ', width - digits);
1383 memcpy (p + width - digits, q, digits);
1388 /* Write a list-directed string. We have to worry about delimiting
1389 the strings if the file has been opened in that mode. */
1392 write_character (st_parameter_dt *dtp, const char *source, int length)
1397 switch (dtp->u.p.current_unit->flags.delim)
1399 case DELIM_APOSTROPHE:
1416 for (i = 0; i < length; i++)
1421 p = write_block (dtp, length + extra);
1426 memcpy (p, source, length);
1431 for (i = 0; i < length; i++)
1443 /* Output a real number with default format.
1444 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1445 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
1448 write_real (st_parameter_dt *dtp, const char *source, int length)
1451 int org_scale = dtp->u.p.scale_factor;
1453 dtp->u.p.scale_factor = 1;
1477 internal_error (&dtp->common, "bad real kind");
1480 write_float (dtp, &f, source , length);
1481 dtp->u.p.scale_factor = org_scale;
1486 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
1488 if (write_char (dtp, '('))
1490 write_real (dtp, source, kind);
1492 if (write_char (dtp, ','))
1494 write_real (dtp, source + size / 2, kind);
1496 write_char (dtp, ')');
1500 /* Write the separator between items. */
1503 write_separator (st_parameter_dt *dtp)
1507 p = write_block (dtp, options.separator_len);
1511 memcpy (p, options.separator, options.separator_len);
1515 /* Write an item with list formatting.
1516 TODO: handle skipping to the next record correctly, particularly
1520 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
1523 if (dtp->u.p.current_unit == NULL)
1526 if (dtp->u.p.first_item)
1528 dtp->u.p.first_item = 0;
1529 write_char (dtp, ' ');
1533 if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
1534 dtp->u.p.current_unit->flags.delim != DELIM_NONE)
1535 write_separator (dtp);
1541 write_integer (dtp, p, kind);
1544 write_logical (dtp, p, kind);
1547 write_character (dtp, p, kind);
1550 write_real (dtp, p, kind);
1553 write_complex (dtp, p, kind, size);
1556 internal_error (&dtp->common, "list_formatted_write(): Bad type");
1559 dtp->u.p.char_flag = (type == BT_CHARACTER);
1564 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1565 size_t size, size_t nelems)
1572 /* Big loop over all the elements. */
1573 for (elem = 0; elem < nelems; elem++)
1575 dtp->u.p.item_count++;
1576 list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
1582 nml_write_obj writes a namelist object to the output stream. It is called
1583 recursively for derived type components:
1584 obj = is the namelist_info for the current object.
1585 offset = the offset relative to the address held by the object for
1586 derived type arrays.
1587 base = is the namelist_info of the derived type, when obj is a
1589 base_name = the full name for a derived type, including qualifiers
1591 The returned value is a pointer to the object beyond the last one
1592 accessed, including nested derived types. Notice that the namelist is
1593 a linear linked list of objects, including derived types and their
1594 components. A tree, of sorts, is implied by the compound names of
1595 the derived type components and this is how this function recurses through
1598 /* A generous estimate of the number of characters needed to print
1599 repeat counts and indices, including commas, asterices and brackets. */
1601 #define NML_DIGITS 20
1603 static namelist_info *
1604 nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
1605 namelist_info * base, char * base_name)
1611 index_type obj_size;
1615 index_type elem_ctr;
1616 index_type obj_name_len;
1621 char rep_buff[NML_DIGITS];
1622 namelist_info * cmp;
1623 namelist_info * retval = obj->next;
1624 size_t base_name_len;
1625 size_t base_var_name_len;
1628 /* Write namelist variable names in upper case. If a derived type,
1629 nothing is output. If a component, base and base_name are set. */
1631 if (obj->type != GFC_DTYPE_DERIVED)
1634 write_character (dtp, "\r\n ", 3);
1636 write_character (dtp, "\n ", 2);
1641 len =strlen (base->var_name);
1642 for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1644 cup = toupper (base_name[dim_i]);
1645 write_character (dtp, &cup, 1);
1648 for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1650 cup = toupper (obj->var_name[dim_i]);
1651 write_character (dtp, &cup, 1);
1653 write_character (dtp, "=", 1);
1656 /* Counts the number of data output on a line, including names. */
1665 case GFC_DTYPE_REAL:
1666 obj_size = size_from_real_kind (len);
1669 case GFC_DTYPE_COMPLEX:
1670 obj_size = size_from_complex_kind (len);
1673 case GFC_DTYPE_CHARACTER:
1674 obj_size = obj->string_length;
1682 obj_size = obj->size;
1684 /* Set the index vector and count the number of elements. */
1687 for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1689 obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1690 nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1693 /* Main loop to output the data held in the object. */
1696 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1699 /* Build the pointer to the data value. The offset is passed by
1700 recursive calls to this function for arrays of derived types.
1701 Is NULL otherwise. */
1703 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1706 /* Check for repeat counts of intrinsic types. */
1708 if ((elem_ctr < (nelem - 1)) &&
1709 (obj->type != GFC_DTYPE_DERIVED) &&
1710 !memcmp (p, (void*)(p + obj_size ), obj_size ))
1715 /* Execute a repeated output. Note the flag no_leading_blank that
1716 is used in the functions used to output the intrinsic types. */
1722 sprintf(rep_buff, " %d*", rep_ctr);
1723 write_character (dtp, rep_buff, strlen (rep_buff));
1724 dtp->u.p.no_leading_blank = 1;
1728 /* Output the data, if an intrinsic type, or recurse into this
1729 routine to treat derived types. */
1734 case GFC_DTYPE_INTEGER:
1735 write_integer (dtp, p, len);
1738 case GFC_DTYPE_LOGICAL:
1739 write_logical (dtp, p, len);
1742 case GFC_DTYPE_CHARACTER:
1743 if (dtp->u.p.nml_delim)
1744 write_character (dtp, &dtp->u.p.nml_delim, 1);
1745 write_character (dtp, p, obj->string_length);
1746 if (dtp->u.p.nml_delim)
1747 write_character (dtp, &dtp->u.p.nml_delim, 1);
1750 case GFC_DTYPE_REAL:
1751 write_real (dtp, p, len);
1754 case GFC_DTYPE_COMPLEX:
1755 dtp->u.p.no_leading_blank = 0;
1757 write_complex (dtp, p, len, obj_size);
1760 case GFC_DTYPE_DERIVED:
1762 /* To treat a derived type, we need to build two strings:
1763 ext_name = the name, including qualifiers that prepends
1764 component names in the output - passed to
1766 obj_name = the derived type name with no qualifiers but %
1767 appended. This is used to identify the
1770 /* First ext_name => get length of all possible components */
1772 base_name_len = base_name ? strlen (base_name) : 0;
1773 base_var_name_len = base ? strlen (base->var_name) : 0;
1774 ext_name = (char*)get_mem ( base_name_len
1776 + strlen (obj->var_name)
1777 + obj->var_rank * NML_DIGITS
1780 memcpy (ext_name, base_name, base_name_len);
1781 clen = strlen (obj->var_name + base_var_name_len);
1782 memcpy (ext_name + base_name_len,
1783 obj->var_name + base_var_name_len, clen);
1785 /* Append the qualifier. */
1787 tot_len = base_name_len + clen;
1788 for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1792 ext_name[tot_len] = '(';
1795 sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
1796 tot_len += strlen (ext_name + tot_len);
1797 ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
1801 ext_name[tot_len] = '\0';
1805 obj_name_len = strlen (obj->var_name) + 1;
1806 obj_name = get_mem (obj_name_len+1);
1807 memcpy (obj_name, obj->var_name, obj_name_len-1);
1808 memcpy (obj_name + obj_name_len-1, "%", 2);
1810 /* Now loop over the components. Update the component pointer
1811 with the return value from nml_write_obj => this loop jumps
1812 past nested derived types. */
1814 for (cmp = obj->next;
1815 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1818 retval = nml_write_obj (dtp, cmp,
1819 (index_type)(p - obj->mem_pos),
1823 free_mem (obj_name);
1824 free_mem (ext_name);
1828 internal_error (&dtp->common, "Bad type for namelist write");
1831 /* Reset the leading blank suppression, write a comma and, if 5
1832 values have been output, write a newline and advance to column
1833 2. Reset the repeat counter. */
1835 dtp->u.p.no_leading_blank = 0;
1836 write_character (dtp, ",", 1);
1841 write_character (dtp, "\r\n ", 3);
1843 write_character (dtp, "\n ", 2);
1849 /* Cycle through and increment the index vector. */
1854 for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1856 obj->ls[dim_i].idx += nml_carry ;
1858 if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound)
1860 obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1866 /* Return a pointer beyond the furthest object accessed. */
1871 /* This is the entry function for namelist writes. It outputs the name
1872 of the namelist and iterates through the namelist by calls to
1873 nml_write_obj. The call below has dummys in the arguments used in
1874 the treatment of derived types. */
1877 namelist_write (st_parameter_dt *dtp)
1879 namelist_info * t1, *t2, *dummy = NULL;
1881 index_type dummy_offset = 0;
1883 char * dummy_name = NULL;
1884 unit_delim tmp_delim;
1886 /* Set the delimiter for namelist output. */
1888 tmp_delim = dtp->u.p.current_unit->flags.delim;
1889 dtp->u.p.current_unit->flags.delim = DELIM_NONE;
1893 dtp->u.p.nml_delim = '"';
1896 case (DELIM_APOSTROPHE):
1897 dtp->u.p.nml_delim = '\'';
1901 dtp->u.p.nml_delim = '\0';
1905 write_character (dtp, "&", 1);
1907 /* Write namelist name in upper case - f95 std. */
1909 for (i = 0 ;i < dtp->namelist_name_len ;i++ )
1911 c = toupper (dtp->namelist_name[i]);
1912 write_character (dtp, &c ,1);
1915 if (dtp->u.p.ionml != NULL)
1917 t1 = dtp->u.p.ionml;
1921 t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
1925 write_character (dtp, " /\r\n", 5);
1927 write_character (dtp, " /\n", 4);
1930 /* Recover the original delimiter. */
1932 dtp->u.p.current_unit->flags.delim = tmp_delim;