1 /* Copyright (C) 2002-2017 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 memset4 (p4
, ' ', nblank
);
888 memset4 (p4
, '0', nzero
);
891 memcpy4 (p4
, q
, digits
);
901 memset (p
, ' ', nblank
);
916 memset (p
, '0', nzero
);
919 memcpy (p
, q
, digits
);
926 /* Convert unsigned octal to ascii. */
929 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
933 assert (len
>= GFC_OTOA_BUF_SIZE
);
938 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
943 *--p
= '0' + (n
& 7);
951 /* Convert unsigned binary to ascii. */
954 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
958 assert (len
>= GFC_BTOA_BUF_SIZE
);
963 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
968 *--p
= '0' + (n
& 1);
975 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
976 to convert large reals with kind sizes that exceed the largest integer type
977 available on certain platforms. In these cases, byte by byte conversion is
978 performed. Endianess is taken into account. */
980 /* Conversion to binary. */
983 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
992 for (i
= 0; i
< len
; i
++)
996 /* Test for zero. Needed by write_boz later. */
1000 for (j
= 0; j
< 8; j
++)
1002 *q
++ = (c
& 128) ? '1' : '0';
1010 const char *p
= s
+ len
- 1;
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';
1033 /* Move past any leading zeros. */
1034 while (*buffer
== '0')
1041 /* Conversion to octal. */
1044 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1050 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
1056 const char *p
= s
+ len
- 1;
1060 /* Test for zero. Needed by write_boz later. */
1064 for (j
= 0; j
< 3 && i
< len
; j
++)
1066 octet
|= (c
& 1) << j
;
1085 /* Test for zero. Needed by write_boz later. */
1089 for (j
= 0; j
< 3 && i
< len
; j
++)
1091 octet
|= (c
& 1) << j
;
1108 /* Move past any leading zeros. */
1115 /* Conversion to hexidecimal. */
1118 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
1120 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
1121 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1132 for (i
= 0; i
< len
; i
++)
1134 /* Test for zero. Needed by write_boz later. */
1138 h
= (*p
>> 4) & 0x0F;
1146 const char *p
= s
+ len
- 1;
1147 for (i
= 0; i
< len
; i
++)
1149 /* Test for zero. Needed by write_boz later. */
1153 h
= (*p
>> 4) & 0x0F;
1165 /* Move past any leading zeros. */
1166 while (*buffer
== '0')
1174 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1176 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1181 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1184 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1185 GFC_UINTEGER_LARGEST n
= 0;
1187 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1189 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1190 write_boz (dtp
, f
, p
, n
);
1194 n
= extract_uint (source
, len
);
1195 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1196 write_boz (dtp
, f
, p
, n
);
1202 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1205 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1206 GFC_UINTEGER_LARGEST n
= 0;
1208 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1210 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1211 write_boz (dtp
, f
, p
, n
);
1215 n
= extract_uint (source
, len
);
1216 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1217 write_boz (dtp
, f
, p
, n
);
1222 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1225 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1226 GFC_UINTEGER_LARGEST n
= 0;
1228 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1230 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1231 write_boz (dtp
, f
, p
, n
);
1235 n
= extract_uint (source
, len
);
1236 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1237 write_boz (dtp
, f
, p
, n
);
1241 /* Take care of the X/TR descriptor. */
1244 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1248 p
= write_block (dtp
, len
);
1251 if (nspaces
> 0 && len
- nspaces
>= 0)
1253 if (unlikely (is_char4_unit (dtp
)))
1255 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1256 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1259 memset (&p
[len
- nspaces
], ' ', nspaces
);
1264 /* List-directed writing. */
1267 /* Write a single character to the output. Returns nonzero if
1268 something goes wrong. */
1271 write_char (st_parameter_dt
*dtp
, int c
)
1275 p
= write_block (dtp
, 1);
1278 if (unlikely (is_char4_unit (dtp
)))
1280 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1291 /* Write a list-directed logical value. */
1294 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1296 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1300 /* Write a list-directed integer value. */
1303 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1309 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1311 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1336 digits
= strlen (q
);
1340 p
= write_block (dtp
, width
);
1344 if (unlikely (is_char4_unit (dtp
)))
1346 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1347 if (dtp
->u
.p
.no_leading_blank
)
1349 memcpy4 (p4
, q
, digits
);
1350 memset4 (p4
+ digits
, ' ', width
- digits
);
1354 memset4 (p4
, ' ', width
- digits
);
1355 memcpy4 (p4
+ width
- digits
, q
, digits
);
1360 if (dtp
->u
.p
.no_leading_blank
)
1362 memcpy (p
, q
, digits
);
1363 memset (p
+ digits
, ' ', width
- digits
);
1367 memset (p
, ' ', width
- digits
);
1368 memcpy (p
+ width
- digits
, q
, digits
);
1373 /* Write a list-directed string. We have to worry about delimiting
1374 the strings if the file has been opened in that mode. */
1380 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
, int mode
)
1387 switch (dtp
->u
.p
.current_unit
->delim_status
)
1389 case DELIM_APOSTROPHE
:
1411 for (i
= 0; i
< length
; i
++)
1416 p
= write_block (dtp
, length
+ extra
);
1420 if (unlikely (is_char4_unit (dtp
)))
1422 gfc_char4_t d4
= (gfc_char4_t
) d
;
1423 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1426 memcpy4 (p4
, source
, length
);
1431 for (i
= 0; i
< length
; i
++)
1433 *p4
++ = (gfc_char4_t
) source
[i
];
1444 memcpy (p
, source
, length
);
1449 for (i
= 0; i
< length
; i
++)
1463 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1464 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1466 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1470 p
= write_block (dtp
, 1);
1473 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1474 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1476 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1478 p
= write_block (dtp
, 1);
1484 /* Floating point helper functions. */
1486 #define BUF_STACK_SZ 256
1489 get_precision (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1491 if (f
->format
!= FMT_EN
)
1492 return determine_precision (dtp
, f
, kind
);
1494 return determine_en_precision (dtp
, f
, source
, kind
);
1497 /* 4932 is the maximum exponent of long double and quad precision, 3
1498 extra characters for the sign, the decimal point, and the
1499 trailing null. Extra digits are added by the calling functions for
1500 requested precision. Likewise for float and double. F0 editing produces
1501 full precision output. */
1503 size_from_kind (st_parameter_dt
*dtp
, const fnode
*f
, int kind
)
1507 if (f
->format
== FMT_F
&& f
->u
.real
.w
== 0)
1512 size
= 38 + 3; /* These constants shown for clarity. */
1524 internal_error (&dtp
->common
, "bad real kind");
1529 size
= f
->u
.real
.w
+ 1; /* One byte for a NULL character. */
1535 select_buffer (st_parameter_dt
*dtp
, const fnode
*f
, int precision
,
1536 char *buf
, size_t *size
, int kind
)
1540 /* The buffer needs at least one more byte to allow room for normalizing. */
1541 *size
= size_from_kind (dtp
, f
, kind
) + precision
+ 1;
1543 if (*size
> BUF_STACK_SZ
)
1544 result
= xmalloc (*size
);
1551 select_string (st_parameter_dt
*dtp
, const fnode
*f
, char *buf
, size_t *size
,
1555 *size
= size_from_kind (dtp
, f
, kind
) + f
->u
.real
.d
;
1556 if (*size
> BUF_STACK_SZ
)
1557 result
= xmalloc (*size
);
1564 write_float_string (st_parameter_dt
*dtp
, char *fstr
, size_t len
)
1566 char *p
= write_block (dtp
, len
);
1570 if (unlikely (is_char4_unit (dtp
)))
1572 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1573 memcpy4 (p4
, fstr
, len
);
1576 memcpy (p
, fstr
, len
);
1581 write_float_0 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1583 char buf_stack
[BUF_STACK_SZ
];
1584 char str_buf
[BUF_STACK_SZ
];
1585 char *buffer
, *result
;
1586 size_t buf_size
, res_len
;
1588 /* Precision for snprintf call. */
1589 int precision
= get_precision (dtp
, f
, source
, kind
);
1591 /* String buffer to hold final result. */
1592 result
= select_string (dtp
, f
, str_buf
, &res_len
, kind
);
1594 buffer
= select_buffer (dtp
, f
, precision
, buf_stack
, &buf_size
, kind
);
1596 get_float_string (dtp
, f
, source
, kind
, 0, buffer
,
1597 precision
, buf_size
, result
, &res_len
);
1598 write_float_string (dtp
, result
, res_len
);
1600 if (buf_size
> BUF_STACK_SZ
)
1602 if (res_len
> BUF_STACK_SZ
)
1607 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1609 write_float_0 (dtp
, f
, p
, len
);
1614 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1616 write_float_0 (dtp
, f
, p
, len
);
1621 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1623 write_float_0 (dtp
, f
, p
, len
);
1628 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1630 write_float_0 (dtp
, f
, p
, len
);
1635 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1637 write_float_0 (dtp
, f
, p
, len
);
1641 /* Set an fnode to default format. */
1644 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1665 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1666 #if GFC_REAL_16_DIGITS == 113
1677 internal_error (&dtp
->common
, "bad real kind");
1682 /* Output a real number with default format.
1683 To guarantee that a binary -> decimal -> binary roundtrip conversion
1684 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1685 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1686 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1687 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1688 Fortran standard requires outputting an extra digit when the scale
1689 factor is 1 and when the magnitude of the value is such that E
1690 editing is used. However, gfortran compensates for this, and thus
1691 for list formatted the same number of significant digits is
1692 generated both when using F and E editing. */
1695 write_real (st_parameter_dt
*dtp
, const char *source
, int kind
)
1698 char buf_stack
[BUF_STACK_SZ
];
1699 char str_buf
[BUF_STACK_SZ
];
1700 char *buffer
, *result
;
1701 size_t buf_size
, res_len
;
1702 int orig_scale
= dtp
->u
.p
.scale_factor
;
1703 dtp
->u
.p
.scale_factor
= 1;
1704 set_fnode_default (dtp
, &f
, kind
);
1706 /* Precision for snprintf call. */
1707 int precision
= get_precision (dtp
, &f
, source
, kind
);
1709 /* String buffer to hold final result. */
1710 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1712 /* Scratch buffer to hold final result. */
1713 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1715 get_float_string (dtp
, &f
, source
, kind
, 1, buffer
,
1716 precision
, buf_size
, result
, &res_len
);
1717 write_float_string (dtp
, result
, res_len
);
1719 dtp
->u
.p
.scale_factor
= orig_scale
;
1720 if (buf_size
> BUF_STACK_SZ
)
1722 if (res_len
> BUF_STACK_SZ
)
1726 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1727 compensate for the extra digit. */
1730 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int kind
, int d
)
1733 char buf_stack
[BUF_STACK_SZ
];
1734 char str_buf
[BUF_STACK_SZ
];
1735 char *buffer
, *result
;
1736 size_t buf_size
, res_len
;
1738 set_fnode_default (dtp
, &f
, kind
);
1743 /* Compensate for extra digits when using scale factor, d is not
1744 specified, and the magnitude is such that E editing is used. */
1745 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1749 dtp
->u
.p
.g0_no_blanks
= 1;
1751 /* Precision for snprintf call. */
1752 int precision
= get_precision (dtp
, &f
, source
, kind
);
1754 /* String buffer to hold final result. */
1755 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1757 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1759 get_float_string (dtp
, &f
, source
, kind
, comp_d
, buffer
,
1760 precision
, buf_size
, result
, &res_len
);
1761 write_float_string (dtp
, result
, res_len
);
1763 dtp
->u
.p
.g0_no_blanks
= 0;
1764 if (buf_size
> BUF_STACK_SZ
)
1766 if (res_len
> BUF_STACK_SZ
)
1772 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1775 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1777 /* Set for no blanks so we get a string result with no leading
1778 blanks. We will pad left later. */
1779 dtp
->u
.p
.g0_no_blanks
= 1;
1782 char buf_stack
[BUF_STACK_SZ
];
1783 char str1_buf
[BUF_STACK_SZ
];
1784 char str2_buf
[BUF_STACK_SZ
];
1785 char *buffer
, *result1
, *result2
;
1786 size_t buf_size
, res_len1
, res_len2
;
1787 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1789 dtp
->u
.p
.scale_factor
= 1;
1790 set_fnode_default (dtp
, &f
, kind
);
1792 /* Set width for two values, parenthesis, and comma. */
1793 width
= 2 * f
.u
.real
.w
+ 3;
1795 /* Set for no blanks so we get a string result with no leading
1796 blanks. We will pad left later. */
1797 dtp
->u
.p
.g0_no_blanks
= 1;
1799 /* Precision for snprintf call. */
1800 int precision
= get_precision (dtp
, &f
, source
, kind
);
1802 /* String buffers to hold final result. */
1803 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1804 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1806 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1808 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1809 precision
, buf_size
, result1
, &res_len1
);
1810 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1811 precision
, buf_size
, result2
, &res_len2
);
1812 lblanks
= width
- res_len1
- res_len2
- 3;
1814 write_x (dtp
, lblanks
, lblanks
);
1815 write_char (dtp
, '(');
1816 write_float_string (dtp
, result1
, res_len1
);
1817 write_char (dtp
, semi_comma
);
1818 write_float_string (dtp
, result2
, res_len2
);
1819 write_char (dtp
, ')');
1821 dtp
->u
.p
.scale_factor
= orig_scale
;
1822 dtp
->u
.p
.g0_no_blanks
= 0;
1823 if (buf_size
> BUF_STACK_SZ
)
1825 if (res_len1
> BUF_STACK_SZ
)
1827 if (res_len2
> BUF_STACK_SZ
)
1832 /* Write the separator between items. */
1835 write_separator (st_parameter_dt
*dtp
)
1839 p
= write_block (dtp
, options
.separator_len
);
1842 if (unlikely (is_char4_unit (dtp
)))
1844 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1845 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1848 memcpy (p
, options
.separator
, options
.separator_len
);
1852 /* Write an item with list formatting.
1853 TODO: handle skipping to the next record correctly, particularly
1857 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1860 if (dtp
->u
.p
.current_unit
== NULL
)
1863 if (dtp
->u
.p
.first_item
)
1865 dtp
->u
.p
.first_item
= 0;
1866 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1867 write_char (dtp
, ' ');
1871 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1872 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1873 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1874 write_separator (dtp
);
1880 write_integer (dtp
, p
, kind
);
1883 write_logical (dtp
, p
, kind
);
1886 write_character (dtp
, p
, kind
, size
, DELIM
);
1889 write_real (dtp
, p
, kind
);
1892 write_complex (dtp
, p
, kind
, size
);
1896 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1897 char iotype
[] = "LISTDIRECTED";
1898 gfc_charlen_type iotype_len
= 12;
1899 char tmp_iomsg
[IOMSG_LEN
] = "";
1901 gfc_charlen_type child_iomsg_len
;
1903 int *child_iostat
= NULL
;
1906 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1907 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1909 /* Set iostat, intent(out). */
1911 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1912 dtp
->common
.iostat
: &noiostat
;
1914 /* Set iomsge, intent(inout). */
1915 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1917 child_iomsg
= dtp
->common
.iomsg
;
1918 child_iomsg_len
= dtp
->common
.iomsg_len
;
1922 child_iomsg
= tmp_iomsg
;
1923 child_iomsg_len
= IOMSG_LEN
;
1926 /* Call the user defined formatted WRITE procedure. */
1927 dtp
->u
.p
.current_unit
->child_dtio
++;
1928 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1929 child_iostat
, child_iomsg
,
1930 iotype_len
, child_iomsg_len
);
1931 dtp
->u
.p
.current_unit
->child_dtio
--;
1935 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1938 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1939 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1944 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1945 size_t size
, size_t nelems
)
1949 size_t stride
= type
== BT_CHARACTER
?
1950 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1954 /* Big loop over all the elements. */
1955 for (elem
= 0; elem
< nelems
; elem
++)
1957 dtp
->u
.p
.item_count
++;
1958 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1964 nml_write_obj writes a namelist object to the output stream. It is called
1965 recursively for derived type components:
1966 obj = is the namelist_info for the current object.
1967 offset = the offset relative to the address held by the object for
1968 derived type arrays.
1969 base = is the namelist_info of the derived type, when obj is a
1971 base_name = the full name for a derived type, including qualifiers
1973 The returned value is a pointer to the object beyond the last one
1974 accessed, including nested derived types. Notice that the namelist is
1975 a linear linked list of objects, including derived types and their
1976 components. A tree, of sorts, is implied by the compound names of
1977 the derived type components and this is how this function recurses through
1980 /* A generous estimate of the number of characters needed to print
1981 repeat counts and indices, including commas, asterices and brackets. */
1983 #define NML_DIGITS 20
1986 namelist_write_newline (st_parameter_dt
*dtp
)
1988 if (!is_internal_unit (dtp
))
1991 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
1993 write_character (dtp
, "\n", 1, 1, NODELIM
);
1998 if (is_array_io (dtp
))
2003 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
2005 p
= write_block (dtp
, length
);
2009 if (unlikely (is_char4_unit (dtp
)))
2011 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
2012 memset4 (p4
, ' ', length
);
2015 memset (p
, ' ', length
);
2017 /* Now that the current record has been padded out,
2018 determine where the next record in the array is. */
2019 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2022 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2025 /* Now seek to this record */
2026 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2028 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2030 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2034 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2038 write_character (dtp
, " ", 1, 1, NODELIM
);
2042 static namelist_info
*
2043 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2044 namelist_info
*base
, char *base_name
)
2050 index_type obj_size
;
2054 index_type elem_ctr
;
2055 size_t obj_name_len
;
2061 size_t ext_name_len
;
2062 char rep_buff
[NML_DIGITS
];
2064 namelist_info
*retval
= obj
->next
;
2065 size_t base_name_len
;
2066 size_t base_var_name_len
;
2069 /* Set the character to be used to separate values
2070 to a comma or semi-colon. */
2073 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2075 /* Write namelist variable names in upper case. If a derived type,
2076 nothing is output. If a component, base and base_name are set. */
2078 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2080 namelist_write_newline (dtp
);
2081 write_character (dtp
, " ", 1, 1, NODELIM
);
2086 len
= strlen (base
->var_name
);
2087 base_name_len
= strlen (base_name
);
2088 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2090 cup
= toupper ((int) base_name
[dim_i
]);
2091 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2094 clen
= strlen (obj
->var_name
);
2095 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2097 cup
= toupper ((int) obj
->var_name
[dim_i
]);
2100 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2102 write_character (dtp
, "=", 1, 1, NODELIM
);
2105 /* Counts the number of data output on a line, including names. */
2115 obj_size
= size_from_real_kind (len
);
2119 obj_size
= size_from_complex_kind (len
);
2123 obj_size
= obj
->string_length
;
2131 obj_size
= obj
->size
;
2133 /* Set the index vector and count the number of elements. */
2136 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2138 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2139 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2142 /* Main loop to output the data held in the object. */
2145 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2148 /* Build the pointer to the data value. The offset is passed by
2149 recursive calls to this function for arrays of derived types.
2150 Is NULL otherwise. */
2152 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2155 /* Check for repeat counts of intrinsic types. */
2157 if ((elem_ctr
< (nelem
- 1)) &&
2158 (obj
->type
!= BT_DERIVED
) &&
2159 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2164 /* Execute a repeated output. Note the flag no_leading_blank that
2165 is used in the functions used to output the intrinsic types. */
2171 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2172 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2173 dtp
->u
.p
.no_leading_blank
= 1;
2177 /* Output the data, if an intrinsic type, or recurse into this
2178 routine to treat derived types. */
2184 write_integer (dtp
, p
, len
);
2188 write_logical (dtp
, p
, len
);
2192 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2193 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2195 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2199 write_real (dtp
, p
, len
);
2203 dtp
->u
.p
.no_leading_blank
= 0;
2205 write_complex (dtp
, p
, len
, obj_size
);
2210 /* To treat a derived type, we need to build two strings:
2211 ext_name = the name, including qualifiers that prepends
2212 component names in the output - passed to
2214 obj_name = the derived type name with no qualifiers but %
2215 appended. This is used to identify the
2218 /* First ext_name => get length of all possible components */
2219 if (obj
->dtio_sub
!= NULL
)
2221 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2222 char iotype
[] = "NAMELIST";
2223 gfc_charlen_type iotype_len
= 8;
2224 char tmp_iomsg
[IOMSG_LEN
] = "";
2226 gfc_charlen_type child_iomsg_len
;
2228 int *child_iostat
= NULL
;
2230 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2232 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2234 /* Set iostat, intent(out). */
2236 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2237 dtp
->common
.iostat
: &noiostat
;
2239 /* Set iomsg, intent(inout). */
2240 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2242 child_iomsg
= dtp
->common
.iomsg
;
2243 child_iomsg_len
= dtp
->common
.iomsg_len
;
2247 child_iomsg
= tmp_iomsg
;
2248 child_iomsg_len
= IOMSG_LEN
;
2251 /* If writing to an internal unit, stash it to allow
2252 the child procedure to access it. */
2253 if (is_internal_unit (dtp
))
2254 stash_internal_unit (dtp
);
2256 /* Call the user defined formatted WRITE procedure. */
2257 dtp
->u
.p
.current_unit
->child_dtio
++;
2258 if (obj
->type
== BT_DERIVED
)
2260 // build a class container
2263 list_obj
.vptr
= obj
->vtable
;
2265 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2266 child_iostat
, child_iomsg
,
2267 iotype_len
, child_iomsg_len
);
2271 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2272 child_iostat
, child_iomsg
,
2273 iotype_len
, child_iomsg_len
);
2275 dtp
->u
.p
.current_unit
->child_dtio
--;
2280 base_name_len
= base_name
? strlen (base_name
) : 0;
2281 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2282 ext_name_len
= base_name_len
+ base_var_name_len
2283 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2284 ext_name
= xmalloc (ext_name_len
);
2287 memcpy (ext_name
, base_name
, base_name_len
);
2288 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2289 memcpy (ext_name
+ base_name_len
,
2290 obj
->var_name
+ base_var_name_len
, clen
);
2292 /* Append the qualifier. */
2294 tot_len
= base_name_len
+ clen
;
2295 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2299 ext_name
[tot_len
] = '(';
2302 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2303 (int) obj
->ls
[dim_i
].idx
);
2304 tot_len
+= strlen (ext_name
+ tot_len
);
2305 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2309 ext_name
[tot_len
] = '\0';
2310 for (q
= ext_name
; *q
; q
++)
2316 obj_name_len
= strlen (obj
->var_name
) + 1;
2317 obj_name
= xmalloc (obj_name_len
+ 1);
2318 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2319 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2321 /* Now loop over the components. Update the component pointer
2322 with the return value from nml_write_obj => this loop jumps
2323 past nested derived types. */
2325 for (cmp
= obj
->next
;
2326 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2329 retval
= nml_write_obj (dtp
, cmp
,
2330 (index_type
)(p
- obj
->mem_pos
),
2339 internal_error (&dtp
->common
, "Bad type for namelist write");
2342 /* Reset the leading blank suppression, write a comma (or semi-colon)
2343 and, if 5 values have been output, write a newline and advance
2344 to column 2. Reset the repeat counter. */
2346 dtp
->u
.p
.no_leading_blank
= 0;
2347 if (obj
->type
== BT_CHARACTER
)
2349 if (dtp
->u
.p
.nml_delim
!= '\0')
2350 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2353 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2357 if (dtp
->u
.p
.nml_delim
== '\0')
2358 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2359 namelist_write_newline (dtp
);
2360 write_character (dtp
, " ", 1, 1, NODELIM
);
2365 /* Cycle through and increment the index vector. */
2370 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2372 obj
->ls
[dim_i
].idx
+= nml_carry
;
2374 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2376 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2382 /* Return a pointer beyond the furthest object accessed. */
2388 /* This is the entry function for namelist writes. It outputs the name
2389 of the namelist and iterates through the namelist by calls to
2390 nml_write_obj. The call below has dummys in the arguments used in
2391 the treatment of derived types. */
2394 namelist_write (st_parameter_dt
*dtp
)
2396 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2398 index_type dummy_offset
= 0;
2400 char *dummy_name
= NULL
;
2402 /* Set the delimiter for namelist output. */
2403 switch (dtp
->u
.p
.current_unit
->delim_status
)
2405 case DELIM_APOSTROPHE
:
2406 dtp
->u
.p
.nml_delim
= '\'';
2409 case DELIM_UNSPECIFIED
:
2410 dtp
->u
.p
.nml_delim
= '"';
2413 dtp
->u
.p
.nml_delim
= '\0';
2416 write_character (dtp
, "&", 1, 1, NODELIM
);
2418 /* Write namelist name in upper case - f95 std. */
2419 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
2421 c
= toupper ((int) dtp
->namelist_name
[i
]);
2422 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2425 if (dtp
->u
.p
.ionml
!= NULL
)
2427 t1
= dtp
->u
.p
.ionml
;
2431 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2435 namelist_write_newline (dtp
);
2436 write_character (dtp
, " /", 1, 2, NODELIM
);