]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/io/format.c
1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
28 /* format.c-- parse a FORMAT string into a binary format suitable for
29 * interpretation during I/O statements */
36 #define FARRAY_SIZE 64
38 typedef struct fnode_array
40 struct fnode_array
*next
;
41 fnode array
[FARRAY_SIZE
];
45 typedef struct format_data
47 char *format_string
, *string
;
50 format_token saved_token
;
51 int value
, format_string_len
, reversion_ok
;
53 const fnode
*saved_format
;
59 static const fnode colon_node
= { FMT_COLON
, 0, NULL
, NULL
, {{ 0, 0, 0 }}, 0,
64 static const char posint_required
[] = "Positive width required in format",
65 period_required
[] = "Period required in format",
66 nonneg_required
[] = "Nonnegative width required in format",
67 unexpected_element
[] = "Unexpected element '%c' in format\n",
68 unexpected_end
[] = "Unexpected end of format string",
69 bad_string
[] = "Unterminated character constant in format",
70 bad_hollerith
[] = "Hollerith constant extends past the end of the format",
71 reversion_error
[] = "Exhausted data descriptors in format",
72 zero_width
[] = "Zero width in format descriptor";
74 /* The following routines support caching format data from parsed format strings
75 into a hash table. This avoids repeatedly parsing duplicate format strings
76 or format strings in I/O statements that are repeated in loops. */
79 /* Traverse the table and free all data. */
82 free_format_hash_table (gfc_unit
*u
)
86 /* free_format_data handles any NULL pointers. */
87 for (i
= 0; i
< FORMAT_HASH_SIZE
; i
++)
89 if (u
->format_hash_table
[i
].hashed_fmt
!= NULL
)
90 free_format_data (u
->format_hash_table
[i
].hashed_fmt
);
91 u
->format_hash_table
[i
].hashed_fmt
= NULL
;
95 /* Traverse the format_data structure and reset the fnode counters. */
98 reset_node (fnode
*fn
)
105 if (fn
->format
!= FMT_LPAREN
)
108 for (f
= fn
->u
.child
; f
; f
= f
->next
)
110 if (f
->format
== FMT_RPAREN
)
117 reset_fnode_counters (st_parameter_dt
*dtp
)
124 /* Clear this pointer at the head so things start at the right place. */
125 fmt
->array
.array
[0].current
= NULL
;
127 for (f
= fmt
->last
->array
[0].u
.child
; f
; f
= f
->next
)
132 /* A simple hashing function to generate an index into the hash table. */
135 uint32_t format_hash (st_parameter_dt
*dtp
)
138 gfc_charlen_type key_len
;
142 /* Hash the format string. Super simple, but what the heck! */
144 key_len
= dtp
->format_len
;
145 for (i
= 0; i
< key_len
; i
++)
147 hash
&= (FORMAT_HASH_SIZE
- 1);
153 save_parsed_format (st_parameter_dt
*dtp
)
158 hash
= format_hash (dtp
);
159 u
= dtp
->u
.p
.current_unit
;
161 /* Index into the hash table. We are simply replacing whatever is there
162 relying on probability. */
163 if (u
->format_hash_table
[hash
].hashed_fmt
!= NULL
)
164 free_format_data (u
->format_hash_table
[hash
].hashed_fmt
);
165 u
->format_hash_table
[hash
].hashed_fmt
= NULL
;
167 u
->format_hash_table
[hash
].key
= dtp
->format
;
168 u
->format_hash_table
[hash
].key_len
= dtp
->format_len
;
169 u
->format_hash_table
[hash
].hashed_fmt
= dtp
->u
.p
.fmt
;
174 find_parsed_format (st_parameter_dt
*dtp
)
179 hash
= format_hash (dtp
);
180 u
= dtp
->u
.p
.current_unit
;
182 if (u
->format_hash_table
[hash
].key
!= NULL
)
184 /* See if it matches. */
185 if (u
->format_hash_table
[hash
].key_len
== dtp
->format_len
)
187 /* So far so good. */
188 if (strncmp (u
->format_hash_table
[hash
].key
,
189 dtp
->format
, dtp
->format_len
) == 0)
190 return u
->format_hash_table
[hash
].hashed_fmt
;
197 /* next_char()-- Return the next character in the format string.
198 * Returns -1 when the string is done. If the literal flag is set,
199 * spaces are significant, otherwise they are not. */
202 next_char (format_data
*fmt
, int literal
)
208 if (fmt
->format_string_len
== 0)
211 fmt
->format_string_len
--;
212 c
= toupper (*fmt
->format_string
++);
213 fmt
->error_element
= c
;
215 while ((c
== ' ' || c
== '\t') && !literal
);
221 /* unget_char()-- Back up one character position. */
223 #define unget_char(fmt) \
224 { fmt->format_string--; fmt->format_string_len++; }
227 /* get_fnode()-- Allocate a new format node, inserting it into the
228 * current singly linked list. These are initially allocated from the
232 get_fnode (format_data
*fmt
, fnode
**head
, fnode
**tail
, format_token t
)
236 if (fmt
->avail
== &fmt
->last
->array
[FARRAY_SIZE
])
238 fmt
->last
->next
= get_mem (sizeof (fnode_array
));
239 fmt
->last
= fmt
->last
->next
;
240 fmt
->last
->next
= NULL
;
241 fmt
->avail
= &fmt
->last
->array
[0];
244 memset (f
, '\0', sizeof (fnode
));
256 f
->source
= fmt
->format_string
;
261 /* free_format_data()-- Free all allocated format data. */
264 free_format_data (format_data
*fmt
)
266 fnode_array
*fa
, *fa_next
;
272 for (fa
= fmt
->array
.next
; fa
; fa
= fa_next
)
283 /* format_lex()-- Simple lexical analyzer for getting the next token
284 * in a FORMAT string. We support a one-level token pushback in the
285 * fmt->saved_token variable. */
288 format_lex (format_data
*fmt
)
295 if (fmt
->saved_token
!= FMT_NONE
)
297 token
= fmt
->saved_token
;
298 fmt
->saved_token
= FMT_NONE
;
303 c
= next_char (fmt
, 0);
320 c
= next_char (fmt
, 0);
327 fmt
->value
= c
- '0';
331 c
= next_char (fmt
, 0);
335 fmt
->value
= 10 * fmt
->value
+ c
- '0';
341 fmt
->value
= -fmt
->value
;
342 token
= FMT_SIGNED_INT
;
355 fmt
->value
= c
- '0';
359 c
= next_char (fmt
, 0);
363 fmt
->value
= 10 * fmt
->value
+ c
- '0';
367 token
= (fmt
->value
== 0) ? FMT_ZERO
: FMT_POSINT
;
391 switch (next_char (fmt
, 0))
412 switch (next_char (fmt
, 0))
429 switch (next_char (fmt
, 0))
449 fmt
->string
= fmt
->format_string
;
450 fmt
->value
= 0; /* This is the length of the string */
454 c
= next_char (fmt
, 1);
457 token
= FMT_BADSTRING
;
458 fmt
->error
= bad_string
;
464 c
= next_char (fmt
, 1);
468 token
= FMT_BADSTRING
;
469 fmt
->error
= bad_string
;
507 switch (next_char (fmt
, 0))
539 switch (next_char (fmt
, 0))
567 /* parse_format_list()-- Parse a format list. Assumes that a left
568 * paren has already been seen. Returns a list representing the
569 * parenthesis node which contains the rest of the list. */
572 parse_format_list (st_parameter_dt
*dtp
)
575 format_token t
, u
, t2
;
577 format_data
*fmt
= dtp
->u
.p
.fmt
;
581 save_format
= !is_internal_unit (dtp
);
583 /* Get the next format item */
585 t
= format_lex (fmt
);
592 t
= format_lex (fmt
);
596 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
597 tail
->repeat
= repeat
;
598 tail
->u
.child
= parse_format_list (dtp
);
599 if (fmt
->error
!= NULL
)
605 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
606 tail
->repeat
= repeat
;
610 get_fnode (fmt
, &head
, &tail
, FMT_X
);
612 tail
->u
.k
= fmt
->value
;
623 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
625 tail
->u
.child
= parse_format_list (dtp
);
626 if (fmt
->error
!= NULL
)
631 case FMT_SIGNED_INT
: /* Signed integer can only precede a P format. */
632 case FMT_ZERO
: /* Same for zero. */
633 t
= format_lex (fmt
);
636 fmt
->error
= "Expected P edit descriptor in format";
641 get_fnode (fmt
, &head
, &tail
, FMT_P
);
642 tail
->u
.k
= fmt
->value
;
645 t
= format_lex (fmt
);
646 if (t
== FMT_F
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_D
647 || t
== FMT_G
|| t
== FMT_E
)
653 fmt
->saved_token
= t
;
656 case FMT_P
: /* P and X require a prior number */
657 fmt
->error
= "P descriptor requires leading scale factor";
664 If we would be pedantic in the library, we would have to reject
665 an X descriptor without an integer prefix:
667 fmt->error = "X descriptor requires leading space count";
670 However, this is an extension supported by many Fortran compilers,
671 including Cray, HP, AIX, and IRIX. Therefore, we allow it in the
672 runtime library, and make the front end reject it if the compiler
673 is in pedantic mode. The interpretation of 'X' is '1X'.
675 get_fnode (fmt
, &head
, &tail
, FMT_X
);
681 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
683 tail
->u
.string
.p
= fmt
->string
;
684 tail
->u
.string
.length
= fmt
->value
;
690 notify_std (&dtp
->common
, GFC_STD_F2003
, "Fortran 2003: DC or DP "
691 "descriptor not allowed");
699 get_fnode (fmt
, &head
, &tail
, t
);
704 get_fnode (fmt
, &head
, &tail
, FMT_COLON
);
709 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
715 get_fnode (fmt
, &head
, &tail
, FMT_DOLLAR
);
717 notify_std (&dtp
->common
, GFC_STD_GNU
, "Extension: $ descriptor");
725 t2
= format_lex (fmt
);
726 if (t2
!= FMT_POSINT
)
728 fmt
->error
= posint_required
;
731 get_fnode (fmt
, &head
, &tail
, t
);
732 tail
->u
.n
= fmt
->value
;
752 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
754 if (fmt
->format_string_len
< 1)
756 fmt
->error
= bad_hollerith
;
760 tail
->u
.string
.p
= fmt
->format_string
;
761 tail
->u
.string
.length
= 1;
764 fmt
->format_string
++;
765 fmt
->format_string_len
--;
770 fmt
->error
= unexpected_end
;
780 fmt
->error
= unexpected_element
;
784 /* In this state, t must currently be a data descriptor. Deal with
785 things that can/must follow the descriptor */
790 t
= format_lex (fmt
);
793 fmt
->error
= "Repeat count cannot follow P descriptor";
797 fmt
->saved_token
= t
;
798 get_fnode (fmt
, &head
, &tail
, FMT_P
);
803 t
= format_lex (fmt
);
806 if (notification_std(GFC_STD_GNU
) == ERROR
)
808 fmt
->error
= posint_required
;
813 fmt
->saved_token
= t
;
814 fmt
->value
= 1; /* Default width */
815 notify_std (&dtp
->common
, GFC_STD_GNU
, posint_required
);
820 get_fnode (fmt
, &head
, &tail
, FMT_L
);
821 tail
->u
.n
= fmt
->value
;
822 tail
->repeat
= repeat
;
826 t
= format_lex (fmt
);
829 fmt
->error
= zero_width
;
835 fmt
->saved_token
= t
;
836 fmt
->value
= -1; /* Width not present */
839 get_fnode (fmt
, &head
, &tail
, FMT_A
);
840 tail
->repeat
= repeat
;
841 tail
->u
.n
= fmt
->value
;
850 get_fnode (fmt
, &head
, &tail
, t
);
851 tail
->repeat
= repeat
;
853 u
= format_lex (fmt
);
854 if (t
== FMT_G
&& u
== FMT_ZERO
)
856 if (notification_std (GFC_STD_F2008
) == ERROR
857 || dtp
->u
.p
.mode
== READING
)
859 fmt
->error
= zero_width
;
863 u
= format_lex (fmt
);
866 fmt
->saved_token
= u
;
870 u
= format_lex (fmt
);
873 fmt
->error
= posint_required
;
876 tail
->u
.real
.d
= fmt
->value
;
879 if (t
== FMT_F
|| dtp
->u
.p
.mode
== WRITING
)
881 if (u
!= FMT_POSINT
&& u
!= FMT_ZERO
)
883 fmt
->error
= nonneg_required
;
891 fmt
->error
= posint_required
;
896 tail
->u
.real
.w
= fmt
->value
;
898 t
= format_lex (fmt
);
901 /* We treat a missing decimal descriptor as 0. Note: This is only
902 allowed if -std=legacy, otherwise an error occurs. */
903 if (compile_options
.warn_std
!= 0)
905 fmt
->error
= period_required
;
908 fmt
->saved_token
= t
;
913 t
= format_lex (fmt
);
914 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
916 fmt
->error
= nonneg_required
;
920 tail
->u
.real
.d
= fmt
->value
;
922 if (t
== FMT_D
|| t
== FMT_F
)
927 /* Look for optional exponent */
928 t
= format_lex (fmt
);
930 fmt
->saved_token
= t
;
933 t
= format_lex (fmt
);
936 fmt
->error
= "Positive exponent width required in format";
940 tail
->u
.real
.e
= fmt
->value
;
946 if (repeat
> fmt
->format_string_len
)
948 fmt
->error
= bad_hollerith
;
952 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
954 tail
->u
.string
.p
= fmt
->format_string
;
955 tail
->u
.string
.length
= repeat
;
958 fmt
->format_string
+= fmt
->value
;
959 fmt
->format_string_len
-= repeat
;
967 get_fnode (fmt
, &head
, &tail
, t
);
968 tail
->repeat
= repeat
;
970 t
= format_lex (fmt
);
972 if (dtp
->u
.p
.mode
== READING
)
976 fmt
->error
= posint_required
;
982 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
984 fmt
->error
= nonneg_required
;
989 tail
->u
.integer
.w
= fmt
->value
;
990 tail
->u
.integer
.m
= -1;
992 t
= format_lex (fmt
);
995 fmt
->saved_token
= t
;
999 t
= format_lex (fmt
);
1000 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1002 fmt
->error
= nonneg_required
;
1006 tail
->u
.integer
.m
= fmt
->value
;
1009 if (tail
->u
.integer
.w
!= 0 && tail
->u
.integer
.m
> tail
->u
.integer
.w
)
1011 fmt
->error
= "Minimum digits exceeds field width";
1018 fmt
->error
= unexpected_element
;
1022 /* Between a descriptor and what comes next */
1024 t
= format_lex (fmt
);
1035 get_fnode (fmt
, &head
, &tail
, t
);
1037 goto optional_comma
;
1040 fmt
->error
= unexpected_end
;
1044 /* Assume a missing comma, this is a GNU extension */
1048 /* Optional comma is a weird between state where we've just finished
1049 reading a colon, slash or P descriptor. */
1051 t
= format_lex (fmt
);
1060 default: /* Assume that we have another format item */
1061 fmt
->saved_token
= t
;
1072 /* format_error()-- Generate an error message for a format statement.
1073 * If the node that gives the location of the error is NULL, the error
1074 * is assumed to happen at parse time, and the current location of the
1077 * We generate a message showing where the problem is. We take extra
1078 * care to print only the relevant part of the format if it is longer
1079 * than a standard 80 column display. */
1082 format_error (st_parameter_dt
*dtp
, const fnode
*f
, const char *message
)
1084 int width
, i
, j
, offset
;
1085 char *p
, buffer
[300];
1086 format_data
*fmt
= dtp
->u
.p
.fmt
;
1089 fmt
->format_string
= f
->source
;
1091 if (message
== unexpected_element
)
1092 sprintf (buffer
, message
, fmt
->error_element
);
1094 sprintf (buffer
, "%s\n", message
);
1096 j
= fmt
->format_string
- dtp
->format
;
1098 offset
= (j
> 60) ? j
- 40 : 0;
1101 width
= dtp
->format_len
- offset
;
1106 /* Show the format */
1108 p
= strchr (buffer
, '\0');
1110 memcpy (p
, dtp
->format
+ offset
, width
);
1115 /* Show where the problem is */
1117 for (i
= 1; i
< j
; i
++)
1123 generate_error (&dtp
->common
, LIBERROR_FORMAT
, buffer
);
1127 /* revert()-- Do reversion of the format. Control reverts to the left
1128 * parenthesis that matches the rightmost right parenthesis. From our
1129 * tree structure, we are looking for the rightmost parenthesis node
1130 * at the second level, the first level always being a single
1131 * parenthesis node. If this node doesn't exit, we use the top
1135 revert (st_parameter_dt
*dtp
)
1138 format_data
*fmt
= dtp
->u
.p
.fmt
;
1140 dtp
->u
.p
.reversion_flag
= 1;
1144 for (f
= fmt
->array
.array
[0].u
.child
; f
; f
= f
->next
)
1145 if (f
->format
== FMT_LPAREN
)
1148 /* If r is NULL because no node was found, the whole tree will be used */
1150 fmt
->array
.array
[0].current
= r
;
1151 fmt
->array
.array
[0].count
= 0;
1154 /* parse_format()-- Parse a format string. */
1157 parse_format (st_parameter_dt
*dtp
)
1161 /* Lookup format string to see if it has already been parsed. */
1163 dtp
->u
.p
.fmt
= find_parsed_format (dtp
);
1165 if (dtp
->u
.p
.fmt
!= NULL
)
1167 dtp
->u
.p
.fmt
->reversion_ok
= 0;
1168 dtp
->u
.p
.fmt
->saved_token
= FMT_NONE
;
1169 dtp
->u
.p
.fmt
->saved_format
= NULL
;
1170 reset_fnode_counters (dtp
);
1174 /* Not found so proceed as follows. */
1176 dtp
->u
.p
.fmt
= fmt
= get_mem (sizeof (format_data
));
1177 fmt
->format_string
= dtp
->format
;
1178 fmt
->format_string_len
= dtp
->format_len
;
1181 fmt
->saved_token
= FMT_NONE
;
1185 /* Initialize variables used during traversal of the tree */
1187 fmt
->reversion_ok
= 0;
1188 fmt
->saved_format
= NULL
;
1190 /* Allocate the first format node as the root of the tree */
1192 fmt
->last
= &fmt
->array
;
1193 fmt
->last
->next
= NULL
;
1194 fmt
->avail
= &fmt
->array
.array
[0];
1196 memset (fmt
->avail
, 0, sizeof (*fmt
->avail
));
1197 fmt
->avail
->format
= FMT_LPAREN
;
1198 fmt
->avail
->repeat
= 1;
1201 if (format_lex (fmt
) == FMT_LPAREN
)
1202 fmt
->array
.array
[0].u
.child
= parse_format_list (dtp
);
1204 fmt
->error
= "Missing initial left parenthesis in format";
1208 format_error (dtp
, NULL
, fmt
->error
);
1209 free_format_hash_table (dtp
->u
.p
.current_unit
);
1212 save_parsed_format (dtp
);
1216 /* next_format0()-- Get the next format node without worrying about
1217 * reversion. Returns NULL when we hit the end of the list.
1218 * Parenthesis nodes are incremented after the list has been
1219 * exhausted, other nodes are incremented before they are returned. */
1221 static const fnode
*
1222 next_format0 (fnode
* f
)
1229 if (f
->format
!= FMT_LPAREN
)
1232 if (f
->count
<= f
->repeat
)
1239 /* Deal with a parenthesis node */
1241 for (; f
->count
< f
->repeat
; f
->count
++)
1243 if (f
->current
== NULL
)
1244 f
->current
= f
->u
.child
;
1246 for (; f
->current
!= NULL
; f
->current
= f
->current
->next
)
1248 r
= next_format0 (f
->current
);
1259 /* next_format()-- Return the next format node. If the format list
1260 * ends up being exhausted, we do reversion. Reversion is only
1261 * allowed if we've seen a data descriptor since the
1262 * initialization or the last reversion. We return NULL if there
1263 * are no more data descriptors to return (which is an error
1267 next_format (st_parameter_dt
*dtp
)
1271 format_data
*fmt
= dtp
->u
.p
.fmt
;
1273 if (fmt
->saved_format
!= NULL
)
1274 { /* Deal with a pushed-back format node */
1275 f
= fmt
->saved_format
;
1276 fmt
->saved_format
= NULL
;
1280 f
= next_format0 (&fmt
->array
.array
[0]);
1283 if (!fmt
->reversion_ok
)
1286 fmt
->reversion_ok
= 0;
1289 f
= next_format0 (&fmt
->array
.array
[0]);
1292 format_error (dtp
, NULL
, reversion_error
);
1296 /* Push the first reverted token and return a colon node in case
1297 * there are no more data items. */
1299 fmt
->saved_format
= f
;
1303 /* If this is a data edit descriptor, then reversion has become OK. */
1307 if (!fmt
->reversion_ok
&&
1308 (t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
|| t
== FMT_Z
|| t
== FMT_F
||
1309 t
== FMT_E
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
|| t
== FMT_L
||
1310 t
== FMT_A
|| t
== FMT_D
))
1311 fmt
->reversion_ok
= 1;
1316 /* unget_format()-- Push the given format back so that it will be
1317 * returned on the next call to next_format() without affecting
1318 * counts. This is necessary when we've encountered a data
1319 * descriptor, but don't know what the data item is yet. The format
1320 * node is pushed back, and we return control to the main program,
1321 * which calls the library back with the data item (or not). */
1324 unget_format (st_parameter_dt
*dtp
, const fnode
*f
)
1326 dtp
->u
.p
.fmt
->saved_format
= f
;