1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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 (void *p
, int offs
, uchar c
, int k
)
48 gfc_char4_t
*q
= (gfc_char4_t
*) (p
+ offs
* 4);
49 for (j
= 0; j
< k
; j
++)
54 memcpy4 (void *dest
, int offs
, const char *source
, int k
)
58 const char *p
= source
;
59 gfc_char4_t
*q
= (gfc_char4_t
*) (dest
+ offs
* 4);
60 for (j
= 0; j
< k
; j
++)
61 *q
++ = (gfc_char4_t
) *p
++;
64 /* This include contains the heart and soul of formatted floating point. */
65 #include "write_float.def"
67 /* Write out default char4. */
70 write_default_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
71 int src_len
, int w_len
)
78 /* Take care of preceding blanks. */
82 p
= write_block (dtp
, k
);
85 if (is_char4_unit (dtp
))
86 memset4 (p
, 0, ' ', k
);
91 /* Get ready to handle delimiters if needed. */
92 switch (dtp
->u
.p
.current_unit
->delim_status
)
94 case DELIM_APOSTROPHE
:
105 /* Now process the remaining characters, one at a time. */
106 for (j
= 0; j
< src_len
; j
++)
109 if (is_char4_unit (dtp
))
112 /* Handle delimiters if any. */
113 if (c
== d
&& d
!= ' ')
115 p
= write_block (dtp
, 2);
118 q
= (gfc_char4_t
*) p
;
123 p
= write_block (dtp
, 1);
126 q
= (gfc_char4_t
*) p
;
132 /* Handle delimiters if any. */
133 if (c
== d
&& d
!= ' ')
135 p
= write_block (dtp
, 2);
142 p
= write_block (dtp
, 1);
146 *p
= c
> 255 ? '?' : (uchar
) c
;
152 /* Write out UTF-8 converted from char4. */
155 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
156 int src_len
, int w_len
)
161 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
162 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
166 /* Take care of preceding blanks. */
170 p
= write_block (dtp
, k
);
176 /* Get ready to handle delimiters if needed. */
177 switch (dtp
->u
.p
.current_unit
->delim_status
)
179 case DELIM_APOSTROPHE
:
190 /* Now process the remaining characters, one at a time. */
191 for (j
= k
; j
< src_len
; j
++)
196 /* Handle the delimiters if any. */
197 if (c
== d
&& d
!= ' ')
199 p
= write_block (dtp
, 2);
206 p
= write_block (dtp
, 1);
214 /* Convert to UTF-8 sequence. */
220 *--q
= ((c
& 0x3F) | 0x80);
224 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
226 *--q
= (c
| masks
[nbytes
-1]);
228 p
= write_block (dtp
, nbytes
);
240 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
245 wlen
= f
->u
.string
.length
< 0
246 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
247 ? len
: f
->u
.string
.length
;
250 /* If this is formatted STREAM IO convert any embedded line feed characters
251 to CR_LF on systems that use that sequence for newlines. See F2003
252 Standard sections 10.6.3 and 9.9 for further information. */
253 if (is_stream_io (dtp
))
255 const char crlf
[] = "\r\n";
259 /* Write out any padding if needed. */
262 p
= write_block (dtp
, wlen
- len
);
265 memset (p
, ' ', wlen
- len
);
268 /* Scan the source string looking for '\n' and convert it if found. */
269 for (i
= 0; i
< wlen
; i
++)
271 if (source
[i
] == '\n')
273 /* Write out the previously scanned characters in the string. */
276 p
= write_block (dtp
, bytes
);
279 memcpy (p
, &source
[q
], bytes
);
284 /* Write out the CR_LF sequence. */
286 p
= write_block (dtp
, 2);
295 /* Write out any remaining bytes if no LF was found. */
298 p
= write_block (dtp
, bytes
);
301 memcpy (p
, &source
[q
], bytes
);
307 p
= write_block (dtp
, wlen
);
311 if (unlikely (is_char4_unit (dtp
)))
314 memcpy4 (p
, 0, source
, wlen
);
317 memset4 (p
, 0, ' ', wlen
- len
);
318 memcpy4 (p
, wlen
- len
, source
, len
);
324 memcpy (p
, source
, wlen
);
327 memset (p
, ' ', wlen
- len
);
328 memcpy (p
+ wlen
- len
, source
, len
);
336 /* The primary difference between write_a_char4 and write_a is that we have to
337 deal with writing from the first byte of the 4-byte character and pay
338 attention to the most significant bytes. For ENCODING="default" write the
339 lowest significant byte. If the 3 most significant bytes contain
340 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
341 to the UTF-8 encoded string before writing out. */
344 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
349 wlen
= f
->u
.string
.length
< 0
350 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
351 ? len
: f
->u
.string
.length
;
353 q
= (gfc_char4_t
*) source
;
355 /* If this is formatted STREAM IO convert any embedded line feed characters
356 to CR_LF on systems that use that sequence for newlines. See F2003
357 Standard sections 10.6.3 and 9.9 for further information. */
358 if (is_stream_io (dtp
))
360 const gfc_char4_t crlf
[] = {0x000d,0x000a};
365 /* Write out any padding if needed. */
369 p
= write_block (dtp
, wlen
- len
);
372 memset (p
, ' ', wlen
- len
);
375 /* Scan the source string looking for '\n' and convert it if found. */
376 qq
= (gfc_char4_t
*) source
;
377 for (i
= 0; i
< wlen
; i
++)
381 /* Write out the previously scanned characters in the string. */
384 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
385 write_utf8_char4 (dtp
, q
, bytes
, 0);
387 write_default_char4 (dtp
, q
, bytes
, 0);
391 /* Write out the CR_LF sequence. */
392 write_default_char4 (dtp
, crlf
, 2, 0);
398 /* Write out any remaining bytes if no LF was found. */
401 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
402 write_utf8_char4 (dtp
, q
, bytes
, 0);
404 write_default_char4 (dtp
, q
, bytes
, 0);
410 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
411 write_utf8_char4 (dtp
, q
, len
, wlen
);
413 write_default_char4 (dtp
, q
, len
, wlen
);
420 static GFC_INTEGER_LARGEST
421 extract_int (const void *p
, int len
)
423 GFC_INTEGER_LARGEST i
= 0;
433 memcpy ((void *) &tmp
, p
, len
);
440 memcpy ((void *) &tmp
, p
, len
);
447 memcpy ((void *) &tmp
, p
, len
);
454 memcpy ((void *) &tmp
, p
, len
);
458 #ifdef HAVE_GFC_INTEGER_16
462 memcpy ((void *) &tmp
, p
, len
);
468 internal_error (NULL
, "bad integer kind");
474 static GFC_UINTEGER_LARGEST
475 extract_uint (const void *p
, int len
)
477 GFC_UINTEGER_LARGEST i
= 0;
487 memcpy ((void *) &tmp
, p
, len
);
488 i
= (GFC_UINTEGER_1
) tmp
;
494 memcpy ((void *) &tmp
, p
, len
);
495 i
= (GFC_UINTEGER_2
) tmp
;
501 memcpy ((void *) &tmp
, p
, len
);
502 i
= (GFC_UINTEGER_4
) tmp
;
508 memcpy ((void *) &tmp
, p
, len
);
509 i
= (GFC_UINTEGER_8
) tmp
;
512 #ifdef HAVE_GFC_INTEGER_16
516 GFC_INTEGER_16 tmp
= 0;
517 memcpy ((void *) &tmp
, p
, len
);
518 i
= (GFC_UINTEGER_16
) tmp
;
523 internal_error (NULL
, "bad integer kind");
531 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
535 GFC_INTEGER_LARGEST n
;
537 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
539 p
= write_block (dtp
, wlen
);
543 n
= extract_int (source
, len
);
545 if (unlikely (is_char4_unit (dtp
)))
547 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
548 memset4 (p
, 0, ' ', wlen
-1);
549 p4
[wlen
- 1] = (n
) ? 'T' : 'F';
553 memset (p
, ' ', wlen
-1);
554 p
[wlen
- 1] = (n
) ? 'T' : 'F';
559 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
561 int w
, m
, digits
, nzero
, nblank
;
569 if (m
== 0 && n
== 0)
574 p
= write_block (dtp
, w
);
577 if (unlikely (is_char4_unit (dtp
)))
578 memset4 (p
, 0, ' ', w
);
586 /* Select a width if none was specified. The idea here is to always
590 w
= ((digits
< m
) ? m
: digits
);
592 p
= write_block (dtp
, w
);
600 /* See if things will work. */
602 nblank
= w
- (nzero
+ digits
);
604 if (unlikely (is_char4_unit (dtp
)))
606 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
609 memset4 (p4
, 0, '*', w
);
613 if (!dtp
->u
.p
.no_leading_blank
)
615 memset4 (p4
, 0, ' ', nblank
);
617 memset4 (p4
, 0, '0', nzero
);
619 memcpy4 (p4
, 0, q
, digits
);
623 memset4 (p4
, 0, '0', nzero
);
625 memcpy4 (p4
, 0, q
, digits
);
627 memset4 (p4
, 0, ' ', nblank
);
628 dtp
->u
.p
.no_leading_blank
= 0;
639 if (!dtp
->u
.p
.no_leading_blank
)
641 memset (p
, ' ', nblank
);
643 memset (p
, '0', nzero
);
645 memcpy (p
, q
, digits
);
649 memset (p
, '0', nzero
);
651 memcpy (p
, q
, digits
);
653 memset (p
, ' ', nblank
);
654 dtp
->u
.p
.no_leading_blank
= 0;
662 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
664 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
666 GFC_INTEGER_LARGEST n
= 0;
667 int w
, m
, digits
, nsign
, nzero
, nblank
;
671 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
674 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
676 n
= extract_int (source
, len
);
679 if (m
== 0 && n
== 0)
684 p
= write_block (dtp
, w
);
687 if (unlikely (is_char4_unit (dtp
)))
688 memset4 (p
, 0, ' ', w
);
694 sign
= calculate_sign (dtp
, n
< 0);
697 nsign
= sign
== S_NONE
? 0 : 1;
699 /* conv calls itoa which sets the negative sign needed
700 by write_integer. The sign '+' or '-' is set below based on sign
701 calculated above, so we just point past the sign in the string
702 before proceeding to avoid double signs in corner cases.
704 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
710 /* Select a width if none was specified. The idea here is to always
714 w
= ((digits
< m
) ? m
: digits
) + nsign
;
716 p
= write_block (dtp
, w
);
724 /* See if things will work. */
726 nblank
= w
- (nsign
+ nzero
+ digits
);
728 if (unlikely (is_char4_unit (dtp
)))
730 gfc_char4_t
* p4
= (gfc_char4_t
*) p
;
733 memset4 (p4
, 0, '*', w
);
737 memset4 (p4
, 0, ' ', nblank
);
752 memset4 (p4
, 0, '0', nzero
);
755 memcpy4 (p4
, 0, q
, digits
);
765 memset (p
, ' ', nblank
);
780 memset (p
, '0', nzero
);
783 memcpy (p
, q
, digits
);
790 /* Convert unsigned octal to ascii. */
793 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
797 assert (len
>= GFC_OTOA_BUF_SIZE
);
802 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
807 *--p
= '0' + (n
& 7);
815 /* Convert unsigned binary to ascii. */
818 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
822 assert (len
>= GFC_BTOA_BUF_SIZE
);
827 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
832 *--p
= '0' + (n
& 1);
839 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
840 to convert large reals with kind sizes that exceed the largest integer type
841 available on certain platforms. In these cases, byte by byte conversion is
842 performed. Endianess is taken into account. */
844 /* Conversion to binary. */
847 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
856 for (i
= 0; i
< len
; i
++)
860 /* Test for zero. Needed by write_boz later. */
864 for (j
= 0; j
< 8; j
++)
866 *q
++ = (c
& 128) ? '1' : '0';
874 const char *p
= s
+ len
- 1;
875 for (i
= 0; i
< len
; i
++)
879 /* Test for zero. Needed by write_boz later. */
883 for (j
= 0; j
< 8; j
++)
885 *q
++ = (c
& 128) ? '1' : '0';
897 /* Move past any leading zeros. */
898 while (*buffer
== '0')
905 /* Conversion to octal. */
908 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
914 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
920 const char *p
= s
+ len
- 1;
924 /* Test for zero. Needed by write_boz later. */
928 for (j
= 0; j
< 3 && i
< len
; j
++)
930 octet
|= (c
& 1) << j
;
949 /* Test for zero. Needed by write_boz later. */
953 for (j
= 0; j
< 3 && i
< len
; j
++)
955 octet
|= (c
& 1) << j
;
972 /* Move past any leading zeros. */
979 /* Conversion to hexidecimal. */
982 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
984 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
985 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
996 for (i
= 0; i
< len
; i
++)
998 /* Test for zero. Needed by write_boz later. */
1002 h
= (*p
>> 4) & 0x0F;
1010 const char *p
= s
+ len
- 1;
1011 for (i
= 0; i
< len
; i
++)
1013 /* Test for zero. Needed by write_boz later. */
1017 h
= (*p
>> 4) & 0x0F;
1029 /* Move past any leading zeros. */
1030 while (*buffer
== '0')
1036 /* gfc_itoa()-- Integer to decimal conversion.
1037 The itoa function is a widespread non-standard extension to standard
1038 C, often declared in <stdlib.h>. Even though the itoa defined here
1039 is a static function we take care not to conflict with any prior
1040 non-static declaration. Hence the 'gfc_' prefix, which is normally
1041 reserved for functions with external linkage. */
1044 gfc_itoa (GFC_INTEGER_LARGEST n
, char *buffer
, size_t len
)
1048 GFC_UINTEGER_LARGEST t
;
1050 assert (len
>= GFC_ITOA_BUF_SIZE
);
1060 t
= -n
; /*must use unsigned to protect from overflow*/
1063 p
= buffer
+ GFC_ITOA_BUF_SIZE
- 1;
1068 *--p
= '0' + (t
% 10);
1079 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1081 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
1086 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1089 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
1090 GFC_UINTEGER_LARGEST n
= 0;
1092 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1094 p
= btoa_big (source
, itoa_buf
, len
, &n
);
1095 write_boz (dtp
, f
, p
, n
);
1099 n
= extract_uint (source
, len
);
1100 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
1101 write_boz (dtp
, f
, p
, n
);
1107 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1110 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
1111 GFC_UINTEGER_LARGEST n
= 0;
1113 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1115 p
= otoa_big (source
, itoa_buf
, len
, &n
);
1116 write_boz (dtp
, f
, p
, n
);
1120 n
= extract_uint (source
, len
);
1121 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
1122 write_boz (dtp
, f
, p
, n
);
1127 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
1130 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
1131 GFC_UINTEGER_LARGEST n
= 0;
1133 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1135 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1136 write_boz (dtp
, f
, p
, n
);
1140 n
= extract_uint (source
, len
);
1141 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1142 write_boz (dtp
, f
, p
, n
);
1148 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1150 write_float (dtp
, f
, p
, len
);
1155 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1157 write_float (dtp
, f
, p
, len
);
1162 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1164 write_float (dtp
, f
, p
, len
);
1169 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1171 write_float (dtp
, f
, p
, len
);
1176 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1178 write_float (dtp
, f
, p
, len
);
1182 /* Take care of the X/TR descriptor. */
1185 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1189 p
= write_block (dtp
, len
);
1192 if (nspaces
> 0 && len
- nspaces
>= 0)
1194 if (unlikely (is_char4_unit (dtp
)))
1195 memset4 (p
, len
- nspaces
, ' ', nspaces
);
1197 memset (&p
[len
- nspaces
], ' ', nspaces
);
1202 /* List-directed writing. */
1205 /* Write a single character to the output. Returns nonzero if
1206 something goes wrong. */
1209 write_char (st_parameter_dt
*dtp
, char c
)
1213 p
= write_block (dtp
, 1);
1223 /* Write a list-directed logical value. */
1226 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1228 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1232 /* Write a list-directed integer value. */
1235 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1241 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1243 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1268 digits
= strlen (q
);
1272 p
= write_block (dtp
, width
);
1276 if (unlikely (is_char4_unit (dtp
)))
1278 if (dtp
->u
.p
.no_leading_blank
)
1280 memcpy4 (p
, 0, q
, digits
);
1281 memset4 (p
, digits
, ' ', width
- digits
);
1285 memset4 (p
, 0, ' ', width
- digits
);
1286 memcpy4 (p
, width
- digits
, q
, digits
);
1291 if (dtp
->u
.p
.no_leading_blank
)
1293 memcpy (p
, q
, digits
);
1294 memset (p
+ digits
, ' ', width
- digits
);
1298 memset (p
, ' ', width
- digits
);
1299 memcpy (p
+ width
- digits
, q
, digits
);
1304 /* Write a list-directed string. We have to worry about delimiting
1305 the strings if the file has been opened in that mode. */
1308 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
1313 switch (dtp
->u
.p
.current_unit
->delim_status
)
1315 case DELIM_APOSTROPHE
:
1334 for (i
= 0; i
< length
; i
++)
1339 p
= write_block (dtp
, length
+ extra
);
1343 if (unlikely (is_char4_unit (dtp
)))
1345 gfc_char4_t d4
= (gfc_char4_t
) d
;
1346 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
1349 memcpy4 (p4
, 0, source
, length
);
1354 for (i
= 0; i
< length
; i
++)
1356 *p4
++ = (gfc_char4_t
) source
[i
];
1367 memcpy (p
, source
, length
);
1372 for (i
= 0; i
< length
; i
++)
1386 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1387 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1389 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1393 p
= write_block (dtp
, 1);
1396 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1397 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1399 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1401 p
= write_block (dtp
, 1);
1408 /* Set an fnode to default format. */
1411 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1437 internal_error (&dtp
->common
, "bad real kind");
1441 /* Output a real number with default format.
1442 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1443 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
1446 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1449 int org_scale
= dtp
->u
.p
.scale_factor
;
1450 dtp
->u
.p
.scale_factor
= 1;
1451 set_fnode_default (dtp
, &f
, length
);
1452 write_float (dtp
, &f
, source
, length
);
1453 dtp
->u
.p
.scale_factor
= org_scale
;
1458 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1461 set_fnode_default (dtp
, &f
, length
);
1464 dtp
->u
.p
.g0_no_blanks
= 1;
1465 write_float (dtp
, &f
, source
, length
);
1466 dtp
->u
.p
.g0_no_blanks
= 0;
1471 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1474 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1476 if (write_char (dtp
, '('))
1478 write_real (dtp
, source
, kind
);
1480 if (write_char (dtp
, semi_comma
))
1482 write_real (dtp
, source
+ size
/ 2, kind
);
1484 write_char (dtp
, ')');
1488 /* Write the separator between items. */
1491 write_separator (st_parameter_dt
*dtp
)
1495 p
= write_block (dtp
, options
.separator_len
);
1499 memcpy (p
, options
.separator
, options
.separator_len
);
1503 /* Write an item with list formatting.
1504 TODO: handle skipping to the next record correctly, particularly
1508 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1511 if (dtp
->u
.p
.current_unit
== NULL
)
1514 if (dtp
->u
.p
.first_item
)
1516 dtp
->u
.p
.first_item
= 0;
1517 write_char (dtp
, ' ');
1521 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1522 dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
)
1523 write_separator (dtp
);
1529 write_integer (dtp
, p
, kind
);
1532 write_logical (dtp
, p
, kind
);
1535 write_character (dtp
, p
, kind
, size
);
1538 write_real (dtp
, p
, kind
);
1541 write_complex (dtp
, p
, kind
, size
);
1544 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1547 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1552 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1553 size_t size
, size_t nelems
)
1557 size_t stride
= type
== BT_CHARACTER
?
1558 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1562 /* Big loop over all the elements. */
1563 for (elem
= 0; elem
< nelems
; elem
++)
1565 dtp
->u
.p
.item_count
++;
1566 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1572 nml_write_obj writes a namelist object to the output stream. It is called
1573 recursively for derived type components:
1574 obj = is the namelist_info for the current object.
1575 offset = the offset relative to the address held by the object for
1576 derived type arrays.
1577 base = is the namelist_info of the derived type, when obj is a
1579 base_name = the full name for a derived type, including qualifiers
1581 The returned value is a pointer to the object beyond the last one
1582 accessed, including nested derived types. Notice that the namelist is
1583 a linear linked list of objects, including derived types and their
1584 components. A tree, of sorts, is implied by the compound names of
1585 the derived type components and this is how this function recurses through
1588 /* A generous estimate of the number of characters needed to print
1589 repeat counts and indices, including commas, asterices and brackets. */
1591 #define NML_DIGITS 20
1594 namelist_write_newline (st_parameter_dt
*dtp
)
1596 if (!is_internal_unit (dtp
))
1599 write_character (dtp
, "\r\n", 1, 2);
1601 write_character (dtp
, "\n", 1, 1);
1606 if (is_array_io (dtp
))
1611 /* Now that the current record has been padded out,
1612 determine where the next record in the array is. */
1613 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1616 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1619 /* Now seek to this record */
1620 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1622 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1624 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1628 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1632 write_character (dtp
, " ", 1, 1);
1636 static namelist_info
*
1637 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1638 namelist_info
* base
, char * base_name
)
1644 index_type obj_size
;
1648 index_type elem_ctr
;
1649 size_t obj_name_len
;
1654 char rep_buff
[NML_DIGITS
];
1655 namelist_info
* cmp
;
1656 namelist_info
* retval
= obj
->next
;
1657 size_t base_name_len
;
1658 size_t base_var_name_len
;
1660 unit_delim tmp_delim
;
1662 /* Set the character to be used to separate values
1663 to a comma or semi-colon. */
1666 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1668 /* Write namelist variable names in upper case. If a derived type,
1669 nothing is output. If a component, base and base_name are set. */
1671 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1673 namelist_write_newline (dtp
);
1674 write_character (dtp
, " ", 1, 1);
1679 len
= strlen (base
->var_name
);
1680 base_name_len
= strlen (base_name
);
1681 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
1683 cup
= toupper (base_name
[dim_i
]);
1684 write_character (dtp
, &cup
, 1, 1);
1687 clen
= strlen (obj
->var_name
);
1688 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
1690 cup
= toupper (obj
->var_name
[dim_i
]);
1691 write_character (dtp
, &cup
, 1, 1);
1693 write_character (dtp
, "=", 1, 1);
1696 /* Counts the number of data output on a line, including names. */
1705 case GFC_DTYPE_REAL
:
1706 obj_size
= size_from_real_kind (len
);
1709 case GFC_DTYPE_COMPLEX
:
1710 obj_size
= size_from_complex_kind (len
);
1713 case GFC_DTYPE_CHARACTER
:
1714 obj_size
= obj
->string_length
;
1722 obj_size
= obj
->size
;
1724 /* Set the index vector and count the number of elements. */
1727 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1729 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
1730 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
1733 /* Main loop to output the data held in the object. */
1736 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1739 /* Build the pointer to the data value. The offset is passed by
1740 recursive calls to this function for arrays of derived types.
1741 Is NULL otherwise. */
1743 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1746 /* Check for repeat counts of intrinsic types. */
1748 if ((elem_ctr
< (nelem
- 1)) &&
1749 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1750 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1755 /* Execute a repeated output. Note the flag no_leading_blank that
1756 is used in the functions used to output the intrinsic types. */
1762 sprintf(rep_buff
, " %d*", rep_ctr
);
1763 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1764 dtp
->u
.p
.no_leading_blank
= 1;
1768 /* Output the data, if an intrinsic type, or recurse into this
1769 routine to treat derived types. */
1774 case GFC_DTYPE_INTEGER
:
1775 write_integer (dtp
, p
, len
);
1778 case GFC_DTYPE_LOGICAL
:
1779 write_logical (dtp
, p
, len
);
1782 case GFC_DTYPE_CHARACTER
:
1783 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1784 if (dtp
->u
.p
.nml_delim
== '"')
1785 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1786 if (dtp
->u
.p
.nml_delim
== '\'')
1787 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1788 write_character (dtp
, p
, 1, obj
->string_length
);
1789 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1792 case GFC_DTYPE_REAL
:
1793 write_real (dtp
, p
, len
);
1796 case GFC_DTYPE_COMPLEX
:
1797 dtp
->u
.p
.no_leading_blank
= 0;
1799 write_complex (dtp
, p
, len
, obj_size
);
1802 case GFC_DTYPE_DERIVED
:
1804 /* To treat a derived type, we need to build two strings:
1805 ext_name = the name, including qualifiers that prepends
1806 component names in the output - passed to
1808 obj_name = the derived type name with no qualifiers but %
1809 appended. This is used to identify the
1812 /* First ext_name => get length of all possible components */
1814 base_name_len
= base_name
? strlen (base_name
) : 0;
1815 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1816 ext_name
= (char*)get_mem ( base_name_len
1818 + strlen (obj
->var_name
)
1819 + obj
->var_rank
* NML_DIGITS
1822 memcpy (ext_name
, base_name
, base_name_len
);
1823 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1824 memcpy (ext_name
+ base_name_len
,
1825 obj
->var_name
+ base_var_name_len
, clen
);
1827 /* Append the qualifier. */
1829 tot_len
= base_name_len
+ clen
;
1830 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1834 ext_name
[tot_len
] = '(';
1837 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1838 tot_len
+= strlen (ext_name
+ tot_len
);
1839 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1843 ext_name
[tot_len
] = '\0';
1847 obj_name_len
= strlen (obj
->var_name
) + 1;
1848 obj_name
= get_mem (obj_name_len
+1);
1849 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1850 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1852 /* Now loop over the components. Update the component pointer
1853 with the return value from nml_write_obj => this loop jumps
1854 past nested derived types. */
1856 for (cmp
= obj
->next
;
1857 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1860 retval
= nml_write_obj (dtp
, cmp
,
1861 (index_type
)(p
- obj
->mem_pos
),
1870 internal_error (&dtp
->common
, "Bad type for namelist write");
1873 /* Reset the leading blank suppression, write a comma (or semi-colon)
1874 and, if 5 values have been output, write a newline and advance
1875 to column 2. Reset the repeat counter. */
1877 dtp
->u
.p
.no_leading_blank
= 0;
1878 write_character (dtp
, &semi_comma
, 1, 1);
1882 namelist_write_newline (dtp
);
1883 write_character (dtp
, " ", 1, 1);
1888 /* Cycle through and increment the index vector. */
1893 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
1895 obj
->ls
[dim_i
].idx
+= nml_carry
;
1897 if (obj
->ls
[dim_i
].idx
> (ssize_t
) GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
1899 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
1905 /* Return a pointer beyond the furthest object accessed. */
1911 /* This is the entry function for namelist writes. It outputs the name
1912 of the namelist and iterates through the namelist by calls to
1913 nml_write_obj. The call below has dummys in the arguments used in
1914 the treatment of derived types. */
1917 namelist_write (st_parameter_dt
*dtp
)
1919 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1921 index_type dummy_offset
= 0;
1923 char * dummy_name
= NULL
;
1924 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1926 /* Set the delimiter for namelist output. */
1927 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1929 dtp
->u
.p
.nml_delim
= tmp_delim
== DELIM_APOSTROPHE
? '\'' : '"';
1931 /* Temporarily disable namelist delimters. */
1932 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1934 write_character (dtp
, "&", 1, 1);
1936 /* Write namelist name in upper case - f95 std. */
1937 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1939 c
= toupper (dtp
->namelist_name
[i
]);
1940 write_character (dtp
, &c
, 1 ,1);
1943 if (dtp
->u
.p
.ionml
!= NULL
)
1945 t1
= dtp
->u
.p
.ionml
;
1949 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1953 namelist_write_newline (dtp
);
1954 write_character (dtp
, " /", 1, 2);
1955 /* Restore the original delimiter. */
1956 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;