1 /* Copyright (C) 2002-2016 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist output contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
36 #define star_fill(p, n) memset(p, '*', n)
38 typedef unsigned char uchar
;
40 /* Helper functions for character(kind=4) internal units. These are needed
41 by write_float.def. */
44 memcpy4 (gfc_char4_t
*dest
, const char *source
, int k
)
48 const char *p
= source
;
49 for (j
= 0; j
< k
; j
++)
50 *dest
++ = (gfc_char4_t
) *p
++;
53 /* This include contains the heart and soul of formatted floating point. */
54 #include "write_float.def"
56 /* Write out default char4. */
59 write_default_char4 (st_parameter_dt
*dtp
, const gfc_char4_t
*source
,
60 int src_len
, int w_len
)
67 /* Take care of preceding blanks. */
71 p
= write_block (dtp
, k
);
74 if (is_char4_unit (dtp
))
76 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
83 /* Get ready to handle delimiters if needed. */
84 switch (dtp
->u
.p
.current_unit
->delim_status
)
86 case DELIM_APOSTROPHE
:
97 /* Now process the remaining characters, one at a time. */
98 for (j
= 0; j
< src_len
; j
++)
101 if (is_char4_unit (dtp
))
104 /* Handle delimiters if any. */
105 if (c
== d
&& d
!= ' ')
107 p
= write_block (dtp
, 2);
110 q
= (gfc_char4_t
*) p
;
115 p
= write_block (dtp
, 1);
118 q
= (gfc_char4_t
*) p
;
124 /* Handle delimiters if any. */
125 if (c
== d
&& d
!= ' ')
127 p
= write_block (dtp
, 2);
134 p
= write_block (dtp
, 1);
138 *p
= c
> 255 ? '?' : (uchar
) c
;
144 /* Write out UTF-8 converted from char4. */
147 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
148 int src_len
, int w_len
)
153 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
154 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
158 /* Take care of preceding blanks. */
162 p
= write_block (dtp
, k
);
168 /* Get ready to handle delimiters if needed. */
169 switch (dtp
->u
.p
.current_unit
->delim_status
)
171 case DELIM_APOSTROPHE
:
182 /* Now process the remaining characters, one at a time. */
183 for (j
= k
; j
< src_len
; j
++)
188 /* Handle the delimiters if any. */
189 if (c
== d
&& d
!= ' ')
191 p
= write_block (dtp
, 2);
198 p
= write_block (dtp
, 1);
206 /* Convert to UTF-8 sequence. */
212 *--q
= ((c
& 0x3F) | 0x80);
216 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
218 *--q
= (c
| masks
[nbytes
-1]);
220 p
= write_block (dtp
, nbytes
);
232 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
237 wlen
= f
->u
.string
.length
< 0
238 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
239 ? len
: f
->u
.string
.length
;
242 /* If this is formatted STREAM IO convert any embedded line feed characters
243 to CR_LF on systems that use that sequence for newlines. See F2003
244 Standard sections 10.6.3 and 9.9 for further information. */
245 if (is_stream_io (dtp
))
247 const char crlf
[] = "\r\n";
251 /* Write out any padding if needed. */
254 p
= write_block (dtp
, wlen
- len
);
257 memset (p
, ' ', wlen
- len
);
260 /* Scan the source string looking for '\n' and convert it if found. */
261 for (i
= 0; i
< wlen
; i
++)
263 if (source
[i
] == '\n')
265 /* Write out the previously scanned characters in the string. */
268 p
= write_block (dtp
, bytes
);
271 memcpy (p
, &source
[q
], bytes
);
276 /* Write out the CR_LF sequence. */
278 p
= write_block (dtp
, 2);
287 /* Write out any remaining bytes if no LF was found. */
290 p
= write_block (dtp
, bytes
);
293 memcpy (p
, &source
[q
], bytes
);
299 p
= write_block (dtp
, wlen
);
303 if (unlikely (is_char4_unit (dtp
)))
305 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
307 memcpy4 (p4
, source
, wlen
);
310 memset4 (p4
, ' ', wlen
- len
);
311 memcpy4 (p4
+ wlen
- len
, source
, len
);
317 memcpy (p
, source
, wlen
);
320 memset (p
, ' ', wlen
- len
);
321 memcpy (p
+ wlen
- len
, source
, len
);
329 /* The primary difference between write_a_char4 and write_a is that we have to
330 deal with writing from the first byte of the 4-byte character and pay
331 attention to the most significant bytes. For ENCODING="default" write the
332 lowest significant byte. If the 3 most significant bytes contain
333 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
334 to the UTF-8 encoded string before writing out. */
337 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
342 wlen
= f
->u
.string
.length
< 0
343 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
344 ? len
: f
->u
.string
.length
;
346 q
= (gfc_char4_t
*) source
;
348 /* If this is formatted STREAM IO convert any embedded line feed characters
349 to CR_LF on systems that use that sequence for newlines. See F2003
350 Standard sections 10.6.3 and 9.9 for further information. */
351 if (is_stream_io (dtp
))
353 const gfc_char4_t crlf
[] = {0x000d,0x000a};
358 /* Write out any padding if needed. */
362 p
= write_block (dtp
, wlen
- len
);
365 memset (p
, ' ', wlen
- len
);
368 /* Scan the source string looking for '\n' and convert it if found. */
369 qq
= (gfc_char4_t
*) source
;
370 for (i
= 0; i
< wlen
; i
++)
374 /* Write out the previously scanned characters in the string. */
377 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
378 write_utf8_char4 (dtp
, q
, bytes
, 0);
380 write_default_char4 (dtp
, q
, bytes
, 0);
384 /* Write out the CR_LF sequence. */
385 write_default_char4 (dtp
, crlf
, 2, 0);
391 /* Write out any remaining bytes if no LF was found. */
394 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
395 write_utf8_char4 (dtp
, q
, bytes
, 0);
397 write_default_char4 (dtp
, q
, bytes
, 0);
403 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
404 write_utf8_char4 (dtp
, q
, len
, wlen
);
406 write_default_char4 (dtp
, q
, len
, wlen
);
413 static GFC_INTEGER_LARGEST
414 extract_int (const void *p
, int len
)
416 GFC_INTEGER_LARGEST i
= 0;
426 memcpy ((void *) &tmp
, p
, len
);
433 memcpy ((void *) &tmp
, p
, len
);
440 memcpy ((void *) &tmp
, p
, len
);
447 memcpy ((void *) &tmp
, p
, len
);
451 #ifdef HAVE_GFC_INTEGER_16
455 memcpy ((void *) &tmp
, p
, len
);
461 internal_error (NULL
, "bad integer kind");
467 static GFC_UINTEGER_LARGEST
468 extract_uint (const void *p
, int len
)
470 GFC_UINTEGER_LARGEST i
= 0;
480 memcpy ((void *) &tmp
, p
, len
);
481 i
= (GFC_UINTEGER_1
) tmp
;
487 memcpy ((void *) &tmp
, p
, len
);
488 i
= (GFC_UINTEGER_2
) tmp
;
494 memcpy ((void *) &tmp
, p
, len
);
495 i
= (GFC_UINTEGER_4
) tmp
;
501 memcpy ((void *) &tmp
, p
, len
);
502 i
= (GFC_UINTEGER_8
) tmp
;
505 #ifdef HAVE_GFC_INTEGER_16
509 GFC_INTEGER_16 tmp
= 0;
510 memcpy ((void *) &tmp
, p
, len
);
511 i
= (GFC_UINTEGER_16
) tmp
;
516 internal_error (NULL
, "bad integer kind");
524 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
528 GFC_INTEGER_LARGEST n
;
530 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
532 p
= write_block (dtp
, wlen
);
536 n
= extract_int (source
, len
);
538 if (unlikely (is_char4_unit (dtp
)))
540 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
541 memset4 (p4
, ' ', wlen
-1);
542 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
546 memset (p
, ' ', wlen
-1);
547 p
[wlen
- 1] = (n
) ? 'T' : 'F';
552 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
554 int w
, m
, digits
, nzero
, nblank
;
562 if (m
== 0 && n
== 0)
567 p
= write_block (dtp
, w
);
570 if (unlikely (is_char4_unit (dtp
)))
572 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
573 memset4 (p4
, ' ', w
);
582 /* Select a width if none was specified. The idea here is to always
586 w
= ((digits
< m
) ? m
: digits
);
588 p
= write_block (dtp
, w
);
596 /* See if things will work. */
598 nblank
= w
- (nzero
+ digits
);
600 if (unlikely (is_char4_unit (dtp
)))
602 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
605 memset4 (p4
, '*', w
);
609 if (!dtp
->u
.p
.no_leading_blank
)
611 memset4 (p4
, ' ', nblank
);
613 memset4 (p4
, '0', nzero
);
615 memcpy4 (p4
, q
, digits
);
619 memset4 (p4
, '0', nzero
);
621 memcpy4 (p4
, q
, digits
);
623 memset4 (p4
, ' ', nblank
);
624 dtp
->u
.p
.no_leading_blank
= 0;
635 if (!dtp
->u
.p
.no_leading_blank
)
637 memset (p
, ' ', nblank
);
639 memset (p
, '0', nzero
);
641 memcpy (p
, q
, digits
);
645 memset (p
, '0', nzero
);
647 memcpy (p
, q
, digits
);
649 memset (p
, ' ', nblank
);
650 dtp
->u
.p
.no_leading_blank
= 0;
658 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
660 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
662 GFC_INTEGER_LARGEST n
= 0;
663 int w
, m
, digits
, nsign
, nzero
, nblank
;
667 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
670 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
672 n
= extract_int (source
, len
);
675 if (m
== 0 && n
== 0)
680 p
= write_block (dtp
, w
);
683 if (unlikely (is_char4_unit (dtp
)))
685 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
686 memset4 (p4
, ' ', w
);
693 sign
= calculate_sign (dtp
, n
< 0);
696 nsign
= sign
== S_NONE
? 0 : 1;
698 /* conv calls itoa which sets the negative sign needed
699 by write_integer. The sign '+' or '-' is set below based on sign
700 calculated above, so we just point past the sign in the string
701 before proceeding to avoid double signs in corner cases.
703 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
709 /* Select a width if none was specified. The idea here is to always
713 w
= ((digits
< m
) ? m
: digits
) + nsign
;
715 p
= write_block (dtp
, w
);
723 /* See if things will work. */
725 nblank
= w
- (nsign
+ nzero
+ digits
);
727 if (unlikely (is_char4_unit (dtp
)))
729 gfc_char4_t
* p4
= (gfc_char4_t
*) p
;
732 memset4 (p4
, '*', w
);
736 memset4 (p4
, ' ', nblank
);
751 memset4 (p4
, '0', nzero
);
754 memcpy4 (p4
, q
, digits
);
764 memset (p
, ' ', nblank
);
779 memset (p
, '0', nzero
);
782 memcpy (p
, q
, digits
);
789 /* Convert unsigned octal to ascii. */
792 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
796 assert (len
>= GFC_OTOA_BUF_SIZE
);
801 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
806 *--p
= '0' + (n
& 7);
814 /* Convert unsigned binary to ascii. */
817 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
821 assert (len
>= GFC_BTOA_BUF_SIZE
);
826 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
831 *--p
= '0' + (n
& 1);
838 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
839 to convert large reals with kind sizes that exceed the largest integer type
840 available on certain platforms. In these cases, byte by byte conversion is
841 performed. Endianess is taken into account. */
843 /* Conversion to binary. */
846 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
855 for (i
= 0; i
< len
; i
++)
859 /* Test for zero. Needed by write_boz later. */
863 for (j
= 0; j
< 8; j
++)
865 *q
++ = (c
& 128) ? '1' : '0';
873 const char *p
= s
+ len
- 1;
874 for (i
= 0; i
< len
; i
++)
878 /* Test for zero. Needed by write_boz later. */
882 for (j
= 0; j
< 8; j
++)
884 *q
++ = (c
& 128) ? '1' : '0';
896 /* Move past any leading zeros. */
897 while (*buffer
== '0')
904 /* Conversion to octal. */
907 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
913 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
919 const char *p
= s
+ len
- 1;
923 /* Test for zero. Needed by write_boz later. */
927 for (j
= 0; j
< 3 && i
< len
; j
++)
929 octet
|= (c
& 1) << j
;
948 /* Test for zero. Needed by write_boz later. */
952 for (j
= 0; j
< 3 && i
< len
; j
++)
954 octet
|= (c
& 1) << j
;
971 /* Move past any leading zeros. */
978 /* Conversion to hexidecimal. */
981 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
983 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
984 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
995 for (i
= 0; i
< len
; i
++)
997 /* Test for zero. Needed by write_boz later. */
1001 h
= (*p
>> 4) & 0x0F;
1009 const char *p
= s
+ len
- 1;
1010 for (i
= 0; i
< len
; i
++)
1012 /* Test for zero. Needed by write_boz later. */
1016 h
= (*p
>> 4) & 0x0F;
1028 /* Move past any leading zeros. */
1029 while (*buffer
== '0')
1037 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1039 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1044 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1047 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1048 GFC_UINTEGER_LARGEST n
= 0;
1050 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1052 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1053 write_boz (dtp
, f
, p
, n
);
1057 n
= extract_uint (source
, len
);
1058 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1059 write_boz (dtp
, f
, p
, n
);
1065 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1068 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1069 GFC_UINTEGER_LARGEST n
= 0;
1071 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1073 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1074 write_boz (dtp
, f
, p
, n
);
1078 n
= extract_uint (source
, len
);
1079 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1080 write_boz (dtp
, f
, p
, n
);
1085 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1088 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1089 GFC_UINTEGER_LARGEST n
= 0;
1091 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1093 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1094 write_boz (dtp
, f
, p
, n
);
1098 n
= extract_uint (source
, len
);
1099 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1100 write_boz (dtp
, f
, p
, n
);
1104 /* Take care of the X/TR descriptor. */
1107 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1111 p
= write_block (dtp
, len
);
1114 if (nspaces
> 0 && len
- nspaces
>= 0)
1116 if (unlikely (is_char4_unit (dtp
)))
1118 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1119 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1122 memset (&p
[len
- nspaces
], ' ', nspaces
);
1127 /* List-directed writing. */
1130 /* Write a single character to the output. Returns nonzero if
1131 something goes wrong. */
1134 write_char (st_parameter_dt
*dtp
, int c
)
1138 p
= write_block (dtp
, 1);
1141 if (unlikely (is_char4_unit (dtp
)))
1143 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1154 /* Write a list-directed logical value. */
1157 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1159 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1163 /* Write a list-directed integer value. */
1166 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1172 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1174 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1199 digits
= strlen (q
);
1203 p
= write_block (dtp
, width
);
1207 if (unlikely (is_char4_unit (dtp
)))
1209 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1210 if (dtp
->u
.p
.no_leading_blank
)
1212 memcpy4 (p4
, q
, digits
);
1213 memset4 (p4
+ digits
, ' ', width
- digits
);
1217 memset4 (p4
, ' ', width
- digits
);
1218 memcpy4 (p4
+ width
- digits
, q
, digits
);
1223 if (dtp
->u
.p
.no_leading_blank
)
1225 memcpy (p
, q
, digits
);
1226 memset (p
+ digits
, ' ', width
- digits
);
1230 memset (p
, ' ', width
- digits
);
1231 memcpy (p
+ width
- digits
, q
, digits
);
1236 /* Write a list-directed string. We have to worry about delimiting
1237 the strings if the file has been opened in that mode. */
1243 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
, int mode
)
1250 switch (dtp
->u
.p
.current_unit
->delim_status
)
1252 case DELIM_APOSTROPHE
:
1274 for (i
= 0; i
< length
; i
++)
1279 p
= write_block (dtp
, length
+ extra
);
1283 if (unlikely (is_char4_unit (dtp
)))
1285 gfc_char4_t d4
= (gfc_char4_t
) d
;
1286 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1289 memcpy4 (p4
, source
, length
);
1294 for (i
= 0; i
< length
; i
++)
1296 *p4
++ = (gfc_char4_t
) source
[i
];
1307 memcpy (p
, source
, length
);
1312 for (i
= 0; i
< length
; i
++)
1326 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1327 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1329 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1333 p
= write_block (dtp
, 1);
1336 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1337 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1339 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1341 p
= write_block (dtp
, 1);
1347 /* Floating point helper functions. */
1349 #define BUF_STACK_SZ 256
1352 get_precision (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1354 if (f
->format
!= FMT_EN
)
1355 return determine_precision (dtp
, f
, kind
);
1357 return determine_en_precision (dtp
, f
, source
, kind
);
1360 /* 4932 is the maximum exponent of long double and quad precision, 3
1361 extra characters for the sign, the decimal point, and the
1362 trailing null. Extra digits are added by the calling functions for
1363 requested precision. Likewise for float and double. F0 editing produces
1364 full precision output. */
1366 size_from_kind (st_parameter_dt
*dtp
, const fnode
*f
, int kind
)
1370 if (f
->format
== FMT_F
&& f
->u
.real
.w
== 0)
1375 size
= 38 + 3; /* These constants shown for clarity. */
1387 internal_error (&dtp
->common
, "bad real kind");
1392 size
= f
->u
.real
.w
+ 1; /* One byte for a NULL character. */
1398 select_buffer (st_parameter_dt
*dtp
, const fnode
*f
, int precision
,
1399 char *buf
, size_t *size
, int kind
)
1403 /* The buffer needs at least one more byte to allow room for normalizing. */
1404 *size
= size_from_kind (dtp
, f
, kind
) + precision
+ 1;
1406 if (*size
> BUF_STACK_SZ
)
1407 result
= xmalloc (*size
);
1414 select_string (st_parameter_dt
*dtp
, const fnode
*f
, char *buf
, size_t *size
,
1418 *size
= size_from_kind (dtp
, f
, kind
) + f
->u
.real
.d
;
1419 if (*size
> BUF_STACK_SZ
)
1420 result
= xmalloc (*size
);
1427 write_float_string (st_parameter_dt
*dtp
, char *fstr
, size_t len
)
1429 char *p
= write_block (dtp
, len
);
1433 if (unlikely (is_char4_unit (dtp
)))
1435 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1436 memcpy4 (p4
, fstr
, len
);
1439 memcpy (p
, fstr
, len
);
1444 write_float_0 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1446 char buf_stack
[BUF_STACK_SZ
];
1447 char str_buf
[BUF_STACK_SZ
];
1448 char *buffer
, *result
;
1449 size_t buf_size
, res_len
;
1451 /* Precision for snprintf call. */
1452 int precision
= get_precision (dtp
, f
, source
, kind
);
1454 /* String buffer to hold final result. */
1455 result
= select_string (dtp
, f
, str_buf
, &res_len
, kind
);
1457 buffer
= select_buffer (dtp
, f
, precision
, buf_stack
, &buf_size
, kind
);
1459 get_float_string (dtp
, f
, source
, kind
, 0, buffer
,
1460 precision
, buf_size
, result
, &res_len
);
1461 write_float_string (dtp
, result
, res_len
);
1463 if (buf_size
> BUF_STACK_SZ
)
1465 if (res_len
> BUF_STACK_SZ
)
1470 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1472 write_float_0 (dtp
, f
, p
, len
);
1477 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1479 write_float_0 (dtp
, f
, p
, len
);
1484 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1486 write_float_0 (dtp
, f
, p
, len
);
1491 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1493 write_float_0 (dtp
, f
, p
, len
);
1498 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1500 write_float_0 (dtp
, f
, p
, len
);
1504 /* Set an fnode to default format. */
1507 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1528 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1529 #if GFC_REAL_16_DIGITS == 113
1540 internal_error (&dtp
->common
, "bad real kind");
1545 /* Output a real number with default format.
1546 To guarantee that a binary -> decimal -> binary roundtrip conversion
1547 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1548 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1549 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1550 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1551 Fortran standard requires outputting an extra digit when the scale
1552 factor is 1 and when the magnitude of the value is such that E
1553 editing is used. However, gfortran compensates for this, and thus
1554 for list formatted the same number of significant digits is
1555 generated both when using F and E editing. */
1558 write_real (st_parameter_dt
*dtp
, const char *source
, int kind
)
1561 char buf_stack
[BUF_STACK_SZ
];
1562 char str_buf
[BUF_STACK_SZ
];
1563 char *buffer
, *result
;
1564 size_t buf_size
, res_len
;
1565 int orig_scale
= dtp
->u
.p
.scale_factor
;
1566 dtp
->u
.p
.scale_factor
= 1;
1567 set_fnode_default (dtp
, &f
, kind
);
1569 /* Precision for snprintf call. */
1570 int precision
= get_precision (dtp
, &f
, source
, kind
);
1572 /* String buffer to hold final result. */
1573 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1575 /* Scratch buffer to hold final result. */
1576 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1578 get_float_string (dtp
, &f
, source
, kind
, 1, buffer
,
1579 precision
, buf_size
, result
, &res_len
);
1580 write_float_string (dtp
, result
, res_len
);
1582 dtp
->u
.p
.scale_factor
= orig_scale
;
1583 if (buf_size
> BUF_STACK_SZ
)
1585 if (res_len
> BUF_STACK_SZ
)
1589 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1590 compensate for the extra digit. */
1593 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int kind
, int d
)
1596 char buf_stack
[BUF_STACK_SZ
];
1597 char str_buf
[BUF_STACK_SZ
];
1598 char *buffer
, *result
;
1599 size_t buf_size
, res_len
;
1601 set_fnode_default (dtp
, &f
, kind
);
1606 /* Compensate for extra digits when using scale factor, d is not
1607 specified, and the magnitude is such that E editing is used. */
1608 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1612 dtp
->u
.p
.g0_no_blanks
= 1;
1614 /* Precision for snprintf call. */
1615 int precision
= get_precision (dtp
, &f
, source
, kind
);
1617 /* String buffer to hold final result. */
1618 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1620 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1622 get_float_string (dtp
, &f
, source
, kind
, comp_d
, buffer
,
1623 precision
, buf_size
, result
, &res_len
);
1624 write_float_string (dtp
, result
, res_len
);
1626 dtp
->u
.p
.g0_no_blanks
= 0;
1627 if (buf_size
> BUF_STACK_SZ
)
1629 if (res_len
> BUF_STACK_SZ
)
1635 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1638 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1640 /* Set for no blanks so we get a string result with no leading
1641 blanks. We will pad left later. */
1642 dtp
->u
.p
.g0_no_blanks
= 1;
1645 char buf_stack
[BUF_STACK_SZ
];
1646 char str1_buf
[BUF_STACK_SZ
];
1647 char str2_buf
[BUF_STACK_SZ
];
1648 char *buffer
, *result1
, *result2
;
1649 size_t buf_size
, res_len1
, res_len2
;
1650 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1652 dtp
->u
.p
.scale_factor
= 1;
1653 set_fnode_default (dtp
, &f
, kind
);
1655 /* Set width for two values, parenthesis, and comma. */
1656 width
= 2 * f
.u
.real
.w
+ 3;
1658 /* Set for no blanks so we get a string result with no leading
1659 blanks. We will pad left later. */
1660 dtp
->u
.p
.g0_no_blanks
= 1;
1662 /* Precision for snprintf call. */
1663 int precision
= get_precision (dtp
, &f
, source
, kind
);
1665 /* String buffers to hold final result. */
1666 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1667 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1669 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1671 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1672 precision
, buf_size
, result1
, &res_len1
);
1673 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1674 precision
, buf_size
, result2
, &res_len2
);
1675 lblanks
= width
- res_len1
- res_len2
- 3;
1677 write_x (dtp
, lblanks
, lblanks
);
1678 write_char (dtp
, '(');
1679 write_float_string (dtp
, result1
, res_len1
);
1680 write_char (dtp
, semi_comma
);
1681 write_float_string (dtp
, result2
, res_len2
);
1682 write_char (dtp
, ')');
1684 dtp
->u
.p
.scale_factor
= orig_scale
;
1685 dtp
->u
.p
.g0_no_blanks
= 0;
1686 if (buf_size
> BUF_STACK_SZ
)
1688 if (res_len1
> BUF_STACK_SZ
)
1690 if (res_len2
> BUF_STACK_SZ
)
1695 /* Write the separator between items. */
1698 write_separator (st_parameter_dt
*dtp
)
1702 p
= write_block (dtp
, options
.separator_len
);
1705 if (unlikely (is_char4_unit (dtp
)))
1707 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1708 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1711 memcpy (p
, options
.separator
, options
.separator_len
);
1715 /* Write an item with list formatting.
1716 TODO: handle skipping to the next record correctly, particularly
1720 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1723 if (dtp
->u
.p
.current_unit
== NULL
)
1726 if (dtp
->u
.p
.first_item
)
1728 dtp
->u
.p
.first_item
= 0;
1729 write_char (dtp
, ' ');
1733 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1734 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1735 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1736 write_separator (dtp
);
1742 write_integer (dtp
, p
, kind
);
1745 write_logical (dtp
, p
, kind
);
1748 write_character (dtp
, p
, kind
, size
, DELIM
);
1751 write_real (dtp
, p
, kind
);
1754 write_complex (dtp
, p
, kind
, size
);
1758 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1759 char iotype
[] = "LISTDIRECTED";
1760 gfc_charlen_type iotype_len
= 12;
1761 char tmp_iomsg
[IOMSG_LEN
] = "";
1763 gfc_charlen_type child_iomsg_len
;
1765 int *child_iostat
= NULL
;
1768 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1769 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1771 /* Set iostat, intent(out). */
1773 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1774 dtp
->common
.iostat
: &noiostat
;
1776 /* Set iomsge, intent(inout). */
1777 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1779 child_iomsg
= dtp
->common
.iomsg
;
1780 child_iomsg_len
= dtp
->common
.iomsg_len
;
1784 child_iomsg
= tmp_iomsg
;
1785 child_iomsg_len
= IOMSG_LEN
;
1788 /* Call the user defined formatted WRITE procedure. */
1789 dtp
->u
.p
.current_unit
->child_dtio
++;
1790 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1791 child_iostat
, child_iomsg
,
1792 iotype_len
, child_iomsg_len
);
1793 dtp
->u
.p
.current_unit
->child_dtio
--;
1797 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1800 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1801 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1806 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1807 size_t size
, size_t nelems
)
1811 size_t stride
= type
== BT_CHARACTER
?
1812 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1816 /* Big loop over all the elements. */
1817 for (elem
= 0; elem
< nelems
; elem
++)
1819 dtp
->u
.p
.item_count
++;
1820 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1826 nml_write_obj writes a namelist object to the output stream. It is called
1827 recursively for derived type components:
1828 obj = is the namelist_info for the current object.
1829 offset = the offset relative to the address held by the object for
1830 derived type arrays.
1831 base = is the namelist_info of the derived type, when obj is a
1833 base_name = the full name for a derived type, including qualifiers
1835 The returned value is a pointer to the object beyond the last one
1836 accessed, including nested derived types. Notice that the namelist is
1837 a linear linked list of objects, including derived types and their
1838 components. A tree, of sorts, is implied by the compound names of
1839 the derived type components and this is how this function recurses through
1842 /* A generous estimate of the number of characters needed to print
1843 repeat counts and indices, including commas, asterices and brackets. */
1845 #define NML_DIGITS 20
1848 namelist_write_newline (st_parameter_dt
*dtp
)
1850 if (!is_internal_unit (dtp
))
1853 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
1855 write_character (dtp
, "\n", 1, 1, NODELIM
);
1860 if (is_array_io (dtp
))
1865 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
1867 p
= write_block (dtp
, length
);
1871 if (unlikely (is_char4_unit (dtp
)))
1873 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1874 memset4 (p4
, ' ', length
);
1877 memset (p
, ' ', length
);
1879 /* Now that the current record has been padded out,
1880 determine where the next record in the array is. */
1881 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1884 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1887 /* Now seek to this record */
1888 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1890 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1892 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1896 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1900 write_character (dtp
, " ", 1, 1, NODELIM
);
1904 static namelist_info
*
1905 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1906 namelist_info
* base
, char * base_name
)
1912 index_type obj_size
;
1916 index_type elem_ctr
;
1917 size_t obj_name_len
;
1923 size_t ext_name_len
;
1924 char rep_buff
[NML_DIGITS
];
1925 namelist_info
* cmp
;
1926 namelist_info
* retval
= obj
->next
;
1927 size_t base_name_len
;
1928 size_t base_var_name_len
;
1931 /* Set the character to be used to separate values
1932 to a comma or semi-colon. */
1935 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1937 /* Write namelist variable names in upper case. If a derived type,
1938 nothing is output. If a component, base and base_name are set. */
1940 if (obj
->type
!= BT_DERIVED
)
1942 namelist_write_newline (dtp
);
1943 write_character (dtp
, " ", 1, 1, NODELIM
);
1948 len
= strlen (base
->var_name
);
1949 base_name_len
= strlen (base_name
);
1950 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
1952 cup
= toupper ((int) base_name
[dim_i
]);
1953 write_character (dtp
, &cup
, 1, 1, NODELIM
);
1956 clen
= strlen (obj
->var_name
);
1957 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
1959 cup
= toupper ((int) obj
->var_name
[dim_i
]);
1962 write_character (dtp
, &cup
, 1, 1, NODELIM
);
1964 write_character (dtp
, "=", 1, 1, NODELIM
);
1967 /* Counts the number of data output on a line, including names. */
1977 obj_size
= size_from_real_kind (len
);
1981 obj_size
= size_from_complex_kind (len
);
1985 obj_size
= obj
->string_length
;
1993 obj_size
= obj
->size
;
1995 /* Set the index vector and count the number of elements. */
1998 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2000 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2001 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2004 /* Main loop to output the data held in the object. */
2007 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2010 /* Build the pointer to the data value. The offset is passed by
2011 recursive calls to this function for arrays of derived types.
2012 Is NULL otherwise. */
2014 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2017 /* Check for repeat counts of intrinsic types. */
2019 if ((elem_ctr
< (nelem
- 1)) &&
2020 (obj
->type
!= BT_DERIVED
) &&
2021 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
2026 /* Execute a repeated output. Note the flag no_leading_blank that
2027 is used in the functions used to output the intrinsic types. */
2033 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2034 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2035 dtp
->u
.p
.no_leading_blank
= 1;
2039 /* Output the data, if an intrinsic type, or recurse into this
2040 routine to treat derived types. */
2046 write_integer (dtp
, p
, len
);
2050 write_logical (dtp
, p
, len
);
2054 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2055 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2057 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2061 write_real (dtp
, p
, len
);
2065 dtp
->u
.p
.no_leading_blank
= 0;
2067 write_complex (dtp
, p
, len
, obj_size
);
2072 /* To treat a derived type, we need to build two strings:
2073 ext_name = the name, including qualifiers that prepends
2074 component names in the output - passed to
2076 obj_name = the derived type name with no qualifiers but %
2077 appended. This is used to identify the
2080 /* First ext_name => get length of all possible components */
2081 if (obj
->dtio_sub
!= NULL
)
2083 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2084 char iotype
[] = "NAMELIST";
2085 gfc_charlen_type iotype_len
= 8;
2086 char tmp_iomsg
[IOMSG_LEN
] = "";
2088 gfc_charlen_type child_iomsg_len
;
2090 int *child_iostat
= NULL
;
2093 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2095 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2098 list_obj
.vptr
= obj
->vtable
;
2101 /* Set iostat, intent(out). */
2103 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2104 dtp
->common
.iostat
: &noiostat
;
2106 /* Set iomsg, intent(inout). */
2107 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2109 child_iomsg
= dtp
->common
.iomsg
;
2110 child_iomsg_len
= dtp
->common
.iomsg_len
;
2114 child_iomsg
= tmp_iomsg
;
2115 child_iomsg_len
= IOMSG_LEN
;
2117 namelist_write_newline (dtp
);
2118 /* Call the user defined formatted WRITE procedure. */
2119 dtp
->u
.p
.current_unit
->child_dtio
++;
2120 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2121 child_iostat
, child_iomsg
,
2122 iotype_len
, child_iomsg_len
);
2123 dtp
->u
.p
.current_unit
->child_dtio
--;
2128 base_name_len
= base_name
? strlen (base_name
) : 0;
2129 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2130 ext_name_len
= base_name_len
+ base_var_name_len
2131 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2132 ext_name
= xmalloc (ext_name_len
);
2135 memcpy (ext_name
, base_name
, base_name_len
);
2136 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2137 memcpy (ext_name
+ base_name_len
,
2138 obj
->var_name
+ base_var_name_len
, clen
);
2140 /* Append the qualifier. */
2142 tot_len
= base_name_len
+ clen
;
2143 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2147 ext_name
[tot_len
] = '(';
2150 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2151 (int) obj
->ls
[dim_i
].idx
);
2152 tot_len
+= strlen (ext_name
+ tot_len
);
2153 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2157 ext_name
[tot_len
] = '\0';
2158 for (q
= ext_name
; *q
; q
++)
2164 obj_name_len
= strlen (obj
->var_name
) + 1;
2165 obj_name
= xmalloc (obj_name_len
+ 1);
2166 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2167 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2169 /* Now loop over the components. Update the component pointer
2170 with the return value from nml_write_obj => this loop jumps
2171 past nested derived types. */
2173 for (cmp
= obj
->next
;
2174 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2177 retval
= nml_write_obj (dtp
, cmp
,
2178 (index_type
)(p
- obj
->mem_pos
),
2187 internal_error (&dtp
->common
, "Bad type for namelist write");
2190 /* Reset the leading blank suppression, write a comma (or semi-colon)
2191 and, if 5 values have been output, write a newline and advance
2192 to column 2. Reset the repeat counter. */
2194 dtp
->u
.p
.no_leading_blank
= 0;
2195 if (obj
->type
== BT_CHARACTER
)
2197 if (dtp
->u
.p
.nml_delim
!= '\0')
2198 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2201 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2205 if (dtp
->u
.p
.nml_delim
== '\0')
2206 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2207 namelist_write_newline (dtp
);
2208 write_character (dtp
, " ", 1, 1, NODELIM
);
2213 /* Cycle through and increment the index vector. */
2218 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2220 obj
->ls
[dim_i
].idx
+= nml_carry
;
2222 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2224 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2230 /* Return a pointer beyond the furthest object accessed. */
2236 /* This is the entry function for namelist writes. It outputs the name
2237 of the namelist and iterates through the namelist by calls to
2238 nml_write_obj. The call below has dummys in the arguments used in
2239 the treatment of derived types. */
2242 namelist_write (st_parameter_dt
*dtp
)
2244 namelist_info
* t1
, *t2
, *dummy
= NULL
;
2246 index_type dummy_offset
= 0;
2248 char * dummy_name
= NULL
;
2250 /* Set the delimiter for namelist output. */
2251 switch (dtp
->u
.p
.current_unit
->delim_status
)
2253 case DELIM_APOSTROPHE
:
2254 dtp
->u
.p
.nml_delim
= '\'';
2257 case DELIM_UNSPECIFIED
:
2258 dtp
->u
.p
.nml_delim
= '"';
2261 dtp
->u
.p
.nml_delim
= '\0';
2264 write_character (dtp
, "&", 1, 1, NODELIM
);
2266 /* Write namelist name in upper case - f95 std. */
2267 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
2269 c
= toupper ((int) dtp
->namelist_name
[i
]);
2270 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2273 if (dtp
->u
.p
.ionml
!= NULL
)
2275 t1
= dtp
->u
.p
.ionml
;
2279 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2283 namelist_write_newline (dtp
);
2284 write_character (dtp
, " /", 1, 2, NODELIM
);