1 /* Copyright (C) 2002-2017 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
27 /* format.c-- parse a FORMAT string into a binary format suitable for
28 * interpretation during I/O statements */
36 static const fnode colon_node
= { FMT_COLON
, 0, NULL
, NULL
, {{ 0, 0, 0 }}, 0,
41 static const char posint_required
[] = "Positive width required in format",
42 period_required
[] = "Period required in format",
43 nonneg_required
[] = "Nonnegative width required in format",
44 unexpected_element
[] = "Unexpected element '%c' in format\n",
45 unexpected_end
[] = "Unexpected end of format string",
46 bad_string
[] = "Unterminated character constant in format",
47 bad_hollerith
[] = "Hollerith constant extends past the end of the format",
48 reversion_error
[] = "Exhausted data descriptors in format",
49 zero_width
[] = "Zero width in format descriptor";
51 /* The following routines support caching format data from parsed format strings
52 into a hash table. This avoids repeatedly parsing duplicate format strings
53 or format strings in I/O statements that are repeated in loops. */
56 /* Traverse the table and free all data. */
59 free_format_hash_table (gfc_unit
*u
)
63 /* free_format_data handles any NULL pointers. */
64 for (i
= 0; i
< FORMAT_HASH_SIZE
; i
++)
66 if (u
->format_hash_table
[i
].hashed_fmt
!= NULL
)
68 free_format_data (u
->format_hash_table
[i
].hashed_fmt
);
69 free (u
->format_hash_table
[i
].key
);
71 u
->format_hash_table
[i
].key
= NULL
;
72 u
->format_hash_table
[i
].key_len
= 0;
73 u
->format_hash_table
[i
].hashed_fmt
= NULL
;
77 /* Traverse the format_data structure and reset the fnode counters. */
80 reset_node (fnode
*fn
)
87 if (fn
->format
!= FMT_LPAREN
)
90 for (f
= fn
->u
.child
; f
; f
= f
->next
)
92 if (f
->format
== FMT_RPAREN
)
99 reset_fnode_counters (st_parameter_dt
*dtp
)
106 /* Clear this pointer at the head so things start at the right place. */
107 fmt
->array
.array
[0].current
= NULL
;
109 for (f
= fmt
->array
.array
[0].u
.child
; f
; f
= f
->next
)
114 /* A simple hashing function to generate an index into the hash table. */
117 format_hash (st_parameter_dt
*dtp
)
120 gfc_charlen_type key_len
;
124 /* Hash the format string. Super simple, but what the heck! */
126 key_len
= dtp
->format_len
;
127 for (i
= 0; i
< key_len
; i
++)
129 hash
&= (FORMAT_HASH_SIZE
- 1);
135 save_parsed_format (st_parameter_dt
*dtp
)
140 hash
= format_hash (dtp
);
141 u
= dtp
->u
.p
.current_unit
;
143 /* Index into the hash table. We are simply replacing whatever is there
144 relying on probability. */
145 if (u
->format_hash_table
[hash
].hashed_fmt
!= NULL
)
146 free_format_data (u
->format_hash_table
[hash
].hashed_fmt
);
147 u
->format_hash_table
[hash
].hashed_fmt
= NULL
;
149 free (u
->format_hash_table
[hash
].key
);
150 u
->format_hash_table
[hash
].key
= dtp
->format
;
152 u
->format_hash_table
[hash
].key_len
= dtp
->format_len
;
153 u
->format_hash_table
[hash
].hashed_fmt
= dtp
->u
.p
.fmt
;
158 find_parsed_format (st_parameter_dt
*dtp
)
163 hash
= format_hash (dtp
);
164 u
= dtp
->u
.p
.current_unit
;
166 if (u
->format_hash_table
[hash
].key
!= NULL
)
168 /* See if it matches. */
169 if (u
->format_hash_table
[hash
].key_len
== dtp
->format_len
)
171 /* So far so good. */
172 if (strncmp (u
->format_hash_table
[hash
].key
,
173 dtp
->format
, dtp
->format_len
) == 0)
174 return u
->format_hash_table
[hash
].hashed_fmt
;
181 /* next_char()-- Return the next character in the format string.
182 * Returns -1 when the string is done. If the literal flag is set,
183 * spaces are significant, otherwise they are not. */
186 next_char (format_data
*fmt
, int literal
)
192 if (fmt
->format_string_len
== 0)
195 fmt
->format_string_len
--;
196 c
= toupper (*fmt
->format_string
++);
197 fmt
->error_element
= c
;
199 while ((c
== ' ' || c
== '\t') && !literal
);
205 /* unget_char()-- Back up one character position. */
207 #define unget_char(fmt) \
208 { fmt->format_string--; fmt->format_string_len++; }
211 /* get_fnode()-- Allocate a new format node, inserting it into the
212 * current singly linked list. These are initially allocated from the
216 get_fnode (format_data
*fmt
, fnode
**head
, fnode
**tail
, format_token t
)
220 if (fmt
->avail
== &fmt
->last
->array
[FARRAY_SIZE
])
222 fmt
->last
->next
= xmalloc (sizeof (fnode_array
));
223 fmt
->last
= fmt
->last
->next
;
224 fmt
->last
->next
= NULL
;
225 fmt
->avail
= &fmt
->last
->array
[0];
228 memset (f
, '\0', sizeof (fnode
));
240 f
->source
= fmt
->format_string
;
245 /* free_format()-- Free allocated format string. */
247 free_format (st_parameter_dt
*dtp
)
249 if ((dtp
->common
.flags
& IOPARM_DT_HAS_FORMAT
) && dtp
->format
)
257 /* free_format_data()-- Free all allocated format data. */
260 free_format_data (format_data
*fmt
)
262 fnode_array
*fa
, *fa_next
;
268 /* Free vlist descriptors in the fnode_array if one was allocated. */
269 for (fnp
= fmt
->array
.array
; fnp
->format
!= FMT_NONE
; fnp
++)
270 if (fnp
->format
== FMT_DT
)
272 if (GFC_DESCRIPTOR_DATA(fnp
->u
.udf
.vlist
))
273 free (GFC_DESCRIPTOR_DATA(fnp
->u
.udf
.vlist
));
274 free (fnp
->u
.udf
.vlist
);
277 for (fa
= fmt
->array
.next
; fa
; fa
= fa_next
)
288 /* format_lex()-- Simple lexical analyzer for getting the next token
289 * in a FORMAT string. We support a one-level token pushback in the
290 * fmt->saved_token variable. */
293 format_lex (format_data
*fmt
)
300 if (fmt
->saved_token
!= FMT_NONE
)
302 token
= fmt
->saved_token
;
303 fmt
->saved_token
= FMT_NONE
;
308 c
= next_char (fmt
, 0);
329 c
= next_char (fmt
, 0);
336 fmt
->value
= c
- '0';
340 c
= next_char (fmt
, 0);
344 fmt
->value
= 10 * fmt
->value
+ c
- '0';
350 fmt
->value
= -fmt
->value
;
351 token
= FMT_SIGNED_INT
;
364 fmt
->value
= c
- '0';
368 c
= next_char (fmt
, 0);
372 fmt
->value
= 10 * fmt
->value
+ c
- '0';
376 token
= (fmt
->value
== 0) ? FMT_ZERO
: FMT_POSINT
;
400 switch (next_char (fmt
, 0))
421 switch (next_char (fmt
, 0))
438 switch (next_char (fmt
, 0))
458 fmt
->string
= fmt
->format_string
;
459 fmt
->value
= 0; /* This is the length of the string */
463 c
= next_char (fmt
, 1);
466 token
= FMT_BADSTRING
;
467 fmt
->error
= bad_string
;
473 c
= next_char (fmt
, 1);
477 token
= FMT_BADSTRING
;
478 fmt
->error
= bad_string
;
516 switch (next_char (fmt
, 0))
548 switch (next_char (fmt
, 0))
567 switch (next_char (fmt
, 0))
607 /* parse_format_list()-- Parse a format list. Assumes that a left
608 * paren has already been seen. Returns a list representing the
609 * parenthesis node which contains the rest of the list. */
612 parse_format_list (st_parameter_dt
*dtp
, bool *seen_dd
)
615 format_token t
, u
, t2
;
617 format_data
*fmt
= dtp
->u
.p
.fmt
;
618 bool seen_data_desc
= false;
622 /* Get the next format item */
624 t
= format_lex (fmt
);
629 t
= format_lex (fmt
);
632 fmt
->error
= "Left parenthesis required after '*'";
635 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
636 tail
->repeat
= -2; /* Signifies unlimited format. */
637 tail
->u
.child
= parse_format_list (dtp
, &seen_data_desc
);
638 *seen_dd
= seen_data_desc
;
639 if (fmt
->error
!= NULL
)
643 fmt
->error
= "'*' requires at least one associated data descriptor";
651 t
= format_lex (fmt
);
655 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
656 tail
->repeat
= repeat
;
657 tail
->u
.child
= parse_format_list (dtp
, &seen_data_desc
);
658 *seen_dd
= seen_data_desc
;
659 if (fmt
->error
!= NULL
)
665 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
666 tail
->repeat
= repeat
;
670 get_fnode (fmt
, &head
, &tail
, FMT_X
);
672 tail
->u
.k
= fmt
->value
;
683 get_fnode (fmt
, &head
, &tail
, FMT_LPAREN
);
685 tail
->u
.child
= parse_format_list (dtp
, &seen_data_desc
);
686 *seen_dd
= seen_data_desc
;
687 if (fmt
->error
!= NULL
)
692 case FMT_SIGNED_INT
: /* Signed integer can only precede a P format. */
693 case FMT_ZERO
: /* Same for zero. */
694 t
= format_lex (fmt
);
697 fmt
->error
= "Expected P edit descriptor in format";
702 get_fnode (fmt
, &head
, &tail
, FMT_P
);
703 tail
->u
.k
= fmt
->value
;
706 t
= format_lex (fmt
);
707 if (t
== FMT_F
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_D
708 || t
== FMT_G
|| t
== FMT_E
)
714 if (t
!= FMT_COMMA
&& t
!= FMT_RPAREN
&& t
!= FMT_SLASH
717 fmt
->error
= "Comma required after P descriptor";
721 fmt
->saved_token
= t
;
724 case FMT_P
: /* P and X require a prior number */
725 fmt
->error
= "P descriptor requires leading scale factor";
732 If we would be pedantic in the library, we would have to reject
733 an X descriptor without an integer prefix:
735 fmt->error = "X descriptor requires leading space count";
738 However, this is an extension supported by many Fortran compilers,
739 including Cray, HP, AIX, and IRIX. Therefore, we allow it in the
740 runtime library, and make the front end reject it if the compiler
741 is in pedantic mode. The interpretation of 'X' is '1X'.
743 get_fnode (fmt
, &head
, &tail
, FMT_X
);
749 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
750 tail
->u
.string
.p
= fmt
->string
;
751 tail
->u
.string
.length
= fmt
->value
;
761 notify_std (&dtp
->common
, GFC_STD_F2003
, "Fortran 2003: Round "
762 "descriptor not allowed");
763 get_fnode (fmt
, &head
, &tail
, t
);
769 notify_std (&dtp
->common
, GFC_STD_F2003
, "Fortran 2003: DC or DP "
770 "descriptor not allowed");
777 get_fnode (fmt
, &head
, &tail
, t
);
782 get_fnode (fmt
, &head
, &tail
, FMT_COLON
);
787 get_fnode (fmt
, &head
, &tail
, FMT_SLASH
);
793 get_fnode (fmt
, &head
, &tail
, FMT_DOLLAR
);
795 notify_std (&dtp
->common
, GFC_STD_GNU
, "Extension: $ descriptor");
801 t2
= format_lex (fmt
);
802 if (t2
!= FMT_POSINT
)
804 fmt
->error
= posint_required
;
807 get_fnode (fmt
, &head
, &tail
, t
);
808 tail
->u
.n
= fmt
->value
;
830 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
831 if (fmt
->format_string_len
< 1)
833 fmt
->error
= bad_hollerith
;
837 tail
->u
.string
.p
= fmt
->format_string
;
838 tail
->u
.string
.length
= 1;
841 fmt
->format_string
++;
842 fmt
->format_string_len
--;
847 fmt
->error
= unexpected_end
;
857 fmt
->error
= unexpected_element
;
861 /* In this state, t must currently be a data descriptor. Deal with
862 things that can/must follow the descriptor */
869 t
= format_lex (fmt
);
874 if (notification_std(GFC_STD_GNU
) == NOTIFICATION_ERROR
)
876 fmt
->error
= "Extension: Zero width after L descriptor";
880 notify_std (&dtp
->common
, GFC_STD_GNU
,
881 "Zero width after L descriptor");
885 fmt
->saved_token
= t
;
886 notify_std (&dtp
->common
, GFC_STD_GNU
,
887 "Positive width required with L descriptor");
889 fmt
->value
= 1; /* Default width */
891 get_fnode (fmt
, &head
, &tail
, FMT_L
);
892 tail
->u
.n
= fmt
->value
;
893 tail
->repeat
= repeat
;
898 t
= format_lex (fmt
);
901 fmt
->error
= zero_width
;
907 fmt
->saved_token
= t
;
908 fmt
->value
= -1; /* Width not present */
911 get_fnode (fmt
, &head
, &tail
, FMT_A
);
912 tail
->repeat
= repeat
;
913 tail
->u
.n
= fmt
->value
;
923 get_fnode (fmt
, &head
, &tail
, t
);
924 tail
->repeat
= repeat
;
926 u
= format_lex (fmt
);
927 if (t
== FMT_G
&& u
== FMT_ZERO
)
930 if (notification_std (GFC_STD_F2008
) == NOTIFICATION_ERROR
931 || dtp
->u
.p
.mode
== READING
)
933 fmt
->error
= zero_width
;
937 u
= format_lex (fmt
);
940 fmt
->saved_token
= u
;
944 u
= format_lex (fmt
);
947 fmt
->error
= posint_required
;
950 tail
->u
.real
.d
= fmt
->value
;
953 if (t
== FMT_F
&& dtp
->u
.p
.mode
== WRITING
)
956 if (u
!= FMT_POSINT
&& u
!= FMT_ZERO
)
958 fmt
->error
= nonneg_required
;
962 else if (u
!= FMT_POSINT
)
964 fmt
->error
= posint_required
;
968 tail
->u
.real
.w
= fmt
->value
;
970 t
= format_lex (fmt
);
973 /* We treat a missing decimal descriptor as 0. Note: This is only
974 allowed if -std=legacy, otherwise an error occurs. */
975 if (compile_options
.warn_std
!= 0)
977 fmt
->error
= period_required
;
980 fmt
->saved_token
= t
;
986 t
= format_lex (fmt
);
987 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
989 fmt
->error
= nonneg_required
;
993 tail
->u
.real
.d
= fmt
->value
;
996 if (t2
== FMT_D
|| t2
== FMT_F
)
1002 /* Look for optional exponent */
1003 t
= format_lex (fmt
);
1005 fmt
->saved_token
= t
;
1008 t
= format_lex (fmt
);
1009 if (t
!= FMT_POSINT
)
1011 fmt
->error
= "Positive exponent width required in format";
1015 tail
->u
.real
.e
= fmt
->value
;
1021 get_fnode (fmt
, &head
, &tail
, t
);
1022 tail
->repeat
= repeat
;
1024 t
= format_lex (fmt
);
1026 /* Initialize the vlist to a zero size array. */
1027 tail
->u
.udf
.vlist
= xmalloc (sizeof(gfc_array_i4
));
1028 GFC_DESCRIPTOR_DATA(tail
->u
.udf
.vlist
) = NULL
;
1029 GFC_DIMENSION_SET(tail
->u
.udf
.vlist
->dim
[0],1, 0, 0);
1031 if (t
== FMT_STRING
)
1033 /* Get pointer to the optional format string. */
1034 tail
->u
.udf
.string
= fmt
->string
;
1035 tail
->u
.udf
.string_len
= fmt
->value
;
1036 t
= format_lex (fmt
);
1038 if (t
== FMT_LPAREN
)
1040 /* Temporary buffer to hold the vlist values. */
1041 GFC_INTEGER_4 temp
[FARRAY_SIZE
];
1044 t
= format_lex (fmt
);
1045 if (t
!= FMT_POSINT
)
1047 fmt
->error
= posint_required
;
1050 /* Save the positive integer value. */
1051 temp
[i
++] = fmt
->value
;
1052 t
= format_lex (fmt
);
1055 if (t
== FMT_RPAREN
)
1057 /* We have parsed the complete vlist so initialize the
1058 array descriptor and save it in the format node. */
1059 gfc_array_i4
*vp
= tail
->u
.udf
.vlist
;
1060 GFC_DESCRIPTOR_DATA(vp
) = xmalloc (i
* sizeof(GFC_INTEGER_4
));
1061 GFC_DIMENSION_SET(vp
->dim
[0],1, i
, 1);
1062 memcpy (GFC_DESCRIPTOR_DATA(vp
), temp
, i
* sizeof(GFC_INTEGER_4
));
1065 fmt
->error
= unexpected_element
;
1068 fmt
->saved_token
= t
;
1071 if (repeat
> fmt
->format_string_len
)
1073 fmt
->error
= bad_hollerith
;
1077 get_fnode (fmt
, &head
, &tail
, FMT_STRING
);
1078 tail
->u
.string
.p
= fmt
->format_string
;
1079 tail
->u
.string
.length
= repeat
;
1082 fmt
->format_string
+= fmt
->value
;
1083 fmt
->format_string_len
-= repeat
;
1092 get_fnode (fmt
, &head
, &tail
, t
);
1093 tail
->repeat
= repeat
;
1095 t
= format_lex (fmt
);
1097 if (dtp
->u
.p
.mode
== READING
)
1099 if (t
!= FMT_POSINT
)
1101 fmt
->error
= posint_required
;
1107 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1109 fmt
->error
= nonneg_required
;
1114 tail
->u
.integer
.w
= fmt
->value
;
1115 tail
->u
.integer
.m
= -1;
1117 t
= format_lex (fmt
);
1118 if (t
!= FMT_PERIOD
)
1120 fmt
->saved_token
= t
;
1124 t
= format_lex (fmt
);
1125 if (t
!= FMT_ZERO
&& t
!= FMT_POSINT
)
1127 fmt
->error
= nonneg_required
;
1131 tail
->u
.integer
.m
= fmt
->value
;
1134 if (tail
->u
.integer
.w
!= 0 && tail
->u
.integer
.m
> tail
->u
.integer
.w
)
1136 fmt
->error
= "Minimum digits exceeds field width";
1143 fmt
->error
= unexpected_element
;
1147 /* Between a descriptor and what comes next */
1149 t
= format_lex (fmt
);
1160 get_fnode (fmt
, &head
, &tail
, t
);
1162 goto optional_comma
;
1165 fmt
->error
= unexpected_end
;
1169 /* Assume a missing comma, this is a GNU extension */
1173 /* Optional comma is a weird between state where we've just finished
1174 reading a colon, slash or P descriptor. */
1176 t
= format_lex (fmt
);
1185 default: /* Assume that we have another format item */
1186 fmt
->saved_token
= t
;
1198 /* format_error()-- Generate an error message for a format statement.
1199 * If the node that gives the location of the error is NULL, the error
1200 * is assumed to happen at parse time, and the current location of the
1203 * We generate a message showing where the problem is. We take extra
1204 * care to print only the relevant part of the format if it is longer
1205 * than a standard 80 column display. */
1208 format_error (st_parameter_dt
*dtp
, const fnode
*f
, const char *message
)
1210 int width
, i
, offset
;
1212 char *p
, buffer
[BUFLEN
];
1213 format_data
*fmt
= dtp
->u
.p
.fmt
;
1217 else /* This should not happen. */
1220 if (message
== unexpected_element
)
1221 snprintf (buffer
, BUFLEN
, message
, fmt
->error_element
);
1223 snprintf (buffer
, BUFLEN
, "%s\n", message
);
1225 /* Get the offset into the format string where the error occurred. */
1226 offset
= dtp
->format_len
- (fmt
->reversion_ok
?
1227 (int) strlen(p
) : fmt
->format_string_len
);
1229 width
= dtp
->format_len
;
1234 /* Show the format */
1236 p
= strchr (buffer
, '\0');
1239 memcpy (p
, dtp
->format
, width
);
1244 /* Show where the problem is */
1246 for (i
= 1; i
< offset
; i
++)
1252 generate_error (&dtp
->common
, LIBERROR_FORMAT
, buffer
);
1256 /* revert()-- Do reversion of the format. Control reverts to the left
1257 * parenthesis that matches the rightmost right parenthesis. From our
1258 * tree structure, we are looking for the rightmost parenthesis node
1259 * at the second level, the first level always being a single
1260 * parenthesis node. If this node doesn't exit, we use the top
1264 revert (st_parameter_dt
*dtp
)
1267 format_data
*fmt
= dtp
->u
.p
.fmt
;
1269 dtp
->u
.p
.reversion_flag
= 1;
1273 for (f
= fmt
->array
.array
[0].u
.child
; f
; f
= f
->next
)
1274 if (f
->format
== FMT_LPAREN
)
1277 /* If r is NULL because no node was found, the whole tree will be used */
1279 fmt
->array
.array
[0].current
= r
;
1280 fmt
->array
.array
[0].count
= 0;
1283 /* parse_format()-- Parse a format string. */
1286 parse_format (st_parameter_dt
*dtp
)
1289 bool format_cache_ok
, seen_data_desc
= false;
1291 /* Don't cache for internal units and set an arbitrary limit on the
1292 size of format strings we will cache. (Avoids memory issues.)
1293 Also, the format_hash_table resides in the current_unit, so
1294 child_dtio procedures would overwrite the parent table */
1295 format_cache_ok
= !is_internal_unit (dtp
)
1296 && (dtp
->u
.p
.current_unit
->child_dtio
== 0);
1298 /* Lookup format string to see if it has already been parsed. */
1299 if (format_cache_ok
)
1301 dtp
->u
.p
.fmt
= find_parsed_format (dtp
);
1303 if (dtp
->u
.p
.fmt
!= NULL
)
1305 dtp
->u
.p
.fmt
->reversion_ok
= 0;
1306 dtp
->u
.p
.fmt
->saved_token
= FMT_NONE
;
1307 dtp
->u
.p
.fmt
->saved_format
= NULL
;
1308 reset_fnode_counters (dtp
);
1313 /* Not found so proceed as follows. */
1315 char *fmt_string
= fc_strdup_notrim (dtp
->format
, dtp
->format_len
);
1316 dtp
->format
= fmt_string
;
1318 dtp
->u
.p
.fmt
= fmt
= xmalloc (sizeof (format_data
));
1319 fmt
->format_string
= dtp
->format
;
1320 fmt
->format_string_len
= dtp
->format_len
;
1323 fmt
->saved_token
= FMT_NONE
;
1327 /* Initialize variables used during traversal of the tree. */
1329 fmt
->reversion_ok
= 0;
1330 fmt
->saved_format
= NULL
;
1332 /* Initialize the fnode_array. */
1334 memset (&(fmt
->array
), 0, sizeof(fmt
->array
));
1336 /* Allocate the first format node as the root of the tree. */
1338 fmt
->last
= &fmt
->array
;
1339 fmt
->last
->next
= NULL
;
1340 fmt
->avail
= &fmt
->array
.array
[0];
1342 memset (fmt
->avail
, 0, sizeof (*fmt
->avail
));
1343 fmt
->avail
->format
= FMT_LPAREN
;
1344 fmt
->avail
->repeat
= 1;
1347 if (format_lex (fmt
) == FMT_LPAREN
)
1348 fmt
->array
.array
[0].u
.child
= parse_format_list (dtp
, &seen_data_desc
);
1350 fmt
->error
= "Missing initial left parenthesis in format";
1352 if (format_cache_ok
)
1353 save_parsed_format (dtp
);
1355 dtp
->u
.p
.format_not_saved
= 1;
1358 format_error (dtp
, NULL
, fmt
->error
);
1362 /* next_format0()-- Get the next format node without worrying about
1363 * reversion. Returns NULL when we hit the end of the list.
1364 * Parenthesis nodes are incremented after the list has been
1365 * exhausted, other nodes are incremented before they are returned. */
1367 static const fnode
*
1368 next_format0 (fnode
* f
)
1375 if (f
->format
!= FMT_LPAREN
)
1378 if (f
->count
<= f
->repeat
)
1385 /* Deal with a parenthesis node with unlimited format. */
1387 if (f
->repeat
== -2) /* -2 signifies unlimited. */
1390 if (f
->current
== NULL
)
1391 f
->current
= f
->u
.child
;
1393 for (; f
->current
!= NULL
; f
->current
= f
->current
->next
)
1395 r
= next_format0 (f
->current
);
1401 /* Deal with a parenthesis node with specific repeat count. */
1402 for (; f
->count
< f
->repeat
; f
->count
++)
1404 if (f
->current
== NULL
)
1405 f
->current
= f
->u
.child
;
1407 for (; f
->current
!= NULL
; f
->current
= f
->current
->next
)
1409 r
= next_format0 (f
->current
);
1420 /* next_format()-- Return the next format node. If the format list
1421 * ends up being exhausted, we do reversion. Reversion is only
1422 * allowed if we've seen a data descriptor since the
1423 * initialization or the last reversion. We return NULL if there
1424 * are no more data descriptors to return (which is an error
1428 next_format (st_parameter_dt
*dtp
)
1432 format_data
*fmt
= dtp
->u
.p
.fmt
;
1434 if (fmt
->saved_format
!= NULL
)
1435 { /* Deal with a pushed-back format node */
1436 f
= fmt
->saved_format
;
1437 fmt
->saved_format
= NULL
;
1441 f
= next_format0 (&fmt
->array
.array
[0]);
1444 if (!fmt
->reversion_ok
)
1447 fmt
->reversion_ok
= 0;
1450 f
= next_format0 (&fmt
->array
.array
[0]);
1453 format_error (dtp
, NULL
, reversion_error
);
1457 /* Push the first reverted token and return a colon node in case
1458 * there are no more data items. */
1460 fmt
->saved_format
= f
;
1464 /* If this is a data edit descriptor, then reversion has become OK. */
1468 if (!fmt
->reversion_ok
&&
1469 (t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
|| t
== FMT_Z
|| t
== FMT_F
||
1470 t
== FMT_E
|| t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
|| t
== FMT_L
||
1471 t
== FMT_A
|| t
== FMT_D
|| t
== FMT_DT
))
1472 fmt
->reversion_ok
= 1;
1477 /* unget_format()-- Push the given format back so that it will be
1478 * returned on the next call to next_format() without affecting
1479 * counts. This is necessary when we've encountered a data
1480 * descriptor, but don't know what the data item is yet. The format
1481 * node is pushed back, and we return control to the main program,
1482 * which calls the library back with the data item (or not). */
1485 unget_format (st_parameter_dt
*dtp
, const fnode
*f
)
1487 dtp
->u
.p
.fmt
->saved_format
= f
;