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);
1152 if (is_array_io (dtp
))
1155 int finished
, length
;
1157 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1159 /* Now that the current record has been padded out,
1160 determine where the next record in the array is. */
1161 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1164 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1167 /* Now seek to this record */
1168 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1170 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1172 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1176 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1180 write_character (dtp
, " ", 1, 1);
1184 static namelist_info
*
1185 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1186 namelist_info
* base
, char * base_name
)
1192 index_type obj_size
;
1196 index_type elem_ctr
;
1197 index_type obj_name_len
;
1202 char rep_buff
[NML_DIGITS
];
1203 namelist_info
* cmp
;
1204 namelist_info
* retval
= obj
->next
;
1205 size_t base_name_len
;
1206 size_t base_var_name_len
;
1208 unit_delim tmp_delim
;
1210 /* Set the character to be used to separate values
1211 to a comma or semi-colon. */
1214 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1216 /* Write namelist variable names in upper case. If a derived type,
1217 nothing is output. If a component, base and base_name are set. */
1219 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1221 namelist_write_newline (dtp
);
1222 write_character (dtp
, " ", 1, 1);
1227 len
=strlen (base
->var_name
);
1228 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1230 cup
= toupper (base_name
[dim_i
]);
1231 write_character (dtp
, &cup
, 1, 1);
1234 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1236 cup
= toupper (obj
->var_name
[dim_i
]);
1237 write_character (dtp
, &cup
, 1, 1);
1239 write_character (dtp
, "=", 1, 1);
1242 /* Counts the number of data output on a line, including names. */
1251 case GFC_DTYPE_REAL
:
1252 obj_size
= size_from_real_kind (len
);
1255 case GFC_DTYPE_COMPLEX
:
1256 obj_size
= size_from_complex_kind (len
);
1259 case GFC_DTYPE_CHARACTER
:
1260 obj_size
= obj
->string_length
;
1268 obj_size
= obj
->size
;
1270 /* Set the index vector and count the number of elements. */
1273 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1275 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1276 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1279 /* Main loop to output the data held in the object. */
1282 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1285 /* Build the pointer to the data value. The offset is passed by
1286 recursive calls to this function for arrays of derived types.
1287 Is NULL otherwise. */
1289 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1292 /* Check for repeat counts of intrinsic types. */
1294 if ((elem_ctr
< (nelem
- 1)) &&
1295 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1296 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1301 /* Execute a repeated output. Note the flag no_leading_blank that
1302 is used in the functions used to output the intrinsic types. */
1308 sprintf(rep_buff
, " %d*", rep_ctr
);
1309 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1310 dtp
->u
.p
.no_leading_blank
= 1;
1314 /* Output the data, if an intrinsic type, or recurse into this
1315 routine to treat derived types. */
1320 case GFC_DTYPE_INTEGER
:
1321 write_integer (dtp
, p
, len
);
1324 case GFC_DTYPE_LOGICAL
:
1325 write_logical (dtp
, p
, len
);
1328 case GFC_DTYPE_CHARACTER
:
1329 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1330 if (dtp
->u
.p
.nml_delim
== '"')
1331 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1332 if (dtp
->u
.p
.nml_delim
== '\'')
1333 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1334 write_character (dtp
, p
, 1, obj
->string_length
);
1335 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1338 case GFC_DTYPE_REAL
:
1339 write_real (dtp
, p
, len
);
1342 case GFC_DTYPE_COMPLEX
:
1343 dtp
->u
.p
.no_leading_blank
= 0;
1345 write_complex (dtp
, p
, len
, obj_size
);
1348 case GFC_DTYPE_DERIVED
:
1350 /* To treat a derived type, we need to build two strings:
1351 ext_name = the name, including qualifiers that prepends
1352 component names in the output - passed to
1354 obj_name = the derived type name with no qualifiers but %
1355 appended. This is used to identify the
1358 /* First ext_name => get length of all possible components */
1360 base_name_len
= base_name
? strlen (base_name
) : 0;
1361 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1362 ext_name
= (char*)get_mem ( base_name_len
1364 + strlen (obj
->var_name
)
1365 + obj
->var_rank
* NML_DIGITS
1368 memcpy (ext_name
, base_name
, base_name_len
);
1369 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1370 memcpy (ext_name
+ base_name_len
,
1371 obj
->var_name
+ base_var_name_len
, clen
);
1373 /* Append the qualifier. */
1375 tot_len
= base_name_len
+ clen
;
1376 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1380 ext_name
[tot_len
] = '(';
1383 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1384 tot_len
+= strlen (ext_name
+ tot_len
);
1385 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1389 ext_name
[tot_len
] = '\0';
1393 obj_name_len
= strlen (obj
->var_name
) + 1;
1394 obj_name
= get_mem (obj_name_len
+1);
1395 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1396 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1398 /* Now loop over the components. Update the component pointer
1399 with the return value from nml_write_obj => this loop jumps
1400 past nested derived types. */
1402 for (cmp
= obj
->next
;
1403 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1406 retval
= nml_write_obj (dtp
, cmp
,
1407 (index_type
)(p
- obj
->mem_pos
),
1411 free_mem (obj_name
);
1412 free_mem (ext_name
);
1416 internal_error (&dtp
->common
, "Bad type for namelist write");
1419 /* Reset the leading blank suppression, write a comma (or semi-colon)
1420 and, if 5 values have been output, write a newline and advance
1421 to column 2. Reset the repeat counter. */
1423 dtp
->u
.p
.no_leading_blank
= 0;
1424 write_character (dtp
, &semi_comma
, 1, 1);
1428 namelist_write_newline (dtp
);
1429 write_character (dtp
, " ", 1, 1);
1434 /* Cycle through and increment the index vector. */
1439 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1441 obj
->ls
[dim_i
].idx
+= nml_carry
;
1443 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1445 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1451 /* Return a pointer beyond the furthest object accessed. */
1457 /* This is the entry function for namelist writes. It outputs the name
1458 of the namelist and iterates through the namelist by calls to
1459 nml_write_obj. The call below has dummys in the arguments used in
1460 the treatment of derived types. */
1463 namelist_write (st_parameter_dt
*dtp
)
1465 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1467 index_type dummy_offset
= 0;
1469 char * dummy_name
= NULL
;
1470 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1472 /* Set the delimiter for namelist output. */
1473 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1475 dtp
->u
.p
.nml_delim
= tmp_delim
== DELIM_APOSTROPHE
? '\'' : '"';
1477 /* Temporarily disable namelist delimters. */
1478 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1480 write_character (dtp
, "&", 1, 1);
1482 /* Write namelist name in upper case - f95 std. */
1483 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1485 c
= toupper (dtp
->namelist_name
[i
]);
1486 write_character (dtp
, &c
, 1 ,1);
1489 if (dtp
->u
.p
.ionml
!= NULL
)
1491 t1
= dtp
->u
.p
.ionml
;
1495 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1499 namelist_write_newline (dtp
);
1500 write_character (dtp
, " /", 1, 2);
1501 /* Restore the original delimiter. */
1502 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;