1 /* Copyright (C) 2002-2016 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/>. */
36 #define star_fill(p, n) memset(p, '*', n)
38 typedef unsigned char uchar
;
40 /* Helper functions for character(kind=4) internal units. These are needed
41 by write_float.def. */
44 memcpy4 (gfc_char4_t
*dest
, const char *source
, int k
)
48 const char *p
= source
;
49 for (j
= 0; j
< k
; j
++)
50 *dest
++ = (gfc_char4_t
) *p
++;
53 /* This include contains the heart and soul of formatted floating point. */
54 #include "write_float.def"
56 /* Write out default char4. */
59 write_default_char4 (st_parameter_dt
*dtp
, const gfc_char4_t
*source
,
60 int src_len
, int w_len
)
67 /* Take care of preceding blanks. */
71 p
= write_block (dtp
, k
);
74 if (is_char4_unit (dtp
))
76 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
83 /* Get ready to handle delimiters if needed. */
84 switch (dtp
->u
.p
.current_unit
->delim_status
)
86 case DELIM_APOSTROPHE
:
97 /* Now process the remaining characters, one at a time. */
98 for (j
= 0; j
< src_len
; j
++)
101 if (is_char4_unit (dtp
))
104 /* Handle delimiters if any. */
105 if (c
== d
&& d
!= ' ')
107 p
= write_block (dtp
, 2);
110 q
= (gfc_char4_t
*) p
;
115 p
= write_block (dtp
, 1);
118 q
= (gfc_char4_t
*) p
;
124 /* Handle delimiters if any. */
125 if (c
== d
&& d
!= ' ')
127 p
= write_block (dtp
, 2);
134 p
= write_block (dtp
, 1);
138 *p
= c
> 255 ? '?' : (uchar
) c
;
144 /* Write out UTF-8 converted from char4. */
147 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
148 int src_len
, int w_len
)
153 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
154 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
158 /* Take care of preceding blanks. */
162 p
= write_block (dtp
, k
);
168 /* Get ready to handle delimiters if needed. */
169 switch (dtp
->u
.p
.current_unit
->delim_status
)
171 case DELIM_APOSTROPHE
:
182 /* Now process the remaining characters, one at a time. */
183 for (j
= k
; j
< src_len
; j
++)
188 /* Handle the delimiters if any. */
189 if (c
== d
&& d
!= ' ')
191 p
= write_block (dtp
, 2);
198 p
= write_block (dtp
, 1);
206 /* Convert to UTF-8 sequence. */
212 *--q
= ((c
& 0x3F) | 0x80);
216 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
218 *--q
= (c
| masks
[nbytes
-1]);
220 p
= write_block (dtp
, nbytes
);
232 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
237 wlen
= f
->u
.string
.length
< 0
238 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
239 ? len
: f
->u
.string
.length
;
242 /* If this is formatted STREAM IO convert any embedded line feed characters
243 to CR_LF on systems that use that sequence for newlines. See F2003
244 Standard sections 10.6.3 and 9.9 for further information. */
245 if (is_stream_io (dtp
))
247 const char crlf
[] = "\r\n";
251 /* Write out any padding if needed. */
254 p
= write_block (dtp
, wlen
- len
);
257 memset (p
, ' ', wlen
- len
);
260 /* Scan the source string looking for '\n' and convert it if found. */
261 for (i
= 0; i
< wlen
; i
++)
263 if (source
[i
] == '\n')
265 /* Write out the previously scanned characters in the string. */
268 p
= write_block (dtp
, bytes
);
271 memcpy (p
, &source
[q
], bytes
);
276 /* Write out the CR_LF sequence. */
278 p
= write_block (dtp
, 2);
287 /* Write out any remaining bytes if no LF was found. */
290 p
= write_block (dtp
, bytes
);
293 memcpy (p
, &source
[q
], bytes
);
299 p
= write_block (dtp
, wlen
);
303 if (unlikely (is_char4_unit (dtp
)))
305 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
307 memcpy4 (p4
, source
, wlen
);
310 memset4 (p4
, ' ', wlen
- len
);
311 memcpy4 (p4
+ wlen
- len
, source
, len
);
317 memcpy (p
, source
, wlen
);
320 memset (p
, ' ', wlen
- len
);
321 memcpy (p
+ wlen
- len
, source
, len
);
329 /* The primary difference between write_a_char4 and write_a is that we have to
330 deal with writing from the first byte of the 4-byte character and pay
331 attention to the most significant bytes. For ENCODING="default" write the
332 lowest significant byte. If the 3 most significant bytes contain
333 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
334 to the UTF-8 encoded string before writing out. */
337 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
342 wlen
= f
->u
.string
.length
< 0
343 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
344 ? len
: f
->u
.string
.length
;
346 q
= (gfc_char4_t
*) source
;
348 /* If this is formatted STREAM IO convert any embedded line feed characters
349 to CR_LF on systems that use that sequence for newlines. See F2003
350 Standard sections 10.6.3 and 9.9 for further information. */
351 if (is_stream_io (dtp
))
353 const gfc_char4_t crlf
[] = {0x000d,0x000a};
358 /* Write out any padding if needed. */
362 p
= write_block (dtp
, wlen
- len
);
365 memset (p
, ' ', wlen
- len
);
368 /* Scan the source string looking for '\n' and convert it if found. */
369 qq
= (gfc_char4_t
*) source
;
370 for (i
= 0; i
< wlen
; i
++)
374 /* Write out the previously scanned characters in the string. */
377 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
378 write_utf8_char4 (dtp
, q
, bytes
, 0);
380 write_default_char4 (dtp
, q
, bytes
, 0);
384 /* Write out the CR_LF sequence. */
385 write_default_char4 (dtp
, crlf
, 2, 0);
391 /* Write out any remaining bytes if no LF was found. */
394 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
395 write_utf8_char4 (dtp
, q
, bytes
, 0);
397 write_default_char4 (dtp
, q
, bytes
, 0);
403 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
404 write_utf8_char4 (dtp
, q
, len
, wlen
);
406 write_default_char4 (dtp
, q
, len
, wlen
);
413 static GFC_INTEGER_LARGEST
414 extract_int (const void *p
, int len
)
416 GFC_INTEGER_LARGEST i
= 0;
426 memcpy ((void *) &tmp
, p
, len
);
433 memcpy ((void *) &tmp
, p
, len
);
440 memcpy ((void *) &tmp
, p
, len
);
447 memcpy ((void *) &tmp
, p
, len
);
451 #ifdef HAVE_GFC_INTEGER_16
455 memcpy ((void *) &tmp
, p
, len
);
461 internal_error (NULL
, "bad integer kind");
467 static GFC_UINTEGER_LARGEST
468 extract_uint (const void *p
, int len
)
470 GFC_UINTEGER_LARGEST i
= 0;
480 memcpy ((void *) &tmp
, p
, len
);
481 i
= (GFC_UINTEGER_1
) tmp
;
487 memcpy ((void *) &tmp
, p
, len
);
488 i
= (GFC_UINTEGER_2
) tmp
;
494 memcpy ((void *) &tmp
, p
, len
);
495 i
= (GFC_UINTEGER_4
) tmp
;
501 memcpy ((void *) &tmp
, p
, len
);
502 i
= (GFC_UINTEGER_8
) tmp
;
505 #ifdef HAVE_GFC_INTEGER_16
509 GFC_INTEGER_16 tmp
= 0;
510 memcpy ((void *) &tmp
, p
, len
);
511 i
= (GFC_UINTEGER_16
) tmp
;
516 internal_error (NULL
, "bad integer kind");
524 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
528 GFC_INTEGER_LARGEST n
;
530 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
532 p
= write_block (dtp
, wlen
);
536 n
= extract_int (source
, len
);
538 if (unlikely (is_char4_unit (dtp
)))
540 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
541 memset4 (p4
, ' ', wlen
-1);
542 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
546 memset (p
, ' ', wlen
-1);
547 p
[wlen
- 1] = (n
) ? 'T' : 'F';
552 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
554 int w
, m
, digits
, nzero
, nblank
;
562 if (m
== 0 && n
== 0)
567 p
= write_block (dtp
, w
);
570 if (unlikely (is_char4_unit (dtp
)))
572 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
573 memset4 (p4
, ' ', w
);
582 /* Select a width if none was specified. The idea here is to always
586 w
= ((digits
< m
) ? m
: digits
);
588 p
= write_block (dtp
, w
);
596 /* See if things will work. */
598 nblank
= w
- (nzero
+ digits
);
600 if (unlikely (is_char4_unit (dtp
)))
602 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
605 memset4 (p4
, '*', w
);
609 if (!dtp
->u
.p
.no_leading_blank
)
611 memset4 (p4
, ' ', nblank
);
613 memset4 (p4
, '0', nzero
);
615 memcpy4 (p4
, q
, digits
);
619 memset4 (p4
, '0', nzero
);
621 memcpy4 (p4
, q
, digits
);
623 memset4 (p4
, ' ', nblank
);
624 dtp
->u
.p
.no_leading_blank
= 0;
635 if (!dtp
->u
.p
.no_leading_blank
)
637 memset (p
, ' ', nblank
);
639 memset (p
, '0', nzero
);
641 memcpy (p
, q
, digits
);
645 memset (p
, '0', nzero
);
647 memcpy (p
, q
, digits
);
649 memset (p
, ' ', nblank
);
650 dtp
->u
.p
.no_leading_blank
= 0;
658 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
660 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
662 GFC_INTEGER_LARGEST n
= 0;
663 int w
, m
, digits
, nsign
, nzero
, nblank
;
667 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
670 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
672 n
= extract_int (source
, len
);
675 if (m
== 0 && n
== 0)
680 p
= write_block (dtp
, w
);
683 if (unlikely (is_char4_unit (dtp
)))
685 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
686 memset4 (p4
, ' ', w
);
693 sign
= calculate_sign (dtp
, n
< 0);
696 nsign
= sign
== S_NONE
? 0 : 1;
698 /* conv calls itoa which sets the negative sign needed
699 by write_integer. The sign '+' or '-' is set below based on sign
700 calculated above, so we just point past the sign in the string
701 before proceeding to avoid double signs in corner cases.
703 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
709 /* Select a width if none was specified. The idea here is to always
713 w
= ((digits
< m
) ? m
: digits
) + nsign
;
715 p
= write_block (dtp
, w
);
723 /* See if things will work. */
725 nblank
= w
- (nsign
+ nzero
+ digits
);
727 if (unlikely (is_char4_unit (dtp
)))
729 gfc_char4_t
* p4
= (gfc_char4_t
*) p
;
732 memset4 (p4
, '*', w
);
736 memset4 (p4
, ' ', nblank
);
751 memset4 (p4
, '0', nzero
);
754 memcpy4 (p4
, q
, digits
);
764 memset (p
, ' ', nblank
);
779 memset (p
, '0', nzero
);
782 memcpy (p
, q
, digits
);
789 /* Convert unsigned octal to ascii. */
792 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
796 assert (len
>= GFC_OTOA_BUF_SIZE
);
801 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
806 *--p
= '0' + (n
& 7);
814 /* Convert unsigned binary to ascii. */
817 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
821 assert (len
>= GFC_BTOA_BUF_SIZE
);
826 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
831 *--p
= '0' + (n
& 1);
838 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
839 to convert large reals with kind sizes that exceed the largest integer type
840 available on certain platforms. In these cases, byte by byte conversion is
841 performed. Endianess is taken into account. */
843 /* Conversion to binary. */
846 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
855 for (i
= 0; i
< len
; i
++)
859 /* Test for zero. Needed by write_boz later. */
863 for (j
= 0; j
< 8; j
++)
865 *q
++ = (c
& 128) ? '1' : '0';
873 const char *p
= s
+ len
- 1;
874 for (i
= 0; i
< len
; i
++)
878 /* Test for zero. Needed by write_boz later. */
882 for (j
= 0; j
< 8; j
++)
884 *q
++ = (c
& 128) ? '1' : '0';
896 /* Move past any leading zeros. */
897 while (*buffer
== '0')
904 /* Conversion to octal. */
907 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
913 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
919 const char *p
= s
+ len
- 1;
923 /* Test for zero. Needed by write_boz later. */
927 for (j
= 0; j
< 3 && i
< len
; j
++)
929 octet
|= (c
& 1) << j
;
948 /* Test for zero. Needed by write_boz later. */
952 for (j
= 0; j
< 3 && i
< len
; j
++)
954 octet
|= (c
& 1) << j
;
971 /* Move past any leading zeros. */
978 /* Conversion to hexidecimal. */
981 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
983 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
984 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
995 for (i
= 0; i
< len
; i
++)
997 /* Test for zero. Needed by write_boz later. */
1001 h
= (*p
>> 4) & 0x0F;
1009 const char *p
= s
+ len
- 1;
1010 for (i
= 0; i
< len
; i
++)
1012 /* Test for zero. Needed by write_boz later. */
1016 h
= (*p
>> 4) & 0x0F;
1028 /* Move past any leading zeros. */
1029 while (*buffer
== '0')
1037 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1039 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1044 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1047 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1048 GFC_UINTEGER_LARGEST n
= 0;
1050 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1052 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1053 write_boz (dtp
, f
, p
, n
);
1057 n
= extract_uint (source
, len
);
1058 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1059 write_boz (dtp
, f
, p
, n
);
1065 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1068 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1069 GFC_UINTEGER_LARGEST n
= 0;
1071 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1073 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1074 write_boz (dtp
, f
, p
, n
);
1078 n
= extract_uint (source
, len
);
1079 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1080 write_boz (dtp
, f
, p
, n
);
1085 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1088 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1089 GFC_UINTEGER_LARGEST n
= 0;
1091 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1093 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1094 write_boz (dtp
, f
, p
, n
);
1098 n
= extract_uint (source
, len
);
1099 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1100 write_boz (dtp
, f
, p
, n
);
1106 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1108 write_float (dtp
, f
, p
, len
, 0);
1113 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1115 write_float (dtp
, f
, p
, len
, 0);
1120 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1122 write_float (dtp
, f
, p
, len
, 0);
1127 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1129 write_float (dtp
, f
, p
, len
, 0);
1134 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1136 write_float (dtp
, f
, p
, len
, 0);
1140 /* Take care of the X/TR descriptor. */
1143 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1147 p
= write_block (dtp
, len
);
1150 if (nspaces
> 0 && len
- nspaces
>= 0)
1152 if (unlikely (is_char4_unit (dtp
)))
1154 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1155 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1158 memset (&p
[len
- nspaces
], ' ', nspaces
);
1163 /* List-directed writing. */
1166 /* Write a single character to the output. Returns nonzero if
1167 something goes wrong. */
1170 write_char (st_parameter_dt
*dtp
, int c
)
1174 p
= write_block (dtp
, 1);
1177 if (unlikely (is_char4_unit (dtp
)))
1179 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1190 /* Write a list-directed logical value. */
1193 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1195 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1199 /* Write a list-directed integer value. */
1202 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1208 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1210 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1235 digits
= strlen (q
);
1239 p
= write_block (dtp
, width
);
1243 if (unlikely (is_char4_unit (dtp
)))
1245 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1246 if (dtp
->u
.p
.no_leading_blank
)
1248 memcpy4 (p4
, q
, digits
);
1249 memset4 (p4
+ digits
, ' ', width
- digits
);
1253 memset4 (p4
, ' ', width
- digits
);
1254 memcpy4 (p4
+ width
- digits
, q
, digits
);
1259 if (dtp
->u
.p
.no_leading_blank
)
1261 memcpy (p
, q
, digits
);
1262 memset (p
+ digits
, ' ', width
- digits
);
1266 memset (p
, ' ', width
- digits
);
1267 memcpy (p
+ width
- digits
, q
, digits
);
1272 /* Write a list-directed string. We have to worry about delimiting
1273 the strings if the file has been opened in that mode. */
1279 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
, int mode
)
1286 switch (dtp
->u
.p
.current_unit
->delim_status
)
1288 case DELIM_APOSTROPHE
:
1310 for (i
= 0; i
< length
; i
++)
1315 p
= write_block (dtp
, length
+ extra
);
1319 if (unlikely (is_char4_unit (dtp
)))
1321 gfc_char4_t d4
= (gfc_char4_t
) d
;
1322 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1325 memcpy4 (p4
, source
, length
);
1330 for (i
= 0; i
< length
; i
++)
1332 *p4
++ = (gfc_char4_t
) source
[i
];
1343 memcpy (p
, source
, length
);
1348 for (i
= 0; i
< length
; i
++)
1362 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1363 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1365 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1369 p
= write_block (dtp
, 1);
1372 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1373 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1375 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1377 p
= write_block (dtp
, 1);
1384 /* Set an fnode to default format. */
1387 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1408 /* Adjust decimal precision depending on binary precision, 106 or 113. */
1409 #if GFC_REAL_16_DIGITS == 113
1420 internal_error (&dtp
->common
, "bad real kind");
1425 /* Output a real number with default format. To guarantee that a
1426 binary -> decimal -> binary roundtrip conversion recovers the
1427 original value, IEEE 754-2008 requires 9, 17, 21 and 36 significant
1428 digits for REAL kinds 4, 8, 10, and 16, respectively. Thus, we use
1429 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4 for
1430 REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1431 Fortran standard requires outputting an extra digit when the scale
1432 factor is 1 and when the magnitude of the value is such that E
1433 editing is used. However, gfortran compensates for this, and thus
1434 for list formatted the same number of significant digits is
1435 generated both when using F and E editing. */
1438 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1441 int org_scale
= dtp
->u
.p
.scale_factor
;
1442 dtp
->u
.p
.scale_factor
= 1;
1443 set_fnode_default (dtp
, &f
, length
);
1444 write_float (dtp
, &f
, source
, length
, 1);
1445 dtp
->u
.p
.scale_factor
= org_scale
;
1448 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1449 compensate for the extra digit. */
1452 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1456 set_fnode_default (dtp
, &f
, length
);
1460 /* Compensate for extra digits when using scale factor, d is not
1461 specified, and the magnitude is such that E editing is used. */
1462 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1466 dtp
->u
.p
.g0_no_blanks
= 1;
1467 write_float (dtp
, &f
, source
, length
, comp_d
);
1468 dtp
->u
.p
.g0_no_blanks
= 0;
1473 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1476 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1478 if (write_char (dtp
, '('))
1480 write_real (dtp
, source
, kind
);
1482 if (write_char (dtp
, semi_comma
))
1484 write_real (dtp
, source
+ size
/ 2, kind
);
1486 write_char (dtp
, ')');
1490 /* Write the separator between items. */
1493 write_separator (st_parameter_dt
*dtp
)
1497 p
= write_block (dtp
, options
.separator_len
);
1500 if (unlikely (is_char4_unit (dtp
)))
1502 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1503 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1506 memcpy (p
, options
.separator
, options
.separator_len
);
1510 /* Write an item with list formatting.
1511 TODO: handle skipping to the next record correctly, particularly
1515 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1518 if (dtp
->u
.p
.current_unit
== NULL
)
1521 if (dtp
->u
.p
.first_item
)
1523 dtp
->u
.p
.first_item
= 0;
1524 write_char (dtp
, ' ');
1528 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1529 (dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
1530 && dtp
->u
.p
.current_unit
->delim_status
!= DELIM_UNSPECIFIED
))
1531 write_separator (dtp
);
1537 write_integer (dtp
, p
, kind
);
1540 write_logical (dtp
, p
, kind
);
1543 write_character (dtp
, p
, kind
, size
, DELIM
);
1546 write_real (dtp
, p
, kind
);
1549 write_complex (dtp
, p
, kind
, size
);
1552 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1555 fbuf_flush_list (dtp
->u
.p
.current_unit
, LIST_WRITING
);
1556 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1561 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1562 size_t size
, size_t nelems
)
1566 size_t stride
= type
== BT_CHARACTER
?
1567 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1571 /* Big loop over all the elements. */
1572 for (elem
= 0; elem
< nelems
; elem
++)
1574 dtp
->u
.p
.item_count
++;
1575 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1581 nml_write_obj writes a namelist object to the output stream. It is called
1582 recursively for derived type components:
1583 obj = is the namelist_info for the current object.
1584 offset = the offset relative to the address held by the object for
1585 derived type arrays.
1586 base = is the namelist_info of the derived type, when obj is a
1588 base_name = the full name for a derived type, including qualifiers
1590 The returned value is a pointer to the object beyond the last one
1591 accessed, including nested derived types. Notice that the namelist is
1592 a linear linked list of objects, including derived types and their
1593 components. A tree, of sorts, is implied by the compound names of
1594 the derived type components and this is how this function recurses through
1597 /* A generous estimate of the number of characters needed to print
1598 repeat counts and indices, including commas, asterices and brackets. */
1600 #define NML_DIGITS 20
1603 namelist_write_newline (st_parameter_dt
*dtp
)
1605 if (!is_internal_unit (dtp
))
1608 write_character (dtp
, "\r\n", 1, 2, NODELIM
);
1610 write_character (dtp
, "\n", 1, 1, NODELIM
);
1615 if (is_array_io (dtp
))
1620 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
1622 p
= write_block (dtp
, length
);
1626 if (unlikely (is_char4_unit (dtp
)))
1628 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1629 memset4 (p4
, ' ', length
);
1632 memset (p
, ' ', length
);
1634 /* Now that the current record has been padded out,
1635 determine where the next record in the array is. */
1636 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1639 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1642 /* Now seek to this record */
1643 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1645 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1647 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1651 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1655 write_character (dtp
, " ", 1, 1, NODELIM
);
1659 static namelist_info
*
1660 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1661 namelist_info
* base
, char * base_name
)
1667 index_type obj_size
;
1671 index_type elem_ctr
;
1672 size_t obj_name_len
;
1678 size_t ext_name_len
;
1679 char rep_buff
[NML_DIGITS
];
1680 namelist_info
* cmp
;
1681 namelist_info
* retval
= obj
->next
;
1682 size_t base_name_len
;
1683 size_t base_var_name_len
;
1686 /* Set the character to be used to separate values
1687 to a comma or semi-colon. */
1690 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1692 /* Write namelist variable names in upper case. If a derived type,
1693 nothing is output. If a component, base and base_name are set. */
1695 if (obj
->type
!= BT_DERIVED
)
1697 namelist_write_newline (dtp
);
1698 write_character (dtp
, " ", 1, 1, NODELIM
);
1703 len
= strlen (base
->var_name
);
1704 base_name_len
= strlen (base_name
);
1705 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
1707 cup
= toupper ((int) base_name
[dim_i
]);
1708 write_character (dtp
, &cup
, 1, 1, NODELIM
);
1711 clen
= strlen (obj
->var_name
);
1712 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
1714 cup
= toupper ((int) obj
->var_name
[dim_i
]);
1717 write_character (dtp
, &cup
, 1, 1, NODELIM
);
1719 write_character (dtp
, "=", 1, 1, NODELIM
);
1722 /* Counts the number of data output on a line, including names. */
1732 obj_size
= size_from_real_kind (len
);
1736 obj_size
= size_from_complex_kind (len
);
1740 obj_size
= obj
->string_length
;
1748 obj_size
= obj
->size
;
1750 /* Set the index vector and count the number of elements. */
1753 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1755 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
1756 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
1759 /* Main loop to output the data held in the object. */
1762 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1765 /* Build the pointer to the data value. The offset is passed by
1766 recursive calls to this function for arrays of derived types.
1767 Is NULL otherwise. */
1769 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1772 /* Check for repeat counts of intrinsic types. */
1774 if ((elem_ctr
< (nelem
- 1)) &&
1775 (obj
->type
!= BT_DERIVED
) &&
1776 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1781 /* Execute a repeated output. Note the flag no_leading_blank that
1782 is used in the functions used to output the intrinsic types. */
1788 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
1789 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
), NODELIM
);
1790 dtp
->u
.p
.no_leading_blank
= 1;
1794 /* Output the data, if an intrinsic type, or recurse into this
1795 routine to treat derived types. */
1801 write_integer (dtp
, p
, len
);
1805 write_logical (dtp
, p
, len
);
1809 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1810 write_character (dtp
, p
, 4, obj
->string_length
, DELIM
);
1812 write_character (dtp
, p
, 1, obj
->string_length
, DELIM
);
1816 write_real (dtp
, p
, len
);
1820 dtp
->u
.p
.no_leading_blank
= 0;
1822 write_complex (dtp
, p
, len
, obj_size
);
1827 /* To treat a derived type, we need to build two strings:
1828 ext_name = the name, including qualifiers that prepends
1829 component names in the output - passed to
1831 obj_name = the derived type name with no qualifiers but %
1832 appended. This is used to identify the
1835 /* First ext_name => get length of all possible components */
1837 base_name_len
= base_name
? strlen (base_name
) : 0;
1838 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1839 ext_name_len
= base_name_len
+ base_var_name_len
1840 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
1841 ext_name
= xmalloc (ext_name_len
);
1844 memcpy (ext_name
, base_name
, base_name_len
);
1845 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1846 memcpy (ext_name
+ base_name_len
,
1847 obj
->var_name
+ base_var_name_len
, clen
);
1849 /* Append the qualifier. */
1851 tot_len
= base_name_len
+ clen
;
1852 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1856 ext_name
[tot_len
] = '(';
1859 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
1860 (int) obj
->ls
[dim_i
].idx
);
1861 tot_len
+= strlen (ext_name
+ tot_len
);
1862 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1866 ext_name
[tot_len
] = '\0';
1867 for (q
= ext_name
; *q
; q
++)
1873 obj_name_len
= strlen (obj
->var_name
) + 1;
1874 obj_name
= xmalloc (obj_name_len
+ 1);
1875 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1876 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1878 /* Now loop over the components. Update the component pointer
1879 with the return value from nml_write_obj => this loop jumps
1880 past nested derived types. */
1882 for (cmp
= obj
->next
;
1883 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1886 retval
= nml_write_obj (dtp
, cmp
,
1887 (index_type
)(p
- obj
->mem_pos
),
1896 internal_error (&dtp
->common
, "Bad type for namelist write");
1899 /* Reset the leading blank suppression, write a comma (or semi-colon)
1900 and, if 5 values have been output, write a newline and advance
1901 to column 2. Reset the repeat counter. */
1903 dtp
->u
.p
.no_leading_blank
= 0;
1904 if (obj
->type
== BT_CHARACTER
)
1906 if (dtp
->u
.p
.nml_delim
!= '\0')
1907 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
1910 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
1914 if (dtp
->u
.p
.nml_delim
== '\0')
1915 write_character (dtp
, &semi_comma
, 1, 1, NODELIM
);
1916 namelist_write_newline (dtp
);
1917 write_character (dtp
, " ", 1, 1, NODELIM
);
1922 /* Cycle through and increment the index vector. */
1927 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
1929 obj
->ls
[dim_i
].idx
+= nml_carry
;
1931 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
1933 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
1939 /* Return a pointer beyond the furthest object accessed. */
1945 /* This is the entry function for namelist writes. It outputs the name
1946 of the namelist and iterates through the namelist by calls to
1947 nml_write_obj. The call below has dummys in the arguments used in
1948 the treatment of derived types. */
1951 namelist_write (st_parameter_dt
*dtp
)
1953 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1955 index_type dummy_offset
= 0;
1957 char * dummy_name
= NULL
;
1959 /* Set the delimiter for namelist output. */
1960 switch (dtp
->u
.p
.current_unit
->delim_status
)
1962 case DELIM_APOSTROPHE
:
1963 dtp
->u
.p
.nml_delim
= '\'';
1966 case DELIM_UNSPECIFIED
:
1967 dtp
->u
.p
.nml_delim
= '"';
1970 dtp
->u
.p
.nml_delim
= '\0';
1973 write_character (dtp
, "&", 1, 1, NODELIM
);
1975 /* Write namelist name in upper case - f95 std. */
1976 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1978 c
= toupper ((int) dtp
->namelist_name
[i
]);
1979 write_character (dtp
, &c
, 1 ,1, NODELIM
);
1982 if (dtp
->u
.p
.ionml
!= NULL
)
1984 t1
= dtp
->u
.p
.ionml
;
1988 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1992 namelist_write_newline (dtp
);
1993 write_character (dtp
, " /", 1, 2, NODELIM
);