1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
40 #define star_fill(p, n) memset(p, '*', n)
42 #include "write_float.def"
44 typedef unsigned char uchar
;
46 /* Write out default char4. */
49 write_default_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
50 int src_len
, int w_len
)
57 /* Take care of preceding blanks. */
61 p
= write_block (dtp
, k
);
67 /* Get ready to handle delimiters if needed. */
68 switch (dtp
->u
.p
.current_unit
->delim_status
)
70 case DELIM_APOSTROPHE
:
81 /* Now process the remaining characters, one at a time. */
82 for (j
= k
; j
< src_len
; j
++)
86 /* Handle delimiters if any. */
87 if (c
== d
&& d
!= ' ')
89 p
= write_block (dtp
, 2);
96 p
= write_block (dtp
, 1);
100 *p
= c
> 255 ? '?' : (uchar
) c
;
105 /* Write out UTF-8 converted from char4. */
108 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
109 int src_len
, int w_len
)
114 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
115 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
119 /* Take care of preceding blanks. */
123 p
= write_block (dtp
, k
);
129 /* Get ready to handle delimiters if needed. */
130 switch (dtp
->u
.p
.current_unit
->delim_status
)
132 case DELIM_APOSTROPHE
:
143 /* Now process the remaining characters, one at a time. */
144 for (j
= k
; j
< src_len
; j
++)
149 /* Handle the delimiters if any. */
150 if (c
== d
&& d
!= ' ')
152 p
= write_block (dtp
, 2);
159 p
= write_block (dtp
, 1);
167 /* Convert to UTF-8 sequence. */
173 *--q
= ((c
& 0x3F) | 0x80);
177 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
179 *--q
= (c
| masks
[nbytes
-1]);
181 p
= write_block (dtp
, nbytes
);
193 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
198 wlen
= f
->u
.string
.length
< 0
199 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
200 ? len
: f
->u
.string
.length
;
203 /* If this is formatted STREAM IO convert any embedded line feed characters
204 to CR_LF on systems that use that sequence for newlines. See F2003
205 Standard sections 10.6.3 and 9.9 for further information. */
206 if (is_stream_io (dtp
))
208 const char crlf
[] = "\r\n";
212 /* Write out any padding if needed. */
215 p
= write_block (dtp
, wlen
- len
);
218 memset (p
, ' ', wlen
- len
);
221 /* Scan the source string looking for '\n' and convert it if found. */
222 for (i
= 0; i
< wlen
; i
++)
224 if (source
[i
] == '\n')
226 /* Write out the previously scanned characters in the string. */
229 p
= write_block (dtp
, bytes
);
232 memcpy (p
, &source
[q
], bytes
);
237 /* Write out the CR_LF sequence. */
239 p
= write_block (dtp
, 2);
248 /* Write out any remaining bytes if no LF was found. */
251 p
= write_block (dtp
, bytes
);
254 memcpy (p
, &source
[q
], bytes
);
260 p
= write_block (dtp
, wlen
);
265 memcpy (p
, source
, wlen
);
268 memset (p
, ' ', wlen
- len
);
269 memcpy (p
+ wlen
- len
, source
, len
);
277 /* The primary difference between write_a_char4 and write_a is that we have to
278 deal with writing from the first byte of the 4-byte character and pay
279 attention to the most significant bytes. For ENCODING="default" write the
280 lowest significant byte. If the 3 most significant bytes contain
281 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
282 to the UTF-8 encoded string before writing out. */
285 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
290 wlen
= f
->u
.string
.length
< 0
291 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
292 ? len
: f
->u
.string
.length
;
294 q
= (gfc_char4_t
*) source
;
296 /* If this is formatted STREAM IO convert any embedded line feed characters
297 to CR_LF on systems that use that sequence for newlines. See F2003
298 Standard sections 10.6.3 and 9.9 for further information. */
299 if (is_stream_io (dtp
))
301 const char crlf
[] = "\r\n";
306 /* Write out any padding if needed. */
310 p
= write_block (dtp
, wlen
- len
);
313 memset (p
, ' ', wlen
- len
);
316 /* Scan the source string looking for '\n' and convert it if found. */
317 qq
= (gfc_char4_t
*) source
;
318 for (i
= 0; i
< wlen
; i
++)
322 /* Write out the previously scanned characters in the string. */
325 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
326 write_utf8_char4 (dtp
, q
, bytes
, 0);
328 write_default_char4 (dtp
, q
, bytes
, 0);
332 /* Write out the CR_LF sequence. */
333 write_default_char4 (dtp
, crlf
, 2, 0);
339 /* Write out any remaining bytes if no LF was found. */
342 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
343 write_utf8_char4 (dtp
, q
, bytes
, 0);
345 write_default_char4 (dtp
, q
, bytes
, 0);
351 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
352 write_utf8_char4 (dtp
, q
, len
, wlen
);
354 write_default_char4 (dtp
, q
, len
, wlen
);
361 static GFC_INTEGER_LARGEST
362 extract_int (const void *p
, int len
)
364 GFC_INTEGER_LARGEST i
= 0;
374 memcpy ((void *) &tmp
, p
, len
);
381 memcpy ((void *) &tmp
, p
, len
);
388 memcpy ((void *) &tmp
, p
, len
);
395 memcpy ((void *) &tmp
, p
, len
);
399 #ifdef HAVE_GFC_INTEGER_16
403 memcpy ((void *) &tmp
, p
, len
);
409 internal_error (NULL
, "bad integer kind");
415 static GFC_UINTEGER_LARGEST
416 extract_uint (const void *p
, int len
)
418 GFC_UINTEGER_LARGEST i
= 0;
428 memcpy ((void *) &tmp
, p
, len
);
429 i
= (GFC_UINTEGER_1
) tmp
;
435 memcpy ((void *) &tmp
, p
, len
);
436 i
= (GFC_UINTEGER_2
) tmp
;
442 memcpy ((void *) &tmp
, p
, len
);
443 i
= (GFC_UINTEGER_4
) tmp
;
449 memcpy ((void *) &tmp
, p
, len
);
450 i
= (GFC_UINTEGER_8
) tmp
;
453 #ifdef HAVE_GFC_INTEGER_16
457 memcpy ((void *) &tmp
, p
, len
);
458 i
= (GFC_UINTEGER_16
) tmp
;
463 internal_error (NULL
, "bad integer kind");
471 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
475 GFC_INTEGER_LARGEST n
;
477 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
479 p
= write_block (dtp
, wlen
);
483 memset (p
, ' ', wlen
- 1);
484 n
= extract_int (source
, len
);
485 p
[wlen
- 1] = (n
) ? 'T' : 'F';
490 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
491 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
493 GFC_UINTEGER_LARGEST n
= 0;
494 int w
, m
, digits
, nzero
, nblank
;
497 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
502 n
= extract_uint (source
, len
);
506 if (m
== 0 && n
== 0)
511 p
= write_block (dtp
, w
);
519 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
522 /* Select a width if none was specified. The idea here is to always
526 w
= ((digits
< m
) ? m
: digits
);
528 p
= write_block (dtp
, w
);
536 /* See if things will work. */
538 nblank
= w
- (nzero
+ digits
);
547 if (!dtp
->u
.p
.no_leading_blank
)
549 memset (p
, ' ', nblank
);
551 memset (p
, '0', nzero
);
553 memcpy (p
, q
, digits
);
557 memset (p
, '0', nzero
);
559 memcpy (p
, q
, digits
);
561 memset (p
, ' ', nblank
);
562 dtp
->u
.p
.no_leading_blank
= 0;
570 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
572 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
574 GFC_INTEGER_LARGEST n
= 0;
575 int w
, m
, digits
, nsign
, nzero
, nblank
;
579 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
582 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
584 n
= extract_int (source
, len
);
587 if (m
== 0 && n
== 0)
592 p
= write_block (dtp
, w
);
600 sign
= calculate_sign (dtp
, n
< 0);
604 nsign
= sign
== S_NONE
? 0 : 1;
605 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
609 /* Select a width if none was specified. The idea here is to always
613 w
= ((digits
< m
) ? m
: digits
) + nsign
;
615 p
= write_block (dtp
, w
);
623 /* See if things will work. */
625 nblank
= w
- (nsign
+ nzero
+ digits
);
633 memset (p
, ' ', nblank
);
648 memset (p
, '0', nzero
);
651 memcpy (p
, q
, digits
);
658 /* Convert unsigned octal to ascii. */
661 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
665 assert (len
>= GFC_OTOA_BUF_SIZE
);
670 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
675 *--p
= '0' + (n
& 7);
683 /* Convert unsigned binary to ascii. */
686 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
690 assert (len
>= GFC_BTOA_BUF_SIZE
);
695 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
700 *--p
= '0' + (n
& 1);
709 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
711 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
716 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
718 write_int (dtp
, f
, p
, len
, btoa
);
723 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
725 write_int (dtp
, f
, p
, len
, otoa
);
729 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
731 write_int (dtp
, f
, p
, len
, xtoa
);
736 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
738 write_float (dtp
, f
, p
, len
);
743 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
745 write_float (dtp
, f
, p
, len
);
750 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
752 write_float (dtp
, f
, p
, len
);
757 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
759 write_float (dtp
, f
, p
, len
);
764 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
766 write_float (dtp
, f
, p
, len
);
770 /* Take care of the X/TR descriptor. */
773 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
777 p
= write_block (dtp
, len
);
782 memset (&p
[len
- nspaces
], ' ', nspaces
);
786 /* List-directed writing. */
789 /* Write a single character to the output. Returns nonzero if
790 something goes wrong. */
793 write_char (st_parameter_dt
*dtp
, char c
)
797 p
= write_block (dtp
, 1);
807 /* Write a list-directed logical value. */
810 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
812 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
816 /* Write a list-directed integer value. */
819 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
825 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
827 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
856 p
= write_block (dtp
, width
);
859 if (dtp
->u
.p
.no_leading_blank
)
861 memcpy (p
, q
, digits
);
862 memset (p
+ digits
, ' ', width
- digits
);
866 memset (p
, ' ', width
- digits
);
867 memcpy (p
+ width
- digits
, q
, digits
);
872 /* Write a list-directed string. We have to worry about delimiting
873 the strings if the file has been opened in that mode. */
876 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
881 switch (dtp
->u
.p
.current_unit
->delim_status
)
883 case DELIM_APOSTROPHE
:
902 for (i
= 0; i
< length
; i
++)
907 p
= write_block (dtp
, length
+ extra
);
912 memcpy (p
, source
, length
);
917 for (i
= 0; i
< length
; i
++)
931 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
932 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
934 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
938 p
= write_block (dtp
, 1);
941 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
942 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
944 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
946 p
= write_block (dtp
, 1);
953 /* Set an fnode to default format. */
956 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
982 internal_error (&dtp
->common
, "bad real kind");
986 /* Output a real number with default format.
987 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
988 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
991 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
994 int org_scale
= dtp
->u
.p
.scale_factor
;
995 dtp
->u
.p
.scale_factor
= 1;
996 set_fnode_default (dtp
, &f
, length
);
997 write_float (dtp
, &f
, source
, length
);
998 dtp
->u
.p
.scale_factor
= org_scale
;
1003 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1006 int org_scale
= dtp
->u
.p
.scale_factor
;
1007 dtp
->u
.p
.scale_factor
= 1;
1008 set_fnode_default (dtp
, &f
, length
);
1011 write_float (dtp
, &f
, source
, length
);
1012 dtp
->u
.p
.scale_factor
= org_scale
;
1017 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1020 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1022 if (write_char (dtp
, '('))
1024 write_real (dtp
, source
, kind
);
1026 if (write_char (dtp
, semi_comma
))
1028 write_real (dtp
, source
+ size
/ 2, kind
);
1030 write_char (dtp
, ')');
1034 /* Write the separator between items. */
1037 write_separator (st_parameter_dt
*dtp
)
1041 p
= write_block (dtp
, options
.separator_len
);
1045 memcpy (p
, options
.separator
, options
.separator_len
);
1049 /* Write an item with list formatting.
1050 TODO: handle skipping to the next record correctly, particularly
1054 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1057 if (dtp
->u
.p
.current_unit
== NULL
)
1060 if (dtp
->u
.p
.first_item
)
1062 dtp
->u
.p
.first_item
= 0;
1063 write_char (dtp
, ' ');
1067 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1068 dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
)
1069 write_separator (dtp
);
1075 write_integer (dtp
, p
, kind
);
1078 write_logical (dtp
, p
, kind
);
1081 write_character (dtp
, p
, kind
, size
);
1084 write_real (dtp
, p
, kind
);
1087 write_complex (dtp
, p
, kind
, size
);
1090 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1093 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1098 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1099 size_t size
, size_t nelems
)
1103 size_t stride
= type
== BT_CHARACTER
?
1104 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1108 /* Big loop over all the elements. */
1109 for (elem
= 0; elem
< nelems
; elem
++)
1111 dtp
->u
.p
.item_count
++;
1112 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1118 nml_write_obj writes a namelist object to the output stream. It is called
1119 recursively for derived type components:
1120 obj = is the namelist_info for the current object.
1121 offset = the offset relative to the address held by the object for
1122 derived type arrays.
1123 base = is the namelist_info of the derived type, when obj is a
1125 base_name = the full name for a derived type, including qualifiers
1127 The returned value is a pointer to the object beyond the last one
1128 accessed, including nested derived types. Notice that the namelist is
1129 a linear linked list of objects, including derived types and their
1130 components. A tree, of sorts, is implied by the compound names of
1131 the derived type components and this is how this function recurses through
1134 /* A generous estimate of the number of characters needed to print
1135 repeat counts and indices, including commas, asterices and brackets. */
1137 #define NML_DIGITS 20
1140 namelist_write_newline (st_parameter_dt
*dtp
)
1142 if (!is_internal_unit (dtp
))
1145 write_character (dtp
, "\r\n", 1, 2);
1147 write_character (dtp
, "\n", 1, 1);
1151 write_character (dtp
, " ", 1, 1);
1155 static namelist_info
*
1156 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1157 namelist_info
* base
, char * base_name
)
1163 index_type obj_size
;
1167 index_type elem_ctr
;
1168 index_type obj_name_len
;
1173 char rep_buff
[NML_DIGITS
];
1174 namelist_info
* cmp
;
1175 namelist_info
* retval
= obj
->next
;
1176 size_t base_name_len
;
1177 size_t base_var_name_len
;
1179 unit_delim tmp_delim
;
1181 /* Set the character to be used to separate values
1182 to a comma or semi-colon. */
1185 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1187 /* Write namelist variable names in upper case. If a derived type,
1188 nothing is output. If a component, base and base_name are set. */
1190 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1192 namelist_write_newline (dtp
);
1193 write_character (dtp
, " ", 1, 1);
1198 len
=strlen (base
->var_name
);
1199 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1201 cup
= toupper (base_name
[dim_i
]);
1202 write_character (dtp
, &cup
, 1, 1);
1205 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1207 cup
= toupper (obj
->var_name
[dim_i
]);
1208 write_character (dtp
, &cup
, 1, 1);
1210 write_character (dtp
, "=", 1, 1);
1213 /* Counts the number of data output on a line, including names. */
1222 case GFC_DTYPE_REAL
:
1223 obj_size
= size_from_real_kind (len
);
1226 case GFC_DTYPE_COMPLEX
:
1227 obj_size
= size_from_complex_kind (len
);
1230 case GFC_DTYPE_CHARACTER
:
1231 obj_size
= obj
->string_length
;
1239 obj_size
= obj
->size
;
1241 /* Set the index vector and count the number of elements. */
1244 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1246 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1247 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1250 /* Main loop to output the data held in the object. */
1253 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1256 /* Build the pointer to the data value. The offset is passed by
1257 recursive calls to this function for arrays of derived types.
1258 Is NULL otherwise. */
1260 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1263 /* Check for repeat counts of intrinsic types. */
1265 if ((elem_ctr
< (nelem
- 1)) &&
1266 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1267 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1272 /* Execute a repeated output. Note the flag no_leading_blank that
1273 is used in the functions used to output the intrinsic types. */
1279 sprintf(rep_buff
, " %d*", rep_ctr
);
1280 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1281 dtp
->u
.p
.no_leading_blank
= 1;
1285 /* Output the data, if an intrinsic type, or recurse into this
1286 routine to treat derived types. */
1291 case GFC_DTYPE_INTEGER
:
1292 write_integer (dtp
, p
, len
);
1295 case GFC_DTYPE_LOGICAL
:
1296 write_logical (dtp
, p
, len
);
1299 case GFC_DTYPE_CHARACTER
:
1300 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1301 if (dtp
->u
.p
.nml_delim
== '"')
1302 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1303 if (dtp
->u
.p
.nml_delim
== '\'')
1304 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1305 write_character (dtp
, p
, 1, obj
->string_length
);
1306 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1309 case GFC_DTYPE_REAL
:
1310 write_real (dtp
, p
, len
);
1313 case GFC_DTYPE_COMPLEX
:
1314 dtp
->u
.p
.no_leading_blank
= 0;
1316 write_complex (dtp
, p
, len
, obj_size
);
1319 case GFC_DTYPE_DERIVED
:
1321 /* To treat a derived type, we need to build two strings:
1322 ext_name = the name, including qualifiers that prepends
1323 component names in the output - passed to
1325 obj_name = the derived type name with no qualifiers but %
1326 appended. This is used to identify the
1329 /* First ext_name => get length of all possible components */
1331 base_name_len
= base_name
? strlen (base_name
) : 0;
1332 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1333 ext_name
= (char*)get_mem ( base_name_len
1335 + strlen (obj
->var_name
)
1336 + obj
->var_rank
* NML_DIGITS
1339 memcpy (ext_name
, base_name
, base_name_len
);
1340 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1341 memcpy (ext_name
+ base_name_len
,
1342 obj
->var_name
+ base_var_name_len
, clen
);
1344 /* Append the qualifier. */
1346 tot_len
= base_name_len
+ clen
;
1347 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1351 ext_name
[tot_len
] = '(';
1354 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1355 tot_len
+= strlen (ext_name
+ tot_len
);
1356 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1360 ext_name
[tot_len
] = '\0';
1364 obj_name_len
= strlen (obj
->var_name
) + 1;
1365 obj_name
= get_mem (obj_name_len
+1);
1366 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1367 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1369 /* Now loop over the components. Update the component pointer
1370 with the return value from nml_write_obj => this loop jumps
1371 past nested derived types. */
1373 for (cmp
= obj
->next
;
1374 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1377 retval
= nml_write_obj (dtp
, cmp
,
1378 (index_type
)(p
- obj
->mem_pos
),
1382 free_mem (obj_name
);
1383 free_mem (ext_name
);
1387 internal_error (&dtp
->common
, "Bad type for namelist write");
1390 /* Reset the leading blank suppression, write a comma (or semi-colon)
1391 and, if 5 values have been output, write a newline and advance
1392 to column 2. Reset the repeat counter. */
1394 dtp
->u
.p
.no_leading_blank
= 0;
1395 write_character (dtp
, &semi_comma
, 1, 1);
1399 namelist_write_newline (dtp
);
1400 write_character (dtp
, " ", 1, 1);
1405 /* Cycle through and increment the index vector. */
1410 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1412 obj
->ls
[dim_i
].idx
+= nml_carry
;
1414 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1416 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1422 /* Return a pointer beyond the furthest object accessed. */
1428 /* This is the entry function for namelist writes. It outputs the name
1429 of the namelist and iterates through the namelist by calls to
1430 nml_write_obj. The call below has dummys in the arguments used in
1431 the treatment of derived types. */
1434 namelist_write (st_parameter_dt
*dtp
)
1436 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1438 index_type dummy_offset
= 0;
1440 char * dummy_name
= NULL
;
1441 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1443 /* Set the delimiter for namelist output. */
1444 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1448 dtp
->u
.p
.nml_delim
= '"';
1451 case (DELIM_APOSTROPHE
):
1452 dtp
->u
.p
.nml_delim
= '\'';
1456 dtp
->u
.p
.nml_delim
= '\0';
1460 /* Temporarily disable namelist delimters. */
1461 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1463 write_character (dtp
, "&", 1, 1);
1465 /* Write namelist name in upper case - f95 std. */
1466 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1468 c
= toupper (dtp
->namelist_name
[i
]);
1469 write_character (dtp
, &c
, 1 ,1);
1472 if (dtp
->u
.p
.ionml
!= NULL
)
1474 t1
= dtp
->u
.p
.ionml
;
1478 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1482 write_character (dtp
, " /", 1, 3);
1483 namelist_write_newline (dtp
);
1484 /* Restore the original delimiter. */
1485 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;