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
, int *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
, int *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';
363 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
368 wlen
= f
->u
.string
.length
< 0
369 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
370 ? len
: 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 (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
, int len
)
479 wlen
= f
->u
.string
.length
< 0
480 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
481 ? len
: 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 (i
= 0; i
< wlen
; i
++)
511 /* Write out the previously scanned characters in the string. */
514 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
515 write_utf8_char4 (dtp
, q
, bytes
, 0);
517 write_default_char4 (dtp
, q
, bytes
, 0);
521 /* Write out the CR_LF sequence. */
522 write_default_char4 (dtp
, crlf
, 2, 0);
528 /* Write out any remaining bytes if no LF was found. */
531 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
532 write_utf8_char4 (dtp
, q
, bytes
, 0);
534 write_default_char4 (dtp
, q
, bytes
, 0);
540 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
541 write_utf8_char4 (dtp
, q
, len
, wlen
);
543 write_default_char4 (dtp
, q
, len
, wlen
);
550 static GFC_INTEGER_LARGEST
551 extract_int (const void *p
, int len
)
553 GFC_INTEGER_LARGEST i
= 0;
563 memcpy ((void *) &tmp
, p
, len
);
570 memcpy ((void *) &tmp
, p
, len
);
577 memcpy ((void *) &tmp
, p
, len
);
584 memcpy ((void *) &tmp
, p
, len
);
588 #ifdef HAVE_GFC_INTEGER_16
592 memcpy ((void *) &tmp
, p
, len
);
598 internal_error (NULL
, "bad integer kind");
604 static GFC_UINTEGER_LARGEST
605 extract_uint (const void *p
, int len
)
607 GFC_UINTEGER_LARGEST i
= 0;
617 memcpy ((void *) &tmp
, p
, len
);
618 i
= (GFC_UINTEGER_1
) tmp
;
624 memcpy ((void *) &tmp
, p
, len
);
625 i
= (GFC_UINTEGER_2
) tmp
;
631 memcpy ((void *) &tmp
, p
, len
);
632 i
= (GFC_UINTEGER_4
) tmp
;
638 memcpy ((void *) &tmp
, p
, len
);
639 i
= (GFC_UINTEGER_8
) tmp
;
642 #ifdef HAVE_GFC_INTEGER_16
646 GFC_INTEGER_16 tmp
= 0;
647 memcpy ((void *) &tmp
, p
, len
);
648 i
= (GFC_UINTEGER_16
) tmp
;
653 internal_error (NULL
, "bad integer kind");
661 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
665 GFC_INTEGER_LARGEST n
;
667 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
669 p
= write_block (dtp
, wlen
);
673 n
= extract_int (source
, len
);
675 if (unlikely (is_char4_unit (dtp
)))
677 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
678 memset4 (p4
, ' ', wlen
-1);
679 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
683 memset (p
, ' ', wlen
-1);
684 p
[wlen
- 1] = (n
) ? 'T' : 'F';
689 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
691 int w
, m
, digits
, nzero
, nblank
;
699 if (m
== 0 && n
== 0)
704 p
= write_block (dtp
, w
);
707 if (unlikely (is_char4_unit (dtp
)))
709 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
710 memset4 (p4
, ' ', w
);
719 /* Select a width if none was specified. The idea here is to always
723 w
= ((digits
< m
) ? m
: digits
);
725 p
= write_block (dtp
, w
);
733 /* See if things will work. */
735 nblank
= w
- (nzero
+ digits
);
737 if (unlikely (is_char4_unit (dtp
)))
739 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
742 memset4 (p4
, '*', w
);
746 if (!dtp
->u
.p
.no_leading_blank
)
748 memset4 (p4
, ' ', nblank
);
750 memset4 (p4
, '0', nzero
);
752 memcpy4 (p4
, q
, digits
);
756 memset4 (p4
, '0', nzero
);
758 memcpy4 (p4
, q
, digits
);
760 memset4 (p4
, ' ', nblank
);
761 dtp
->u
.p
.no_leading_blank
= 0;
772 if (!dtp
->u
.p
.no_leading_blank
)
774 memset (p
, ' ', nblank
);
776 memset (p
, '0', nzero
);
778 memcpy (p
, q
, digits
);
782 memset (p
, '0', nzero
);
784 memcpy (p
, q
, digits
);
786 memset (p
, ' ', nblank
);
787 dtp
->u
.p
.no_leading_blank
= 0;
795 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
797 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
799 GFC_INTEGER_LARGEST n
= 0;
800 int w
, m
, digits
, nsign
, nzero
, nblank
;
804 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
807 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
809 n
= extract_int (source
, len
);
812 if (m
== 0 && n
== 0)
817 p
= write_block (dtp
, w
);
820 if (unlikely (is_char4_unit (dtp
)))
822 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
823 memset4 (p4
, ' ', w
);
830 sign
= calculate_sign (dtp
, n
< 0);
833 nsign
= sign
== S_NONE
? 0 : 1;
835 /* conv calls itoa which sets the negative sign needed
836 by write_integer. The sign '+' or '-' is set below based on sign
837 calculated above, so we just point past the sign in the string
838 before proceeding to avoid double signs in corner cases.
840 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
846 /* Select a width if none was specified. The idea here is to always
850 w
= ((digits
< m
) ? m
: digits
) + nsign
;
852 p
= write_block (dtp
, w
);
860 /* See if things will work. */
862 nblank
= w
- (nsign
+ nzero
+ digits
);
864 if (unlikely (is_char4_unit (dtp
)))
866 gfc_char4_t
*p4
= (gfc_char4_t
*)p
;
869 memset4 (p4
, '*', w
);
873 if (!dtp
->u
.p
.namelist_mode
)
875 memset4 (p4
, ' ', nblank
);
891 memset4 (p4
, '0', nzero
);
894 memcpy4 (p4
, q
, digits
);
897 if (dtp
->u
.p
.namelist_mode
)
900 memset4 (p4
, ' ', nblank
);
910 if (!dtp
->u
.p
.namelist_mode
)
912 memset (p
, ' ', nblank
);
928 memset (p
, '0', nzero
);
931 memcpy (p
, q
, digits
);
933 if (dtp
->u
.p
.namelist_mode
)
936 memset (p
, ' ', nblank
);
944 /* Convert unsigned octal to ascii. */
947 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
951 assert (len
>= GFC_OTOA_BUF_SIZE
);
956 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
961 *--p
= '0' + (n
& 7);
969 /* Convert unsigned binary to ascii. */
972 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
976 assert (len
>= GFC_BTOA_BUF_SIZE
);
981 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
986 *--p
= '0' + (n
& 1);
993 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
994 to convert large reals with kind sizes that exceed the largest integer type
995 available on certain platforms. In these cases, byte by byte conversion is
996 performed. Endianess is taken into account. */
998 /* Conversion to binary. */
1001 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1007 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1010 for (i
= 0; i
< len
; i
++)
1014 /* Test for zero. Needed by write_boz later. */
1018 for (j
= 0; j
< 8; j
++)
1020 *q
++ = (c
& 128) ? '1' : '0';
1028 const char *p
= s
+ len
- 1;
1029 for (i
= 0; i
< len
; i
++)
1033 /* Test for zero. Needed by write_boz later. */
1037 for (j
= 0; j
< 8; j
++)
1039 *q
++ = (c
& 128) ? '1' : '0';
1051 /* Move past any leading zeros. */
1052 while (*buffer
== '0')
1059 /* Conversion to octal. */
1062 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1068 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1072 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1074 const char *p
= s
+ len
- 1;
1078 /* Test for zero. Needed by write_boz later. */
1082 for (j
= 0; j
< 3 && i
< len
; j
++)
1084 octet
|= (c
& 1) << j
;
1103 /* Test for zero. Needed by write_boz later. */
1107 for (j
= 0; j
< 3 && i
< len
; j
++)
1109 octet
|= (c
& 1) << j
;
1126 /* Move past any leading zeros. */
1133 /* Conversion to hexidecimal. */
1136 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1138 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
1139 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1147 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
1150 for (i
= 0; i
< len
; i
++)
1152 /* Test for zero. Needed by write_boz later. */
1156 h
= (*p
>> 4) & 0x0F;
1164 const char *p
= s
+ len
- 1;
1165 for (i
= 0; i
< len
; i
++)
1167 /* Test for zero. Needed by write_boz later. */
1171 h
= (*p
>> 4) & 0x0F;
1183 /* Move past any leading zeros. */
1184 while (*buffer
== '0')
1192 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1194 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1199 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1202 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1203 GFC_UINTEGER_LARGEST n
= 0;
1205 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1207 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1208 write_boz (dtp
, f
, p
, n
);
1212 n
= extract_uint (source
, len
);
1213 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1214 write_boz (dtp
, f
, p
, n
);
1220 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1223 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1224 GFC_UINTEGER_LARGEST n
= 0;
1226 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1228 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1229 write_boz (dtp
, f
, p
, n
);
1233 n
= extract_uint (source
, len
);
1234 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1235 write_boz (dtp
, f
, p
, n
);
1240 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1243 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1244 GFC_UINTEGER_LARGEST n
= 0;
1246 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1248 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1249 write_boz (dtp
, f
, p
, n
);
1253 n
= extract_uint (source
, len
);
1254 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1255 write_boz (dtp
, f
, p
, n
);
1259 /* Take care of the X/TR descriptor. */
1262 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1266 p
= write_block (dtp
, len
);
1269 if (nspaces
> 0 && len
- nspaces
>= 0)
1271 if (unlikely (is_char4_unit (dtp
)))
1273 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1274 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1277 memset (&p
[len
- nspaces
], ' ', nspaces
);
1282 /* List-directed writing. */
1285 /* Write a single character to the output. Returns nonzero if
1286 something goes wrong. */
1289 write_char (st_parameter_dt
*dtp
, int c
)
1293 p
= write_block (dtp
, 1);
1296 if (unlikely (is_char4_unit (dtp
)))
1298 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1309 /* Write a list-directed logical value. */
1312 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1314 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1318 /* Write a list-directed integer value. */
1321 write_integer (st_parameter_dt
*dtp
, const char *source
, int kind
)
1348 f
.u
.integer
.w
= width
;
1350 write_decimal (dtp
, &f
, source
, kind
, (void *) gfc_itoa
);
1354 /* Write a list-directed string. We have to worry about delimiting
1355 the strings if the file has been opened in that mode. */
1361 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
, int mode
)
1368 switch (dtp
->u
.p
.current_unit
->delim_status
)
1370 case DELIM_APOSTROPHE
:
1392 for (i
= 0; i
< length
; i
++)
1397 p
= write_block (dtp
, length
+ extra
);
1401 if (unlikely (is_char4_unit (dtp
)))
1403 gfc_char4_t d4
= (gfc_char4_t
) d
;
1404 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1407 memcpy4 (p4
, source
, length
);
1412 for (i
= 0; i
< length
; i
++)
1414 *p4
++ = (gfc_char4_t
) source
[i
];
1425 memcpy (p
, source
, length
);
1430 for (i
= 0; i
< length
; i
++)
1444 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1445 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1447 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1451 p
= write_block (dtp
, 1);
1454 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1455 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1457 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1459 p
= write_block (dtp
, 1);
1465 /* Floating point helper functions. */
1467 #define BUF_STACK_SZ 256
1470 get_precision (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1472 if (f
->format
!= FMT_EN
)
1473 return determine_precision (dtp
, f
, kind
);
1475 return determine_en_precision (dtp
, f
, source
, kind
);
1478 /* 4932 is the maximum exponent of long double and quad precision, 3
1479 extra characters for the sign, the decimal point, and the
1480 trailing null. Extra digits are added by the calling functions for
1481 requested precision. Likewise for float and double. F0 editing produces
1482 full precision output. */
1484 size_from_kind (st_parameter_dt
*dtp
, const fnode
*f
, int kind
)
1488 if (f
->format
== FMT_F
&& f
->u
.real
.w
== 0)
1493 size
= 38 + 3; /* These constants shown for clarity. */
1505 internal_error (&dtp
->common
, "bad real kind");
1510 size
= f
->u
.real
.w
+ 1; /* One byte for a NULL character. */
1516 select_buffer (st_parameter_dt
*dtp
, const fnode
*f
, int precision
,
1517 char *buf
, size_t *size
, int kind
)
1521 /* The buffer needs at least one more byte to allow room for normalizing. */
1522 *size
= size_from_kind (dtp
, f
, kind
) + precision
+ 1;
1524 if (*size
> BUF_STACK_SZ
)
1525 result
= xmalloc (*size
);
1532 select_string (st_parameter_dt
*dtp
, const fnode
*f
, char *buf
, size_t *size
,
1536 *size
= size_from_kind (dtp
, f
, kind
) + f
->u
.real
.d
+ 1;
1537 if (*size
> BUF_STACK_SZ
)
1538 result
= xmalloc (*size
);
1545 write_float_string (st_parameter_dt
*dtp
, char *fstr
, size_t len
)
1547 char *p
= write_block (dtp
, len
);
1551 if (unlikely (is_char4_unit (dtp
)))
1553 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1554 memcpy4 (p4
, fstr
, len
);
1557 memcpy (p
, fstr
, len
);
1562 write_float_0 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1564 char buf_stack
[BUF_STACK_SZ
];
1565 char str_buf
[BUF_STACK_SZ
];
1566 char *buffer
, *result
;
1567 size_t buf_size
, res_len
;
1569 /* Precision for snprintf call. */
1570 int precision
= get_precision (dtp
, f
, source
, kind
);
1572 /* String buffer to hold final result. */
1573 result
= select_string (dtp
, f
, str_buf
, &res_len
, kind
);
1575 buffer
= select_buffer (dtp
, f
, precision
, buf_stack
, &buf_size
, kind
);
1577 get_float_string (dtp
, f
, source
, kind
, 0, buffer
,
1578 precision
, buf_size
, result
, &res_len
);
1579 write_float_string (dtp
, result
, res_len
);
1581 if (buf_size
> BUF_STACK_SZ
)
1583 if (res_len
> BUF_STACK_SZ
)
1588 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1590 write_float_0 (dtp
, f
, p
, len
);
1595 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1597 write_float_0 (dtp
, f
, p
, len
);
1602 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1604 write_float_0 (dtp
, f
, p
, len
);
1609 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1611 write_float_0 (dtp
, f
, p
, len
);
1616 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1618 write_float_0 (dtp
, f
, p
, len
);
1622 /* Set an fnode to default format. */
1625 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1646 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1647 #if GFC_REAL_16_DIGITS == 113
1658 internal_error (&dtp
->common
, "bad real kind");
1663 /* Output a real number with default format.
1664 To guarantee that a binary -> decimal -> binary roundtrip conversion
1665 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1666 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1667 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1668 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1669 Fortran standard requires outputting an extra digit when the scale
1670 factor is 1 and when the magnitude of the value is such that E
1671 editing is used. However, gfortran compensates for this, and thus
1672 for list formatted the same number of significant digits is
1673 generated both when using F and E editing. */
1676 write_real (st_parameter_dt
*dtp
, const char *source
, int kind
)
1679 char buf_stack
[BUF_STACK_SZ
];
1680 char str_buf
[BUF_STACK_SZ
];
1681 char *buffer
, *result
;
1682 size_t buf_size
, res_len
;
1683 int orig_scale
= dtp
->u
.p
.scale_factor
;
1684 dtp
->u
.p
.scale_factor
= 1;
1685 set_fnode_default (dtp
, &f
, kind
);
1687 /* Precision for snprintf call. */
1688 int precision
= get_precision (dtp
, &f
, source
, kind
);
1690 /* String buffer to hold final result. */
1691 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1693 /* Scratch buffer to hold final result. */
1694 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1696 get_float_string (dtp
, &f
, source
, kind
, 1, buffer
,
1697 precision
, buf_size
, result
, &res_len
);
1698 write_float_string (dtp
, result
, res_len
);
1700 dtp
->u
.p
.scale_factor
= orig_scale
;
1701 if (buf_size
> BUF_STACK_SZ
)
1703 if (res_len
> BUF_STACK_SZ
)
1707 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1708 compensate for the extra digit. */
1711 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int kind
, int d
)
1714 char buf_stack
[BUF_STACK_SZ
];
1715 char str_buf
[BUF_STACK_SZ
];
1716 char *buffer
, *result
;
1717 size_t buf_size
, res_len
;
1719 set_fnode_default (dtp
, &f
, kind
);
1724 /* Compensate for extra digits when using scale factor, d is not
1725 specified, and the magnitude is such that E editing is used. */
1726 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1730 dtp
->u
.p
.g0_no_blanks
= 1;
1732 /* Precision for snprintf call. */
1733 int precision
= get_precision (dtp
, &f
, source
, kind
);
1735 /* String buffer to hold final result. */
1736 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1738 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1740 get_float_string (dtp
, &f
, source
, kind
, comp_d
, buffer
,
1741 precision
, buf_size
, result
, &res_len
);
1742 write_float_string (dtp
, result
, res_len
);
1744 dtp
->u
.p
.g0_no_blanks
= 0;
1745 if (buf_size
> BUF_STACK_SZ
)
1747 if (res_len
> BUF_STACK_SZ
)
1753 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1756 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1758 /* Set for no blanks so we get a string result with no leading
1759 blanks. We will pad left later. */
1760 dtp
->u
.p
.g0_no_blanks
= 1;
1763 char buf_stack
[BUF_STACK_SZ
];
1764 char str1_buf
[BUF_STACK_SZ
];
1765 char str2_buf
[BUF_STACK_SZ
];
1766 char *buffer
, *result1
, *result2
;
1767 size_t buf_size
, res_len1
, res_len2
;
1768 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1770 dtp
->u
.p
.scale_factor
= 1;
1771 set_fnode_default (dtp
, &f
, kind
);
1773 /* Set width for two values, parenthesis, and comma. */
1774 width
= 2 * f
.u
.real
.w
+ 3;
1776 /* Set for no blanks so we get a string result with no leading
1777 blanks. We will pad left later. */
1778 dtp
->u
.p
.g0_no_blanks
= 1;
1780 /* Precision for snprintf call. */
1781 int precision
= get_precision (dtp
, &f
, source
, kind
);
1783 /* String buffers to hold final result. */
1784 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1785 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1787 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1789 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1790 precision
, buf_size
, result1
, &res_len1
);
1791 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1792 precision
, buf_size
, result2
, &res_len2
);
1793 if (!dtp
->u
.p
.namelist_mode
)
1795 lblanks
= width
- res_len1
- res_len2
- 3;
1796 write_x (dtp
, lblanks
, lblanks
);
1798 write_char (dtp
, '(');
1799 write_float_string (dtp
, result1
, res_len1
);
1800 write_char (dtp
, semi_comma
);
1801 write_float_string (dtp
, result2
, res_len2
);
1802 write_char (dtp
, ')');
1804 dtp
->u
.p
.scale_factor
= orig_scale
;
1805 dtp
->u
.p
.g0_no_blanks
= 0;
1806 if (buf_size
> BUF_STACK_SZ
)
1808 if (res_len1
> BUF_STACK_SZ
)
1810 if (res_len2
> BUF_STACK_SZ
)
1815 /* Write the separator between items. */
1818 write_separator (st_parameter_dt
*dtp
)
1822 p
= write_block (dtp
, options
.separator_len
);
1825 if (unlikely (is_char4_unit (dtp
)))
1827 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1828 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1831 memcpy (p
, options
.separator
, options
.separator_len
);
1835 /* Write an item with list formatting.
1836 TODO: handle skipping to the next record correctly, particularly
1840 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1843 if (dtp
->u
.p
.current_unit
== NULL
)
1846 if (dtp
->u
.p
.first_item
)
1848 dtp
->u
.p
.first_item
= 0;
1849 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1850 write_char (dtp
, ' ');
1854 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1855 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1856 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1857 write_separator (dtp
);
1863 write_integer (dtp
, p
, kind
);
1866 write_logical (dtp
, p
, kind
);
1869 write_character (dtp
, p
, kind
, size
, DELIM
);
1872 write_real (dtp
, p
, kind
);
1875 write_complex (dtp
, p
, kind
, size
);
1879 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1880 char iotype
[] = "LISTDIRECTED";
1881 gfc_charlen_type iotype_len
= 12;
1882 char tmp_iomsg
[IOMSG_LEN
] = "";
1884 gfc_charlen_type child_iomsg_len
;
1886 int *child_iostat
= NULL
;
1889 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1890 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1892 /* Set iostat, intent(out). */
1894 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1895 dtp
->common
.iostat
: &noiostat
;
1897 /* Set iomsge, intent(inout). */
1898 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1900 child_iomsg
= dtp
->common
.iomsg
;
1901 child_iomsg_len
= dtp
->common
.iomsg_len
;
1905 child_iomsg
= tmp_iomsg
;
1906 child_iomsg_len
= IOMSG_LEN
;
1909 /* Call the user defined formatted WRITE procedure. */
1910 dtp
->u
.p
.current_unit
->child_dtio
++;
1911 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1912 child_iostat
, child_iomsg
,
1913 iotype_len
, child_iomsg_len
);
1914 dtp
->u
.p
.current_unit
->child_dtio
--;
1918 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1921 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1922 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1927 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1928 size_t size
, size_t nelems
)
1932 size_t stride
= type
== BT_CHARACTER
?
1933 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1937 /* Big loop over all the elements. */
1938 for (elem
= 0; elem
< nelems
; elem
++)
1940 dtp
->u
.p
.item_count
++;
1941 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1947 nml_write_obj writes a namelist object to the output stream. It is called
1948 recursively for derived type components:
1949 obj = is the namelist_info for the current object.
1950 offset = the offset relative to the address held by the object for
1951 derived type arrays.
1952 base = is the namelist_info of the derived type, when obj is a
1954 base_name = the full name for a derived type, including qualifiers
1956 The returned value is a pointer to the object beyond the last one
1957 accessed, including nested derived types. Notice that the namelist is
1958 a linear linked list of objects, including derived types and their
1959 components. A tree, of sorts, is implied by the compound names of
1960 the derived type components and this is how this function recurses through
1963 /* A generous estimate of the number of characters needed to print
1964 repeat counts and indices, including commas, asterices and brackets. */
1966 #define NML_DIGITS 20
1969 namelist_write_newline (st_parameter_dt
*dtp
)
1971 if (!is_internal_unit (dtp
))
1974 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
1976 write_character (dtp
, "\n", 1, 1, NODELIM
);
1981 if (is_array_io (dtp
))
1986 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
1988 p
= write_block (dtp
, length
);
1992 if (unlikely (is_char4_unit (dtp
)))
1994 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1995 memset4 (p4
, ' ', length
);
1998 memset (p
, ' ', length
);
2000 /* Now that the current record has been padded out,
2001 determine where the next record in the array is. */
2002 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2005 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2008 /* Now seek to this record */
2009 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2011 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2013 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2017 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2021 write_character (dtp
, " ", 1, 1, NODELIM
);
2025 static namelist_info
*
2026 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2027 namelist_info
*base
, char *base_name
)
2033 index_type obj_size
;
2037 index_type elem_ctr
;
2038 size_t obj_name_len
;
2044 size_t ext_name_len
;
2045 char rep_buff
[NML_DIGITS
];
2047 namelist_info
*retval
= obj
->next
;
2048 size_t base_name_len
;
2049 size_t base_var_name_len
;
2052 /* Set the character to be used to separate values
2053 to a comma or semi-colon. */
2056 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2058 /* Write namelist variable names in upper case. If a derived type,
2059 nothing is output. If a component, base and base_name are set. */
2061 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2063 namelist_write_newline (dtp
);
2064 write_character (dtp
, " ", 1, 1, NODELIM
);
2069 len
= strlen (base
->var_name
);
2070 base_name_len
= strlen (base_name
);
2071 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2073 cup
= toupper ((int) base_name
[dim_i
]);
2074 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2077 clen
= strlen (obj
->var_name
);
2078 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2080 cup
= toupper ((int) obj
->var_name
[dim_i
]);
2083 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2085 write_character (dtp
, "=", 1, 1, NODELIM
);
2088 /* Counts the number of data output on a line, including names. */
2098 obj_size
= size_from_real_kind (len
);
2102 obj_size
= size_from_complex_kind (len
);
2106 obj_size
= obj
->string_length
;
2114 obj_size
= obj
->size
;
2116 /* Set the index vector and count the number of elements. */
2119 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2121 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2122 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2125 /* Main loop to output the data held in the object. */
2128 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2131 /* Build the pointer to the data value. The offset is passed by
2132 recursive calls to this function for arrays of derived types.
2133 Is NULL otherwise. */
2135 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2138 /* Check for repeat counts of intrinsic types. */
2140 if ((elem_ctr
< (nelem
- 1)) &&
2141 (obj
->type
!= BT_DERIVED
) &&
2142 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2147 /* Execute a repeated output. Note the flag no_leading_blank that
2148 is used in the functions used to output the intrinsic types. */
2154 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2155 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2156 dtp
->u
.p
.no_leading_blank
= 1;
2160 /* Output the data, if an intrinsic type, or recurse into this
2161 routine to treat derived types. */
2167 write_integer (dtp
, p
, len
);
2171 write_logical (dtp
, p
, len
);
2175 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2176 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2178 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2182 write_real (dtp
, p
, len
);
2186 dtp
->u
.p
.no_leading_blank
= 0;
2188 write_complex (dtp
, p
, len
, obj_size
);
2193 /* To treat a derived type, we need to build two strings:
2194 ext_name = the name, including qualifiers that prepends
2195 component names in the output - passed to
2197 obj_name = the derived type name with no qualifiers but %
2198 appended. This is used to identify the
2201 /* First ext_name => get length of all possible components */
2202 if (obj
->dtio_sub
!= NULL
)
2204 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2205 char iotype
[] = "NAMELIST";
2206 gfc_charlen_type iotype_len
= 8;
2207 char tmp_iomsg
[IOMSG_LEN
] = "";
2209 gfc_charlen_type child_iomsg_len
;
2211 int *child_iostat
= NULL
;
2213 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2215 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2217 /* Set iostat, intent(out). */
2219 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2220 dtp
->common
.iostat
: &noiostat
;
2222 /* Set iomsg, intent(inout). */
2223 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2225 child_iomsg
= dtp
->common
.iomsg
;
2226 child_iomsg_len
= dtp
->common
.iomsg_len
;
2230 child_iomsg
= tmp_iomsg
;
2231 child_iomsg_len
= IOMSG_LEN
;
2234 /* Call the user defined formatted WRITE procedure. */
2235 dtp
->u
.p
.current_unit
->child_dtio
++;
2236 if (obj
->type
== BT_DERIVED
)
2238 /* Build a class container. */
2241 list_obj
.vptr
= obj
->vtable
;
2243 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2244 child_iostat
, child_iomsg
,
2245 iotype_len
, child_iomsg_len
);
2249 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2250 child_iostat
, child_iomsg
,
2251 iotype_len
, child_iomsg_len
);
2253 dtp
->u
.p
.current_unit
->child_dtio
--;
2258 base_name_len
= base_name
? strlen (base_name
) : 0;
2259 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2260 ext_name_len
= base_name_len
+ base_var_name_len
2261 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2262 ext_name
= xmalloc (ext_name_len
);
2265 memcpy (ext_name
, base_name
, base_name_len
);
2266 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2267 memcpy (ext_name
+ base_name_len
,
2268 obj
->var_name
+ base_var_name_len
, clen
);
2270 /* Append the qualifier. */
2272 tot_len
= base_name_len
+ clen
;
2273 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2277 ext_name
[tot_len
] = '(';
2280 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2281 (int) obj
->ls
[dim_i
].idx
);
2282 tot_len
+= strlen (ext_name
+ tot_len
);
2283 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2287 ext_name
[tot_len
] = '\0';
2288 for (q
= ext_name
; *q
; q
++)
2294 obj_name_len
= strlen (obj
->var_name
) + 1;
2295 obj_name
= xmalloc (obj_name_len
+ 1);
2296 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2297 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2299 /* Now loop over the components. Update the component pointer
2300 with the return value from nml_write_obj => this loop jumps
2301 past nested derived types. */
2303 for (cmp
= obj
->next
;
2304 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2307 retval
= nml_write_obj (dtp
, cmp
,
2308 (index_type
)(p
- obj
->mem_pos
),
2317 internal_error (&dtp
->common
, "Bad type for namelist write");
2320 /* Reset the leading blank suppression, write a comma (or semi-colon)
2321 and, if 5 values have been output, write a newline and advance
2322 to column 2. Reset the repeat counter. */
2324 dtp
->u
.p
.no_leading_blank
= 0;
2325 if (obj
->type
== BT_CHARACTER
)
2327 if (dtp
->u
.p
.nml_delim
!= '\0')
2328 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2331 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2335 if (dtp
->u
.p
.nml_delim
== '\0')
2336 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2337 namelist_write_newline (dtp
);
2338 write_character (dtp
, " ", 1, 1, NODELIM
);
2343 /* Cycle through and increment the index vector. */
2348 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2350 obj
->ls
[dim_i
].idx
+= nml_carry
;
2352 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2354 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2360 /* Return a pointer beyond the furthest object accessed. */
2366 /* This is the entry function for namelist writes. It outputs the name
2367 of the namelist and iterates through the namelist by calls to
2368 nml_write_obj. The call below has dummys in the arguments used in
2369 the treatment of derived types. */
2372 namelist_write (st_parameter_dt
*dtp
)
2374 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2376 index_type dummy_offset
= 0;
2378 char *dummy_name
= NULL
;
2380 /* Set the delimiter for namelist output. */
2381 switch (dtp
->u
.p
.current_unit
->delim_status
)
2383 case DELIM_APOSTROPHE
:
2384 dtp
->u
.p
.nml_delim
= '\'';
2387 case DELIM_UNSPECIFIED
:
2388 dtp
->u
.p
.nml_delim
= '"';
2391 dtp
->u
.p
.nml_delim
= '\0';
2394 write_character (dtp
, "&", 1, 1, NODELIM
);
2396 /* Write namelist name in upper case - f95 std. */
2397 for (gfc_charlen_type i
= 0; i
< dtp
->namelist_name_len
; i
++ )
2399 c
= toupper ((int) dtp
->namelist_name
[i
]);
2400 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2403 if (dtp
->u
.p
.ionml
!= NULL
)
2405 t1
= dtp
->u
.p
.ionml
;
2409 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2413 namelist_write_newline (dtp
);
2414 write_character (dtp
, " /", 1, 2, NODELIM
);