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);
603 nsign
= sign
== S_NONE
? 0 : 1;
605 /* conv calls gfc_itoa which sets the negative sign needed
606 by write_integer. The sign '+' or '-' is set below based on sign
607 calculated above, so we just point past the sign in the string
608 before proceeding to avoid double signs in corner cases.
610 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
616 /* Select a width if none was specified. The idea here is to always
620 w
= ((digits
< m
) ? m
: digits
) + nsign
;
622 p
= write_block (dtp
, w
);
630 /* See if things will work. */
632 nblank
= w
- (nsign
+ nzero
+ digits
);
640 memset (p
, ' ', nblank
);
655 memset (p
, '0', nzero
);
658 memcpy (p
, q
, digits
);
665 /* Convert unsigned octal to ascii. */
668 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
672 assert (len
>= GFC_OTOA_BUF_SIZE
);
677 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
682 *--p
= '0' + (n
& 7);
690 /* Convert unsigned binary to ascii. */
693 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
697 assert (len
>= GFC_BTOA_BUF_SIZE
);
702 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
707 *--p
= '0' + (n
& 1);
716 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
718 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
723 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
725 write_int (dtp
, f
, p
, len
, btoa
);
730 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
732 write_int (dtp
, f
, p
, len
, otoa
);
736 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
738 write_int (dtp
, f
, p
, len
, xtoa
);
743 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
745 write_float (dtp
, f
, p
, len
);
750 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
752 write_float (dtp
, f
, p
, len
);
757 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
759 write_float (dtp
, f
, p
, len
);
764 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
766 write_float (dtp
, f
, p
, len
);
771 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
773 write_float (dtp
, f
, p
, len
);
777 /* Take care of the X/TR descriptor. */
780 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
784 p
= write_block (dtp
, len
);
787 if (nspaces
> 0 && len
- nspaces
>= 0)
788 memset (&p
[len
- nspaces
], ' ', nspaces
);
792 /* List-directed writing. */
795 /* Write a single character to the output. Returns nonzero if
796 something goes wrong. */
799 write_char (st_parameter_dt
*dtp
, char c
)
803 p
= write_block (dtp
, 1);
813 /* Write a list-directed logical value. */
816 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
818 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
822 /* Write a list-directed integer value. */
825 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
831 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
833 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
862 p
= write_block (dtp
, width
);
865 if (dtp
->u
.p
.no_leading_blank
)
867 memcpy (p
, q
, digits
);
868 memset (p
+ digits
, ' ', width
- digits
);
872 memset (p
, ' ', width
- digits
);
873 memcpy (p
+ width
- digits
, q
, digits
);
878 /* Write a list-directed string. We have to worry about delimiting
879 the strings if the file has been opened in that mode. */
882 write_character (st_parameter_dt
*dtp
, const char *source
, int kind
, int length
)
887 switch (dtp
->u
.p
.current_unit
->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 set_fnode_default (dtp
, &f
, length
);
1015 dtp
->u
.p
.g0_no_blanks
= 1;
1016 write_float (dtp
, &f
, source
, length
);
1017 dtp
->u
.p
.g0_no_blanks
= 0;
1022 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
1025 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1027 if (write_char (dtp
, '('))
1029 write_real (dtp
, source
, kind
);
1031 if (write_char (dtp
, semi_comma
))
1033 write_real (dtp
, source
+ size
/ 2, kind
);
1035 write_char (dtp
, ')');
1039 /* Write the separator between items. */
1042 write_separator (st_parameter_dt
*dtp
)
1046 p
= write_block (dtp
, options
.separator_len
);
1050 memcpy (p
, options
.separator
, options
.separator_len
);
1054 /* Write an item with list formatting.
1055 TODO: handle skipping to the next record correctly, particularly
1059 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1062 if (dtp
->u
.p
.current_unit
== NULL
)
1065 if (dtp
->u
.p
.first_item
)
1067 dtp
->u
.p
.first_item
= 0;
1068 write_char (dtp
, ' ');
1072 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
1073 dtp
->u
.p
.current_unit
->delim_status
!= DELIM_NONE
)
1074 write_separator (dtp
);
1080 write_integer (dtp
, p
, kind
);
1083 write_logical (dtp
, p
, kind
);
1086 write_character (dtp
, p
, kind
, size
);
1089 write_real (dtp
, p
, kind
);
1092 write_complex (dtp
, p
, kind
, size
);
1095 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
1098 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
1103 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1104 size_t size
, size_t nelems
)
1108 size_t stride
= type
== BT_CHARACTER
?
1109 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1113 /* Big loop over all the elements. */
1114 for (elem
= 0; elem
< nelems
; elem
++)
1116 dtp
->u
.p
.item_count
++;
1117 list_formatted_write_scalar (dtp
, type
, tmp
+ elem
* stride
, kind
, size
);
1123 nml_write_obj writes a namelist object to the output stream. It is called
1124 recursively for derived type components:
1125 obj = is the namelist_info for the current object.
1126 offset = the offset relative to the address held by the object for
1127 derived type arrays.
1128 base = is the namelist_info of the derived type, when obj is a
1130 base_name = the full name for a derived type, including qualifiers
1132 The returned value is a pointer to the object beyond the last one
1133 accessed, including nested derived types. Notice that the namelist is
1134 a linear linked list of objects, including derived types and their
1135 components. A tree, of sorts, is implied by the compound names of
1136 the derived type components and this is how this function recurses through
1139 /* A generous estimate of the number of characters needed to print
1140 repeat counts and indices, including commas, asterices and brackets. */
1142 #define NML_DIGITS 20
1145 namelist_write_newline (st_parameter_dt
*dtp
)
1147 if (!is_internal_unit (dtp
))
1150 write_character (dtp
, "\r\n", 1, 2);
1152 write_character (dtp
, "\n", 1, 1);
1157 if (is_array_io (dtp
))
1160 int finished
, length
;
1162 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1164 /* Now that the current record has been padded out,
1165 determine where the next record in the array is. */
1166 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
1169 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1172 /* Now seek to this record */
1173 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1175 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
1177 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
1181 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1185 write_character (dtp
, " ", 1, 1);
1189 static namelist_info
*
1190 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
1191 namelist_info
* base
, char * base_name
)
1197 index_type obj_size
;
1201 index_type elem_ctr
;
1202 index_type obj_name_len
;
1207 char rep_buff
[NML_DIGITS
];
1208 namelist_info
* cmp
;
1209 namelist_info
* retval
= obj
->next
;
1210 size_t base_name_len
;
1211 size_t base_var_name_len
;
1213 unit_delim tmp_delim
;
1215 /* Set the character to be used to separate values
1216 to a comma or semi-colon. */
1219 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_POINT
? ',' : ';';
1221 /* Write namelist variable names in upper case. If a derived type,
1222 nothing is output. If a component, base and base_name are set. */
1224 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1226 namelist_write_newline (dtp
);
1227 write_character (dtp
, " ", 1, 1);
1232 len
=strlen (base
->var_name
);
1233 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
1235 cup
= toupper (base_name
[dim_i
]);
1236 write_character (dtp
, &cup
, 1, 1);
1239 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
1241 cup
= toupper (obj
->var_name
[dim_i
]);
1242 write_character (dtp
, &cup
, 1, 1);
1244 write_character (dtp
, "=", 1, 1);
1247 /* Counts the number of data output on a line, including names. */
1256 case GFC_DTYPE_REAL
:
1257 obj_size
= size_from_real_kind (len
);
1260 case GFC_DTYPE_COMPLEX
:
1261 obj_size
= size_from_complex_kind (len
);
1264 case GFC_DTYPE_CHARACTER
:
1265 obj_size
= obj
->string_length
;
1273 obj_size
= obj
->size
;
1275 /* Set the index vector and count the number of elements. */
1278 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1280 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1281 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1284 /* Main loop to output the data held in the object. */
1287 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1290 /* Build the pointer to the data value. The offset is passed by
1291 recursive calls to this function for arrays of derived types.
1292 Is NULL otherwise. */
1294 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1297 /* Check for repeat counts of intrinsic types. */
1299 if ((elem_ctr
< (nelem
- 1)) &&
1300 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1301 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1306 /* Execute a repeated output. Note the flag no_leading_blank that
1307 is used in the functions used to output the intrinsic types. */
1313 sprintf(rep_buff
, " %d*", rep_ctr
);
1314 write_character (dtp
, rep_buff
, 1, strlen (rep_buff
));
1315 dtp
->u
.p
.no_leading_blank
= 1;
1319 /* Output the data, if an intrinsic type, or recurse into this
1320 routine to treat derived types. */
1325 case GFC_DTYPE_INTEGER
:
1326 write_integer (dtp
, p
, len
);
1329 case GFC_DTYPE_LOGICAL
:
1330 write_logical (dtp
, p
, len
);
1333 case GFC_DTYPE_CHARACTER
:
1334 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1335 if (dtp
->u
.p
.nml_delim
== '"')
1336 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
1337 if (dtp
->u
.p
.nml_delim
== '\'')
1338 dtp
->u
.p
.current_unit
->delim_status
= DELIM_APOSTROPHE
;
1339 write_character (dtp
, p
, 1, obj
->string_length
);
1340 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;
1343 case GFC_DTYPE_REAL
:
1344 write_real (dtp
, p
, len
);
1347 case GFC_DTYPE_COMPLEX
:
1348 dtp
->u
.p
.no_leading_blank
= 0;
1350 write_complex (dtp
, p
, len
, obj_size
);
1353 case GFC_DTYPE_DERIVED
:
1355 /* To treat a derived type, we need to build two strings:
1356 ext_name = the name, including qualifiers that prepends
1357 component names in the output - passed to
1359 obj_name = the derived type name with no qualifiers but %
1360 appended. This is used to identify the
1363 /* First ext_name => get length of all possible components */
1365 base_name_len
= base_name
? strlen (base_name
) : 0;
1366 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1367 ext_name
= (char*)get_mem ( base_name_len
1369 + strlen (obj
->var_name
)
1370 + obj
->var_rank
* NML_DIGITS
1373 memcpy (ext_name
, base_name
, base_name_len
);
1374 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1375 memcpy (ext_name
+ base_name_len
,
1376 obj
->var_name
+ base_var_name_len
, clen
);
1378 /* Append the qualifier. */
1380 tot_len
= base_name_len
+ clen
;
1381 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1385 ext_name
[tot_len
] = '(';
1388 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1389 tot_len
+= strlen (ext_name
+ tot_len
);
1390 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1394 ext_name
[tot_len
] = '\0';
1398 obj_name_len
= strlen (obj
->var_name
) + 1;
1399 obj_name
= get_mem (obj_name_len
+1);
1400 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1401 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1403 /* Now loop over the components. Update the component pointer
1404 with the return value from nml_write_obj => this loop jumps
1405 past nested derived types. */
1407 for (cmp
= obj
->next
;
1408 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1411 retval
= nml_write_obj (dtp
, cmp
,
1412 (index_type
)(p
- obj
->mem_pos
),
1416 free_mem (obj_name
);
1417 free_mem (ext_name
);
1421 internal_error (&dtp
->common
, "Bad type for namelist write");
1424 /* Reset the leading blank suppression, write a comma (or semi-colon)
1425 and, if 5 values have been output, write a newline and advance
1426 to column 2. Reset the repeat counter. */
1428 dtp
->u
.p
.no_leading_blank
= 0;
1429 write_character (dtp
, &semi_comma
, 1, 1);
1433 namelist_write_newline (dtp
);
1434 write_character (dtp
, " ", 1, 1);
1439 /* Cycle through and increment the index vector. */
1444 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1446 obj
->ls
[dim_i
].idx
+= nml_carry
;
1448 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1450 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1456 /* Return a pointer beyond the furthest object accessed. */
1462 /* This is the entry function for namelist writes. It outputs the name
1463 of the namelist and iterates through the namelist by calls to
1464 nml_write_obj. The call below has dummys in the arguments used in
1465 the treatment of derived types. */
1468 namelist_write (st_parameter_dt
*dtp
)
1470 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1472 index_type dummy_offset
= 0;
1474 char * dummy_name
= NULL
;
1475 unit_delim tmp_delim
= DELIM_UNSPECIFIED
;
1477 /* Set the delimiter for namelist output. */
1478 tmp_delim
= dtp
->u
.p
.current_unit
->delim_status
;
1480 dtp
->u
.p
.nml_delim
= tmp_delim
== DELIM_APOSTROPHE
? '\'' : '"';
1482 /* Temporarily disable namelist delimters. */
1483 dtp
->u
.p
.current_unit
->delim_status
= DELIM_NONE
;
1485 write_character (dtp
, "&", 1, 1);
1487 /* Write namelist name in upper case - f95 std. */
1488 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1490 c
= toupper (dtp
->namelist_name
[i
]);
1491 write_character (dtp
, &c
, 1 ,1);
1494 if (dtp
->u
.p
.ionml
!= NULL
)
1496 t1
= dtp
->u
.p
.ionml
;
1500 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1504 namelist_write_newline (dtp
);
1505 write_character (dtp
, " /", 1, 2);
1506 /* Restore the original delimiter. */
1507 dtp
->u
.p
.current_unit
->delim_status
= tmp_delim
;