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. */
69 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
70 switch (dtp
->u
.p
.delim_status
)
72 case DELIM_APOSTROPHE
:
83 /* Now process the remaining characters, one at a time. */
84 for (j
= k
; j
< src_len
; j
++)
88 /* Handle delimiters if any. */
89 if (c
== d
&& d
!= ' ')
91 p
= write_block (dtp
, 2);
98 p
= write_block (dtp
, 1);
102 *p
= c
> 255 ? '?' : (uchar
) c
;
107 /* Write out UTF-8 converted from char4. */
110 write_utf8_char4 (st_parameter_dt
*dtp
, gfc_char4_t
*source
,
111 int src_len
, int w_len
)
116 static const uchar masks
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
117 static const uchar limits
[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
121 /* Take care of preceding blanks. */
125 p
= write_block (dtp
, k
);
131 /* Get ready to handle delimiters if needed. */
133 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
134 switch (dtp
->u
.p
.delim_status
)
136 case DELIM_APOSTROPHE
:
147 /* Now process the remaining characters, one at a time. */
148 for (j
= k
; j
< src_len
; j
++)
153 /* Handle the delimiters if any. */
154 if (c
== d
&& d
!= ' ')
156 p
= write_block (dtp
, 2);
163 p
= write_block (dtp
, 1);
171 /* Convert to UTF-8 sequence. */
177 *--q
= ((c
& 0x3F) | 0x80);
181 while (c
>= 0x3F || (c
& limits
[nbytes
-1]));
183 *--q
= (c
| masks
[nbytes
-1]);
185 p
= write_block (dtp
, nbytes
);
197 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
202 wlen
= f
->u
.string
.length
< 0
203 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
204 ? len
: f
->u
.string
.length
;
207 /* If this is formatted STREAM IO convert any embedded line feed characters
208 to CR_LF on systems that use that sequence for newlines. See F2003
209 Standard sections 10.6.3 and 9.9 for further information. */
210 if (is_stream_io (dtp
))
212 const char crlf
[] = "\r\n";
216 /* Write out any padding if needed. */
219 p
= write_block (dtp
, wlen
- len
);
222 memset (p
, ' ', wlen
- len
);
225 /* Scan the source string looking for '\n' and convert it if found. */
226 for (i
= 0; i
< wlen
; i
++)
228 if (source
[i
] == '\n')
230 /* Write out the previously scanned characters in the string. */
233 p
= write_block (dtp
, bytes
);
236 memcpy (p
, &source
[q
], bytes
);
241 /* Write out the CR_LF sequence. */
243 p
= write_block (dtp
, 2);
252 /* Write out any remaining bytes if no LF was found. */
255 p
= write_block (dtp
, bytes
);
258 memcpy (p
, &source
[q
], bytes
);
264 p
= write_block (dtp
, wlen
);
269 memcpy (p
, source
, wlen
);
272 memset (p
, ' ', wlen
- len
);
273 memcpy (p
+ wlen
- len
, source
, len
);
281 /* The primary difference between write_a_char4 and write_a is that we have to
282 deal with writing from the first byte of the 4-byte character and pay
283 attention to the most significant bytes. For ENCODING="default" write the
284 lowest significant byte. If the 3 most significant bytes contain
285 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
286 to the UTF-8 encoded string before writing out. */
289 write_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
294 wlen
= f
->u
.string
.length
< 0
295 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
296 ? len
: f
->u
.string
.length
;
298 q
= (gfc_char4_t
*) source
;
300 /* If this is formatted STREAM IO convert any embedded line feed characters
301 to CR_LF on systems that use that sequence for newlines. See F2003
302 Standard sections 10.6.3 and 9.9 for further information. */
303 if (is_stream_io (dtp
))
305 const char crlf
[] = "\r\n";
310 /* Write out any padding if needed. */
314 p
= write_block (dtp
, wlen
- len
);
317 memset (p
, ' ', wlen
- len
);
320 /* Scan the source string looking for '\n' and convert it if found. */
321 qq
= (gfc_char4_t
*) source
;
322 for (i
= 0; i
< wlen
; i
++)
326 /* Write out the previously scanned characters in the string. */
329 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
330 write_utf8_char4 (dtp
, q
, bytes
, 0);
332 write_default_char4 (dtp
, q
, bytes
, 0);
336 /* Write out the CR_LF sequence. */
337 write_default_char4 (dtp
, crlf
, 2, 0);
343 /* Write out any remaining bytes if no LF was found. */
346 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
347 write_utf8_char4 (dtp
, q
, bytes
, 0);
349 write_default_char4 (dtp
, q
, bytes
, 0);
355 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
356 write_utf8_char4 (dtp
, q
, len
, wlen
);
358 write_default_char4 (dtp
, q
, len
, wlen
);
365 static GFC_INTEGER_LARGEST
366 extract_int (const void *p
, int len
)
368 GFC_INTEGER_LARGEST i
= 0;
378 memcpy ((void *) &tmp
, p
, len
);
385 memcpy ((void *) &tmp
, p
, len
);
392 memcpy ((void *) &tmp
, p
, len
);
399 memcpy ((void *) &tmp
, p
, len
);
403 #ifdef HAVE_GFC_INTEGER_16
407 memcpy ((void *) &tmp
, p
, len
);
413 internal_error (NULL
, "bad integer kind");
419 static GFC_UINTEGER_LARGEST
420 extract_uint (const void *p
, int len
)
422 GFC_UINTEGER_LARGEST i
= 0;
432 memcpy ((void *) &tmp
, p
, len
);
433 i
= (GFC_UINTEGER_1
) tmp
;
439 memcpy ((void *) &tmp
, p
, len
);
440 i
= (GFC_UINTEGER_2
) tmp
;
446 memcpy ((void *) &tmp
, p
, len
);
447 i
= (GFC_UINTEGER_4
) tmp
;
453 memcpy ((void *) &tmp
, p
, len
);
454 i
= (GFC_UINTEGER_8
) tmp
;
457 #ifdef HAVE_GFC_INTEGER_16
461 memcpy ((void *) &tmp
, p
, len
);
462 i
= (GFC_UINTEGER_16
) tmp
;
467 internal_error (NULL
, "bad integer kind");
475 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
479 GFC_INTEGER_LARGEST n
;
481 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
483 p
= write_block (dtp
, wlen
);
487 memset (p
, ' ', wlen
- 1);
488 n
= extract_int (source
, len
);
489 p
[wlen
- 1] = (n
) ? 'T' : 'F';
494 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
495 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
497 GFC_UINTEGER_LARGEST n
= 0;
498 int w
, m
, digits
, nzero
, nblank
;
501 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
506 n
= extract_uint (source
, len
);
510 if (m
== 0 && n
== 0)
515 p
= write_block (dtp
, w
);
523 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
526 /* Select a width if none was specified. The idea here is to always
530 w
= ((digits
< m
) ? m
: digits
);
532 p
= write_block (dtp
, w
);
540 /* See if things will work. */
542 nblank
= w
- (nzero
+ digits
);
551 if (!dtp
->u
.p
.no_leading_blank
)
553 memset (p
, ' ', nblank
);
555 memset (p
, '0', nzero
);
557 memcpy (p
, q
, digits
);
561 memset (p
, '0', nzero
);
563 memcpy (p
, q
, digits
);
565 memset (p
, ' ', nblank
);
566 dtp
->u
.p
.no_leading_blank
= 0;
574 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
576 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
578 GFC_INTEGER_LARGEST n
= 0;
579 int w
, m
, digits
, nsign
, nzero
, nblank
;
583 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
586 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
588 n
= extract_int (source
, len
);
591 if (m
== 0 && n
== 0)
596 p
= write_block (dtp
, w
);
604 sign
= calculate_sign (dtp
, n
< 0);
608 nsign
= sign
== S_NONE
? 0 : 1;
609 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
613 /* Select a width if none was specified. The idea here is to always
617 w
= ((digits
< m
) ? m
: digits
) + nsign
;
619 p
= write_block (dtp
, w
);
627 /* See if things will work. */
629 nblank
= w
- (nsign
+ nzero
+ digits
);
637 memset (p
, ' ', nblank
);
652 memset (p
, '0', nzero
);
655 memcpy (p
, q
, digits
);
662 /* Convert unsigned octal to ascii. */
665 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
669 assert (len
>= GFC_OTOA_BUF_SIZE
);
674 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
679 *--p
= '0' + (n
& 7);
687 /* Convert unsigned binary to ascii. */
690 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
694 assert (len
>= GFC_BTOA_BUF_SIZE
);
699 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
704 *--p
= '0' + (n
& 1);
713 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
715 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
720 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
722 write_int (dtp
, f
, p
, len
, btoa
);
727 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
729 write_int (dtp
, f
, p
, len
, otoa
);
733 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
735 write_int (dtp
, f
, p
, len
, xtoa
);
740 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
742 write_float (dtp
, f
, p
, len
);
747 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
749 write_float (dtp
, f
, p
, len
);
754 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
756 write_float (dtp
, f
, p
, len
);
761 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
763 write_float (dtp
, f
, p
, len
);
768 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
770 write_float (dtp
, f
, p
, len
);
774 /* Take care of the X/TR descriptor. */
777 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
781 p
= write_block (dtp
, len
);
786 memset (&p
[len
- nspaces
], ' ', nspaces
);
790 /* List-directed writing. */
793 /* Write a single character to the output. Returns nonzero if
794 something goes wrong. */
797 write_char (st_parameter_dt
*dtp
, char c
)
801 p
= write_block (dtp
, 1);
811 /* Write a list-directed logical value. */
814 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
816 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
820 /* Write a list-directed integer value. */
823 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
829 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
831 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
860 p
= write_block (dtp
, width
);
863 if (dtp
->u
.p
.no_leading_blank
)
865 memcpy (p
, q
, digits
);
866 memset (p
+ digits
, ' ', width
- digits
);
870 memset (p
, ' ', width
- digits
);
871 memcpy (p
+ width
- digits
, q
, digits
);
876 /* Write a list-directed string. We have to worry about delimiting
877 the strings if the file has been opened in that mode. */
880 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
886 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
887 switch (dtp
->u
.p
.delim_status
)
889 case DELIM_APOSTROPHE
:
908 for (i
= 0; i
< length
; i
++)
913 p
= write_block (dtp
, length
+ extra
);
918 memcpy (p
, source
, length
);
923 for (i
= 0; i
< length
; i
++)
937 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
938 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
940 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
944 p
= write_block (dtp
, 1);
947 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
948 write_utf8_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
950 write_default_char4 (dtp
, (gfc_char4_t
*) source
, length
, 0);
952 p
= write_block (dtp
, 1);
959 /* Set an fnode to default format. */
962 set_fnode_default (st_parameter_dt
*dtp
, fnode
*f
, int length
)
988 internal_error (&dtp
->common
, "bad real kind");
992 /* Output a real number with default format.
993 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
994 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
997 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
1000 int org_scale
= dtp
->u
.p
.scale_factor
;
1001 dtp
->u
.p
.scale_factor
= 1;
1002 set_fnode_default (dtp
, &f
, length
);
1003 write_float (dtp
, &f
, source
, length
);
1004 dtp
->u
.p
.scale_factor
= org_scale
;
1009 write_real_g0 (st_parameter_dt
*dtp
, const char *source
, int length
, int d
)
1012 int org_scale
= dtp
->u
.p
.scale_factor
;
1013 dtp
->u
.p
.scale_factor
= 1;
1014 set_fnode_default (dtp
, &f
, length
);
1017 write_float (dtp
, &f
, source
, length
);
1018 dtp
->u
.p
.scale_factor
= org_scale
;
1023 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1025 char semi_comma
= ',';
1027 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
1028 semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
1030 if (write_char (dtp
, '('))
1032 write_real (dtp
, source
, kind
);
1034 if (write_char (dtp
, semi_comma
))
1036 write_real (dtp
, source
+ size
/ 2, kind
);
1038 write_char (dtp
, ')');
1042 /* Write the separator between items. */
1045 write_separator (st_parameter_dt
*dtp
)
1049 p
= write_block (dtp
, options
.separator_len
);
1053 memcpy (p
, options
.separator
, options
.separator_len
);
1057 /* Write an item with list formatting.
1058 TODO: handle skipping to the next record correctly, particularly
1062 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1065 if (dtp
->u
.p
.current_unit
== NULL
)
1068 if (dtp
->u
.p
.first_item
)
1070 dtp
->u
.p
.first_item
= 0;
1071 write_char (dtp
, ' ');
1075 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
1077 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1078 dtp
->u
.p
.delim_status
!= DELIM_NONE
)
1079 write_separator (dtp
);
1083 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
)
1084 write_separator (dtp
);
1091 write_integer (dtp
, p
, kind
);
1094 write_logical (dtp
, p
, kind
);
1097 write_character (dtp
, p
, kind
, size
);
1100 write_real (dtp
, p
, kind
);
1103 write_complex (dtp
, p
, kind
, size
);
1106 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1109 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1114 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1115 size_t size
, size_t nelems
)
1119 size_t stride
= type
== BT_CHARACTER
?
1120 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1124 /* Big loop over all the elements. */
1125 for (elem
= 0; elem
< nelems
; elem
++)
1127 dtp
->u
.p
.item_count
++;
1128 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1134 nml_write_obj writes a namelist object to the output stream. It is called
1135 recursively for derived type components:
1136 obj = is the namelist_info for the current object.
1137 offset = the offset relative to the address held by the object for
1138 derived type arrays.
1139 base = is the namelist_info of the derived type, when obj is a
1141 base_name = the full name for a derived type, including qualifiers
1143 The returned value is a pointer to the object beyond the last one
1144 accessed, including nested derived types. Notice that the namelist is
1145 a linear linked list of objects, including derived types and their
1146 components. A tree, of sorts, is implied by the compound names of
1147 the derived type components and this is how this function recurses through
1150 /* A generous estimate of the number of characters needed to print
1151 repeat counts and indices, including commas, asterices and brackets. */
1153 #define NML_DIGITS 20
1156 namelist_write_newline (st_parameter_dt
*dtp
)
1158 if (!is_internal_unit (dtp
))
1161 write_character (dtp
, "\r\n", 1, 2);
1163 write_character (dtp
, "\n", 1, 1);
1167 write_character (dtp
, " ", 1, 1);
1171 static namelist_info
*
1172 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1173 namelist_info
* base
, char * base_name
)
1179 index_type obj_size
;
1183 index_type elem_ctr
;
1184 index_type obj_name_len
;
1189 char rep_buff
[NML_DIGITS
];
1190 namelist_info
* cmp
;
1191 namelist_info
* retval
= obj
->next
;
1192 size_t base_name_len
;
1193 size_t base_var_name_len
;
1195 unit_delim tmp_delim
;
1197 /* Set the character to be used to separate values
1198 to a comma or semi-colon. */
1200 char semi_comma
= ',';
1202 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
1203 semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
1205 /* Write namelist variable names in upper case. If a derived type,
1206 nothing is output. If a component, base and base_name are set. */
1208 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1210 namelist_write_newline (dtp
);
1211 write_character (dtp
, " ", 1, 1);
1216 len
=strlen (base
->var_name
);
1217 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1219 cup
= toupper (base_name
[dim_i
]);
1220 write_character (dtp
, &cup
, 1, 1);
1223 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1225 cup
= toupper (obj
->var_name
[dim_i
]);
1226 write_character (dtp
, &cup
, 1, 1);
1228 write_character (dtp
, "=", 1, 1);
1231 /* Counts the number of data output on a line, including names. */
1240 case GFC_DTYPE_REAL
:
1241 obj_size
= size_from_real_kind (len
);
1244 case GFC_DTYPE_COMPLEX
:
1245 obj_size
= size_from_complex_kind (len
);
1248 case GFC_DTYPE_CHARACTER
:
1249 obj_size
= obj
->string_length
;
1257 obj_size
= obj
->size
;
1259 /* Set the index vector and count the number of elements. */
1262 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1264 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1265 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1268 /* Main loop to output the data held in the object. */
1271 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1274 /* Build the pointer to the data value. The offset is passed by
1275 recursive calls to this function for arrays of derived types.
1276 Is NULL otherwise. */
1278 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1281 /* Check for repeat counts of intrinsic types. */
1283 if ((elem_ctr
< (nelem
- 1)) &&
1284 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1285 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1290 /* Execute a repeated output. Note the flag no_leading_blank that
1291 is used in the functions used to output the intrinsic types. */
1297 sprintf(rep_buff
, " %d*", rep_ctr
);
1298 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1299 dtp
->u
.p
.no_leading_blank
= 1;
1303 /* Output the data, if an intrinsic type, or recurse into this
1304 routine to treat derived types. */
1309 case GFC_DTYPE_INTEGER
:
1310 write_integer (dtp
, p
, len
);
1313 case GFC_DTYPE_LOGICAL
:
1314 write_logical (dtp
, p
, len
);
1317 case GFC_DTYPE_CHARACTER
:
1318 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
1320 tmp_delim
= dtp
->u
.p
.delim_status
;
1321 if (dtp
->u
.p
.nml_delim
== '"')
1322 dtp
->u
.p
.delim_status
= DELIM_QUOTE
;
1323 if (dtp
->u
.p
.nml_delim
== '\'')
1324 dtp
->u
.p
.delim_status
= DELIM_APOSTROPHE
;
1325 write_character (dtp
, p
, 1, obj
->string_length
);
1326 dtp
->u
.p
.delim_status
= tmp_delim
;
1329 write_character (dtp
, p
, 1, obj
->string_length
);
1332 case GFC_DTYPE_REAL
:
1333 write_real (dtp
, p
, len
);
1336 case GFC_DTYPE_COMPLEX
:
1337 dtp
->u
.p
.no_leading_blank
= 0;
1339 write_complex (dtp
, p
, len
, obj_size
);
1342 case GFC_DTYPE_DERIVED
:
1344 /* To treat a derived type, we need to build two strings:
1345 ext_name = the name, including qualifiers that prepends
1346 component names in the output - passed to
1348 obj_name = the derived type name with no qualifiers but %
1349 appended. This is used to identify the
1352 /* First ext_name => get length of all possible components */
1354 base_name_len
= base_name
? strlen (base_name
) : 0;
1355 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1356 ext_name
= (char*)get_mem ( base_name_len
1358 + strlen (obj
->var_name
)
1359 + obj
->var_rank
* NML_DIGITS
1362 memcpy (ext_name
, base_name
, base_name_len
);
1363 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1364 memcpy (ext_name
+ base_name_len
,
1365 obj
->var_name
+ base_var_name_len
, clen
);
1367 /* Append the qualifier. */
1369 tot_len
= base_name_len
+ clen
;
1370 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1374 ext_name
[tot_len
] = '(';
1377 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1378 tot_len
+= strlen (ext_name
+ tot_len
);
1379 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1383 ext_name
[tot_len
] = '\0';
1387 obj_name_len
= strlen (obj
->var_name
) + 1;
1388 obj_name
= get_mem (obj_name_len
+1);
1389 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1390 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1392 /* Now loop over the components. Update the component pointer
1393 with the return value from nml_write_obj => this loop jumps
1394 past nested derived types. */
1396 for (cmp
= obj
->next
;
1397 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1400 retval
= nml_write_obj (dtp
, cmp
,
1401 (index_type
)(p
- obj
->mem_pos
),
1405 free_mem (obj_name
);
1406 free_mem (ext_name
);
1410 internal_error (&dtp
->common
, "Bad type for namelist write");
1413 /* Reset the leading blank suppression, write a comma (or semi-colon)
1414 and, if 5 values have been output, write a newline and advance
1415 to column 2. Reset the repeat counter. */
1417 dtp
->u
.p
.no_leading_blank
= 0;
1418 write_character (dtp
, &semi_comma
, 1, 1);
1422 namelist_write_newline (dtp
);
1423 write_character (dtp
, " ", 1, 1);
1428 /* Cycle through and increment the index vector. */
1433 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1435 obj
->ls
[dim_i
].idx
+= nml_carry
;
1437 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1439 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1445 /* Return a pointer beyond the furthest object accessed. */
1451 /* This is the entry function for namelist writes. It outputs the name
1452 of the namelist and iterates through the namelist by calls to
1453 nml_write_obj. The call below has dummys in the arguments used in
1454 the treatment of derived types. */
1457 namelist_write (st_parameter_dt
*dtp
)
1459 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1461 index_type dummy_offset
= 0;
1463 char * dummy_name
= NULL
;
1464 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1466 /* Set the delimiter for namelist output. */
1467 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
1469 tmp_delim
= dtp
->u
.p
.delim_status
;
1473 dtp
->u
.p
.nml_delim
= '"';
1476 case (DELIM_APOSTROPHE
):
1477 dtp
->u
.p
.nml_delim
= '\'';
1481 dtp
->u
.p
.nml_delim
= '\0';
1485 /* Temporarily disable namelist delimters. */
1486 dtp
->u
.p
.delim_status
= DELIM_NONE
;
1488 write_character (dtp
, "&", 1, 1);
1490 /* Write namelist name in upper case - f95 std. */
1491 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1493 c
= toupper (dtp
->namelist_name
[i
]);
1494 write_character (dtp
, &c
, 1 ,1);
1497 if (dtp
->u
.p
.ionml
!= NULL
)
1499 t1
= dtp
->u
.p
.ionml
;
1503 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1507 write_character (dtp
, " /", 1, 3);
1508 namelist_write_newline (dtp
);
1509 /* Restore the original delimiter. */
1510 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
1511 dtp
->u
.p
.delim_status
= tmp_delim
;