1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist output contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
37 #define star_fill(p, n) memset(p, '*', n)
39 typedef unsigned char uchar
;
41 /* Helper functions for character(kind=4) internal units. These are needed
42 by write_float.def. */
45 memset4 (gfc_char4_t
*p
, gfc_char4_t c
, int k
)
48 for (j
= 0; j
< k
; j
++)
53 memcpy4 (gfc_char4_t
*dest
, const char *source
, int k
)
57 const char *p
= source
;
58 for (j
= 0; j
< k
; j
++)
59 *dest
++ = (gfc_char4_t
) *p
++;
62 /* This include contains the heart and soul of formatted floating point. */
63 #include "write_float.def"
65 /* Write out default char4. */
68 write_default_char4 (st_parameter_dt
*dtp
, const gfc_char4_t
*source
,
69 int src_len
, int w_len
)
76 /* Take care of preceding blanks. */
80 p
= write_block (dtp
, k
);
83 if (is_char4_unit (dtp
))
85 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
92 /* Get ready to handle delimiters if needed. */
93 switch (dtp
->u
.p
.current_unit
->delim_status
)
95 case DELIM_APOSTROPHE
:
106 /* Now process the remaining characters, one at a time. */
107 for (j
= 0; j
< src_len
; j
++)
110 if (is_char4_unit (dtp
))
113 /* Handle delimiters if any. */
114 if (c
== d
&& d
!= ' ')
116 p
= write_block (dtp
, 2);
119 q
= (gfc_char4_t
*) p
;
124 p
= write_block (dtp
, 1);
127 q
= (gfc_char4_t
*) p
;
133 /* Handle delimiters if any. */
134 if (c
== d
&& d
!= ' ')
136 p
= write_block (dtp
, 2);
143 p
= write_block (dtp
, 1);
147 *p
= c
> 255 ? '?' : (uchar
) c
;
153 /* Write out UTF-8 converted from char4. */
156 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
157 int src_len
, int w_len
)
162 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
163 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
167 /* Take care of preceding blanks. */
171 p
= write_block (dtp
, k
);
177 /* Get ready to handle delimiters if needed. */
178 switch (dtp
->u
.p
.current_unit
->delim_status
)
180 case DELIM_APOSTROPHE
:
191 /* Now process the remaining characters, one at a time. */
192 for (j
= k
; j
< src_len
; j
++)
197 /* Handle the delimiters if any. */
198 if (c
== d
&& d
!= ' ')
200 p
= write_block (dtp
, 2);
207 p
= write_block (dtp
, 1);
215 /* Convert to UTF-8 sequence. */
221 *--q
= ((c
& 0x3F) | 0x80);
225 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
227 *--q
= (c
| masks
[nbytes
-1]);
229 p
= write_block (dtp
, nbytes
);
241 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
246 wlen
= f
->u
.string
.length
< 0
247 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
248 ? len
: f
->u
.string
.length
;
251 /* If this is formatted STREAM IO convert any embedded line feed characters
252 to CR_LF on systems that use that sequence for newlines. See F2003
253 Standard sections 10.6.3 and 9.9 for further information. */
254 if (is_stream_io (dtp
))
256 const char crlf
[] = "\r\n";
260 /* Write out any padding if needed. */
263 p
= write_block (dtp
, wlen
- len
);
266 memset (p
, ' ', wlen
- len
);
269 /* Scan the source string looking for '\n' and convert it if found. */
270 for (i
= 0; i
< wlen
; i
++)
272 if (source
[i
] == '\n')
274 /* Write out the previously scanned characters in the string. */
277 p
= write_block (dtp
, bytes
);
280 memcpy (p
, &source
[q
], bytes
);
285 /* Write out the CR_LF sequence. */
287 p
= write_block (dtp
, 2);
296 /* Write out any remaining bytes if no LF was found. */
299 p
= write_block (dtp
, bytes
);
302 memcpy (p
, &source
[q
], bytes
);
308 p
= write_block (dtp
, wlen
);
312 if (unlikely (is_char4_unit (dtp
)))
314 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
316 memcpy4 (p4
, source
, wlen
);
319 memset4 (p4
, ' ', wlen
- len
);
320 memcpy4 (p4
+ wlen
- len
, source
, len
);
326 memcpy (p
, source
, wlen
);
329 memset (p
, ' ', wlen
- len
);
330 memcpy (p
+ wlen
- len
, source
, len
);
338 /* The primary difference between write_a_char4 and write_a is that we have to
339 deal with writing from the first byte of the 4-byte character and pay
340 attention to the most significant bytes. For ENCODING="default" write the
341 lowest significant byte. If the 3 most significant bytes contain
342 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
343 to the UTF-8 encoded string before writing out. */
346 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
351 wlen
= f
->u
.string
.length
< 0
352 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
353 ? len
: f
->u
.string
.length
;
355 q
= (gfc_char4_t
*) source
;
357 /* If this is formatted STREAM IO convert any embedded line feed characters
358 to CR_LF on systems that use that sequence for newlines. See F2003
359 Standard sections 10.6.3 and 9.9 for further information. */
360 if (is_stream_io (dtp
))
362 const gfc_char4_t crlf
[] = {0x000d,0x000a};
367 /* Write out any padding if needed. */
371 p
= write_block (dtp
, wlen
- len
);
374 memset (p
, ' ', wlen
- len
);
377 /* Scan the source string looking for '\n' and convert it if found. */
378 qq
= (gfc_char4_t
*) source
;
379 for (i
= 0; i
< wlen
; i
++)
383 /* Write out the previously scanned characters in the string. */
386 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
387 write_utf8_char4 (dtp
, q
, bytes
, 0);
389 write_default_char4 (dtp
, q
, bytes
, 0);
393 /* Write out the CR_LF sequence. */
394 write_default_char4 (dtp
, crlf
, 2, 0);
400 /* Write out any remaining bytes if no LF was found. */
403 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
404 write_utf8_char4 (dtp
, q
, bytes
, 0);
406 write_default_char4 (dtp
, q
, bytes
, 0);
412 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
413 write_utf8_char4 (dtp
, q
, len
, wlen
);
415 write_default_char4 (dtp
, q
, len
, wlen
);
422 static GFC_INTEGER_LARGEST
423 extract_int (const void *p
, int len
)
425 GFC_INTEGER_LARGEST i
= 0;
435 memcpy ((void *) &tmp
, p
, len
);
442 memcpy ((void *) &tmp
, p
, len
);
449 memcpy ((void *) &tmp
, p
, len
);
456 memcpy ((void *) &tmp
, p
, len
);
460 #ifdef HAVE_GFC_INTEGER_16
464 memcpy ((void *) &tmp
, p
, len
);
470 internal_error (NULL
, "bad integer kind");
476 static GFC_UINTEGER_LARGEST
477 extract_uint (const void *p
, int len
)
479 GFC_UINTEGER_LARGEST i
= 0;
489 memcpy ((void *) &tmp
, p
, len
);
490 i
= (GFC_UINTEGER_1
) tmp
;
496 memcpy ((void *) &tmp
, p
, len
);
497 i
= (GFC_UINTEGER_2
) tmp
;
503 memcpy ((void *) &tmp
, p
, len
);
504 i
= (GFC_UINTEGER_4
) tmp
;
510 memcpy ((void *) &tmp
, p
, len
);
511 i
= (GFC_UINTEGER_8
) tmp
;
514 #ifdef HAVE_GFC_INTEGER_16
518 GFC_INTEGER_16 tmp
= 0;
519 memcpy ((void *) &tmp
, p
, len
);
520 i
= (GFC_UINTEGER_16
) tmp
;
525 internal_error (NULL
, "bad integer kind");
533 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
537 GFC_INTEGER_LARGEST n
;
539 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
541 p
= write_block (dtp
, wlen
);
545 n
= extract_int (source
, len
);
547 if (unlikely (is_char4_unit (dtp
)))
549 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
550 memset4 (p4
, ' ', wlen
-1);
551 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
555 memset (p
, ' ', wlen
-1);
556 p
[wlen
- 1] = (n
) ? 'T' : 'F';
561 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
563 int w
, m
, digits
, nzero
, nblank
;
571 if (m
== 0 && n
== 0)
576 p
= write_block (dtp
, w
);
579 if (unlikely (is_char4_unit (dtp
)))
581 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
582 memset4 (p4
, ' ', w
);
591 /* Select a width if none was specified. The idea here is to always
595 w
= ((digits
< m
) ? m
: digits
);
597 p
= write_block (dtp
, w
);
605 /* See if things will work. */
607 nblank
= w
- (nzero
+ digits
);
609 if (unlikely (is_char4_unit (dtp
)))
611 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
614 memset4 (p4
, '*', w
);
618 if (!dtp
->u
.p
.no_leading_blank
)
620 memset4 (p4
, ' ', nblank
);
622 memset4 (p4
, '0', nzero
);
624 memcpy4 (p4
, q
, digits
);
628 memset4 (p4
, '0', nzero
);
630 memcpy4 (p4
, q
, digits
);
632 memset4 (p4
, ' ', nblank
);
633 dtp
->u
.p
.no_leading_blank
= 0;
644 if (!dtp
->u
.p
.no_leading_blank
)
646 memset (p
, ' ', nblank
);
648 memset (p
, '0', nzero
);
650 memcpy (p
, q
, digits
);
654 memset (p
, '0', nzero
);
656 memcpy (p
, q
, digits
);
658 memset (p
, ' ', nblank
);
659 dtp
->u
.p
.no_leading_blank
= 0;
667 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
669 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
671 GFC_INTEGER_LARGEST n
= 0;
672 int w
, m
, digits
, nsign
, nzero
, nblank
;
676 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
679 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
681 n
= extract_int (source
, len
);
684 if (m
== 0 && n
== 0)
689 p
= write_block (dtp
, w
);
692 if (unlikely (is_char4_unit (dtp
)))
694 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
695 memset4 (p4
, ' ', w
);
702 sign
= calculate_sign (dtp
, n
< 0);
705 nsign
= sign
== S_NONE
? 0 : 1;
707 /* conv calls itoa which sets the negative sign needed
708 by write_integer. The sign '+' or '-' is set below based on sign
709 calculated above, so we just point past the sign in the string
710 before proceeding to avoid double signs in corner cases.
712 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
718 /* Select a width if none was specified. The idea here is to always
722 w
= ((digits
< m
) ? m
: digits
) + nsign
;
724 p
= write_block (dtp
, w
);
732 /* See if things will work. */
734 nblank
= w
- (nsign
+ nzero
+ digits
);
736 if (unlikely (is_char4_unit (dtp
)))
738 gfc_char4_t
* p4
= (gfc_char4_t
*) p
;
741 memset4 (p4
, '*', w
);
745 memset4 (p4
, ' ', nblank
);
760 memset4 (p4
, '0', nzero
);
763 memcpy4 (p4
, q
, digits
);
773 memset (p
, ' ', nblank
);
788 memset (p
, '0', nzero
);
791 memcpy (p
, q
, digits
);
798 /* Convert unsigned octal to ascii. */
801 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
805 assert (len
>= GFC_OTOA_BUF_SIZE
);
810 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
815 *--p
= '0' + (n
& 7);
823 /* Convert unsigned binary to ascii. */
826 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
830 assert (len
>= GFC_BTOA_BUF_SIZE
);
835 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
840 *--p
= '0' + (n
& 1);
847 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
848 to convert large reals with kind sizes that exceed the largest integer type
849 available on certain platforms. In these cases, byte by byte conversion is
850 performed. Endianess is taken into account. */
852 /* Conversion to binary. */
855 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
864 for (i
= 0; i
< len
; i
++)
868 /* Test for zero. Needed by write_boz later. */
872 for (j
= 0; j
< 8; j
++)
874 *q
++ = (c
& 128) ? '1' : '0';
882 const char *p
= s
+ len
- 1;
883 for (i
= 0; i
< len
; i
++)
887 /* Test for zero. Needed by write_boz later. */
891 for (j
= 0; j
< 8; j
++)
893 *q
++ = (c
& 128) ? '1' : '0';
905 /* Move past any leading zeros. */
906 while (*buffer
== '0')
913 /* Conversion to octal. */
916 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
922 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
928 const char *p
= s
+ len
- 1;
932 /* Test for zero. Needed by write_boz later. */
936 for (j
= 0; j
< 3 && i
< len
; j
++)
938 octet
|= (c
& 1) << j
;
957 /* Test for zero. Needed by write_boz later. */
961 for (j
= 0; j
< 3 && i
< len
; j
++)
963 octet
|= (c
& 1) << j
;
980 /* Move past any leading zeros. */
987 /* Conversion to hexidecimal. */
990 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
992 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
993 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
1004 for (i
= 0; i
< len
; i
++)
1006 /* Test for zero. Needed by write_boz later. */
1010 h
= (*p
>> 4) & 0x0F;
1018 const char *p
= s
+ len
- 1;
1019 for (i
= 0; i
< len
; i
++)
1021 /* Test for zero. Needed by write_boz later. */
1025 h
= (*p
>> 4) & 0x0F;
1037 /* Move past any leading zeros. */
1038 while (*buffer
== '0')
1044 /* gfc_itoa()-- Integer to decimal conversion.
1045 The itoa function is a widespread non-standard extension to standard
1046 C, often declared in <stdlib.h>. Even though the itoa defined here
1047 is a static function we take care not to conflict with any prior
1048 non-static declaration. Hence the 'gfc_' prefix, which is normally
1049 reserved for functions with external linkage. */
1052 gfc_itoa (GFC_INTEGER_LARGEST n
, char *buffer
, size_t len
)
1056 GFC_UINTEGER_LARGEST t
;
1058 assert (len
>= GFC_ITOA_BUF_SIZE
);
1068 t
= -n
; /*must use unsigned to protect from overflow*/
1071 p
= buffer
+ GFC_ITOA_BUF_SIZE
- 1;
1076 *--p
= '0' + (t
% 10);
1087 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1089 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1094 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1097 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1098 GFC_UINTEGER_LARGEST n
= 0;
1100 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1102 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1103 write_boz (dtp
, f
, p
, n
);
1107 n
= extract_uint (source
, len
);
1108 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1109 write_boz (dtp
, f
, p
, n
);
1115 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1118 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1119 GFC_UINTEGER_LARGEST n
= 0;
1121 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1123 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1124 write_boz (dtp
, f
, p
, n
);
1128 n
= extract_uint (source
, len
);
1129 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1130 write_boz (dtp
, f
, p
, n
);
1135 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1138 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1139 GFC_UINTEGER_LARGEST n
= 0;
1141 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1143 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1144 write_boz (dtp
, f
, p
, n
);
1148 n
= extract_uint (source
, len
);
1149 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1150 write_boz (dtp
, f
, p
, n
);
1156 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1158 write_float (dtp
, f
, p
, len
, 0);
1163 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1165 write_float (dtp
, f
, p
, len
, 0);
1170 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1172 write_float (dtp
, f
, p
, len
, 0);
1177 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1179 write_float (dtp
, f
, p
, len
, 0);
1184 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1186 write_float (dtp
, f
, p
, len
, 0);
1190 /* Take care of the X/TR descriptor. */
1193 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1197 p
= write_block (dtp
, len
);
1200 if (nspaces
> 0 && len
- nspaces
>= 0)
1202 if (unlikely (is_char4_unit (dtp
)))
1204 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1205 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1208 memset (&p
[len
- nspaces
], ' ', nspaces
);
1213 /* List-directed writing. */
1216 /* Write a single character to the output. Returns nonzero if
1217 something goes wrong. */
1220 write_char (st_parameter_dt
*dtp
, int c
)
1224 p
= write_block (dtp
, 1);
1227 if (unlikely (is_char4_unit (dtp
)))
1229 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1240 /* Write a list-directed logical value. */
1243 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1245 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1249 /* Write a list-directed integer value. */
1252 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1258 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1260 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1285 digits
= strlen (q
);
1289 p
= write_block (dtp
, width
);
1293 if (unlikely (is_char4_unit (dtp
)))
1295 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1296 if (dtp
->u
.p
.no_leading_blank
)
1298 memcpy4 (p4
, q
, digits
);
1299 memset4 (p4
+ digits
, ' ', width
- digits
);
1303 memset4 (p4
, ' ', width
- digits
);
1304 memcpy4 (p4
+ width
- digits
, q
, digits
);
1309 if (dtp
->u
.p
.no_leading_blank
)
1311 memcpy (p
, q
, digits
);
1312 memset (p
+ digits
, ' ', width
- digits
);
1316 memset (p
, ' ', width
- digits
);
1317 memcpy (p
+ width
- digits
, q
, digits
);
1322 /* Write a list-directed string. We have to worry about delimiting
1323 the strings if the file has been opened in that mode. */
1326 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
1331 switch (dtp
->u
.p
.current_unit
->delim_status
)
1333 case DELIM_APOSTROPHE
:
1352 for (i
= 0; i
< length
; i
++)
1357 p
= write_block (dtp
, length
+ extra
);
1361 if (unlikely (is_char4_unit (dtp
)))
1363 gfc_char4_t d4
= (gfc_char4_t
) d
;
1364 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1367 memcpy4 (p4
, source
, length
);
1372 for (i
= 0; i
< length
; i
++)
1374 *p4
++ = (gfc_char4_t
) source
[i
];
1385 memcpy (p
, source
, length
);
1390 for (i
= 0; i
< length
; i
++)
1404 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1405 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1407 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1411 p
= write_block (dtp
, 1);
1414 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1415 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1417 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1419 p
= write_block (dtp
, 1);
1426 /* Set an fnode to default format. */
1429 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1455 internal_error (&dtp
->common
, "bad real kind");
1460 /* Output a real number with default format. This is 1PG16.9E2 for
1461 REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4 for REAL(10) and
1462 1PG45.36E4 for REAL(16). The exception is that the Fortran standard
1463 requires outputting an extra digit when the scale factor is 1 and
1464 when the magnitude of the value is such that E editing is
1465 used. However, gfortran compensates for this, and thus for list
1466 formatted the same number of significant digits is generated both
1467 when using F and E editing. */
1470 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1473 int org_scale
= dtp
->u
.p
.scale_factor
;
1474 dtp
->u
.p
.scale_factor
= 1;
1475 set_fnode_default (dtp
, &f
, length
);
1476 write_float (dtp
, &f
, source
, length
, 1);
1477 dtp
->u
.p
.scale_factor
= org_scale
;
1480 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1481 compensate for the extra digit. */
1484 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1488 set_fnode_default (dtp
, &f
, length
);
1492 /* Compensate for extra digits when using scale factor, d is not
1493 specified, and the magnitude is such that E editing is used. */
1494 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1498 dtp
->u
.p
.g0_no_blanks
= 1;
1499 write_float (dtp
, &f
, source
, length
, comp_d
);
1500 dtp
->u
.p
.g0_no_blanks
= 0;
1505 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1508 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1510 if (write_char (dtp
, '('))
1512 write_real (dtp
, source
, kind
);
1514 if (write_char (dtp
, semi_comma
))
1516 write_real (dtp
, source
+ size
/ 2, kind
);
1518 write_char (dtp
, ')');
1522 /* Write the separator between items. */
1525 write_separator (st_parameter_dt
*dtp
)
1529 p
= write_block (dtp
, options
.separator_len
);
1532 if (unlikely (is_char4_unit (dtp
)))
1534 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1535 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1538 memcpy (p
, options
.separator
, options
.separator_len
);
1542 /* Write an item with list formatting.
1543 TODO: handle skipping to the next record correctly, particularly
1547 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1550 if (dtp
->u
.p
.current_unit
== NULL
)
1553 if (dtp
->u
.p
.first_item
)
1555 dtp
->u
.p
.first_item
= 0;
1556 write_char (dtp
, ' ');
1560 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1561 dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
)
1562 write_separator (dtp
);
1568 write_integer (dtp
, p
, kind
);
1571 write_logical (dtp
, p
, kind
);
1574 write_character (dtp
, p
, kind
, size
);
1577 write_real (dtp
, p
, kind
);
1580 write_complex (dtp
, p
, kind
, size
);
1583 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1586 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1591 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1592 size_t size
, size_t nelems
)
1596 size_t stride
= type
== BT_CHARACTER
?
1597 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1601 /* Big loop over all the elements. */
1602 for (elem
= 0; elem
< nelems
; elem
++)
1604 dtp
->u
.p
.item_count
++;
1605 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1611 nml_write_obj writes a namelist object to the output stream. It is called
1612 recursively for derived type components:
1613 obj = is the namelist_info for the current object.
1614 offset = the offset relative to the address held by the object for
1615 derived type arrays.
1616 base = is the namelist_info of the derived type, when obj is a
1618 base_name = the full name for a derived type, including qualifiers
1620 The returned value is a pointer to the object beyond the last one
1621 accessed, including nested derived types. Notice that the namelist is
1622 a linear linked list of objects, including derived types and their
1623 components. A tree, of sorts, is implied by the compound names of
1624 the derived type components and this is how this function recurses through
1627 /* A generous estimate of the number of characters needed to print
1628 repeat counts and indices, including commas, asterices and brackets. */
1630 #define NML_DIGITS 20
1633 namelist_write_newline (st_parameter_dt
*dtp
)
1635 if (!is_internal_unit (dtp
))
1638 write_character (dtp
, "\r\n", 1, 2);
1640 write_character (dtp
, "\n", 1, 1);
1645 if (is_array_io (dtp
))
1650 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
1652 p
= write_block (dtp
, length
);
1656 if (unlikely (is_char4_unit (dtp
)))
1658 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1659 memset4 (p4
, ' ', length
);
1662 memset (p
, ' ', length
);
1664 /* Now that the current record has been padded out,
1665 determine where the next record in the array is. */
1666 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1669 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1672 /* Now seek to this record */
1673 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1675 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1677 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1681 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1685 write_character (dtp
, " ", 1, 1);
1689 static namelist_info
*
1690 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1691 namelist_info
* base
, char * base_name
)
1697 index_type obj_size
;
1701 index_type elem_ctr
;
1702 size_t obj_name_len
;
1707 size_t ext_name_len
;
1708 char rep_buff
[NML_DIGITS
];
1709 namelist_info
* cmp
;
1710 namelist_info
* retval
= obj
->next
;
1711 size_t base_name_len
;
1712 size_t base_var_name_len
;
1714 unit_delim tmp_delim
;
1716 /* Set the character to be used to separate values
1717 to a comma or semi-colon. */
1720 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1722 /* Write namelist variable names in upper case. If a derived type,
1723 nothing is output. If a component, base and base_name are set. */
1725 if (obj
->type
!= BT_DERIVED
)
1727 namelist_write_newline (dtp
);
1728 write_character (dtp
, " ", 1, 1);
1733 len
= strlen (base
->var_name
);
1734 base_name_len
= strlen (base_name
);
1735 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
1737 cup
= toupper ((int) base_name
[dim_i
]);
1738 write_character (dtp
, &cup
, 1, 1);
1741 clen
= strlen (obj
->var_name
);
1742 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
1744 cup
= toupper ((int) obj
->var_name
[dim_i
]);
1745 write_character (dtp
, &cup
, 1, 1);
1747 write_character (dtp
, "=", 1, 1);
1750 /* Counts the number of data output on a line, including names. */
1760 obj_size
= size_from_real_kind (len
);
1764 obj_size
= size_from_complex_kind (len
);
1768 obj_size
= obj
->string_length
;
1776 obj_size
= obj
->size
;
1778 /* Set the index vector and count the number of elements. */
1781 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1783 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
1784 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
1787 /* Main loop to output the data held in the object. */
1790 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1793 /* Build the pointer to the data value. The offset is passed by
1794 recursive calls to this function for arrays of derived types.
1795 Is NULL otherwise. */
1797 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1800 /* Check for repeat counts of intrinsic types. */
1802 if ((elem_ctr
< (nelem
- 1)) &&
1803 (obj
->type
!= BT_DERIVED
) &&
1804 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1809 /* Execute a repeated output. Note the flag no_leading_blank that
1810 is used in the functions used to output the intrinsic types. */
1816 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
1817 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1818 dtp
->u
.p
.no_leading_blank
= 1;
1822 /* Output the data, if an intrinsic type, or recurse into this
1823 routine to treat derived types. */
1829 write_integer (dtp
, p
, len
);
1833 write_logical (dtp
, p
, len
);
1837 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1838 if (dtp
->u
.p
.nml_delim
== '"')
1839 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1840 if (dtp
->u
.p
.nml_delim
== '\'')
1841 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1842 write_character (dtp
, p
, 1, obj
->string_length
);
1843 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1847 write_real (dtp
, p
, len
);
1851 dtp
->u
.p
.no_leading_blank
= 0;
1853 write_complex (dtp
, p
, len
, obj_size
);
1858 /* To treat a derived type, we need to build two strings:
1859 ext_name = the name, including qualifiers that prepends
1860 component names in the output - passed to
1862 obj_name = the derived type name with no qualifiers but %
1863 appended. This is used to identify the
1866 /* First ext_name => get length of all possible components */
1868 base_name_len
= base_name
? strlen (base_name
) : 0;
1869 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1870 ext_name_len
= base_name_len
+ base_var_name_len
1871 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
1872 ext_name
= (char*)get_mem (ext_name_len
);
1874 memcpy (ext_name
, base_name
, base_name_len
);
1875 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1876 memcpy (ext_name
+ base_name_len
,
1877 obj
->var_name
+ base_var_name_len
, clen
);
1879 /* Append the qualifier. */
1881 tot_len
= base_name_len
+ clen
;
1882 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1886 ext_name
[tot_len
] = '(';
1889 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
1890 (int) obj
->ls
[dim_i
].idx
);
1891 tot_len
+= strlen (ext_name
+ tot_len
);
1892 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1896 ext_name
[tot_len
] = '\0';
1900 obj_name_len
= strlen (obj
->var_name
) + 1;
1901 obj_name
= get_mem (obj_name_len
+1);
1902 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1903 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1905 /* Now loop over the components. Update the component pointer
1906 with the return value from nml_write_obj => this loop jumps
1907 past nested derived types. */
1909 for (cmp
= obj
->next
;
1910 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1913 retval
= nml_write_obj (dtp
, cmp
,
1914 (index_type
)(p
- obj
->mem_pos
),
1923 internal_error (&dtp
->common
, "Bad type for namelist write");
1926 /* Reset the leading blank suppression, write a comma (or semi-colon)
1927 and, if 5 values have been output, write a newline and advance
1928 to column 2. Reset the repeat counter. */
1930 dtp
->u
.p
.no_leading_blank
= 0;
1931 write_character (dtp
, &semi_comma
, 1, 1);
1935 namelist_write_newline (dtp
);
1936 write_character (dtp
, " ", 1, 1);
1941 /* Cycle through and increment the index vector. */
1946 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
1948 obj
->ls
[dim_i
].idx
+= nml_carry
;
1950 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
1952 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
1958 /* Return a pointer beyond the furthest object accessed. */
1964 /* This is the entry function for namelist writes. It outputs the name
1965 of the namelist and iterates through the namelist by calls to
1966 nml_write_obj. The call below has dummys in the arguments used in
1967 the treatment of derived types. */
1970 namelist_write (st_parameter_dt
*dtp
)
1972 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1974 index_type dummy_offset
= 0;
1976 char * dummy_name
= NULL
;
1977 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1979 /* Set the delimiter for namelist output. */
1980 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1982 dtp
->u
.p
.nml_delim
= tmp_delim
== DELIM_APOSTROPHE
? '\'' : '"';
1984 /* Temporarily disable namelist delimters. */
1985 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1987 write_character (dtp
, "&", 1, 1);
1989 /* Write namelist name in upper case - f95 std. */
1990 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1992 c
= toupper ((int) dtp
->namelist_name
[i
]);
1993 write_character (dtp
, &c
, 1 ,1);
1996 if (dtp
->u
.p
.ionml
!= NULL
)
1998 t1
= dtp
->u
.p
.ionml
;
2002 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2006 namelist_write_newline (dtp
);
2007 write_character (dtp
, " /", 1, 2);
2008 /* Restore the original delimiter. */
2009 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;