1 /* Copyright (C) 2002-2023 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 <string.h>
33
34
35 static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
36 NULL };
37
38 /* Error messages. */
39
40 static const char posint_required[] = "Positive integer required in format",
41 period_required[] = "Period required in format",
42 nonneg_required[] = "Nonnegative width required in format",
43 unexpected_element[] = "Unexpected element '%c' in format\n",
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",
47 reversion_error[] = "Exhausted data descriptors in format",
48 zero_width[] = "Zero width in format descriptor";
49
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)
66 {
67 free_format_data (u->format_hash_table[i].hashed_fmt);
68 free (u->format_hash_table[i].key);
69 }
70 u->format_hash_table[i].key = NULL;
71 u->format_hash_table[i].key_len = 0;
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;
85
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
108 for (f = fmt->array.array[0].u.child; f; f = f->next)
109 reset_node (f);
110 }
111
112
113 /* A simple hashing function to generate an index into the hash table. */
114
115 static uint32_t
116 format_hash (st_parameter_dt *dtp)
117 {
118 char *key;
119 gfc_charlen_type key_len;
120 uint32_t hash = 0;
121 gfc_charlen_type i;
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
148 free (u->format_hash_table[hash].key);
149 u->format_hash_table[hash].key = dtp->format;
150
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
180 /* next_char()-- Return the next character in the format string.
181 Returns -1 when the string is done. If the literal flag is set,
182 spaces are significant, otherwise they are not. */
183
184 static int
185 next_char (format_data *fmt, int literal)
186 {
187 int c;
188
189 do
190 {
191 if (fmt->format_string_len == 0)
192 return -1;
193
194 fmt->format_string_len--;
195 c = safe_toupper (*fmt->format_string++);
196 fmt->error_element = c;
197 }
198 while ((c == ' ' || c == '\t') && !literal);
199
200 return c;
201 }
202
203
204 /* unget_char()-- Back up one character position. */
205
206 #define unget_char(fmt) \
207 { fmt->format_string--; fmt->format_string_len++; }
208
209
210 /* get_fnode()-- Allocate a new format node, inserting it into the
211 current singly linked list. These are initially allocated from the
212 static buffer. */
213
214 static fnode *
215 get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
216 {
217 fnode *f;
218
219 if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
220 {
221 fmt->last->next = xmalloc (sizeof (fnode_array));
222 fmt->last = fmt->last->next;
223 fmt->last->next = NULL;
224 fmt->avail = &fmt->last->array[0];
225 }
226 f = fmt->avail++;
227 memset (f, '\0', sizeof (fnode));
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;
239 f->source = fmt->format_string;
240 return f;
241 }
242
243
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
256 /* free_format_data()-- Free all allocated format data. */
257
258 void
259 free_format_data (format_data *fmt)
260 {
261 fnode_array *fa, *fa_next;
262 fnode *fnp;
263
264 if (fmt == NULL)
265 return;
266
267 /* Free vlist descriptors in the fnode_array if one was allocated. */
268 for (fnp = fmt->array.array; fnp < &fmt->array.array[FARRAY_SIZE] &&
269 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 (!safe_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 (!safe_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 (!safe_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 int standard;
620
621 head = tail = NULL;
622
623 /* Get the next format item */
624 format_item:
625 t = format_lex (fmt);
626 format_item_1:
627 switch (t)
628 {
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. */
638 tail->u.child = parse_format_list (dtp, &seen_data_desc);
639 *seen_dd = seen_data_desc;
640 if (fmt->error != NULL)
641 goto finished;
642 if (!seen_data_desc)
643 {
644 fmt->error = "'*' requires at least one associated data descriptor";
645 goto finished;
646 }
647 goto between_desc;
648
649 case FMT_POSINT:
650 repeat = fmt->value;
651
652 t = format_lex (fmt);
653 switch (t)
654 {
655 case FMT_LPAREN:
656 get_fnode (fmt, &head, &tail, FMT_LPAREN);
657 tail->repeat = repeat;
658 tail->u.child = parse_format_list (dtp, &seen_data_desc);
659 *seen_dd = seen_data_desc;
660 if (fmt->error != NULL)
661 goto finished;
662
663 goto between_desc;
664
665 case FMT_SLASH:
666 get_fnode (fmt, &head, &tail, FMT_SLASH);
667 tail->repeat = repeat;
668 goto optional_comma;
669
670 case FMT_X:
671 get_fnode (fmt, &head, &tail, FMT_X);
672 tail->repeat = 1;
673 tail->u.k = fmt->value;
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:
684 get_fnode (fmt, &head, &tail, FMT_LPAREN);
685 tail->repeat = 1;
686 tail->u.child = parse_format_list (dtp, &seen_data_desc);
687 *seen_dd = seen_data_desc;
688 if (fmt->error != NULL)
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. */
695 t = format_lex (fmt);
696 if (t != FMT_P)
697 {
698 fmt->error = "Expected P edit descriptor in format";
699 goto finished;
700 }
701
702 p_descriptor:
703 get_fnode (fmt, &head, &tail, FMT_P);
704 tail->u.k = fmt->value;
705 tail->repeat = 1;
706
707 t = format_lex (fmt);
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
715 if (t != FMT_COMMA && t != FMT_RPAREN && t != FMT_SLASH
716 && t != FMT_POSINT)
717 {
718 fmt->error = "Comma required after P descriptor";
719 goto finished;
720 }
721
722 fmt->saved_token = t;
723 goto optional_comma;
724
725 case FMT_P: /* P and X require a prior number */
726 fmt->error = "P descriptor requires leading scale factor";
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
736 fmt->error = "X descriptor requires leading space count";
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 */
744 get_fnode (fmt, &head, &tail, FMT_X);
745 tail->repeat = 1;
746 tail->u.k = 1;
747 goto between_desc;
748
749 case FMT_STRING:
750 get_fnode (fmt, &head, &tail, FMT_STRING);
751 tail->u.string.p = fmt->string;
752 tail->u.string.length = fmt->value;
753 tail->repeat = 1;
754 goto optional_comma;
755
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;
767
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. */
773 case FMT_S:
774 case FMT_SS:
775 case FMT_SP:
776 case FMT_BN:
777 case FMT_BZ:
778 get_fnode (fmt, &head, &tail, t);
779 tail->repeat = 1;
780 goto between_desc;
781
782 case FMT_COLON:
783 get_fnode (fmt, &head, &tail, FMT_COLON);
784 tail->repeat = 1;
785 goto optional_comma;
786
787 case FMT_SLASH:
788 get_fnode (fmt, &head, &tail, FMT_SLASH);
789 tail->repeat = 1;
790 tail->u.r = 1;
791 goto optional_comma;
792
793 case FMT_DOLLAR:
794 get_fnode (fmt, &head, &tail, FMT_DOLLAR);
795 tail->repeat = 1;
796 notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
797 goto between_desc;
798
799 case FMT_T:
800 case FMT_TL:
801 case FMT_TR:
802 t2 = format_lex (fmt);
803 if (t2 != FMT_POSINT)
804 {
805 fmt->error = posint_required;
806 goto finished;
807 }
808 get_fnode (fmt, &head, &tail, t);
809 tail->u.n = fmt->value;
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:
821 case FMT_DT:
822 case FMT_L:
823 case FMT_A:
824 case FMT_F:
825 case FMT_G:
826 repeat = 1;
827 *seen_dd = true;
828 goto data_desc;
829
830 case FMT_H:
831 get_fnode (fmt, &head, &tail, FMT_STRING);
832 if (fmt->format_string_len < 1)
833 {
834 fmt->error = bad_hollerith;
835 goto finished;
836 }
837
838 tail->u.string.p = fmt->format_string;
839 tail->u.string.length = 1;
840 tail->repeat = 1;
841
842 fmt->format_string++;
843 fmt->format_string_len--;
844
845 goto between_desc;
846
847 case FMT_END:
848 fmt->error = unexpected_end;
849 goto finished;
850
851 case FMT_BADSTRING:
852 goto finished;
853
854 case FMT_RPAREN:
855 goto finished;
856
857 default:
858 fmt->error = unexpected_element;
859 goto finished;
860 }
861
862 /* In this state, t must currently be a data descriptor. Deal with
863 things that can/must follow the descriptor */
864 data_desc:
865
866 switch (t)
867 {
868 case FMT_L:
869 *seen_dd = true;
870 t = format_lex (fmt);
871 if (t != FMT_POSINT)
872 {
873 if (t == FMT_ZERO)
874 {
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");
883 }
884 else
885 {
886 fmt->saved_token = t;
887 notify_std (&dtp->common, GFC_STD_GNU,
888 "Positive width required with L descriptor");
889 }
890 fmt->value = 1; /* Default width */
891 }
892 get_fnode (fmt, &head, &tail, FMT_L);
893 tail->u.n = fmt->value;
894 tail->repeat = repeat;
895 break;
896
897 case FMT_A:
898 *seen_dd = true;
899 t = format_lex (fmt);
900 if (t == FMT_ZERO)
901 {
902 fmt->error = zero_width;
903 goto finished;
904 }
905
906 if (t != FMT_POSINT)
907 {
908 fmt->saved_token = t;
909 fmt->value = -1; /* Width not present */
910 }
911
912 get_fnode (fmt, &head, &tail, FMT_A);
913 tail->repeat = repeat;
914 tail->u.n = fmt->value;
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:
923 *seen_dd = true;
924 get_fnode (fmt, &head, &tail, t);
925 tail->repeat = repeat;
926
927 u = format_lex (fmt);
928
929 /* Processing for zero width formats. */
930 if (u == FMT_ZERO)
931 {
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
940 || dtp->u.p.mode == READING)
941 {
942 fmt->error = zero_width;
943 goto finished;
944 }
945 tail->u.real.w = 0;
946
947 /* Look for the dot seperator. */
948 u = format_lex (fmt);
949 if (u != FMT_PERIOD)
950 {
951 fmt->saved_token = u;
952 break;
953 }
954
955 /* Look for the precision. */
956 u = format_lex (fmt);
957 if (u != FMT_ZERO && u != FMT_POSINT)
958 {
959 fmt->error = nonneg_required;
960 goto finished;
961 }
962 tail->u.real.d = fmt->value;
963
964 /* Look for optional exponent, not allowed for FMT_D */
965 if (t == FMT_D)
966 break;
967 u = format_lex (fmt);
968 if (u != FMT_E)
969 fmt->saved_token = u;
970 else
971 {
972 u = format_lex (fmt);
973 if (u != FMT_POSINT)
974 {
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 }
986 }
987 tail->u.real.e = fmt->value;
988 }
989 break;
990 }
991
992 /* Processing for positive width formats. */
993 if (u == FMT_POSINT)
994 {
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)
1002 {
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;
1011 tail->u.real.d = 0;
1012 tail->u.real.e = -1;
1013 break;
1014 }
1015
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)
1020 {
1021 fmt->error = nonneg_required;
1022 goto finished;
1023 }
1024 tail->u.real.d = fmt->value;
1025 tail->u.real.e = -1;
1026
1027 /* Done with D and F formats. */
1028 if (t2 == FMT_D || t2 == FMT_F)
1029 {
1030 *seen_dd = true;
1031 break;
1032 }
1033
1034 /* Look for optional exponent */
1035 u = format_lex (fmt);
1036 if (u != FMT_E)
1037 fmt->saved_token = u;
1038 else
1039 {
1040 u = format_lex (fmt);
1041 if (u != FMT_POSINT)
1042 {
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 }
1054 }
1055 tail->u.real.e = fmt->value;
1056 }
1057 break;
1058 }
1059
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 }
1068 break;
1069
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
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));
1080 GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
1081 GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
1082
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. */
1111 gfc_full_array_i4 *vp = tail->u.udf.vlist;
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;
1122 case FMT_H:
1123 if (repeat > fmt->format_string_len)
1124 {
1125 fmt->error = bad_hollerith;
1126 goto finished;
1127 }
1128
1129 get_fnode (fmt, &head, &tail, FMT_STRING);
1130 tail->u.string.p = fmt->format_string;
1131 tail->u.string.length = repeat;
1132 tail->repeat = 1;
1133
1134 fmt->format_string += fmt->value;
1135 fmt->format_string_len -= repeat;
1136
1137 break;
1138
1139 case FMT_I:
1140 case FMT_B:
1141 case FMT_O:
1142 case FMT_Z:
1143 *seen_dd = true;
1144 get_fnode (fmt, &head, &tail, t);
1145 tail->repeat = repeat;
1146
1147 t = format_lex (fmt);
1148
1149 if (dtp->u.p.mode == READING)
1150 {
1151 if (t != FMT_POSINT)
1152 {
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 }
1160 fmt->error = posint_required;
1161 goto finished;
1162 }
1163 }
1164 else
1165 {
1166 if (t != FMT_ZERO && t != FMT_POSINT)
1167 {
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 }
1175 fmt->error = nonneg_required;
1176 goto finished;
1177 }
1178 }
1179
1180 tail->u.integer.w = fmt->value;
1181 tail->u.integer.m = -1;
1182
1183 t = format_lex (fmt);
1184 if (t != FMT_PERIOD)
1185 {
1186 fmt->saved_token = t;
1187 }
1188 else
1189 {
1190 t = format_lex (fmt);
1191 if (t != FMT_ZERO && t != FMT_POSINT)
1192 {
1193 fmt->error = nonneg_required;
1194 goto finished;
1195 }
1196
1197 tail->u.integer.m = fmt->value;
1198 }
1199
1200 if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
1201 {
1202 fmt->error = "Minimum digits exceeds field width";
1203 goto finished;
1204 }
1205
1206 break;
1207
1208 default:
1209 fmt->error = unexpected_element;
1210 goto finished;
1211 }
1212
1213 /* Between a descriptor and what comes next */
1214 between_desc:
1215 t = format_lex (fmt);
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:
1225 case FMT_COLON:
1226 get_fnode (fmt, &head, &tail, t);
1227 tail->repeat = 1;
1228 goto optional_comma;
1229
1230 case FMT_END:
1231 fmt->error = unexpected_end;
1232 goto finished;
1233
1234 default:
1235 /* Assume a missing comma, this is a GNU extension */
1236 goto format_item_1;
1237 }
1238
1239 /* Optional comma is a weird between state where we've just finished
1240 reading a colon, slash or P descriptor. */
1241 optional_comma:
1242 t = format_lex (fmt);
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 */
1252 fmt->saved_token = t;
1253 break;
1254 }
1255
1256 goto format_item;
1257
1258 finished:
1259
1260 return head;
1261 }
1262
1263
1264 /* format_error()-- Generate an error message for a format statement.
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. */
1272
1273 void
1274 format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
1275 {
1276 int width, i, offset;
1277 #define BUFLEN 300
1278 char *p, buffer[BUFLEN];
1279 format_data *fmt = dtp->u.p.fmt;
1280
1281 if (f != NULL)
1282 p = f->source;
1283 else /* This should not happen. */
1284 p = dtp->format;
1285
1286 if (message == unexpected_element)
1287 snprintf (buffer, BUFLEN, message, fmt->error_element);
1288 else
1289 snprintf (buffer, BUFLEN, "%s\n", message);
1290
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);
1294
1295 width = dtp->format_len;
1296
1297 if (width > 80)
1298 width = 80;
1299
1300 /* Show the format */
1301
1302 p = strchr (buffer, '\0');
1303
1304 if (dtp->format)
1305 memcpy (p, dtp->format, width);
1306
1307 p += width;
1308 *p++ = '\n';
1309
1310 /* Show where the problem is */
1311
1312 for (i = 1; i < offset; i++)
1313 *p++ = ' ';
1314
1315 *p++ = '^';
1316 *p = '\0';
1317
1318 generate_error (&dtp->common, LIBERROR_FORMAT, buffer);
1319 }
1320
1321
1322 /* revert()-- Do reversion of the format. Control reverts to the left
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. */
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
1349 /* parse_format()-- Parse a format string. */
1350
1351 void
1352 parse_format (st_parameter_dt *dtp)
1353 {
1354 format_data *fmt;
1355 bool format_cache_ok, seen_data_desc = false;
1356
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);
1363
1364 /* Lookup format string to see if it has already been parsed. */
1365 if (format_cache_ok)
1366 {
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 }
1377 }
1378
1379 /* Not found so proceed as follows. */
1380
1381 char *fmt_string = fc_strdup_notrim (dtp->format, dtp->format_len);
1382 dtp->format = fmt_string;
1383
1384 dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data));
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;
1392
1393 /* Initialize variables used during traversal of the tree. */
1394
1395 fmt->reversion_ok = 0;
1396 fmt->saved_format = NULL;
1397
1398 /* Initialize the fnode_array. */
1399
1400 memset (&(fmt->array), 0, sizeof(fmt->array));
1401
1402 /* Allocate the first format node as the root of the tree. */
1403
1404 fmt->last = &fmt->array;
1405 fmt->last->next = NULL;
1406 fmt->avail = &fmt->array.array[0];
1407
1408 memset (fmt->avail, 0, sizeof (*fmt->avail));
1409 fmt->avail->format = FMT_LPAREN;
1410 fmt->avail->repeat = 1;
1411 fmt->avail++;
1412
1413 if (format_lex (fmt) == FMT_LPAREN)
1414 fmt->array.array[0].u.child = parse_format_list (dtp, &seen_data_desc);
1415 else
1416 fmt->error = "Missing initial left parenthesis in format";
1417
1418 if (format_cache_ok)
1419 save_parsed_format (dtp);
1420 else
1421 dtp->u.p.format_not_saved = 1;
1422
1423 if (fmt->error)
1424 format_error (dtp, NULL, fmt->error);
1425 }
1426
1427
1428 /* next_format0()-- Get the next format node without worrying about
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. */
1432
1433 static const fnode *
1434 next_format0 (fnode *f)
1435 {
1436 const fnode *r;
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
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 }
1466
1467 /* Deal with a parenthesis node with specific repeat count. */
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
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). */
1492
1493 const fnode *
1494 next_format (st_parameter_dt *dtp)
1495 {
1496 format_token t;
1497 const fnode *f;
1498 format_data *fmt = dtp->u.p.fmt;
1499
1500 if (fmt->saved_format != NULL)
1501 { /* Deal with a pushed-back format node */
1502 f = fmt->saved_format;
1503 fmt->saved_format = NULL;
1504 goto done;
1505 }
1506
1507 f = next_format0 (&fmt->array.array[0]);
1508 if (f == NULL)
1509 {
1510 if (!fmt->reversion_ok)
1511 return NULL;
1512
1513 fmt->reversion_ok = 0;
1514 revert (dtp);
1515
1516 f = next_format0 (&fmt->array.array[0]);
1517 if (f == NULL)
1518 {
1519 format_error (dtp, NULL, reversion_error);
1520 return NULL;
1521 }
1522
1523 /* Push the first reverted token and return a colon node in case
1524 there are no more data items. */
1525
1526 fmt->saved_format = f;
1527 return &colon_node;
1528 }
1529
1530 /* If this is a data edit descriptor, then reversion has become OK. */
1531 done:
1532 t = f->format;
1533
1534 if (!fmt->reversion_ok &&
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 ||
1537 t == FMT_A || t == FMT_D || t == FMT_DT))
1538 fmt->reversion_ok = 1;
1539 return f;
1540 }
1541
1542
1543 /* unget_format()-- Push the given format back so that it will be
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). */
1549
1550 void
1551 unget_format (st_parameter_dt *dtp, const fnode *f)
1552 {
1553 dtp->u.p.fmt->saved_format = f;
1554 }
1555