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. */
39 #define star_fill(p, n) memset(p, '*', n)
41 #include "write_float.def"
44 write_a (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
)
49 wlen
= f
->u
.string
.length
< 0 ? len
: f
->u
.string
.length
;
52 /* If this is formatted STREAM IO convert any embedded line feed characters
53 to CR_LF on systems that use that sequence for newlines. See F2003
54 Standard sections 10.6.3 and 9.9 for further information. */
55 if (is_stream_io (dtp
))
57 const char crlf
[] = "\r\n";
61 /* Write out any padding if needed. */
64 p
= write_block (dtp
, wlen
- len
);
67 memset (p
, ' ', wlen
- len
);
70 /* Scan the source string looking for '\n' and convert it if found. */
71 for (i
= 0; i
< wlen
; i
++)
73 if (source
[i
] == '\n')
75 /* Write out the previously scanned characters in the string. */
78 p
= write_block (dtp
, bytes
);
81 memcpy (p
, &source
[q
], bytes
);
86 /* Write out the CR_LF sequence. */
88 p
= write_block (dtp
, 2);
97 /* Write out any remaining bytes if no LF was found. */
100 p
= write_block (dtp
, bytes
);
103 memcpy (p
, &source
[q
], bytes
);
109 p
= write_block (dtp
, wlen
);
114 memcpy (p
, source
, wlen
);
117 memset (p
, ' ', wlen
- len
);
118 memcpy (p
+ wlen
- len
, source
, len
);
125 static GFC_INTEGER_LARGEST
126 extract_int (const void *p
, int len
)
128 GFC_INTEGER_LARGEST i
= 0;
138 memcpy ((void *) &tmp
, p
, len
);
145 memcpy ((void *) &tmp
, p
, len
);
152 memcpy ((void *) &tmp
, p
, len
);
159 memcpy ((void *) &tmp
, p
, len
);
163 #ifdef HAVE_GFC_INTEGER_16
167 memcpy ((void *) &tmp
, p
, len
);
173 internal_error (NULL
, "bad integer kind");
179 static GFC_UINTEGER_LARGEST
180 extract_uint (const void *p
, int len
)
182 GFC_UINTEGER_LARGEST i
= 0;
192 memcpy ((void *) &tmp
, p
, len
);
193 i
= (GFC_UINTEGER_1
) tmp
;
199 memcpy ((void *) &tmp
, p
, len
);
200 i
= (GFC_UINTEGER_2
) tmp
;
206 memcpy ((void *) &tmp
, p
, len
);
207 i
= (GFC_UINTEGER_4
) tmp
;
213 memcpy ((void *) &tmp
, p
, len
);
214 i
= (GFC_UINTEGER_8
) tmp
;
217 #ifdef HAVE_GFC_INTEGER_16
221 memcpy ((void *) &tmp
, p
, len
);
222 i
= (GFC_UINTEGER_16
) tmp
;
227 internal_error (NULL
, "bad integer kind");
235 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
238 GFC_INTEGER_LARGEST n
;
240 p
= write_block (dtp
, f
->u
.w
);
244 memset (p
, ' ', f
->u
.w
- 1);
245 n
= extract_int (source
, len
);
246 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
251 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
252 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
254 GFC_UINTEGER_LARGEST n
= 0;
255 int w
, m
, digits
, nzero
, nblank
;
258 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
263 n
= extract_uint (source
, len
);
267 if (m
== 0 && n
== 0)
272 p
= write_block (dtp
, w
);
280 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
283 /* Select a width if none was specified. The idea here is to always
287 w
= ((digits
< m
) ? m
: digits
);
289 p
= write_block (dtp
, w
);
297 /* See if things will work. */
299 nblank
= w
- (nzero
+ digits
);
308 if (!dtp
->u
.p
.no_leading_blank
)
310 memset (p
, ' ', nblank
);
312 memset (p
, '0', nzero
);
314 memcpy (p
, q
, digits
);
318 memset (p
, '0', nzero
);
320 memcpy (p
, q
, digits
);
322 memset (p
, ' ', nblank
);
323 dtp
->u
.p
.no_leading_blank
= 0;
331 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
333 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
335 GFC_INTEGER_LARGEST n
= 0;
336 int w
, m
, digits
, nsign
, nzero
, nblank
;
340 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
345 n
= extract_int (source
, len
);
349 if (m
== 0 && n
== 0)
354 p
= write_block (dtp
, w
);
362 sign
= calculate_sign (dtp
, n
< 0);
366 nsign
= sign
== S_NONE
? 0 : 1;
367 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
371 /* Select a width if none was specified. The idea here is to always
375 w
= ((digits
< m
) ? m
: digits
) + nsign
;
377 p
= write_block (dtp
, w
);
385 /* See if things will work. */
387 nblank
= w
- (nsign
+ nzero
+ digits
);
395 memset (p
, ' ', nblank
);
410 memset (p
, '0', nzero
);
413 memcpy (p
, q
, digits
);
420 /* Convert unsigned octal to ascii. */
423 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
427 assert (len
>= GFC_OTOA_BUF_SIZE
);
432 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
437 *--p
= '0' + (n
& 7);
445 /* Convert unsigned binary to ascii. */
448 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
452 assert (len
>= GFC_BTOA_BUF_SIZE
);
457 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
462 *--p
= '0' + (n
& 1);
471 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
473 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
478 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
480 write_int (dtp
, f
, p
, len
, btoa
);
485 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
487 write_int (dtp
, f
, p
, len
, otoa
);
491 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
493 write_int (dtp
, f
, p
, len
, xtoa
);
498 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
500 write_float (dtp
, f
, p
, len
);
505 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
507 write_float (dtp
, f
, p
, len
);
512 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
514 write_float (dtp
, f
, p
, len
);
519 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
521 write_float (dtp
, f
, p
, len
);
526 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
528 write_float (dtp
, f
, p
, len
);
532 /* Take care of the X/TR descriptor. */
535 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
539 p
= write_block (dtp
, len
);
544 memset (&p
[len
- nspaces
], ' ', nspaces
);
548 /* List-directed writing. */
551 /* Write a single character to the output. Returns nonzero if
552 something goes wrong. */
555 write_char (st_parameter_dt
*dtp
, char c
)
559 p
= write_block (dtp
, 1);
569 /* Write a list-directed logical value. */
572 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
574 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
578 /* Write a list-directed integer value. */
581 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
587 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
589 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
618 p
= write_block (dtp
, width
);
621 if (dtp
->u
.p
.no_leading_blank
)
623 memcpy (p
, q
, digits
);
624 memset (p
+ digits
, ' ', width
- digits
);
628 memset (p
, ' ', width
- digits
);
629 memcpy (p
+ width
- digits
, q
, digits
);
634 /* Write a list-directed string. We have to worry about delimiting
635 the strings if the file has been opened in that mode. */
638 write_character (st_parameter_dt
*dtp
, const char *source
, int length
)
643 switch (dtp
->u
.p
.delim_status
)
645 case DELIM_APOSTROPHE
:
662 for (i
= 0; i
< length
; i
++)
667 p
= write_block (dtp
, length
+ extra
);
672 memcpy (p
, source
, length
);
677 for (i
= 0; i
< length
; i
++)
689 /* Output a real number with default format.
690 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
691 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
694 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
697 int org_scale
= dtp
->u
.p
.scale_factor
;
699 dtp
->u
.p
.scale_factor
= 1;
723 internal_error (&dtp
->common
, "bad real kind");
726 write_float (dtp
, &f
, source
, length
);
727 dtp
->u
.p
.scale_factor
= org_scale
;
732 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
734 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
736 if (write_char (dtp
, '('))
738 write_real (dtp
, source
, kind
);
740 if (write_char (dtp
, semi_comma
))
742 write_real (dtp
, source
+ size
/ 2, kind
);
744 write_char (dtp
, ')');
748 /* Write the separator between items. */
751 write_separator (st_parameter_dt
*dtp
)
755 p
= write_block (dtp
, options
.separator_len
);
759 memcpy (p
, options
.separator
, options
.separator_len
);
763 /* Write an item with list formatting.
764 TODO: handle skipping to the next record correctly, particularly
768 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
771 if (dtp
->u
.p
.current_unit
== NULL
)
774 if (dtp
->u
.p
.first_item
)
776 dtp
->u
.p
.first_item
= 0;
777 write_char (dtp
, ' ');
781 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
782 dtp
->u
.p
.delim_status
!= DELIM_NONE
)
783 write_separator (dtp
);
789 write_integer (dtp
, p
, kind
);
792 write_logical (dtp
, p
, kind
);
795 write_character (dtp
, p
, kind
);
798 write_real (dtp
, p
, kind
);
801 write_complex (dtp
, p
, kind
, size
);
804 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
807 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
812 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
813 size_t size
, size_t nelems
)
820 /* Big loop over all the elements. */
821 for (elem
= 0; elem
< nelems
; elem
++)
823 dtp
->u
.p
.item_count
++;
824 list_formatted_write_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
830 nml_write_obj writes a namelist object to the output stream. It is called
831 recursively for derived type components:
832 obj = is the namelist_info for the current object.
833 offset = the offset relative to the address held by the object for
835 base = is the namelist_info of the derived type, when obj is a
837 base_name = the full name for a derived type, including qualifiers
839 The returned value is a pointer to the object beyond the last one
840 accessed, including nested derived types. Notice that the namelist is
841 a linear linked list of objects, including derived types and their
842 components. A tree, of sorts, is implied by the compound names of
843 the derived type components and this is how this function recurses through
846 /* A generous estimate of the number of characters needed to print
847 repeat counts and indices, including commas, asterices and brackets. */
849 #define NML_DIGITS 20
851 static namelist_info
*
852 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
853 namelist_info
* base
, char * base_name
)
864 index_type obj_name_len
;
869 char rep_buff
[NML_DIGITS
];
871 namelist_info
* retval
= obj
->next
;
872 size_t base_name_len
;
873 size_t base_var_name_len
;
875 unit_delim tmp_delim
;
877 /* Set the character to be used to separate values
878 to a comma or semi-colon. */
880 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
882 /* Write namelist variable names in upper case. If a derived type,
883 nothing is output. If a component, base and base_name are set. */
885 if (obj
->type
!= GFC_DTYPE_DERIVED
)
888 write_character (dtp
, "\r\n ", 3);
890 write_character (dtp
, "\n ", 2);
895 len
=strlen (base
->var_name
);
896 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
898 cup
= toupper (base_name
[dim_i
]);
899 write_character (dtp
, &cup
, 1);
902 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
904 cup
= toupper (obj
->var_name
[dim_i
]);
905 write_character (dtp
, &cup
, 1);
907 write_character (dtp
, "=", 1);
910 /* Counts the number of data output on a line, including names. */
920 obj_size
= size_from_real_kind (len
);
923 case GFC_DTYPE_COMPLEX
:
924 obj_size
= size_from_complex_kind (len
);
927 case GFC_DTYPE_CHARACTER
:
928 obj_size
= obj
->string_length
;
936 obj_size
= obj
->size
;
938 /* Set the index vector and count the number of elements. */
941 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
943 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
944 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
947 /* Main loop to output the data held in the object. */
950 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
953 /* Build the pointer to the data value. The offset is passed by
954 recursive calls to this function for arrays of derived types.
955 Is NULL otherwise. */
957 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
960 /* Check for repeat counts of intrinsic types. */
962 if ((elem_ctr
< (nelem
- 1)) &&
963 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
964 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
969 /* Execute a repeated output. Note the flag no_leading_blank that
970 is used in the functions used to output the intrinsic types. */
976 sprintf(rep_buff
, " %d*", rep_ctr
);
977 write_character (dtp
, rep_buff
, strlen (rep_buff
));
978 dtp
->u
.p
.no_leading_blank
= 1;
982 /* Output the data, if an intrinsic type, or recurse into this
983 routine to treat derived types. */
988 case GFC_DTYPE_INTEGER
:
989 write_integer (dtp
, p
, len
);
992 case GFC_DTYPE_LOGICAL
:
993 write_logical (dtp
, p
, len
);
996 case GFC_DTYPE_CHARACTER
:
997 tmp_delim
= dtp
->u
.p
.delim_status
;
998 if (dtp
->u
.p
.nml_delim
== '"')
999 dtp
->u
.p
.delim_status
= DELIM_QUOTE
;
1000 if (dtp
->u
.p
.nml_delim
== '\'')
1001 dtp
->u
.p
.delim_status
= DELIM_APOSTROPHE
;
1002 write_character (dtp
, p
, obj
->string_length
);
1003 dtp
->u
.p
.delim_status
= tmp_delim
;
1006 case GFC_DTYPE_REAL
:
1007 write_real (dtp
, p
, len
);
1010 case GFC_DTYPE_COMPLEX
:
1011 dtp
->u
.p
.no_leading_blank
= 0;
1013 write_complex (dtp
, p
, len
, obj_size
);
1016 case GFC_DTYPE_DERIVED
:
1018 /* To treat a derived type, we need to build two strings:
1019 ext_name = the name, including qualifiers that prepends
1020 component names in the output - passed to
1022 obj_name = the derived type name with no qualifiers but %
1023 appended. This is used to identify the
1026 /* First ext_name => get length of all possible components */
1028 base_name_len
= base_name
? strlen (base_name
) : 0;
1029 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1030 ext_name
= (char*)get_mem ( base_name_len
1032 + strlen (obj
->var_name
)
1033 + obj
->var_rank
* NML_DIGITS
1036 memcpy (ext_name
, base_name
, base_name_len
);
1037 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1038 memcpy (ext_name
+ base_name_len
,
1039 obj
->var_name
+ base_var_name_len
, clen
);
1041 /* Append the qualifier. */
1043 tot_len
= base_name_len
+ clen
;
1044 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1048 ext_name
[tot_len
] = '(';
1051 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1052 tot_len
+= strlen (ext_name
+ tot_len
);
1053 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1057 ext_name
[tot_len
] = '\0';
1061 obj_name_len
= strlen (obj
->var_name
) + 1;
1062 obj_name
= get_mem (obj_name_len
+1);
1063 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1064 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1066 /* Now loop over the components. Update the component pointer
1067 with the return value from nml_write_obj => this loop jumps
1068 past nested derived types. */
1070 for (cmp
= obj
->next
;
1071 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1074 retval
= nml_write_obj (dtp
, cmp
,
1075 (index_type
)(p
- obj
->mem_pos
),
1079 free_mem (obj_name
);
1080 free_mem (ext_name
);
1084 internal_error (&dtp
->common
, "Bad type for namelist write");
1087 /* Reset the leading blank suppression, write a comma (or semi-colon)
1088 and, if 5 values have been output, write a newline and advance
1089 to column 2. Reset the repeat counter. */
1091 dtp
->u
.p
.no_leading_blank
= 0;
1092 write_character (dtp
, &semi_comma
, 1);
1097 write_character (dtp
, "\r\n ", 3);
1099 write_character (dtp
, "\n ", 2);
1105 /* Cycle through and increment the index vector. */
1110 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1112 obj
->ls
[dim_i
].idx
+= nml_carry
;
1114 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1116 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1122 /* Return a pointer beyond the furthest object accessed. */
1127 /* This is the entry function for namelist writes. It outputs the name
1128 of the namelist and iterates through the namelist by calls to
1129 nml_write_obj. The call below has dummys in the arguments used in
1130 the treatment of derived types. */
1133 namelist_write (st_parameter_dt
*dtp
)
1135 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1137 index_type dummy_offset
= 0;
1139 char * dummy_name
= NULL
;
1140 unit_delim tmp_delim
;
1142 /* Set the delimiter for namelist output. */
1144 tmp_delim
= dtp
->u
.p
.delim_status
;
1148 dtp
->u
.p
.nml_delim
= '"';
1151 case (DELIM_APOSTROPHE
):
1152 dtp
->u
.p
.nml_delim
= '\'';
1156 dtp
->u
.p
.nml_delim
= '\0';
1160 /* Temporarily disable namelist delimters. */
1161 dtp
->u
.p
.delim_status
= DELIM_NONE
;
1163 write_character (dtp
, "&", 1);
1165 /* Write namelist name in upper case - f95 std. */
1166 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1168 c
= toupper (dtp
->namelist_name
[i
]);
1169 write_character (dtp
, &c
,1);
1172 if (dtp
->u
.p
.ionml
!= NULL
)
1174 t1
= dtp
->u
.p
.ionml
;
1178 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1183 write_character (dtp
, " /\r\n", 5);
1185 write_character (dtp
, " /\n", 4);
1188 /* Restore the original delimiter. */
1189 dtp
->u
.p
.delim_status
= tmp_delim
;