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 if (f
->u
.real
.d
> 0)
1789 ff
.u
.real
.d
= f
->u
.real
.d
;
1790 ff
.format
= f
->format
;
1792 /* For FMT_G, Compensate for extra digits when using scale factor, d
1793 is not specified, and the magnitude is such that E editing
1795 if (f
->format
== FMT_G
)
1797 if (dtp
->u
.p
.scale_factor
> 0 && f
->u
.real
.d
== 0)
1803 if (f
->u
.real
.e
>= 0)
1804 ff
.u
.real
.e
= f
->u
.real
.e
;
1806 dtp
->u
.p
.g0_no_blanks
= 1;
1808 /* Precision for snprintf call. */
1809 int precision
= get_precision (dtp
, &ff
, source
, kind
);
1811 /* String buffer to hold final result. */
1812 result
= select_string (dtp
, &ff
, str_buf
, &res_len
, kind
);
1814 buffer
= select_buffer (dtp
, &ff
, precision
, buf_stack
, &buf_size
, kind
);
1816 get_float_string (dtp
, &ff
, source
, kind
, comp_d
, buffer
,
1817 precision
, buf_size
, result
, &flt_str_len
);
1818 write_float_string (dtp
, result
, flt_str_len
);
1820 dtp
->u
.p
.g0_no_blanks
= 0;
1821 if (buf_size
> BUF_STACK_SZ
)
1823 if (res_len
> BUF_STACK_SZ
)
1829 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1832 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1834 /* Set for no blanks so we get a string result with no leading
1835 blanks. We will pad left later. */
1836 dtp
->u
.p
.g0_no_blanks
= 1;
1839 char buf_stack
[BUF_STACK_SZ
];
1840 char str1_buf
[BUF_STACK_SZ
];
1841 char str2_buf
[BUF_STACK_SZ
];
1842 char *buffer
, *result1
, *result2
;
1843 size_t buf_size
, res_len1
, res_len2
, flt_str_len1
, flt_str_len2
;
1844 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1846 dtp
->u
.p
.scale_factor
= 1;
1847 set_fnode_default (dtp
, &f
, kind
);
1849 /* Set width for two values, parenthesis, and comma. */
1850 width
= 2 * f
.u
.real
.w
+ 3;
1852 /* Set for no blanks so we get a string result with no leading
1853 blanks. We will pad left later. */
1854 dtp
->u
.p
.g0_no_blanks
= 1;
1856 /* Precision for snprintf call. */
1857 int precision
= get_precision (dtp
, &f
, source
, kind
);
1859 /* String buffers to hold final result. */
1860 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1861 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1863 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1865 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1866 precision
, buf_size
, result1
, &flt_str_len1
);
1867 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1868 precision
, buf_size
, result2
, &flt_str_len2
);
1869 if (!dtp
->u
.p
.namelist_mode
)
1871 lblanks
= width
- flt_str_len1
- flt_str_len2
- 3;
1872 write_x (dtp
, lblanks
, lblanks
);
1874 write_char (dtp
, '(');
1875 write_float_string (dtp
, result1
, flt_str_len1
);
1876 write_char (dtp
, semi_comma
);
1877 write_float_string (dtp
, result2
, flt_str_len2
);
1878 write_char (dtp
, ')');
1880 dtp
->u
.p
.scale_factor
= orig_scale
;
1881 dtp
->u
.p
.g0_no_blanks
= 0;
1882 if (buf_size
> BUF_STACK_SZ
)
1884 if (res_len1
> BUF_STACK_SZ
)
1886 if (res_len2
> BUF_STACK_SZ
)
1891 /* Write the separator between items. */
1894 write_separator (st_parameter_dt
*dtp
)
1898 p
= write_block (dtp
, options
.separator_len
);
1901 if (unlikely (is_char4_unit (dtp
)))
1903 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1904 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1907 memcpy (p
, options
.separator
, options
.separator_len
);
1911 /* Write an item with list formatting.
1912 TODO: handle skipping to the next record correctly, particularly
1916 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1919 if (dtp
->u
.p
.current_unit
== NULL
)
1922 if (dtp
->u
.p
.first_item
)
1924 dtp
->u
.p
.first_item
= 0;
1925 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1926 write_char (dtp
, ' ');
1930 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1931 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1932 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1933 write_separator (dtp
);
1939 write_integer (dtp
, p
, kind
);
1942 write_logical (dtp
, p
, kind
);
1945 write_character (dtp
, p
, kind
, size
, DELIM
);
1948 write_real (dtp
, p
, kind
);
1951 write_complex (dtp
, p
, kind
, size
);
1955 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
1956 char iotype
[] = "LISTDIRECTED";
1957 gfc_charlen_type iotype_len
= 12;
1958 char tmp_iomsg
[IOMSG_LEN
] = "";
1960 gfc_charlen_type child_iomsg_len
;
1961 GFC_INTEGER_4 noiostat
;
1962 GFC_INTEGER_4
*child_iostat
= NULL
;
1963 gfc_full_array_i4 vlist
;
1965 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1966 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1968 /* Set iostat, intent(out). */
1970 child_iostat
= ((dtp
->common
.flags
& IOPARM_HAS_IOSTAT
)
1971 ? dtp
->common
.iostat
: &noiostat
);
1973 /* Set iomsge, intent(inout). */
1974 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1976 child_iomsg
= dtp
->common
.iomsg
;
1977 child_iomsg_len
= dtp
->common
.iomsg_len
;
1981 child_iomsg
= tmp_iomsg
;
1982 child_iomsg_len
= IOMSG_LEN
;
1985 /* Call the user defined formatted WRITE procedure. */
1986 dtp
->u
.p
.current_unit
->child_dtio
++;
1987 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1988 child_iostat
, child_iomsg
,
1989 iotype_len
, child_iomsg_len
);
1990 dtp
->u
.p
.current_unit
->child_dtio
--;
1994 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1997 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1998 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
2003 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2004 size_t size
, size_t nelems
)
2008 size_t stride
= type
== BT_CHARACTER
?
2009 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2013 /* Big loop over all the elements. */
2014 for (elem
= 0; elem
< nelems
; elem
++)
2016 dtp
->u
.p
.item_count
++;
2017 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
2023 nml_write_obj writes a namelist object to the output stream. It is called
2024 recursively for derived type components:
2025 obj = is the namelist_info for the current object.
2026 offset = the offset relative to the address held by the object for
2027 derived type arrays.
2028 base = is the namelist_info of the derived type, when obj is a
2030 base_name = the full name for a derived type, including qualifiers
2032 The returned value is a pointer to the object beyond the last one
2033 accessed, including nested derived types. Notice that the namelist is
2034 a linear linked list of objects, including derived types and their
2035 components. A tree, of sorts, is implied by the compound names of
2036 the derived type components and this is how this function recurses through
2039 /* A generous estimate of the number of characters needed to print
2040 repeat counts and indices, including commas, asterices and brackets. */
2042 #define NML_DIGITS 20
2045 namelist_write_newline (st_parameter_dt
*dtp
)
2047 if (!is_internal_unit (dtp
))
2050 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
2052 write_character (dtp
, "\n", 1, 1, NODELIM
);
2057 if (is_array_io (dtp
))
2062 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
2064 p
= write_block (dtp
, length
);
2068 if (unlikely (is_char4_unit (dtp
)))
2070 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
2071 memset4 (p4
, ' ', length
);
2074 memset (p
, ' ', length
);
2076 /* Now that the current record has been padded out,
2077 determine where the next record in the array is. */
2078 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2081 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2084 /* Now seek to this record */
2085 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2087 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2089 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2093 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2097 write_character (dtp
, " ", 1, 1, NODELIM
);
2101 static namelist_info
*
2102 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2103 namelist_info
*base
, char *base_name
)
2109 index_type obj_size
;
2113 index_type elem_ctr
;
2114 size_t obj_name_len
;
2120 size_t ext_name_len
;
2121 char rep_buff
[NML_DIGITS
];
2123 namelist_info
*retval
= obj
->next
;
2124 size_t base_name_len
;
2125 size_t base_var_name_len
;
2128 /* Set the character to be used to separate values
2129 to a comma or semi-colon. */
2132 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2134 /* Write namelist variable names in upper case. If a derived type,
2135 nothing is output. If a component, base and base_name are set. */
2137 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2139 namelist_write_newline (dtp
);
2140 write_character (dtp
, " ", 1, 1, NODELIM
);
2145 len
= strlen (base
->var_name
);
2146 base_name_len
= strlen (base_name
);
2147 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2149 cup
= safe_toupper (base_name
[dim_i
]);
2150 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2153 clen
= strlen (obj
->var_name
);
2154 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2156 cup
= safe_toupper (obj
->var_name
[dim_i
]);
2159 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2161 write_character (dtp
, "=", 1, 1, NODELIM
);
2164 /* Counts the number of data output on a line, including names. */
2174 obj_size
= size_from_real_kind (len
);
2178 obj_size
= size_from_complex_kind (len
);
2182 obj_size
= obj
->string_length
;
2190 obj_size
= obj
->size
;
2192 /* Set the index vector and count the number of elements. */
2195 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2197 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2198 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2201 /* Main loop to output the data held in the object. */
2204 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2207 /* Build the pointer to the data value. The offset is passed by
2208 recursive calls to this function for arrays of derived types.
2209 Is NULL otherwise. */
2211 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2214 /* Check for repeat counts of intrinsic types. */
2216 if ((elem_ctr
< (nelem
- 1)) &&
2217 (obj
->type
!= BT_DERIVED
) &&
2218 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2223 /* Execute a repeated output. Note the flag no_leading_blank that
2224 is used in the functions used to output the intrinsic types. */
2230 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2231 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2232 dtp
->u
.p
.no_leading_blank
= 1;
2236 /* Output the data, if an intrinsic type, or recurse into this
2237 routine to treat derived types. */
2243 write_integer (dtp
, p
, len
);
2247 write_logical (dtp
, p
, len
);
2251 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2252 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2254 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2258 write_real (dtp
, p
, len
);
2262 dtp
->u
.p
.no_leading_blank
= 0;
2264 write_complex (dtp
, p
, len
, obj_size
);
2269 /* To treat a derived type, we need to build two strings:
2270 ext_name = the name, including qualifiers that prepends
2271 component names in the output - passed to
2273 obj_name = the derived type name with no qualifiers but %
2274 appended. This is used to identify the
2277 /* First ext_name => get length of all possible components */
2278 if (obj
->dtio_sub
!= NULL
)
2280 GFC_INTEGER_4 unit
= dtp
->u
.p
.current_unit
->unit_number
;
2281 char iotype
[] = "NAMELIST";
2282 gfc_charlen_type iotype_len
= 8;
2283 char tmp_iomsg
[IOMSG_LEN
] = "";
2285 gfc_charlen_type child_iomsg_len
;
2286 GFC_INTEGER_4 noiostat
;
2287 GFC_INTEGER_4
*child_iostat
= NULL
;
2288 gfc_full_array_i4 vlist
;
2289 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2291 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2293 /* Set iostat, intent(out). */
2295 child_iostat
= ((dtp
->common
.flags
& IOPARM_HAS_IOSTAT
)
2296 ? dtp
->common
.iostat
: &noiostat
);
2298 /* Set iomsg, intent(inout). */
2299 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2301 child_iomsg
= dtp
->common
.iomsg
;
2302 child_iomsg_len
= dtp
->common
.iomsg_len
;
2306 child_iomsg
= tmp_iomsg
;
2307 child_iomsg_len
= IOMSG_LEN
;
2310 /* Call the user defined formatted WRITE procedure. */
2311 dtp
->u
.p
.current_unit
->child_dtio
++;
2312 if (obj
->type
== BT_DERIVED
)
2314 /* Build a class container. */
2317 list_obj
.vptr
= obj
->vtable
;
2319 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2320 child_iostat
, child_iomsg
,
2321 iotype_len
, child_iomsg_len
);
2325 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2326 child_iostat
, child_iomsg
,
2327 iotype_len
, child_iomsg_len
);
2329 dtp
->u
.p
.current_unit
->child_dtio
--;
2334 base_name_len
= base_name
? strlen (base_name
) : 0;
2335 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2336 ext_name_len
= base_name_len
+ base_var_name_len
2337 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2338 ext_name
= xmalloc (ext_name_len
);
2341 memcpy (ext_name
, base_name
, base_name_len
);
2342 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2343 memcpy (ext_name
+ base_name_len
,
2344 obj
->var_name
+ base_var_name_len
, clen
);
2346 /* Append the qualifier. */
2348 tot_len
= base_name_len
+ clen
;
2349 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2353 ext_name
[tot_len
] = '(';
2356 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2357 (int) obj
->ls
[dim_i
].idx
);
2358 tot_len
+= strlen (ext_name
+ tot_len
);
2359 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2363 ext_name
[tot_len
] = '\0';
2364 for (q
= ext_name
; *q
; q
++)
2370 obj_name_len
= strlen (obj
->var_name
) + 1;
2371 obj_name
= xmalloc (obj_name_len
+ 1);
2372 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2373 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2375 /* Now loop over the components. Update the component pointer
2376 with the return value from nml_write_obj => this loop jumps
2377 past nested derived types. */
2379 for (cmp
= obj
->next
;
2380 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2383 retval
= nml_write_obj (dtp
, cmp
,
2384 (index_type
)(p
- obj
->mem_pos
),
2393 internal_error (&dtp
->common
, "Bad type for namelist write");
2396 /* Reset the leading blank suppression, write a comma (or semi-colon)
2397 and, if 5 values have been output, write a newline and advance
2398 to column 2. Reset the repeat counter. */
2400 dtp
->u
.p
.no_leading_blank
= 0;
2401 if (obj
->type
== BT_CHARACTER
)
2403 if (dtp
->u
.p
.nml_delim
!= '\0')
2404 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2407 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2411 if (dtp
->u
.p
.nml_delim
== '\0')
2412 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2413 namelist_write_newline (dtp
);
2414 write_character (dtp
, " ", 1, 1, NODELIM
);
2419 /* Cycle through and increment the index vector. */
2424 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2426 obj
->ls
[dim_i
].idx
+= nml_carry
;
2428 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2430 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2436 /* Return a pointer beyond the furthest object accessed. */
2442 /* This is the entry function for namelist writes. It outputs the name
2443 of the namelist and iterates through the namelist by calls to
2444 nml_write_obj. The call below has dummys in the arguments used in
2445 the treatment of derived types. */
2448 namelist_write (st_parameter_dt
*dtp
)
2450 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2451 index_type dummy_offset
= 0;
2453 char *dummy_name
= NULL
;
2455 /* Set the delimiter for namelist output. */
2456 switch (dtp
->u
.p
.current_unit
->delim_status
)
2458 case DELIM_APOSTROPHE
:
2459 dtp
->u
.p
.nml_delim
= '\'';
2462 case DELIM_UNSPECIFIED
:
2463 dtp
->u
.p
.nml_delim
= '"';
2466 dtp
->u
.p
.nml_delim
= '\0';
2469 if (is_internal_unit (dtp
))
2470 write_character (dtp
, " ", 1, 1, NODELIM
);
2471 write_character (dtp
, "&", 1, 1, NODELIM
);
2473 /* Write namelist name in upper case - f95 std. */
2474 for (gfc_charlen_type i
= 0; i
< dtp
->namelist_name_len
; i
++ )
2476 c
= safe_toupper (dtp
->namelist_name
[i
]);
2477 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2480 if (dtp
->u
.p
.ionml
!= NULL
)
2482 t1
= dtp
->u
.p
.ionml
;
2486 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2490 namelist_write_newline (dtp
);
2491 write_character (dtp
, " /", 1, 2, NODELIM
);