1 /* Copyright (C) 2002-2024 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
;
651 # ifdef HAVE_GFC_REAL_17
654 GFC_INTEGER_16 tmp
= 0;
655 memcpy ((void *) &tmp
, p
, 16);
656 i
= (GFC_UINTEGER_16
) tmp
;
662 internal_error (NULL
, "bad integer kind");
670 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
674 GFC_INTEGER_LARGEST n
;
676 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
678 p
= write_block (dtp
, wlen
);
682 n
= extract_int (source
, len
);
684 if (unlikely (is_char4_unit (dtp
)))
686 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
687 memset4 (p4
, ' ', wlen
-1);
688 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
692 memset (p
, ' ', wlen
-1);
693 p
[wlen
- 1] = (n
) ? 'T' : 'F';
697 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
, int len
)
699 int w
, m
, digits
, nzero
, nblank
;
707 if (m
== 0 && n
== 0)
712 p
= write_block (dtp
, w
);
715 if (unlikely (is_char4_unit (dtp
)))
717 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
718 memset4 (p4
, ' ', w
);
727 /* Select a width if none was specified. The idea here is to always
730 if (w
== DEFAULT_WIDTH
)
731 w
= default_width_for_integer (len
);
734 w
= ((digits
< m
) ? m
: digits
);
736 p
= write_block (dtp
, w
);
744 /* See if things will work. */
746 nblank
= w
- (nzero
+ digits
);
748 if (unlikely (is_char4_unit (dtp
)))
750 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
753 memset4 (p4
, '*', w
);
757 if (!dtp
->u
.p
.no_leading_blank
)
759 memset4 (p4
, ' ', nblank
);
761 memset4 (p4
, '0', nzero
);
763 memcpy4 (p4
, q
, digits
);
767 memset4 (p4
, '0', nzero
);
769 memcpy4 (p4
, q
, digits
);
771 memset4 (p4
, ' ', nblank
);
772 dtp
->u
.p
.no_leading_blank
= 0;
783 if (!dtp
->u
.p
.no_leading_blank
)
785 memset (p
, ' ', nblank
);
787 memset (p
, '0', nzero
);
789 memcpy (p
, q
, digits
);
793 memset (p
, '0', nzero
);
795 memcpy (p
, q
, digits
);
797 memset (p
, ' ', nblank
);
798 dtp
->u
.p
.no_leading_blank
= 0;
806 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
809 GFC_INTEGER_LARGEST n
= 0;
810 GFC_UINTEGER_LARGEST absn
;
811 int w
, m
, digits
, nsign
, nzero
, nblank
;
815 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
818 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
820 n
= extract_int (source
, len
);
823 if (m
== 0 && n
== 0)
828 p
= write_block (dtp
, w
);
831 if (unlikely (is_char4_unit (dtp
)))
833 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
834 memset4 (p4
, ' ', w
);
841 sign
= calculate_sign (dtp
, n
< 0);
843 /* Use unsigned to protect from overflow. */
844 absn
= -(GFC_UINTEGER_LARGEST
) n
;
847 nsign
= sign
== S_NONE
? 0 : 1;
849 /* gfc_itoa() converts the nonnegative value to decimal representation. */
850 q
= gfc_itoa (absn
, itoa_buf
, sizeof (itoa_buf
));
853 /* Select a width if none was specified. The idea here is to always
855 if (w
== DEFAULT_WIDTH
)
856 w
= default_width_for_integer (len
);
859 w
= ((digits
< m
) ? m
: digits
) + nsign
;
861 p
= write_block (dtp
, w
);
869 /* See if things will work. */
871 nblank
= w
- (nsign
+ nzero
+ digits
);
873 if (unlikely (is_char4_unit (dtp
)))
875 gfc_char4_t
*p4
= (gfc_char4_t
*)p
;
878 memset4 (p4
, '*', w
);
882 if (!dtp
->u
.p
.namelist_mode
)
884 memset4 (p4
, ' ', nblank
);
900 memset4 (p4
, '0', nzero
);
903 memcpy4 (p4
, q
, digits
);
906 if (dtp
->u
.p
.namelist_mode
)
909 memset4 (p4
, ' ', nblank
);
919 if (!dtp
->u
.p
.namelist_mode
)
921 memset (p
, ' ', nblank
);
937 memset (p
, '0', nzero
);
940 memcpy (p
, q
, digits
);
942 if (dtp
->u
.p
.namelist_mode
)
945 memset (p
, ' ', nblank
);
953 /* Convert hexadecimal to ASCII. */
956 xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
961 assert (len
>= GFC_XTOA_BUF_SIZE
);
966 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
973 digit
+= 'A' - '0' - 10;
983 /* Convert unsigned octal to ASCII. */
986 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
990 assert (len
>= GFC_OTOA_BUF_SIZE
);
995 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1000 *--p
= '0' + (n
& 7);
1008 /* Convert unsigned binary to ASCII. */
1011 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
1015 assert (len
>= GFC_BTOA_BUF_SIZE
);
1020 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
1025 *--p
= '0' + (n
& 1);
1032 /* The following three functions, btoa_big, otoa_big, and xtoa_big, are needed
1033 to convert large reals with kind sizes that exceed the largest integer type
1034 available on certain platforms. In these cases, byte by byte conversion is
1035 performed. Endianess is taken into account. */
1037 /* Conversion to binary. */
1040 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1046 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1049 for (i
= 0; i
< len
; i
++)
1053 /* Test for zero. Needed by write_boz later. */
1057 for (j
= 0; j
< 8; j
++)
1059 *q
++ = (c
& 128) ? '1' : '0';
1067 const char *p
= s
+ len
- 1;
1068 for (i
= 0; i
< len
; i
++)
1072 /* Test for zero. Needed by write_boz later. */
1076 for (j
= 0; j
< 8; j
++)
1078 *q
++ = (c
& 128) ? '1' : '0';
1088 /* Move past any leading zeros. */
1089 while (*buffer
== '0')
1096 /* Conversion to octal. */
1099 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1105 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1109 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1111 const char *p
= s
+ len
- 1;
1115 /* Test for zero. Needed by write_boz later. */
1119 for (j
= 0; j
< 3 && i
< len
; j
++)
1121 octet
|= (c
& 1) << j
;
1140 /* Test for zero. Needed by write_boz later. */
1144 for (j
= 0; j
< 3 && i
< len
; j
++)
1146 octet
|= (c
& 1) << j
;
1163 /* Move past any leading zeros. */
1170 /* Conversion to hexadecimal. */
1173 xtoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1175 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
1176 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1182 /* write_z, which calls xtoa_big, is called from transfer.c,
1183 formatted_transfer_scalar_write. There it is passed the kind as
1184 'len' argument, which means a maximum of 16. The buffer is large
1185 enough, but the compiler does not know that, so shut up the
1189 __builtin_unreachable ();
1193 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1196 for (i
= 0; i
< len
; i
++)
1198 /* Test for zero. Needed by write_boz later. */
1202 h
= (*p
>> 4) & 0x0F;
1210 const char *p
= s
+ len
- 1;
1211 for (i
= 0; i
< len
; i
++)
1213 /* Test for zero. Needed by write_boz later. */
1217 h
= (*p
>> 4) & 0x0F;
1229 /* Move past any leading zeros. */
1230 while (*buffer
== '0')
1238 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1240 write_decimal (dtp
, f
, p
, len
);
1245 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1248 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1249 GFC_UINTEGER_LARGEST n
= 0;
1251 /* Ensure we end up with a null terminated string. */
1252 memset(itoa_buf
, '\0', GFC_BTOA_BUF_SIZE
);
1254 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1256 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1257 write_boz (dtp
, f
, p
, n
, len
);
1261 n
= extract_uint (source
, len
);
1262 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1263 write_boz (dtp
, f
, p
, n
, len
);
1269 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1272 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1273 GFC_UINTEGER_LARGEST n
= 0;
1275 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1277 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1278 write_boz (dtp
, f
, p
, n
, len
);
1282 n
= extract_uint (source
, len
);
1283 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1284 write_boz (dtp
, f
, p
, n
, len
);
1289 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1292 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1293 GFC_UINTEGER_LARGEST n
= 0;
1295 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1297 p
= xtoa_big (source
, itoa_buf
, len
, &n
);
1298 write_boz (dtp
, f
, p
, n
, len
);
1302 n
= extract_uint (source
, len
);
1303 p
= xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1304 write_boz (dtp
, f
, p
, n
, len
);
1308 /* Take care of the X/TR descriptor. */
1311 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1315 p
= write_block (dtp
, len
);
1318 if (nspaces
> 0 && len
- nspaces
>= 0)
1320 if (unlikely (is_char4_unit (dtp
)))
1322 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1323 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1326 memset (&p
[len
- nspaces
], ' ', nspaces
);
1331 /* List-directed writing. */
1334 /* Write a single character to the output. Returns nonzero if
1335 something goes wrong. */
1338 write_char (st_parameter_dt
*dtp
, int c
)
1342 p
= write_block (dtp
, 1);
1345 if (unlikely (is_char4_unit (dtp
)))
1347 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1358 /* Write a list-directed logical value. */
1361 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1363 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1367 /* Write a list-directed integer value. */
1370 write_integer (st_parameter_dt
*dtp
, const char *source
, int kind
)
1401 f
.u
.integer
.w
= width
;
1403 f
.format
= FMT_NONE
;
1404 write_decimal (dtp
, &f
, source
, kind
);
1408 /* Write a list-directed string. We have to worry about delimiting
1409 the strings if the file has been opened in that mode. */
1415 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t length
, int mode
)
1422 switch (dtp
->u
.p
.current_unit
->delim_status
)
1424 case DELIM_APOSTROPHE
:
1446 for (size_t i
= 0; i
< length
; i
++)
1451 p
= write_block (dtp
, length
+ extra
);
1455 if (unlikely (is_char4_unit (dtp
)))
1457 gfc_char4_t d4
= (gfc_char4_t
) d
;
1458 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1461 memcpy4 (p4
, source
, length
);
1466 for (size_t i
= 0; i
< length
; i
++)
1468 *p4
++ = (gfc_char4_t
) source
[i
];
1479 memcpy (p
, source
, length
);
1484 for (size_t i
= 0; i
< length
; i
++)
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);
1505 p
= write_block (dtp
, 1);
1508 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1509 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1511 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1513 p
= write_block (dtp
, 1);
1519 /* Floating point helper functions. */
1521 #define BUF_STACK_SZ 384
1524 get_precision (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1526 if (f
->format
!= FMT_EN
)
1527 return determine_precision (dtp
, f
, kind
);
1529 return determine_en_precision (dtp
, f
, source
, kind
);
1532 /* 4932 is the maximum exponent of long double and quad precision, 3
1533 extra characters for the sign, the decimal point, and the
1534 trailing null. Extra digits are added by the calling functions for
1535 requested precision. Likewise for float and double. F0 editing produces
1536 full precision output. */
1538 size_from_kind (st_parameter_dt
*dtp
, const fnode
*f
, int kind
)
1542 if ((f
->format
== FMT_F
&& f
->u
.real
.w
== 0) || f
->u
.real
.w
== DEFAULT_WIDTH
)
1547 size
= 38 + 3; /* These constants shown for clarity. */
1556 #ifdef HAVE_GFC_REAL_17
1562 internal_error (&dtp
->common
, "bad real kind");
1567 size
= f
->u
.real
.w
+ 1; /* One byte for a NULL character. */
1573 select_buffer (st_parameter_dt
*dtp
, const fnode
*f
, int precision
,
1574 char *buf
, size_t *size
, int kind
)
1578 /* The buffer needs at least one more byte to allow room for
1579 normalizing and 1 to hold null terminator. */
1580 *size
= size_from_kind (dtp
, f
, kind
) + precision
+ 1 + 1;
1582 if (*size
> BUF_STACK_SZ
)
1583 result
= xmalloc (*size
);
1590 select_string (st_parameter_dt
*dtp
, const fnode
*f
, char *buf
, size_t *size
,
1594 *size
= size_from_kind (dtp
, f
, kind
) + f
->u
.real
.d
+ 1;
1595 if (*size
> BUF_STACK_SZ
)
1596 result
= xmalloc (*size
);
1603 write_float_string (st_parameter_dt
*dtp
, char *fstr
, size_t len
)
1605 char *p
= write_block (dtp
, len
);
1609 if (unlikely (is_char4_unit (dtp
)))
1611 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1612 memcpy4 (p4
, fstr
, len
);
1615 memcpy (p
, fstr
, len
);
1620 write_float_0 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1622 char buf_stack
[BUF_STACK_SZ
];
1623 char str_buf
[BUF_STACK_SZ
];
1624 char *buffer
, *result
;
1625 size_t buf_size
, res_len
, flt_str_len
;
1627 /* Precision for snprintf call. */
1628 int precision
= get_precision (dtp
, f
, source
, kind
);
1630 /* String buffer to hold final result. */
1631 result
= select_string (dtp
, f
, str_buf
, &res_len
, kind
);
1633 buffer
= select_buffer (dtp
, f
, precision
, buf_stack
, &buf_size
, kind
);
1635 get_float_string (dtp
, f
, source
, kind
, 0, buffer
,
1636 precision
, buf_size
, result
, &flt_str_len
);
1637 write_float_string (dtp
, result
, flt_str_len
);
1639 if (buf_size
> BUF_STACK_SZ
)
1641 if (res_len
> BUF_STACK_SZ
)
1646 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1648 write_float_0 (dtp
, f
, p
, len
);
1653 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1655 write_float_0 (dtp
, f
, p
, len
);
1660 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1662 write_float_0 (dtp
, f
, p
, len
);
1667 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1669 write_float_0 (dtp
, f
, p
, len
);
1674 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1676 write_float_0 (dtp
, f
, p
, len
);
1680 /* Set an fnode to default format. */
1683 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1704 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1705 #if GFC_REAL_16_DIGITS == 113
1715 #ifdef HAVE_GFC_REAL_17
1723 internal_error (&dtp
->common
, "bad real kind");
1728 /* Output a real number with default format.
1729 To guarantee that a binary -> decimal -> binary roundtrip conversion
1730 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1731 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1732 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1733 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1734 Fortran standard requires outputting an extra digit when the scale
1735 factor is 1 and when the magnitude of the value is such that E
1736 editing is used. However, gfortran compensates for this, and thus
1737 for list formatted the same number of significant digits is
1738 generated both when using F and E editing. */
1741 write_real (st_parameter_dt
*dtp
, const char *source
, int kind
)
1744 char buf_stack
[BUF_STACK_SZ
];
1745 char str_buf
[BUF_STACK_SZ
];
1746 char *buffer
, *result
;
1747 size_t buf_size
, res_len
, flt_str_len
;
1748 int orig_scale
= dtp
->u
.p
.scale_factor
;
1749 dtp
->u
.p
.scale_factor
= 1;
1750 set_fnode_default (dtp
, &f
, kind
);
1752 /* Precision for snprintf call. */
1753 int precision
= get_precision (dtp
, &f
, source
, kind
);
1755 /* String buffer to hold final result. */
1756 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1758 /* Scratch buffer to hold final result. */
1759 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1761 get_float_string (dtp
, &f
, source
, kind
, 1, buffer
,
1762 precision
, buf_size
, result
, &flt_str_len
);
1763 write_float_string (dtp
, result
, flt_str_len
);
1765 dtp
->u
.p
.scale_factor
= orig_scale
;
1766 if (buf_size
> BUF_STACK_SZ
)
1768 if (res_len
> BUF_STACK_SZ
)
1772 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1773 compensate for the extra digit. */
1776 write_real_w0 (st_parameter_dt
*dtp
, const char *source
, int kind
,
1780 char buf_stack
[BUF_STACK_SZ
];
1781 char str_buf
[BUF_STACK_SZ
];
1782 char *buffer
, *result
;
1783 size_t buf_size
, res_len
, flt_str_len
;
1786 set_fnode_default (dtp
, &ff
, kind
);
1788 ff
.format
= f
->format
;
1790 /* For FMT_G, Compensate for extra digits when using scale factor, d
1791 is not specified, and the magnitude is such that E editing
1793 if (f
->format
== FMT_G
)
1795 if (f
->u
.real
.d
> 0)
1796 ff
.u
.real
.d
= f
->u
.real
.d
;
1797 if (dtp
->u
.p
.scale_factor
> 0 && f
->u
.real
.d
== 0)
1803 if (f
->u
.real
.d
>= 0)
1804 ff
.u
.real
.d
= f
->u
.real
.d
;
1807 if (f
->u
.real
.e
>= 0)
1808 ff
.u
.real
.e
= f
->u
.real
.e
;
1810 dtp
->u
.p
.g0_no_blanks
= 1;
1812 /* Precision for snprintf call. */
1813 int precision
= get_precision (dtp
, &ff
, source
, kind
);
1815 /* String buffer to hold final result. */
1816 result
= select_string (dtp
, &ff
, str_buf
, &res_len
, kind
);
1818 buffer
= select_buffer (dtp
, &ff
, precision
, buf_stack
, &buf_size
, kind
);
1820 get_float_string (dtp
, &ff
, source
, kind
, comp_d
, buffer
,
1821 precision
, buf_size
, result
, &flt_str_len
);
1822 write_float_string (dtp
, result
, flt_str_len
);
1824 dtp
->u
.p
.g0_no_blanks
= 0;
1825 if (buf_size
> BUF_STACK_SZ
)
1827 if (res_len
> BUF_STACK_SZ
)
1833 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1836 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1838 /* Set for no blanks so we get a string result with no leading
1839 blanks. We will pad left later. */
1840 dtp
->u
.p
.g0_no_blanks
= 1;
1843 char buf_stack
[BUF_STACK_SZ
];
1844 char str1_buf
[BUF_STACK_SZ
];
1845 char str2_buf
[BUF_STACK_SZ
];
1846 char *buffer
, *result1
, *result2
;
1847 size_t buf_size
, res_len1
, res_len2
, flt_str_len1
, flt_str_len2
;
1848 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1850 dtp
->u
.p
.scale_factor
= 1;
1851 set_fnode_default (dtp
, &f
, kind
);
1853 /* Set width for two values, parenthesis, and comma. */
1854 width
= 2 * f
.u
.real
.w
+ 3;
1856 /* Set for no blanks so we get a string result with no leading
1857 blanks. We will pad left later. */
1858 dtp
->u
.p
.g0_no_blanks
= 1;
1860 /* Precision for snprintf call. */
1861 int precision
= get_precision (dtp
, &f
, source
, kind
);
1863 /* String buffers to hold final result. */
1864 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1865 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1867 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1869 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1870 precision
, buf_size
, result1
, &flt_str_len1
);
1871 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1872 precision
, buf_size
, result2
, &flt_str_len2
);
1873 if (!dtp
->u
.p
.namelist_mode
)
1875 lblanks
= width
- flt_str_len1
- flt_str_len2
- 3;
1876 write_x (dtp
, lblanks
, lblanks
);
1878 write_char (dtp
, '(');
1879 write_float_string (dtp
, result1
, flt_str_len1
);
1880 write_char (dtp
, semi_comma
);
1881 write_float_string (dtp
, result2
, flt_str_len2
);
1882 write_char (dtp
, ')');
1884 dtp
->u
.p
.scale_factor
= orig_scale
;
1885 dtp
->u
.p
.g0_no_blanks
= 0;
1886 if (buf_size
> BUF_STACK_SZ
)
1888 if (res_len1
> BUF_STACK_SZ
)
1890 if (res_len2
> BUF_STACK_SZ
)
1895 /* Write the separator between items. */
1898 write_separator (st_parameter_dt
*dtp
)
1902 p
= write_block (dtp
, options
.separator_len
);
1905 if (unlikely (is_char4_unit (dtp
)))
1907 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1908 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1911 memcpy (p
, options
.separator
, options
.separator_len
);
1915 /* Write an item with list formatting.
1916 TODO: handle skipping to the next record correctly, particularly
1920 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1923 if (dtp
->u
.p
.current_unit
== NULL
)
1926 if (dtp
->u
.p
.first_item
)
1928 dtp
->u
.p
.first_item
= 0;
1929 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1930 write_char (dtp
, ' ');
1934 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1935 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1936 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1937 write_separator (dtp
);
1943 write_integer (dtp
, p
, kind
);
1946 write_logical (dtp
, p
, kind
);
1949 write_character (dtp
, p
, kind
, size
, DELIM
);
1952 write_real (dtp
, p
, kind
);
1955 write_complex (dtp
, p
, kind
, size
);
1959 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
1960 char iotype
[] = "LISTDIRECTED";
1961 gfc_charlen_type iotype_len
= 12;
1962 char tmp_iomsg
[IOMSG_LEN
] = "";
1964 gfc_charlen_type child_iomsg_len
;
1965 GFC_INTEGER_4 noiostat
;
1966 GFC_INTEGER_4
*child_iostat
= NULL
;
1967 gfc_full_array_i4 vlist
;
1969 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1970 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1972 /* Set iostat, intent(out). */
1974 child_iostat
= ((dtp
->common
.flags
& IOPARM_HAS_IOSTAT
)
1975 ? dtp
->common
.iostat
: &noiostat
);
1977 /* Set iomsge, intent(inout). */
1978 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1980 child_iomsg
= dtp
->common
.iomsg
;
1981 child_iomsg_len
= dtp
->common
.iomsg_len
;
1985 child_iomsg
= tmp_iomsg
;
1986 child_iomsg_len
= IOMSG_LEN
;
1989 /* Call the user defined formatted WRITE procedure. */
1990 dtp
->u
.p
.current_unit
->child_dtio
++;
1991 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1992 child_iostat
, child_iomsg
,
1993 iotype_len
, child_iomsg_len
);
1994 dtp
->u
.p
.child_saved_iostat
= *child_iostat
;
1995 dtp
->u
.p
.current_unit
->child_dtio
--;
1997 if ((dtp
->u
.p
.child_saved_iostat
!= 0) &&
1998 !(dtp
->common
.flags
& IOPARM_HAS_IOMSG
) &&
1999 !(dtp
->common
.flags
& IOPARM_HAS_IOSTAT
))
2001 char message
[IOMSG_LEN
+ 1];
2002 child_iomsg_len
= string_len_trim (IOMSG_LEN
, child_iomsg
);
2003 fstrcpy (message
, child_iomsg_len
, child_iomsg
, child_iomsg_len
);
2004 message
[child_iomsg_len
] = '\0';
2005 generate_error (&dtp
->common
, dtp
->u
.p
.child_saved_iostat
,
2011 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
2014 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
2015 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
2020 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2021 size_t size
, size_t nelems
)
2025 size_t stride
= type
== BT_CHARACTER
?
2026 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2030 /* Big loop over all the elements. */
2031 for (elem
= 0; elem
< nelems
; elem
++)
2033 dtp
->u
.p
.item_count
++;
2034 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
2040 nml_write_obj writes a namelist object to the output stream. It is called
2041 recursively for derived type components:
2042 obj = is the namelist_info for the current object.
2043 offset = the offset relative to the address held by the object for
2044 derived type arrays.
2045 base = is the namelist_info of the derived type, when obj is a
2047 base_name = the full name for a derived type, including qualifiers
2049 The returned value is a pointer to the object beyond the last one
2050 accessed, including nested derived types. Notice that the namelist is
2051 a linear linked list of objects, including derived types and their
2052 components. A tree, of sorts, is implied by the compound names of
2053 the derived type components and this is how this function recurses through
2056 /* A generous estimate of the number of characters needed to print
2057 repeat counts and indices, including commas, asterices and brackets. */
2059 #define NML_DIGITS 20
2062 namelist_write_newline (st_parameter_dt
*dtp
)
2064 if (!is_internal_unit (dtp
))
2067 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
2069 write_character (dtp
, "\n", 1, 1, NODELIM
);
2074 if (is_array_io (dtp
))
2079 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
2081 p
= write_block (dtp
, length
);
2085 if (unlikely (is_char4_unit (dtp
)))
2087 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
2088 memset4 (p4
, ' ', length
);
2091 memset (p
, ' ', length
);
2093 /* Now that the current record has been padded out,
2094 determine where the next record in the array is. */
2095 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2098 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2101 /* Now seek to this record */
2102 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2104 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2106 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2110 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2114 write_character (dtp
, " ", 1, 1, NODELIM
);
2118 static namelist_info
*
2119 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2120 namelist_info
*base
, char *base_name
)
2126 index_type obj_size
;
2130 index_type elem_ctr
;
2131 size_t obj_name_len
;
2137 size_t ext_name_len
;
2138 char rep_buff
[NML_DIGITS
];
2140 namelist_info
*retval
= obj
->next
;
2141 size_t base_name_len
;
2142 size_t base_var_name_len
;
2145 /* Set the character to be used to separate values
2146 to a comma or semi-colon. */
2149 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2151 /* Write namelist variable names in upper case. If a derived type,
2152 nothing is output. If a component, base and base_name are set. */
2154 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2156 namelist_write_newline (dtp
);
2157 write_character (dtp
, " ", 1, 1, NODELIM
);
2162 len
= strlen (base
->var_name
);
2163 base_name_len
= strlen (base_name
);
2164 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2166 cup
= safe_toupper (base_name
[dim_i
]);
2167 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2170 clen
= strlen (obj
->var_name
);
2171 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2173 cup
= safe_toupper (obj
->var_name
[dim_i
]);
2176 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2178 write_character (dtp
, "=", 1, 1, NODELIM
);
2181 /* Counts the number of data output on a line, including names. */
2191 obj_size
= size_from_real_kind (len
);
2195 obj_size
= size_from_complex_kind (len
);
2199 obj_size
= obj
->string_length
;
2207 obj_size
= obj
->size
;
2209 /* Set the index vector and count the number of elements. */
2212 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2214 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2215 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2218 /* Main loop to output the data held in the object. */
2221 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2224 /* Build the pointer to the data value. The offset is passed by
2225 recursive calls to this function for arrays of derived types.
2226 Is NULL otherwise. */
2228 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2231 /* Check for repeat counts of intrinsic types. */
2233 if ((elem_ctr
< (nelem
- 1)) &&
2234 (obj
->type
!= BT_DERIVED
) &&
2235 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2240 /* Execute a repeated output. Note the flag no_leading_blank that
2241 is used in the functions used to output the intrinsic types. */
2247 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2248 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2249 dtp
->u
.p
.no_leading_blank
= 1;
2253 /* Output the data, if an intrinsic type, or recurse into this
2254 routine to treat derived types. */
2260 write_integer (dtp
, p
, len
);
2264 write_logical (dtp
, p
, len
);
2268 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2269 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2271 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2275 write_real (dtp
, p
, len
);
2279 dtp
->u
.p
.no_leading_blank
= 0;
2281 write_complex (dtp
, p
, len
, obj_size
);
2286 /* To treat a derived type, we need to build two strings:
2287 ext_name = the name, including qualifiers that prepends
2288 component names in the output - passed to
2290 obj_name = the derived type name with no qualifiers but %
2291 appended. This is used to identify the
2294 /* First ext_name => get length of all possible components */
2295 if (obj
->dtio_sub
!= NULL
)
2297 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
2298 char iotype
[] = "NAMELIST";
2299 gfc_charlen_type iotype_len
= 8;
2300 char tmp_iomsg
[IOMSG_LEN
] = "";
2302 gfc_charlen_type child_iomsg_len
;
2303 GFC_INTEGER_4 noiostat
;
2304 GFC_INTEGER_4
*child_iostat
= NULL
;
2305 gfc_full_array_i4 vlist
;
2306 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2308 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2310 /* Set iostat, intent(out). */
2312 child_iostat
= ((dtp
->common
.flags
& IOPARM_HAS_IOSTAT
)
2313 ? dtp
->common
.iostat
: &noiostat
);
2315 /* Set iomsg, intent(inout). */
2316 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2318 child_iomsg
= dtp
->common
.iomsg
;
2319 child_iomsg_len
= dtp
->common
.iomsg_len
;
2323 child_iomsg
= tmp_iomsg
;
2324 child_iomsg_len
= IOMSG_LEN
;
2327 /* Call the user defined formatted WRITE procedure. */
2328 dtp
->u
.p
.current_unit
->child_dtio
++;
2329 if (obj
->type
== BT_DERIVED
)
2331 /* Build a class container. */
2334 list_obj
.vptr
= obj
->vtable
;
2336 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2337 child_iostat
, child_iomsg
,
2338 iotype_len
, child_iomsg_len
);
2342 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2343 child_iostat
, child_iomsg
,
2344 iotype_len
, child_iomsg_len
);
2346 dtp
->u
.p
.child_saved_iostat
= *child_iostat
;
2347 dtp
->u
.p
.current_unit
->child_dtio
--;
2349 if ((dtp
->u
.p
.child_saved_iostat
!= 0) &&
2350 !(dtp
->common
.flags
& IOPARM_HAS_IOMSG
) &&
2351 !(dtp
->common
.flags
& IOPARM_HAS_IOSTAT
))
2353 char message
[IOMSG_LEN
+ 1];
2355 /* Trim trailing spaces from the message. */
2356 child_iomsg_len
= string_len_trim (IOMSG_LEN
, child_iomsg
);
2357 fstrcpy (message
, child_iomsg_len
, child_iomsg
, child_iomsg_len
);
2358 message
[child_iomsg_len
] = '\0';
2359 generate_error (&dtp
->common
, dtp
->u
.p
.child_saved_iostat
,
2366 base_name_len
= base_name
? strlen (base_name
) : 0;
2367 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2368 ext_name_len
= base_name_len
+ base_var_name_len
2369 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2370 ext_name
= xmalloc (ext_name_len
);
2373 memcpy (ext_name
, base_name
, base_name_len
);
2374 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2375 memcpy (ext_name
+ base_name_len
,
2376 obj
->var_name
+ base_var_name_len
, clen
);
2378 /* Append the qualifier. */
2380 tot_len
= base_name_len
+ clen
;
2381 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2385 ext_name
[tot_len
] = '(';
2388 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2389 (int) obj
->ls
[dim_i
].idx
);
2390 tot_len
+= strlen (ext_name
+ tot_len
);
2391 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2395 ext_name
[tot_len
] = '\0';
2396 for (q
= ext_name
; *q
; q
++)
2402 obj_name_len
= strlen (obj
->var_name
) + 1;
2403 obj_name
= xmalloc (obj_name_len
+ 1);
2404 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2405 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2407 /* Now loop over the components. Update the component pointer
2408 with the return value from nml_write_obj => this loop jumps
2409 past nested derived types. */
2411 for (cmp
= obj
->next
;
2412 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2415 retval
= nml_write_obj (dtp
, cmp
,
2416 (index_type
)(p
- obj
->mem_pos
),
2425 internal_error (&dtp
->common
, "Bad type for namelist write");
2428 /* Reset the leading blank suppression, write a comma (or semi-colon)
2429 and, if 5 values have been output, write a newline and advance
2430 to column 2. Reset the repeat counter. */
2432 dtp
->u
.p
.no_leading_blank
= 0;
2433 if (obj
->type
== BT_CHARACTER
)
2435 if (dtp
->u
.p
.nml_delim
!= '\0')
2436 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2439 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2443 if (dtp
->u
.p
.nml_delim
== '\0')
2444 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2445 namelist_write_newline (dtp
);
2446 write_character (dtp
, " ", 1, 1, NODELIM
);
2451 /* Cycle through and increment the index vector. */
2456 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2458 obj
->ls
[dim_i
].idx
+= nml_carry
;
2460 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2462 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2468 /* Return a pointer beyond the furthest object accessed. */
2474 /* This is the entry function for namelist writes. It outputs the name
2475 of the namelist and iterates through the namelist by calls to
2476 nml_write_obj. The call below has dummys in the arguments used in
2477 the treatment of derived types. */
2480 namelist_write (st_parameter_dt
*dtp
)
2482 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2483 index_type dummy_offset
= 0;
2485 char *dummy_name
= NULL
;
2487 /* Set the delimiter for namelist output. */
2488 switch (dtp
->u
.p
.current_unit
->delim_status
)
2490 case DELIM_APOSTROPHE
:
2491 dtp
->u
.p
.nml_delim
= '\'';
2494 case DELIM_UNSPECIFIED
:
2495 dtp
->u
.p
.nml_delim
= '"';
2498 dtp
->u
.p
.nml_delim
= '\0';
2501 if (is_internal_unit (dtp
))
2502 write_character (dtp
, " ", 1, 1, NODELIM
);
2503 write_character (dtp
, "&", 1, 1, NODELIM
);
2505 /* Write namelist name in upper case - f95 std. */
2506 for (gfc_charlen_type i
= 0; i
< dtp
->namelist_name_len
; i
++ )
2508 c
= safe_toupper (dtp
->namelist_name
[i
]);
2509 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2512 if (dtp
->u
.p
.ionml
!= NULL
)
2514 t1
= dtp
->u
.p
.ionml
;
2518 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2522 namelist_write_newline (dtp
);
2523 write_character (dtp
, " /", 1, 2, NODELIM
);