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_REAL_LARGEST
106 extract_real (const void *p
, int len
)
108 GFC_REAL_LARGEST i
= 0;
112 i
= *((const GFC_REAL_4
*) p
);
115 i
= *((const GFC_REAL_8
*) p
);
117 #ifdef HAVE_GFC_REAL_10
119 i
= *((const GFC_REAL_10
*) p
);
122 #ifdef HAVE_GFC_REAL_16
124 i
= *((const GFC_REAL_16
*) p
);
128 internal_error ("bad real kind");
134 /* Given a flag that indicate if a value is negative or not, return a
135 sign_t that gives the sign that we need to produce. */
138 calculate_sign (int negative_flag
)
140 sign_t s
= SIGN_NONE
;
145 switch (g
.sign_status
)
154 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
162 /* Returns the value of 10**d. */
164 static GFC_REAL_LARGEST
165 calculate_exp (int d
)
168 GFC_REAL_LARGEST r
= 1.0;
170 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
173 r
= (d
>= 0) ? r
: 1.0 / r
;
179 /* Generate corresponding I/O format for FMT_G output.
180 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
181 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
183 Data Magnitude Equivalent Conversion
184 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
185 m = 0 F(w-n).(d-1), n' '
186 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
187 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
188 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
189 ................ ..........
190 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
191 m >= 10**d-0.5 Ew.d[Ee]
193 notes: for Gw.d , n' ' means 4 blanks
194 for Gw.dEe, n' ' means e+2 blanks */
197 calculate_G_format (fnode
*f
, GFC_REAL_LARGEST value
, int *num_blank
)
203 GFC_REAL_LARGEST m
, exp_d
;
207 newf
= get_mem (sizeof (fnode
));
209 /* Absolute value. */
210 m
= (value
> 0.0) ? value
: -value
;
212 /* In case of the two data magnitude ranges,
213 generate E editing, Ew.d[Ee]. */
214 exp_d
= calculate_exp (d
);
215 if ((m
> 0.0 && m
< 0.1 - 0.05 / exp_d
) || (m
>= exp_d
- 0.5 ))
217 newf
->format
= FMT_E
;
225 /* Use binary search to find the data magnitude range. */
234 GFC_REAL_LARGEST temp
;
235 mid
= (low
+ high
) / 2;
237 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
238 temp
= 0.1 * calculate_exp (mid
) - 0.5 * calculate_exp (mid
- d
- 1);
243 if (ubound
== lbound
+ 1)
250 if (ubound
== lbound
+ 1)
261 /* Pad with blanks where the exponent would be. */
267 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
268 newf
->format
= FMT_F
;
269 newf
->u
.real
.w
= f
->u
.real
.w
- *num_blank
;
273 newf
->u
.real
.d
= d
- 1;
275 newf
->u
.real
.d
= - (mid
- d
- 1);
277 /* For F editing, the scale factor is ignored. */
283 /* Output a real number according to its format which is FMT_G free. */
286 output_float (fnode
*f
, GFC_REAL_LARGEST value
)
288 /* This must be large enough to accurately hold any value. */
299 /* Number of digits before the decimal point. */
301 /* Number of zeros after the decimal point. */
303 /* Number of digits after the decimal point. */
305 /* Number of zeros after the decimal point, whatever the precision. */
320 /* We should always know the field width and precision. */
322 internal_error ("Unspecified precision");
324 /* Use sprintf to print the number in the format +D.DDDDe+ddd
325 For an N digit exponent, this gives us (32-6)-N digits after the
326 decimal point, plus another one before the decimal point. */
327 sign
= calculate_sign (value
< 0.0);
331 /* Printf always prints at least two exponent digits. */
336 #if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16)
337 abslog
= fabs((double) log10l(value
));
339 abslog
= fabs(log10(value
));
344 edigits
= 1 + (int) log10(abslog
);
347 if (ft
== FMT_F
|| ft
== FMT_EN
348 || ((ft
== FMT_D
|| ft
== FMT_E
) && g
.scale_factor
!= 0))
350 /* Always convert at full precision to avoid double rounding. */
351 ndigits
= 27 - edigits
;
355 /* We know the number of digits, so can let printf do the rounding
361 if (ndigits
> 27 - edigits
)
362 ndigits
= 27 - edigits
;
365 /* # The result will always contain a decimal point, even if no
368 * - The converted value is to be left adjusted on the field boundary
370 * + A sign (+ or -) always be placed before a number
372 * 31 minimum field width
374 * * (ndigits-1) is used as the precision
376 * e format: [-]d.ddde±dd where there is one digit before the
377 * decimal-point character and the number of digits after it is
378 * equal to the precision. The exponent always contains at least two
379 * digits; if the value is zero, the exponent is 00.
381 sprintf (buffer
, "%+-#31.*" GFC_REAL_LARGEST_FORMAT
"e",
384 /* Check the resulting string has punctuation in the correct places. */
385 if (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e')
386 internal_error ("printf is broken");
388 /* Read the exponent back in. */
389 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
391 /* Make sure zero comes out as 0.0e0. */
395 /* Normalize the fractional component. */
396 buffer
[2] = buffer
[1];
399 /* Figure out where to place the decimal point. */
403 nbefore
= e
+ g
.scale_factor
;
436 nafter
= (d
- i
) + 1;
452 /* The exponent must be a multiple of three, with 1-3 digits before
453 the decimal point. */
462 nbefore
= 3 - nbefore
;
481 /* Should never happen. */
482 internal_error ("Unexpected format token");
485 /* Round the value. */
486 if (nbefore
+ nafter
== 0)
489 if (nzero_real
== d
&& digits
[0] >= '5')
491 /* We rounded to zero but shouldn't have */
498 else if (nbefore
+ nafter
< ndigits
)
500 ndigits
= nbefore
+ nafter
;
502 if (digits
[i
] >= '5')
504 /* Propagate the carry. */
505 for (i
--; i
>= 0; i
--)
507 if (digits
[i
] != '9')
517 /* The carry overflowed. Fortunately we have some spare space
518 at the start of the buffer. We may discard some digits, but
519 this is ok because we already know they are zero. */
532 else if (ft
== FMT_EN
)
547 /* Calculate the format of the exponent field. */
551 for (i
= abs (e
); i
>= 10; i
/= 10)
556 /* Width not specified. Must be no more than 3 digits. */
557 if (e
> 999 || e
< -999)
562 if (e
> 99 || e
< -99)
568 /* Exponent width specified, check it is wide enough. */
569 if (edigits
> f
->u
.real
.e
)
572 edigits
= f
->u
.real
.e
+ 2;
578 /* Pick a field size if none was specified. */
580 w
= nbefore
+ nzero
+ nafter
+ (sign
!= SIGN_NONE
? 2 : 1);
582 /* Create the ouput buffer. */
583 out
= write_block (w
);
587 /* Zero values always output as positive, even if the value was negative
589 for (i
= 0; i
< ndigits
; i
++)
591 if (digits
[i
] != '0')
595 sign
= calculate_sign (0);
597 /* Work out how much padding is needed. */
598 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
599 if (sign
!= SIGN_NONE
)
602 /* Check the value fits in the specified field width. */
603 if (nblanks
< 0 || edigits
== -1)
609 /* See if we have space for a zero before the decimal point. */
610 if (nbefore
== 0 && nblanks
> 0)
618 /* Padd to full field width. */
621 if ( ( nblanks
> 0 ) && !no_leading_blank
)
623 memset (out
, ' ', nblanks
);
627 /* Output the initial sign (if any). */
628 if (sign
== SIGN_PLUS
)
630 else if (sign
== SIGN_MINUS
)
633 /* Output an optional leading zero. */
637 /* Output the part before the decimal point, padding with zeros. */
640 if (nbefore
> ndigits
)
645 memcpy (out
, digits
, i
);
653 /* Output the decimal point. */
656 /* Output leading zeros after the decimal point. */
659 for (i
= 0; i
< nzero
; i
++)
663 /* Output digits after the decimal point, padding with zeros. */
666 if (nafter
> ndigits
)
671 memcpy (out
, digits
, i
);
680 /* Output the exponent. */
689 snprintf (buffer
, 32, "%+0*d", edigits
, e
);
691 sprintf (buffer
, "%+0*d", edigits
, e
);
693 memcpy (out
, buffer
, edigits
);
696 if ( no_leading_blank
)
699 memset( out
, ' ' , nblanks
);
700 no_leading_blank
= 0;
706 write_l (fnode
* f
, char *source
, int len
)
709 GFC_INTEGER_LARGEST n
;
711 p
= write_block (f
->u
.w
);
715 memset (p
, ' ', f
->u
.w
- 1);
716 n
= extract_int (source
, len
);
717 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
720 /* Output a real number according to its format. */
723 write_float (fnode
*f
, const char *source
, int len
)
726 int nb
=0, res
, save_scale_factor
;
730 n
= extract_real (source
, len
);
732 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
734 /* TODO: there are some systems where isfinite is not able to work
735 with long double variables. We should detect this case and
736 provide our own version for isfinite. */
741 p
= write_block (nb
);
758 memcpy(p
+ nb
- 8, "Infinity", 8);
760 memcpy(p
+ nb
- 3, "Inf", 3);
761 if (nb
< 8 && nb
> 3)
767 memcpy(p
+ nb
- 3, "NaN", 3);
772 if (f
->format
!= FMT_G
)
778 save_scale_factor
= g
.scale_factor
;
779 f2
= calculate_G_format(f
, n
, &nb
);
780 output_float (f2
, n
);
781 g
.scale_factor
= save_scale_factor
;
787 p
= write_block (nb
);
795 write_int (fnode
*f
, const char *source
, int len
,
796 char *(*conv
) (GFC_UINTEGER_LARGEST
))
798 GFC_UINTEGER_LARGEST n
= 0;
799 int w
, m
, digits
, nzero
, nblank
;
805 n
= extract_int (source
, len
);
809 if (m
== 0 && n
== 0)
825 /* Select a width if none was specified. The idea here is to always
829 w
= ((digits
< m
) ? m
: digits
);
839 /* See if things will work. */
841 nblank
= w
- (nzero
+ digits
);
850 if (!no_leading_blank
)
852 memset (p
, ' ', nblank
);
854 memset (p
, '0', nzero
);
856 memcpy (p
, q
, digits
);
860 memset (p
, '0', nzero
);
862 memcpy (p
, q
, digits
);
864 memset (p
, ' ', nblank
);
865 no_leading_blank
= 0;
873 write_decimal (fnode
*f
, const char *source
, int len
,
874 char *(*conv
) (GFC_INTEGER_LARGEST
))
876 GFC_INTEGER_LARGEST n
= 0;
877 int w
, m
, digits
, nsign
, nzero
, nblank
;
884 n
= extract_int (source
, len
);
888 if (m
== 0 && n
== 0)
901 sign
= calculate_sign (n
< 0);
905 nsign
= sign
== SIGN_NONE
? 0 : 1;
910 /* Select a width if none was specified. The idea here is to always
914 w
= ((digits
< m
) ? m
: digits
) + nsign
;
924 /* See if things will work. */
926 nblank
= w
- (nsign
+ nzero
+ digits
);
934 memset (p
, ' ', nblank
);
949 memset (p
, '0', nzero
);
952 memcpy (p
, q
, digits
);
959 /* Convert unsigned octal to ascii. */
962 otoa (GFC_UINTEGER_LARGEST n
)
973 p
= scratch
+ sizeof (SCRATCH_SIZE
) - 1;
987 /* Convert unsigned binary to ascii. */
990 btoa (GFC_UINTEGER_LARGEST n
)
1001 p
= scratch
+ sizeof (SCRATCH_SIZE
) - 1;
1006 *p
-- = '0' + (n
& 1);
1015 write_i (fnode
* f
, const char *p
, int len
)
1017 write_decimal (f
, p
, len
, (void *) gfc_itoa
);
1022 write_b (fnode
* f
, const char *p
, int len
)
1024 write_int (f
, p
, len
, btoa
);
1029 write_o (fnode
* f
, const char *p
, int len
)
1031 write_int (f
, p
, len
, otoa
);
1035 write_z (fnode
* f
, const char *p
, int len
)
1037 write_int (f
, p
, len
, xtoa
);
1042 write_d (fnode
*f
, const char *p
, int len
)
1044 write_float (f
, p
, len
);
1049 write_e (fnode
*f
, const char *p
, int len
)
1051 write_float (f
, p
, len
);
1056 write_f (fnode
*f
, const char *p
, int len
)
1058 write_float (f
, p
, len
);
1063 write_en (fnode
*f
, const char *p
, int len
)
1065 write_float (f
, p
, len
);
1070 write_es (fnode
*f
, const char *p
, int len
)
1072 write_float (f
, p
, len
);
1076 /* Take care of the X/TR descriptor. */
1083 p
= write_block (f
->u
.n
);
1087 memset (p
, ' ', f
->u
.n
);
1091 /* List-directed writing. */
1094 /* Write a single character to the output. Returns nonzero if
1095 something goes wrong. */
1102 p
= write_block (1);
1112 /* Write a list-directed logical value. */
1115 write_logical (const char *source
, int length
)
1117 write_char (extract_int (source
, length
) ? 'T' : 'F');
1121 /* Write a list-directed integer value. */
1124 write_integer (const char *source
, int length
)
1131 q
= gfc_itoa (extract_int (source
, length
));
1156 digits
= strlen (q
);
1160 p
= write_block (width
) ;
1161 if (no_leading_blank
)
1163 memcpy (p
, q
, digits
);
1164 memset(p
+ digits
,' ', width
- digits
) ;
1168 memset(p
,' ', width
- digits
) ;
1169 memcpy (p
+ width
- digits
, q
, digits
);
1174 /* Write a list-directed string. We have to worry about delimiting
1175 the strings if the file has been opened in that mode. */
1178 write_character (const char *source
, int length
)
1183 switch (current_unit
->flags
.delim
)
1185 case DELIM_APOSTROPHE
:
1202 for (i
= 0; i
< length
; i
++)
1207 p
= write_block (length
+ extra
);
1212 memcpy (p
, source
, length
);
1217 for (i
= 0; i
< length
; i
++)
1229 /* Output a real number with default format.
1230 This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8). */
1233 write_real (const char *source
, int length
)
1236 int org_scale
= g
.scale_factor
;
1251 write_float (&f
, source
, length
);
1252 g
.scale_factor
= org_scale
;
1257 write_complex (const char *source
, int len
)
1259 if (write_char ('('))
1261 write_real (source
, len
);
1263 if (write_char (','))
1265 write_real (source
+ len
, len
);
1271 /* Write the separator between items. */
1274 write_separator (void)
1278 p
= write_block (options
.separator_len
);
1282 memcpy (p
, options
.separator
, options
.separator_len
);
1286 /* Write an item with list formatting.
1287 TODO: handle skipping to the next record correctly, particularly
1291 list_formatted_write (bt type
, void *p
, int len
)
1293 static int char_flag
;
1295 if (current_unit
== NULL
)
1306 if (type
!= BT_CHARACTER
|| !char_flag
||
1307 current_unit
->flags
.delim
!= DELIM_NONE
)
1314 write_integer (p
, len
);
1317 write_logical (p
, len
);
1320 write_character (p
, len
);
1323 write_real (p
, len
);
1326 write_complex (p
, len
);
1329 internal_error ("list_formatted_write(): Bad type");
1332 char_flag
= (type
== BT_CHARACTER
);
1337 nml_write_obj writes a namelist object to the output stream. It is called
1338 recursively for derived type components:
1339 obj = is the namelist_info for the current object.
1340 offset = the offset relative to the address held by the object for
1341 derived type arrays.
1342 base = is the namelist_info of the derived type, when obj is a
1344 base_name = the full name for a derived type, including qualifiers
1346 The returned value is a pointer to the object beyond the last one
1347 accessed, including nested derived types. Notice that the namelist is
1348 a linear linked list of objects, including derived types and their
1349 components. A tree, of sorts, is implied by the compound names of
1350 the derived type components and this is how this function recurses through
1353 /* A generous estimate of the number of characters needed to print
1354 repeat counts and indices, including commas, asterices and brackets. */
1356 #define NML_DIGITS 20
1358 /* Stores the delimiter to be used for character objects. */
1360 static const char * nml_delim
;
1362 static namelist_info
*
1363 nml_write_obj (namelist_info
* obj
, index_type offset
,
1364 namelist_info
* base
, char * base_name
)
1370 index_type obj_size
;
1374 index_type elem_ctr
;
1375 index_type obj_name_len
;
1380 char rep_buff
[NML_DIGITS
];
1381 namelist_info
* cmp
;
1382 namelist_info
* retval
= obj
->next
;
1384 /* Write namelist variable names in upper case. If a derived type,
1385 nothing is output. If a component, base and base_name are set. */
1387 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1389 write_character ("\n ", 2);
1393 len
=strlen (base
->var_name
);
1394 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1396 cup
= toupper (base_name
[dim_i
]);
1397 write_character (&cup
, 1);
1400 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1402 cup
= toupper (obj
->var_name
[dim_i
]);
1403 write_character (&cup
, 1);
1405 write_character ("=", 1);
1408 /* Counts the number of data output on a line, including names. */
1414 if (obj
->type
== GFC_DTYPE_COMPLEX
)
1416 if (obj
->type
== GFC_DTYPE_CHARACTER
)
1417 obj_size
= obj
->string_length
;
1419 obj_size
= obj
->size
;
1421 /* Set the index vector and count the number of elements. */
1424 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1426 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1427 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1430 /* Main loop to output the data held in the object. */
1433 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1436 /* Build the pointer to the data value. The offset is passed by
1437 recursive calls to this function for arrays of derived types.
1438 Is NULL otherwise. */
1440 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1443 /* Check for repeat counts of intrinsic types. */
1445 if ((elem_ctr
< (nelem
- 1)) &&
1446 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1447 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1452 /* Execute a repeated output. Note the flag no_leading_blank that
1453 is used in the functions used to output the intrinsic types. */
1459 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1460 write_character (rep_buff
, strlen (rep_buff
));
1461 no_leading_blank
= 1;
1465 /* Output the data, if an intrinsic type, or recurse into this
1466 routine to treat derived types. */
1471 case GFC_DTYPE_INTEGER
:
1472 write_integer (p
, len
);
1475 case GFC_DTYPE_LOGICAL
:
1476 write_logical (p
, len
);
1479 case GFC_DTYPE_CHARACTER
:
1481 write_character (nml_delim
, 1);
1482 write_character (p
, obj
->string_length
);
1484 write_character (nml_delim
, 1);
1487 case GFC_DTYPE_REAL
:
1488 write_real (p
, len
);
1491 case GFC_DTYPE_COMPLEX
:
1492 no_leading_blank
= 0;
1494 write_complex (p
, len
);
1497 case GFC_DTYPE_DERIVED
:
1499 /* To treat a derived type, we need to build two strings:
1500 ext_name = the name, including qualifiers that prepends
1501 component names in the output - passed to
1503 obj_name = the derived type name with no qualifiers but %
1504 appended. This is used to identify the
1507 /* First ext_name => get length of all possible components */
1509 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1510 + (base
? strlen (base
->var_name
) : 0)
1511 + strlen (obj
->var_name
)
1512 + obj
->var_rank
* NML_DIGITS
1515 strcpy(ext_name
, base_name
? base_name
: "");
1516 clen
= base
? strlen (base
->var_name
) : 0;
1517 strcat (ext_name
, obj
->var_name
+ clen
);
1519 /* Append the qualifier. */
1521 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1523 strcat (ext_name
, dim_i
? "" : "(");
1524 clen
= strlen (ext_name
);
1525 st_sprintf (ext_name
+ clen
, "%d", (int) obj
->ls
[dim_i
].idx
);
1526 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1531 obj_name_len
= strlen (obj
->var_name
) + 1;
1532 obj_name
= get_mem (obj_name_len
+1);
1533 strcpy (obj_name
, obj
->var_name
);
1534 strcat (obj_name
, "%");
1536 /* Now loop over the components. Update the component pointer
1537 with the return value from nml_write_obj => this loop jumps
1538 past nested derived types. */
1540 for (cmp
= obj
->next
;
1541 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1544 retval
= nml_write_obj (cmp
, (index_type
)(p
- obj
->mem_pos
),
1548 free_mem (obj_name
);
1549 free_mem (ext_name
);
1553 internal_error ("Bad type for namelist write");
1556 /* Reset the leading blank suppression, write a comma and, if 5
1557 values have been output, write a newline and advance to column
1558 2. Reset the repeat counter. */
1560 no_leading_blank
= 0;
1561 write_character (",", 1);
1565 write_character ("\n ", 2);
1570 /* Cycle through and increment the index vector. */
1575 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1577 obj
->ls
[dim_i
].idx
+= nml_carry
;
1579 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1581 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1587 /* Return a pointer beyond the furthest object accessed. */
1592 /* This is the entry function for namelist writes. It outputs the name
1593 of the namelist and iterates through the namelist by calls to
1594 nml_write_obj. The call below has dummys in the arguments used in
1595 the treatment of derived types. */
1598 namelist_write (void)
1600 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1602 index_type dummy_offset
= 0;
1604 char * dummy_name
= NULL
;
1605 unit_delim tmp_delim
;
1607 /* Set the delimiter for namelist output. */
1609 tmp_delim
= current_unit
->flags
.delim
;
1610 current_unit
->flags
.delim
= DELIM_NONE
;
1617 case (DELIM_APOSTROPHE
):
1625 write_character ("&",1);
1627 /* Write namelist name in upper case - f95 std. */
1629 for (i
= 0 ;i
< ioparm
.namelist_name_len
;i
++ )
1631 c
= toupper (ioparm
.namelist_name
[i
]);
1632 write_character (&c
,1);
1641 t1
= nml_write_obj (t2
, dummy_offset
, dummy
, dummy_name
);
1644 write_character (" /\n", 4);
1646 /* Recover the original delimiter. */
1648 current_unit
->flags
.delim
= tmp_delim
;