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/>. */
35 #define star_fill(p, n) memset(p, '*', n)
37 #include "write_float.def"
39 typedef unsigned char uchar
;
41 /* Write out default char4. */
44 write_default_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
45 int src_len
, int w_len
)
52 /* Take care of preceding blanks. */
56 p
= write_block (dtp
, k
);
62 /* Get ready to handle delimiters if needed. */
63 switch (dtp
->u
.p
.current_unit
->delim_status
)
65 case DELIM_APOSTROPHE
:
76 /* Now process the remaining characters, one at a time. */
77 for (j
= k
; j
< src_len
; j
++)
81 /* Handle delimiters if any. */
82 if (c
== d
&& d
!= ' ')
84 p
= write_block (dtp
, 2);
91 p
= write_block (dtp
, 1);
95 *p
= c
> 255 ? '?' : (uchar
) c
;
100 /* Write out UTF-8 converted from char4. */
103 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
104 int src_len
, int w_len
)
109 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
110 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
114 /* Take care of preceding blanks. */
118 p
= write_block (dtp
, k
);
124 /* Get ready to handle delimiters if needed. */
125 switch (dtp
->u
.p
.current_unit
->delim_status
)
127 case DELIM_APOSTROPHE
:
138 /* Now process the remaining characters, one at a time. */
139 for (j
= k
; j
< src_len
; j
++)
144 /* Handle the delimiters if any. */
145 if (c
== d
&& d
!= ' ')
147 p
= write_block (dtp
, 2);
154 p
= write_block (dtp
, 1);
162 /* Convert to UTF-8 sequence. */
168 *--q
= ((c
& 0x3F) | 0x80);
172 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
174 *--q
= (c
| masks
[nbytes
-1]);
176 p
= write_block (dtp
, nbytes
);
188 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
193 wlen
= f
->u
.string
.length
< 0
194 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
195 ? len
: f
->u
.string
.length
;
198 /* If this is formatted STREAM IO convert any embedded line feed characters
199 to CR_LF on systems that use that sequence for newlines. See F2003
200 Standard sections 10.6.3 and 9.9 for further information. */
201 if (is_stream_io (dtp
))
203 const char crlf
[] = "\r\n";
207 /* Write out any padding if needed. */
210 p
= write_block (dtp
, wlen
- len
);
213 memset (p
, ' ', wlen
- len
);
216 /* Scan the source string looking for '\n' and convert it if found. */
217 for (i
= 0; i
< wlen
; i
++)
219 if (source
[i
] == '\n')
221 /* Write out the previously scanned characters in the string. */
224 p
= write_block (dtp
, bytes
);
227 memcpy (p
, &source
[q
], bytes
);
232 /* Write out the CR_LF sequence. */
234 p
= write_block (dtp
, 2);
243 /* Write out any remaining bytes if no LF was found. */
246 p
= write_block (dtp
, bytes
);
249 memcpy (p
, &source
[q
], bytes
);
255 p
= write_block (dtp
, wlen
);
260 memcpy (p
, source
, wlen
);
263 memset (p
, ' ', wlen
- len
);
264 memcpy (p
+ wlen
- len
, source
, len
);
272 /* The primary difference between write_a_char4 and write_a is that we have to
273 deal with writing from the first byte of the 4-byte character and pay
274 attention to the most significant bytes. For ENCODING="default" write the
275 lowest significant byte. If the 3 most significant bytes contain
276 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
277 to the UTF-8 encoded string before writing out. */
280 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
285 wlen
= f
->u
.string
.length
< 0
286 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
287 ? len
: f
->u
.string
.length
;
289 q
= (gfc_char4_t
*) source
;
291 /* If this is formatted STREAM IO convert any embedded line feed characters
292 to CR_LF on systems that use that sequence for newlines. See F2003
293 Standard sections 10.6.3 and 9.9 for further information. */
294 if (is_stream_io (dtp
))
296 const gfc_char4_t crlf
[] = {0x000d,0x000a};
301 /* Write out any padding if needed. */
305 p
= write_block (dtp
, wlen
- len
);
308 memset (p
, ' ', wlen
- len
);
311 /* Scan the source string looking for '\n' and convert it if found. */
312 qq
= (gfc_char4_t
*) source
;
313 for (i
= 0; i
< wlen
; i
++)
317 /* Write out the previously scanned characters in the string. */
320 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
321 write_utf8_char4 (dtp
, q
, bytes
, 0);
323 write_default_char4 (dtp
, q
, bytes
, 0);
327 /* Write out the CR_LF sequence. */
328 write_default_char4 (dtp
, crlf
, 2, 0);
334 /* Write out any remaining bytes if no LF was found. */
337 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
338 write_utf8_char4 (dtp
, q
, bytes
, 0);
340 write_default_char4 (dtp
, q
, bytes
, 0);
346 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
347 write_utf8_char4 (dtp
, q
, len
, wlen
);
349 write_default_char4 (dtp
, q
, len
, wlen
);
356 static GFC_INTEGER_LARGEST
357 extract_int (const void *p
, int len
)
359 GFC_INTEGER_LARGEST i
= 0;
369 memcpy ((void *) &tmp
, p
, len
);
376 memcpy ((void *) &tmp
, p
, len
);
383 memcpy ((void *) &tmp
, p
, len
);
390 memcpy ((void *) &tmp
, p
, len
);
394 #ifdef HAVE_GFC_INTEGER_16
398 memcpy ((void *) &tmp
, p
, len
);
404 internal_error (NULL
, "bad integer kind");
410 static GFC_UINTEGER_LARGEST
411 extract_uint (const void *p
, int len
)
413 GFC_UINTEGER_LARGEST i
= 0;
423 memcpy ((void *) &tmp
, p
, len
);
424 i
= (GFC_UINTEGER_1
) tmp
;
430 memcpy ((void *) &tmp
, p
, len
);
431 i
= (GFC_UINTEGER_2
) tmp
;
437 memcpy ((void *) &tmp
, p
, len
);
438 i
= (GFC_UINTEGER_4
) tmp
;
444 memcpy ((void *) &tmp
, p
, len
);
445 i
= (GFC_UINTEGER_8
) tmp
;
448 #ifdef HAVE_GFC_INTEGER_16
452 GFC_INTEGER_16 tmp
= 0;
453 memcpy ((void *) &tmp
, p
, len
);
454 i
= (GFC_UINTEGER_16
) tmp
;
459 internal_error (NULL
, "bad integer kind");
467 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
471 GFC_INTEGER_LARGEST n
;
473 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
475 p
= write_block (dtp
, wlen
);
479 memset (p
, ' ', wlen
- 1);
480 n
= extract_int (source
, len
);
481 p
[wlen
- 1] = (n
) ? 'T' : 'F';
486 write_boz (st_parameter_dt
*dtp
, const fnode
*f
, const char *q
, int n
)
488 int w
, m
, digits
, nzero
, nblank
;
496 if (m
== 0 && n
== 0)
501 p
= write_block (dtp
, w
);
511 /* Select a width if none was specified. The idea here is to always
515 w
= ((digits
< m
) ? m
: digits
);
517 p
= write_block (dtp
, w
);
525 /* See if things will work. */
527 nblank
= w
- (nzero
+ digits
);
535 if (!dtp
->u
.p
.no_leading_blank
)
537 memset (p
, ' ', nblank
);
539 memset (p
, '0', nzero
);
541 memcpy (p
, q
, digits
);
545 memset (p
, '0', nzero
);
547 memcpy (p
, q
, digits
);
549 memset (p
, ' ', nblank
);
550 dtp
->u
.p
.no_leading_blank
= 0;
558 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
560 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
562 GFC_INTEGER_LARGEST n
= 0;
563 int w
, m
, digits
, nsign
, nzero
, nblank
;
567 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
570 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
572 n
= extract_int (source
, len
);
575 if (m
== 0 && n
== 0)
580 p
= write_block (dtp
, w
);
588 sign
= calculate_sign (dtp
, n
< 0);
591 nsign
= sign
== S_NONE
? 0 : 1;
593 /* conv calls itoa which sets the negative sign needed
594 by write_integer. The sign '+' or '-' is set below based on sign
595 calculated above, so we just point past the sign in the string
596 before proceeding to avoid double signs in corner cases.
598 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
604 /* Select a width if none was specified. The idea here is to always
608 w
= ((digits
< m
) ? m
: digits
) + nsign
;
610 p
= write_block (dtp
, w
);
618 /* See if things will work. */
620 nblank
= w
- (nsign
+ nzero
+ digits
);
628 memset (p
, ' ', nblank
);
643 memset (p
, '0', nzero
);
646 memcpy (p
, q
, digits
);
653 /* Convert unsigned octal to ascii. */
656 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
660 assert (len
>= GFC_OTOA_BUF_SIZE
);
665 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
670 *--p
= '0' + (n
& 7);
678 /* Convert unsigned binary to ascii. */
681 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
685 assert (len
>= GFC_BTOA_BUF_SIZE
);
690 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
695 *--p
= '0' + (n
& 1);
702 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
703 to convert large reals with kind sizes that exceed the largest integer type
704 available on certain platforms. In these cases, byte by byte conversion is
705 performed. Endianess is taken into account. */
707 /* Conversion to binary. */
710 btoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
719 for (i
= 0; i
< len
; i
++)
723 /* Test for zero. Needed by write_boz later. */
727 for (j
= 0; j
< 8; j
++)
729 *q
++ = (c
& 128) ? '1' : '0';
737 const char *p
= s
+ len
- 1;
738 for (i
= 0; i
< len
; i
++)
742 /* Test for zero. Needed by write_boz later. */
746 for (j
= 0; j
< 8; j
++)
748 *q
++ = (c
& 128) ? '1' : '0';
760 /* Move past any leading zeros. */
761 while (*buffer
== '0')
768 /* Conversion to octal. */
771 otoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
777 q
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
783 const char *p
= s
+ len
- 1;
787 /* Test for zero. Needed by write_boz later. */
791 for (j
= 0; j
< 3 && i
< len
; j
++)
793 octet
|= (c
& 1) << j
;
812 /* Test for zero. Needed by write_boz later. */
816 for (j
= 0; j
< 3 && i
< len
; j
++)
818 octet
|= (c
& 1) << j
;
835 /* Move past any leading zeros. */
842 /* Conversion to hexidecimal. */
845 ztoa_big (const char *s
, char *buffer
, int len
, GFC_UINTEGER_LARGEST
*n
)
847 static char a
[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
848 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
859 for (i
= 0; i
< len
; i
++)
861 /* Test for zero. Needed by write_boz later. */
865 h
= (*p
>> 4) & 0x0F;
873 const char *p
= s
+ len
- 1;
874 for (i
= 0; i
< len
; i
++)
876 /* Test for zero. Needed by write_boz later. */
880 h
= (*p
>> 4) & 0x0F;
892 /* Move past any leading zeros. */
893 while (*buffer
== '0')
899 /* gfc_itoa()-- Integer to decimal conversion.
900 The itoa function is a widespread non-standard extension to standard
901 C, often declared in <stdlib.h>. Even though the itoa defined here
902 is a static function we take care not to conflict with any prior
903 non-static declaration. Hence the 'gfc_' prefix, which is normally
904 reserved for functions with external linkage. */
907 gfc_itoa (GFC_INTEGER_LARGEST n
, char *buffer
, size_t len
)
911 GFC_UINTEGER_LARGEST t
;
913 assert (len
>= GFC_ITOA_BUF_SIZE
);
923 t
= -n
; /*must use unsigned to protect from overflow*/
926 p
= buffer
+ GFC_ITOA_BUF_SIZE
- 1;
931 *--p
= '0' + (t
% 10);
942 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
944 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
949 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
952 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
953 GFC_UINTEGER_LARGEST n
= 0;
955 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
957 p
= btoa_big (source
, itoa_buf
, len
, &n
);
958 write_boz (dtp
, f
, p
, n
);
962 n
= extract_uint (source
, len
);
963 p
= btoa (n
, itoa_buf
, sizeof (itoa_buf
));
964 write_boz (dtp
, f
, p
, n
);
970 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
973 char itoa_buf
[GFC_OTOA_BUF_SIZE
];
974 GFC_UINTEGER_LARGEST n
= 0;
976 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
978 p
= otoa_big (source
, itoa_buf
, len
, &n
);
979 write_boz (dtp
, f
, p
, n
);
983 n
= extract_uint (source
, len
);
984 p
= otoa (n
, itoa_buf
, sizeof (itoa_buf
));
985 write_boz (dtp
, f
, p
, n
);
990 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
993 char itoa_buf
[GFC_XTOA_BUF_SIZE
];
994 GFC_UINTEGER_LARGEST n
= 0;
996 if (len
> (int) sizeof (GFC_UINTEGER_LARGEST
))
998 p
= ztoa_big (source
, itoa_buf
, len
, &n
);
999 write_boz (dtp
, f
, p
, n
);
1003 n
= extract_uint (source
, len
);
1004 p
= gfc_xtoa (n
, itoa_buf
, sizeof (itoa_buf
));
1005 write_boz (dtp
, f
, p
, n
);
1011 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1013 write_float (dtp
, f
, p
, len
);
1018 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1020 write_float (dtp
, f
, p
, len
);
1025 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1027 write_float (dtp
, f
, p
, len
);
1032 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1034 write_float (dtp
, f
, p
, len
);
1039 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
1041 write_float (dtp
, f
, p
, len
);
1045 /* Take care of the X/TR descriptor. */
1048 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
1052 p
= write_block (dtp
, len
);
1055 if (nspaces
> 0 && len
- nspaces
>= 0)
1056 memset (&p
[len
- nspaces
], ' ', nspaces
);
1060 /* List-directed writing. */
1063 /* Write a single character to the output. Returns nonzero if
1064 something goes wrong. */
1067 write_char (st_parameter_dt
*dtp
, char c
)
1071 p
= write_block (dtp
, 1);
1081 /* Write a list-directed logical value. */
1084 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
1086 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
1090 /* Write a list-directed integer value. */
1093 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
1099 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
1101 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
1126 digits
= strlen (q
);
1130 p
= write_block (dtp
, width
);
1133 if (dtp
->u
.p
.no_leading_blank
)
1135 memcpy (p
, q
, digits
);
1136 memset (p
+ digits
, ' ', width
- digits
);
1140 memset (p
, ' ', width
- digits
);
1141 memcpy (p
+ width
- digits
, q
, digits
);
1146 /* Write a list-directed string. We have to worry about delimiting
1147 the strings if the file has been opened in that mode. */
1150 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
1155 switch (dtp
->u
.p
.current_unit
->delim_status
)
1157 case DELIM_APOSTROPHE
:
1176 for (i
= 0; i
< length
; i
++)
1181 p
= write_block (dtp
, length
+ extra
);
1186 memcpy (p
, source
, length
);
1191 for (i
= 0; i
< length
; i
++)
1205 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1206 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1208 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1212 p
= write_block (dtp
, 1);
1215 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
1216 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1218 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
1220 p
= write_block (dtp
, 1);
1227 /* Set an fnode to default format. */
1230 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
1256 internal_error (&dtp
->common
, "bad real kind");
1260 /* Output a real number with default format.
1261 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1262 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
1265 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1268 int org_scale
= dtp
->u
.p
.scale_factor
;
1269 dtp
->u
.p
.scale_factor
= 1;
1270 set_fnode_default (dtp
, &f
, length
);
1271 write_float (dtp
, &f
, source
, length
);
1272 dtp
->u
.p
.scale_factor
= org_scale
;
1277 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1280 set_fnode_default (dtp
, &f
, length
);
1283 dtp
->u
.p
.g0_no_blanks
= 1;
1284 write_float (dtp
, &f
, source
, length
);
1285 dtp
->u
.p
.g0_no_blanks
= 0;
1290 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1293 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1295 if (write_char (dtp
, '('))
1297 write_real (dtp
, source
, kind
);
1299 if (write_char (dtp
, semi_comma
))
1301 write_real (dtp
, source
+ size
/ 2, kind
);
1303 write_char (dtp
, ')');
1307 /* Write the separator between items. */
1310 write_separator (st_parameter_dt
*dtp
)
1314 p
= write_block (dtp
, options
.separator_len
);
1318 memcpy (p
, options
.separator
, options
.separator_len
);
1322 /* Write an item with list formatting.
1323 TODO: handle skipping to the next record correctly, particularly
1327 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1330 if (dtp
->u
.p
.current_unit
== NULL
)
1333 if (dtp
->u
.p
.first_item
)
1335 dtp
->u
.p
.first_item
= 0;
1336 write_char (dtp
, ' ');
1340 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1341 dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
)
1342 write_separator (dtp
);
1348 write_integer (dtp
, p
, kind
);
1351 write_logical (dtp
, p
, kind
);
1354 write_character (dtp
, p
, kind
, size
);
1357 write_real (dtp
, p
, kind
);
1360 write_complex (dtp
, p
, kind
, size
);
1363 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1366 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1371 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1372 size_t size
, size_t nelems
)
1376 size_t stride
= type
== BT_CHARACTER
?
1377 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1381 /* Big loop over all the elements. */
1382 for (elem
= 0; elem
< nelems
; elem
++)
1384 dtp
->u
.p
.item_count
++;
1385 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1391 nml_write_obj writes a namelist object to the output stream. It is called
1392 recursively for derived type components:
1393 obj = is the namelist_info for the current object.
1394 offset = the offset relative to the address held by the object for
1395 derived type arrays.
1396 base = is the namelist_info of the derived type, when obj is a
1398 base_name = the full name for a derived type, including qualifiers
1400 The returned value is a pointer to the object beyond the last one
1401 accessed, including nested derived types. Notice that the namelist is
1402 a linear linked list of objects, including derived types and their
1403 components. A tree, of sorts, is implied by the compound names of
1404 the derived type components and this is how this function recurses through
1407 /* A generous estimate of the number of characters needed to print
1408 repeat counts and indices, including commas, asterices and brackets. */
1410 #define NML_DIGITS 20
1413 namelist_write_newline (st_parameter_dt
*dtp
)
1415 if (!is_internal_unit (dtp
))
1418 write_character (dtp
, "\r\n", 1, 2);
1420 write_character (dtp
, "\n", 1, 1);
1425 if (is_array_io (dtp
))
1428 int finished
, length
;
1430 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1432 /* Now that the current record has been padded out,
1433 determine where the next record in the array is. */
1434 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1437 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1440 /* Now seek to this record */
1441 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1443 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1445 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1449 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1453 write_character (dtp
, " ", 1, 1);
1457 static namelist_info
*
1458 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1459 namelist_info
* base
, char * base_name
)
1465 index_type obj_size
;
1469 index_type elem_ctr
;
1470 size_t obj_name_len
;
1475 char rep_buff
[NML_DIGITS
];
1476 namelist_info
* cmp
;
1477 namelist_info
* retval
= obj
->next
;
1478 size_t base_name_len
;
1479 size_t base_var_name_len
;
1481 unit_delim tmp_delim
;
1483 /* Set the character to be used to separate values
1484 to a comma or semi-colon. */
1487 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1489 /* Write namelist variable names in upper case. If a derived type,
1490 nothing is output. If a component, base and base_name are set. */
1492 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1494 namelist_write_newline (dtp
);
1495 write_character (dtp
, " ", 1, 1);
1500 len
= strlen (base
->var_name
);
1501 base_name_len
= strlen (base_name
);
1502 for (dim_i
= 0; dim_i
< base_name_len
; dim_i
++)
1504 cup
= toupper (base_name
[dim_i
]);
1505 write_character (dtp
, &cup
, 1, 1);
1508 clen
= strlen (obj
->var_name
);
1509 for (dim_i
= len
; dim_i
< clen
; dim_i
++)
1511 cup
= toupper (obj
->var_name
[dim_i
]);
1512 write_character (dtp
, &cup
, 1, 1);
1514 write_character (dtp
, "=", 1, 1);
1517 /* Counts the number of data output on a line, including names. */
1526 case GFC_DTYPE_REAL
:
1527 obj_size
= size_from_real_kind (len
);
1530 case GFC_DTYPE_COMPLEX
:
1531 obj_size
= size_from_complex_kind (len
);
1534 case GFC_DTYPE_CHARACTER
:
1535 obj_size
= obj
->string_length
;
1543 obj_size
= obj
->size
;
1545 /* Set the index vector and count the number of elements. */
1548 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1550 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
, dim_i
);
1551 nelem
= nelem
* GFC_DESCRIPTOR_EXTENT (obj
, dim_i
);
1554 /* Main loop to output the data held in the object. */
1557 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1560 /* Build the pointer to the data value. The offset is passed by
1561 recursive calls to this function for arrays of derived types.
1562 Is NULL otherwise. */
1564 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1567 /* Check for repeat counts of intrinsic types. */
1569 if ((elem_ctr
< (nelem
- 1)) &&
1570 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1571 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1576 /* Execute a repeated output. Note the flag no_leading_blank that
1577 is used in the functions used to output the intrinsic types. */
1583 sprintf(rep_buff
, " %d*", rep_ctr
);
1584 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1585 dtp
->u
.p
.no_leading_blank
= 1;
1589 /* Output the data, if an intrinsic type, or recurse into this
1590 routine to treat derived types. */
1595 case GFC_DTYPE_INTEGER
:
1596 write_integer (dtp
, p
, len
);
1599 case GFC_DTYPE_LOGICAL
:
1600 write_logical (dtp
, p
, len
);
1603 case GFC_DTYPE_CHARACTER
:
1604 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1605 if (dtp
->u
.p
.nml_delim
== '"')
1606 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1607 if (dtp
->u
.p
.nml_delim
== '\'')
1608 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1609 write_character (dtp
, p
, 1, obj
->string_length
);
1610 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1613 case GFC_DTYPE_REAL
:
1614 write_real (dtp
, p
, len
);
1617 case GFC_DTYPE_COMPLEX
:
1618 dtp
->u
.p
.no_leading_blank
= 0;
1620 write_complex (dtp
, p
, len
, obj_size
);
1623 case GFC_DTYPE_DERIVED
:
1625 /* To treat a derived type, we need to build two strings:
1626 ext_name = the name, including qualifiers that prepends
1627 component names in the output - passed to
1629 obj_name = the derived type name with no qualifiers but %
1630 appended. This is used to identify the
1633 /* First ext_name => get length of all possible components */
1635 base_name_len
= base_name
? strlen (base_name
) : 0;
1636 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1637 ext_name
= (char*)get_mem ( base_name_len
1639 + strlen (obj
->var_name
)
1640 + obj
->var_rank
* NML_DIGITS
1643 memcpy (ext_name
, base_name
, base_name_len
);
1644 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1645 memcpy (ext_name
+ base_name_len
,
1646 obj
->var_name
+ base_var_name_len
, clen
);
1648 /* Append the qualifier. */
1650 tot_len
= base_name_len
+ clen
;
1651 for (dim_i
= 0; dim_i
< (size_t) obj
->var_rank
; dim_i
++)
1655 ext_name
[tot_len
] = '(';
1658 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1659 tot_len
+= strlen (ext_name
+ tot_len
);
1660 ext_name
[tot_len
] = ((int) dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1664 ext_name
[tot_len
] = '\0';
1668 obj_name_len
= strlen (obj
->var_name
) + 1;
1669 obj_name
= get_mem (obj_name_len
+1);
1670 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1671 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1673 /* Now loop over the components. Update the component pointer
1674 with the return value from nml_write_obj => this loop jumps
1675 past nested derived types. */
1677 for (cmp
= obj
->next
;
1678 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1681 retval
= nml_write_obj (dtp
, cmp
,
1682 (index_type
)(p
- obj
->mem_pos
),
1686 free_mem (obj_name
);
1687 free_mem (ext_name
);
1691 internal_error (&dtp
->common
, "Bad type for namelist write");
1694 /* Reset the leading blank suppression, write a comma (or semi-colon)
1695 and, if 5 values have been output, write a newline and advance
1696 to column 2. Reset the repeat counter. */
1698 dtp
->u
.p
.no_leading_blank
= 0;
1699 write_character (dtp
, &semi_comma
, 1, 1);
1703 namelist_write_newline (dtp
);
1704 write_character (dtp
, " ", 1, 1);
1709 /* Cycle through and increment the index vector. */
1714 for (dim_i
= 0; nml_carry
&& (dim_i
< (size_t) obj
->var_rank
); dim_i
++)
1716 obj
->ls
[dim_i
].idx
+= nml_carry
;
1718 if (obj
->ls
[dim_i
].idx
> (ssize_t
) GFC_DESCRIPTOR_UBOUND(obj
,dim_i
))
1720 obj
->ls
[dim_i
].idx
= GFC_DESCRIPTOR_LBOUND(obj
,dim_i
);
1726 /* Return a pointer beyond the furthest object accessed. */
1732 /* This is the entry function for namelist writes. It outputs the name
1733 of the namelist and iterates through the namelist by calls to
1734 nml_write_obj. The call below has dummys in the arguments used in
1735 the treatment of derived types. */
1738 namelist_write (st_parameter_dt
*dtp
)
1740 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1742 index_type dummy_offset
= 0;
1744 char * dummy_name
= NULL
;
1745 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1747 /* Set the delimiter for namelist output. */
1748 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1750 dtp
->u
.p
.nml_delim
= tmp_delim
== DELIM_APOSTROPHE
? '\'' : '"';
1752 /* Temporarily disable namelist delimters. */
1753 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1755 write_character (dtp
, "&", 1, 1);
1757 /* Write namelist name in upper case - f95 std. */
1758 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1760 c
= toupper (dtp
->namelist_name
[i
]);
1761 write_character (dtp
, &c
, 1 ,1);
1764 if (dtp
->u
.p
.ionml
!= NULL
)
1766 t1
= dtp
->u
.p
.ionml
;
1770 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1774 namelist_write_newline (dtp
);
1775 write_character (dtp
, " /", 1, 2);
1776 /* Restore the original delimiter. */
1777 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;