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
50 || (f
->format
== FMT_G
&& f
->u
.string
.length
== 0)
51 ? len
: f
->u
.string
.length
;
54 /* If this is formatted STREAM IO convert any embedded line feed characters
55 to CR_LF on systems that use that sequence for newlines. See F2003
56 Standard sections 10.6.3 and 9.9 for further information. */
57 if (is_stream_io (dtp
))
59 const char crlf
[] = "\r\n";
63 /* Write out any padding if needed. */
66 p
= write_block (dtp
, wlen
- len
);
69 memset (p
, ' ', wlen
- len
);
72 /* Scan the source string looking for '\n' and convert it if found. */
73 for (i
= 0; i
< wlen
; i
++)
75 if (source
[i
] == '\n')
77 /* Write out the previously scanned characters in the string. */
80 p
= write_block (dtp
, bytes
);
83 memcpy (p
, &source
[q
], bytes
);
88 /* Write out the CR_LF sequence. */
90 p
= write_block (dtp
, 2);
99 /* Write out any remaining bytes if no LF was found. */
102 p
= write_block (dtp
, bytes
);
105 memcpy (p
, &source
[q
], bytes
);
111 p
= write_block (dtp
, wlen
);
116 memcpy (p
, source
, wlen
);
119 memset (p
, ' ', wlen
- len
);
120 memcpy (p
+ wlen
- len
, source
, len
);
127 static GFC_INTEGER_LARGEST
128 extract_int (const void *p
, int len
)
130 GFC_INTEGER_LARGEST i
= 0;
140 memcpy ((void *) &tmp
, p
, len
);
147 memcpy ((void *) &tmp
, p
, len
);
154 memcpy ((void *) &tmp
, p
, len
);
161 memcpy ((void *) &tmp
, p
, len
);
165 #ifdef HAVE_GFC_INTEGER_16
169 memcpy ((void *) &tmp
, p
, len
);
175 internal_error (NULL
, "bad integer kind");
181 static GFC_UINTEGER_LARGEST
182 extract_uint (const void *p
, int len
)
184 GFC_UINTEGER_LARGEST i
= 0;
194 memcpy ((void *) &tmp
, p
, len
);
195 i
= (GFC_UINTEGER_1
) tmp
;
201 memcpy ((void *) &tmp
, p
, len
);
202 i
= (GFC_UINTEGER_2
) tmp
;
208 memcpy ((void *) &tmp
, p
, len
);
209 i
= (GFC_UINTEGER_4
) tmp
;
215 memcpy ((void *) &tmp
, p
, len
);
216 i
= (GFC_UINTEGER_8
) tmp
;
219 #ifdef HAVE_GFC_INTEGER_16
223 memcpy ((void *) &tmp
, p
, len
);
224 i
= (GFC_UINTEGER_16
) tmp
;
229 internal_error (NULL
, "bad integer kind");
237 write_l (st_parameter_dt
*dtp
, const fnode
*f
, char *source
, int len
)
241 GFC_INTEGER_LARGEST n
;
243 wlen
= (f
->format
== FMT_G
&& f
->u
.w
== 0) ? 1 : f
->u
.w
;
245 p
= write_block (dtp
, wlen
);
249 memset (p
, ' ', wlen
- 1);
250 n
= extract_int (source
, len
);
251 p
[wlen
- 1] = (n
) ? 'T' : 'F';
256 write_int (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
, int len
,
257 const char *(*conv
) (GFC_UINTEGER_LARGEST
, char *, size_t))
259 GFC_UINTEGER_LARGEST n
= 0;
260 int w
, m
, digits
, nzero
, nblank
;
263 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
268 n
= extract_uint (source
, len
);
272 if (m
== 0 && n
== 0)
277 p
= write_block (dtp
, w
);
285 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
288 /* Select a width if none was specified. The idea here is to always
292 w
= ((digits
< m
) ? m
: digits
);
294 p
= write_block (dtp
, w
);
302 /* See if things will work. */
304 nblank
= w
- (nzero
+ digits
);
313 if (!dtp
->u
.p
.no_leading_blank
)
315 memset (p
, ' ', nblank
);
317 memset (p
, '0', nzero
);
319 memcpy (p
, q
, digits
);
323 memset (p
, '0', nzero
);
325 memcpy (p
, q
, digits
);
327 memset (p
, ' ', nblank
);
328 dtp
->u
.p
.no_leading_blank
= 0;
336 write_decimal (st_parameter_dt
*dtp
, const fnode
*f
, const char *source
,
338 const char *(*conv
) (GFC_INTEGER_LARGEST
, char *, size_t))
340 GFC_INTEGER_LARGEST n
= 0;
341 int w
, m
, digits
, nsign
, nzero
, nblank
;
345 char itoa_buf
[GFC_BTOA_BUF_SIZE
];
348 m
= f
->format
== FMT_G
? -1 : f
->u
.integer
.m
;
350 n
= extract_int (source
, len
);
353 if (m
== 0 && n
== 0)
358 p
= write_block (dtp
, w
);
366 sign
= calculate_sign (dtp
, n
< 0);
370 nsign
= sign
== S_NONE
? 0 : 1;
371 q
= conv (n
, itoa_buf
, sizeof (itoa_buf
));
375 /* Select a width if none was specified. The idea here is to always
379 w
= ((digits
< m
) ? m
: digits
) + nsign
;
381 p
= write_block (dtp
, w
);
389 /* See if things will work. */
391 nblank
= w
- (nsign
+ nzero
+ digits
);
399 memset (p
, ' ', nblank
);
414 memset (p
, '0', nzero
);
417 memcpy (p
, q
, digits
);
424 /* Convert unsigned octal to ascii. */
427 otoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
431 assert (len
>= GFC_OTOA_BUF_SIZE
);
436 p
= buffer
+ GFC_OTOA_BUF_SIZE
- 1;
441 *--p
= '0' + (n
& 7);
449 /* Convert unsigned binary to ascii. */
452 btoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
456 assert (len
>= GFC_BTOA_BUF_SIZE
);
461 p
= buffer
+ GFC_BTOA_BUF_SIZE
- 1;
466 *--p
= '0' + (n
& 1);
475 write_i (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
477 write_decimal (dtp
, f
, p
, len
, (void *) gfc_itoa
);
482 write_b (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
484 write_int (dtp
, f
, p
, len
, btoa
);
489 write_o (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
491 write_int (dtp
, f
, p
, len
, otoa
);
495 write_z (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
497 write_int (dtp
, f
, p
, len
, xtoa
);
502 write_d (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
504 write_float (dtp
, f
, p
, len
);
509 write_e (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
511 write_float (dtp
, f
, p
, len
);
516 write_f (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
518 write_float (dtp
, f
, p
, len
);
523 write_en (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
525 write_float (dtp
, f
, p
, len
);
530 write_es (st_parameter_dt
*dtp
, const fnode
*f
, const char *p
, int len
)
532 write_float (dtp
, f
, p
, len
);
536 /* Take care of the X/TR descriptor. */
539 write_x (st_parameter_dt
*dtp
, int len
, int nspaces
)
543 p
= write_block (dtp
, len
);
548 memset (&p
[len
- nspaces
], ' ', nspaces
);
552 /* List-directed writing. */
555 /* Write a single character to the output. Returns nonzero if
556 something goes wrong. */
559 write_char (st_parameter_dt
*dtp
, char c
)
563 p
= write_block (dtp
, 1);
573 /* Write a list-directed logical value. */
576 write_logical (st_parameter_dt
*dtp
, const char *source
, int length
)
578 write_char (dtp
, extract_int (source
, length
) ? 'T' : 'F');
582 /* Write a list-directed integer value. */
585 write_integer (st_parameter_dt
*dtp
, const char *source
, int length
)
591 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
593 q
= gfc_itoa (extract_int (source
, length
), itoa_buf
, sizeof (itoa_buf
));
622 p
= write_block (dtp
, width
);
625 if (dtp
->u
.p
.no_leading_blank
)
627 memcpy (p
, q
, digits
);
628 memset (p
+ digits
, ' ', width
- digits
);
632 memset (p
, ' ', width
- digits
);
633 memcpy (p
+ width
- digits
, q
, digits
);
638 /* Write a list-directed string. We have to worry about delimiting
639 the strings if the file has been opened in that mode. */
642 write_character (st_parameter_dt
*dtp
, const char *source
, int length
)
647 switch (dtp
->u
.p
.delim_status
)
649 case DELIM_APOSTROPHE
:
666 for (i
= 0; i
< length
; i
++)
671 p
= write_block (dtp
, length
+ extra
);
676 memcpy (p
, source
, length
);
681 for (i
= 0; i
< length
; i
++)
693 /* Output a real number with default format.
694 This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
695 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
698 write_real (st_parameter_dt
*dtp
, const char *source
, int length
)
701 int org_scale
= dtp
->u
.p
.scale_factor
;
703 dtp
->u
.p
.scale_factor
= 1;
727 internal_error (&dtp
->common
, "bad real kind");
730 write_float (dtp
, &f
, source
, length
);
731 dtp
->u
.p
.scale_factor
= org_scale
;
736 write_complex (st_parameter_dt
*dtp
, const char *source
, int kind
, size_t size
)
738 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
740 if (write_char (dtp
, '('))
742 write_real (dtp
, source
, kind
);
744 if (write_char (dtp
, semi_comma
))
746 write_real (dtp
, source
+ size
/ 2, kind
);
748 write_char (dtp
, ')');
752 /* Write the separator between items. */
755 write_separator (st_parameter_dt
*dtp
)
759 p
= write_block (dtp
, options
.separator_len
);
763 memcpy (p
, options
.separator
, options
.separator_len
);
767 /* Write an item with list formatting.
768 TODO: handle skipping to the next record correctly, particularly
772 list_formatted_write_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
775 if (dtp
->u
.p
.current_unit
== NULL
)
778 if (dtp
->u
.p
.first_item
)
780 dtp
->u
.p
.first_item
= 0;
781 write_char (dtp
, ' ');
785 if (type
!= BT_CHARACTER
|| !dtp
->u
.p
.char_flag
||
786 dtp
->u
.p
.delim_status
!= DELIM_NONE
)
787 write_separator (dtp
);
793 write_integer (dtp
, p
, kind
);
796 write_logical (dtp
, p
, kind
);
799 write_character (dtp
, p
, kind
);
802 write_real (dtp
, p
, kind
);
805 write_complex (dtp
, p
, kind
, size
);
808 internal_error (&dtp
->common
, "list_formatted_write(): Bad type");
811 dtp
->u
.p
.char_flag
= (type
== BT_CHARACTER
);
816 list_formatted_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
817 size_t size
, size_t nelems
)
824 /* Big loop over all the elements. */
825 for (elem
= 0; elem
< nelems
; elem
++)
827 dtp
->u
.p
.item_count
++;
828 list_formatted_write_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
834 nml_write_obj writes a namelist object to the output stream. It is called
835 recursively for derived type components:
836 obj = is the namelist_info for the current object.
837 offset = the offset relative to the address held by the object for
839 base = is the namelist_info of the derived type, when obj is a
841 base_name = the full name for a derived type, including qualifiers
843 The returned value is a pointer to the object beyond the last one
844 accessed, including nested derived types. Notice that the namelist is
845 a linear linked list of objects, including derived types and their
846 components. A tree, of sorts, is implied by the compound names of
847 the derived type components and this is how this function recurses through
850 /* A generous estimate of the number of characters needed to print
851 repeat counts and indices, including commas, asterices and brackets. */
853 #define NML_DIGITS 20
855 static namelist_info
*
856 nml_write_obj (st_parameter_dt
*dtp
, namelist_info
* obj
, index_type offset
,
857 namelist_info
* base
, char * base_name
)
868 index_type obj_name_len
;
873 char rep_buff
[NML_DIGITS
];
875 namelist_info
* retval
= obj
->next
;
876 size_t base_name_len
;
877 size_t base_var_name_len
;
879 unit_delim tmp_delim
;
881 /* Set the character to be used to separate values
882 to a comma or semi-colon. */
884 char semi_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_POINT
? ',' : ';';
886 /* Write namelist variable names in upper case. If a derived type,
887 nothing is output. If a component, base and base_name are set. */
889 if (obj
->type
!= GFC_DTYPE_DERIVED
)
892 write_character (dtp
, "\r\n ", 3);
894 write_character (dtp
, "\n ", 2);
899 len
=strlen (base
->var_name
);
900 for (dim_i
= 0; dim_i
< (index_type
) strlen (base_name
); dim_i
++)
902 cup
= toupper (base_name
[dim_i
]);
903 write_character (dtp
, &cup
, 1);
906 for (dim_i
=len
; dim_i
< (index_type
) strlen (obj
->var_name
); dim_i
++)
908 cup
= toupper (obj
->var_name
[dim_i
]);
909 write_character (dtp
, &cup
, 1);
911 write_character (dtp
, "=", 1);
914 /* Counts the number of data output on a line, including names. */
924 obj_size
= size_from_real_kind (len
);
927 case GFC_DTYPE_COMPLEX
:
928 obj_size
= size_from_complex_kind (len
);
931 case GFC_DTYPE_CHARACTER
:
932 obj_size
= obj
->string_length
;
940 obj_size
= obj
->size
;
942 /* Set the index vector and count the number of elements. */
945 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
947 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
948 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
951 /* Main loop to output the data held in the object. */
954 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
957 /* Build the pointer to the data value. The offset is passed by
958 recursive calls to this function for arrays of derived types.
959 Is NULL otherwise. */
961 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
964 /* Check for repeat counts of intrinsic types. */
966 if ((elem_ctr
< (nelem
- 1)) &&
967 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
968 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
973 /* Execute a repeated output. Note the flag no_leading_blank that
974 is used in the functions used to output the intrinsic types. */
980 sprintf(rep_buff
, " %d*", rep_ctr
);
981 write_character (dtp
, rep_buff
, strlen (rep_buff
));
982 dtp
->u
.p
.no_leading_blank
= 1;
986 /* Output the data, if an intrinsic type, or recurse into this
987 routine to treat derived types. */
992 case GFC_DTYPE_INTEGER
:
993 write_integer (dtp
, p
, len
);
996 case GFC_DTYPE_LOGICAL
:
997 write_logical (dtp
, p
, len
);
1000 case GFC_DTYPE_CHARACTER
:
1001 tmp_delim
= dtp
->u
.p
.delim_status
;
1002 if (dtp
->u
.p
.nml_delim
== '"')
1003 dtp
->u
.p
.delim_status
= DELIM_QUOTE
;
1004 if (dtp
->u
.p
.nml_delim
== '\'')
1005 dtp
->u
.p
.delim_status
= DELIM_APOSTROPHE
;
1006 write_character (dtp
, p
, obj
->string_length
);
1007 dtp
->u
.p
.delim_status
= tmp_delim
;
1010 case GFC_DTYPE_REAL
:
1011 write_real (dtp
, p
, len
);
1014 case GFC_DTYPE_COMPLEX
:
1015 dtp
->u
.p
.no_leading_blank
= 0;
1017 write_complex (dtp
, p
, len
, obj_size
);
1020 case GFC_DTYPE_DERIVED
:
1022 /* To treat a derived type, we need to build two strings:
1023 ext_name = the name, including qualifiers that prepends
1024 component names in the output - passed to
1026 obj_name = the derived type name with no qualifiers but %
1027 appended. This is used to identify the
1030 /* First ext_name => get length of all possible components */
1032 base_name_len
= base_name
? strlen (base_name
) : 0;
1033 base_var_name_len
= base
? strlen (base
->var_name
) : 0;
1034 ext_name
= (char*)get_mem ( base_name_len
1036 + strlen (obj
->var_name
)
1037 + obj
->var_rank
* NML_DIGITS
1040 memcpy (ext_name
, base_name
, base_name_len
);
1041 clen
= strlen (obj
->var_name
+ base_var_name_len
);
1042 memcpy (ext_name
+ base_name_len
,
1043 obj
->var_name
+ base_var_name_len
, clen
);
1045 /* Append the qualifier. */
1047 tot_len
= base_name_len
+ clen
;
1048 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1052 ext_name
[tot_len
] = '(';
1055 sprintf (ext_name
+ tot_len
, "%d", (int) obj
->ls
[dim_i
].idx
);
1056 tot_len
+= strlen (ext_name
+ tot_len
);
1057 ext_name
[tot_len
] = (dim_i
== obj
->var_rank
- 1) ? ')' : ',';
1061 ext_name
[tot_len
] = '\0';
1065 obj_name_len
= strlen (obj
->var_name
) + 1;
1066 obj_name
= get_mem (obj_name_len
+1);
1067 memcpy (obj_name
, obj
->var_name
, obj_name_len
-1);
1068 memcpy (obj_name
+ obj_name_len
-1, "%", 2);
1070 /* Now loop over the components. Update the component pointer
1071 with the return value from nml_write_obj => this loop jumps
1072 past nested derived types. */
1074 for (cmp
= obj
->next
;
1075 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1078 retval
= nml_write_obj (dtp
, cmp
,
1079 (index_type
)(p
- obj
->mem_pos
),
1083 free_mem (obj_name
);
1084 free_mem (ext_name
);
1088 internal_error (&dtp
->common
, "Bad type for namelist write");
1091 /* Reset the leading blank suppression, write a comma (or semi-colon)
1092 and, if 5 values have been output, write a newline and advance
1093 to column 2. Reset the repeat counter. */
1095 dtp
->u
.p
.no_leading_blank
= 0;
1096 write_character (dtp
, &semi_comma
, 1);
1101 write_character (dtp
, "\r\n ", 3);
1103 write_character (dtp
, "\n ", 2);
1109 /* Cycle through and increment the index vector. */
1114 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1116 obj
->ls
[dim_i
].idx
+= nml_carry
;
1118 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1120 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1126 /* Return a pointer beyond the furthest object accessed. */
1131 /* This is the entry function for namelist writes. It outputs the name
1132 of the namelist and iterates through the namelist by calls to
1133 nml_write_obj. The call below has dummys in the arguments used in
1134 the treatment of derived types. */
1137 namelist_write (st_parameter_dt
*dtp
)
1139 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1141 index_type dummy_offset
= 0;
1143 char * dummy_name
= NULL
;
1144 unit_delim tmp_delim
;
1146 /* Set the delimiter for namelist output. */
1148 tmp_delim
= dtp
->u
.p
.delim_status
;
1152 dtp
->u
.p
.nml_delim
= '"';
1155 case (DELIM_APOSTROPHE
):
1156 dtp
->u
.p
.nml_delim
= '\'';
1160 dtp
->u
.p
.nml_delim
= '\0';
1164 /* Temporarily disable namelist delimters. */
1165 dtp
->u
.p
.delim_status
= DELIM_NONE
;
1167 write_character (dtp
, "&", 1);
1169 /* Write namelist name in upper case - f95 std. */
1170 for (i
= 0 ;i
< dtp
->namelist_name_len
;i
++ )
1172 c
= toupper (dtp
->namelist_name
[i
]);
1173 write_character (dtp
, &c
,1);
1176 if (dtp
->u
.p
.ionml
!= NULL
)
1178 t1
= dtp
->u
.p
.ionml
;
1182 t1
= nml_write_obj (dtp
, t2
, dummy_offset
, dummy
, dummy_name
);
1187 write_character (dtp
, " /\r\n", 5);
1189 write_character (dtp
, " /\n", 4);
1192 /* Restore the original delimiter. */
1193 dtp
->u
.p
.delim_status
= tmp_delim
;