]>
Commit | Line | Data |
---|---|---|
e3c063ce | 1 | /* Copyright (C) 2002-2013 Free Software Foundation, Inc. |
6de9cd9a | 2 | Contributed by Andy Vaught |
10256cbe | 3 | F2003 I/O support contributed by Jerry DeLisle |
6de9cd9a | 4 | |
bb408e87 | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
6de9cd9a DN |
6 | |
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 | |
748086b7 | 9 | the Free Software Foundation; either version 3, or (at your option) |
6de9cd9a DN |
10 | any later version. |
11 | ||
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. | |
16 | ||
748086b7 JJ |
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. | |
20 | ||
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/>. */ | |
6de9cd9a DN |
25 | |
26 | ||
27 | /* format.c-- parse a FORMAT string into a binary format suitable for | |
28 | * interpretation during I/O statements */ | |
29 | ||
36ae8a61 | 30 | #include "io.h" |
92cbdb68 | 31 | #include "format.h" |
6de9cd9a DN |
32 | #include <ctype.h> |
33 | #include <string.h> | |
7812c78c | 34 | #include <stdbool.h> |
bb408e87 | 35 | #include <stdlib.h> |
6de9cd9a | 36 | |
6de9cd9a | 37 | |
5e805e44 JJ |
38 | static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0, |
39 | NULL }; | |
6de9cd9a | 40 | |
7812c78c | 41 | /* Error messages. */ |
6de9cd9a | 42 | |
09003779 | 43 | static const char posint_required[] = "Positive width required in format", |
6de9cd9a DN |
44 | period_required[] = "Period required in format", |
45 | nonneg_required[] = "Nonnegative width required in format", | |
9cad01ce | 46 | unexpected_element[] = "Unexpected element '%c' in format\n", |
6de9cd9a DN |
47 | unexpected_end[] = "Unexpected end of format string", |
48 | bad_string[] = "Unterminated character constant in format", | |
49 | bad_hollerith[] = "Hollerith constant extends past the end of the format", | |
9355110f JD |
50 | reversion_error[] = "Exhausted data descriptors in format", |
51 | zero_width[] = "Zero width in format descriptor"; | |
6de9cd9a | 52 | |
7812c78c JD |
53 | /* The following routines support caching format data from parsed format strings |
54 | into a hash table. This avoids repeatedly parsing duplicate format strings | |
55 | or format strings in I/O statements that are repeated in loops. */ | |
56 | ||
57 | ||
58 | /* Traverse the table and free all data. */ | |
59 | ||
60 | void | |
61 | free_format_hash_table (gfc_unit *u) | |
62 | { | |
63 | size_t i; | |
64 | ||
65 | /* free_format_data handles any NULL pointers. */ | |
66 | for (i = 0; i < FORMAT_HASH_SIZE; i++) | |
67 | { | |
68 | if (u->format_hash_table[i].hashed_fmt != NULL) | |
0c40d234 JB |
69 | { |
70 | free_format_data (u->format_hash_table[i].hashed_fmt); | |
bb408e87 | 71 | free (u->format_hash_table[i].key); |
0c40d234 JB |
72 | } |
73 | u->format_hash_table[i].key = NULL; | |
74 | u->format_hash_table[i].key_len = 0; | |
7812c78c JD |
75 | u->format_hash_table[i].hashed_fmt = NULL; |
76 | } | |
77 | } | |
78 | ||
79 | /* Traverse the format_data structure and reset the fnode counters. */ | |
80 | ||
81 | static void | |
82 | reset_node (fnode *fn) | |
83 | { | |
84 | fnode *f; | |
85 | ||
86 | fn->count = 0; | |
87 | fn->current = NULL; | |
88 | ||
89 | if (fn->format != FMT_LPAREN) | |
90 | return; | |
91 | ||
92 | for (f = fn->u.child; f; f = f->next) | |
93 | { | |
94 | if (f->format == FMT_RPAREN) | |
95 | break; | |
96 | reset_node (f); | |
97 | } | |
98 | } | |
99 | ||
100 | static void | |
101 | reset_fnode_counters (st_parameter_dt *dtp) | |
102 | { | |
103 | fnode *f; | |
104 | format_data *fmt; | |
105 | ||
106 | fmt = dtp->u.p.fmt; | |
107 | ||
108 | /* Clear this pointer at the head so things start at the right place. */ | |
109 | fmt->array.array[0].current = NULL; | |
110 | ||
6c076a6c | 111 | for (f = fmt->array.array[0].u.child; f; f = f->next) |
7812c78c JD |
112 | reset_node (f); |
113 | } | |
114 | ||
115 | ||
116 | /* A simple hashing function to generate an index into the hash table. */ | |
117 | ||
992b0aa1 JB |
118 | static uint32_t |
119 | format_hash (st_parameter_dt *dtp) | |
7812c78c JD |
120 | { |
121 | char *key; | |
f9bfed22 | 122 | gfc_charlen_type key_len; |
7812c78c | 123 | uint32_t hash = 0; |
f9bfed22 | 124 | gfc_charlen_type i; |
7812c78c JD |
125 | |
126 | /* Hash the format string. Super simple, but what the heck! */ | |
127 | key = dtp->format; | |
128 | key_len = dtp->format_len; | |
129 | for (i = 0; i < key_len; i++) | |
130 | hash ^= key[i]; | |
131 | hash &= (FORMAT_HASH_SIZE - 1); | |
132 | return hash; | |
133 | } | |
134 | ||
135 | ||
136 | static void | |
137 | save_parsed_format (st_parameter_dt *dtp) | |
138 | { | |
139 | uint32_t hash; | |
140 | gfc_unit *u; | |
141 | ||
142 | hash = format_hash (dtp); | |
143 | u = dtp->u.p.current_unit; | |
144 | ||
145 | /* Index into the hash table. We are simply replacing whatever is there | |
146 | relying on probability. */ | |
147 | if (u->format_hash_table[hash].hashed_fmt != NULL) | |
148 | free_format_data (u->format_hash_table[hash].hashed_fmt); | |
149 | u->format_hash_table[hash].hashed_fmt = NULL; | |
150 | ||
04695783 | 151 | free (u->format_hash_table[hash].key); |
1a0fd3d3 | 152 | u->format_hash_table[hash].key = xmalloc (dtp->format_len); |
0c40d234 JB |
153 | memcpy (u->format_hash_table[hash].key, dtp->format, dtp->format_len); |
154 | ||
7812c78c JD |
155 | u->format_hash_table[hash].key_len = dtp->format_len; |
156 | u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt; | |
157 | } | |
158 | ||
159 | ||
160 | static format_data * | |
161 | find_parsed_format (st_parameter_dt *dtp) | |
162 | { | |
163 | uint32_t hash; | |
164 | gfc_unit *u; | |
165 | ||
166 | hash = format_hash (dtp); | |
167 | u = dtp->u.p.current_unit; | |
168 | ||
169 | if (u->format_hash_table[hash].key != NULL) | |
170 | { | |
171 | /* See if it matches. */ | |
172 | if (u->format_hash_table[hash].key_len == dtp->format_len) | |
173 | { | |
174 | /* So far so good. */ | |
175 | if (strncmp (u->format_hash_table[hash].key, | |
176 | dtp->format, dtp->format_len) == 0) | |
177 | return u->format_hash_table[hash].hashed_fmt; | |
178 | } | |
179 | } | |
180 | return NULL; | |
181 | } | |
182 | ||
183 | ||
6de9cd9a DN |
184 | /* next_char()-- Return the next character in the format string. |
185 | * Returns -1 when the string is done. If the literal flag is set, | |
186 | * spaces are significant, otherwise they are not. */ | |
187 | ||
188 | static int | |
5e805e44 | 189 | next_char (format_data *fmt, int literal) |
6de9cd9a DN |
190 | { |
191 | int c; | |
192 | ||
193 | do | |
194 | { | |
5e805e44 | 195 | if (fmt->format_string_len == 0) |
6de9cd9a DN |
196 | return -1; |
197 | ||
5e805e44 | 198 | fmt->format_string_len--; |
7812c78c JD |
199 | c = toupper (*fmt->format_string++); |
200 | fmt->error_element = c; | |
6de9cd9a | 201 | } |
c2df0359 | 202 | while ((c == ' ' || c == '\t') && !literal); |
6de9cd9a DN |
203 | |
204 | return c; | |
205 | } | |
206 | ||
207 | ||
208 | /* unget_char()-- Back up one character position. */ | |
209 | ||
5e805e44 JJ |
210 | #define unget_char(fmt) \ |
211 | { fmt->format_string--; fmt->format_string_len++; } | |
6de9cd9a DN |
212 | |
213 | ||
214 | /* get_fnode()-- Allocate a new format node, inserting it into the | |
215 | * current singly linked list. These are initially allocated from the | |
216 | * static buffer. */ | |
217 | ||
218 | static fnode * | |
5e805e44 | 219 | get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t) |
6de9cd9a DN |
220 | { |
221 | fnode *f; | |
222 | ||
5e805e44 | 223 | if (fmt->avail == &fmt->last->array[FARRAY_SIZE]) |
6de9cd9a | 224 | { |
1a0fd3d3 | 225 | fmt->last->next = xmalloc (sizeof (fnode_array)); |
5e805e44 JJ |
226 | fmt->last = fmt->last->next; |
227 | fmt->last->next = NULL; | |
228 | fmt->avail = &fmt->last->array[0]; | |
6de9cd9a | 229 | } |
5e805e44 JJ |
230 | f = fmt->avail++; |
231 | memset (f, '\0', sizeof (fnode)); | |
6de9cd9a DN |
232 | |
233 | if (*head == NULL) | |
234 | *head = *tail = f; | |
235 | else | |
236 | { | |
237 | (*tail)->next = f; | |
238 | *tail = f; | |
239 | } | |
240 | ||
241 | f->format = t; | |
242 | f->repeat = -1; | |
5e805e44 | 243 | f->source = fmt->format_string; |
6de9cd9a DN |
244 | return f; |
245 | } | |
246 | ||
247 | ||
5e805e44 | 248 | /* free_format_data()-- Free all allocated format data. */ |
6de9cd9a | 249 | |
5e805e44 | 250 | void |
7812c78c | 251 | free_format_data (format_data *fmt) |
6de9cd9a | 252 | { |
5e805e44 | 253 | fnode_array *fa, *fa_next; |
7812c78c | 254 | |
6de9cd9a | 255 | |
5e805e44 JJ |
256 | if (fmt == NULL) |
257 | return; | |
6de9cd9a | 258 | |
5e805e44 JJ |
259 | for (fa = fmt->array.next; fa; fa = fa_next) |
260 | { | |
261 | fa_next = fa->next; | |
bb408e87 | 262 | free (fa); |
6de9cd9a | 263 | } |
6de9cd9a | 264 | |
bb408e87 | 265 | free (fmt); |
7812c78c | 266 | fmt = NULL; |
6de9cd9a DN |
267 | } |
268 | ||
269 | ||
270 | /* format_lex()-- Simple lexical analyzer for getting the next token | |
271 | * in a FORMAT string. We support a one-level token pushback in the | |
5e805e44 | 272 | * fmt->saved_token variable. */ |
6de9cd9a DN |
273 | |
274 | static format_token | |
5e805e44 | 275 | format_lex (format_data *fmt) |
6de9cd9a DN |
276 | { |
277 | format_token token; | |
278 | int negative_flag; | |
28963c8f PB |
279 | int c; |
280 | char delim; | |
6de9cd9a | 281 | |
5e805e44 | 282 | if (fmt->saved_token != FMT_NONE) |
6de9cd9a | 283 | { |
5e805e44 JJ |
284 | token = fmt->saved_token; |
285 | fmt->saved_token = FMT_NONE; | |
6de9cd9a DN |
286 | return token; |
287 | } | |
288 | ||
289 | negative_flag = 0; | |
5e805e44 | 290 | c = next_char (fmt, 0); |
6de9cd9a DN |
291 | |
292 | switch (c) | |
293 | { | |
e2cec2c3 JD |
294 | case '*': |
295 | token = FMT_STAR; | |
296 | break; | |
297 | ||
7812c78c JD |
298 | case '(': |
299 | token = FMT_LPAREN; | |
300 | break; | |
301 | ||
302 | case ')': | |
303 | token = FMT_RPAREN; | |
304 | break; | |
305 | ||
6de9cd9a DN |
306 | case '-': |
307 | negative_flag = 1; | |
308 | /* Fall Through */ | |
309 | ||
310 | case '+': | |
5e805e44 | 311 | c = next_char (fmt, 0); |
6de9cd9a DN |
312 | if (!isdigit (c)) |
313 | { | |
314 | token = FMT_UNKNOWN; | |
315 | break; | |
316 | } | |
317 | ||
5e805e44 | 318 | fmt->value = c - '0'; |
6de9cd9a DN |
319 | |
320 | for (;;) | |
321 | { | |
5e805e44 | 322 | c = next_char (fmt, 0); |
6de9cd9a DN |
323 | if (!isdigit (c)) |
324 | break; | |
325 | ||
5e805e44 | 326 | fmt->value = 10 * fmt->value + c - '0'; |
6de9cd9a DN |
327 | } |
328 | ||
5e805e44 | 329 | unget_char (fmt); |
6de9cd9a DN |
330 | |
331 | if (negative_flag) | |
5e805e44 | 332 | fmt->value = -fmt->value; |
6de9cd9a DN |
333 | token = FMT_SIGNED_INT; |
334 | break; | |
335 | ||
336 | case '0': | |
337 | case '1': | |
338 | case '2': | |
339 | case '3': | |
340 | case '4': | |
341 | case '5': | |
342 | case '6': | |
343 | case '7': | |
344 | case '8': | |
345 | case '9': | |
5e805e44 | 346 | fmt->value = c - '0'; |
6de9cd9a DN |
347 | |
348 | for (;;) | |
349 | { | |
5e805e44 | 350 | c = next_char (fmt, 0); |
6de9cd9a DN |
351 | if (!isdigit (c)) |
352 | break; | |
353 | ||
5e805e44 | 354 | fmt->value = 10 * fmt->value + c - '0'; |
6de9cd9a DN |
355 | } |
356 | ||
5e805e44 JJ |
357 | unget_char (fmt); |
358 | token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT; | |
6de9cd9a DN |
359 | break; |
360 | ||
361 | case '.': | |
362 | token = FMT_PERIOD; | |
363 | break; | |
364 | ||
365 | case ',': | |
366 | token = FMT_COMMA; | |
367 | break; | |
368 | ||
369 | case ':': | |
370 | token = FMT_COLON; | |
371 | break; | |
372 | ||
373 | case '/': | |
374 | token = FMT_SLASH; | |
375 | break; | |
376 | ||
377 | case '$': | |
378 | token = FMT_DOLLAR; | |
379 | break; | |
380 | ||
381 | case 'T': | |
5e805e44 | 382 | switch (next_char (fmt, 0)) |
6de9cd9a DN |
383 | { |
384 | case 'L': | |
385 | token = FMT_TL; | |
386 | break; | |
387 | case 'R': | |
388 | token = FMT_TR; | |
389 | break; | |
390 | default: | |
391 | token = FMT_T; | |
5e805e44 | 392 | unget_char (fmt); |
6de9cd9a DN |
393 | break; |
394 | } | |
395 | ||
396 | break; | |
397 | ||
6de9cd9a DN |
398 | case 'X': |
399 | token = FMT_X; | |
400 | break; | |
401 | ||
402 | case 'S': | |
5e805e44 | 403 | switch (next_char (fmt, 0)) |
6de9cd9a DN |
404 | { |
405 | case 'S': | |
406 | token = FMT_SS; | |
407 | break; | |
408 | case 'P': | |
409 | token = FMT_SP; | |
410 | break; | |
411 | default: | |
412 | token = FMT_S; | |
5e805e44 | 413 | unget_char (fmt); |
6de9cd9a DN |
414 | break; |
415 | } | |
416 | ||
417 | break; | |
418 | ||
419 | case 'B': | |
5e805e44 | 420 | switch (next_char (fmt, 0)) |
6de9cd9a DN |
421 | { |
422 | case 'N': | |
423 | token = FMT_BN; | |
424 | break; | |
425 | case 'Z': | |
426 | token = FMT_BZ; | |
427 | break; | |
428 | default: | |
429 | token = FMT_B; | |
5e805e44 | 430 | unget_char (fmt); |
6de9cd9a DN |
431 | break; |
432 | } | |
433 | ||
434 | break; | |
435 | ||
436 | case '\'': | |
437 | case '"': | |
438 | delim = c; | |
439 | ||
5e805e44 JJ |
440 | fmt->string = fmt->format_string; |
441 | fmt->value = 0; /* This is the length of the string */ | |
6de9cd9a DN |
442 | |
443 | for (;;) | |
444 | { | |
5e805e44 | 445 | c = next_char (fmt, 1); |
6de9cd9a DN |
446 | if (c == -1) |
447 | { | |
448 | token = FMT_BADSTRING; | |
5e805e44 | 449 | fmt->error = bad_string; |
6de9cd9a DN |
450 | break; |
451 | } | |
452 | ||
453 | if (c == delim) | |
454 | { | |
5e805e44 | 455 | c = next_char (fmt, 1); |
6de9cd9a DN |
456 | |
457 | if (c == -1) | |
458 | { | |
459 | token = FMT_BADSTRING; | |
5e805e44 | 460 | fmt->error = bad_string; |
6de9cd9a DN |
461 | break; |
462 | } | |
463 | ||
464 | if (c != delim) | |
465 | { | |
5e805e44 | 466 | unget_char (fmt); |
6de9cd9a DN |
467 | token = FMT_STRING; |
468 | break; | |
469 | } | |
470 | } | |
471 | ||
5e805e44 | 472 | fmt->value++; |
6de9cd9a DN |
473 | } |
474 | ||
475 | break; | |
476 | ||
477 | case 'P': | |
478 | token = FMT_P; | |
479 | break; | |
480 | ||
481 | case 'I': | |
482 | token = FMT_I; | |
483 | break; | |
484 | ||
485 | case 'O': | |
486 | token = FMT_O; | |
487 | break; | |
488 | ||
489 | case 'Z': | |
490 | token = FMT_Z; | |
491 | break; | |
492 | ||
493 | case 'F': | |
494 | token = FMT_F; | |
495 | break; | |
496 | ||
497 | case 'E': | |
5e805e44 | 498 | switch (next_char (fmt, 0)) |
6de9cd9a DN |
499 | { |
500 | case 'N': | |
501 | token = FMT_EN; | |
502 | break; | |
503 | case 'S': | |
504 | token = FMT_ES; | |
505 | break; | |
506 | default: | |
507 | token = FMT_E; | |
5e805e44 | 508 | unget_char (fmt); |
6de9cd9a DN |
509 | break; |
510 | } | |
6de9cd9a DN |
511 | break; |
512 | ||
513 | case 'G': | |
514 | token = FMT_G; | |
515 | break; | |
516 | ||
517 | case 'H': | |
518 | token = FMT_H; | |
519 | break; | |
520 | ||
521 | case 'L': | |
522 | token = FMT_L; | |
523 | break; | |
524 | ||
525 | case 'A': | |
526 | token = FMT_A; | |
527 | break; | |
528 | ||
529 | case 'D': | |
10256cbe JD |
530 | switch (next_char (fmt, 0)) |
531 | { | |
532 | case 'P': | |
533 | token = FMT_DP; | |
534 | break; | |
535 | case 'C': | |
536 | token = FMT_DC; | |
537 | break; | |
538 | default: | |
539 | token = FMT_D; | |
540 | unget_char (fmt); | |
541 | break; | |
542 | } | |
6de9cd9a DN |
543 | break; |
544 | ||
379924dd JD |
545 | case 'R': |
546 | switch (next_char (fmt, 0)) | |
547 | { | |
548 | case 'C': | |
549 | token = FMT_RC; | |
550 | break; | |
551 | case 'D': | |
552 | token = FMT_RD; | |
553 | break; | |
554 | case 'N': | |
555 | token = FMT_RN; | |
556 | break; | |
557 | case 'P': | |
558 | token = FMT_RP; | |
559 | break; | |
560 | case 'U': | |
561 | token = FMT_RU; | |
562 | break; | |
563 | case 'Z': | |
564 | token = FMT_RZ; | |
565 | break; | |
566 | default: | |
567 | unget_char (fmt); | |
568 | token = FMT_UNKNOWN; | |
569 | break; | |
570 | } | |
571 | break; | |
572 | ||
6de9cd9a DN |
573 | case -1: |
574 | token = FMT_END; | |
575 | break; | |
576 | ||
577 | default: | |
578 | token = FMT_UNKNOWN; | |
579 | break; | |
580 | } | |
581 | ||
582 | return token; | |
583 | } | |
584 | ||
585 | ||
586 | /* parse_format_list()-- Parse a format list. Assumes that a left | |
587 | * paren has already been seen. Returns a list representing the | |
588 | * parenthesis node which contains the rest of the list. */ | |
589 | ||
590 | static fnode * | |
da0747b9 | 591 | parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd) |
6de9cd9a DN |
592 | { |
593 | fnode *head, *tail; | |
594 | format_token t, u, t2; | |
595 | int repeat; | |
5e805e44 | 596 | format_data *fmt = dtp->u.p.fmt; |
da0747b9 | 597 | bool saveit, seen_data_desc = false; |
6de9cd9a DN |
598 | |
599 | head = tail = NULL; | |
2418d0e0 | 600 | saveit = *save_ok; |
6de9cd9a | 601 | |
f21edfd6 RH |
602 | /* Get the next format item */ |
603 | format_item: | |
5e805e44 | 604 | t = format_lex (fmt); |
53d8a8ac | 605 | format_item_1: |
6de9cd9a DN |
606 | switch (t) |
607 | { | |
e2cec2c3 JD |
608 | case FMT_STAR: |
609 | t = format_lex (fmt); | |
610 | if (t != FMT_LPAREN) | |
611 | { | |
612 | fmt->error = "Left parenthesis required after '*'"; | |
613 | goto finished; | |
614 | } | |
615 | get_fnode (fmt, &head, &tail, FMT_LPAREN); | |
616 | tail->repeat = -2; /* Signifies unlimited format. */ | |
da0747b9 | 617 | tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc); |
e2cec2c3 JD |
618 | if (fmt->error != NULL) |
619 | goto finished; | |
da0747b9 JD |
620 | if (!seen_data_desc) |
621 | { | |
622 | fmt->error = "'*' requires at least one associated data descriptor"; | |
623 | goto finished; | |
624 | } | |
e2cec2c3 JD |
625 | goto between_desc; |
626 | ||
6de9cd9a | 627 | case FMT_POSINT: |
5e805e44 | 628 | repeat = fmt->value; |
6de9cd9a | 629 | |
5e805e44 | 630 | t = format_lex (fmt); |
6de9cd9a DN |
631 | switch (t) |
632 | { | |
633 | case FMT_LPAREN: | |
5e805e44 | 634 | get_fnode (fmt, &head, &tail, FMT_LPAREN); |
6de9cd9a | 635 | tail->repeat = repeat; |
da0747b9 JD |
636 | tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc); |
637 | *seen_dd = seen_data_desc; | |
5e805e44 | 638 | if (fmt->error != NULL) |
6de9cd9a DN |
639 | goto finished; |
640 | ||
641 | goto between_desc; | |
642 | ||
643 | case FMT_SLASH: | |
5e805e44 | 644 | get_fnode (fmt, &head, &tail, FMT_SLASH); |
6de9cd9a DN |
645 | tail->repeat = repeat; |
646 | goto optional_comma; | |
647 | ||
648 | case FMT_X: | |
5e805e44 | 649 | get_fnode (fmt, &head, &tail, FMT_X); |
6de9cd9a | 650 | tail->repeat = 1; |
5e805e44 | 651 | tail->u.k = fmt->value; |
6de9cd9a DN |
652 | goto between_desc; |
653 | ||
654 | case FMT_P: | |
655 | goto p_descriptor; | |
656 | ||
657 | default: | |
658 | goto data_desc; | |
659 | } | |
660 | ||
661 | case FMT_LPAREN: | |
5e805e44 | 662 | get_fnode (fmt, &head, &tail, FMT_LPAREN); |
6de9cd9a | 663 | tail->repeat = 1; |
da0747b9 JD |
664 | tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc); |
665 | *seen_dd = seen_data_desc; | |
5e805e44 | 666 | if (fmt->error != NULL) |
6de9cd9a DN |
667 | goto finished; |
668 | ||
669 | goto between_desc; | |
670 | ||
671 | case FMT_SIGNED_INT: /* Signed integer can only precede a P format. */ | |
672 | case FMT_ZERO: /* Same for zero. */ | |
5e805e44 | 673 | t = format_lex (fmt); |
6de9cd9a DN |
674 | if (t != FMT_P) |
675 | { | |
5e805e44 | 676 | fmt->error = "Expected P edit descriptor in format"; |
6de9cd9a DN |
677 | goto finished; |
678 | } | |
679 | ||
680 | p_descriptor: | |
5e805e44 JJ |
681 | get_fnode (fmt, &head, &tail, FMT_P); |
682 | tail->u.k = fmt->value; | |
d809264e | 683 | tail->repeat = 1; |
6de9cd9a | 684 | |
5e805e44 | 685 | t = format_lex (fmt); |
6de9cd9a DN |
686 | if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D |
687 | || t == FMT_G || t == FMT_E) | |
688 | { | |
689 | repeat = 1; | |
690 | goto data_desc; | |
691 | } | |
692 | ||
0a81006d JD |
693 | if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH |
694 | && t != FMT_POSINT) | |
d8c00a20 JD |
695 | { |
696 | fmt->error = "Comma required after P descriptor"; | |
697 | goto finished; | |
698 | } | |
699 | ||
5e805e44 | 700 | fmt->saved_token = t; |
187f0734 | 701 | goto optional_comma; |
6de9cd9a DN |
702 | |
703 | case FMT_P: /* P and X require a prior number */ | |
5e805e44 | 704 | fmt->error = "P descriptor requires leading scale factor"; |
6de9cd9a DN |
705 | goto finished; |
706 | ||
707 | case FMT_X: | |
708 | /* | |
709 | EXTENSION! | |
710 | ||
711 | If we would be pedantic in the library, we would have to reject | |
712 | an X descriptor without an integer prefix: | |
713 | ||
5e805e44 | 714 | fmt->error = "X descriptor requires leading space count"; |
6de9cd9a DN |
715 | goto finished; |
716 | ||
717 | However, this is an extension supported by many Fortran compilers, | |
718 | including Cray, HP, AIX, and IRIX. Therefore, we allow it in the | |
719 | runtime library, and make the front end reject it if the compiler | |
720 | is in pedantic mode. The interpretation of 'X' is '1X'. | |
721 | */ | |
5e805e44 | 722 | get_fnode (fmt, &head, &tail, FMT_X); |
6de9cd9a DN |
723 | tail->repeat = 1; |
724 | tail->u.k = 1; | |
725 | goto between_desc; | |
726 | ||
727 | case FMT_STRING: | |
d8c00a20 | 728 | /* TODO: Find out why it is necessary to turn off format caching. */ |
2418d0e0 | 729 | saveit = false; |
5e805e44 | 730 | get_fnode (fmt, &head, &tail, FMT_STRING); |
5e805e44 JJ |
731 | tail->u.string.p = fmt->string; |
732 | tail->u.string.length = fmt->value; | |
6de9cd9a | 733 | tail->repeat = 1; |
11670eeb | 734 | goto optional_comma; |
379924dd JD |
735 | |
736 | case FMT_RC: | |
737 | case FMT_RD: | |
738 | case FMT_RN: | |
739 | case FMT_RP: | |
740 | case FMT_RU: | |
741 | case FMT_RZ: | |
742 | notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: Round " | |
743 | "descriptor not allowed"); | |
744 | get_fnode (fmt, &head, &tail, t); | |
745 | tail->repeat = 1; | |
746 | goto between_desc; | |
6de9cd9a | 747 | |
10256cbe JD |
748 | case FMT_DC: |
749 | case FMT_DP: | |
750 | notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP " | |
751 | "descriptor not allowed"); | |
752 | /* Fall through. */ | |
6de9cd9a DN |
753 | case FMT_S: |
754 | case FMT_SS: | |
755 | case FMT_SP: | |
756 | case FMT_BN: | |
757 | case FMT_BZ: | |
5e805e44 | 758 | get_fnode (fmt, &head, &tail, t); |
06e4f02a | 759 | tail->repeat = 1; |
6de9cd9a DN |
760 | goto between_desc; |
761 | ||
762 | case FMT_COLON: | |
5e805e44 | 763 | get_fnode (fmt, &head, &tail, FMT_COLON); |
a50f3cd3 | 764 | tail->repeat = 1; |
6de9cd9a DN |
765 | goto optional_comma; |
766 | ||
767 | case FMT_SLASH: | |
5e805e44 | 768 | get_fnode (fmt, &head, &tail, FMT_SLASH); |
6de9cd9a DN |
769 | tail->repeat = 1; |
770 | tail->u.r = 1; | |
771 | goto optional_comma; | |
772 | ||
773 | case FMT_DOLLAR: | |
5e805e44 | 774 | get_fnode (fmt, &head, &tail, FMT_DOLLAR); |
c9330b03 | 775 | tail->repeat = 1; |
2e444427 | 776 | notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor"); |
6de9cd9a DN |
777 | goto between_desc; |
778 | ||
779 | case FMT_T: | |
780 | case FMT_TL: | |
781 | case FMT_TR: | |
5e805e44 | 782 | t2 = format_lex (fmt); |
6de9cd9a DN |
783 | if (t2 != FMT_POSINT) |
784 | { | |
5e805e44 | 785 | fmt->error = posint_required; |
6de9cd9a DN |
786 | goto finished; |
787 | } | |
5e805e44 JJ |
788 | get_fnode (fmt, &head, &tail, t); |
789 | tail->u.n = fmt->value; | |
6de9cd9a DN |
790 | tail->repeat = 1; |
791 | goto between_desc; | |
792 | ||
793 | case FMT_I: | |
794 | case FMT_B: | |
795 | case FMT_O: | |
796 | case FMT_Z: | |
797 | case FMT_E: | |
798 | case FMT_EN: | |
799 | case FMT_ES: | |
800 | case FMT_D: | |
801 | case FMT_L: | |
802 | case FMT_A: | |
803 | case FMT_F: | |
804 | case FMT_G: | |
805 | repeat = 1; | |
da0747b9 | 806 | *seen_dd = true; |
6de9cd9a DN |
807 | goto data_desc; |
808 | ||
809 | case FMT_H: | |
5e805e44 | 810 | get_fnode (fmt, &head, &tail, FMT_STRING); |
5e805e44 | 811 | if (fmt->format_string_len < 1) |
6de9cd9a | 812 | { |
5e805e44 | 813 | fmt->error = bad_hollerith; |
6de9cd9a DN |
814 | goto finished; |
815 | } | |
816 | ||
5e805e44 | 817 | tail->u.string.p = fmt->format_string; |
6de9cd9a DN |
818 | tail->u.string.length = 1; |
819 | tail->repeat = 1; | |
820 | ||
5e805e44 JJ |
821 | fmt->format_string++; |
822 | fmt->format_string_len--; | |
6de9cd9a DN |
823 | |
824 | goto between_desc; | |
825 | ||
826 | case FMT_END: | |
5e805e44 | 827 | fmt->error = unexpected_end; |
6de9cd9a DN |
828 | goto finished; |
829 | ||
830 | case FMT_BADSTRING: | |
831 | goto finished; | |
832 | ||
833 | case FMT_RPAREN: | |
834 | goto finished; | |
835 | ||
836 | default: | |
5e805e44 | 837 | fmt->error = unexpected_element; |
6de9cd9a DN |
838 | goto finished; |
839 | } | |
840 | ||
f21edfd6 RH |
841 | /* In this state, t must currently be a data descriptor. Deal with |
842 | things that can/must follow the descriptor */ | |
843 | data_desc: | |
6de9cd9a DN |
844 | switch (t) |
845 | { | |
6de9cd9a | 846 | case FMT_L: |
5e805e44 | 847 | t = format_lex (fmt); |
6de9cd9a DN |
848 | if (t != FMT_POSINT) |
849 | { | |
b2ef02df | 850 | if (notification_std(GFC_STD_GNU) == NOTIFICATION_ERROR) |
8f0d39a8 FXC |
851 | { |
852 | fmt->error = posint_required; | |
853 | goto finished; | |
854 | } | |
855 | else | |
856 | { | |
857 | fmt->saved_token = t; | |
858 | fmt->value = 1; /* Default width */ | |
2e444427 | 859 | notify_std (&dtp->common, GFC_STD_GNU, posint_required); |
8f0d39a8 | 860 | } |
6de9cd9a DN |
861 | } |
862 | ||
5e805e44 JJ |
863 | get_fnode (fmt, &head, &tail, FMT_L); |
864 | tail->u.n = fmt->value; | |
6de9cd9a DN |
865 | tail->repeat = repeat; |
866 | break; | |
867 | ||
868 | case FMT_A: | |
5e805e44 | 869 | t = format_lex (fmt); |
9355110f JD |
870 | if (t == FMT_ZERO) |
871 | { | |
872 | fmt->error = zero_width; | |
873 | goto finished; | |
874 | } | |
875 | ||
6de9cd9a DN |
876 | if (t != FMT_POSINT) |
877 | { | |
5e805e44 JJ |
878 | fmt->saved_token = t; |
879 | fmt->value = -1; /* Width not present */ | |
6de9cd9a DN |
880 | } |
881 | ||
5e805e44 | 882 | get_fnode (fmt, &head, &tail, FMT_A); |
6de9cd9a | 883 | tail->repeat = repeat; |
5e805e44 | 884 | tail->u.n = fmt->value; |
6de9cd9a DN |
885 | break; |
886 | ||
887 | case FMT_D: | |
888 | case FMT_E: | |
889 | case FMT_F: | |
890 | case FMT_G: | |
891 | case FMT_EN: | |
892 | case FMT_ES: | |
5e805e44 | 893 | get_fnode (fmt, &head, &tail, t); |
6de9cd9a DN |
894 | tail->repeat = repeat; |
895 | ||
5e805e44 | 896 | u = format_lex (fmt); |
9355110f JD |
897 | if (t == FMT_G && u == FMT_ZERO) |
898 | { | |
b2ef02df | 899 | if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR |
9355110f JD |
900 | || dtp->u.p.mode == READING) |
901 | { | |
902 | fmt->error = zero_width; | |
903 | goto finished; | |
904 | } | |
905 | tail->u.real.w = 0; | |
900e887f JD |
906 | u = format_lex (fmt); |
907 | if (u != FMT_PERIOD) | |
908 | { | |
909 | fmt->saved_token = u; | |
910 | break; | |
911 | } | |
912 | ||
913 | u = format_lex (fmt); | |
914 | if (u != FMT_POSINT) | |
915 | { | |
916 | fmt->error = posint_required; | |
917 | goto finished; | |
918 | } | |
919 | tail->u.real.d = fmt->value; | |
9355110f JD |
920 | break; |
921 | } | |
a30595bf | 922 | if (t == FMT_F && dtp->u.p.mode == WRITING) |
6de9cd9a DN |
923 | { |
924 | if (u != FMT_POSINT && u != FMT_ZERO) | |
925 | { | |
5e805e44 | 926 | fmt->error = nonneg_required; |
6de9cd9a DN |
927 | goto finished; |
928 | } | |
929 | } | |
a30595bf | 930 | else if (u != FMT_POSINT) |
6de9cd9a | 931 | { |
a30595bf JD |
932 | fmt->error = posint_required; |
933 | goto finished; | |
6de9cd9a DN |
934 | } |
935 | ||
5e805e44 | 936 | tail->u.real.w = fmt->value; |
6de9cd9a | 937 | t2 = t; |
5e805e44 | 938 | t = format_lex (fmt); |
6de9cd9a DN |
939 | if (t != FMT_PERIOD) |
940 | { | |
a7a8dddd JD |
941 | /* We treat a missing decimal descriptor as 0. Note: This is only |
942 | allowed if -std=legacy, otherwise an error occurs. */ | |
943 | if (compile_options.warn_std != 0) | |
944 | { | |
945 | fmt->error = period_required; | |
946 | goto finished; | |
947 | } | |
948 | fmt->saved_token = t; | |
949 | tail->u.real.d = 0; | |
d8c00a20 | 950 | tail->u.real.e = -1; |
a7a8dddd | 951 | break; |
6de9cd9a DN |
952 | } |
953 | ||
5e805e44 | 954 | t = format_lex (fmt); |
6de9cd9a DN |
955 | if (t != FMT_ZERO && t != FMT_POSINT) |
956 | { | |
5e805e44 | 957 | fmt->error = nonneg_required; |
6de9cd9a DN |
958 | goto finished; |
959 | } | |
960 | ||
5e805e44 | 961 | tail->u.real.d = fmt->value; |
d8c00a20 | 962 | tail->u.real.e = -1; |
6de9cd9a | 963 | |
d8c00a20 | 964 | if (t2 == FMT_D || t2 == FMT_F) |
6de9cd9a DN |
965 | break; |
966 | ||
6de9cd9a | 967 | |
f21edfd6 | 968 | /* Look for optional exponent */ |
5e805e44 | 969 | t = format_lex (fmt); |
6de9cd9a | 970 | if (t != FMT_E) |
5e805e44 | 971 | fmt->saved_token = t; |
6de9cd9a DN |
972 | else |
973 | { | |
5e805e44 | 974 | t = format_lex (fmt); |
6de9cd9a DN |
975 | if (t != FMT_POSINT) |
976 | { | |
5e805e44 | 977 | fmt->error = "Positive exponent width required in format"; |
6de9cd9a DN |
978 | goto finished; |
979 | } | |
980 | ||
5e805e44 | 981 | tail->u.real.e = fmt->value; |
6de9cd9a DN |
982 | } |
983 | ||
984 | break; | |
985 | ||
986 | case FMT_H: | |
5e805e44 | 987 | if (repeat > fmt->format_string_len) |
6de9cd9a | 988 | { |
5e805e44 | 989 | fmt->error = bad_hollerith; |
6de9cd9a DN |
990 | goto finished; |
991 | } | |
992 | ||
5e805e44 | 993 | get_fnode (fmt, &head, &tail, FMT_STRING); |
5e805e44 | 994 | tail->u.string.p = fmt->format_string; |
6de9cd9a DN |
995 | tail->u.string.length = repeat; |
996 | tail->repeat = 1; | |
997 | ||
5e805e44 JJ |
998 | fmt->format_string += fmt->value; |
999 | fmt->format_string_len -= repeat; | |
6de9cd9a DN |
1000 | |
1001 | break; | |
1002 | ||
1003 | case FMT_I: | |
1004 | case FMT_B: | |
1005 | case FMT_O: | |
1006 | case FMT_Z: | |
5e805e44 | 1007 | get_fnode (fmt, &head, &tail, t); |
6de9cd9a DN |
1008 | tail->repeat = repeat; |
1009 | ||
5e805e44 | 1010 | t = format_lex (fmt); |
6de9cd9a | 1011 | |
5e805e44 | 1012 | if (dtp->u.p.mode == READING) |
6de9cd9a DN |
1013 | { |
1014 | if (t != FMT_POSINT) | |
1015 | { | |
5e805e44 | 1016 | fmt->error = posint_required; |
6de9cd9a DN |
1017 | goto finished; |
1018 | } | |
1019 | } | |
1020 | else | |
1021 | { | |
1022 | if (t != FMT_ZERO && t != FMT_POSINT) | |
1023 | { | |
5e805e44 | 1024 | fmt->error = nonneg_required; |
6de9cd9a DN |
1025 | goto finished; |
1026 | } | |
1027 | } | |
1028 | ||
5e805e44 | 1029 | tail->u.integer.w = fmt->value; |
6de9cd9a DN |
1030 | tail->u.integer.m = -1; |
1031 | ||
5e805e44 | 1032 | t = format_lex (fmt); |
6de9cd9a DN |
1033 | if (t != FMT_PERIOD) |
1034 | { | |
5e805e44 | 1035 | fmt->saved_token = t; |
6de9cd9a DN |
1036 | } |
1037 | else | |
1038 | { | |
5e805e44 | 1039 | t = format_lex (fmt); |
6de9cd9a DN |
1040 | if (t != FMT_ZERO && t != FMT_POSINT) |
1041 | { | |
5e805e44 | 1042 | fmt->error = nonneg_required; |
6de9cd9a DN |
1043 | goto finished; |
1044 | } | |
1045 | ||
5e805e44 | 1046 | tail->u.integer.m = fmt->value; |
6de9cd9a DN |
1047 | } |
1048 | ||
1049 | if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w) | |
1050 | { | |
5e805e44 | 1051 | fmt->error = "Minimum digits exceeds field width"; |
6de9cd9a DN |
1052 | goto finished; |
1053 | } | |
1054 | ||
1055 | break; | |
1056 | ||
1057 | default: | |
5e805e44 | 1058 | fmt->error = unexpected_element; |
6de9cd9a DN |
1059 | goto finished; |
1060 | } | |
1061 | ||
f21edfd6 RH |
1062 | /* Between a descriptor and what comes next */ |
1063 | between_desc: | |
5e805e44 | 1064 | t = format_lex (fmt); |
6de9cd9a DN |
1065 | switch (t) |
1066 | { | |
1067 | case FMT_COMMA: | |
1068 | goto format_item; | |
1069 | ||
1070 | case FMT_RPAREN: | |
1071 | goto finished; | |
1072 | ||
1073 | case FMT_SLASH: | |
6de9cd9a | 1074 | case FMT_COLON: |
5a97b4f9 JD |
1075 | get_fnode (fmt, &head, &tail, t); |
1076 | tail->repeat = 1; | |
6de9cd9a DN |
1077 | goto optional_comma; |
1078 | ||
1079 | case FMT_END: | |
5e805e44 | 1080 | fmt->error = unexpected_end; |
6de9cd9a DN |
1081 | goto finished; |
1082 | ||
1083 | default: | |
53d8a8ac AP |
1084 | /* Assume a missing comma, this is a GNU extension */ |
1085 | goto format_item_1; | |
6de9cd9a DN |
1086 | } |
1087 | ||
f21edfd6 RH |
1088 | /* Optional comma is a weird between state where we've just finished |
1089 | reading a colon, slash or P descriptor. */ | |
1090 | optional_comma: | |
5e805e44 | 1091 | t = format_lex (fmt); |
6de9cd9a DN |
1092 | switch (t) |
1093 | { | |
1094 | case FMT_COMMA: | |
1095 | break; | |
1096 | ||
1097 | case FMT_RPAREN: | |
1098 | goto finished; | |
1099 | ||
1100 | default: /* Assume that we have another format item */ | |
5e805e44 | 1101 | fmt->saved_token = t; |
6de9cd9a DN |
1102 | break; |
1103 | } | |
1104 | ||
1105 | goto format_item; | |
1106 | ||
f21edfd6 | 1107 | finished: |
2418d0e0 JD |
1108 | |
1109 | *save_ok = saveit; | |
1110 | ||
6de9cd9a DN |
1111 | return head; |
1112 | } | |
1113 | ||
1114 | ||
1115 | /* format_error()-- Generate an error message for a format statement. | |
1116 | * If the node that gives the location of the error is NULL, the error | |
1117 | * is assumed to happen at parse time, and the current location of the | |
1118 | * parser is shown. | |
1119 | * | |
5e805e44 JJ |
1120 | * We generate a message showing where the problem is. We take extra |
1121 | * care to print only the relevant part of the format if it is longer | |
1122 | * than a standard 80 column display. */ | |
6de9cd9a DN |
1123 | |
1124 | void | |
5e805e44 | 1125 | format_error (st_parameter_dt *dtp, const fnode *f, const char *message) |
6de9cd9a DN |
1126 | { |
1127 | int width, i, j, offset; | |
d30fe1c5 JB |
1128 | #define BUFLEN 300 |
1129 | char *p, buffer[BUFLEN]; | |
5e805e44 | 1130 | format_data *fmt = dtp->u.p.fmt; |
6de9cd9a DN |
1131 | |
1132 | if (f != NULL) | |
5e805e44 | 1133 | fmt->format_string = f->source; |
6de9cd9a | 1134 | |
9cad01ce | 1135 | if (message == unexpected_element) |
d30fe1c5 | 1136 | snprintf (buffer, BUFLEN, message, fmt->error_element); |
9cad01ce | 1137 | else |
d30fe1c5 | 1138 | snprintf (buffer, BUFLEN, "%s\n", message); |
6de9cd9a | 1139 | |
5e805e44 | 1140 | j = fmt->format_string - dtp->format; |
6de9cd9a DN |
1141 | |
1142 | offset = (j > 60) ? j - 40 : 0; | |
1143 | ||
1144 | j -= offset; | |
5e805e44 | 1145 | width = dtp->format_len - offset; |
6de9cd9a DN |
1146 | |
1147 | if (width > 80) | |
1148 | width = 80; | |
1149 | ||
1150 | /* Show the format */ | |
1151 | ||
1152 | p = strchr (buffer, '\0'); | |
1153 | ||
5e805e44 | 1154 | memcpy (p, dtp->format + offset, width); |
6de9cd9a DN |
1155 | |
1156 | p += width; | |
1157 | *p++ = '\n'; | |
1158 | ||
1159 | /* Show where the problem is */ | |
1160 | ||
1161 | for (i = 1; i < j; i++) | |
1162 | *p++ = ' '; | |
1163 | ||
1164 | *p++ = '^'; | |
1165 | *p = '\0'; | |
1166 | ||
d74b97cc | 1167 | generate_error (&dtp->common, LIBERROR_FORMAT, buffer); |
6de9cd9a DN |
1168 | } |
1169 | ||
1170 | ||
7812c78c JD |
1171 | /* revert()-- Do reversion of the format. Control reverts to the left |
1172 | * parenthesis that matches the rightmost right parenthesis. From our | |
1173 | * tree structure, we are looking for the rightmost parenthesis node | |
1174 | * at the second level, the first level always being a single | |
1175 | * parenthesis node. If this node doesn't exit, we use the top | |
1176 | * level. */ | |
1177 | ||
1178 | static void | |
1179 | revert (st_parameter_dt *dtp) | |
1180 | { | |
1181 | fnode *f, *r; | |
1182 | format_data *fmt = dtp->u.p.fmt; | |
1183 | ||
1184 | dtp->u.p.reversion_flag = 1; | |
1185 | ||
1186 | r = NULL; | |
1187 | ||
1188 | for (f = fmt->array.array[0].u.child; f; f = f->next) | |
1189 | if (f->format == FMT_LPAREN) | |
1190 | r = f; | |
1191 | ||
1192 | /* If r is NULL because no node was found, the whole tree will be used */ | |
1193 | ||
1194 | fmt->array.array[0].current = r; | |
1195 | fmt->array.array[0].count = 0; | |
1196 | } | |
1197 | ||
6de9cd9a DN |
1198 | /* parse_format()-- Parse a format string. */ |
1199 | ||
1200 | void | |
5e805e44 | 1201 | parse_format (st_parameter_dt *dtp) |
6de9cd9a | 1202 | { |
5e805e44 | 1203 | format_data *fmt; |
da0747b9 | 1204 | bool format_cache_ok, seen_data_desc = false; |
6de9cd9a | 1205 | |
601aa68f JD |
1206 | /* Don't cache for internal units and set an arbitrary limit on the size of |
1207 | format strings we will cache. (Avoids memory issues.) */ | |
6c076a6c | 1208 | format_cache_ok = !is_internal_unit (dtp); |
7812c78c | 1209 | |
2418d0e0 JD |
1210 | /* Lookup format string to see if it has already been parsed. */ |
1211 | if (format_cache_ok) | |
7812c78c | 1212 | { |
2418d0e0 JD |
1213 | dtp->u.p.fmt = find_parsed_format (dtp); |
1214 | ||
1215 | if (dtp->u.p.fmt != NULL) | |
1216 | { | |
1217 | dtp->u.p.fmt->reversion_ok = 0; | |
1218 | dtp->u.p.fmt->saved_token = FMT_NONE; | |
1219 | dtp->u.p.fmt->saved_format = NULL; | |
1220 | reset_fnode_counters (dtp); | |
1221 | return; | |
1222 | } | |
7812c78c JD |
1223 | } |
1224 | ||
1225 | /* Not found so proceed as follows. */ | |
1226 | ||
1a0fd3d3 | 1227 | dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data)); |
5e805e44 JJ |
1228 | fmt->format_string = dtp->format; |
1229 | fmt->format_string_len = dtp->format_len; | |
1230 | ||
1231 | fmt->string = NULL; | |
1232 | fmt->saved_token = FMT_NONE; | |
1233 | fmt->error = NULL; | |
1234 | fmt->value = 0; | |
6de9cd9a | 1235 | |
2418d0e0 | 1236 | /* Initialize variables used during traversal of the tree. */ |
6de9cd9a | 1237 | |
5e805e44 JJ |
1238 | fmt->reversion_ok = 0; |
1239 | fmt->saved_format = NULL; | |
6de9cd9a | 1240 | |
2418d0e0 | 1241 | /* Allocate the first format node as the root of the tree. */ |
6de9cd9a | 1242 | |
5e805e44 JJ |
1243 | fmt->last = &fmt->array; |
1244 | fmt->last->next = NULL; | |
1245 | fmt->avail = &fmt->array.array[0]; | |
6de9cd9a | 1246 | |
5e805e44 JJ |
1247 | memset (fmt->avail, 0, sizeof (*fmt->avail)); |
1248 | fmt->avail->format = FMT_LPAREN; | |
1249 | fmt->avail->repeat = 1; | |
1250 | fmt->avail++; | |
6de9cd9a | 1251 | |
5e805e44 | 1252 | if (format_lex (fmt) == FMT_LPAREN) |
da0747b9 JD |
1253 | fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok, |
1254 | &seen_data_desc); | |
6de9cd9a | 1255 | else |
5e805e44 | 1256 | fmt->error = "Missing initial left parenthesis in format"; |
6de9cd9a | 1257 | |
5e805e44 | 1258 | if (fmt->error) |
7812c78c JD |
1259 | { |
1260 | format_error (dtp, NULL, fmt->error); | |
1261 | free_format_hash_table (dtp->u.p.current_unit); | |
1262 | return; | |
1263 | } | |
573cbcb9 | 1264 | |
2418d0e0 | 1265 | if (format_cache_ok) |
573cbcb9 | 1266 | save_parsed_format (dtp); |
2418d0e0 JD |
1267 | else |
1268 | dtp->u.p.format_not_saved = 1; | |
6de9cd9a DN |
1269 | } |
1270 | ||
1271 | ||
1272 | /* next_format0()-- Get the next format node without worrying about | |
1273 | * reversion. Returns NULL when we hit the end of the list. | |
1274 | * Parenthesis nodes are incremented after the list has been | |
1275 | * exhausted, other nodes are incremented before they are returned. */ | |
1276 | ||
5e805e44 | 1277 | static const fnode * |
6de9cd9a DN |
1278 | next_format0 (fnode * f) |
1279 | { | |
5e805e44 | 1280 | const fnode *r; |
6de9cd9a DN |
1281 | |
1282 | if (f == NULL) | |
1283 | return NULL; | |
1284 | ||
1285 | if (f->format != FMT_LPAREN) | |
1286 | { | |
1287 | f->count++; | |
1288 | if (f->count <= f->repeat) | |
1289 | return f; | |
1290 | ||
1291 | f->count = 0; | |
1292 | return NULL; | |
1293 | } | |
1294 | ||
e2cec2c3 JD |
1295 | /* Deal with a parenthesis node with unlimited format. */ |
1296 | ||
1297 | if (f->repeat == -2) /* -2 signifies unlimited. */ | |
1298 | for (;;) | |
1299 | { | |
1300 | if (f->current == NULL) | |
1301 | f->current = f->u.child; | |
1302 | ||
1303 | for (; f->current != NULL; f->current = f->current->next) | |
1304 | { | |
1305 | r = next_format0 (f->current); | |
1306 | if (r != NULL) | |
1307 | return r; | |
1308 | } | |
1309 | } | |
6de9cd9a | 1310 | |
e2cec2c3 | 1311 | /* Deal with a parenthesis node with specific repeat count. */ |
6de9cd9a DN |
1312 | for (; f->count < f->repeat; f->count++) |
1313 | { | |
1314 | if (f->current == NULL) | |
1315 | f->current = f->u.child; | |
1316 | ||
1317 | for (; f->current != NULL; f->current = f->current->next) | |
1318 | { | |
1319 | r = next_format0 (f->current); | |
1320 | if (r != NULL) | |
1321 | return r; | |
1322 | } | |
1323 | } | |
1324 | ||
1325 | f->count = 0; | |
1326 | return NULL; | |
1327 | } | |
1328 | ||
1329 | ||
1330 | /* next_format()-- Return the next format node. If the format list | |
1331 | * ends up being exhausted, we do reversion. Reversion is only | |
9355110f | 1332 | * allowed if we've seen a data descriptor since the |
c4ee121a | 1333 | * initialization or the last reversion. We return NULL if there |
6de9cd9a DN |
1334 | * are no more data descriptors to return (which is an error |
1335 | * condition). */ | |
1336 | ||
5e805e44 JJ |
1337 | const fnode * |
1338 | next_format (st_parameter_dt *dtp) | |
6de9cd9a DN |
1339 | { |
1340 | format_token t; | |
5e805e44 JJ |
1341 | const fnode *f; |
1342 | format_data *fmt = dtp->u.p.fmt; | |
6de9cd9a | 1343 | |
5e805e44 | 1344 | if (fmt->saved_format != NULL) |
6de9cd9a | 1345 | { /* Deal with a pushed-back format node */ |
5e805e44 JJ |
1346 | f = fmt->saved_format; |
1347 | fmt->saved_format = NULL; | |
6de9cd9a DN |
1348 | goto done; |
1349 | } | |
1350 | ||
5e805e44 | 1351 | f = next_format0 (&fmt->array.array[0]); |
6de9cd9a DN |
1352 | if (f == NULL) |
1353 | { | |
5e805e44 JJ |
1354 | if (!fmt->reversion_ok) |
1355 | return NULL; | |
6de9cd9a | 1356 | |
5e805e44 JJ |
1357 | fmt->reversion_ok = 0; |
1358 | revert (dtp); | |
6de9cd9a | 1359 | |
5e805e44 | 1360 | f = next_format0 (&fmt->array.array[0]); |
6de9cd9a DN |
1361 | if (f == NULL) |
1362 | { | |
5e805e44 | 1363 | format_error (dtp, NULL, reversion_error); |
6de9cd9a DN |
1364 | return NULL; |
1365 | } | |
1366 | ||
1367 | /* Push the first reverted token and return a colon node in case | |
1368 | * there are no more data items. */ | |
1369 | ||
5e805e44 | 1370 | fmt->saved_format = f; |
6de9cd9a DN |
1371 | return &colon_node; |
1372 | } | |
1373 | ||
1374 | /* If this is a data edit descriptor, then reversion has become OK. */ | |
f21edfd6 | 1375 | done: |
6de9cd9a DN |
1376 | t = f->format; |
1377 | ||
5e805e44 | 1378 | if (!fmt->reversion_ok && |
6de9cd9a DN |
1379 | (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F || |
1380 | t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L || | |
1381 | t == FMT_A || t == FMT_D)) | |
5e805e44 | 1382 | fmt->reversion_ok = 1; |
6de9cd9a DN |
1383 | return f; |
1384 | } | |
1385 | ||
1386 | ||
1387 | /* unget_format()-- Push the given format back so that it will be | |
1388 | * returned on the next call to next_format() without affecting | |
1389 | * counts. This is necessary when we've encountered a data | |
1390 | * descriptor, but don't know what the data item is yet. The format | |
1391 | * node is pushed back, and we return control to the main program, | |
1392 | * which calls the library back with the data item (or not). */ | |
1393 | ||
1394 | void | |
5e805e44 | 1395 | unget_format (st_parameter_dt *dtp, const fnode *f) |
6de9cd9a | 1396 | { |
5e805e44 | 1397 | dtp->u.p.fmt->saved_format = f; |
6de9cd9a DN |
1398 | } |
1399 |