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)
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, 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA. */
37 #include "libgfortran.h"
40 #define star_fill(p, n) memset(p, '*', n)
44 { SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
48 static int no_leading_blank = 0 ;
51 write_a (fnode * f, const char *source, int len)
56 wlen = f->u.string.length < 0 ? len : f->u.string.length;
58 p = write_block (wlen);
63 memcpy (p, source, wlen);
66 memset (p, ' ', wlen - len);
67 memcpy (p + wlen - len, source, len);
71 static GFC_INTEGER_LARGEST
72 extract_int (const void *p, int len)
74 GFC_INTEGER_LARGEST i = 0;
82 i = *((const GFC_INTEGER_1 *) p);
85 i = *((const GFC_INTEGER_2 *) p);
88 i = *((const GFC_INTEGER_4 *) p);
91 i = *((const GFC_INTEGER_8 *) p);
93 #ifdef HAVE_GFC_INTEGER_16
95 i = *((const GFC_INTEGER_16 *) p);
99 internal_error ("bad integer kind");
105 static GFC_UINTEGER_LARGEST
106 extract_uint (const void *p, int len)
108 GFC_UINTEGER_LARGEST i = 0;
116 i = (GFC_UINTEGER_1) *((const GFC_INTEGER_1 *) p);
119 i = (GFC_UINTEGER_2) *((const GFC_INTEGER_2 *) p);
122 i = (GFC_UINTEGER_4) *((const GFC_INTEGER_4 *) p);
125 i = (GFC_UINTEGER_8) *((const GFC_INTEGER_8 *) p);
127 #ifdef HAVE_GFC_INTEGER_16
129 i = (GFC_UINTEGER_16) *((const GFC_INTEGER_16 *) p);
133 internal_error ("bad integer kind");
139 static GFC_REAL_LARGEST
140 extract_real (const void *p, int len)
142 GFC_REAL_LARGEST i = 0;
146 i = *((const GFC_REAL_4 *) p);
149 i = *((const GFC_REAL_8 *) p);
151 #ifdef HAVE_GFC_REAL_10
153 i = *((const GFC_REAL_10 *) p);
156 #ifdef HAVE_GFC_REAL_16
158 i = *((const GFC_REAL_16 *) p);
162 internal_error ("bad real kind");
168 /* Given a flag that indicate if a value is negative or not, return a
169 sign_t that gives the sign that we need to produce. */
172 calculate_sign (int negative_flag)
174 sign_t s = SIGN_NONE;
179 switch (g.sign_status)
188 s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
196 /* Returns the value of 10**d. */
198 static GFC_REAL_LARGEST
199 calculate_exp (int d)
202 GFC_REAL_LARGEST r = 1.0;
204 for (i = 0; i< (d >= 0 ? d : -d); i++)
207 r = (d >= 0) ? r : 1.0 / r;
213 /* Generate corresponding I/O format for FMT_G output.
214 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
215 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
217 Data Magnitude Equivalent Conversion
218 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
219 m = 0 F(w-n).(d-1), n' '
220 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
221 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
222 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
223 ................ ..........
224 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
225 m >= 10**d-0.5 Ew.d[Ee]
227 notes: for Gw.d , n' ' means 4 blanks
228 for Gw.dEe, n' ' means e+2 blanks */
231 calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank)
237 GFC_REAL_LARGEST m, exp_d;
241 newf = get_mem (sizeof (fnode));
243 /* Absolute value. */
244 m = (value > 0.0) ? value : -value;
246 /* In case of the two data magnitude ranges,
247 generate E editing, Ew.d[Ee]. */
248 exp_d = calculate_exp (d);
249 if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ))
251 newf->format = FMT_E;
259 /* Use binary search to find the data magnitude range. */
268 GFC_REAL_LARGEST temp;
269 mid = (low + high) / 2;
271 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
272 temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
277 if (ubound == lbound + 1)
284 if (ubound == lbound + 1)
295 /* Pad with blanks where the exponent would be. */
301 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
302 newf->format = FMT_F;
303 newf->u.real.w = f->u.real.w - *num_blank;
307 newf->u.real.d = d - 1;
309 newf->u.real.d = - (mid - d - 1);
311 /* For F editing, the scale factor is ignored. */
317 /* Output a real number according to its format which is FMT_G free. */
320 output_float (fnode *f, GFC_REAL_LARGEST value)
322 /* This must be large enough to accurately hold any value. */
333 /* Number of digits before the decimal point. */
335 /* Number of zeros after the decimal point. */
337 /* Number of digits after the decimal point. */
339 /* Number of zeros after the decimal point, whatever the precision. */
354 /* We should always know the field width and precision. */
356 internal_error ("Unspecified precision");
358 /* Use sprintf to print the number in the format +D.DDDDe+ddd
359 For an N digit exponent, this gives us (32-6)-N digits after the
360 decimal point, plus another one before the decimal point. */
361 sign = calculate_sign (value < 0.0);
365 /* Printf always prints at least two exponent digits. */
370 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
371 abslog = fabs((double) log10l(value));
373 abslog = fabs(log10(value));
378 edigits = 1 + (int) log10(abslog);
381 if (ft == FMT_F || ft == FMT_EN
382 || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
384 /* Always convert at full precision to avoid double rounding. */
385 ndigits = 27 - edigits;
389 /* We know the number of digits, so can let printf do the rounding
395 if (ndigits > 27 - edigits)
396 ndigits = 27 - edigits;
399 /* # The result will always contain a decimal point, even if no
402 * - The converted value is to be left adjusted on the field boundary
404 * + A sign (+ or -) always be placed before a number
406 * 31 minimum field width
408 * * (ndigits-1) is used as the precision
410 * e format: [-]d.ddde±dd where there is one digit before the
411 * decimal-point character and the number of digits after it is
412 * equal to the precision. The exponent always contains at least two
413 * digits; if the value is zero, the exponent is 00.
415 sprintf (buffer, "%+-#31.*" GFC_REAL_LARGEST_FORMAT "e",
418 /* Check the resulting string has punctuation in the correct places. */
419 if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
420 internal_error ("printf is broken");
422 /* Read the exponent back in. */
423 e = atoi (&buffer[ndigits + 3]) + 1;
425 /* Make sure zero comes out as 0.0e0. */
429 /* Normalize the fractional component. */
430 buffer[2] = buffer[1];
433 /* Figure out where to place the decimal point. */
437 nbefore = e + g.scale_factor;
470 nafter = (d - i) + 1;
486 /* The exponent must be a multiple of three, with 1-3 digits before
487 the decimal point. */
496 nbefore = 3 - nbefore;
515 /* Should never happen. */
516 internal_error ("Unexpected format token");
519 /* Round the value. */
520 if (nbefore + nafter == 0)
523 if (nzero_real == d && digits[0] >= '5')
525 /* We rounded to zero but shouldn't have */
532 else if (nbefore + nafter < ndigits)
534 ndigits = nbefore + nafter;
536 if (digits[i] >= '5')
538 /* Propagate the carry. */
539 for (i--; i >= 0; i--)
541 if (digits[i] != '9')
551 /* The carry overflowed. Fortunately we have some spare space
552 at the start of the buffer. We may discard some digits, but
553 this is ok because we already know they are zero. */
566 else if (ft == FMT_EN)
581 /* Calculate the format of the exponent field. */
585 for (i = abs (e); i >= 10; i /= 10)
590 /* Width not specified. Must be no more than 3 digits. */
591 if (e > 999 || e < -999)
596 if (e > 99 || e < -99)
602 /* Exponent width specified, check it is wide enough. */
603 if (edigits > f->u.real.e)
606 edigits = f->u.real.e + 2;
612 /* Pick a field size if none was specified. */
614 w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
616 /* Create the ouput buffer. */
617 out = write_block (w);
621 /* Zero values always output as positive, even if the value was negative
623 for (i = 0; i < ndigits; i++)
625 if (digits[i] != '0')
629 sign = calculate_sign (0);
631 /* Work out how much padding is needed. */
632 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
633 if (sign != SIGN_NONE)
636 /* Check the value fits in the specified field width. */
637 if (nblanks < 0 || edigits == -1)
643 /* See if we have space for a zero before the decimal point. */
644 if (nbefore == 0 && nblanks > 0)
652 /* Padd to full field width. */
655 if ( ( nblanks > 0 ) && !no_leading_blank )
657 memset (out, ' ', nblanks);
661 /* Output the initial sign (if any). */
662 if (sign == SIGN_PLUS)
664 else if (sign == SIGN_MINUS)
667 /* Output an optional leading zero. */
671 /* Output the part before the decimal point, padding with zeros. */
674 if (nbefore > ndigits)
679 memcpy (out, digits, i);
687 /* Output the decimal point. */
690 /* Output leading zeros after the decimal point. */
693 for (i = 0; i < nzero; i++)
697 /* Output digits after the decimal point, padding with zeros. */
700 if (nafter > ndigits)
705 memcpy (out, digits, i);
714 /* Output the exponent. */
723 snprintf (buffer, 32, "%+0*d", edigits, e);
725 sprintf (buffer, "%+0*d", edigits, e);
727 memcpy (out, buffer, edigits);
730 if ( no_leading_blank )
733 memset( out , ' ' , nblanks );
734 no_leading_blank = 0;
740 write_l (fnode * f, char *source, int len)
743 GFC_INTEGER_LARGEST n;
745 p = write_block (f->u.w);
749 memset (p, ' ', f->u.w - 1);
750 n = extract_int (source, len);
751 p[f->u.w - 1] = (n) ? 'T' : 'F';
754 /* Output a real number according to its format. */
757 write_float (fnode *f, const char *source, int len)
760 int nb =0, res, save_scale_factor;
764 n = extract_real (source, len);
766 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
768 /* TODO: there are some systems where isfinite is not able to work
769 with long double variables. We should detect this case and
770 provide our own version for isfinite. */
775 p = write_block (nb);
792 memcpy(p + nb - 8, "Infinity", 8);
794 memcpy(p + nb - 3, "Inf", 3);
795 if (nb < 8 && nb > 3)
801 memcpy(p + nb - 3, "NaN", 3);
806 if (f->format != FMT_G)
812 save_scale_factor = g.scale_factor;
813 f2 = calculate_G_format(f, n, &nb);
814 output_float (f2, n);
815 g.scale_factor = save_scale_factor;
821 p = write_block (nb);
829 write_int (fnode *f, const char *source, int len,
830 char *(*conv) (GFC_UINTEGER_LARGEST))
832 GFC_UINTEGER_LARGEST n = 0;
833 int w, m, digits, nzero, nblank;
839 n = extract_uint (source, len);
843 if (m == 0 && n == 0)
859 /* Select a width if none was specified. The idea here is to always
863 w = ((digits < m) ? m : digits);
873 /* See if things will work. */
875 nblank = w - (nzero + digits);
884 if (!no_leading_blank)
886 memset (p, ' ', nblank);
888 memset (p, '0', nzero);
890 memcpy (p, q, digits);
894 memset (p, '0', nzero);
896 memcpy (p, q, digits);
898 memset (p, ' ', nblank);
899 no_leading_blank = 0;
907 write_decimal (fnode *f, const char *source, int len,
908 char *(*conv) (GFC_INTEGER_LARGEST))
910 GFC_INTEGER_LARGEST n = 0;
911 int w, m, digits, nsign, nzero, nblank;
918 n = extract_int (source, len);
922 if (m == 0 && n == 0)
935 sign = calculate_sign (n < 0);
939 nsign = sign == SIGN_NONE ? 0 : 1;
944 /* Select a width if none was specified. The idea here is to always
948 w = ((digits < m) ? m : digits) + nsign;
958 /* See if things will work. */
960 nblank = w - (nsign + nzero + digits);
968 memset (p, ' ', nblank);
983 memset (p, '0', nzero);
986 memcpy (p, q, digits);
993 /* Convert unsigned octal to ascii. */
996 otoa (GFC_UINTEGER_LARGEST n)
1007 p = scratch + sizeof (SCRATCH_SIZE) - 1;
1021 /* Convert unsigned binary to ascii. */
1024 btoa (GFC_UINTEGER_LARGEST n)
1035 p = scratch + sizeof (SCRATCH_SIZE) - 1;
1040 *p-- = '0' + (n & 1);
1049 write_i (fnode * f, const char *p, int len)
1051 write_decimal (f, p, len, (void *) gfc_itoa);
1056 write_b (fnode * f, const char *p, int len)
1058 write_int (f, p, len, btoa);
1063 write_o (fnode * f, const char *p, int len)
1065 write_int (f, p, len, otoa);
1069 write_z (fnode * f, const char *p, int len)
1071 write_int (f, p, len, xtoa);
1076 write_d (fnode *f, const char *p, int len)
1078 write_float (f, p, len);
1083 write_e (fnode *f, const char *p, int len)
1085 write_float (f, p, len);
1090 write_f (fnode *f, const char *p, int len)
1092 write_float (f, p, len);
1097 write_en (fnode *f, const char *p, int len)
1099 write_float (f, p, len);
1104 write_es (fnode *f, const char *p, int len)
1106 write_float (f, p, len);
1110 /* Take care of the X/TR descriptor. */
1117 p = write_block (f->u.n);
1121 memset (p, ' ', f->u.n);
1125 /* List-directed writing. */
1128 /* Write a single character to the output. Returns nonzero if
1129 something goes wrong. */
1136 p = write_block (1);
1146 /* Write a list-directed logical value. */
1149 write_logical (const char *source, int length)
1151 write_char (extract_int (source, length) ? 'T' : 'F');
1155 /* Write a list-directed integer value. */
1158 write_integer (const char *source, int length)
1165 q = gfc_itoa (extract_int (source, length));
1190 digits = strlen (q);
1194 p = write_block (width) ;
1195 if (no_leading_blank)
1197 memcpy (p, q, digits);
1198 memset(p + digits ,' ', width - digits) ;
1202 memset(p ,' ', width - digits) ;
1203 memcpy (p + width - digits, q, digits);
1208 /* Write a list-directed string. We have to worry about delimiting
1209 the strings if the file has been opened in that mode. */
1212 write_character (const char *source, int length)
1217 switch (current_unit->flags.delim)
1219 case DELIM_APOSTROPHE:
1236 for (i = 0; i < length; i++)
1241 p = write_block (length + extra);
1246 memcpy (p, source, length);
1251 for (i = 0; i < length; i++)
1263 /* Output a real number with default format.
1264 This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8). */
1267 write_real (const char *source, int length)
1270 int org_scale = g.scale_factor;
1285 write_float (&f, source , length);
1286 g.scale_factor = org_scale;
1291 write_complex (const char *source, int len)
1293 if (write_char ('('))
1295 write_real (source, len);
1297 if (write_char (','))
1299 write_real (source + len, len);
1305 /* Write the separator between items. */
1308 write_separator (void)
1312 p = write_block (options.separator_len);
1316 memcpy (p, options.separator, options.separator_len);
1320 /* Write an item with list formatting.
1321 TODO: handle skipping to the next record correctly, particularly
1325 list_formatted_write (bt type, void *p, int len)
1327 static int char_flag;
1329 if (current_unit == NULL)
1340 if (type != BT_CHARACTER || !char_flag ||
1341 current_unit->flags.delim != DELIM_NONE)
1348 write_integer (p, len);
1351 write_logical (p, len);
1354 write_character (p, len);
1357 write_real (p, len);
1360 write_complex (p, len);
1363 internal_error ("list_formatted_write(): Bad type");
1366 char_flag = (type == BT_CHARACTER);
1371 nml_write_obj writes a namelist object to the output stream. It is called
1372 recursively for derived type components:
1373 obj = is the namelist_info for the current object.
1374 offset = the offset relative to the address held by the object for
1375 derived type arrays.
1376 base = is the namelist_info of the derived type, when obj is a
1378 base_name = the full name for a derived type, including qualifiers
1380 The returned value is a pointer to the object beyond the last one
1381 accessed, including nested derived types. Notice that the namelist is
1382 a linear linked list of objects, including derived types and their
1383 components. A tree, of sorts, is implied by the compound names of
1384 the derived type components and this is how this function recurses through
1387 /* A generous estimate of the number of characters needed to print
1388 repeat counts and indices, including commas, asterices and brackets. */
1390 #define NML_DIGITS 20
1392 /* Stores the delimiter to be used for character objects. */
1394 static const char * nml_delim;
1396 static namelist_info *
1397 nml_write_obj (namelist_info * obj, index_type offset,
1398 namelist_info * base, char * base_name)
1404 index_type obj_size;
1408 index_type elem_ctr;
1409 index_type obj_name_len;
1414 char rep_buff[NML_DIGITS];
1415 namelist_info * cmp;
1416 namelist_info * retval = obj->next;
1418 /* Write namelist variable names in upper case. If a derived type,
1419 nothing is output. If a component, base and base_name are set. */
1421 if (obj->type != GFC_DTYPE_DERIVED)
1423 write_character ("\n ", 2);
1427 len =strlen (base->var_name);
1428 for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
1430 cup = toupper (base_name[dim_i]);
1431 write_character (&cup, 1);
1434 for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
1436 cup = toupper (obj->var_name[dim_i]);
1437 write_character (&cup, 1);
1439 write_character ("=", 1);
1442 /* Counts the number of data output on a line, including names. */
1448 if (obj->type == GFC_DTYPE_COMPLEX)
1450 if (obj->type == GFC_DTYPE_CHARACTER)
1451 obj_size = obj->string_length;
1453 obj_size = obj->size;
1455 /* Set the index vector and count the number of elements. */
1458 for (dim_i=0; dim_i < obj->var_rank; dim_i++)
1460 obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1461 nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
1464 /* Main loop to output the data held in the object. */
1467 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
1470 /* Build the pointer to the data value. The offset is passed by
1471 recursive calls to this function for arrays of derived types.
1472 Is NULL otherwise. */
1474 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
1477 /* Check for repeat counts of intrinsic types. */
1479 if ((elem_ctr < (nelem - 1)) &&
1480 (obj->type != GFC_DTYPE_DERIVED) &&
1481 !memcmp (p, (void*)(p + obj_size ), obj_size ))
1486 /* Execute a repeated output. Note the flag no_leading_blank that
1487 is used in the functions used to output the intrinsic types. */
1493 st_sprintf(rep_buff, " %d*", rep_ctr);
1494 write_character (rep_buff, strlen (rep_buff));
1495 no_leading_blank = 1;
1499 /* Output the data, if an intrinsic type, or recurse into this
1500 routine to treat derived types. */
1505 case GFC_DTYPE_INTEGER:
1506 write_integer (p, len);
1509 case GFC_DTYPE_LOGICAL:
1510 write_logical (p, len);
1513 case GFC_DTYPE_CHARACTER:
1515 write_character (nml_delim, 1);
1516 write_character (p, obj->string_length);
1518 write_character (nml_delim, 1);
1521 case GFC_DTYPE_REAL:
1522 write_real (p, len);
1525 case GFC_DTYPE_COMPLEX:
1526 no_leading_blank = 0;
1528 write_complex (p, len);
1531 case GFC_DTYPE_DERIVED:
1533 /* To treat a derived type, we need to build two strings:
1534 ext_name = the name, including qualifiers that prepends
1535 component names in the output - passed to
1537 obj_name = the derived type name with no qualifiers but %
1538 appended. This is used to identify the
1541 /* First ext_name => get length of all possible components */
1543 ext_name = (char*)get_mem ( (base_name ? strlen (base_name) : 0)
1544 + (base ? strlen (base->var_name) : 0)
1545 + strlen (obj->var_name)
1546 + obj->var_rank * NML_DIGITS
1549 strcpy(ext_name, base_name ? base_name : "");
1550 clen = base ? strlen (base->var_name) : 0;
1551 strcat (ext_name, obj->var_name + clen);
1553 /* Append the qualifier. */
1555 for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
1557 strcat (ext_name, dim_i ? "" : "(");
1558 clen = strlen (ext_name);
1559 st_sprintf (ext_name + clen, "%d", (int) obj->ls[dim_i].idx);
1560 strcat (ext_name, (dim_i == obj->var_rank - 1) ? ")" : ",");
1565 obj_name_len = strlen (obj->var_name) + 1;
1566 obj_name = get_mem (obj_name_len+1);
1567 strcpy (obj_name, obj->var_name);
1568 strcat (obj_name, "%");
1570 /* Now loop over the components. Update the component pointer
1571 with the return value from nml_write_obj => this loop jumps
1572 past nested derived types. */
1574 for (cmp = obj->next;
1575 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
1578 retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
1582 free_mem (obj_name);
1583 free_mem (ext_name);
1587 internal_error ("Bad type for namelist write");
1590 /* Reset the leading blank suppression, write a comma and, if 5
1591 values have been output, write a newline and advance to column
1592 2. Reset the repeat counter. */
1594 no_leading_blank = 0;
1595 write_character (",", 1);
1599 write_character ("\n ", 2);
1604 /* Cycle through and increment the index vector. */
1609 for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
1611 obj->ls[dim_i].idx += nml_carry ;
1613 if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound)
1615 obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
1621 /* Return a pointer beyond the furthest object accessed. */
1626 /* This is the entry function for namelist writes. It outputs the name
1627 of the namelist and iterates through the namelist by calls to
1628 nml_write_obj. The call below has dummys in the arguments used in
1629 the treatment of derived types. */
1632 namelist_write (void)
1634 namelist_info * t1, *t2, *dummy = NULL;
1636 index_type dummy_offset = 0;
1638 char * dummy_name = NULL;
1639 unit_delim tmp_delim;
1641 /* Set the delimiter for namelist output. */
1643 tmp_delim = current_unit->flags.delim;
1644 current_unit->flags.delim = DELIM_NONE;
1651 case (DELIM_APOSTROPHE):
1659 write_character ("&",1);
1661 /* Write namelist name in upper case - f95 std. */
1663 for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
1665 c = toupper (ioparm.namelist_name[i]);
1666 write_character (&c ,1);
1675 t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
1678 write_character (" /\n", 4);
1680 /* Recover the original delimiter. */
1682 current_unit->flags.delim = tmp_delim;