1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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 95 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 #include "write_float.def"
41 typedef unsigned char uchar
;
43 /* Write out default char4. */
46 write_default_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
47 int src_len
, int w_len
)
54 /* Take care of preceding blanks. */
58 p
= write_block (dtp
, k
);
64 /* Get ready to handle delimiters if needed. */
65 switch (dtp
->u
.p
.current_unit
->delim_status
)
67 case DELIM_APOSTROPHE
:
78 /* Now process the remaining characters, one at a time. */
79 for (j
= k
; j
< src_len
; j
++)
83 /* Handle delimiters if any. */
84 if (c
== d
&& d
!= ' ')
86 p
= write_block (dtp
, 2);
93 p
= write_block (dtp
, 1);
97 *p
= c
> 255 ? '?' : (uchar
) c
;
102 /* Write out UTF-8 converted from char4. */
105 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
106 int src_len
, int w_len
)
111 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
112 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
116 /* Take care of preceding blanks. */
120 p
= write_block (dtp
, k
);
126 /* Get ready to handle delimiters if needed. */
127 switch (dtp
->u
.p
.current_unit
->delim_status
)
129 case DELIM_APOSTROPHE
:
140 /* Now process the remaining characters, one at a time. */
141 for (j
= k
; j
< src_len
; j
++)
146 /* Handle the delimiters if any. */
147 if (c
== d
&& d
!= ' ')
149 p
= write_block (dtp
, 2);
156 p
= write_block (dtp
, 1);
164 /* Convert to UTF-8 sequence. */
170 *--q
= ((c
& 0x3F) | 0x80);
174 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
176 *--q
= (c
| masks
[nbytes
-1]);
178 p
= write_block (dtp
, nbytes
);
190 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
195 wlen
= f
->u
.string
.length
< 0
196 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
197 ? len
: f
->u
.string
.length
;
200 /* If this is formatted STREAM IO convert any embedded line feed characters
201 to CR_LF on systems that use that sequence for newlines. See F2003
202 Standard sections 10.6.3 and 9.9 for further information. */
203 if (is_stream_io (dtp
))
205 const char crlf
[] = "\r\n";
209 /* Write out any padding if needed. */
212 p
= write_block (dtp
, wlen
- len
);
215 memset (p
, ' ', wlen
- len
);
218 /* Scan the source string looking for '\n' and convert it if found. */
219 for (i
= 0; i
< wlen
; i
++)
221 if (source
[i
] == '\n')
223 /* Write out the previously scanned characters in the string. */
226 p
= write_block (dtp
, bytes
);
229 memcpy (p
, &source
[q
], bytes
);
234 /* Write out the CR_LF sequence. */
236 p
= write_block (dtp
, 2);
245 /* Write out any remaining bytes if no LF was found. */
248 p
= write_block (dtp
, bytes
);
251 memcpy (p
, &source
[q
], bytes
);
257 p
= write_block (dtp
, wlen
);
262 memcpy (p
, source
, wlen
);
265 memset (p
, ' ', wlen
- len
);
266 memcpy (p
+ wlen
- len
, source
, len
);
274 /* The primary difference between write_a_char4 and write_a is that we have to
275 deal with writing from the first byte of the 4-byte character and pay
276 attention to the most significant bytes. For ENCODING="default" write the
277 lowest significant byte. If the 3 most significant bytes contain
278 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
279 to the UTF-8 encoded string before writing out. */
282 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
287 wlen
= f
->u
.string
.length
< 0
288 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
289 ? len
: f
->u
.string
.length
;
291 q
= (gfc_char4_t
*) source
;
293 /* If this is formatted STREAM IO convert any embedded line feed characters
294 to CR_LF on systems that use that sequence for newlines. See F2003
295 Standard sections 10.6.3 and 9.9 for further information. */
296 if (is_stream_io (dtp
))
298 const gfc_char4_t crlf
[] = {0x000d,0x000a};
303 /* Write out any padding if needed. */
307 p
= write_block (dtp
, wlen
- len
);
310 memset (p
, ' ', wlen
- len
);
313 /* Scan the source string looking for '\n' and convert it if found. */
314 qq
= (gfc_char4_t
*) source
;
315 for (i
= 0; i
< wlen
; i
++)
319 /* Write out the previously scanned characters in the string. */
322 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
323 write_utf8_char4 (dtp
, q
, bytes
, 0);
325 write_default_char4 (dtp
, q
, bytes
, 0);
329 /* Write out the CR_LF sequence. */
330 write_default_char4 (dtp
, crlf
, 2, 0);
336 /* Write out any remaining bytes if no LF was found. */
339 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
340 write_utf8_char4 (dtp
, q
, bytes
, 0);
342 write_default_char4 (dtp
, q
, bytes
, 0);
348 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
349 write_utf8_char4 (dtp
, q
, len
, wlen
);
351 write_default_char4 (dtp
, q
, len
, wlen
);
358 static GFC_INTEGER_LARGEST
359 extract_int (const void *p
, int len
)
361 GFC_INTEGER_LARGEST i
= 0;
371 memcpy ((void *) &tmp
, p
, len
);
378 memcpy ((void *) &tmp
, p
, len
);
385 memcpy ((void *) &tmp
, p
, len
);
392 memcpy ((void *) &tmp
, p
, len
);
396 #ifdef HAVE_GFC_INTEGER_16
400 memcpy ((void *) &tmp
, p
, len
);
406 internal_error (NULL
, "bad integer kind");
412 static GFC_UINTEGER_LARGEST
413 extract_uint (const void *p
, int len
)
415 GFC_UINTEGER_LARGEST i
= 0;
425 memcpy ((void *) &tmp
, p
, len
);
426 i
= (GFC_UINTEGER_1
) tmp
;
432 memcpy ((void *) &tmp
, p
, len
);
433 i
= (GFC_UINTEGER_2
) tmp
;
439 memcpy ((void *) &tmp
, p
, len
);
440 i
= (GFC_UINTEGER_4
) tmp
;
446 memcpy ((void *) &tmp
, p
, len
);
447 i
= (GFC_UINTEGER_8
) tmp
;
450 #ifdef HAVE_GFC_INTEGER_16
454 GFC_INTEGER_16 tmp
= 0;
455 memcpy ((void *) &tmp
, p
, len
);
456 i
= (GFC_UINTEGER_16
) tmp
;
461 internal_error (NULL
, "bad integer kind");
469 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
473 GFC_INTEGER_LARGEST n
;
475 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
477 p
= write_block (dtp
, wlen
);
481 memset (p
, ' ', wlen
- 1);
482 n
= extract_int (source
, len
);
483 p
[wlen
- 1] = (n
) ? 'T' : 'F';
488 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
490 int w
, m
, digits
, nzero
, nblank
;
498 if (m
== 0 && n
== 0)
503 p
= write_block (dtp
, w
);
513 /* Select a width if none was specified. The idea here is to always
517 w
= ((digits
< m
) ? m
: digits
);
519 p
= write_block (dtp
, w
);
527 /* See if things will work. */
529 nblank
= w
- (nzero
+ digits
);
537 if (!dtp
->u
.p
.no_leading_blank
)
539 memset (p
, ' ', nblank
);
541 memset (p
, '0', nzero
);
543 memcpy (p
, q
, digits
);
547 memset (p
, '0', nzero
);
549 memcpy (p
, q
, digits
);
551 memset (p
, ' ', nblank
);
552 dtp
->u
.p
.no_leading_blank
= 0;
560 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
562 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
564 GFC_INTEGER_LARGEST n
= 0;
565 int w
, m
, digits
, nsign
, nzero
, nblank
;
569 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
572 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
574 n
= extract_int (source
, len
);
577 if (m
== 0 && n
== 0)
582 p
= write_block (dtp
, w
);
590 sign
= calculate_sign (dtp
, n
< 0);
593 nsign
= sign
== S_NONE
? 0 : 1;
595 /* conv calls itoa which sets the negative sign needed
596 by write_integer. The sign '+' or '-' is set below based on sign
597 calculated above, so we just point past the sign in the string
598 before proceeding to avoid double signs in corner cases.
600 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
606 /* Select a width if none was specified. The idea here is to always
610 w
= ((digits
< m
) ? m
: digits
) + nsign
;
612 p
= write_block (dtp
, w
);
620 /* See if things will work. */
622 nblank
= w
- (nsign
+ nzero
+ digits
);
630 memset (p
, ' ', nblank
);
645 memset (p
, '0', nzero
);
648 memcpy (p
, q
, digits
);
655 /* Convert unsigned octal to ascii. */
658 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
662 assert (len
>= GFC_OTOA_BUF_SIZE
);
667 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
672 *--p
= '0' + (n
& 7);
680 /* Convert unsigned binary to ascii. */
683 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
687 assert (len
>= GFC_BTOA_BUF_SIZE
);
692 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
697 *--p
= '0' + (n
& 1);
704 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
705 to convert large reals with kind sizes that exceed the largest integer type
706 available on certain platforms. In these cases, byte by byte conversion is
707 performed. Endianess is taken into account. */
709 /* Conversion to binary. */
712 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
721 for (i
= 0; i
< len
; i
++)
725 /* Test for zero. Needed by write_boz later. */
729 for (j
= 0; j
< 8; j
++)
731 *q
++ = (c
& 128) ? '1' : '0';
739 const char *p
= s
+ len
- 1;
740 for (i
= 0; i
< len
; i
++)
744 /* Test for zero. Needed by write_boz later. */
748 for (j
= 0; j
< 8; j
++)
750 *q
++ = (c
& 128) ? '1' : '0';
762 /* Move past any leading zeros. */
763 while (*buffer
== '0')
770 /* Conversion to octal. */
773 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
779 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
785 const char *p
= s
+ len
- 1;
789 /* Test for zero. Needed by write_boz later. */
793 for (j
= 0; j
< 3 && i
< len
; j
++)
795 octet
|= (c
& 1) << j
;
814 /* Test for zero. Needed by write_boz later. */
818 for (j
= 0; j
< 3 && i
< len
; j
++)
820 octet
|= (c
& 1) << j
;
837 /* Move past any leading zeros. */
844 /* Conversion to hexidecimal. */
847 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
849 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
850 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
861 for (i
= 0; i
< len
; i
++)
863 /* Test for zero. Needed by write_boz later. */
867 h
= (*p
>> 4) & 0x0F;
875 const char *p
= s
+ len
- 1;
876 for (i
= 0; i
< len
; i
++)
878 /* Test for zero. Needed by write_boz later. */
882 h
= (*p
>> 4) & 0x0F;
894 /* Move past any leading zeros. */
895 while (*buffer
== '0')
901 /* gfc_itoa()-- Integer to decimal conversion.
902 The itoa function is a widespread non-standard extension to standard
903 C, often declared in <stdlib.h>. Even though the itoa defined here
904 is a static function we take care not to conflict with any prior
905 non-static declaration. Hence the 'gfc_' prefix, which is normally
906 reserved for functions with external linkage. */
909 gfc_itoa (GFC_INTEGER_LARGEST n
, char *buffer
, size_t len
)
913 GFC_UINTEGER_LARGEST t
;
915 assert (len
>= GFC_ITOA_BUF_SIZE
);
925 t
= -n
; /*must use unsigned to protect from overflow*/
928 p
= buffer
+ GFC_ITOA_BUF_SIZE
- 1;
933 *--p
= '0' + (t
% 10);
944 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
946 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
951 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
954 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
955 GFC_UINTEGER_LARGEST n
= 0;
957 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
959 p
= btoa_big (source
, itoa_buf
, len
, &n
);
960 write_boz (dtp
, f
, p
, n
);
964 n
= extract_uint (source
, len
);
965 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
966 write_boz (dtp
, f
, p
, n
);
972 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
975 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
976 GFC_UINTEGER_LARGEST n
= 0;
978 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
980 p
= otoa_big (source
, itoa_buf
, len
, &n
);
981 write_boz (dtp
, f
, p
, n
);
985 n
= extract_uint (source
, len
);
986 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
987 write_boz (dtp
, f
, p
, n
);
992 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
995 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
996 GFC_UINTEGER_LARGEST n
= 0;
998 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
1000 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
1001 write_boz (dtp
, f
, p
, n
);
1005 n
= extract_uint (source
, len
);
1006 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1007 write_boz (dtp
, f
, p
, n
);
1013 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1015 write_float (dtp
, f
, p
, len
);
1020 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1022 write_float (dtp
, f
, p
, len
);
1027 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1029 write_float (dtp
, f
, p
, len
);
1034 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1036 write_float (dtp
, f
, p
, len
);
1041 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1043 write_float (dtp
, f
, p
, len
);
1047 /* Take care of the X/TR descriptor. */
1050 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1054 p
= write_block (dtp
, len
);
1057 if (nspaces
> 0 && len
- nspaces
>= 0)
1058 memset (&p
[len
- nspaces
], ' ', nspaces
);
1062 /* List-directed writing. */
1065 /* Write a single character to the output. Returns nonzero if
1066 something goes wrong. */
1069 write_char (st_parameter_dt
*dtp
, char c
)
1073 p
= write_block (dtp
, 1);
1083 /* Write a list-directed logical value. */
1086 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1088 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1092 /* Write a list-directed integer value. */
1095 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1101 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1103 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1128 digits
= strlen (q
);
1132 p
= write_block (dtp
, width
);
1135 if (dtp
->u
.p
.no_leading_blank
)
1137 memcpy (p
, q
, digits
);
1138 memset (p
+ digits
, ' ', width
- digits
);
1142 memset (p
, ' ', width
- digits
);
1143 memcpy (p
+ width
- digits
, q
, digits
);
1148 /* Write a list-directed string. We have to worry about delimiting
1149 the strings if the file has been opened in that mode. */
1152 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
1157 switch (dtp
->u
.p
.current_unit
->delim_status
)
1159 case DELIM_APOSTROPHE
:
1178 for (i
= 0; i
< length
; i
++)
1183 p
= write_block (dtp
, length
+ extra
);
1188 memcpy (p
, source
, length
);
1193 for (i
= 0; i
< length
; i
++)
1207 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1208 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1210 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1214 p
= write_block (dtp
, 1);
1217 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1218 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1220 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1222 p
= write_block (dtp
, 1);
1229 /* Set an fnode to default format. */
1232 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1258 internal_error (&dtp
->common
, "bad real kind");
1262 /* Output a real number with default format.
1263 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1264 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
1267 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1270 int org_scale
= dtp
->u
.p
.scale_factor
;
1271 dtp
->u
.p
.scale_factor
= 1;
1272 set_fnode_default (dtp
, &f
, length
);
1273 write_float (dtp
, &f
, source
, length
);
1274 dtp
->u
.p
.scale_factor
= org_scale
;
1279 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1282 set_fnode_default (dtp
, &f
, length
);
1285 dtp
->u
.p
.g0_no_blanks
= 1;
1286 write_float (dtp
, &f
, source
, length
);
1287 dtp
->u
.p
.g0_no_blanks
= 0;
1292 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1295 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1297 if (write_char (dtp
, '('))
1299 write_real (dtp
, source
, kind
);
1301 if (write_char (dtp
, semi_comma
))
1303 write_real (dtp
, source
+ size
/ 2, kind
);
1305 write_char (dtp
, ')');
1309 /* Write the separator between items. */
1312 write_separator (st_parameter_dt
*dtp
)
1316 p
= write_block (dtp
, options
.separator_len
);
1320 memcpy (p
, options
.separator
, options
.separator_len
);
1324 /* Write an item with list formatting.
1325 TODO: handle skipping to the next record correctly, particularly
1329 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1332 if (dtp
->u
.p
.current_unit
== NULL
)
1335 if (dtp
->u
.p
.first_item
)
1337 dtp
->u
.p
.first_item
= 0;
1338 write_char (dtp
, ' ');
1342 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1343 dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
)
1344 write_separator (dtp
);
1350 write_integer (dtp
, p
, kind
);
1353 write_logical (dtp
, p
, kind
);
1356 write_character (dtp
, p
, kind
, size
);
1359 write_real (dtp
, p
, kind
);
1362 write_complex (dtp
, p
, kind
, size
);
1365 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1368 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1373 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1374 size_t size
, size_t nelems
)
1378 size_t stride
= type
== BT_CHARACTER
?
1379 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1383 /* Big loop over all the elements. */
1384 for (elem
= 0; elem
< nelems
; elem
++)
1386 dtp
->u
.p
.item_count
++;
1387 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1393 nml_write_obj writes a namelist object to the output stream. It is called
1394 recursively for derived type components:
1395 obj = is the namelist_info for the current object.
1396 offset = the offset relative to the address held by the object for
1397 derived type arrays.
1398 base = is the namelist_info of the derived type, when obj is a
1400 base_name = the full name for a derived type, including qualifiers
1402 The returned value is a pointer to the object beyond the last one
1403 accessed, including nested derived types. Notice that the namelist is
1404 a linear linked list of objects, including derived types and their
1405 components. A tree, of sorts, is implied by the compound names of
1406 the derived type components and this is how this function recurses through
1409 /* A generous estimate of the number of characters needed to print
1410 repeat counts and indices, including commas, asterices and brackets. */
1412 #define NML_DIGITS 20
1415 namelist_write_newline (st_parameter_dt
*dtp
)
1417 if (!is_internal_unit (dtp
))
1420 write_character (dtp
, "\r\n", 1, 2);
1422 write_character (dtp
, "\n", 1, 1);
1427 if (is_array_io (dtp
))
1430 int finished
, length
;
1432 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1434 /* Now that the current record has been padded out,
1435 determine where the next record in the array is. */
1436 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1439 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1442 /* Now seek to this record */
1443 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1445 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1447 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1451 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1455 write_character (dtp
, " ", 1, 1);
1459 static namelist_info
*
1460 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1461 namelist_info
* base
, char * base_name
)
1467 index_type obj_size
;
1471 index_type elem_ctr
;
1472 size_t obj_name_len
;
1477 char rep_buff
[NML_DIGITS
];
1478 namelist_info
* cmp
;
1479 namelist_info
* retval
= obj
->next
;
1480 size_t base_name_len
;
1481 size_t base_var_name_len
;
1483 unit_delim tmp_delim
;
1485 /* Set the character to be used to separate values
1486 to a comma or semi-colon. */
1489 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1491 /* Write namelist variable names in upper case. If a derived type,
1492 nothing is output. If a component, base and base_name are set. */
1494 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1496 namelist_write_newline (dtp
);
1497 write_character (dtp
, " ", 1, 1);
1502 len
= strlen (base
->var_name
);
1503 base_name_len
= strlen (base_name
);
1504 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
1506 cup
= toupper (base_name
[dim_i
]);
1507 write_character (dtp
, &cup
, 1, 1);
1510 clen
= strlen (obj
->var_name
);
1511 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
1513 cup
= toupper (obj
->var_name
[dim_i
]);
1514 write_character (dtp
, &cup
, 1, 1);
1516 write_character (dtp
, "=", 1, 1);
1519 /* Counts the number of data output on a line, including names. */
1528 case GFC_DTYPE_REAL
:
1529 obj_size
= size_from_real_kind (len
);
1532 case GFC_DTYPE_COMPLEX
:
1533 obj_size
= size_from_complex_kind (len
);
1536 case GFC_DTYPE_CHARACTER
:
1537 obj_size
= obj
->string_length
;
1545 obj_size
= obj
->size
;
1547 /* Set the index vector and count the number of elements. */
1550 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1552 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
1553 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
1556 /* Main loop to output the data held in the object. */
1559 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1562 /* Build the pointer to the data value. The offset is passed by
1563 recursive calls to this function for arrays of derived types.
1564 Is NULL otherwise. */
1566 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1569 /* Check for repeat counts of intrinsic types. */
1571 if ((elem_ctr
< (nelem
- 1)) &&
1572 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1573 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1578 /* Execute a repeated output. Note the flag no_leading_blank that
1579 is used in the functions used to output the intrinsic types. */
1585 sprintf(rep_buff
, " %d*", rep_ctr
);
1586 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1587 dtp
->u
.p
.no_leading_blank
= 1;
1591 /* Output the data, if an intrinsic type, or recurse into this
1592 routine to treat derived types. */
1597 case GFC_DTYPE_INTEGER
:
1598 write_integer (dtp
, p
, len
);
1601 case GFC_DTYPE_LOGICAL
:
1602 write_logical (dtp
, p
, len
);
1605 case GFC_DTYPE_CHARACTER
:
1606 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1607 if (dtp
->u
.p
.nml_delim
== '"')
1608 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1609 if (dtp
->u
.p
.nml_delim
== '\'')
1610 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1611 write_character (dtp
, p
, 1, obj
->string_length
);
1612 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1615 case GFC_DTYPE_REAL
:
1616 write_real (dtp
, p
, len
);
1619 case GFC_DTYPE_COMPLEX
:
1620 dtp
->u
.p
.no_leading_blank
= 0;
1622 write_complex (dtp
, p
, len
, obj_size
);
1625 case GFC_DTYPE_DERIVED
:
1627 /* To treat a derived type, we need to build two strings:
1628 ext_name = the name, including qualifiers that prepends
1629 component names in the output - passed to
1631 obj_name = the derived type name with no qualifiers but %
1632 appended. This is used to identify the
1635 /* First ext_name => get length of all possible components */
1637 base_name_len
= base_name
? strlen (base_name
) : 0;
1638 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1639 ext_name
= (char*)get_mem ( base_name_len
1641 + strlen (obj
->var_name
)
1642 + obj
->var_rank
* NML_DIGITS
1645 memcpy (ext_name
, base_name
, base_name_len
);
1646 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1647 memcpy (ext_name
+ base_name_len
,
1648 obj
->var_name
+ base_var_name_len
, clen
);
1650 /* Append the qualifier. */
1652 tot_len
= base_name_len
+ clen
;
1653 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1657 ext_name
[tot_len
] = '(';
1660 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1661 tot_len
+= strlen (ext_name
+ tot_len
);
1662 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1666 ext_name
[tot_len
] = '\0';
1670 obj_name_len
= strlen (obj
->var_name
) + 1;
1671 obj_name
= get_mem (obj_name_len
+1);
1672 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1673 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1675 /* Now loop over the components. Update the component pointer
1676 with the return value from nml_write_obj => this loop jumps
1677 past nested derived types. */
1679 for (cmp
= obj
->next
;
1680 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1683 retval
= nml_write_obj (dtp
, cmp
,
1684 (index_type
)(p
- obj
->mem_pos
),
1688 free_mem (obj_name
);
1689 free_mem (ext_name
);
1693 internal_error (&dtp
->common
, "Bad type for namelist write");
1696 /* Reset the leading blank suppression, write a comma (or semi-colon)
1697 and, if 5 values have been output, write a newline and advance
1698 to column 2. Reset the repeat counter. */
1700 dtp
->u
.p
.no_leading_blank
= 0;
1701 write_character (dtp
, &semi_comma
, 1, 1);
1705 namelist_write_newline (dtp
);
1706 write_character (dtp
, " ", 1, 1);
1711 /* Cycle through and increment the index vector. */
1716 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
1718 obj
->ls
[dim_i
].idx
+= nml_carry
;
1720 if (obj
->ls
[dim_i
].idx
> (ssize_t
) GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
1722 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
1728 /* Return a pointer beyond the furthest object accessed. */
1734 /* This is the entry function for namelist writes. It outputs the name
1735 of the namelist and iterates through the namelist by calls to
1736 nml_write_obj. The call below has dummys in the arguments used in
1737 the treatment of derived types. */
1740 namelist_write (st_parameter_dt
*dtp
)
1742 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1744 index_type dummy_offset
= 0;
1746 char * dummy_name
= NULL
;
1747 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1749 /* Set the delimiter for namelist output. */
1750 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1752 dtp
->u
.p
.nml_delim
= tmp_delim
== DELIM_APOSTROPHE
? '\'' : '"';
1754 /* Temporarily disable namelist delimters. */
1755 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1757 write_character (dtp
, "&", 1, 1);
1759 /* Write namelist name in upper case - f95 std. */
1760 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1762 c
= toupper (dtp
->namelist_name
[i
]);
1763 write_character (dtp
, &c
, 1 ,1);
1766 if (dtp
->u
.p
.ionml
!= NULL
)
1768 t1
= dtp
->u
.p
.ionml
;
1772 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1776 namelist_write_newline (dtp
);
1777 write_character (dtp
, " /", 1, 2);
1778 /* Restore the original delimiter. */
1779 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;