1 /* Copyright (C) 2002-2018 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/>. */
35 #define star_fill(p, n) memset(p, '*', n)
37 typedef unsigned char uchar
;
39 /* Helper functions for character(kind=4) internal units. These are needed
40 by write_float.def. */
43 memcpy4 (gfc_char4_t
*dest
, const char *source
, int k
)
47 const char *p
= source
;
48 for (j
= 0; j
< k
; j
++)
49 *dest
++ = (gfc_char4_t
) *p
++;
52 /* This include contains the heart and soul of formatted floating point. */
53 #include "write_float.def"
55 /* Write out default char4. */
58 write_default_char4 (st_parameter_dt
*dtp
, const gfc_char4_t
*source
,
59 int src_len
, int w_len
)
66 /* Take care of preceding blanks. */
70 p
= write_block (dtp
, k
);
73 if (is_char4_unit (dtp
))
75 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
82 /* Get ready to handle delimiters if needed. */
83 switch (dtp
->u
.p
.current_unit
->delim_status
)
85 case DELIM_APOSTROPHE
:
96 /* Now process the remaining characters, one at a time. */
97 for (j
= 0; j
< src_len
; j
++)
100 if (is_char4_unit (dtp
))
103 /* Handle delimiters if any. */
104 if (c
== d
&& d
!= ' ')
106 p
= write_block (dtp
, 2);
109 q
= (gfc_char4_t
*) p
;
114 p
= write_block (dtp
, 1);
117 q
= (gfc_char4_t
*) p
;
123 /* Handle delimiters if any. */
124 if (c
== d
&& d
!= ' ')
126 p
= write_block (dtp
, 2);
133 p
= write_block (dtp
, 1);
137 *p
= c
> 255 ? '?' : (uchar
) c
;
143 /* Write out UTF-8 converted from char4. */
146 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
147 int src_len
, int w_len
)
152 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
153 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
157 /* Take care of preceding blanks. */
161 p
= write_block (dtp
, k
);
167 /* Get ready to handle delimiters if needed. */
168 switch (dtp
->u
.p
.current_unit
->delim_status
)
170 case DELIM_APOSTROPHE
:
181 /* Now process the remaining characters, one at a time. */
182 for (j
= k
; j
< src_len
; j
++)
187 /* Handle the delimiters if any. */
188 if (c
== d
&& d
!= ' ')
190 p
= write_block (dtp
, 2);
197 p
= write_block (dtp
, 1);
205 /* Convert to UTF-8 sequence. */
211 *--q
= ((c
& 0x3F) | 0x80);
215 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
217 *--q
= (c
| masks
[nbytes
-1]);
219 p
= write_block (dtp
, nbytes
);
230 /* Check the first character in source if we are using CC_FORTRAN
231 and set the cc.type appropriately. The cc.type is used later by write_cc
232 to determine the output start-of-record, and next_record_cc to determine the
233 output end-of-record.
234 This function is called before the output buffer is allocated, so alloc_len
235 is set to the appropriate size to allocate. */
238 write_check_cc (st_parameter_dt
*dtp
, const char **source
, size_t *alloc_len
)
240 /* Only valid for CARRIAGECONTROL=FORTRAN. */
241 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
242 || alloc_len
== NULL
|| source
== NULL
)
245 /* Peek at the first character. */
246 int c
= (*alloc_len
> 0) ? (*source
)[0] : EOF
;
249 /* The start-of-record character which will be printed. */
250 dtp
->u
.p
.cc
.u
.start
= '\n';
251 /* The number of characters to print at the start-of-record.
252 len > 1 means copy the SOR character multiple times.
253 len == 0 means no SOR will be output. */
259 dtp
->u
.p
.cc
.type
= CCF_OVERPRINT
;
263 dtp
->u
.p
.cc
.type
= CCF_ONE_LF
;
267 dtp
->u
.p
.cc
.type
= CCF_TWO_LF
;
271 dtp
->u
.p
.cc
.type
= CCF_PAGE_FEED
;
273 dtp
->u
.p
.cc
.u
.start
= '\f';
276 dtp
->u
.p
.cc
.type
= CCF_PROMPT
;
280 dtp
->u
.p
.cc
.type
= CCF_OVERPRINT_NOA
;
284 /* In the default case we copy ONE_LF. */
285 dtp
->u
.p
.cc
.type
= CCF_DEFAULT
;
290 /* We add n-1 to alloc_len so our write buffer is the right size.
291 We are replacing the first character, and possibly prepending some
292 additional characters. Note for n==0, we actually subtract one from
293 alloc_len, which is correct, since that character is skipped. */
297 *alloc_len
+= dtp
->u
.p
.cc
.len
- 1;
299 /* If we have no input, there is no first character to replace. Make
300 sure we still allocate enough space for the start-of-record string. */
302 *alloc_len
= dtp
->u
.p
.cc
.len
;
307 /* Write the start-of-record character(s) for CC_FORTRAN.
308 Also adjusts the 'cc' struct to contain the end-of-record character
310 The source_len is set to the remaining length to copy from the source,
311 after the start-of-record string was inserted. */
314 write_cc (st_parameter_dt
*dtp
, char *p
, size_t *source_len
)
316 /* Only valid for CARRIAGECONTROL=FORTRAN. */
317 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
|| source_len
== NULL
)
320 /* Write the start-of-record string to the output buffer. Note that len is
321 never more than 2. */
322 if (dtp
->u
.p
.cc
.len
> 0)
324 *(p
++) = dtp
->u
.p
.cc
.u
.start
;
325 if (dtp
->u
.p
.cc
.len
> 1)
326 *(p
++) = dtp
->u
.p
.cc
.u
.start
;
328 /* source_len comes from write_check_cc where it is set to the full
329 allocated length of the output buffer. Therefore we subtract off the
330 length of the SOR string to obtain the remaining source length. */
331 *source_len
-= dtp
->u
.p
.cc
.len
;
336 dtp
->u
.p
.cc
.u
.end
= '\r';
338 /* Update end-of-record character for next_record_w. */
339 switch (dtp
->u
.p
.cc
.type
)
342 case CCF_OVERPRINT_NOA
:
343 /* No end-of-record. */
345 dtp
->u
.p
.cc
.u
.end
= '\0';
353 /* Carriage return. */
355 dtp
->u
.p
.cc
.u
.end
= '\r';
364 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, size_t len
)
369 wlen
= f
->u
.string
.length
< 0
370 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
371 ? len
: (size_t) f
->u
.string
.length
;
374 /* If this is formatted STREAM IO convert any embedded line feed characters
375 to CR_LF on systems that use that sequence for newlines. See F2003
376 Standard sections 10.6.3 and 9.9 for further information. */
377 if (is_stream_io (dtp
))
379 const char crlf
[] = "\r\n";
383 /* Write out any padding if needed. */
386 p
= write_block (dtp
, wlen
- len
);
389 memset (p
, ' ', wlen
- len
);
392 /* Scan the source string looking for '\n' and convert it if found. */
393 for (size_t i
= 0; i
< wlen
; i
++)
395 if (source
[i
] == '\n')
397 /* Write out the previously scanned characters in the string. */
400 p
= write_block (dtp
, bytes
);
403 memcpy (p
, &source
[q
], bytes
);
408 /* Write out the CR_LF sequence. */
410 p
= write_block (dtp
, 2);
419 /* Write out any remaining bytes if no LF was found. */
422 p
= write_block (dtp
, bytes
);
425 memcpy (p
, &source
[q
], bytes
);
431 if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
432 write_check_cc (dtp
, &source
, &wlen
);
434 p
= write_block (dtp
, wlen
);
438 if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
439 p
= write_cc (dtp
, p
, &wlen
);
441 if (unlikely (is_char4_unit (dtp
)))
443 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
445 memcpy4 (p4
, source
, wlen
);
448 memset4 (p4
, ' ', wlen
- len
);
449 memcpy4 (p4
+ wlen
- len
, source
, len
);
455 memcpy (p
, source
, wlen
);
458 memset (p
, ' ', wlen
- len
);
459 memcpy (p
+ wlen
- len
, source
, len
);
467 /* The primary difference between write_a_char4 and write_a is that we have to
468 deal with writing from the first byte of the 4-byte character and pay
469 attention to the most significant bytes. For ENCODING="default" write the
470 lowest significant byte. If the 3 most significant bytes contain
471 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
472 to the UTF-8 encoded string before writing out. */
475 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, size_t len
)
480 wlen
= f
->u
.string
.length
< 0
481 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
482 ? len
: (size_t) f
->u
.string
.length
;
484 q
= (gfc_char4_t
*) source
;
486 /* If this is formatted STREAM IO convert any embedded line feed characters
487 to CR_LF on systems that use that sequence for newlines. See F2003
488 Standard sections 10.6.3 and 9.9 for further information. */
489 if (is_stream_io (dtp
))
491 const gfc_char4_t crlf
[] = {0x000d,0x000a};
496 /* Write out any padding if needed. */
500 p
= write_block (dtp
, wlen
- len
);
503 memset (p
, ' ', wlen
- len
);
506 /* Scan the source string looking for '\n' and convert it if found. */
507 qq
= (gfc_char4_t
*) source
;
508 for (size_t i
= 0; i
< wlen
; i
++)
512 /* Write out the previously scanned characters in the string. */
515 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
516 write_utf8_char4 (dtp
, q
, bytes
, 0);
518 write_default_char4 (dtp
, q
, bytes
, 0);
522 /* Write out the CR_LF sequence. */
523 write_default_char4 (dtp
, crlf
, 2, 0);
529 /* Write out any remaining bytes if no LF was found. */
532 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
533 write_utf8_char4 (dtp
, q
, bytes
, 0);
535 write_default_char4 (dtp
, q
, bytes
, 0);
541 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
542 write_utf8_char4 (dtp
, q
, len
, wlen
);
544 write_default_char4 (dtp
, q
, len
, wlen
);
551 static GFC_INTEGER_LARGEST
552 extract_int (const void *p
, int len
)
554 GFC_INTEGER_LARGEST i
= 0;
564 memcpy ((void *) &tmp
, p
, len
);
571 memcpy ((void *) &tmp
, p
, len
);
578 memcpy ((void *) &tmp
, p
, len
);
585 memcpy ((void *) &tmp
, p
, len
);
589 #ifdef HAVE_GFC_INTEGER_16
593 memcpy ((void *) &tmp
, p
, len
);
599 internal_error (NULL
, "bad integer kind");
605 static GFC_UINTEGER_LARGEST
606 extract_uint (const void *p
, int len
)
608 GFC_UINTEGER_LARGEST i
= 0;
618 memcpy ((void *) &tmp
, p
, len
);
619 i
= (GFC_UINTEGER_1
) tmp
;
625 memcpy ((void *) &tmp
, p
, len
);
626 i
= (GFC_UINTEGER_2
) tmp
;
632 memcpy ((void *) &tmp
, p
, len
);
633 i
= (GFC_UINTEGER_4
) tmp
;
639 memcpy ((void *) &tmp
, p
, len
);
640 i
= (GFC_UINTEGER_8
) tmp
;
643 #ifdef HAVE_GFC_INTEGER_16
647 GFC_INTEGER_16 tmp
= 0;
648 memcpy ((void *) &tmp
, p
, len
);
649 i
= (GFC_UINTEGER_16
) tmp
;
654 internal_error (NULL
, "bad integer kind");
662 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
666 GFC_INTEGER_LARGEST n
;
668 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
670 p
= write_block (dtp
, wlen
);
674 n
= extract_int (source
, len
);
676 if (unlikely (is_char4_unit (dtp
)))
678 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
679 memset4 (p4
, ' ', wlen
-1);
680 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
684 memset (p
, ' ', wlen
-1);
685 p
[wlen
- 1] = (n
) ? 'T' : 'F';
690 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
692 int w
, m
, digits
, nzero
, nblank
;
700 if (m
== 0 && n
== 0)
705 p
= write_block (dtp
, w
);
708 if (unlikely (is_char4_unit (dtp
)))
710 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
711 memset4 (p4
, ' ', w
);
720 /* Select a width if none was specified. The idea here is to always
724 w
= ((digits
< m
) ? m
: digits
);
726 p
= write_block (dtp
, w
);
734 /* See if things will work. */
736 nblank
= w
- (nzero
+ digits
);
738 if (unlikely (is_char4_unit (dtp
)))
740 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
743 memset4 (p4
, '*', w
);
747 if (!dtp
->u
.p
.no_leading_blank
)
749 memset4 (p4
, ' ', nblank
);
751 memset4 (p4
, '0', nzero
);
753 memcpy4 (p4
, q
, digits
);
757 memset4 (p4
, '0', nzero
);
759 memcpy4 (p4
, q
, digits
);
761 memset4 (p4
, ' ', nblank
);
762 dtp
->u
.p
.no_leading_blank
= 0;
773 if (!dtp
->u
.p
.no_leading_blank
)
775 memset (p
, ' ', nblank
);
777 memset (p
, '0', nzero
);
779 memcpy (p
, q
, digits
);
783 memset (p
, '0', nzero
);
785 memcpy (p
, q
, digits
);
787 memset (p
, ' ', nblank
);
788 dtp
->u
.p
.no_leading_blank
= 0;
796 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
798 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
800 GFC_INTEGER_LARGEST n
= 0;
801 int w
, m
, digits
, nsign
, nzero
, nblank
;
805 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
808 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
810 n
= extract_int (source
, len
);
813 if (m
== 0 && n
== 0)
818 p
= write_block (dtp
, w
);
821 if (unlikely (is_char4_unit (dtp
)))
823 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
824 memset4 (p4
, ' ', w
);
831 sign
= calculate_sign (dtp
, n
< 0);
834 nsign
= sign
== S_NONE
? 0 : 1;
836 /* conv calls itoa which sets the negative sign needed
837 by write_integer. The sign '+' or '-' is set below based on sign
838 calculated above, so we just point past the sign in the string
839 before proceeding to avoid double signs in corner cases.
841 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
847 /* Select a width if none was specified. The idea here is to always
851 w
= ((digits
< m
) ? m
: digits
) + nsign
;
853 p
= write_block (dtp
, w
);
861 /* See if things will work. */
863 nblank
= w
- (nsign
+ nzero
+ digits
);
865 if (unlikely (is_char4_unit (dtp
)))
867 gfc_char4_t
*p4
= (gfc_char4_t
*)p
;
870 memset4 (p4
, '*', w
);
874 if (!dtp
->u
.p
.namelist_mode
)
876 memset4 (p4
, ' ', nblank
);
892 memset4 (p4
, '0', nzero
);
895 memcpy4 (p4
, q
, digits
);
898 if (dtp
->u
.p
.namelist_mode
)
901 memset4 (p4
, ' ', nblank
);
911 if (!dtp
->u
.p
.namelist_mode
)
913 memset (p
, ' ', nblank
);
929 memset (p
, '0', nzero
);
932 memcpy (p
, q
, digits
);
934 if (dtp
->u
.p
.namelist_mode
)
937 memset (p
, ' ', nblank
);
945 /* Convert unsigned octal to ascii. */
948 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
952 assert (len
>= GFC_OTOA_BUF_SIZE
);
957 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
962 *--p
= '0' + (n
& 7);
970 /* Convert unsigned binary to ascii. */
973 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
977 assert (len
>= GFC_BTOA_BUF_SIZE
);
982 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
987 *--p
= '0' + (n
& 1);
994 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
995 to convert large reals with kind sizes that exceed the largest integer type
996 available on certain platforms. In these cases, byte by byte conversion is
997 performed. Endianess is taken into account. */
999 /* Conversion to binary. */
1002 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1008 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1011 for (i
= 0; i
< len
; i
++)
1015 /* Test for zero. Needed by write_boz later. */
1019 for (j
= 0; j
< 8; j
++)
1021 *q
++ = (c
& 128) ? '1' : '0';
1029 const char *p
= s
+ len
- 1;
1030 for (i
= 0; i
< len
; i
++)
1034 /* Test for zero. Needed by write_boz later. */
1038 for (j
= 0; j
< 8; j
++)
1040 *q
++ = (c
& 128) ? '1' : '0';
1052 /* Move past any leading zeros. */
1053 while (*buffer
== '0')
1060 /* Conversion to octal. */
1063 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1069 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1073 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1075 const char *p
= s
+ len
- 1;
1079 /* Test for zero. Needed by write_boz later. */
1083 for (j
= 0; j
< 3 && i
< len
; j
++)
1085 octet
|= (c
& 1) << j
;
1104 /* Test for zero. Needed by write_boz later. */
1108 for (j
= 0; j
< 3 && i
< len
; j
++)
1110 octet
|= (c
& 1) << j
;
1127 /* Move past any leading zeros. */
1134 /* Conversion to hexidecimal. */
1137 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1139 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
1140 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1148 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1151 for (i
= 0; i
< len
; i
++)
1153 /* Test for zero. Needed by write_boz later. */
1157 h
= (*p
>> 4) & 0x0F;
1165 const char *p
= s
+ len
- 1;
1166 for (i
= 0; i
< len
; i
++)
1168 /* Test for zero. Needed by write_boz later. */
1172 h
= (*p
>> 4) & 0x0F;
1184 /* Move past any leading zeros. */
1185 while (*buffer
== '0')
1193 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1195 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1200 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1203 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1204 GFC_UINTEGER_LARGEST n
= 0;
1206 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1208 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1209 write_boz (dtp
, f
, p
, n
);
1213 n
= extract_uint (source
, len
);
1214 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1215 write_boz (dtp
, f
, p
, n
);
1221 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1224 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1225 GFC_UINTEGER_LARGEST n
= 0;
1227 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1229 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1230 write_boz (dtp
, f
, p
, n
);
1234 n
= extract_uint (source
, len
);
1235 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1236 write_boz (dtp
, f
, p
, n
);
1241 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1244 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1245 GFC_UINTEGER_LARGEST n
= 0;
1247 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1249 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1250 write_boz (dtp
, f
, p
, n
);
1254 n
= extract_uint (source
, len
);
1255 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1256 write_boz (dtp
, f
, p
, n
);
1260 /* Take care of the X/TR descriptor. */
1263 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1267 p
= write_block (dtp
, len
);
1270 if (nspaces
> 0 && len
- nspaces
>= 0)
1272 if (unlikely (is_char4_unit (dtp
)))
1274 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1275 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1278 memset (&p
[len
- nspaces
], ' ', nspaces
);
1283 /* List-directed writing. */
1286 /* Write a single character to the output. Returns nonzero if
1287 something goes wrong. */
1290 write_char (st_parameter_dt
*dtp
, int c
)
1294 p
= write_block (dtp
, 1);
1297 if (unlikely (is_char4_unit (dtp
)))
1299 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1310 /* Write a list-directed logical value. */
1313 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1315 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1319 /* Write a list-directed integer value. */
1322 write_integer (st_parameter_dt
*dtp
, const char *source
, int kind
)
1349 f
.u
.integer
.w
= width
;
1351 write_decimal (dtp
, &f
, source
, kind
, (void *) gfc_itoa
);
1355 /* Write a list-directed string. We have to worry about delimiting
1356 the strings if the file has been opened in that mode. */
1362 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t length
, int mode
)
1369 switch (dtp
->u
.p
.current_unit
->delim_status
)
1371 case DELIM_APOSTROPHE
:
1393 for (size_t i
= 0; i
< length
; i
++)
1398 p
= write_block (dtp
, length
+ extra
);
1402 if (unlikely (is_char4_unit (dtp
)))
1404 gfc_char4_t d4
= (gfc_char4_t
) d
;
1405 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1408 memcpy4 (p4
, source
, length
);
1413 for (size_t i
= 0; i
< length
; i
++)
1415 *p4
++ = (gfc_char4_t
) source
[i
];
1426 memcpy (p
, source
, length
);
1431 for (size_t i
= 0; i
< length
; i
++)
1445 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1446 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1448 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1452 p
= write_block (dtp
, 1);
1455 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1456 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1458 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1460 p
= write_block (dtp
, 1);
1466 /* Floating point helper functions. */
1468 #define BUF_STACK_SZ 256
1471 get_precision (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1473 if (f
->format
!= FMT_EN
)
1474 return determine_precision (dtp
, f
, kind
);
1476 return determine_en_precision (dtp
, f
, source
, kind
);
1479 /* 4932 is the maximum exponent of long double and quad precision, 3
1480 extra characters for the sign, the decimal point, and the
1481 trailing null. Extra digits are added by the calling functions for
1482 requested precision. Likewise for float and double. F0 editing produces
1483 full precision output. */
1485 size_from_kind (st_parameter_dt
*dtp
, const fnode
*f
, int kind
)
1489 if (f
->format
== FMT_F
&& f
->u
.real
.w
== 0)
1494 size
= 38 + 3; /* These constants shown for clarity. */
1506 internal_error (&dtp
->common
, "bad real kind");
1511 size
= f
->u
.real
.w
+ 1; /* One byte for a NULL character. */
1517 select_buffer (st_parameter_dt
*dtp
, const fnode
*f
, int precision
,
1518 char *buf
, size_t *size
, int kind
)
1522 /* The buffer needs at least one more byte to allow room for
1523 normalizing and 1 to hold null terminator. */
1524 *size
= size_from_kind (dtp
, f
, kind
) + precision
+ 1 + 1;
1526 if (*size
> BUF_STACK_SZ
)
1527 result
= xmalloc (*size
);
1534 select_string (st_parameter_dt
*dtp
, const fnode
*f
, char *buf
, size_t *size
,
1538 *size
= size_from_kind (dtp
, f
, kind
) + f
->u
.real
.d
+ 1;
1539 if (*size
> BUF_STACK_SZ
)
1540 result
= xmalloc (*size
);
1547 write_float_string (st_parameter_dt
*dtp
, char *fstr
, size_t len
)
1549 char *p
= write_block (dtp
, len
);
1553 if (unlikely (is_char4_unit (dtp
)))
1555 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1556 memcpy4 (p4
, fstr
, len
);
1559 memcpy (p
, fstr
, len
);
1564 write_float_0 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1566 char buf_stack
[BUF_STACK_SZ
];
1567 char str_buf
[BUF_STACK_SZ
];
1568 char *buffer
, *result
;
1569 size_t buf_size
, res_len
, flt_str_len
;
1571 /* Precision for snprintf call. */
1572 int precision
= get_precision (dtp
, f
, source
, kind
);
1574 /* String buffer to hold final result. */
1575 result
= select_string (dtp
, f
, str_buf
, &res_len
, kind
);
1577 buffer
= select_buffer (dtp
, f
, precision
, buf_stack
, &buf_size
, kind
);
1579 get_float_string (dtp
, f
, source
, kind
, 0, buffer
,
1580 precision
, buf_size
, result
, &flt_str_len
);
1581 write_float_string (dtp
, result
, flt_str_len
);
1583 if (buf_size
> BUF_STACK_SZ
)
1585 if (res_len
> BUF_STACK_SZ
)
1590 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1592 write_float_0 (dtp
, f
, p
, len
);
1597 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1599 write_float_0 (dtp
, f
, p
, len
);
1604 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1606 write_float_0 (dtp
, f
, p
, len
);
1611 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1613 write_float_0 (dtp
, f
, p
, len
);
1618 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1620 write_float_0 (dtp
, f
, p
, len
);
1624 /* Set an fnode to default format. */
1627 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1648 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1649 #if GFC_REAL_16_DIGITS == 113
1660 internal_error (&dtp
->common
, "bad real kind");
1665 /* Output a real number with default format.
1666 To guarantee that a binary -> decimal -> binary roundtrip conversion
1667 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1668 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1669 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1670 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1671 Fortran standard requires outputting an extra digit when the scale
1672 factor is 1 and when the magnitude of the value is such that E
1673 editing is used. However, gfortran compensates for this, and thus
1674 for list formatted the same number of significant digits is
1675 generated both when using F and E editing. */
1678 write_real (st_parameter_dt
*dtp
, const char *source
, int kind
)
1681 char buf_stack
[BUF_STACK_SZ
];
1682 char str_buf
[BUF_STACK_SZ
];
1683 char *buffer
, *result
;
1684 size_t buf_size
, res_len
;
1685 int orig_scale
= dtp
->u
.p
.scale_factor
;
1686 dtp
->u
.p
.scale_factor
= 1;
1687 set_fnode_default (dtp
, &f
, kind
);
1689 /* Precision for snprintf call. */
1690 int precision
= get_precision (dtp
, &f
, source
, kind
);
1692 /* String buffer to hold final result. */
1693 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1695 /* Scratch buffer to hold final result. */
1696 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1698 get_float_string (dtp
, &f
, source
, kind
, 1, buffer
,
1699 precision
, buf_size
, result
, &res_len
);
1700 write_float_string (dtp
, result
, res_len
);
1702 dtp
->u
.p
.scale_factor
= orig_scale
;
1703 if (buf_size
> BUF_STACK_SZ
)
1705 if (res_len
> BUF_STACK_SZ
)
1709 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1710 compensate for the extra digit. */
1713 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int kind
, int d
)
1716 char buf_stack
[BUF_STACK_SZ
];
1717 char str_buf
[BUF_STACK_SZ
];
1718 char *buffer
, *result
;
1719 size_t buf_size
, res_len
;
1721 set_fnode_default (dtp
, &f
, kind
);
1726 /* Compensate for extra digits when using scale factor, d is not
1727 specified, and the magnitude is such that E editing is used. */
1728 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1732 dtp
->u
.p
.g0_no_blanks
= 1;
1734 /* Precision for snprintf call. */
1735 int precision
= get_precision (dtp
, &f
, source
, kind
);
1737 /* String buffer to hold final result. */
1738 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1740 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1742 get_float_string (dtp
, &f
, source
, kind
, comp_d
, buffer
,
1743 precision
, buf_size
, result
, &res_len
);
1744 write_float_string (dtp
, result
, res_len
);
1746 dtp
->u
.p
.g0_no_blanks
= 0;
1747 if (buf_size
> BUF_STACK_SZ
)
1749 if (res_len
> BUF_STACK_SZ
)
1755 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1758 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1760 /* Set for no blanks so we get a string result with no leading
1761 blanks. We will pad left later. */
1762 dtp
->u
.p
.g0_no_blanks
= 1;
1765 char buf_stack
[BUF_STACK_SZ
];
1766 char str1_buf
[BUF_STACK_SZ
];
1767 char str2_buf
[BUF_STACK_SZ
];
1768 char *buffer
, *result1
, *result2
;
1769 size_t buf_size
, res_len1
, res_len2
;
1770 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1772 dtp
->u
.p
.scale_factor
= 1;
1773 set_fnode_default (dtp
, &f
, kind
);
1775 /* Set width for two values, parenthesis, and comma. */
1776 width
= 2 * f
.u
.real
.w
+ 3;
1778 /* Set for no blanks so we get a string result with no leading
1779 blanks. We will pad left later. */
1780 dtp
->u
.p
.g0_no_blanks
= 1;
1782 /* Precision for snprintf call. */
1783 int precision
= get_precision (dtp
, &f
, source
, kind
);
1785 /* String buffers to hold final result. */
1786 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1787 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1789 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1791 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1792 precision
, buf_size
, result1
, &res_len1
);
1793 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1794 precision
, buf_size
, result2
, &res_len2
);
1795 if (!dtp
->u
.p
.namelist_mode
)
1797 lblanks
= width
- res_len1
- res_len2
- 3;
1798 write_x (dtp
, lblanks
, lblanks
);
1800 write_char (dtp
, '(');
1801 write_float_string (dtp
, result1
, res_len1
);
1802 write_char (dtp
, semi_comma
);
1803 write_float_string (dtp
, result2
, res_len2
);
1804 write_char (dtp
, ')');
1806 dtp
->u
.p
.scale_factor
= orig_scale
;
1807 dtp
->u
.p
.g0_no_blanks
= 0;
1808 if (buf_size
> BUF_STACK_SZ
)
1810 if (res_len1
> BUF_STACK_SZ
)
1812 if (res_len2
> BUF_STACK_SZ
)
1817 /* Write the separator between items. */
1820 write_separator (st_parameter_dt
*dtp
)
1824 p
= write_block (dtp
, options
.separator_len
);
1827 if (unlikely (is_char4_unit (dtp
)))
1829 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1830 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1833 memcpy (p
, options
.separator
, options
.separator_len
);
1837 /* Write an item with list formatting.
1838 TODO: handle skipping to the next record correctly, particularly
1842 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1845 if (dtp
->u
.p
.current_unit
== NULL
)
1848 if (dtp
->u
.p
.first_item
)
1850 dtp
->u
.p
.first_item
= 0;
1851 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1852 write_char (dtp
, ' ');
1856 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1857 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1858 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1859 write_separator (dtp
);
1865 write_integer (dtp
, p
, kind
);
1868 write_logical (dtp
, p
, kind
);
1871 write_character (dtp
, p
, kind
, size
, DELIM
);
1874 write_real (dtp
, p
, kind
);
1877 write_complex (dtp
, p
, kind
, size
);
1881 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1882 char iotype
[] = "LISTDIRECTED";
1883 gfc_charlen_type iotype_len
= 12;
1884 char tmp_iomsg
[IOMSG_LEN
] = "";
1886 gfc_charlen_type child_iomsg_len
;
1888 int *child_iostat
= NULL
;
1889 gfc_full_array_i4 vlist
;
1891 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1892 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1894 /* Set iostat, intent(out). */
1896 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1897 dtp
->common
.iostat
: &noiostat
;
1899 /* Set iomsge, intent(inout). */
1900 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1902 child_iomsg
= dtp
->common
.iomsg
;
1903 child_iomsg_len
= dtp
->common
.iomsg_len
;
1907 child_iomsg
= tmp_iomsg
;
1908 child_iomsg_len
= IOMSG_LEN
;
1911 /* Call the user defined formatted WRITE procedure. */
1912 dtp
->u
.p
.current_unit
->child_dtio
++;
1913 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1914 child_iostat
, child_iomsg
,
1915 iotype_len
, child_iomsg_len
);
1916 dtp
->u
.p
.current_unit
->child_dtio
--;
1920 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1923 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1924 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1929 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1930 size_t size
, size_t nelems
)
1934 size_t stride
= type
== BT_CHARACTER
?
1935 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1939 /* Big loop over all the elements. */
1940 for (elem
= 0; elem
< nelems
; elem
++)
1942 dtp
->u
.p
.item_count
++;
1943 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1949 nml_write_obj writes a namelist object to the output stream. It is called
1950 recursively for derived type components:
1951 obj = is the namelist_info for the current object.
1952 offset = the offset relative to the address held by the object for
1953 derived type arrays.
1954 base = is the namelist_info of the derived type, when obj is a
1956 base_name = the full name for a derived type, including qualifiers
1958 The returned value is a pointer to the object beyond the last one
1959 accessed, including nested derived types. Notice that the namelist is
1960 a linear linked list of objects, including derived types and their
1961 components. A tree, of sorts, is implied by the compound names of
1962 the derived type components and this is how this function recurses through
1965 /* A generous estimate of the number of characters needed to print
1966 repeat counts and indices, including commas, asterices and brackets. */
1968 #define NML_DIGITS 20
1971 namelist_write_newline (st_parameter_dt
*dtp
)
1973 if (!is_internal_unit (dtp
))
1976 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
1978 write_character (dtp
, "\n", 1, 1, NODELIM
);
1983 if (is_array_io (dtp
))
1988 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
1990 p
= write_block (dtp
, length
);
1994 if (unlikely (is_char4_unit (dtp
)))
1996 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1997 memset4 (p4
, ' ', length
);
2000 memset (p
, ' ', length
);
2002 /* Now that the current record has been padded out,
2003 determine where the next record in the array is. */
2004 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2007 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2010 /* Now seek to this record */
2011 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2013 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2015 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2019 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2023 write_character (dtp
, " ", 1, 1, NODELIM
);
2027 static namelist_info
*
2028 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2029 namelist_info
*base
, char *base_name
)
2035 index_type obj_size
;
2039 index_type elem_ctr
;
2040 size_t obj_name_len
;
2046 size_t ext_name_len
;
2047 char rep_buff
[NML_DIGITS
];
2049 namelist_info
*retval
= obj
->next
;
2050 size_t base_name_len
;
2051 size_t base_var_name_len
;
2054 /* Set the character to be used to separate values
2055 to a comma or semi-colon. */
2058 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2060 /* Write namelist variable names in upper case. If a derived type,
2061 nothing is output. If a component, base and base_name are set. */
2063 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2065 namelist_write_newline (dtp
);
2066 write_character (dtp
, " ", 1, 1, NODELIM
);
2071 len
= strlen (base
->var_name
);
2072 base_name_len
= strlen (base_name
);
2073 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2075 cup
= toupper ((int) base_name
[dim_i
]);
2076 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2079 clen
= strlen (obj
->var_name
);
2080 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2082 cup
= toupper ((int) obj
->var_name
[dim_i
]);
2085 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2087 write_character (dtp
, "=", 1, 1, NODELIM
);
2090 /* Counts the number of data output on a line, including names. */
2100 obj_size
= size_from_real_kind (len
);
2104 obj_size
= size_from_complex_kind (len
);
2108 obj_size
= obj
->string_length
;
2116 obj_size
= obj
->size
;
2118 /* Set the index vector and count the number of elements. */
2121 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2123 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2124 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2127 /* Main loop to output the data held in the object. */
2130 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2133 /* Build the pointer to the data value. The offset is passed by
2134 recursive calls to this function for arrays of derived types.
2135 Is NULL otherwise. */
2137 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2140 /* Check for repeat counts of intrinsic types. */
2142 if ((elem_ctr
< (nelem
- 1)) &&
2143 (obj
->type
!= BT_DERIVED
) &&
2144 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2149 /* Execute a repeated output. Note the flag no_leading_blank that
2150 is used in the functions used to output the intrinsic types. */
2156 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2157 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2158 dtp
->u
.p
.no_leading_blank
= 1;
2162 /* Output the data, if an intrinsic type, or recurse into this
2163 routine to treat derived types. */
2169 write_integer (dtp
, p
, len
);
2173 write_logical (dtp
, p
, len
);
2177 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2178 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2180 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2184 write_real (dtp
, p
, len
);
2188 dtp
->u
.p
.no_leading_blank
= 0;
2190 write_complex (dtp
, p
, len
, obj_size
);
2195 /* To treat a derived type, we need to build two strings:
2196 ext_name = the name, including qualifiers that prepends
2197 component names in the output - passed to
2199 obj_name = the derived type name with no qualifiers but %
2200 appended. This is used to identify the
2203 /* First ext_name => get length of all possible components */
2204 if (obj
->dtio_sub
!= NULL
)
2206 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2207 char iotype
[] = "NAMELIST";
2208 gfc_charlen_type iotype_len
= 8;
2209 char tmp_iomsg
[IOMSG_LEN
] = "";
2211 gfc_charlen_type child_iomsg_len
;
2213 int *child_iostat
= NULL
;
2214 gfc_full_array_i4 vlist
;
2215 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2217 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2219 /* Set iostat, intent(out). */
2221 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2222 dtp
->common
.iostat
: &noiostat
;
2224 /* Set iomsg, intent(inout). */
2225 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2227 child_iomsg
= dtp
->common
.iomsg
;
2228 child_iomsg_len
= dtp
->common
.iomsg_len
;
2232 child_iomsg
= tmp_iomsg
;
2233 child_iomsg_len
= IOMSG_LEN
;
2236 /* Call the user defined formatted WRITE procedure. */
2237 dtp
->u
.p
.current_unit
->child_dtio
++;
2238 if (obj
->type
== BT_DERIVED
)
2240 /* Build a class container. */
2243 list_obj
.vptr
= obj
->vtable
;
2245 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2246 child_iostat
, child_iomsg
,
2247 iotype_len
, child_iomsg_len
);
2251 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2252 child_iostat
, child_iomsg
,
2253 iotype_len
, child_iomsg_len
);
2255 dtp
->u
.p
.current_unit
->child_dtio
--;
2260 base_name_len
= base_name
? strlen (base_name
) : 0;
2261 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2262 ext_name_len
= base_name_len
+ base_var_name_len
2263 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2264 ext_name
= xmalloc (ext_name_len
);
2267 memcpy (ext_name
, base_name
, base_name_len
);
2268 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2269 memcpy (ext_name
+ base_name_len
,
2270 obj
->var_name
+ base_var_name_len
, clen
);
2272 /* Append the qualifier. */
2274 tot_len
= base_name_len
+ clen
;
2275 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2279 ext_name
[tot_len
] = '(';
2282 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2283 (int) obj
->ls
[dim_i
].idx
);
2284 tot_len
+= strlen (ext_name
+ tot_len
);
2285 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2289 ext_name
[tot_len
] = '\0';
2290 for (q
= ext_name
; *q
; q
++)
2296 obj_name_len
= strlen (obj
->var_name
) + 1;
2297 obj_name
= xmalloc (obj_name_len
+ 1);
2298 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2299 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2301 /* Now loop over the components. Update the component pointer
2302 with the return value from nml_write_obj => this loop jumps
2303 past nested derived types. */
2305 for (cmp
= obj
->next
;
2306 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2309 retval
= nml_write_obj (dtp
, cmp
,
2310 (index_type
)(p
- obj
->mem_pos
),
2319 internal_error (&dtp
->common
, "Bad type for namelist write");
2322 /* Reset the leading blank suppression, write a comma (or semi-colon)
2323 and, if 5 values have been output, write a newline and advance
2324 to column 2. Reset the repeat counter. */
2326 dtp
->u
.p
.no_leading_blank
= 0;
2327 if (obj
->type
== BT_CHARACTER
)
2329 if (dtp
->u
.p
.nml_delim
!= '\0')
2330 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2333 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2337 if (dtp
->u
.p
.nml_delim
== '\0')
2338 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2339 namelist_write_newline (dtp
);
2340 write_character (dtp
, " ", 1, 1, NODELIM
);
2345 /* Cycle through and increment the index vector. */
2350 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2352 obj
->ls
[dim_i
].idx
+= nml_carry
;
2354 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2356 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2362 /* Return a pointer beyond the furthest object accessed. */
2368 /* This is the entry function for namelist writes. It outputs the name
2369 of the namelist and iterates through the namelist by calls to
2370 nml_write_obj. The call below has dummys in the arguments used in
2371 the treatment of derived types. */
2374 namelist_write (st_parameter_dt
*dtp
)
2376 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2377 index_type dummy_offset
= 0;
2379 char *dummy_name
= NULL
;
2381 /* Set the delimiter for namelist output. */
2382 switch (dtp
->u
.p
.current_unit
->delim_status
)
2384 case DELIM_APOSTROPHE
:
2385 dtp
->u
.p
.nml_delim
= '\'';
2388 case DELIM_UNSPECIFIED
:
2389 dtp
->u
.p
.nml_delim
= '"';
2392 dtp
->u
.p
.nml_delim
= '\0';
2395 write_character (dtp
, "&", 1, 1, NODELIM
);
2397 /* Write namelist name in upper case - f95 std. */
2398 for (gfc_charlen_type i
= 0; i
< dtp
->namelist_name_len
; i
++ )
2400 c
= toupper ((int) dtp
->namelist_name
[i
]);
2401 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2404 if (dtp
->u
.p
.ionml
!= NULL
)
2406 t1
= dtp
->u
.p
.ionml
;
2410 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2414 namelist_write_newline (dtp
);
2415 write_character (dtp
, " /", 1, 2, NODELIM
);