1 /* Copyright (C) 2002-2019 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
)
1353 f
.u
.integer
.w
= width
;
1355 f
.format
= FMT_NONE
;
1356 write_decimal (dtp
, &f
, source
, kind
, (void *) gfc_itoa
);
1360 /* Write a list-directed string. We have to worry about delimiting
1361 the strings if the file has been opened in that mode. */
1367 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t length
, int mode
)
1374 switch (dtp
->u
.p
.current_unit
->delim_status
)
1376 case DELIM_APOSTROPHE
:
1398 for (size_t i
= 0; i
< length
; i
++)
1403 p
= write_block (dtp
, length
+ extra
);
1407 if (unlikely (is_char4_unit (dtp
)))
1409 gfc_char4_t d4
= (gfc_char4_t
) d
;
1410 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1413 memcpy4 (p4
, source
, length
);
1418 for (size_t i
= 0; i
< length
; i
++)
1420 *p4
++ = (gfc_char4_t
) source
[i
];
1431 memcpy (p
, source
, length
);
1436 for (size_t i
= 0; i
< length
; i
++)
1450 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1451 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1453 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1457 p
= write_block (dtp
, 1);
1460 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1461 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1463 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1465 p
= write_block (dtp
, 1);
1471 /* Floating point helper functions. */
1473 #define BUF_STACK_SZ 384
1476 get_precision (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1478 if (f
->format
!= FMT_EN
)
1479 return determine_precision (dtp
, f
, kind
);
1481 return determine_en_precision (dtp
, f
, source
, kind
);
1484 /* 4932 is the maximum exponent of long double and quad precision, 3
1485 extra characters for the sign, the decimal point, and the
1486 trailing null. Extra digits are added by the calling functions for
1487 requested precision. Likewise for float and double. F0 editing produces
1488 full precision output. */
1490 size_from_kind (st_parameter_dt
*dtp
, const fnode
*f
, int kind
)
1494 if (f
->format
== FMT_F
&& f
->u
.real
.w
== 0)
1499 size
= 38 + 3; /* These constants shown for clarity. */
1511 internal_error (&dtp
->common
, "bad real kind");
1516 size
= f
->u
.real
.w
+ 1; /* One byte for a NULL character. */
1522 select_buffer (st_parameter_dt
*dtp
, const fnode
*f
, int precision
,
1523 char *buf
, size_t *size
, int kind
)
1527 /* The buffer needs at least one more byte to allow room for
1528 normalizing and 1 to hold null terminator. */
1529 *size
= size_from_kind (dtp
, f
, kind
) + precision
+ 1 + 1;
1531 if (*size
> BUF_STACK_SZ
)
1532 result
= xmalloc (*size
);
1539 select_string (st_parameter_dt
*dtp
, const fnode
*f
, char *buf
, size_t *size
,
1543 *size
= size_from_kind (dtp
, f
, kind
) + f
->u
.real
.d
+ 1;
1544 if (*size
> BUF_STACK_SZ
)
1545 result
= xmalloc (*size
);
1552 write_float_string (st_parameter_dt
*dtp
, char *fstr
, size_t len
)
1554 char *p
= write_block (dtp
, len
);
1558 if (unlikely (is_char4_unit (dtp
)))
1560 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1561 memcpy4 (p4
, fstr
, len
);
1564 memcpy (p
, fstr
, len
);
1569 write_float_0 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int kind
)
1571 char buf_stack
[BUF_STACK_SZ
];
1572 char str_buf
[BUF_STACK_SZ
];
1573 char *buffer
, *result
;
1574 size_t buf_size
, res_len
, flt_str_len
;
1576 /* Precision for snprintf call. */
1577 int precision
= get_precision (dtp
, f
, source
, kind
);
1579 /* String buffer to hold final result. */
1580 result
= select_string (dtp
, f
, str_buf
, &res_len
, kind
);
1582 buffer
= select_buffer (dtp
, f
, precision
, buf_stack
, &buf_size
, kind
);
1584 get_float_string (dtp
, f
, source
, kind
, 0, buffer
,
1585 precision
, buf_size
, result
, &flt_str_len
);
1586 write_float_string (dtp
, result
, flt_str_len
);
1588 if (buf_size
> BUF_STACK_SZ
)
1590 if (res_len
> BUF_STACK_SZ
)
1595 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1597 write_float_0 (dtp
, f
, p
, len
);
1602 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1604 write_float_0 (dtp
, f
, p
, len
);
1609 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1611 write_float_0 (dtp
, f
, p
, len
);
1616 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1618 write_float_0 (dtp
, f
, p
, len
);
1623 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1625 write_float_0 (dtp
, f
, p
, len
);
1629 /* Set an fnode to default format. */
1632 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1653 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1654 #if GFC_REAL_16_DIGITS == 113
1665 internal_error (&dtp
->common
, "bad real kind");
1670 /* Output a real number with default format.
1671 To guarantee that a binary -> decimal -> binary roundtrip conversion
1672 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
1673 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
1674 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
1675 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1676 Fortran standard requires outputting an extra digit when the scale
1677 factor is 1 and when the magnitude of the value is such that E
1678 editing is used. However, gfortran compensates for this, and thus
1679 for list formatted the same number of significant digits is
1680 generated both when using F and E editing. */
1683 write_real (st_parameter_dt
*dtp
, const char *source
, int kind
)
1686 char buf_stack
[BUF_STACK_SZ
];
1687 char str_buf
[BUF_STACK_SZ
];
1688 char *buffer
, *result
;
1689 size_t buf_size
, res_len
, flt_str_len
;
1690 int orig_scale
= dtp
->u
.p
.scale_factor
;
1691 dtp
->u
.p
.scale_factor
= 1;
1692 set_fnode_default (dtp
, &f
, kind
);
1694 /* Precision for snprintf call. */
1695 int precision
= get_precision (dtp
, &f
, source
, kind
);
1697 /* String buffer to hold final result. */
1698 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1700 /* Scratch buffer to hold final result. */
1701 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1703 get_float_string (dtp
, &f
, source
, kind
, 1, buffer
,
1704 precision
, buf_size
, result
, &flt_str_len
);
1705 write_float_string (dtp
, result
, flt_str_len
);
1707 dtp
->u
.p
.scale_factor
= orig_scale
;
1708 if (buf_size
> BUF_STACK_SZ
)
1710 if (res_len
> BUF_STACK_SZ
)
1714 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1715 compensate for the extra digit. */
1718 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int kind
, int d
)
1721 char buf_stack
[BUF_STACK_SZ
];
1722 char str_buf
[BUF_STACK_SZ
];
1723 char *buffer
, *result
;
1724 size_t buf_size
, res_len
, flt_str_len
;
1726 set_fnode_default (dtp
, &f
, kind
);
1731 /* Compensate for extra digits when using scale factor, d is not
1732 specified, and the magnitude is such that E editing is used. */
1733 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1737 dtp
->u
.p
.g0_no_blanks
= 1;
1739 /* Precision for snprintf call. */
1740 int precision
= get_precision (dtp
, &f
, source
, kind
);
1742 /* String buffer to hold final result. */
1743 result
= select_string (dtp
, &f
, str_buf
, &res_len
, kind
);
1745 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1747 get_float_string (dtp
, &f
, source
, kind
, comp_d
, buffer
,
1748 precision
, buf_size
, result
, &flt_str_len
);
1749 write_float_string (dtp
, result
, flt_str_len
);
1751 dtp
->u
.p
.g0_no_blanks
= 0;
1752 if (buf_size
> BUF_STACK_SZ
)
1754 if (res_len
> BUF_STACK_SZ
)
1760 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1763 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1765 /* Set for no blanks so we get a string result with no leading
1766 blanks. We will pad left later. */
1767 dtp
->u
.p
.g0_no_blanks
= 1;
1770 char buf_stack
[BUF_STACK_SZ
];
1771 char str1_buf
[BUF_STACK_SZ
];
1772 char str2_buf
[BUF_STACK_SZ
];
1773 char *buffer
, *result1
, *result2
;
1774 size_t buf_size
, res_len1
, res_len2
, flt_str_len1
, flt_str_len2
;
1775 int width
, lblanks
, orig_scale
= dtp
->u
.p
.scale_factor
;
1777 dtp
->u
.p
.scale_factor
= 1;
1778 set_fnode_default (dtp
, &f
, kind
);
1780 /* Set width for two values, parenthesis, and comma. */
1781 width
= 2 * f
.u
.real
.w
+ 3;
1783 /* Set for no blanks so we get a string result with no leading
1784 blanks. We will pad left later. */
1785 dtp
->u
.p
.g0_no_blanks
= 1;
1787 /* Precision for snprintf call. */
1788 int precision
= get_precision (dtp
, &f
, source
, kind
);
1790 /* String buffers to hold final result. */
1791 result1
= select_string (dtp
, &f
, str1_buf
, &res_len1
, kind
);
1792 result2
= select_string (dtp
, &f
, str2_buf
, &res_len2
, kind
);
1794 buffer
= select_buffer (dtp
, &f
, precision
, buf_stack
, &buf_size
, kind
);
1796 get_float_string (dtp
, &f
, source
, kind
, 0, buffer
,
1797 precision
, buf_size
, result1
, &flt_str_len1
);
1798 get_float_string (dtp
, &f
, source
+ size
/ 2 , kind
, 0, buffer
,
1799 precision
, buf_size
, result2
, &flt_str_len2
);
1800 if (!dtp
->u
.p
.namelist_mode
)
1802 lblanks
= width
- flt_str_len1
- flt_str_len2
- 3;
1803 write_x (dtp
, lblanks
, lblanks
);
1805 write_char (dtp
, '(');
1806 write_float_string (dtp
, result1
, flt_str_len1
);
1807 write_char (dtp
, semi_comma
);
1808 write_float_string (dtp
, result2
, flt_str_len2
);
1809 write_char (dtp
, ')');
1811 dtp
->u
.p
.scale_factor
= orig_scale
;
1812 dtp
->u
.p
.g0_no_blanks
= 0;
1813 if (buf_size
> BUF_STACK_SZ
)
1815 if (res_len1
> BUF_STACK_SZ
)
1817 if (res_len2
> BUF_STACK_SZ
)
1822 /* Write the separator between items. */
1825 write_separator (st_parameter_dt
*dtp
)
1829 p
= write_block (dtp
, options
.separator_len
);
1832 if (unlikely (is_char4_unit (dtp
)))
1834 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1835 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1838 memcpy (p
, options
.separator
, options
.separator_len
);
1842 /* Write an item with list formatting.
1843 TODO: handle skipping to the next record correctly, particularly
1847 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1850 if (dtp
->u
.p
.current_unit
== NULL
)
1853 if (dtp
->u
.p
.first_item
)
1855 dtp
->u
.p
.first_item
= 0;
1856 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1857 write_char (dtp
, ' ');
1861 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1862 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1863 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1864 write_separator (dtp
);
1870 write_integer (dtp
, p
, kind
);
1873 write_logical (dtp
, p
, kind
);
1876 write_character (dtp
, p
, kind
, size
, DELIM
);
1879 write_real (dtp
, p
, kind
);
1882 write_complex (dtp
, p
, kind
, size
);
1886 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1887 char iotype
[] = "LISTDIRECTED";
1888 gfc_charlen_type iotype_len
= 12;
1889 char tmp_iomsg
[IOMSG_LEN
] = "";
1891 gfc_charlen_type child_iomsg_len
;
1893 int *child_iostat
= NULL
;
1894 gfc_full_array_i4 vlist
;
1896 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1897 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1899 /* Set iostat, intent(out). */
1901 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1902 dtp
->common
.iostat
: &noiostat
;
1904 /* Set iomsge, intent(inout). */
1905 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1907 child_iomsg
= dtp
->common
.iomsg
;
1908 child_iomsg_len
= dtp
->common
.iomsg_len
;
1912 child_iomsg
= tmp_iomsg
;
1913 child_iomsg_len
= IOMSG_LEN
;
1916 /* Call the user defined formatted WRITE procedure. */
1917 dtp
->u
.p
.current_unit
->child_dtio
++;
1918 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1919 child_iostat
, child_iomsg
,
1920 iotype_len
, child_iomsg_len
);
1921 dtp
->u
.p
.current_unit
->child_dtio
--;
1925 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1928 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1929 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1934 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1935 size_t size
, size_t nelems
)
1939 size_t stride
= type
== BT_CHARACTER
?
1940 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1944 /* Big loop over all the elements. */
1945 for (elem
= 0; elem
< nelems
; elem
++)
1947 dtp
->u
.p
.item_count
++;
1948 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1954 nml_write_obj writes a namelist object to the output stream. It is called
1955 recursively for derived type components:
1956 obj = is the namelist_info for the current object.
1957 offset = the offset relative to the address held by the object for
1958 derived type arrays.
1959 base = is the namelist_info of the derived type, when obj is a
1961 base_name = the full name for a derived type, including qualifiers
1963 The returned value is a pointer to the object beyond the last one
1964 accessed, including nested derived types. Notice that the namelist is
1965 a linear linked list of objects, including derived types and their
1966 components. A tree, of sorts, is implied by the compound names of
1967 the derived type components and this is how this function recurses through
1970 /* A generous estimate of the number of characters needed to print
1971 repeat counts and indices, including commas, asterices and brackets. */
1973 #define NML_DIGITS 20
1976 namelist_write_newline (st_parameter_dt
*dtp
)
1978 if (!is_internal_unit (dtp
))
1981 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
1983 write_character (dtp
, "\n", 1, 1, NODELIM
);
1988 if (is_array_io (dtp
))
1993 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
1995 p
= write_block (dtp
, length
);
1999 if (unlikely (is_char4_unit (dtp
)))
2001 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
2002 memset4 (p4
, ' ', length
);
2005 memset (p
, ' ', length
);
2007 /* Now that the current record has been padded out,
2008 determine where the next record in the array is. */
2009 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2012 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2015 /* Now seek to this record */
2016 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2018 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2020 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2024 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2028 write_character (dtp
, " ", 1, 1, NODELIM
);
2032 static namelist_info
*
2033 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2034 namelist_info
*base
, char *base_name
)
2040 index_type obj_size
;
2044 index_type elem_ctr
;
2045 size_t obj_name_len
;
2051 size_t ext_name_len
;
2052 char rep_buff
[NML_DIGITS
];
2054 namelist_info
*retval
= obj
->next
;
2055 size_t base_name_len
;
2056 size_t base_var_name_len
;
2059 /* Set the character to be used to separate values
2060 to a comma or semi-colon. */
2063 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2065 /* Write namelist variable names in upper case. If a derived type,
2066 nothing is output. If a component, base and base_name are set. */
2068 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2070 namelist_write_newline (dtp
);
2071 write_character (dtp
, " ", 1, 1, NODELIM
);
2076 len
= strlen (base
->var_name
);
2077 base_name_len
= strlen (base_name
);
2078 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2080 cup
= toupper ((int) base_name
[dim_i
]);
2081 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2084 clen
= strlen (obj
->var_name
);
2085 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2087 cup
= toupper ((int) obj
->var_name
[dim_i
]);
2090 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2092 write_character (dtp
, "=", 1, 1, NODELIM
);
2095 /* Counts the number of data output on a line, including names. */
2105 obj_size
= size_from_real_kind (len
);
2109 obj_size
= size_from_complex_kind (len
);
2113 obj_size
= obj
->string_length
;
2121 obj_size
= obj
->size
;
2123 /* Set the index vector and count the number of elements. */
2126 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2128 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2129 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2132 /* Main loop to output the data held in the object. */
2135 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2138 /* Build the pointer to the data value. The offset is passed by
2139 recursive calls to this function for arrays of derived types.
2140 Is NULL otherwise. */
2142 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2145 /* Check for repeat counts of intrinsic types. */
2147 if ((elem_ctr
< (nelem
- 1)) &&
2148 (obj
->type
!= BT_DERIVED
) &&
2149 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2154 /* Execute a repeated output. Note the flag no_leading_blank that
2155 is used in the functions used to output the intrinsic types. */
2161 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2162 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2163 dtp
->u
.p
.no_leading_blank
= 1;
2167 /* Output the data, if an intrinsic type, or recurse into this
2168 routine to treat derived types. */
2174 write_integer (dtp
, p
, len
);
2178 write_logical (dtp
, p
, len
);
2182 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2183 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2185 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2189 write_real (dtp
, p
, len
);
2193 dtp
->u
.p
.no_leading_blank
= 0;
2195 write_complex (dtp
, p
, len
, obj_size
);
2200 /* To treat a derived type, we need to build two strings:
2201 ext_name = the name, including qualifiers that prepends
2202 component names in the output - passed to
2204 obj_name = the derived type name with no qualifiers but %
2205 appended. This is used to identify the
2208 /* First ext_name => get length of all possible components */
2209 if (obj
->dtio_sub
!= NULL
)
2211 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2212 char iotype
[] = "NAMELIST";
2213 gfc_charlen_type iotype_len
= 8;
2214 char tmp_iomsg
[IOMSG_LEN
] = "";
2216 gfc_charlen_type child_iomsg_len
;
2218 int *child_iostat
= NULL
;
2219 gfc_full_array_i4 vlist
;
2220 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2222 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2224 /* Set iostat, intent(out). */
2226 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2227 dtp
->common
.iostat
: &noiostat
;
2229 /* Set iomsg, intent(inout). */
2230 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2232 child_iomsg
= dtp
->common
.iomsg
;
2233 child_iomsg_len
= dtp
->common
.iomsg_len
;
2237 child_iomsg
= tmp_iomsg
;
2238 child_iomsg_len
= IOMSG_LEN
;
2241 /* Call the user defined formatted WRITE procedure. */
2242 dtp
->u
.p
.current_unit
->child_dtio
++;
2243 if (obj
->type
== BT_DERIVED
)
2245 /* Build a class container. */
2248 list_obj
.vptr
= obj
->vtable
;
2250 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2251 child_iostat
, child_iomsg
,
2252 iotype_len
, child_iomsg_len
);
2256 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2257 child_iostat
, child_iomsg
,
2258 iotype_len
, child_iomsg_len
);
2260 dtp
->u
.p
.current_unit
->child_dtio
--;
2265 base_name_len
= base_name
? strlen (base_name
) : 0;
2266 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2267 ext_name_len
= base_name_len
+ base_var_name_len
2268 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2269 ext_name
= xmalloc (ext_name_len
);
2272 memcpy (ext_name
, base_name
, base_name_len
);
2273 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2274 memcpy (ext_name
+ base_name_len
,
2275 obj
->var_name
+ base_var_name_len
, clen
);
2277 /* Append the qualifier. */
2279 tot_len
= base_name_len
+ clen
;
2280 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2284 ext_name
[tot_len
] = '(';
2287 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2288 (int) obj
->ls
[dim_i
].idx
);
2289 tot_len
+= strlen (ext_name
+ tot_len
);
2290 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2294 ext_name
[tot_len
] = '\0';
2295 for (q
= ext_name
; *q
; q
++)
2301 obj_name_len
= strlen (obj
->var_name
) + 1;
2302 obj_name
= xmalloc (obj_name_len
+ 1);
2303 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2304 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2306 /* Now loop over the components. Update the component pointer
2307 with the return value from nml_write_obj => this loop jumps
2308 past nested derived types. */
2310 for (cmp
= obj
->next
;
2311 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2314 retval
= nml_write_obj (dtp
, cmp
,
2315 (index_type
)(p
- obj
->mem_pos
),
2324 internal_error (&dtp
->common
, "Bad type for namelist write");
2327 /* Reset the leading blank suppression, write a comma (or semi-colon)
2328 and, if 5 values have been output, write a newline and advance
2329 to column 2. Reset the repeat counter. */
2331 dtp
->u
.p
.no_leading_blank
= 0;
2332 if (obj
->type
== BT_CHARACTER
)
2334 if (dtp
->u
.p
.nml_delim
!= '\0')
2335 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2338 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2342 if (dtp
->u
.p
.nml_delim
== '\0')
2343 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2344 namelist_write_newline (dtp
);
2345 write_character (dtp
, " ", 1, 1, NODELIM
);
2350 /* Cycle through and increment the index vector. */
2355 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2357 obj
->ls
[dim_i
].idx
+= nml_carry
;
2359 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2361 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2367 /* Return a pointer beyond the furthest object accessed. */
2373 /* This is the entry function for namelist writes. It outputs the name
2374 of the namelist and iterates through the namelist by calls to
2375 nml_write_obj. The call below has dummys in the arguments used in
2376 the treatment of derived types. */
2379 namelist_write (st_parameter_dt
*dtp
)
2381 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2382 index_type dummy_offset
= 0;
2384 char *dummy_name
= NULL
;
2386 /* Set the delimiter for namelist output. */
2387 switch (dtp
->u
.p
.current_unit
->delim_status
)
2389 case DELIM_APOSTROPHE
:
2390 dtp
->u
.p
.nml_delim
= '\'';
2393 case DELIM_UNSPECIFIED
:
2394 dtp
->u
.p
.nml_delim
= '"';
2397 dtp
->u
.p
.nml_delim
= '\0';
2400 write_character (dtp
, "&", 1, 1, NODELIM
);
2402 /* Write namelist name in upper case - f95 std. */
2403 for (gfc_charlen_type i
= 0; i
< dtp
->namelist_name_len
; i
++ )
2405 c
= toupper ((int) dtp
->namelist_name
[i
]);
2406 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2409 if (dtp
->u
.p
.ionml
!= NULL
)
2411 t1
= dtp
->u
.p
.ionml
;
2415 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2419 namelist_write_newline (dtp
);
2420 write_character (dtp
, " /", 1, 2, NODELIM
);