1 /* Copyright (C) 2002-2022 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/>. */
34 #define star_fill(p, n) memset(p, '*', n)
36 typedef unsigned char uchar
;
38 /* Helper functions for character(kind=4) internal units. These are needed
39 by write_float.def. */
42 memcpy4 (gfc_char4_t
*dest
, const char *source
, int k
)
46 const char *p
= source
;
47 for (j
= 0; j
< k
; j
++)
48 *dest
++ = (gfc_char4_t
) *p
++;
51 /* This include contains the heart and soul of formatted floating point. */
52 #include "write_float.def"
54 /* Write out default char4. */
57 write_default_char4 (st_parameter_dt
*dtp
, const gfc_char4_t
*source
,
58 int src_len
, int w_len
)
65 /* Take care of preceding blanks. */
69 p
= write_block (dtp
, k
);
72 if (is_char4_unit (dtp
))
74 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
81 /* Get ready to handle delimiters if needed. */
82 switch (dtp
->u
.p
.current_unit
->delim_status
)
84 case DELIM_APOSTROPHE
:
95 /* Now process the remaining characters, one at a time. */
96 for (j
= 0; j
< src_len
; j
++)
99 if (is_char4_unit (dtp
))
102 /* Handle delimiters if any. */
103 if (c
== d
&& d
!= ' ')
105 p
= write_block (dtp
, 2);
108 q
= (gfc_char4_t
*) p
;
113 p
= write_block (dtp
, 1);
116 q
= (gfc_char4_t
*) p
;
122 /* Handle delimiters if any. */
123 if (c
== d
&& d
!= ' ')
125 p
= write_block (dtp
, 2);
132 p
= write_block (dtp
, 1);
136 *p
= c
> 255 ? '?' : (uchar
) c
;
142 /* Write out UTF-8 converted from char4. */
145 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
146 int src_len
, int w_len
)
151 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
152 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
156 /* Take care of preceding blanks. */
160 p
= write_block (dtp
, k
);
166 /* Get ready to handle delimiters if needed. */
167 switch (dtp
->u
.p
.current_unit
->delim_status
)
169 case DELIM_APOSTROPHE
:
180 /* Now process the remaining characters, one at a time. */
181 for (j
= k
; j
< src_len
; j
++)
186 /* Handle the delimiters if any. */
187 if (c
== d
&& d
!= ' ')
189 p
= write_block (dtp
, 2);
196 p
= write_block (dtp
, 1);
204 /* Convert to UTF-8 sequence. */
210 *--q
= ((c
& 0x3F) | 0x80);
214 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
216 *--q
= (c
| masks
[nbytes
-1]);
218 p
= write_block (dtp
, nbytes
);
229 /* Check the first character in source if we are using CC_FORTRAN
230 and set the cc.type appropriately. The cc.type is used later by write_cc
231 to determine the output start-of-record, and next_record_cc to determine the
232 output end-of-record.
233 This function is called before the output buffer is allocated, so alloc_len
234 is set to the appropriate size to allocate. */
237 write_check_cc (st_parameter_dt
*dtp
, const char **source
, size_t *alloc_len
)
239 /* Only valid for CARRIAGECONTROL=FORTRAN. */
240 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
241 || alloc_len
== NULL
|| source
== NULL
)
244 /* Peek at the first character. */
245 int c
= (*alloc_len
> 0) ? (*source
)[0] : EOF
;
248 /* The start-of-record character which will be printed. */
249 dtp
->u
.p
.cc
.u
.start
= '\n';
250 /* The number of characters to print at the start-of-record.
251 len > 1 means copy the SOR character multiple times.
252 len == 0 means no SOR will be output. */
258 dtp
->u
.p
.cc
.type
= CCF_OVERPRINT
;
262 dtp
->u
.p
.cc
.type
= CCF_ONE_LF
;
266 dtp
->u
.p
.cc
.type
= CCF_TWO_LF
;
270 dtp
->u
.p
.cc
.type
= CCF_PAGE_FEED
;
272 dtp
->u
.p
.cc
.u
.start
= '\f';
275 dtp
->u
.p
.cc
.type
= CCF_PROMPT
;
279 dtp
->u
.p
.cc
.type
= CCF_OVERPRINT_NOA
;
283 /* In the default case we copy ONE_LF. */
284 dtp
->u
.p
.cc
.type
= CCF_DEFAULT
;
289 /* We add n-1 to alloc_len so our write buffer is the right size.
290 We are replacing the first character, and possibly prepending some
291 additional characters. Note for n==0, we actually subtract one from
292 alloc_len, which is correct, since that character is skipped. */
296 *alloc_len
+= dtp
->u
.p
.cc
.len
- 1;
298 /* If we have no input, there is no first character to replace. Make
299 sure we still allocate enough space for the start-of-record string. */
301 *alloc_len
= dtp
->u
.p
.cc
.len
;
306 /* Write the start-of-record character(s) for CC_FORTRAN.
307 Also adjusts the 'cc' struct to contain the end-of-record character
309 The source_len is set to the remaining length to copy from the source,
310 after the start-of-record string was inserted. */
313 write_cc (st_parameter_dt
*dtp
, char *p
, size_t *source_len
)
315 /* Only valid for CARRIAGECONTROL=FORTRAN. */
316 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
|| source_len
== NULL
)
319 /* Write the start-of-record string to the output buffer. Note that len is
320 never more than 2. */
321 if (dtp
->u
.p
.cc
.len
> 0)
323 *(p
++) = dtp
->u
.p
.cc
.u
.start
;
324 if (dtp
->u
.p
.cc
.len
> 1)
325 *(p
++) = dtp
->u
.p
.cc
.u
.start
;
327 /* source_len comes from write_check_cc where it is set to the full
328 allocated length of the output buffer. Therefore we subtract off the
329 length of the SOR string to obtain the remaining source length. */
330 *source_len
-= dtp
->u
.p
.cc
.len
;
335 dtp
->u
.p
.cc
.u
.end
= '\r';
337 /* Update end-of-record character for next_record_w. */
338 switch (dtp
->u
.p
.cc
.type
)
341 case CCF_OVERPRINT_NOA
:
342 /* No end-of-record. */
344 dtp
->u
.p
.cc
.u
.end
= '\0';
352 /* Carriage return. */
354 dtp
->u
.p
.cc
.u
.end
= '\r';
363 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, size_t len
)
368 wlen
= f
->u
.string
.length
< 0
369 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
370 ? len
: (size_t) f
->u
.string
.length
;
373 /* If this is formatted STREAM IO convert any embedded line feed characters
374 to CR_LF on systems that use that sequence for newlines. See F2003
375 Standard sections 10.6.3 and 9.9 for further information. */
376 if (is_stream_io (dtp
))
378 const char crlf
[] = "\r\n";
382 /* Write out any padding if needed. */
385 p
= write_block (dtp
, wlen
- len
);
388 memset (p
, ' ', wlen
- len
);
391 /* Scan the source string looking for '\n' and convert it if found. */
392 for (size_t i
= 0; i
< wlen
; i
++)
394 if (source
[i
] == '\n')
396 /* Write out the previously scanned characters in the string. */
399 p
= write_block (dtp
, bytes
);
402 memcpy (p
, &source
[q
], bytes
);
407 /* Write out the CR_LF sequence. */
409 p
= write_block (dtp
, 2);
418 /* Write out any remaining bytes if no LF was found. */
421 p
= write_block (dtp
, bytes
);
424 memcpy (p
, &source
[q
], bytes
);
430 if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
431 write_check_cc (dtp
, &source
, &wlen
);
433 p
= write_block (dtp
, wlen
);
437 if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
438 p
= write_cc (dtp
, p
, &wlen
);
440 if (unlikely (is_char4_unit (dtp
)))
442 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
444 memcpy4 (p4
, source
, wlen
);
447 memset4 (p4
, ' ', wlen
- len
);
448 memcpy4 (p4
+ wlen
- len
, source
, len
);
454 memcpy (p
, source
, wlen
);
457 memset (p
, ' ', wlen
- len
);
458 memcpy (p
+ wlen
- len
, source
, len
);
466 /* The primary difference between write_a_char4 and write_a is that we have to
467 deal with writing from the first byte of the 4-byte character and pay
468 attention to the most significant bytes. For ENCODING="default" write the
469 lowest significant byte. If the 3 most significant bytes contain
470 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
471 to the UTF-8 encoded string before writing out. */
474 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, size_t len
)
479 wlen
= f
->u
.string
.length
< 0
480 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
481 ? len
: (size_t) f
->u
.string
.length
;
483 q
= (gfc_char4_t
*) source
;
485 /* If this is formatted STREAM IO convert any embedded line feed characters
486 to CR_LF on systems that use that sequence for newlines. See F2003
487 Standard sections 10.6.3 and 9.9 for further information. */
488 if (is_stream_io (dtp
))
490 const gfc_char4_t crlf
[] = {0x000d,0x000a};
495 /* Write out any padding if needed. */
499 p
= write_block (dtp
, wlen
- len
);
502 memset (p
, ' ', wlen
- len
);
505 /* Scan the source string looking for '\n' and convert it if found. */
506 qq
= (gfc_char4_t
*) source
;
507 for (size_t i
= 0; i
< wlen
; i
++)
511 /* Write out the previously scanned characters in the string. */
514 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
515 write_utf8_char4 (dtp
, q
, bytes
, 0);
517 write_default_char4 (dtp
, q
, bytes
, 0);
521 /* Write out the CR_LF sequence. */
522 write_default_char4 (dtp
, crlf
, 2, 0);
528 /* Write out any remaining bytes if no LF was found. */
531 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
532 write_utf8_char4 (dtp
, q
, bytes
, 0);
534 write_default_char4 (dtp
, q
, bytes
, 0);
540 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
541 write_utf8_char4 (dtp
, q
, len
, wlen
);
543 write_default_char4 (dtp
, q
, len
, wlen
);
550 static GFC_INTEGER_LARGEST
551 extract_int (const void *p
, int len
)
553 GFC_INTEGER_LARGEST i
= 0;
563 memcpy ((void *) &tmp
, p
, len
);
570 memcpy ((void *) &tmp
, p
, len
);
577 memcpy ((void *) &tmp
, p
, len
);
584 memcpy ((void *) &tmp
, p
, len
);
588 #ifdef HAVE_GFC_INTEGER_16
592 memcpy ((void *) &tmp
, p
, len
);
598 internal_error (NULL
, "bad integer kind");
604 static GFC_UINTEGER_LARGEST
605 extract_uint (const void *p
, int len
)
607 GFC_UINTEGER_LARGEST i
= 0;
617 memcpy ((void *) &tmp
, p
, len
);
618 i
= (GFC_UINTEGER_1
) tmp
;
624 memcpy ((void *) &tmp
, p
, len
);
625 i
= (GFC_UINTEGER_2
) tmp
;
631 memcpy ((void *) &tmp
, p
, len
);
632 i
= (GFC_UINTEGER_4
) tmp
;
638 memcpy ((void *) &tmp
, p
, len
);
639 i
= (GFC_UINTEGER_8
) tmp
;
642 #ifdef HAVE_GFC_INTEGER_16
646 GFC_INTEGER_16 tmp
= 0;
647 memcpy ((void *) &tmp
, p
, len
);
648 i
= (GFC_UINTEGER_16
) tmp
;
653 internal_error (NULL
, "bad integer kind");
661 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
665 GFC_INTEGER_LARGEST n
;
667 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
669 p
= write_block (dtp
, wlen
);
673 n
= extract_int (source
, len
);
675 if (unlikely (is_char4_unit (dtp
)))
677 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
678 memset4 (p4
, ' ', wlen
-1);
679 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
683 memset (p
, ' ', wlen
-1);
684 p
[wlen
- 1] = (n
) ? 'T' : 'F';
688 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
, int len
)
690 int w
, m
, digits
, nzero
, nblank
;
698 if (m
== 0 && n
== 0)
703 p
= write_block (dtp
, w
);
706 if (unlikely (is_char4_unit (dtp
)))
708 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
709 memset4 (p4
, ' ', w
);
718 /* Select a width if none was specified. The idea here is to always
721 if (w
== DEFAULT_WIDTH
)
722 w
= default_width_for_integer (len
);
725 w
= ((digits
< m
) ? m
: digits
);
727 p
= write_block (dtp
, w
);
735 /* See if things will work. */
737 nblank
= w
- (nzero
+ digits
);
739 if (unlikely (is_char4_unit (dtp
)))
741 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
744 memset4 (p4
, '*', w
);
748 if (!dtp
->u
.p
.no_leading_blank
)
750 memset4 (p4
, ' ', nblank
);
752 memset4 (p4
, '0', nzero
);
754 memcpy4 (p4
, q
, digits
);
758 memset4 (p4
, '0', nzero
);
760 memcpy4 (p4
, q
, digits
);
762 memset4 (p4
, ' ', nblank
);
763 dtp
->u
.p
.no_leading_blank
= 0;
774 if (!dtp
->u
.p
.no_leading_blank
)
776 memset (p
, ' ', nblank
);
778 memset (p
, '0', nzero
);
780 memcpy (p
, q
, digits
);
784 memset (p
, '0', nzero
);
786 memcpy (p
, q
, digits
);
788 memset (p
, ' ', nblank
);
789 dtp
->u
.p
.no_leading_blank
= 0;
797 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
800 GFC_INTEGER_LARGEST n
= 0;
801 GFC_UINTEGER_LARGEST absn
;
802 int w
, m
, digits
, nsign
, nzero
, nblank
;
806 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
809 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
811 n
= extract_int (source
, len
);
814 if (m
== 0 && n
== 0)
819 p
= write_block (dtp
, w
);
822 if (unlikely (is_char4_unit (dtp
)))
824 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
825 memset4 (p4
, ' ', w
);
832 sign
= calculate_sign (dtp
, n
< 0);
834 /* Use unsigned to protect from overflow. */
835 absn
= -(GFC_UINTEGER_LARGEST
) n
;
838 nsign
= sign
== S_NONE
? 0 : 1;
840 /* gfc_itoa() converts the nonnegative value to decimal representation. */
841 q
= gfc_itoa (absn
, itoa_buf
, sizeof (itoa_buf
));
844 /* Select a width if none was specified. The idea here is to always
846 if (w
== DEFAULT_WIDTH
)
847 w
= default_width_for_integer (len
);
850 w
= ((digits
< m
) ? m
: digits
) + nsign
;
852 p
= write_block (dtp
, w
);
860 /* See if things will work. */
862 nblank
= w
- (nsign
+ nzero
+ digits
);
864 if (unlikely (is_char4_unit (dtp
)))
866 gfc_char4_t
*p4
= (gfc_char4_t
*)p
;
869 memset4 (p4
, '*', w
);
873 if (!dtp
->u
.p
.namelist_mode
)
875 memset4 (p4
, ' ', nblank
);
891 memset4 (p4
, '0', nzero
);
894 memcpy4 (p4
, q
, digits
);
897 if (dtp
->u
.p
.namelist_mode
)
900 memset4 (p4
, ' ', nblank
);
910 if (!dtp
->u
.p
.namelist_mode
)
912 memset (p
, ' ', nblank
);
928 memset (p
, '0', nzero
);
931 memcpy (p
, q
, digits
);
933 if (dtp
->u
.p
.namelist_mode
)
936 memset (p
, ' ', nblank
);
944 /* Convert hexadecimal to ASCII. */
947 xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
952 assert (len
>= GFC_XTOA_BUF_SIZE
);
957 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
964 digit
+= 'A' - '0' - 10;
974 /* Convert unsigned octal to ASCII. */
977 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
981 assert (len
>= GFC_OTOA_BUF_SIZE
);
986 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
991 *--p
= '0' + (n
& 7);
999 /* Convert unsigned binary to ASCII. */
1002 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1006 assert (len
>= GFC_BTOA_BUF_SIZE
);
1011 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
1016 *--p
= '0' + (n
& 1);
1023 /* The following three functions, btoa_big, otoa_big, and xtoa_big, are needed
1024 to convert large reals with kind sizes that exceed the largest integer type
1025 available on certain platforms. In these cases, byte by byte conversion is
1026 performed. Endianess is taken into account. */
1028 /* Conversion to binary. */
1031 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1037 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1040 for (i
= 0; i
< len
; i
++)
1044 /* Test for zero. Needed by write_boz later. */
1048 for (j
= 0; j
< 8; j
++)
1050 *q
++ = (c
& 128) ? '1' : '0';
1058 const char *p
= s
+ len
- 1;
1059 for (i
= 0; i
< len
; i
++)
1063 /* Test for zero. Needed by write_boz later. */
1067 for (j
= 0; j
< 8; j
++)
1069 *q
++ = (c
& 128) ? '1' : '0';
1079 /* Move past any leading zeros. */
1080 while (*buffer
== '0')
1087 /* Conversion to octal. */
1090 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1096 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1100 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1102 const char *p
= s
+ len
- 1;
1106 /* Test for zero. Needed by write_boz later. */
1110 for (j
= 0; j
< 3 && i
< len
; j
++)
1112 octet
|= (c
& 1) << j
;
1131 /* Test for zero. Needed by write_boz later. */
1135 for (j
= 0; j
< 3 && i
< len
; j
++)
1137 octet
|= (c
& 1) << j
;
1154 /* Move past any leading zeros. */
1161 /* Conversion to hexadecimal. */
1164 xtoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1166 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
1167 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1175 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1178 for (i
= 0; i
< len
; i
++)
1180 /* Test for zero. Needed by write_boz later. */
1184 h
= (*p
>> 4) & 0x0F;
1192 const char *p
= s
+ len
- 1;
1193 for (i
= 0; i
< len
; i
++)
1195 /* Test for zero. Needed by write_boz later. */
1199 h
= (*p
>> 4) & 0x0F;
1206 /* write_z, which calls xtoa_big, is called from transfer.c,
1207 formatted_transfer_scalar_write. There it is passed the kind as
1208 argument, which means a maximum of 16. The buffer is large
1209 enough, but the compiler does not know that, so shut up the
1211 #pragma GCC diagnostic push
1212 #pragma GCC diagnostic ignored "-Wstringop-overflow"
1214 #pragma GCC diagnostic pop
1219 /* Move past any leading zeros. */
1220 while (*buffer
== '0')
1228 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1230 write_decimal (dtp
, f
, p
, len
);
1235 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1238 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1239 GFC_UINTEGER_LARGEST n
= 0;
1241 /* Ensure we end up with a null terminated string. */
1242 memset(itoa_buf
, '\0', GFC_BTOA_BUF_SIZE
);
1244 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1246 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1247 write_boz (dtp
, f
, p
, n
, len
);
1251 n
= extract_uint (source
, len
);
1252 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1253 write_boz (dtp
, f
, p
, n
, len
);
1259 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1262 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1263 GFC_UINTEGER_LARGEST n
= 0;
1265 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1267 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1268 write_boz (dtp
, f
, p
, n
, len
);
1272 n
= extract_uint (source
, len
);
1273 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1274 write_boz (dtp
, f
, p
, n
, len
);
1279 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1282 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1283 GFC_UINTEGER_LARGEST n
= 0;
1285 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1287 p
= xtoa_big (source
, itoa_buf
, len
, &n
);
1288 write_boz (dtp
, f
, p
, n
, len
);
1292 n
= extract_uint (source
, len
);
1293 p
= xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1294 write_boz (dtp
, f
, p
, n
, len
);
1298 /* Take care of the X/TR descriptor. */
1301 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1305 p
= write_block (dtp
, len
);
1308 if (nspaces
> 0 && len
- nspaces
>= 0)
1310 if (unlikely (is_char4_unit (dtp
)))
1312 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1313 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1316 memset (&p
[len
- nspaces
], ' ', nspaces
);
1321 /* List-directed writing. */
1324 /* Write a single character to the output. Returns nonzero if
1325 something goes wrong. */
1328 write_char (st_parameter_dt
*dtp
, int c
)
1332 p
= write_block (dtp
, 1);
1335 if (unlikely (is_char4_unit (dtp
)))
1337 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1348 /* Write a list-directed logical value. */
1351 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1353 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1357 /* Write a list-directed integer value. */
1360 write_integer (st_parameter_dt
*dtp
, const char *source
, int kind
)
1391 f
.u
.integer
.w
= width
;
1393 f
.format
= FMT_NONE
;
1394 write_decimal (dtp
, &f
, source
, kind
);
1398 /* Write a list-directed string. We have to worry about delimiting
1399 the strings if the file has been opened in that mode. */
1405 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t length
, int mode
)
1412 switch (dtp
->u
.p
.current_unit
->delim_status
)
1414 case DELIM_APOSTROPHE
:
1436 for (size_t i
= 0; i
< length
; i
++)
1441 p
= write_block (dtp
, length
+ extra
);
1445 if (unlikely (is_char4_unit (dtp
)))
1447 gfc_char4_t d4
= (gfc_char4_t
) d
;
1448 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1451 memcpy4 (p4
, source
, length
);
1456 for (size_t i
= 0; i
< length
; i
++)
1458 *p4
++ = (gfc_char4_t
) source
[i
];
1469 memcpy (p
, source
, length
);
1474 for (size_t i
= 0; i
< length
; i
++)
1488 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1489 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1491 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1495 p
= write_block (dtp
, 1);
1498 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1499 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1501 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1503 p
= write_block (dtp
, 1);
1509 /* Floating point helper functions. */
1511 #define BUF_STACK_SZ 384
1514 get_precision (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1516 if (f
->format
!= FMT_EN
)
1517 return determine_precision (dtp
, f
, kind
);
1519 return determine_en_precision (dtp
, f
, source
, kind
);
1522 /* 4932 is the maximum exponent of long double and quad precision, 3
1523 extra characters for the sign, the decimal point, and the
1524 trailing null. Extra digits are added by the calling functions for
1525 requested precision. Likewise for float and double. F0 editing produces
1526 full precision output. */
1528 size_from_kind (st_parameter_dt
*dtp
, const fnode
*f
, int kind
)
1532 if ((f
->format
== FMT_F
&& f
->u
.real
.w
== 0) || f
->u
.real
.w
== DEFAULT_WIDTH
)
1537 size
= 38 + 3; /* These constants shown for clarity. */
1549 internal_error (&dtp
->common
, "bad real kind");
1554 size
= f
->u
.real
.w
+ 1; /* One byte for a NULL character. */
1560 select_buffer (st_parameter_dt
*dtp
, const fnode
*f
, int precision
,
1561 char *buf
, size_t *size
, int kind
)
1565 /* The buffer needs at least one more byte to allow room for
1566 normalizing and 1 to hold null terminator. */
1567 *size
= size_from_kind (dtp
, f
, kind
) + precision
+ 1 + 1;
1569 if (*size
> BUF_STACK_SZ
)
1570 result
= xmalloc (*size
);
1577 select_string (st_parameter_dt
*dtp
, const fnode
*f
, char *buf
, size_t *size
,
1581 *size
= size_from_kind (dtp
, f
, kind
) + f
->u
.real
.d
+ 1;
1582 if (*size
> BUF_STACK_SZ
)
1583 result
= xmalloc (*size
);
1590 write_float_string (st_parameter_dt
*dtp
, char *fstr
, size_t len
)
1592 char *p
= write_block (dtp
, len
);
1596 if (unlikely (is_char4_unit (dtp
)))
1598 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1599 memcpy4 (p4
, fstr
, len
);
1602 memcpy (p
, fstr
, len
);
1607 write_float_0 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1609 char buf_stack
[BUF_STACK_SZ
];
1610 char str_buf
[BUF_STACK_SZ
];
1611 char *buffer
, *result
;
1612 size_t buf_size
, res_len
, flt_str_len
;
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
, 0, buffer
,
1623 precision
, buf_size
, result
, &flt_str_len
);
1624 write_float_string (dtp
, result
, flt_str_len
);
1626 if (buf_size
> BUF_STACK_SZ
)
1628 if (res_len
> BUF_STACK_SZ
)
1633 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1635 write_float_0 (dtp
, f
, p
, len
);
1640 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1642 write_float_0 (dtp
, f
, p
, len
);
1647 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1649 write_float_0 (dtp
, f
, p
, len
);
1654 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1656 write_float_0 (dtp
, f
, p
, len
);
1661 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1663 write_float_0 (dtp
, f
, p
, len
);
1667 /* Set an fnode to default format. */
1670 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1691 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1692 #if GFC_REAL_16_DIGITS == 113
1703 internal_error (&dtp
->common
, "bad real kind");
1708 /* Output a real number with default format.
1709 To guarantee that a binary -> decimal -> binary roundtrip conversion
1710 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1711 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1712 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1713 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1714 Fortran standard requires outputting an extra digit when the scale
1715 factor is 1 and when the magnitude of the value is such that E
1716 editing is used. However, gfortran compensates for this, and thus
1717 for list formatted the same number of significant digits is
1718 generated both when using F and E editing. */
1721 write_real (st_parameter_dt
*dtp
, const char *source
, int kind
)
1724 char buf_stack
[BUF_STACK_SZ
];
1725 char str_buf
[BUF_STACK_SZ
];
1726 char *buffer
, *result
;
1727 size_t buf_size
, res_len
, flt_str_len
;
1728 int orig_scale
= dtp
->u
.p
.scale_factor
;
1729 dtp
->u
.p
.scale_factor
= 1;
1730 set_fnode_default (dtp
, &f
, kind
);
1732 /* Precision for snprintf call. */
1733 int precision
= get_precision (dtp
, &f
, source
, kind
);
1735 /* String buffer to hold final result. */
1736 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1738 /* Scratch buffer to hold final result. */
1739 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1741 get_float_string (dtp
, &f
, source
, kind
, 1, buffer
,
1742 precision
, buf_size
, result
, &flt_str_len
);
1743 write_float_string (dtp
, result
, flt_str_len
);
1745 dtp
->u
.p
.scale_factor
= orig_scale
;
1746 if (buf_size
> BUF_STACK_SZ
)
1748 if (res_len
> BUF_STACK_SZ
)
1752 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1753 compensate for the extra digit. */
1756 write_real_w0 (st_parameter_dt
*dtp
, const char *source
, int kind
,
1760 char buf_stack
[BUF_STACK_SZ
];
1761 char str_buf
[BUF_STACK_SZ
];
1762 char *buffer
, *result
;
1763 size_t buf_size
, res_len
, flt_str_len
;
1766 set_fnode_default (dtp
, &ff
, kind
);
1768 if (f
->u
.real
.d
> 0)
1769 ff
.u
.real
.d
= f
->u
.real
.d
;
1770 ff
.format
= f
->format
;
1772 /* For FMT_G, Compensate for extra digits when using scale factor, d
1773 is not specified, and the magnitude is such that E editing
1775 if (f
->format
== FMT_G
)
1777 if (dtp
->u
.p
.scale_factor
> 0 && f
->u
.real
.d
== 0)
1783 if (f
->u
.real
.e
>= 0)
1784 ff
.u
.real
.e
= f
->u
.real
.e
;
1786 dtp
->u
.p
.g0_no_blanks
= 1;
1788 /* Precision for snprintf call. */
1789 int precision
= get_precision (dtp
, &ff
, source
, kind
);
1791 /* String buffer to hold final result. */
1792 result
= select_string (dtp
, &ff
, str_buf
, &res_len
, kind
);
1794 buffer
= select_buffer (dtp
, &ff
, precision
, buf_stack
, &buf_size
, kind
);
1796 get_float_string (dtp
, &ff
, source
, kind
, comp_d
, buffer
,
1797 precision
, buf_size
, result
, &flt_str_len
);
1798 write_float_string (dtp
, result
, flt_str_len
);
1800 dtp
->u
.p
.g0_no_blanks
= 0;
1801 if (buf_size
> BUF_STACK_SZ
)
1803 if (res_len
> BUF_STACK_SZ
)
1809 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1812 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1814 /* Set for no blanks so we get a string result with no leading
1815 blanks. We will pad left later. */
1816 dtp
->u
.p
.g0_no_blanks
= 1;
1819 char buf_stack
[BUF_STACK_SZ
];
1820 char str1_buf
[BUF_STACK_SZ
];
1821 char str2_buf
[BUF_STACK_SZ
];
1822 char *buffer
, *result1
, *result2
;
1823 size_t buf_size
, res_len1
, res_len2
, flt_str_len1
, flt_str_len2
;
1824 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1826 dtp
->u
.p
.scale_factor
= 1;
1827 set_fnode_default (dtp
, &f
, kind
);
1829 /* Set width for two values, parenthesis, and comma. */
1830 width
= 2 * f
.u
.real
.w
+ 3;
1832 /* Set for no blanks so we get a string result with no leading
1833 blanks. We will pad left later. */
1834 dtp
->u
.p
.g0_no_blanks
= 1;
1836 /* Precision for snprintf call. */
1837 int precision
= get_precision (dtp
, &f
, source
, kind
);
1839 /* String buffers to hold final result. */
1840 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1841 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1843 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1845 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1846 precision
, buf_size
, result1
, &flt_str_len1
);
1847 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1848 precision
, buf_size
, result2
, &flt_str_len2
);
1849 if (!dtp
->u
.p
.namelist_mode
)
1851 lblanks
= width
- flt_str_len1
- flt_str_len2
- 3;
1852 write_x (dtp
, lblanks
, lblanks
);
1854 write_char (dtp
, '(');
1855 write_float_string (dtp
, result1
, flt_str_len1
);
1856 write_char (dtp
, semi_comma
);
1857 write_float_string (dtp
, result2
, flt_str_len2
);
1858 write_char (dtp
, ')');
1860 dtp
->u
.p
.scale_factor
= orig_scale
;
1861 dtp
->u
.p
.g0_no_blanks
= 0;
1862 if (buf_size
> BUF_STACK_SZ
)
1864 if (res_len1
> BUF_STACK_SZ
)
1866 if (res_len2
> BUF_STACK_SZ
)
1871 /* Write the separator between items. */
1874 write_separator (st_parameter_dt
*dtp
)
1878 p
= write_block (dtp
, options
.separator_len
);
1881 if (unlikely (is_char4_unit (dtp
)))
1883 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1884 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1887 memcpy (p
, options
.separator
, options
.separator_len
);
1891 /* Write an item with list formatting.
1892 TODO: handle skipping to the next record correctly, particularly
1896 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1899 if (dtp
->u
.p
.current_unit
== NULL
)
1902 if (dtp
->u
.p
.first_item
)
1904 dtp
->u
.p
.first_item
= 0;
1905 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1906 write_char (dtp
, ' ');
1910 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1911 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1912 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1913 write_separator (dtp
);
1919 write_integer (dtp
, p
, kind
);
1922 write_logical (dtp
, p
, kind
);
1925 write_character (dtp
, p
, kind
, size
, DELIM
);
1928 write_real (dtp
, p
, kind
);
1931 write_complex (dtp
, p
, kind
, size
);
1935 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1936 char iotype
[] = "LISTDIRECTED";
1937 gfc_charlen_type iotype_len
= 12;
1938 char tmp_iomsg
[IOMSG_LEN
] = "";
1940 gfc_charlen_type child_iomsg_len
;
1942 int *child_iostat
= NULL
;
1943 gfc_full_array_i4 vlist
;
1945 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1946 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1948 /* Set iostat, intent(out). */
1950 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1951 dtp
->common
.iostat
: &noiostat
;
1953 /* Set iomsge, intent(inout). */
1954 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1956 child_iomsg
= dtp
->common
.iomsg
;
1957 child_iomsg_len
= dtp
->common
.iomsg_len
;
1961 child_iomsg
= tmp_iomsg
;
1962 child_iomsg_len
= IOMSG_LEN
;
1965 /* Call the user defined formatted WRITE procedure. */
1966 dtp
->u
.p
.current_unit
->child_dtio
++;
1967 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1968 child_iostat
, child_iomsg
,
1969 iotype_len
, child_iomsg_len
);
1970 dtp
->u
.p
.current_unit
->child_dtio
--;
1974 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1977 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1978 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1983 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1984 size_t size
, size_t nelems
)
1988 size_t stride
= type
== BT_CHARACTER
?
1989 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1993 /* Big loop over all the elements. */
1994 for (elem
= 0; elem
< nelems
; elem
++)
1996 dtp
->u
.p
.item_count
++;
1997 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
2003 nml_write_obj writes a namelist object to the output stream. It is called
2004 recursively for derived type components:
2005 obj = is the namelist_info for the current object.
2006 offset = the offset relative to the address held by the object for
2007 derived type arrays.
2008 base = is the namelist_info of the derived type, when obj is a
2010 base_name = the full name for a derived type, including qualifiers
2012 The returned value is a pointer to the object beyond the last one
2013 accessed, including nested derived types. Notice that the namelist is
2014 a linear linked list of objects, including derived types and their
2015 components. A tree, of sorts, is implied by the compound names of
2016 the derived type components and this is how this function recurses through
2019 /* A generous estimate of the number of characters needed to print
2020 repeat counts and indices, including commas, asterices and brackets. */
2022 #define NML_DIGITS 20
2025 namelist_write_newline (st_parameter_dt
*dtp
)
2027 if (!is_internal_unit (dtp
))
2030 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
2032 write_character (dtp
, "\n", 1, 1, NODELIM
);
2037 if (is_array_io (dtp
))
2042 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
2044 p
= write_block (dtp
, length
);
2048 if (unlikely (is_char4_unit (dtp
)))
2050 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
2051 memset4 (p4
, ' ', length
);
2054 memset (p
, ' ', length
);
2056 /* Now that the current record has been padded out,
2057 determine where the next record in the array is. */
2058 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2061 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2064 /* Now seek to this record */
2065 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2067 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2069 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2073 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2077 write_character (dtp
, " ", 1, 1, NODELIM
);
2081 static namelist_info
*
2082 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2083 namelist_info
*base
, char *base_name
)
2089 index_type obj_size
;
2093 index_type elem_ctr
;
2094 size_t obj_name_len
;
2100 size_t ext_name_len
;
2101 char rep_buff
[NML_DIGITS
];
2103 namelist_info
*retval
= obj
->next
;
2104 size_t base_name_len
;
2105 size_t base_var_name_len
;
2108 /* Set the character to be used to separate values
2109 to a comma or semi-colon. */
2112 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2114 /* Write namelist variable names in upper case. If a derived type,
2115 nothing is output. If a component, base and base_name are set. */
2117 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2119 namelist_write_newline (dtp
);
2120 write_character (dtp
, " ", 1, 1, NODELIM
);
2125 len
= strlen (base
->var_name
);
2126 base_name_len
= strlen (base_name
);
2127 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2129 cup
= safe_toupper (base_name
[dim_i
]);
2130 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2133 clen
= strlen (obj
->var_name
);
2134 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2136 cup
= safe_toupper (obj
->var_name
[dim_i
]);
2139 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2141 write_character (dtp
, "=", 1, 1, NODELIM
);
2144 /* Counts the number of data output on a line, including names. */
2154 obj_size
= size_from_real_kind (len
);
2158 obj_size
= size_from_complex_kind (len
);
2162 obj_size
= obj
->string_length
;
2170 obj_size
= obj
->size
;
2172 /* Set the index vector and count the number of elements. */
2175 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2177 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2178 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2181 /* Main loop to output the data held in the object. */
2184 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2187 /* Build the pointer to the data value. The offset is passed by
2188 recursive calls to this function for arrays of derived types.
2189 Is NULL otherwise. */
2191 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2194 /* Check for repeat counts of intrinsic types. */
2196 if ((elem_ctr
< (nelem
- 1)) &&
2197 (obj
->type
!= BT_DERIVED
) &&
2198 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2203 /* Execute a repeated output. Note the flag no_leading_blank that
2204 is used in the functions used to output the intrinsic types. */
2210 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2211 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2212 dtp
->u
.p
.no_leading_blank
= 1;
2216 /* Output the data, if an intrinsic type, or recurse into this
2217 routine to treat derived types. */
2223 write_integer (dtp
, p
, len
);
2227 write_logical (dtp
, p
, len
);
2231 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2232 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2234 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2238 write_real (dtp
, p
, len
);
2242 dtp
->u
.p
.no_leading_blank
= 0;
2244 write_complex (dtp
, p
, len
, obj_size
);
2249 /* To treat a derived type, we need to build two strings:
2250 ext_name = the name, including qualifiers that prepends
2251 component names in the output - passed to
2253 obj_name = the derived type name with no qualifiers but %
2254 appended. This is used to identify the
2257 /* First ext_name => get length of all possible components */
2258 if (obj
->dtio_sub
!= NULL
)
2260 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2261 char iotype
[] = "NAMELIST";
2262 gfc_charlen_type iotype_len
= 8;
2263 char tmp_iomsg
[IOMSG_LEN
] = "";
2265 gfc_charlen_type child_iomsg_len
;
2267 int *child_iostat
= NULL
;
2268 gfc_full_array_i4 vlist
;
2269 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2271 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2273 /* Set iostat, intent(out). */
2275 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2276 dtp
->common
.iostat
: &noiostat
;
2278 /* Set iomsg, intent(inout). */
2279 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2281 child_iomsg
= dtp
->common
.iomsg
;
2282 child_iomsg_len
= dtp
->common
.iomsg_len
;
2286 child_iomsg
= tmp_iomsg
;
2287 child_iomsg_len
= IOMSG_LEN
;
2290 /* Call the user defined formatted WRITE procedure. */
2291 dtp
->u
.p
.current_unit
->child_dtio
++;
2292 if (obj
->type
== BT_DERIVED
)
2294 /* Build a class container. */
2297 list_obj
.vptr
= obj
->vtable
;
2299 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2300 child_iostat
, child_iomsg
,
2301 iotype_len
, child_iomsg_len
);
2305 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2306 child_iostat
, child_iomsg
,
2307 iotype_len
, child_iomsg_len
);
2309 dtp
->u
.p
.current_unit
->child_dtio
--;
2314 base_name_len
= base_name
? strlen (base_name
) : 0;
2315 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2316 ext_name_len
= base_name_len
+ base_var_name_len
2317 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2318 ext_name
= xmalloc (ext_name_len
);
2321 memcpy (ext_name
, base_name
, base_name_len
);
2322 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2323 memcpy (ext_name
+ base_name_len
,
2324 obj
->var_name
+ base_var_name_len
, clen
);
2326 /* Append the qualifier. */
2328 tot_len
= base_name_len
+ clen
;
2329 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2333 ext_name
[tot_len
] = '(';
2336 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2337 (int) obj
->ls
[dim_i
].idx
);
2338 tot_len
+= strlen (ext_name
+ tot_len
);
2339 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2343 ext_name
[tot_len
] = '\0';
2344 for (q
= ext_name
; *q
; q
++)
2350 obj_name_len
= strlen (obj
->var_name
) + 1;
2351 obj_name
= xmalloc (obj_name_len
+ 1);
2352 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2353 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2355 /* Now loop over the components. Update the component pointer
2356 with the return value from nml_write_obj => this loop jumps
2357 past nested derived types. */
2359 for (cmp
= obj
->next
;
2360 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2363 retval
= nml_write_obj (dtp
, cmp
,
2364 (index_type
)(p
- obj
->mem_pos
),
2373 internal_error (&dtp
->common
, "Bad type for namelist write");
2376 /* Reset the leading blank suppression, write a comma (or semi-colon)
2377 and, if 5 values have been output, write a newline and advance
2378 to column 2. Reset the repeat counter. */
2380 dtp
->u
.p
.no_leading_blank
= 0;
2381 if (obj
->type
== BT_CHARACTER
)
2383 if (dtp
->u
.p
.nml_delim
!= '\0')
2384 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2387 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2391 if (dtp
->u
.p
.nml_delim
== '\0')
2392 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2393 namelist_write_newline (dtp
);
2394 write_character (dtp
, " ", 1, 1, NODELIM
);
2399 /* Cycle through and increment the index vector. */
2404 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2406 obj
->ls
[dim_i
].idx
+= nml_carry
;
2408 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2410 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2416 /* Return a pointer beyond the furthest object accessed. */
2422 /* This is the entry function for namelist writes. It outputs the name
2423 of the namelist and iterates through the namelist by calls to
2424 nml_write_obj. The call below has dummys in the arguments used in
2425 the treatment of derived types. */
2428 namelist_write (st_parameter_dt
*dtp
)
2430 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2431 index_type dummy_offset
= 0;
2433 char *dummy_name
= NULL
;
2435 /* Set the delimiter for namelist output. */
2436 switch (dtp
->u
.p
.current_unit
->delim_status
)
2438 case DELIM_APOSTROPHE
:
2439 dtp
->u
.p
.nml_delim
= '\'';
2442 case DELIM_UNSPECIFIED
:
2443 dtp
->u
.p
.nml_delim
= '"';
2446 dtp
->u
.p
.nml_delim
= '\0';
2449 write_character (dtp
, "&", 1, 1, NODELIM
);
2451 /* Write namelist name in upper case - f95 std. */
2452 for (gfc_charlen_type i
= 0; i
< dtp
->namelist_name_len
; i
++ )
2454 c
= safe_toupper (dtp
->namelist_name
[i
]);
2455 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2458 if (dtp
->u
.p
.ionml
!= NULL
)
2460 t1
= dtp
->u
.p
.ionml
;
2464 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2468 namelist_write_newline (dtp
);
2469 write_character (dtp
, " /", 1, 2, NODELIM
);