Mercurial > hg > CbC > CbC_gcc

comparison libgfortran/io/format.c @ 111:04ced10e8804

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