1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011,
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5 Namelist output contributed by Paul Thomas
6 F2003 I/O support contributed by Jerry DeLisle
8 This file is part of the GNU Fortran runtime library (libgfortran).
10 Libgfortran is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3, or (at your option)
15 Libgfortran is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 Under Section 7 of GPL version 3, you are granted additional
21 permissions described in the GCC Runtime Library Exception, version
22 3.1, as published by the Free Software Foundation.
24 You should have received a copy of the GNU General Public License and
25 a copy of the GCC Runtime Library Exception along with this program;
26 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
27 <http://www.gnu.org/licenses/>. */
38 #define star_fill(p, n) memset(p, '*', n)
40 typedef unsigned char uchar
;
42 /* Helper functions for character(kind=4) internal units. These are needed
43 by write_float.def. */
46 memcpy4 (gfc_char4_t
*dest
, const char *source
, int k
)
50 const char *p
= source
;
51 for (j
= 0; j
< k
; j
++)
52 *dest
++ = (gfc_char4_t
) *p
++;
55 /* This include contains the heart and soul of formatted floating point. */
56 #include "write_float.def"
58 /* Write out default char4. */
61 write_default_char4 (st_parameter_dt
*dtp
, const gfc_char4_t
*source
,
62 int src_len
, int w_len
)
69 /* Take care of preceding blanks. */
73 p
= write_block (dtp
, k
);
76 if (is_char4_unit (dtp
))
78 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
85 /* Get ready to handle delimiters if needed. */
86 switch (dtp
->u
.p
.current_unit
->delim_status
)
88 case DELIM_APOSTROPHE
:
99 /* Now process the remaining characters, one at a time. */
100 for (j
= 0; j
< src_len
; j
++)
103 if (is_char4_unit (dtp
))
106 /* Handle delimiters if any. */
107 if (c
== d
&& d
!= ' ')
109 p
= write_block (dtp
, 2);
112 q
= (gfc_char4_t
*) p
;
117 p
= write_block (dtp
, 1);
120 q
= (gfc_char4_t
*) p
;
126 /* Handle delimiters if any. */
127 if (c
== d
&& d
!= ' ')
129 p
= write_block (dtp
, 2);
136 p
= write_block (dtp
, 1);
140 *p
= c
> 255 ? '?' : (uchar
) c
;
146 /* Write out UTF-8 converted from char4. */
149 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
150 int src_len
, int w_len
)
155 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
156 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
160 /* Take care of preceding blanks. */
164 p
= write_block (dtp
, k
);
170 /* Get ready to handle delimiters if needed. */
171 switch (dtp
->u
.p
.current_unit
->delim_status
)
173 case DELIM_APOSTROPHE
:
184 /* Now process the remaining characters, one at a time. */
185 for (j
= k
; j
< src_len
; j
++)
190 /* Handle the delimiters if any. */
191 if (c
== d
&& d
!= ' ')
193 p
= write_block (dtp
, 2);
200 p
= write_block (dtp
, 1);
208 /* Convert to UTF-8 sequence. */
214 *--q
= ((c
& 0x3F) | 0x80);
218 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
220 *--q
= (c
| masks
[nbytes
-1]);
222 p
= write_block (dtp
, nbytes
);
234 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
239 wlen
= f
->u
.string
.length
< 0
240 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
241 ? len
: f
->u
.string
.length
;
244 /* If this is formatted STREAM IO convert any embedded line feed characters
245 to CR_LF on systems that use that sequence for newlines. See F2003
246 Standard sections 10.6.3 and 9.9 for further information. */
247 if (is_stream_io (dtp
))
249 const char crlf
[] = "\r\n";
253 /* Write out any padding if needed. */
256 p
= write_block (dtp
, wlen
- len
);
259 memset (p
, ' ', wlen
- len
);
262 /* Scan the source string looking for '\n' and convert it if found. */
263 for (i
= 0; i
< wlen
; i
++)
265 if (source
[i
] == '\n')
267 /* Write out the previously scanned characters in the string. */
270 p
= write_block (dtp
, bytes
);
273 memcpy (p
, &source
[q
], bytes
);
278 /* Write out the CR_LF sequence. */
280 p
= write_block (dtp
, 2);
289 /* Write out any remaining bytes if no LF was found. */
292 p
= write_block (dtp
, bytes
);
295 memcpy (p
, &source
[q
], bytes
);
301 p
= write_block (dtp
, wlen
);
305 if (unlikely (is_char4_unit (dtp
)))
307 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
309 memcpy4 (p4
, source
, wlen
);
312 memset4 (p4
, ' ', wlen
- len
);
313 memcpy4 (p4
+ wlen
- len
, source
, len
);
319 memcpy (p
, source
, wlen
);
322 memset (p
, ' ', wlen
- len
);
323 memcpy (p
+ wlen
- len
, source
, len
);
331 /* The primary difference between write_a_char4 and write_a is that we have to
332 deal with writing from the first byte of the 4-byte character and pay
333 attention to the most significant bytes. For ENCODING="default" write the
334 lowest significant byte. If the 3 most significant bytes contain
335 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
336 to the UTF-8 encoded string before writing out. */
339 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
344 wlen
= f
->u
.string
.length
< 0
345 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
346 ? len
: f
->u
.string
.length
;
348 q
= (gfc_char4_t
*) source
;
350 /* If this is formatted STREAM IO convert any embedded line feed characters
351 to CR_LF on systems that use that sequence for newlines. See F2003
352 Standard sections 10.6.3 and 9.9 for further information. */
353 if (is_stream_io (dtp
))
355 const gfc_char4_t crlf
[] = {0x000d,0x000a};
360 /* Write out any padding if needed. */
364 p
= write_block (dtp
, wlen
- len
);
367 memset (p
, ' ', wlen
- len
);
370 /* Scan the source string looking for '\n' and convert it if found. */
371 qq
= (gfc_char4_t
*) source
;
372 for (i
= 0; i
< wlen
; i
++)
376 /* Write out the previously scanned characters in the string. */
379 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
380 write_utf8_char4 (dtp
, q
, bytes
, 0);
382 write_default_char4 (dtp
, q
, bytes
, 0);
386 /* Write out the CR_LF sequence. */
387 write_default_char4 (dtp
, crlf
, 2, 0);
393 /* Write out any remaining bytes if no LF was found. */
396 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
397 write_utf8_char4 (dtp
, q
, bytes
, 0);
399 write_default_char4 (dtp
, q
, bytes
, 0);
405 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
406 write_utf8_char4 (dtp
, q
, len
, wlen
);
408 write_default_char4 (dtp
, q
, len
, wlen
);
415 static GFC_INTEGER_LARGEST
416 extract_int (const void *p
, int len
)
418 GFC_INTEGER_LARGEST i
= 0;
428 memcpy ((void *) &tmp
, p
, len
);
435 memcpy ((void *) &tmp
, p
, len
);
442 memcpy ((void *) &tmp
, p
, len
);
449 memcpy ((void *) &tmp
, p
, len
);
453 #ifdef HAVE_GFC_INTEGER_16
457 memcpy ((void *) &tmp
, p
, len
);
463 internal_error (NULL
, "bad integer kind");
469 static GFC_UINTEGER_LARGEST
470 extract_uint (const void *p
, int len
)
472 GFC_UINTEGER_LARGEST i
= 0;
482 memcpy ((void *) &tmp
, p
, len
);
483 i
= (GFC_UINTEGER_1
) tmp
;
489 memcpy ((void *) &tmp
, p
, len
);
490 i
= (GFC_UINTEGER_2
) tmp
;
496 memcpy ((void *) &tmp
, p
, len
);
497 i
= (GFC_UINTEGER_4
) tmp
;
503 memcpy ((void *) &tmp
, p
, len
);
504 i
= (GFC_UINTEGER_8
) tmp
;
507 #ifdef HAVE_GFC_INTEGER_16
511 GFC_INTEGER_16 tmp
= 0;
512 memcpy ((void *) &tmp
, p
, len
);
513 i
= (GFC_UINTEGER_16
) tmp
;
518 internal_error (NULL
, "bad integer kind");
526 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
530 GFC_INTEGER_LARGEST n
;
532 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
534 p
= write_block (dtp
, wlen
);
538 n
= extract_int (source
, len
);
540 if (unlikely (is_char4_unit (dtp
)))
542 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
543 memset4 (p4
, ' ', wlen
-1);
544 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
548 memset (p
, ' ', wlen
-1);
549 p
[wlen
- 1] = (n
) ? 'T' : 'F';
554 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
556 int w
, m
, digits
, nzero
, nblank
;
564 if (m
== 0 && n
== 0)
569 p
= write_block (dtp
, w
);
572 if (unlikely (is_char4_unit (dtp
)))
574 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
575 memset4 (p4
, ' ', w
);
584 /* Select a width if none was specified. The idea here is to always
588 w
= ((digits
< m
) ? m
: digits
);
590 p
= write_block (dtp
, w
);
598 /* See if things will work. */
600 nblank
= w
- (nzero
+ digits
);
602 if (unlikely (is_char4_unit (dtp
)))
604 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
607 memset4 (p4
, '*', w
);
611 if (!dtp
->u
.p
.no_leading_blank
)
613 memset4 (p4
, ' ', nblank
);
615 memset4 (p4
, '0', nzero
);
617 memcpy4 (p4
, q
, digits
);
621 memset4 (p4
, '0', nzero
);
623 memcpy4 (p4
, q
, digits
);
625 memset4 (p4
, ' ', nblank
);
626 dtp
->u
.p
.no_leading_blank
= 0;
637 if (!dtp
->u
.p
.no_leading_blank
)
639 memset (p
, ' ', nblank
);
641 memset (p
, '0', nzero
);
643 memcpy (p
, q
, digits
);
647 memset (p
, '0', nzero
);
649 memcpy (p
, q
, digits
);
651 memset (p
, ' ', nblank
);
652 dtp
->u
.p
.no_leading_blank
= 0;
660 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
662 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
664 GFC_INTEGER_LARGEST n
= 0;
665 int w
, m
, digits
, nsign
, nzero
, nblank
;
669 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
672 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
674 n
= extract_int (source
, len
);
677 if (m
== 0 && n
== 0)
682 p
= write_block (dtp
, w
);
685 if (unlikely (is_char4_unit (dtp
)))
687 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
688 memset4 (p4
, ' ', w
);
695 sign
= calculate_sign (dtp
, n
< 0);
698 nsign
= sign
== S_NONE
? 0 : 1;
700 /* conv calls itoa which sets the negative sign needed
701 by write_integer. The sign '+' or '-' is set below based on sign
702 calculated above, so we just point past the sign in the string
703 before proceeding to avoid double signs in corner cases.
705 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
711 /* Select a width if none was specified. The idea here is to always
715 w
= ((digits
< m
) ? m
: digits
) + nsign
;
717 p
= write_block (dtp
, w
);
725 /* See if things will work. */
727 nblank
= w
- (nsign
+ nzero
+ digits
);
729 if (unlikely (is_char4_unit (dtp
)))
731 gfc_char4_t
* p4
= (gfc_char4_t
*) p
;
734 memset4 (p4
, '*', w
);
738 memset4 (p4
, ' ', nblank
);
753 memset4 (p4
, '0', nzero
);
756 memcpy4 (p4
, q
, digits
);
766 memset (p
, ' ', nblank
);
781 memset (p
, '0', nzero
);
784 memcpy (p
, q
, digits
);
791 /* Convert unsigned octal to ascii. */
794 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
798 assert (len
>= GFC_OTOA_BUF_SIZE
);
803 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
808 *--p
= '0' + (n
& 7);
816 /* Convert unsigned binary to ascii. */
819 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
823 assert (len
>= GFC_BTOA_BUF_SIZE
);
828 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
833 *--p
= '0' + (n
& 1);
840 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
841 to convert large reals with kind sizes that exceed the largest integer type
842 available on certain platforms. In these cases, byte by byte conversion is
843 performed. Endianess is taken into account. */
845 /* Conversion to binary. */
848 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
857 for (i
= 0; i
< len
; i
++)
861 /* Test for zero. Needed by write_boz later. */
865 for (j
= 0; j
< 8; j
++)
867 *q
++ = (c
& 128) ? '1' : '0';
875 const char *p
= s
+ len
- 1;
876 for (i
= 0; i
< len
; i
++)
880 /* Test for zero. Needed by write_boz later. */
884 for (j
= 0; j
< 8; j
++)
886 *q
++ = (c
& 128) ? '1' : '0';
898 /* Move past any leading zeros. */
899 while (*buffer
== '0')
906 /* Conversion to octal. */
909 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
915 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
921 const char *p
= s
+ len
- 1;
925 /* Test for zero. Needed by write_boz later. */
929 for (j
= 0; j
< 3 && i
< len
; j
++)
931 octet
|= (c
& 1) << j
;
950 /* Test for zero. Needed by write_boz later. */
954 for (j
= 0; j
< 3 && i
< len
; j
++)
956 octet
|= (c
& 1) << j
;
973 /* Move past any leading zeros. */
980 /* Conversion to hexidecimal. */
983 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
985 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
986 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
997 for (i
= 0; i
< len
; i
++)
999 /* Test for zero. Needed by write_boz later. */
1003 h
= (*p
>> 4) & 0x0F;
1011 const char *p
= s
+ len
- 1;
1012 for (i
= 0; i
< len
; i
++)
1014 /* Test for zero. Needed by write_boz later. */
1018 h
= (*p
>> 4) & 0x0F;
1030 /* Move past any leading zeros. */
1031 while (*buffer
== '0')
1037 /* gfc_itoa()-- Integer to decimal conversion.
1038 The itoa function is a widespread non-standard extension to standard
1039 C, often declared in <stdlib.h>. Even though the itoa defined here
1040 is a static function we take care not to conflict with any prior
1041 non-static declaration. Hence the 'gfc_' prefix, which is normally
1042 reserved for functions with external linkage. */
1045 gfc_itoa (GFC_INTEGER_LARGEST n
, char *buffer
, size_t len
)
1049 GFC_UINTEGER_LARGEST t
;
1051 assert (len
>= GFC_ITOA_BUF_SIZE
);
1061 t
= -n
; /*must use unsigned to protect from overflow*/
1064 p
= buffer
+ GFC_ITOA_BUF_SIZE
- 1;
1069 *--p
= '0' + (t
% 10);
1080 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1082 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1087 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1090 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1091 GFC_UINTEGER_LARGEST n
= 0;
1093 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1095 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1096 write_boz (dtp
, f
, p
, n
);
1100 n
= extract_uint (source
, len
);
1101 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1102 write_boz (dtp
, f
, p
, n
);
1108 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1111 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1112 GFC_UINTEGER_LARGEST n
= 0;
1114 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1116 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1117 write_boz (dtp
, f
, p
, n
);
1121 n
= extract_uint (source
, len
);
1122 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1123 write_boz (dtp
, f
, p
, n
);
1128 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1131 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1132 GFC_UINTEGER_LARGEST n
= 0;
1134 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1136 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1137 write_boz (dtp
, f
, p
, n
);
1141 n
= extract_uint (source
, len
);
1142 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1143 write_boz (dtp
, f
, p
, n
);
1149 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1151 write_float (dtp
, f
, p
, len
, 0);
1156 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1158 write_float (dtp
, f
, p
, len
, 0);
1163 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1165 write_float (dtp
, f
, p
, len
, 0);
1170 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1172 write_float (dtp
, f
, p
, len
, 0);
1177 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1179 write_float (dtp
, f
, p
, len
, 0);
1183 /* Take care of the X/TR descriptor. */
1186 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1190 p
= write_block (dtp
, len
);
1193 if (nspaces
> 0 && len
- nspaces
>= 0)
1195 if (unlikely (is_char4_unit (dtp
)))
1197 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1198 memset4 (&p4
[len
- nspaces
], ' ', nspaces
);
1201 memset (&p
[len
- nspaces
], ' ', nspaces
);
1206 /* List-directed writing. */
1209 /* Write a single character to the output. Returns nonzero if
1210 something goes wrong. */
1213 write_char (st_parameter_dt
*dtp
, int c
)
1217 p
= write_block (dtp
, 1);
1220 if (unlikely (is_char4_unit (dtp
)))
1222 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1233 /* Write a list-directed logical value. */
1236 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1238 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1242 /* Write a list-directed integer value. */
1245 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1251 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1253 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1278 digits
= strlen (q
);
1282 p
= write_block (dtp
, width
);
1286 if (unlikely (is_char4_unit (dtp
)))
1288 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1289 if (dtp
->u
.p
.no_leading_blank
)
1291 memcpy4 (p4
, q
, digits
);
1292 memset4 (p4
+ digits
, ' ', width
- digits
);
1296 memset4 (p4
, ' ', width
- digits
);
1297 memcpy4 (p4
+ width
- digits
, q
, digits
);
1302 if (dtp
->u
.p
.no_leading_blank
)
1304 memcpy (p
, q
, digits
);
1305 memset (p
+ digits
, ' ', width
- digits
);
1309 memset (p
, ' ', width
- digits
);
1310 memcpy (p
+ width
- digits
, q
, digits
);
1315 /* Write a list-directed string. We have to worry about delimiting
1316 the strings if the file has been opened in that mode. */
1319 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
1324 switch (dtp
->u
.p
.current_unit
->delim_status
)
1326 case DELIM_APOSTROPHE
:
1345 for (i
= 0; i
< length
; i
++)
1350 p
= write_block (dtp
, length
+ extra
);
1354 if (unlikely (is_char4_unit (dtp
)))
1356 gfc_char4_t d4
= (gfc_char4_t
) d
;
1357 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1360 memcpy4 (p4
, source
, length
);
1365 for (i
= 0; i
< length
; i
++)
1367 *p4
++ = (gfc_char4_t
) source
[i
];
1378 memcpy (p
, source
, length
);
1383 for (i
= 0; i
< length
; i
++)
1397 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1398 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1400 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1404 p
= write_block (dtp
, 1);
1407 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1408 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1410 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1412 p
= write_block (dtp
, 1);
1419 /* Set an fnode to default format. */
1422 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1448 internal_error (&dtp
->common
, "bad real kind");
1453 /* Output a real number with default format. To guarantee that a
1454 binary -> decimal -> binary roundtrip conversion recovers the
1455 original value, IEEE 754-2008 requires 9, 17, 21 and 36 significant
1456 digits for REAL kinds 4, 8, 10, and 16, respectively. Thus, we use
1457 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4 for
1458 REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
1459 Fortran standard requires outputting an extra digit when the scale
1460 factor is 1 and when the magnitude of the value is such that E
1461 editing is used. However, gfortran compensates for this, and thus
1462 for list formatted the same number of significant digits is
1463 generated both when using F and E editing. */
1466 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1469 int org_scale
= dtp
->u
.p
.scale_factor
;
1470 dtp
->u
.p
.scale_factor
= 1;
1471 set_fnode_default (dtp
, &f
, length
);
1472 write_float (dtp
, &f
, source
, length
, 1);
1473 dtp
->u
.p
.scale_factor
= org_scale
;
1476 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
1477 compensate for the extra digit. */
1480 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1484 set_fnode_default (dtp
, &f
, length
);
1488 /* Compensate for extra digits when using scale factor, d is not
1489 specified, and the magnitude is such that E editing is used. */
1490 if (dtp
->u
.p
.scale_factor
> 0 && d
== 0)
1494 dtp
->u
.p
.g0_no_blanks
= 1;
1495 write_float (dtp
, &f
, source
, length
, comp_d
);
1496 dtp
->u
.p
.g0_no_blanks
= 0;
1501 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1504 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1506 if (write_char (dtp
, '('))
1508 write_real (dtp
, source
, kind
);
1510 if (write_char (dtp
, semi_comma
))
1512 write_real (dtp
, source
+ size
/ 2, kind
);
1514 write_char (dtp
, ')');
1518 /* Write the separator between items. */
1521 write_separator (st_parameter_dt
*dtp
)
1525 p
= write_block (dtp
, options
.separator_len
);
1528 if (unlikely (is_char4_unit (dtp
)))
1530 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1531 memcpy4 (p4
, options
.separator
, options
.separator_len
);
1534 memcpy (p
, options
.separator
, options
.separator_len
);
1538 /* Write an item with list formatting.
1539 TODO: handle skipping to the next record correctly, particularly
1543 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1546 if (dtp
->u
.p
.current_unit
== NULL
)
1549 if (dtp
->u
.p
.first_item
)
1551 dtp
->u
.p
.first_item
= 0;
1552 write_char (dtp
, ' ');
1556 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1557 dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
)
1558 write_separator (dtp
);
1564 write_integer (dtp
, p
, kind
);
1567 write_logical (dtp
, p
, kind
);
1570 write_character (dtp
, p
, kind
, size
);
1573 write_real (dtp
, p
, kind
);
1576 write_complex (dtp
, p
, kind
, size
);
1579 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1582 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1587 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1588 size_t size
, size_t nelems
)
1592 size_t stride
= type
== BT_CHARACTER
?
1593 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1597 /* Big loop over all the elements. */
1598 for (elem
= 0; elem
< nelems
; elem
++)
1600 dtp
->u
.p
.item_count
++;
1601 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1607 nml_write_obj writes a namelist object to the output stream. It is called
1608 recursively for derived type components:
1609 obj = is the namelist_info for the current object.
1610 offset = the offset relative to the address held by the object for
1611 derived type arrays.
1612 base = is the namelist_info of the derived type, when obj is a
1614 base_name = the full name for a derived type, including qualifiers
1616 The returned value is a pointer to the object beyond the last one
1617 accessed, including nested derived types. Notice that the namelist is
1618 a linear linked list of objects, including derived types and their
1619 components. A tree, of sorts, is implied by the compound names of
1620 the derived type components and this is how this function recurses through
1623 /* A generous estimate of the number of characters needed to print
1624 repeat counts and indices, including commas, asterices and brackets. */
1626 #define NML_DIGITS 20
1629 namelist_write_newline (st_parameter_dt
*dtp
)
1631 if (!is_internal_unit (dtp
))
1634 write_character (dtp
, "\r\n", 1, 2);
1636 write_character (dtp
, "\n", 1, 1);
1641 if (is_array_io (dtp
))
1646 int length
= dtp
->u
.p
.current_unit
->bytes_left
;
1648 p
= write_block (dtp
, length
);
1652 if (unlikely (is_char4_unit (dtp
)))
1654 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1655 memset4 (p4
, ' ', length
);
1658 memset (p
, ' ', length
);
1660 /* Now that the current record has been padded out,
1661 determine where the next record in the array is. */
1662 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1665 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1668 /* Now seek to this record */
1669 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1671 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1673 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1677 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1681 write_character (dtp
, " ", 1, 1);
1685 static namelist_info
*
1686 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1687 namelist_info
* base
, char * base_name
)
1693 index_type obj_size
;
1697 index_type elem_ctr
;
1698 size_t obj_name_len
;
1703 size_t ext_name_len
;
1704 char rep_buff
[NML_DIGITS
];
1705 namelist_info
* cmp
;
1706 namelist_info
* retval
= obj
->next
;
1707 size_t base_name_len
;
1708 size_t base_var_name_len
;
1710 unit_delim tmp_delim
;
1712 /* Set the character to be used to separate values
1713 to a comma or semi-colon. */
1716 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1718 /* Write namelist variable names in upper case. If a derived type,
1719 nothing is output. If a component, base and base_name are set. */
1721 if (obj
->type
!= BT_DERIVED
)
1723 namelist_write_newline (dtp
);
1724 write_character (dtp
, " ", 1, 1);
1729 len
= strlen (base
->var_name
);
1730 base_name_len
= strlen (base_name
);
1731 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
1733 cup
= toupper ((int) base_name
[dim_i
]);
1734 write_character (dtp
, &cup
, 1, 1);
1737 clen
= strlen (obj
->var_name
);
1738 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
1740 cup
= toupper ((int) obj
->var_name
[dim_i
]);
1741 write_character (dtp
, &cup
, 1, 1);
1743 write_character (dtp
, "=", 1, 1);
1746 /* Counts the number of data output on a line, including names. */
1756 obj_size
= size_from_real_kind (len
);
1760 obj_size
= size_from_complex_kind (len
);
1764 obj_size
= obj
->string_length
;
1772 obj_size
= obj
->size
;
1774 /* Set the index vector and count the number of elements. */
1777 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1779 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
1780 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
1783 /* Main loop to output the data held in the object. */
1786 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1789 /* Build the pointer to the data value. The offset is passed by
1790 recursive calls to this function for arrays of derived types.
1791 Is NULL otherwise. */
1793 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1796 /* Check for repeat counts of intrinsic types. */
1798 if ((elem_ctr
< (nelem
- 1)) &&
1799 (obj
->type
!= BT_DERIVED
) &&
1800 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1805 /* Execute a repeated output. Note the flag no_leading_blank that
1806 is used in the functions used to output the intrinsic types. */
1812 snprintf(rep_buff
, NML_DIGITS
, " %d*", rep_ctr
);
1813 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1814 dtp
->u
.p
.no_leading_blank
= 1;
1818 /* Output the data, if an intrinsic type, or recurse into this
1819 routine to treat derived types. */
1825 write_integer (dtp
, p
, len
);
1829 write_logical (dtp
, p
, len
);
1833 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1834 if (dtp
->u
.p
.nml_delim
== '"')
1835 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1836 if (dtp
->u
.p
.nml_delim
== '\'')
1837 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1838 write_character (dtp
, p
, 1, obj
->string_length
);
1839 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1843 write_real (dtp
, p
, len
);
1847 dtp
->u
.p
.no_leading_blank
= 0;
1849 write_complex (dtp
, p
, len
, obj_size
);
1854 /* To treat a derived type, we need to build two strings:
1855 ext_name = the name, including qualifiers that prepends
1856 component names in the output - passed to
1858 obj_name = the derived type name with no qualifiers but %
1859 appended. This is used to identify the
1862 /* First ext_name => get length of all possible components */
1864 base_name_len
= base_name
? strlen (base_name
) : 0;
1865 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1866 ext_name_len
= base_name_len
+ base_var_name_len
1867 + strlen (obj
->var_name
) + obj
->var_rank
* NML_DIGITS
+ 1;
1868 ext_name
= (char*)xmalloc (ext_name_len
);
1870 memcpy (ext_name
, base_name
, base_name_len
);
1871 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1872 memcpy (ext_name
+ base_name_len
,
1873 obj
->var_name
+ base_var_name_len
, clen
);
1875 /* Append the qualifier. */
1877 tot_len
= base_name_len
+ clen
;
1878 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1882 ext_name
[tot_len
] = '(';
1885 snprintf (ext_name
+ tot_len
, ext_name_len
- tot_len
, "%d",
1886 (int) obj
->ls
[dim_i
].idx
);
1887 tot_len
+= strlen (ext_name
+ tot_len
);
1888 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1892 ext_name
[tot_len
] = '\0';
1896 obj_name_len
= strlen (obj
->var_name
) + 1;
1897 obj_name
= xmalloc (obj_name_len
+1);
1898 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1899 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1901 /* Now loop over the components. Update the component pointer
1902 with the return value from nml_write_obj => this loop jumps
1903 past nested derived types. */
1905 for (cmp
= obj
->next
;
1906 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1909 retval
= nml_write_obj (dtp
, cmp
,
1910 (index_type
)(p
- obj
->mem_pos
),
1919 internal_error (&dtp
->common
, "Bad type for namelist write");
1922 /* Reset the leading blank suppression, write a comma (or semi-colon)
1923 and, if 5 values have been output, write a newline and advance
1924 to column 2. Reset the repeat counter. */
1926 dtp
->u
.p
.no_leading_blank
= 0;
1927 write_character (dtp
, &semi_comma
, 1, 1);
1931 namelist_write_newline (dtp
);
1932 write_character (dtp
, " ", 1, 1);
1937 /* Cycle through and increment the index vector. */
1942 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
1944 obj
->ls
[dim_i
].idx
+= nml_carry
;
1946 if (obj
->ls
[dim_i
].idx
> GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
1948 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
1954 /* Return a pointer beyond the furthest object accessed. */
1960 /* This is the entry function for namelist writes. It outputs the name
1961 of the namelist and iterates through the namelist by calls to
1962 nml_write_obj. The call below has dummys in the arguments used in
1963 the treatment of derived types. */
1966 namelist_write (st_parameter_dt
*dtp
)
1968 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1970 index_type dummy_offset
= 0;
1972 char * dummy_name
= NULL
;
1973 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1975 /* Set the delimiter for namelist output. */
1976 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1978 dtp
->u
.p
.nml_delim
= tmp_delim
== DELIM_APOSTROPHE
? '\'' : '"';
1980 /* Temporarily disable namelist delimters. */
1981 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1983 write_character (dtp
, "&", 1, 1);
1985 /* Write namelist name in upper case - f95 std. */
1986 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1988 c
= toupper ((int) dtp
->namelist_name
[i
]);
1989 write_character (dtp
, &c
, 1 ,1);
1992 if (dtp
->u
.p
.ionml
!= NULL
)
1994 t1
= dtp
->u
.p
.ionml
;
1998 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
2002 namelist_write_newline (dtp
);
2003 write_character (dtp
, " /", 1, 2);
2004 /* Restore the original delimiter. */
2005 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;