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