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
)
989 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
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;
1054 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
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'};
1129 if (__BYTE_ORDER__
== __ORDER_BIG_ENDIAN__
)
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
+ 1;
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 if (!dtp
->u
.p
.namelist_mode
)
1814 lblanks
= width
- res_len1
- res_len2
- 3;
1815 write_x (dtp
, lblanks
, lblanks
);
1817 write_char (dtp
, '(');
1818 write_float_string (dtp
, result1
, res_len1
);
1819 write_char (dtp
, semi_comma
);
1820 write_float_string (dtp
, result2
, res_len2
);
1821 write_char (dtp
, ')');
1823 dtp
->u
.p
.scale_factor
= orig_scale
;
1824 dtp
->u
.p
.g0_no_blanks
= 0;
1825 if (buf_size
> BUF_STACK_SZ
)
1827 if (res_len1
> BUF_STACK_SZ
)
1829 if (res_len2
> BUF_STACK_SZ
)
1834 /* Write the separator between items. */
1837 write_separator (st_parameter_dt
*dtp
)
1841 p
= write_block (dtp
, options
.separator_len
);
1844 if (unlikely (is_char4_unit (dtp
)))
1846 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1847 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1850 memcpy (p
, options
.separator
, options
.separator_len
);
1854 /* Write an item with list formatting.
1855 TODO: handle skipping to the next record correctly, particularly
1859 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1862 if (dtp
->u
.p
.current_unit
== NULL
)
1865 if (dtp
->u
.p
.first_item
)
1867 dtp
->u
.p
.first_item
= 0;
1868 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
1869 write_char (dtp
, ' ');
1873 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1874 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1875 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1876 write_separator (dtp
);
1882 write_integer (dtp
, p
, kind
);
1885 write_logical (dtp
, p
, kind
);
1888 write_character (dtp
, p
, kind
, size
, DELIM
);
1891 write_real (dtp
, p
, kind
);
1894 write_complex (dtp
, p
, kind
, size
);
1898 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1899 char iotype
[] = "LISTDIRECTED";
1900 gfc_charlen_type iotype_len
= 12;
1901 char tmp_iomsg
[IOMSG_LEN
] = "";
1903 gfc_charlen_type child_iomsg_len
;
1905 int *child_iostat
= NULL
;
1908 GFC_DESCRIPTOR_DATA(&vlist
) = NULL
;
1909 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
1911 /* Set iostat, intent(out). */
1913 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1914 dtp
->common
.iostat
: &noiostat
;
1916 /* Set iomsge, intent(inout). */
1917 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1919 child_iomsg
= dtp
->common
.iomsg
;
1920 child_iomsg_len
= dtp
->common
.iomsg_len
;
1924 child_iomsg
= tmp_iomsg
;
1925 child_iomsg_len
= IOMSG_LEN
;
1928 /* Call the user defined formatted WRITE procedure. */
1929 dtp
->u
.p
.current_unit
->child_dtio
++;
1930 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, &vlist
,
1931 child_iostat
, child_iomsg
,
1932 iotype_len
, child_iomsg_len
);
1933 dtp
->u
.p
.current_unit
->child_dtio
--;
1937 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1940 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1941 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1946 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1947 size_t size
, size_t nelems
)
1951 size_t stride
= type
== BT_CHARACTER
?
1952 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1956 /* Big loop over all the elements. */
1957 for (elem
= 0; elem
< nelems
; elem
++)
1959 dtp
->u
.p
.item_count
++;
1960 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1966 nml_write_obj writes a namelist object to the output stream. It is called
1967 recursively for derived type components:
1968 obj = is the namelist_info for the current object.
1969 offset = the offset relative to the address held by the object for
1970 derived type arrays.
1971 base = is the namelist_info of the derived type, when obj is a
1973 base_name = the full name for a derived type, including qualifiers
1975 The returned value is a pointer to the object beyond the last one
1976 accessed, including nested derived types. Notice that the namelist is
1977 a linear linked list of objects, including derived types and their
1978 components. A tree, of sorts, is implied by the compound names of
1979 the derived type components and this is how this function recurses through
1982 /* A generous estimate of the number of characters needed to print
1983 repeat counts and indices, including commas, asterices and brackets. */
1985 #define NML_DIGITS 20
1988 namelist_write_newline (st_parameter_dt
*dtp
)
1990 if (!is_internal_unit (dtp
))
1993 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
1995 write_character (dtp
, "\n", 1, 1, NODELIM
);
2000 if (is_array_io (dtp
))
2005 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
2007 p
= write_block (dtp
, length
);
2011 if (unlikely (is_char4_unit (dtp
)))
2013 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
2014 memset4 (p4
, ' ', length
);
2017 memset (p
, ' ', length
);
2019 /* Now that the current record has been padded out,
2020 determine where the next record in the array is. */
2021 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2024 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2027 /* Now seek to this record */
2028 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2030 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2032 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2036 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2040 write_character (dtp
, " ", 1, 1, NODELIM
);
2044 static namelist_info
*
2045 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
*obj
, index_type offset
,
2046 namelist_info
*base
, char *base_name
)
2052 index_type obj_size
;
2056 index_type elem_ctr
;
2057 size_t obj_name_len
;
2063 size_t ext_name_len
;
2064 char rep_buff
[NML_DIGITS
];
2066 namelist_info
*retval
= obj
->next
;
2067 size_t base_name_len
;
2068 size_t base_var_name_len
;
2071 /* Set the character to be used to separate values
2072 to a comma or semi-colon. */
2075 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
2077 /* Write namelist variable names in upper case. If a derived type,
2078 nothing is output. If a component, base and base_name are set. */
2080 if (obj
->type
!= BT_DERIVED
|| obj
->dtio_sub
!= NULL
)
2082 namelist_write_newline (dtp
);
2083 write_character (dtp
, " ", 1, 1, NODELIM
);
2088 len
= strlen (base
->var_name
);
2089 base_name_len
= strlen (base_name
);
2090 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
2092 cup
= toupper ((int) base_name
[dim_i
]);
2093 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2096 clen
= strlen (obj
->var_name
);
2097 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
2099 cup
= toupper ((int) obj
->var_name
[dim_i
]);
2102 write_character (dtp
, &cup
, 1, 1, NODELIM
);
2104 write_character (dtp
, "=", 1, 1, NODELIM
);
2107 /* Counts the number of data output on a line, including names. */
2117 obj_size
= size_from_real_kind (len
);
2121 obj_size
= size_from_complex_kind (len
);
2125 obj_size
= obj
->string_length
;
2133 obj_size
= obj
->size
;
2135 /* Set the index vector and count the number of elements. */
2138 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2140 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
2141 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
2144 /* Main loop to output the data held in the object. */
2147 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
2150 /* Build the pointer to the data value. The offset is passed by
2151 recursive calls to this function for arrays of derived types.
2152 Is NULL otherwise. */
2154 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
2157 /* Check for repeat counts of intrinsic types. */
2159 if ((elem_ctr
< (nelem
- 1)) &&
2160 (obj
->type
!= BT_DERIVED
) &&
2161 !memcmp (p
, (void *)(p
+ obj_size
), obj_size
))
2166 /* Execute a repeated output. Note the flag no_leading_blank that
2167 is used in the functions used to output the intrinsic types. */
2173 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
2174 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
2175 dtp
->u
.p
.no_leading_blank
= 1;
2179 /* Output the data, if an intrinsic type, or recurse into this
2180 routine to treat derived types. */
2186 write_integer (dtp
, p
, len
);
2190 write_logical (dtp
, p
, len
);
2194 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
2195 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
2197 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
2201 write_real (dtp
, p
, len
);
2205 dtp
->u
.p
.no_leading_blank
= 0;
2207 write_complex (dtp
, p
, len
, obj_size
);
2212 /* To treat a derived type, we need to build two strings:
2213 ext_name = the name, including qualifiers that prepends
2214 component names in the output - passed to
2216 obj_name = the derived type name with no qualifiers but %
2217 appended. This is used to identify the
2220 /* First ext_name => get length of all possible components */
2221 if (obj
->dtio_sub
!= NULL
)
2223 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
2224 char iotype
[] = "NAMELIST";
2225 gfc_charlen_type iotype_len
= 8;
2226 char tmp_iomsg
[IOMSG_LEN
] = "";
2228 gfc_charlen_type child_iomsg_len
;
2230 int *child_iostat
= NULL
;
2232 formatted_dtio dtio_ptr
= (formatted_dtio
)obj
->dtio_sub
;
2234 GFC_DIMENSION_SET(vlist
.dim
[0],1, 0, 0);
2236 /* Set iostat, intent(out). */
2238 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
2239 dtp
->common
.iostat
: &noiostat
;
2241 /* Set iomsg, intent(inout). */
2242 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
2244 child_iomsg
= dtp
->common
.iomsg
;
2245 child_iomsg_len
= dtp
->common
.iomsg_len
;
2249 child_iomsg
= tmp_iomsg
;
2250 child_iomsg_len
= IOMSG_LEN
;
2253 /* Call the user defined formatted WRITE procedure. */
2254 dtp
->u
.p
.current_unit
->child_dtio
++;
2255 if (obj
->type
== BT_DERIVED
)
2257 // build a class container
2260 list_obj
.vptr
= obj
->vtable
;
2262 dtio_ptr ((void *)&list_obj
, &unit
, iotype
, &vlist
,
2263 child_iostat
, child_iomsg
,
2264 iotype_len
, child_iomsg_len
);
2268 dtio_ptr (p
, &unit
, iotype
, &vlist
,
2269 child_iostat
, child_iomsg
,
2270 iotype_len
, child_iomsg_len
);
2272 dtp
->u
.p
.current_unit
->child_dtio
--;
2277 base_name_len
= base_name
? strlen (base_name
) : 0;
2278 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
2279 ext_name_len
= base_name_len
+ base_var_name_len
2280 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
2281 ext_name
= xmalloc (ext_name_len
);
2284 memcpy (ext_name
, base_name
, base_name_len
);
2285 clen
= strlen (obj
->var_name
+ base_var_name_len
);
2286 memcpy (ext_name
+ base_name_len
,
2287 obj
->var_name
+ base_var_name_len
, clen
);
2289 /* Append the qualifier. */
2291 tot_len
= base_name_len
+ clen
;
2292 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
2296 ext_name
[tot_len
] = '(';
2299 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
2300 (int) obj
->ls
[dim_i
].idx
);
2301 tot_len
+= strlen (ext_name
+ tot_len
);
2302 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
2306 ext_name
[tot_len
] = '\0';
2307 for (q
= ext_name
; *q
; q
++)
2313 obj_name_len
= strlen (obj
->var_name
) + 1;
2314 obj_name
= xmalloc (obj_name_len
+ 1);
2315 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
2316 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
2318 /* Now loop over the components. Update the component pointer
2319 with the return value from nml_write_obj => this loop jumps
2320 past nested derived types. */
2322 for (cmp
= obj
->next
;
2323 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
2326 retval
= nml_write_obj (dtp
, cmp
,
2327 (index_type
)(p
- obj
->mem_pos
),
2336 internal_error (&dtp
->common
, "Bad type for namelist write");
2339 /* Reset the leading blank suppression, write a comma (or semi-colon)
2340 and, if 5 values have been output, write a newline and advance
2341 to column 2. Reset the repeat counter. */
2343 dtp
->u
.p
.no_leading_blank
= 0;
2344 if (obj
->type
== BT_CHARACTER
)
2346 if (dtp
->u
.p
.nml_delim
!= '\0')
2347 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2350 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2354 if (dtp
->u
.p
.nml_delim
== '\0')
2355 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
2356 namelist_write_newline (dtp
);
2357 write_character (dtp
, " ", 1, 1, NODELIM
);
2362 /* Cycle through and increment the index vector. */
2367 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
2369 obj
->ls
[dim_i
].idx
+= nml_carry
;
2371 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
2373 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
2379 /* Return a pointer beyond the furthest object accessed. */
2385 /* This is the entry function for namelist writes. It outputs the name
2386 of the namelist and iterates through the namelist by calls to
2387 nml_write_obj. The call below has dummys in the arguments used in
2388 the treatment of derived types. */
2391 namelist_write (st_parameter_dt
*dtp
)
2393 namelist_info
*t1
, *t2
, *dummy
= NULL
;
2395 index_type dummy_offset
= 0;
2397 char *dummy_name
= NULL
;
2399 /* Set the delimiter for namelist output. */
2400 switch (dtp
->u
.p
.current_unit
->delim_status
)
2402 case DELIM_APOSTROPHE
:
2403 dtp
->u
.p
.nml_delim
= '\'';
2406 case DELIM_UNSPECIFIED
:
2407 dtp
->u
.p
.nml_delim
= '"';
2410 dtp
->u
.p
.nml_delim
= '\0';
2413 write_character (dtp
, "&", 1, 1, NODELIM
);
2415 /* Write namelist name in upper case - f95 std. */
2416 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
2418 c
= toupper ((int) dtp
->namelist_name
[i
]);
2419 write_character (dtp
, &c
, 1 ,1, NODELIM
);
2422 if (dtp
->u
.p
.ionml
!= NULL
)
2424 t1
= dtp
->u
.p
.ionml
;
2428 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2432 namelist_write_newline (dtp
);
2433 write_character (dtp
, " /", 1, 2, NODELIM
);