1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2022 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "options.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
28
29 int gfc_matching_ptr_assignment = 0;
30 int gfc_matching_procptr_assignment = 0;
31 bool gfc_matching_prefix = false;
32
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack *select_type_stack = NULL;
35
36 /* List of type parameter expressions. */
37 gfc_actual_arglist *type_param_spec_list;
38
39 /* For debugging and diagnostic purposes. Return the textual representation
40 of the intrinsic operator OP. */
41 const char *
gfc_op2string(gfc_intrinsic_op op)42 gfc_op2string (gfc_intrinsic_op op)
43 {
44 switch (op)
45 {
46 case INTRINSIC_UPLUS:
47 case INTRINSIC_PLUS:
48 return "+";
49
50 case INTRINSIC_UMINUS:
51 case INTRINSIC_MINUS:
52 return "-";
53
54 case INTRINSIC_POWER:
55 return "**";
56 case INTRINSIC_CONCAT:
57 return "//";
58 case INTRINSIC_TIMES:
59 return "*";
60 case INTRINSIC_DIVIDE:
61 return "/";
62
63 case INTRINSIC_AND:
64 return ".and.";
65 case INTRINSIC_OR:
66 return ".or.";
67 case INTRINSIC_EQV:
68 return ".eqv.";
69 case INTRINSIC_NEQV:
70 return ".neqv.";
71
72 case INTRINSIC_EQ_OS:
73 return ".eq.";
74 case INTRINSIC_EQ:
75 return "==";
76 case INTRINSIC_NE_OS:
77 return ".ne.";
78 case INTRINSIC_NE:
79 return "/=";
80 case INTRINSIC_GE_OS:
81 return ".ge.";
82 case INTRINSIC_GE:
83 return ">=";
84 case INTRINSIC_LE_OS:
85 return ".le.";
86 case INTRINSIC_LE:
87 return "<=";
88 case INTRINSIC_LT_OS:
89 return ".lt.";
90 case INTRINSIC_LT:
91 return "<";
92 case INTRINSIC_GT_OS:
93 return ".gt.";
94 case INTRINSIC_GT:
95 return ">";
96 case INTRINSIC_NOT:
97 return ".not.";
98
99 case INTRINSIC_ASSIGN:
100 return "=";
101
102 case INTRINSIC_PARENTHESES:
103 return "parens";
104
105 case INTRINSIC_NONE:
106 return "none";
107
108 /* DTIO */
109 case INTRINSIC_FORMATTED:
110 return "formatted";
111 case INTRINSIC_UNFORMATTED:
112 return "unformatted";
113
114 default:
115 break;
116 }
117
118 gfc_internal_error ("gfc_op2string(): Bad code");
119 /* Not reached. */
120 }
121
122
123 /******************** Generic matching subroutines ************************/
124
125 /* Matches a member separator. With standard FORTRAN this is '%', but with
126 DEC structures we must carefully match dot ('.').
127 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
128 can be either a component reference chain or a combination of binary
129 operations.
130 There is no real way to win because the string may be grammatically
131 ambiguous. The following rules help avoid ambiguities - they match
132 some behavior of other (older) compilers. If the rules here are changed
133 the test cases should be updated. If the user has problems with these rules
134 they probably deserve the consequences. Consider "x.y.z":
135 (1) If any user defined operator ".y." exists, this is always y(x,z)
136 (even if ".y." is the wrong type and/or x has a member y).
137 (2) Otherwise if x has a member y, and y is itself a derived type,
138 this is (x->y)->z, even if an intrinsic operator exists which
139 can handle (x,z).
140 (3) If x has no member y or (x->y) is not a derived type but ".y."
141 is an intrinsic operator (such as ".eq."), this is y(x,z).
142 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
143 error.
144 It is worth noting that the logic here does not support mixed use of member
145 accessors within a single string. That is, even if x has component y and y
146 has component z, the following are all syntax errors:
147 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
148 */
149
150 match
gfc_match_member_sep(gfc_symbol * sym)151 gfc_match_member_sep(gfc_symbol *sym)
152 {
153 char name[GFC_MAX_SYMBOL_LEN + 1];
154 locus dot_loc, start_loc;
155 gfc_intrinsic_op iop;
156 match m;
157 gfc_symbol *tsym;
158 gfc_component *c = NULL;
159
160 /* What a relief: '%' is an unambiguous member separator. */
161 if (gfc_match_char ('%') == MATCH_YES)
162 return MATCH_YES;
163
164 /* Beware ye who enter here. */
165 if (!flag_dec_structure || !sym)
166 return MATCH_NO;
167
168 tsym = NULL;
169
170 /* We may be given either a derived type variable or the derived type
171 declaration itself (which actually contains the components);
172 we need the latter to search for components. */
173 if (gfc_fl_struct (sym->attr.flavor))
174 tsym = sym;
175 else if (gfc_bt_struct (sym->ts.type))
176 tsym = sym->ts.u.derived;
177
178 iop = INTRINSIC_NONE;
179 name[0] = '\0';
180 m = MATCH_NO;
181
182 /* If we have to reject come back here later. */
183 start_loc = gfc_current_locus;
184
185 /* Look for a component access next. */
186 if (gfc_match_char ('.') != MATCH_YES)
187 return MATCH_NO;
188
189 /* If we accept, come back here. */
190 dot_loc = gfc_current_locus;
191
192 /* Try to match a symbol name following the dot. */
193 if (gfc_match_name (name) != MATCH_YES)
194 {
195 gfc_error ("Expected structure component or operator name "
196 "after '.' at %C");
197 goto error;
198 }
199
200 /* If no dot follows we have "x.y" which should be a component access. */
201 if (gfc_match_char ('.') != MATCH_YES)
202 goto yes;
203
204 /* Now we have a string "x.y.z" which could be a nested member access
205 (x->y)->z or a binary operation y on x and z. */
206
207 /* First use any user-defined operators ".y." */
208 if (gfc_find_uop (name, sym->ns) != NULL)
209 goto no;
210
211 /* Match accesses to existing derived-type components for
212 derived-type vars: "x.y.z" = (x->y)->z */
213 c = gfc_find_component(tsym, name, false, true, NULL);
214 if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
215 goto yes;
216
217 /* If y is not a component or has no members, try intrinsic operators. */
218 gfc_current_locus = start_loc;
219 if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
220 {
221 /* If ".y." is not an intrinsic operator but y was a valid non-
222 structure component, match and leave the trailing dot to be
223 dealt with later. */
224 if (c)
225 goto yes;
226
227 gfc_error ("%qs is neither a defined operator nor a "
228 "structure component in dotted string at %C", name);
229 goto error;
230 }
231
232 /* .y. is an intrinsic operator, overriding any possible member access. */
233 goto no;
234
235 /* Return keeping the current locus consistent with the match result. */
236 error:
237 m = MATCH_ERROR;
238 no:
239 gfc_current_locus = start_loc;
240 return m;
241 yes:
242 gfc_current_locus = dot_loc;
243 return MATCH_YES;
244 }
245
246
247 /* This function scans the current statement counting the opened and closed
248 parenthesis to make sure they are balanced. */
249
250 match
gfc_match_parens(void)251 gfc_match_parens (void)
252 {
253 locus old_loc, where;
254 int count;
255 gfc_instring instring;
256 gfc_char_t c, quote;
257
258 old_loc = gfc_current_locus;
259 count = 0;
260 instring = NONSTRING;
261 quote = ' ';
262
263 for (;;)
264 {
265 if (count > 0)
266 where = gfc_current_locus;
267 c = gfc_next_char_literal (instring);
268 if (c == '\n')
269 break;
270 if (quote == ' ' && ((c == '\'') || (c == '"')))
271 {
272 quote = c;
273 instring = INSTRING_WARN;
274 continue;
275 }
276 if (quote != ' ' && c == quote)
277 {
278 quote = ' ';
279 instring = NONSTRING;
280 continue;
281 }
282
283 if (c == '(' && quote == ' ')
284 {
285 count++;
286 }
287 if (c == ')' && quote == ' ')
288 {
289 count--;
290 where = gfc_current_locus;
291 }
292 }
293
294 gfc_current_locus = old_loc;
295
296 if (count != 0)
297 {
298 gfc_error ("Missing %qs in statement at or before %L",
299 count > 0? ")":"(", &where);
300 return MATCH_ERROR;
301 }
302
303 return MATCH_YES;
304 }
305
306
307 /* See if the next character is a special character that has
308 escaped by a \ via the -fbackslash option. */
309
310 match
gfc_match_special_char(gfc_char_t * res)311 gfc_match_special_char (gfc_char_t *res)
312 {
313 int len, i;
314 gfc_char_t c, n;
315 match m;
316
317 m = MATCH_YES;
318
319 switch ((c = gfc_next_char_literal (INSTRING_WARN)))
320 {
321 case 'a':
322 *res = '\a';
323 break;
324 case 'b':
325 *res = '\b';
326 break;
327 case 't':
328 *res = '\t';
329 break;
330 case 'f':
331 *res = '\f';
332 break;
333 case 'n':
334 *res = '\n';
335 break;
336 case 'r':
337 *res = '\r';
338 break;
339 case 'v':
340 *res = '\v';
341 break;
342 case '\\':
343 *res = '\\';
344 break;
345 case '0':
346 *res = '\0';
347 break;
348
349 case 'x':
350 case 'u':
351 case 'U':
352 /* Hexadecimal form of wide characters. */
353 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
354 n = 0;
355 for (i = 0; i < len; i++)
356 {
357 char buf[2] = { '\0', '\0' };
358
359 c = gfc_next_char_literal (INSTRING_WARN);
360 if (!gfc_wide_fits_in_byte (c)
361 || !gfc_check_digit ((unsigned char) c, 16))
362 return MATCH_NO;
363
364 buf[0] = (unsigned char) c;
365 n = n << 4;
366 n += strtol (buf, NULL, 16);
367 }
368 *res = n;
369 break;
370
371 default:
372 /* Unknown backslash codes are simply not expanded. */
373 m = MATCH_NO;
374 break;
375 }
376
377 return m;
378 }
379
380
381 /* In free form, match at least one space. Always matches in fixed
382 form. */
383
384 match
gfc_match_space(void)385 gfc_match_space (void)
386 {
387 locus old_loc;
388 char c;
389
390 if (gfc_current_form == FORM_FIXED)
391 return MATCH_YES;
392
393 old_loc = gfc_current_locus;
394
395 c = gfc_next_ascii_char ();
396 if (!gfc_is_whitespace (c))
397 {
398 gfc_current_locus = old_loc;
399 return MATCH_NO;
400 }
401
402 gfc_gobble_whitespace ();
403
404 return MATCH_YES;
405 }
406
407
408 /* Match an end of statement. End of statement is optional
409 whitespace, followed by a ';' or '\n' or comment '!'. If a
410 semicolon is found, we continue to eat whitespace and semicolons. */
411
412 match
gfc_match_eos(void)413 gfc_match_eos (void)
414 {
415 locus old_loc;
416 int flag;
417 char c;
418
419 flag = 0;
420
421 for (;;)
422 {
423 old_loc = gfc_current_locus;
424 gfc_gobble_whitespace ();
425
426 c = gfc_next_ascii_char ();
427 switch (c)
428 {
429 case '!':
430 do
431 {
432 c = gfc_next_ascii_char ();
433 }
434 while (c != '\n');
435
436 /* Fall through. */
437
438 case '\n':
439 return MATCH_YES;
440
441 case ';':
442 flag = 1;
443 continue;
444 }
445
446 break;
447 }
448
449 gfc_current_locus = old_loc;
450 return (flag) ? MATCH_YES : MATCH_NO;
451 }
452
453
454 /* Match a literal integer on the input, setting the value on
455 MATCH_YES. Literal ints occur in kind-parameters as well as
456 old-style character length specifications. If cnt is non-NULL it
457 will be set to the number of digits. */
458
459 match
gfc_match_small_literal_int(int * value,int * cnt)460 gfc_match_small_literal_int (int *value, int *cnt)
461 {
462 locus old_loc;
463 char c;
464 int i, j;
465
466 old_loc = gfc_current_locus;
467
468 *value = -1;
469 gfc_gobble_whitespace ();
470 c = gfc_next_ascii_char ();
471 if (cnt)
472 *cnt = 0;
473
474 if (!ISDIGIT (c))
475 {
476 gfc_current_locus = old_loc;
477 return MATCH_NO;
478 }
479
480 i = c - '0';
481 j = 1;
482
483 for (;;)
484 {
485 old_loc = gfc_current_locus;
486 c = gfc_next_ascii_char ();
487
488 if (!ISDIGIT (c))
489 break;
490
491 i = 10 * i + c - '0';
492 j++;
493
494 if (i > 99999999)
495 {
496 gfc_error ("Integer too large at %C");
497 return MATCH_ERROR;
498 }
499 }
500
501 gfc_current_locus = old_loc;
502
503 *value = i;
504 if (cnt)
505 *cnt = j;
506 return MATCH_YES;
507 }
508
509
510 /* Match a small, constant integer expression, like in a kind
511 statement. On MATCH_YES, 'value' is set. */
512
513 match
gfc_match_small_int(int * value)514 gfc_match_small_int (int *value)
515 {
516 gfc_expr *expr;
517 match m;
518 int i;
519
520 m = gfc_match_expr (&expr);
521 if (m != MATCH_YES)
522 return m;
523
524 if (gfc_extract_int (expr, &i, 1))
525 m = MATCH_ERROR;
526 gfc_free_expr (expr);
527
528 *value = i;
529 return m;
530 }
531
532
533 /* Matches a statement label. Uses gfc_match_small_literal_int() to
534 do most of the work. */
535
536 match
gfc_match_st_label(gfc_st_label ** label)537 gfc_match_st_label (gfc_st_label **label)
538 {
539 locus old_loc;
540 match m;
541 int i, cnt;
542
543 old_loc = gfc_current_locus;
544
545 m = gfc_match_small_literal_int (&i, &cnt);
546 if (m != MATCH_YES)
547 return m;
548
549 if (cnt > 5)
550 {
551 gfc_error ("Too many digits in statement label at %C");
552 goto cleanup;
553 }
554
555 if (i == 0)
556 {
557 gfc_error ("Statement label at %C is zero");
558 goto cleanup;
559 }
560
561 *label = gfc_get_st_label (i);
562 return MATCH_YES;
563
564 cleanup:
565
566 gfc_current_locus = old_loc;
567 return MATCH_ERROR;
568 }
569
570
571 /* Match and validate a label associated with a named IF, DO or SELECT
572 statement. If the symbol does not have the label attribute, we add
573 it. We also make sure the symbol does not refer to another
574 (active) block. A matched label is pointed to by gfc_new_block. */
575
576 static match
gfc_match_label(void)577 gfc_match_label (void)
578 {
579 char name[GFC_MAX_SYMBOL_LEN + 1];
580 match m;
581
582 gfc_new_block = NULL;
583
584 m = gfc_match (" %n :", name);
585 if (m != MATCH_YES)
586 return m;
587
588 if (gfc_get_symbol (name, NULL, &gfc_new_block))
589 {
590 gfc_error ("Label name %qs at %C is ambiguous", name);
591 return MATCH_ERROR;
592 }
593
594 if (gfc_new_block->attr.flavor == FL_LABEL)
595 {
596 gfc_error ("Duplicate construct label %qs at %C", name);
597 return MATCH_ERROR;
598 }
599
600 if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
601 gfc_new_block->name, NULL))
602 return MATCH_ERROR;
603
604 return MATCH_YES;
605 }
606
607
608 /* See if the current input looks like a name of some sort. Modifies
609 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
610 Note that options.cc restricts max_identifier_length to not more
611 than GFC_MAX_SYMBOL_LEN. */
612
613 match
gfc_match_name(char * buffer)614 gfc_match_name (char *buffer)
615 {
616 locus old_loc;
617 int i;
618 char c;
619
620 old_loc = gfc_current_locus;
621 gfc_gobble_whitespace ();
622
623 c = gfc_next_ascii_char ();
624 if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore)))
625 {
626 /* Special cases for unary minus and plus, which allows for a sensible
627 error message for code of the form 'c = exp(-a*b) )' where an
628 extra ')' appears at the end of statement. */
629 if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+')
630 gfc_error ("Invalid character in name at %C");
631 gfc_current_locus = old_loc;
632 return MATCH_NO;
633 }
634
635 i = 0;
636
637 do
638 {
639 buffer[i++] = c;
640
641 if (i > gfc_option.max_identifier_length)
642 {
643 gfc_error ("Name at %C is too long");
644 return MATCH_ERROR;
645 }
646
647 old_loc = gfc_current_locus;
648 c = gfc_next_ascii_char ();
649 }
650 while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$'));
651
652 if (c == '$' && !flag_dollar_ok)
653 {
654 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
655 "allow it as an extension", &old_loc);
656 return MATCH_ERROR;
657 }
658
659 buffer[i] = '\0';
660 gfc_current_locus = old_loc;
661
662 return MATCH_YES;
663 }
664
665
666 /* Match a symbol on the input. Modifies the pointer to the symbol
667 pointer if successful. */
668
669 match
gfc_match_sym_tree(gfc_symtree ** matched_symbol,int host_assoc)670 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
671 {
672 char buffer[GFC_MAX_SYMBOL_LEN + 1];
673 match m;
674
675 m = gfc_match_name (buffer);
676 if (m != MATCH_YES)
677 return m;
678
679 if (host_assoc)
680 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
681 ? MATCH_ERROR : MATCH_YES;
682
683 if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
684 return MATCH_ERROR;
685
686 return MATCH_YES;
687 }
688
689
690 match
gfc_match_symbol(gfc_symbol ** matched_symbol,int host_assoc)691 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
692 {
693 gfc_symtree *st;
694 match m;
695
696 m = gfc_match_sym_tree (&st, host_assoc);
697
698 if (m == MATCH_YES)
699 {
700 if (st)
701 *matched_symbol = st->n.sym;
702 else
703 *matched_symbol = NULL;
704 }
705 else
706 *matched_symbol = NULL;
707 return m;
708 }
709
710
711 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
712 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
713 in matchexp.cc. */
714
715 match
gfc_match_intrinsic_op(gfc_intrinsic_op * result)716 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
717 {
718 locus orig_loc = gfc_current_locus;
719 char ch;
720
721 gfc_gobble_whitespace ();
722 ch = gfc_next_ascii_char ();
723 switch (ch)
724 {
725 case '+':
726 /* Matched "+". */
727 *result = INTRINSIC_PLUS;
728 return MATCH_YES;
729
730 case '-':
731 /* Matched "-". */
732 *result = INTRINSIC_MINUS;
733 return MATCH_YES;
734
735 case '=':
736 if (gfc_next_ascii_char () == '=')
737 {
738 /* Matched "==". */
739 *result = INTRINSIC_EQ;
740 return MATCH_YES;
741 }
742 break;
743
744 case '<':
745 if (gfc_peek_ascii_char () == '=')
746 {
747 /* Matched "<=". */
748 gfc_next_ascii_char ();
749 *result = INTRINSIC_LE;
750 return MATCH_YES;
751 }
752 /* Matched "<". */
753 *result = INTRINSIC_LT;
754 return MATCH_YES;
755
756 case '>':
757 if (gfc_peek_ascii_char () == '=')
758 {
759 /* Matched ">=". */
760 gfc_next_ascii_char ();
761 *result = INTRINSIC_GE;
762 return MATCH_YES;
763 }
764 /* Matched ">". */
765 *result = INTRINSIC_GT;
766 return MATCH_YES;
767
768 case '*':
769 if (gfc_peek_ascii_char () == '*')
770 {
771 /* Matched "**". */
772 gfc_next_ascii_char ();
773 *result = INTRINSIC_POWER;
774 return MATCH_YES;
775 }
776 /* Matched "*". */
777 *result = INTRINSIC_TIMES;
778 return MATCH_YES;
779
780 case '/':
781 ch = gfc_peek_ascii_char ();
782 if (ch == '=')
783 {
784 /* Matched "/=". */
785 gfc_next_ascii_char ();
786 *result = INTRINSIC_NE;
787 return MATCH_YES;
788 }
789 else if (ch == '/')
790 {
791 /* Matched "//". */
792 gfc_next_ascii_char ();
793 *result = INTRINSIC_CONCAT;
794 return MATCH_YES;
795 }
796 /* Matched "/". */
797 *result = INTRINSIC_DIVIDE;
798 return MATCH_YES;
799
800 case '.':
801 ch = gfc_next_ascii_char ();
802 switch (ch)
803 {
804 case 'a':
805 if (gfc_next_ascii_char () == 'n'
806 && gfc_next_ascii_char () == 'd'
807 && gfc_next_ascii_char () == '.')
808 {
809 /* Matched ".and.". */
810 *result = INTRINSIC_AND;
811 return MATCH_YES;
812 }
813 break;
814
815 case 'e':
816 if (gfc_next_ascii_char () == 'q')
817 {
818 ch = gfc_next_ascii_char ();
819 if (ch == '.')
820 {
821 /* Matched ".eq.". */
822 *result = INTRINSIC_EQ_OS;
823 return MATCH_YES;
824 }
825 else if (ch == 'v')
826 {
827 if (gfc_next_ascii_char () == '.')
828 {
829 /* Matched ".eqv.". */
830 *result = INTRINSIC_EQV;
831 return MATCH_YES;
832 }
833 }
834 }
835 break;
836
837 case 'g':
838 ch = gfc_next_ascii_char ();
839 if (ch == 'e')
840 {
841 if (gfc_next_ascii_char () == '.')
842 {
843 /* Matched ".ge.". */
844 *result = INTRINSIC_GE_OS;
845 return MATCH_YES;
846 }
847 }
848 else if (ch == 't')
849 {
850 if (gfc_next_ascii_char () == '.')
851 {
852 /* Matched ".gt.". */
853 *result = INTRINSIC_GT_OS;
854 return MATCH_YES;
855 }
856 }
857 break;
858
859 case 'l':
860 ch = gfc_next_ascii_char ();
861 if (ch == 'e')
862 {
863 if (gfc_next_ascii_char () == '.')
864 {
865 /* Matched ".le.". */
866 *result = INTRINSIC_LE_OS;
867 return MATCH_YES;
868 }
869 }
870 else if (ch == 't')
871 {
872 if (gfc_next_ascii_char () == '.')
873 {
874 /* Matched ".lt.". */
875 *result = INTRINSIC_LT_OS;
876 return MATCH_YES;
877 }
878 }
879 break;
880
881 case 'n':
882 ch = gfc_next_ascii_char ();
883 if (ch == 'e')
884 {
885 ch = gfc_next_ascii_char ();
886 if (ch == '.')
887 {
888 /* Matched ".ne.". */
889 *result = INTRINSIC_NE_OS;
890 return MATCH_YES;
891 }
892 else if (ch == 'q')
893 {
894 if (gfc_next_ascii_char () == 'v'
895 && gfc_next_ascii_char () == '.')
896 {
897 /* Matched ".neqv.". */
898 *result = INTRINSIC_NEQV;
899 return MATCH_YES;
900 }
901 }
902 }
903 else if (ch == 'o')
904 {
905 if (gfc_next_ascii_char () == 't'
906 && gfc_next_ascii_char () == '.')
907 {
908 /* Matched ".not.". */
909 *result = INTRINSIC_NOT;
910 return MATCH_YES;
911 }
912 }
913 break;
914
915 case 'o':
916 if (gfc_next_ascii_char () == 'r'
917 && gfc_next_ascii_char () == '.')
918 {
919 /* Matched ".or.". */
920 *result = INTRINSIC_OR;
921 return MATCH_YES;
922 }
923 break;
924
925 case 'x':
926 if (gfc_next_ascii_char () == 'o'
927 && gfc_next_ascii_char () == 'r'
928 && gfc_next_ascii_char () == '.')
929 {
930 if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C"))
931 return MATCH_ERROR;
932 /* Matched ".xor." - equivalent to ".neqv.". */
933 *result = INTRINSIC_NEQV;
934 return MATCH_YES;
935 }
936 break;
937
938 default:
939 break;
940 }
941 break;
942
943 default:
944 break;
945 }
946
947 gfc_current_locus = orig_loc;
948 return MATCH_NO;
949 }
950
951
952 /* Match a loop control phrase:
953
954 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
955
956 If the final integer expression is not present, a constant unity
957 expression is returned. We don't return MATCH_ERROR until after
958 the equals sign is seen. */
959
960 match
gfc_match_iterator(gfc_iterator * iter,int init_flag)961 gfc_match_iterator (gfc_iterator *iter, int init_flag)
962 {
963 char name[GFC_MAX_SYMBOL_LEN + 1];
964 gfc_expr *var, *e1, *e2, *e3;
965 locus start;
966 match m;
967
968 e1 = e2 = e3 = NULL;
969
970 /* Match the start of an iterator without affecting the symbol table. */
971
972 start = gfc_current_locus;
973 m = gfc_match (" %n =", name);
974 gfc_current_locus = start;
975
976 if (m != MATCH_YES)
977 return MATCH_NO;
978
979 m = gfc_match_variable (&var, 0);
980 if (m != MATCH_YES)
981 return MATCH_NO;
982
983 if (var->symtree->n.sym->attr.dimension)
984 {
985 gfc_error ("Loop variable at %C cannot be an array");
986 goto cleanup;
987 }
988
989 /* F2008, C617 & C565. */
990 if (var->symtree->n.sym->attr.codimension)
991 {
992 gfc_error ("Loop variable at %C cannot be a coarray");
993 goto cleanup;
994 }
995
996 if (var->ref != NULL)
997 {
998 gfc_error ("Loop variable at %C cannot be a sub-component");
999 goto cleanup;
1000 }
1001
1002 gfc_match_char ('=');
1003
1004 var->symtree->n.sym->attr.implied_index = 1;
1005
1006 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
1007 if (m == MATCH_NO)
1008 goto syntax;
1009 if (m == MATCH_ERROR)
1010 goto cleanup;
1011
1012 if (gfc_match_char (',') != MATCH_YES)
1013 goto syntax;
1014
1015 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
1016 if (m == MATCH_NO)
1017 goto syntax;
1018 if (m == MATCH_ERROR)
1019 goto cleanup;
1020
1021 if (gfc_match_char (',') != MATCH_YES)
1022 {
1023 e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1024 goto done;
1025 }
1026
1027 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1028 if (m == MATCH_ERROR)
1029 goto cleanup;
1030 if (m == MATCH_NO)
1031 {
1032 gfc_error ("Expected a step value in iterator at %C");
1033 goto cleanup;
1034 }
1035
1036 done:
1037 iter->var = var;
1038 iter->start = e1;
1039 iter->end = e2;
1040 iter->step = e3;
1041 return MATCH_YES;
1042
1043 syntax:
1044 gfc_error ("Syntax error in iterator at %C");
1045
1046 cleanup:
1047 gfc_free_expr (e1);
1048 gfc_free_expr (e2);
1049 gfc_free_expr (e3);
1050
1051 return MATCH_ERROR;
1052 }
1053
1054
1055 /* Tries to match the next non-whitespace character on the input.
1056 This subroutine does not return MATCH_ERROR. */
1057
1058 match
gfc_match_char(char c)1059 gfc_match_char (char c)
1060 {
1061 locus where;
1062
1063 where = gfc_current_locus;
1064 gfc_gobble_whitespace ();
1065
1066 if (gfc_next_ascii_char () == c)
1067 return MATCH_YES;
1068
1069 gfc_current_locus = where;
1070 return MATCH_NO;
1071 }
1072
1073
1074 /* General purpose matching subroutine. The target string is a
1075 scanf-like format string in which spaces correspond to arbitrary
1076 whitespace (including no whitespace), characters correspond to
1077 themselves. The %-codes are:
1078
1079 %% Literal percent sign
1080 %e Expression, pointer to a pointer is set
1081 %s Symbol, pointer to the symbol is set
1082 %n Name, character buffer is set to name
1083 %t Matches end of statement.
1084 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1085 %l Matches a statement label
1086 %v Matches a variable expression (an lvalue, except function references
1087 having a data pointer result)
1088 % Matches a required space (in free form) and optional spaces. */
1089
1090 match
gfc_match(const char * target,...)1091 gfc_match (const char *target, ...)
1092 {
1093 gfc_st_label **label;
1094 int matches, *ip;
1095 locus old_loc;
1096 va_list argp;
1097 char c, *np;
1098 match m, n;
1099 void **vp;
1100 const char *p;
1101
1102 old_loc = gfc_current_locus;
1103 va_start (argp, target);
1104 m = MATCH_NO;
1105 matches = 0;
1106 p = target;
1107
1108 loop:
1109 c = *p++;
1110 switch (c)
1111 {
1112 case ' ':
1113 gfc_gobble_whitespace ();
1114 goto loop;
1115 case '\0':
1116 m = MATCH_YES;
1117 break;
1118
1119 case '%':
1120 c = *p++;
1121 switch (c)
1122 {
1123 case 'e':
1124 vp = va_arg (argp, void **);
1125 n = gfc_match_expr ((gfc_expr **) vp);
1126 if (n != MATCH_YES)
1127 {
1128 m = n;
1129 goto not_yes;
1130 }
1131
1132 matches++;
1133 goto loop;
1134
1135 case 'v':
1136 vp = va_arg (argp, void **);
1137 n = gfc_match_variable ((gfc_expr **) vp, 0);
1138 if (n != MATCH_YES)
1139 {
1140 m = n;
1141 goto not_yes;
1142 }
1143
1144 matches++;
1145 goto loop;
1146
1147 case 's':
1148 vp = va_arg (argp, void **);
1149 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1150 if (n != MATCH_YES)
1151 {
1152 m = n;
1153 goto not_yes;
1154 }
1155
1156 matches++;
1157 goto loop;
1158
1159 case 'n':
1160 np = va_arg (argp, char *);
1161 n = gfc_match_name (np);
1162 if (n != MATCH_YES)
1163 {
1164 m = n;
1165 goto not_yes;
1166 }
1167
1168 matches++;
1169 goto loop;
1170
1171 case 'l':
1172 label = va_arg (argp, gfc_st_label **);
1173 n = gfc_match_st_label (label);
1174 if (n != MATCH_YES)
1175 {
1176 m = n;
1177 goto not_yes;
1178 }
1179
1180 matches++;
1181 goto loop;
1182
1183 case 'o':
1184 ip = va_arg (argp, int *);
1185 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1186 if (n != MATCH_YES)
1187 {
1188 m = n;
1189 goto not_yes;
1190 }
1191
1192 matches++;
1193 goto loop;
1194
1195 case 't':
1196 if (gfc_match_eos () != MATCH_YES)
1197 {
1198 m = MATCH_NO;
1199 goto not_yes;
1200 }
1201 goto loop;
1202
1203 case ' ':
1204 if (gfc_match_space () == MATCH_YES)
1205 goto loop;
1206 m = MATCH_NO;
1207 goto not_yes;
1208
1209 case '%':
1210 break; /* Fall through to character matcher. */
1211
1212 default:
1213 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1214 }
1215 /* FALLTHRU */
1216
1217 default:
1218
1219 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1220 expect an upper case character here! */
1221 gcc_assert (TOLOWER (c) == c);
1222
1223 if (c == gfc_next_ascii_char ())
1224 goto loop;
1225 break;
1226 }
1227
1228 not_yes:
1229 va_end (argp);
1230
1231 if (m != MATCH_YES)
1232 {
1233 /* Clean up after a failed match. */
1234 gfc_current_locus = old_loc;
1235 va_start (argp, target);
1236
1237 p = target;
1238 for (; matches > 0; matches--)
1239 {
1240 while (*p++ != '%');
1241
1242 switch (*p++)
1243 {
1244 case '%':
1245 matches++;
1246 break; /* Skip. */
1247
1248 /* Matches that don't have to be undone */
1249 case 'o':
1250 case 'l':
1251 case 'n':
1252 case 's':
1253 (void) va_arg (argp, void **);
1254 break;
1255
1256 case 'e':
1257 case 'v':
1258 vp = va_arg (argp, void **);
1259 gfc_free_expr ((struct gfc_expr *)*vp);
1260 *vp = NULL;
1261 break;
1262 }
1263 }
1264
1265 va_end (argp);
1266 }
1267
1268 return m;
1269 }
1270
1271
1272 /*********************** Statement level matching **********************/
1273
1274 /* Matches the start of a program unit, which is the program keyword
1275 followed by an obligatory symbol. */
1276
1277 match
gfc_match_program(void)1278 gfc_match_program (void)
1279 {
1280 gfc_symbol *sym;
1281 match m;
1282
1283 m = gfc_match ("% %s%t", &sym);
1284
1285 if (m == MATCH_NO)
1286 {
1287 gfc_error ("Invalid form of PROGRAM statement at %C");
1288 m = MATCH_ERROR;
1289 }
1290
1291 if (m == MATCH_ERROR)
1292 return m;
1293
1294 if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL))
1295 return MATCH_ERROR;
1296
1297 gfc_new_block = sym;
1298
1299 return MATCH_YES;
1300 }
1301
1302
1303 /* Match a simple assignment statement. */
1304
1305 match
gfc_match_assignment(void)1306 gfc_match_assignment (void)
1307 {
1308 gfc_expr *lvalue, *rvalue;
1309 locus old_loc;
1310 match m;
1311
1312 old_loc = gfc_current_locus;
1313
1314 lvalue = NULL;
1315 m = gfc_match (" %v =", &lvalue);
1316 if (m != MATCH_YES)
1317 {
1318 gfc_current_locus = old_loc;
1319 gfc_free_expr (lvalue);
1320 return MATCH_NO;
1321 }
1322
1323 rvalue = NULL;
1324 m = gfc_match (" %e%t", &rvalue);
1325
1326 if (m == MATCH_YES
1327 && rvalue->ts.type == BT_BOZ
1328 && lvalue->ts.type == BT_CLASS)
1329 {
1330 m = MATCH_ERROR;
1331 gfc_error ("BOZ literal constant at %L is neither a DATA statement "
1332 "value nor an actual argument of INT/REAL/DBLE/CMPLX "
1333 "intrinsic subprogram", &rvalue->where);
1334 }
1335
1336 if (lvalue->expr_type == EXPR_CONSTANT)
1337 {
1338 /* This clobbers %len and %kind. */
1339 m = MATCH_ERROR;
1340 gfc_error ("Assignment to a constant expression at %C");
1341 }
1342
1343 if (m != MATCH_YES)
1344 {
1345 gfc_current_locus = old_loc;
1346 gfc_free_expr (lvalue);
1347 gfc_free_expr (rvalue);
1348 return m;
1349 }
1350
1351 if (!lvalue->symtree)
1352 {
1353 gfc_free_expr (lvalue);
1354 gfc_free_expr (rvalue);
1355 return MATCH_ERROR;
1356 }
1357
1358
1359 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1360
1361 new_st.op = EXEC_ASSIGN;
1362 new_st.expr1 = lvalue;
1363 new_st.expr2 = rvalue;
1364
1365 gfc_check_do_variable (lvalue->symtree);
1366
1367 return MATCH_YES;
1368 }
1369
1370
1371 /* Match a pointer assignment statement. */
1372
1373 match
gfc_match_pointer_assignment(void)1374 gfc_match_pointer_assignment (void)
1375 {
1376 gfc_expr *lvalue, *rvalue;
1377 locus old_loc;
1378 match m;
1379
1380 old_loc = gfc_current_locus;
1381
1382 lvalue = rvalue = NULL;
1383 gfc_matching_ptr_assignment = 0;
1384 gfc_matching_procptr_assignment = 0;
1385
1386 m = gfc_match (" %v =>", &lvalue);
1387 if (m != MATCH_YES || !lvalue->symtree)
1388 {
1389 m = MATCH_NO;
1390 goto cleanup;
1391 }
1392
1393 if (lvalue->symtree->n.sym->attr.proc_pointer
1394 || gfc_is_proc_ptr_comp (lvalue))
1395 gfc_matching_procptr_assignment = 1;
1396 else
1397 gfc_matching_ptr_assignment = 1;
1398
1399 m = gfc_match (" %e%t", &rvalue);
1400 gfc_matching_ptr_assignment = 0;
1401 gfc_matching_procptr_assignment = 0;
1402 if (m != MATCH_YES)
1403 goto cleanup;
1404
1405 new_st.op = EXEC_POINTER_ASSIGN;
1406 new_st.expr1 = lvalue;
1407 new_st.expr2 = rvalue;
1408
1409 return MATCH_YES;
1410
1411 cleanup:
1412 gfc_current_locus = old_loc;
1413 gfc_free_expr (lvalue);
1414 gfc_free_expr (rvalue);
1415 return m;
1416 }
1417
1418
1419 /* We try to match an easy arithmetic IF statement. This only happens
1420 when just after having encountered a simple IF statement. This code
1421 is really duplicate with parts of the gfc_match_if code, but this is
1422 *much* easier. */
1423
1424 static match
match_arithmetic_if(void)1425 match_arithmetic_if (void)
1426 {
1427 gfc_st_label *l1, *l2, *l3;
1428 gfc_expr *expr;
1429 match m;
1430
1431 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1432 if (m != MATCH_YES)
1433 return m;
1434
1435 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1436 || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1437 || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1438 {
1439 gfc_free_expr (expr);
1440 return MATCH_ERROR;
1441 }
1442
1443 if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
1444 "Arithmetic IF statement at %C"))
1445 return MATCH_ERROR;
1446
1447 new_st.op = EXEC_ARITHMETIC_IF;
1448 new_st.expr1 = expr;
1449 new_st.label1 = l1;
1450 new_st.label2 = l2;
1451 new_st.label3 = l3;
1452
1453 return MATCH_YES;
1454 }
1455
1456
1457 /* The IF statement is a bit of a pain. First of all, there are three
1458 forms of it, the simple IF, the IF that starts a block and the
1459 arithmetic IF.
1460
1461 There is a problem with the simple IF and that is the fact that we
1462 only have a single level of undo information on symbols. What this
1463 means is for a simple IF, we must re-match the whole IF statement
1464 multiple times in order to guarantee that the symbol table ends up
1465 in the proper state. */
1466
1467 static match match_simple_forall (void);
1468 static match match_simple_where (void);
1469
1470 match
gfc_match_if(gfc_statement * if_type)1471 gfc_match_if (gfc_statement *if_type)
1472 {
1473 gfc_expr *expr;
1474 gfc_st_label *l1, *l2, *l3;
1475 locus old_loc, old_loc2;
1476 gfc_code *p;
1477 match m, n;
1478
1479 n = gfc_match_label ();
1480 if (n == MATCH_ERROR)
1481 return n;
1482
1483 old_loc = gfc_current_locus;
1484
1485 m = gfc_match (" if ", &expr);
1486 if (m != MATCH_YES)
1487 return m;
1488
1489 if (gfc_match_char ('(') != MATCH_YES)
1490 {
1491 gfc_error ("Missing %<(%> in IF-expression at %C");
1492 return MATCH_ERROR;
1493 }
1494
1495 m = gfc_match ("%e", &expr);
1496 if (m != MATCH_YES)
1497 return m;
1498
1499 old_loc2 = gfc_current_locus;
1500 gfc_current_locus = old_loc;
1501
1502 if (gfc_match_parens () == MATCH_ERROR)
1503 return MATCH_ERROR;
1504
1505 gfc_current_locus = old_loc2;
1506
1507 if (gfc_match_char (')') != MATCH_YES)
1508 {
1509 gfc_error ("Syntax error in IF-expression at %C");
1510 gfc_free_expr (expr);
1511 return MATCH_ERROR;
1512 }
1513
1514 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1515
1516 if (m == MATCH_YES)
1517 {
1518 if (n == MATCH_YES)
1519 {
1520 gfc_error ("Block label not appropriate for arithmetic IF "
1521 "statement at %C");
1522 gfc_free_expr (expr);
1523 return MATCH_ERROR;
1524 }
1525
1526 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1527 || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1528 || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1529 {
1530 gfc_free_expr (expr);
1531 return MATCH_ERROR;
1532 }
1533
1534 if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
1535 "Arithmetic IF statement at %C"))
1536 return MATCH_ERROR;
1537
1538 new_st.op = EXEC_ARITHMETIC_IF;
1539 new_st.expr1 = expr;
1540 new_st.label1 = l1;
1541 new_st.label2 = l2;
1542 new_st.label3 = l3;
1543
1544 *if_type = ST_ARITHMETIC_IF;
1545 return MATCH_YES;
1546 }
1547
1548 if (gfc_match (" then%t") == MATCH_YES)
1549 {
1550 new_st.op = EXEC_IF;
1551 new_st.expr1 = expr;
1552 *if_type = ST_IF_BLOCK;
1553 return MATCH_YES;
1554 }
1555
1556 if (n == MATCH_YES)
1557 {
1558 gfc_error ("Block label is not appropriate for IF statement at %C");
1559 gfc_free_expr (expr);
1560 return MATCH_ERROR;
1561 }
1562
1563 /* At this point the only thing left is a simple IF statement. At
1564 this point, n has to be MATCH_NO, so we don't have to worry about
1565 re-matching a block label. From what we've got so far, try
1566 matching an assignment. */
1567
1568 *if_type = ST_SIMPLE_IF;
1569
1570 m = gfc_match_assignment ();
1571 if (m == MATCH_YES)
1572 goto got_match;
1573
1574 gfc_free_expr (expr);
1575 gfc_undo_symbols ();
1576 gfc_current_locus = old_loc;
1577
1578 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1579 assignment was found. For MATCH_NO, continue to call the various
1580 matchers. */
1581 if (m == MATCH_ERROR)
1582 return MATCH_ERROR;
1583
1584 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1585
1586 m = gfc_match_pointer_assignment ();
1587 if (m == MATCH_YES)
1588 goto got_match;
1589
1590 gfc_free_expr (expr);
1591 gfc_undo_symbols ();
1592 gfc_current_locus = old_loc;
1593
1594 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1595
1596 /* Look at the next keyword to see which matcher to call. Matching
1597 the keyword doesn't affect the symbol table, so we don't have to
1598 restore between tries. */
1599
1600 #define match(string, subr, statement) \
1601 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1602
1603 gfc_clear_error ();
1604
1605 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1606 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1607 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1608 match ("call", gfc_match_call, ST_CALL)
1609 match ("change team", gfc_match_change_team, ST_CHANGE_TEAM)
1610 match ("close", gfc_match_close, ST_CLOSE)
1611 match ("continue", gfc_match_continue, ST_CONTINUE)
1612 match ("cycle", gfc_match_cycle, ST_CYCLE)
1613 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1614 match ("end file", gfc_match_endfile, ST_END_FILE)
1615 match ("end team", gfc_match_end_team, ST_END_TEAM)
1616 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
1617 match ("event post", gfc_match_event_post, ST_EVENT_POST)
1618 match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
1619 match ("exit", gfc_match_exit, ST_EXIT)
1620 match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
1621 match ("flush", gfc_match_flush, ST_FLUSH)
1622 match ("forall", match_simple_forall, ST_FORALL)
1623 match ("form team", gfc_match_form_team, ST_FORM_TEAM)
1624 match ("go to", gfc_match_goto, ST_GOTO)
1625 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1626 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1627 match ("lock", gfc_match_lock, ST_LOCK)
1628 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1629 match ("open", gfc_match_open, ST_OPEN)
1630 match ("pause", gfc_match_pause, ST_NONE)
1631 match ("print", gfc_match_print, ST_WRITE)
1632 match ("read", gfc_match_read, ST_READ)
1633 match ("return", gfc_match_return, ST_RETURN)
1634 match ("rewind", gfc_match_rewind, ST_REWIND)
1635 match ("stop", gfc_match_stop, ST_STOP)
1636 match ("wait", gfc_match_wait, ST_WAIT)
1637 match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1638 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1639 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1640 match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM)
1641 match ("unlock", gfc_match_unlock, ST_UNLOCK)
1642 match ("where", match_simple_where, ST_WHERE)
1643 match ("write", gfc_match_write, ST_WRITE)
1644
1645 if (flag_dec)
1646 match ("type", gfc_match_print, ST_WRITE)
1647
1648 /* All else has failed, so give up. See if any of the matchers has
1649 stored an error message of some sort. */
1650 if (!gfc_error_check ())
1651 gfc_error ("Syntax error in IF-clause after %C");
1652
1653 gfc_free_expr (expr);
1654 return MATCH_ERROR;
1655
1656 got_match:
1657 if (m == MATCH_NO)
1658 gfc_error ("Syntax error in IF-clause after %C");
1659 if (m != MATCH_YES)
1660 {
1661 gfc_free_expr (expr);
1662 return MATCH_ERROR;
1663 }
1664
1665 /* At this point, we've matched the single IF and the action clause
1666 is in new_st. Rearrange things so that the IF statement appears
1667 in new_st. */
1668
1669 p = gfc_get_code (EXEC_IF);
1670 p->next = XCNEW (gfc_code);
1671 *p->next = new_st;
1672 p->next->loc = gfc_current_locus;
1673
1674 p->expr1 = expr;
1675
1676 gfc_clear_new_st ();
1677
1678 new_st.op = EXEC_IF;
1679 new_st.block = p;
1680
1681 return MATCH_YES;
1682 }
1683
1684 #undef match
1685
1686
1687 /* Match an ELSE statement. */
1688
1689 match
gfc_match_else(void)1690 gfc_match_else (void)
1691 {
1692 char name[GFC_MAX_SYMBOL_LEN + 1];
1693
1694 if (gfc_match_eos () == MATCH_YES)
1695 return MATCH_YES;
1696
1697 if (gfc_match_name (name) != MATCH_YES
1698 || gfc_current_block () == NULL
1699 || gfc_match_eos () != MATCH_YES)
1700 {
1701 gfc_error ("Invalid character(s) in ELSE statement after %C");
1702 return MATCH_ERROR;
1703 }
1704
1705 if (strcmp (name, gfc_current_block ()->name) != 0)
1706 {
1707 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1708 name, gfc_current_block ()->name);
1709 return MATCH_ERROR;
1710 }
1711
1712 return MATCH_YES;
1713 }
1714
1715
1716 /* Match an ELSE IF statement. */
1717
1718 match
gfc_match_elseif(void)1719 gfc_match_elseif (void)
1720 {
1721 char name[GFC_MAX_SYMBOL_LEN + 1];
1722 gfc_expr *expr, *then;
1723 locus where;
1724 match m;
1725
1726 if (gfc_match_char ('(') != MATCH_YES)
1727 {
1728 gfc_error ("Missing %<(%> in ELSE IF expression at %C");
1729 return MATCH_ERROR;
1730 }
1731
1732 m = gfc_match (" %e ", &expr);
1733 if (m != MATCH_YES)
1734 return m;
1735
1736 if (gfc_match_char (')') != MATCH_YES)
1737 {
1738 gfc_error ("Missing %<)%> in ELSE IF expression at %C");
1739 goto cleanup;
1740 }
1741
1742 m = gfc_match (" then ", &then);
1743
1744 where = gfc_current_locus;
1745
1746 if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES
1747 || (gfc_current_block ()
1748 && gfc_match_name (name) == MATCH_YES)))
1749 goto done;
1750
1751 if (gfc_match_eos () == MATCH_YES)
1752 {
1753 gfc_error ("Missing THEN in ELSE IF statement after %L", &where);
1754 goto cleanup;
1755 }
1756
1757 if (gfc_match_name (name) != MATCH_YES
1758 || gfc_current_block () == NULL
1759 || gfc_match_eos () != MATCH_YES)
1760 {
1761 gfc_error ("Syntax error in ELSE IF statement after %L", &where);
1762 goto cleanup;
1763 }
1764
1765 if (strcmp (name, gfc_current_block ()->name) != 0)
1766 {
1767 gfc_error ("Label %qs after %L doesn't match IF label %qs",
1768 name, &where, gfc_current_block ()->name);
1769 goto cleanup;
1770 }
1771
1772 if (m != MATCH_YES)
1773 return m;
1774
1775 done:
1776 new_st.op = EXEC_IF;
1777 new_st.expr1 = expr;
1778 return MATCH_YES;
1779
1780 cleanup:
1781 gfc_free_expr (expr);
1782 return MATCH_ERROR;
1783 }
1784
1785
1786 /* Free a gfc_iterator structure. */
1787
1788 void
gfc_free_iterator(gfc_iterator * iter,int flag)1789 gfc_free_iterator (gfc_iterator *iter, int flag)
1790 {
1791
1792 if (iter == NULL)
1793 return;
1794
1795 gfc_free_expr (iter->var);
1796 gfc_free_expr (iter->start);
1797 gfc_free_expr (iter->end);
1798 gfc_free_expr (iter->step);
1799
1800 if (flag)
1801 free (iter);
1802 }
1803
1804
1805 /* Match a CRITICAL statement. */
1806 match
gfc_match_critical(void)1807 gfc_match_critical (void)
1808 {
1809 gfc_st_label *label = NULL;
1810
1811 if (gfc_match_label () == MATCH_ERROR)
1812 return MATCH_ERROR;
1813
1814 if (gfc_match (" critical") != MATCH_YES)
1815 return MATCH_NO;
1816
1817 if (gfc_match_st_label (&label) == MATCH_ERROR)
1818 return MATCH_ERROR;
1819
1820 if (gfc_match_eos () != MATCH_YES)
1821 {
1822 gfc_syntax_error (ST_CRITICAL);
1823 return MATCH_ERROR;
1824 }
1825
1826 if (gfc_pure (NULL))
1827 {
1828 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1829 return MATCH_ERROR;
1830 }
1831
1832 if (gfc_find_state (COMP_DO_CONCURRENT))
1833 {
1834 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1835 "block");
1836 return MATCH_ERROR;
1837 }
1838
1839 gfc_unset_implicit_pure (NULL);
1840
1841 if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
1842 return MATCH_ERROR;
1843
1844 if (flag_coarray == GFC_FCOARRAY_NONE)
1845 {
1846 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1847 "enable");
1848 return MATCH_ERROR;
1849 }
1850
1851 if (gfc_find_state (COMP_CRITICAL))
1852 {
1853 gfc_error ("Nested CRITICAL block at %C");
1854 return MATCH_ERROR;
1855 }
1856
1857 new_st.op = EXEC_CRITICAL;
1858
1859 if (label != NULL
1860 && !gfc_reference_st_label (label, ST_LABEL_TARGET))
1861 return MATCH_ERROR;
1862
1863 return MATCH_YES;
1864 }
1865
1866
1867 /* Match a BLOCK statement. */
1868
1869 match
gfc_match_block(void)1870 gfc_match_block (void)
1871 {
1872 match m;
1873
1874 if (gfc_match_label () == MATCH_ERROR)
1875 return MATCH_ERROR;
1876
1877 if (gfc_match (" block") != MATCH_YES)
1878 return MATCH_NO;
1879
1880 /* For this to be a correct BLOCK statement, the line must end now. */
1881 m = gfc_match_eos ();
1882 if (m == MATCH_ERROR)
1883 return MATCH_ERROR;
1884 if (m == MATCH_NO)
1885 return MATCH_NO;
1886
1887 return MATCH_YES;
1888 }
1889
1890
1891 /* Match an ASSOCIATE statement. */
1892
1893 match
gfc_match_associate(void)1894 gfc_match_associate (void)
1895 {
1896 if (gfc_match_label () == MATCH_ERROR)
1897 return MATCH_ERROR;
1898
1899 if (gfc_match (" associate") != MATCH_YES)
1900 return MATCH_NO;
1901
1902 /* Match the association list. */
1903 if (gfc_match_char ('(') != MATCH_YES)
1904 {
1905 gfc_error ("Expected association list at %C");
1906 return MATCH_ERROR;
1907 }
1908 new_st.ext.block.assoc = NULL;
1909 while (true)
1910 {
1911 gfc_association_list* newAssoc = gfc_get_association_list ();
1912 gfc_association_list* a;
1913
1914 /* Match the next association. */
1915 if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
1916 {
1917 gfc_error ("Expected association at %C");
1918 goto assocListError;
1919 }
1920
1921 if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
1922 {
1923 /* Have another go, allowing for procedure pointer selectors. */
1924 gfc_matching_procptr_assignment = 1;
1925 if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
1926 {
1927 gfc_error ("Invalid association target at %C");
1928 goto assocListError;
1929 }
1930 gfc_matching_procptr_assignment = 0;
1931 }
1932 newAssoc->where = gfc_current_locus;
1933
1934 /* Check that the current name is not yet in the list. */
1935 for (a = new_st.ext.block.assoc; a; a = a->next)
1936 if (!strcmp (a->name, newAssoc->name))
1937 {
1938 gfc_error ("Duplicate name %qs in association at %C",
1939 newAssoc->name);
1940 goto assocListError;
1941 }
1942
1943 /* The target expression must not be coindexed. */
1944 if (gfc_is_coindexed (newAssoc->target))
1945 {
1946 gfc_error ("Association target at %C must not be coindexed");
1947 goto assocListError;
1948 }
1949
1950 /* The target expression cannot be a BOZ literal constant. */
1951 if (newAssoc->target->ts.type == BT_BOZ)
1952 {
1953 gfc_error ("Association target at %L cannot be a BOZ literal "
1954 "constant", &newAssoc->target->where);
1955 goto assocListError;
1956 }
1957
1958 /* The `variable' field is left blank for now; because the target is not
1959 yet resolved, we can't use gfc_has_vector_subscript to determine it
1960 for now. This is set during resolution. */
1961
1962 /* Put it into the list. */
1963 newAssoc->next = new_st.ext.block.assoc;
1964 new_st.ext.block.assoc = newAssoc;
1965
1966 /* Try next one or end if closing parenthesis is found. */
1967 gfc_gobble_whitespace ();
1968 if (gfc_peek_char () == ')')
1969 break;
1970 if (gfc_match_char (',') != MATCH_YES)
1971 {
1972 gfc_error ("Expected %<)%> or %<,%> at %C");
1973 return MATCH_ERROR;
1974 }
1975
1976 continue;
1977
1978 assocListError:
1979 free (newAssoc);
1980 goto error;
1981 }
1982 if (gfc_match_char (')') != MATCH_YES)
1983 {
1984 /* This should never happen as we peek above. */
1985 gcc_unreachable ();
1986 }
1987
1988 if (gfc_match_eos () != MATCH_YES)
1989 {
1990 gfc_error ("Junk after ASSOCIATE statement at %C");
1991 goto error;
1992 }
1993
1994 return MATCH_YES;
1995
1996 error:
1997 gfc_free_association_list (new_st.ext.block.assoc);
1998 return MATCH_ERROR;
1999 }
2000
2001
2002 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2003 an accessible derived type. */
2004
2005 static match
match_derived_type_spec(gfc_typespec * ts)2006 match_derived_type_spec (gfc_typespec *ts)
2007 {
2008 char name[GFC_MAX_SYMBOL_LEN + 1];
2009 locus old_locus;
2010 gfc_symbol *derived, *der_type;
2011 match m = MATCH_YES;
2012 gfc_actual_arglist *decl_type_param_list = NULL;
2013 bool is_pdt_template = false;
2014
2015 old_locus = gfc_current_locus;
2016
2017 if (gfc_match ("%n", name) != MATCH_YES)
2018 {
2019 gfc_current_locus = old_locus;
2020 return MATCH_NO;
2021 }
2022
2023 gfc_find_symbol (name, NULL, 1, &derived);
2024
2025 /* Match the PDT spec list, if there. */
2026 if (derived && derived->attr.flavor == FL_PROCEDURE)
2027 {
2028 gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
2029 is_pdt_template = der_type
2030 && der_type->attr.flavor == FL_DERIVED
2031 && der_type->attr.pdt_template;
2032 }
2033
2034 if (is_pdt_template)
2035 m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
2036
2037 if (m == MATCH_ERROR)
2038 {
2039 gfc_free_actual_arglist (decl_type_param_list);
2040 return m;
2041 }
2042
2043 if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
2044 derived = gfc_find_dt_in_generic (derived);
2045
2046 /* If this is a PDT, find the specific instance. */
2047 if (m == MATCH_YES && is_pdt_template)
2048 {
2049 gfc_namespace *old_ns;
2050
2051 old_ns = gfc_current_ns;
2052 while (gfc_current_ns && gfc_current_ns->parent)
2053 gfc_current_ns = gfc_current_ns->parent;
2054
2055 if (type_param_spec_list)
2056 gfc_free_actual_arglist (type_param_spec_list);
2057 m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
2058 &type_param_spec_list);
2059 gfc_free_actual_arglist (decl_type_param_list);
2060
2061 if (m != MATCH_YES)
2062 return m;
2063 derived = der_type;
2064 gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
2065 gfc_set_sym_referenced (derived);
2066
2067 gfc_current_ns = old_ns;
2068 }
2069
2070 if (derived && derived->attr.flavor == FL_DERIVED)
2071 {
2072 ts->type = BT_DERIVED;
2073 ts->u.derived = derived;
2074 return MATCH_YES;
2075 }
2076
2077 gfc_current_locus = old_locus;
2078 return MATCH_NO;
2079 }
2080
2081
2082 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2083 gfc_match_decl_type_spec() from decl.cc, with the following exceptions:
2084 It only includes the intrinsic types from the Fortran 2003 standard
2085 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2086 the implicit_flag is not needed, so it was removed. Derived types are
2087 identified by their name alone. */
2088
2089 match
gfc_match_type_spec(gfc_typespec * ts)2090 gfc_match_type_spec (gfc_typespec *ts)
2091 {
2092 match m;
2093 locus old_locus;
2094 char c, name[GFC_MAX_SYMBOL_LEN + 1];
2095
2096 gfc_clear_ts (ts);
2097 gfc_gobble_whitespace ();
2098 old_locus = gfc_current_locus;
2099
2100 /* If c isn't [a-z], then return immediately. */
2101 c = gfc_peek_ascii_char ();
2102 if (!ISALPHA(c))
2103 return MATCH_NO;
2104
2105 type_param_spec_list = NULL;
2106
2107 if (match_derived_type_spec (ts) == MATCH_YES)
2108 {
2109 /* Enforce F03:C401. */
2110 if (ts->u.derived->attr.abstract)
2111 {
2112 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2113 ts->u.derived->name, &old_locus);
2114 return MATCH_ERROR;
2115 }
2116 return MATCH_YES;
2117 }
2118
2119 if (gfc_match ("integer") == MATCH_YES)
2120 {
2121 ts->type = BT_INTEGER;
2122 ts->kind = gfc_default_integer_kind;
2123 goto kind_selector;
2124 }
2125
2126 if (gfc_match ("double precision") == MATCH_YES)
2127 {
2128 ts->type = BT_REAL;
2129 ts->kind = gfc_default_double_kind;
2130 return MATCH_YES;
2131 }
2132
2133 if (gfc_match ("complex") == MATCH_YES)
2134 {
2135 ts->type = BT_COMPLEX;
2136 ts->kind = gfc_default_complex_kind;
2137 goto kind_selector;
2138 }
2139
2140 if (gfc_match ("character") == MATCH_YES)
2141 {
2142 ts->type = BT_CHARACTER;
2143
2144 m = gfc_match_char_spec (ts);
2145
2146 if (m == MATCH_NO)
2147 m = MATCH_YES;
2148
2149 return m;
2150 }
2151
2152 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2153 or list item in a type-list of an OpenMP reduction clause. Need to
2154 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2155 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2156 written the use of LOGICAL as a type-spec or intrinsic subprogram
2157 was overlooked. */
2158
2159 m = gfc_match (" %n", name);
2160 if (m == MATCH_YES
2161 && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0))
2162 {
2163 char c;
2164 gfc_expr *e;
2165 locus where;
2166
2167 if (*name == 'r')
2168 {
2169 ts->type = BT_REAL;
2170 ts->kind = gfc_default_real_kind;
2171 }
2172 else
2173 {
2174 ts->type = BT_LOGICAL;
2175 ts->kind = gfc_default_logical_kind;
2176 }
2177
2178 gfc_gobble_whitespace ();
2179
2180 /* Prevent REAL*4, etc. */
2181 c = gfc_peek_ascii_char ();
2182 if (c == '*')
2183 {
2184 gfc_error ("Invalid type-spec at %C");
2185 return MATCH_ERROR;
2186 }
2187
2188 /* Found leading colon in REAL::, a trailing ')' in for example
2189 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2190 if (c == ':' || c == ')' || (flag_openmp && c == ','))
2191 return MATCH_YES;
2192
2193 /* Found something other than the opening '(' in REAL(... */
2194 if (c != '(')
2195 return MATCH_NO;
2196 else
2197 gfc_next_char (); /* Burn the '('. */
2198
2199 /* Look for the optional KIND=. */
2200 where = gfc_current_locus;
2201 m = gfc_match ("%n", name);
2202 if (m == MATCH_YES)
2203 {
2204 gfc_gobble_whitespace ();
2205 c = gfc_next_char ();
2206 if (c == '=')
2207 {
2208 if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0)
2209 return MATCH_NO;
2210 else if (strcmp(name, "kind") == 0)
2211 goto found;
2212 else
2213 return MATCH_ERROR;
2214 }
2215 else
2216 gfc_current_locus = where;
2217 }
2218 else
2219 gfc_current_locus = where;
2220
2221 found:
2222
2223 m = gfc_match_expr (&e);
2224 if (m == MATCH_NO || m == MATCH_ERROR)
2225 return m;
2226
2227 /* If a comma appears, it is an intrinsic subprogram. */
2228 gfc_gobble_whitespace ();
2229 c = gfc_peek_ascii_char ();
2230 if (c == ',')
2231 {
2232 gfc_free_expr (e);
2233 return MATCH_NO;
2234 }
2235
2236 /* If ')' appears, we have REAL(initialization-expr), here check for
2237 a scalar integer initialization-expr and valid kind parameter. */
2238 if (c == ')')
2239 {
2240 bool ok = true;
2241 if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE)
2242 ok = gfc_reduce_init_expr (e);
2243 if (!ok || e->ts.type != BT_INTEGER || e->rank > 0)
2244 {
2245 gfc_free_expr (e);
2246 return MATCH_NO;
2247 }
2248
2249 if (e->expr_type != EXPR_CONSTANT)
2250 goto ohno;
2251
2252 gfc_next_char (); /* Burn the ')'. */
2253 ts->kind = (int) mpz_get_si (e->value.integer);
2254 if (gfc_validate_kind (ts->type, ts->kind , true) == -1)
2255 {
2256 gfc_error ("Invalid type-spec at %C");
2257 return MATCH_ERROR;
2258 }
2259
2260 gfc_free_expr (e);
2261
2262 return MATCH_YES;
2263 }
2264 }
2265
2266 ohno:
2267
2268 /* If a type is not matched, simply return MATCH_NO. */
2269 gfc_current_locus = old_locus;
2270 return MATCH_NO;
2271
2272 kind_selector:
2273
2274 gfc_gobble_whitespace ();
2275
2276 /* This prevents INTEGER*4, etc. */
2277 if (gfc_peek_ascii_char () == '*')
2278 {
2279 gfc_error ("Invalid type-spec at %C");
2280 return MATCH_ERROR;
2281 }
2282
2283 m = gfc_match_kind_spec (ts, false);
2284
2285 /* No kind specifier found. */
2286 if (m == MATCH_NO)
2287 m = MATCH_YES;
2288
2289 return m;
2290 }
2291
2292
2293 /******************** FORALL subroutines ********************/
2294
2295 /* Free a list of FORALL iterators. */
2296
2297 void
gfc_free_forall_iterator(gfc_forall_iterator * iter)2298 gfc_free_forall_iterator (gfc_forall_iterator *iter)
2299 {
2300 gfc_forall_iterator *next;
2301
2302 while (iter)
2303 {
2304 next = iter->next;
2305 gfc_free_expr (iter->var);
2306 gfc_free_expr (iter->start);
2307 gfc_free_expr (iter->end);
2308 gfc_free_expr (iter->stride);
2309 free (iter);
2310 iter = next;
2311 }
2312 }
2313
2314
2315 /* Match an iterator as part of a FORALL statement. The format is:
2316
2317 <var> = <start>:<end>[:<stride>]
2318
2319 On MATCH_NO, the caller tests for the possibility that there is a
2320 scalar mask expression. */
2321
2322 static match
match_forall_iterator(gfc_forall_iterator ** result)2323 match_forall_iterator (gfc_forall_iterator **result)
2324 {
2325 gfc_forall_iterator *iter;
2326 locus where;
2327 match m;
2328
2329 where = gfc_current_locus;
2330 iter = XCNEW (gfc_forall_iterator);
2331
2332 m = gfc_match_expr (&iter->var);
2333 if (m != MATCH_YES)
2334 goto cleanup;
2335
2336 if (gfc_match_char ('=') != MATCH_YES
2337 || iter->var->expr_type != EXPR_VARIABLE)
2338 {
2339 m = MATCH_NO;
2340 goto cleanup;
2341 }
2342
2343 m = gfc_match_expr (&iter->start);
2344 if (m != MATCH_YES)
2345 goto cleanup;
2346
2347 if (gfc_match_char (':') != MATCH_YES)
2348 goto syntax;
2349
2350 m = gfc_match_expr (&iter->end);
2351 if (m == MATCH_NO)
2352 goto syntax;
2353 if (m == MATCH_ERROR)
2354 goto cleanup;
2355
2356 if (gfc_match_char (':') == MATCH_NO)
2357 iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2358 else
2359 {
2360 m = gfc_match_expr (&iter->stride);
2361 if (m == MATCH_NO)
2362 goto syntax;
2363 if (m == MATCH_ERROR)
2364 goto cleanup;
2365 }
2366
2367 /* Mark the iteration variable's symbol as used as a FORALL index. */
2368 iter->var->symtree->n.sym->forall_index = true;
2369
2370 *result = iter;
2371 return MATCH_YES;
2372
2373 syntax:
2374 gfc_error ("Syntax error in FORALL iterator at %C");
2375 m = MATCH_ERROR;
2376
2377 cleanup:
2378
2379 gfc_current_locus = where;
2380 gfc_free_forall_iterator (iter);
2381 return m;
2382 }
2383
2384
2385 /* Match the header of a FORALL statement. */
2386
2387 static match
match_forall_header(gfc_forall_iterator ** phead,gfc_expr ** mask)2388 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2389 {
2390 gfc_forall_iterator *head, *tail, *new_iter;
2391 gfc_expr *msk;
2392 match m;
2393
2394 gfc_gobble_whitespace ();
2395
2396 head = tail = NULL;
2397 msk = NULL;
2398
2399 if (gfc_match_char ('(') != MATCH_YES)
2400 return MATCH_NO;
2401
2402 m = match_forall_iterator (&new_iter);
2403 if (m == MATCH_ERROR)
2404 goto cleanup;
2405 if (m == MATCH_NO)
2406 goto syntax;
2407
2408 head = tail = new_iter;
2409
2410 for (;;)
2411 {
2412 if (gfc_match_char (',') != MATCH_YES)
2413 break;
2414
2415 m = match_forall_iterator (&new_iter);
2416 if (m == MATCH_ERROR)
2417 goto cleanup;
2418
2419 if (m == MATCH_YES)
2420 {
2421 tail->next = new_iter;
2422 tail = new_iter;
2423 continue;
2424 }
2425
2426 /* Have to have a mask expression. */
2427
2428 m = gfc_match_expr (&msk);
2429 if (m == MATCH_NO)
2430 goto syntax;
2431 if (m == MATCH_ERROR)
2432 goto cleanup;
2433
2434 break;
2435 }
2436
2437 if (gfc_match_char (')') == MATCH_NO)
2438 goto syntax;
2439
2440 *phead = head;
2441 *mask = msk;
2442 return MATCH_YES;
2443
2444 syntax:
2445 gfc_syntax_error (ST_FORALL);
2446
2447 cleanup:
2448 gfc_free_expr (msk);
2449 gfc_free_forall_iterator (head);
2450
2451 return MATCH_ERROR;
2452 }
2453
2454 /* Match the rest of a simple FORALL statement that follows an
2455 IF statement. */
2456
2457 static match
match_simple_forall(void)2458 match_simple_forall (void)
2459 {
2460 gfc_forall_iterator *head;
2461 gfc_expr *mask;
2462 gfc_code *c;
2463 match m;
2464
2465 mask = NULL;
2466 head = NULL;
2467 c = NULL;
2468
2469 m = match_forall_header (&head, &mask);
2470
2471 if (m == MATCH_NO)
2472 goto syntax;
2473 if (m != MATCH_YES)
2474 goto cleanup;
2475
2476 m = gfc_match_assignment ();
2477
2478 if (m == MATCH_ERROR)
2479 goto cleanup;
2480 if (m == MATCH_NO)
2481 {
2482 m = gfc_match_pointer_assignment ();
2483 if (m == MATCH_ERROR)
2484 goto cleanup;
2485 if (m == MATCH_NO)
2486 goto syntax;
2487 }
2488
2489 c = XCNEW (gfc_code);
2490 *c = new_st;
2491 c->loc = gfc_current_locus;
2492
2493 if (gfc_match_eos () != MATCH_YES)
2494 goto syntax;
2495
2496 gfc_clear_new_st ();
2497 new_st.op = EXEC_FORALL;
2498 new_st.expr1 = mask;
2499 new_st.ext.forall_iterator = head;
2500 new_st.block = gfc_get_code (EXEC_FORALL);
2501 new_st.block->next = c;
2502
2503 return MATCH_YES;
2504
2505 syntax:
2506 gfc_syntax_error (ST_FORALL);
2507
2508 cleanup:
2509 gfc_free_forall_iterator (head);
2510 gfc_free_expr (mask);
2511
2512 return MATCH_ERROR;
2513 }
2514
2515
2516 /* Match a FORALL statement. */
2517
2518 match
gfc_match_forall(gfc_statement * st)2519 gfc_match_forall (gfc_statement *st)
2520 {
2521 gfc_forall_iterator *head;
2522 gfc_expr *mask;
2523 gfc_code *c;
2524 match m0, m;
2525
2526 head = NULL;
2527 mask = NULL;
2528 c = NULL;
2529
2530 m0 = gfc_match_label ();
2531 if (m0 == MATCH_ERROR)
2532 return MATCH_ERROR;
2533
2534 m = gfc_match (" forall");
2535 if (m != MATCH_YES)
2536 return m;
2537
2538 m = match_forall_header (&head, &mask);
2539 if (m == MATCH_ERROR)
2540 goto cleanup;
2541 if (m == MATCH_NO)
2542 goto syntax;
2543
2544 if (gfc_match_eos () == MATCH_YES)
2545 {
2546 *st = ST_FORALL_BLOCK;
2547 new_st.op = EXEC_FORALL;
2548 new_st.expr1 = mask;
2549 new_st.ext.forall_iterator = head;
2550 return MATCH_YES;
2551 }
2552
2553 m = gfc_match_assignment ();
2554 if (m == MATCH_ERROR)
2555 goto cleanup;
2556 if (m == MATCH_NO)
2557 {
2558 m = gfc_match_pointer_assignment ();
2559 if (m == MATCH_ERROR)
2560 goto cleanup;
2561 if (m == MATCH_NO)
2562 goto syntax;
2563 }
2564
2565 c = XCNEW (gfc_code);
2566 *c = new_st;
2567 c->loc = gfc_current_locus;
2568
2569 gfc_clear_new_st ();
2570 new_st.op = EXEC_FORALL;
2571 new_st.expr1 = mask;
2572 new_st.ext.forall_iterator = head;
2573 new_st.block = gfc_get_code (EXEC_FORALL);
2574 new_st.block->next = c;
2575
2576 *st = ST_FORALL;
2577 return MATCH_YES;
2578
2579 syntax:
2580 gfc_syntax_error (ST_FORALL);
2581
2582 cleanup:
2583 gfc_free_forall_iterator (head);
2584 gfc_free_expr (mask);
2585 gfc_free_statements (c);
2586 return MATCH_NO;
2587 }
2588
2589
2590 /* Match a DO statement. */
2591
2592 match
gfc_match_do(void)2593 gfc_match_do (void)
2594 {
2595 gfc_iterator iter, *ip;
2596 locus old_loc;
2597 gfc_st_label *label;
2598 match m;
2599
2600 old_loc = gfc_current_locus;
2601
2602 memset (&iter, '\0', sizeof (gfc_iterator));
2603 label = NULL;
2604
2605 m = gfc_match_label ();
2606 if (m == MATCH_ERROR)
2607 return m;
2608
2609 if (gfc_match (" do") != MATCH_YES)
2610 return MATCH_NO;
2611
2612 m = gfc_match_st_label (&label);
2613 if (m == MATCH_ERROR)
2614 goto cleanup;
2615
2616 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2617
2618 if (gfc_match_eos () == MATCH_YES)
2619 {
2620 iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2621 new_st.op = EXEC_DO_WHILE;
2622 goto done;
2623 }
2624
2625 /* Match an optional comma, if no comma is found, a space is obligatory. */
2626 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2627 return MATCH_NO;
2628
2629 /* Check for balanced parens. */
2630
2631 if (gfc_match_parens () == MATCH_ERROR)
2632 return MATCH_ERROR;
2633
2634 if (gfc_match (" concurrent") == MATCH_YES)
2635 {
2636 gfc_forall_iterator *head;
2637 gfc_expr *mask;
2638
2639 if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
2640 return MATCH_ERROR;
2641
2642
2643 mask = NULL;
2644 head = NULL;
2645 m = match_forall_header (&head, &mask);
2646
2647 if (m == MATCH_NO)
2648 return m;
2649 if (m == MATCH_ERROR)
2650 goto concurr_cleanup;
2651
2652 if (gfc_match_eos () != MATCH_YES)
2653 goto concurr_cleanup;
2654
2655 if (label != NULL
2656 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2657 goto concurr_cleanup;
2658
2659 new_st.label1 = label;
2660 new_st.op = EXEC_DO_CONCURRENT;
2661 new_st.expr1 = mask;
2662 new_st.ext.forall_iterator = head;
2663
2664 return MATCH_YES;
2665
2666 concurr_cleanup:
2667 gfc_syntax_error (ST_DO);
2668 gfc_free_expr (mask);
2669 gfc_free_forall_iterator (head);
2670 return MATCH_ERROR;
2671 }
2672
2673 /* See if we have a DO WHILE. */
2674 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2675 {
2676 new_st.op = EXEC_DO_WHILE;
2677 goto done;
2678 }
2679
2680 /* The abortive DO WHILE may have done something to the symbol
2681 table, so we start over. */
2682 gfc_undo_symbols ();
2683 gfc_current_locus = old_loc;
2684
2685 gfc_match_label (); /* This won't error. */
2686 gfc_match (" do "); /* This will work. */
2687
2688 gfc_match_st_label (&label); /* Can't error out. */
2689 gfc_match_char (','); /* Optional comma. */
2690
2691 m = gfc_match_iterator (&iter, 0);
2692 if (m == MATCH_NO)
2693 return MATCH_NO;
2694 if (m == MATCH_ERROR)
2695 goto cleanup;
2696
2697 iter.var->symtree->n.sym->attr.implied_index = 0;
2698 gfc_check_do_variable (iter.var->symtree);
2699
2700 if (gfc_match_eos () != MATCH_YES)
2701 {
2702 gfc_syntax_error (ST_DO);
2703 goto cleanup;
2704 }
2705
2706 new_st.op = EXEC_DO;
2707
2708 done:
2709 if (label != NULL
2710 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2711 goto cleanup;
2712
2713 new_st.label1 = label;
2714
2715 if (new_st.op == EXEC_DO_WHILE)
2716 new_st.expr1 = iter.end;
2717 else
2718 {
2719 new_st.ext.iterator = ip = gfc_get_iterator ();
2720 *ip = iter;
2721 }
2722
2723 return MATCH_YES;
2724
2725 cleanup:
2726 gfc_free_iterator (&iter, 0);
2727
2728 return MATCH_ERROR;
2729 }
2730
2731
2732 /* Match an EXIT or CYCLE statement. */
2733
2734 static match
match_exit_cycle(gfc_statement st,gfc_exec_op op)2735 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2736 {
2737 gfc_state_data *p, *o;
2738 gfc_symbol *sym;
2739 match m;
2740 int cnt;
2741
2742 if (gfc_match_eos () == MATCH_YES)
2743 sym = NULL;
2744 else
2745 {
2746 char name[GFC_MAX_SYMBOL_LEN + 1];
2747 gfc_symtree* stree;
2748
2749 m = gfc_match ("% %n%t", name);
2750 if (m == MATCH_ERROR)
2751 return MATCH_ERROR;
2752 if (m == MATCH_NO)
2753 {
2754 gfc_syntax_error (st);
2755 return MATCH_ERROR;
2756 }
2757
2758 /* Find the corresponding symbol. If there's a BLOCK statement
2759 between here and the label, it is not in gfc_current_ns but a parent
2760 namespace! */
2761 stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2762 if (!stree)
2763 {
2764 gfc_error ("Name %qs in %s statement at %C is unknown",
2765 name, gfc_ascii_statement (st));
2766 return MATCH_ERROR;
2767 }
2768
2769 sym = stree->n.sym;
2770 if (sym->attr.flavor != FL_LABEL)
2771 {
2772 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2773 name, gfc_ascii_statement (st));
2774 return MATCH_ERROR;
2775 }
2776 }
2777
2778 /* Find the loop specified by the label (or lack of a label). */
2779 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2780 if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2781 o = p;
2782 else if (p->state == COMP_CRITICAL)
2783 {
2784 gfc_error("%s statement at %C leaves CRITICAL construct",
2785 gfc_ascii_statement (st));
2786 return MATCH_ERROR;
2787 }
2788 else if (p->state == COMP_DO_CONCURRENT
2789 && (op == EXEC_EXIT || (sym && sym != p->sym)))
2790 {
2791 /* F2008, C821 & C845. */
2792 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2793 gfc_ascii_statement (st));
2794 return MATCH_ERROR;
2795 }
2796 else if ((sym && sym == p->sym)
2797 || (!sym && (p->state == COMP_DO
2798 || p->state == COMP_DO_CONCURRENT)))
2799 break;
2800
2801 if (p == NULL)
2802 {
2803 if (sym == NULL)
2804 gfc_error ("%s statement at %C is not within a construct",
2805 gfc_ascii_statement (st));
2806 else
2807 gfc_error ("%s statement at %C is not within construct %qs",
2808 gfc_ascii_statement (st), sym->name);
2809
2810 return MATCH_ERROR;
2811 }
2812
2813 /* Special checks for EXIT from non-loop constructs. */
2814 switch (p->state)
2815 {
2816 case COMP_DO:
2817 case COMP_DO_CONCURRENT:
2818 break;
2819
2820 case COMP_CRITICAL:
2821 /* This is already handled above. */
2822 gcc_unreachable ();
2823
2824 case COMP_ASSOCIATE:
2825 case COMP_BLOCK:
2826 case COMP_IF:
2827 case COMP_SELECT:
2828 case COMP_SELECT_TYPE:
2829 case COMP_SELECT_RANK:
2830 gcc_assert (sym);
2831 if (op == EXEC_CYCLE)
2832 {
2833 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2834 " construct %qs", sym->name);
2835 return MATCH_ERROR;
2836 }
2837 gcc_assert (op == EXEC_EXIT);
2838 if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
2839 " do-construct-name at %C"))
2840 return MATCH_ERROR;
2841 break;
2842
2843 default:
2844 gfc_error ("%s statement at %C is not applicable to construct %qs",
2845 gfc_ascii_statement (st), sym->name);
2846 return MATCH_ERROR;
2847 }
2848
2849 if (o != NULL)
2850 {
2851 gfc_error (is_oacc (p)
2852 ? G_("%s statement at %C leaving OpenACC structured block")
2853 : G_("%s statement at %C leaving OpenMP structured block"),
2854 gfc_ascii_statement (st));
2855 return MATCH_ERROR;
2856 }
2857
2858 for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2859 o = o->previous;
2860
2861 int count = 1;
2862 if (cnt > 0
2863 && o != NULL
2864 && o->state == COMP_OMP_STRUCTURED_BLOCK)
2865 switch (o->head->op)
2866 {
2867 case EXEC_OACC_LOOP:
2868 case EXEC_OACC_KERNELS_LOOP:
2869 case EXEC_OACC_PARALLEL_LOOP:
2870 case EXEC_OACC_SERIAL_LOOP:
2871 gcc_assert (o->head->next != NULL
2872 && (o->head->next->op == EXEC_DO
2873 || o->head->next->op == EXEC_DO_WHILE)
2874 && o->previous != NULL
2875 && o->previous->tail->op == o->head->op);
2876 if (o->previous->tail->ext.omp_clauses != NULL)
2877 {
2878 /* Both collapsed and tiled loops are lowered the same way, but are
2879 not compatible. In gfc_trans_omp_do, the tile is prioritized. */
2880 if (o->previous->tail->ext.omp_clauses->tile_list)
2881 {
2882 count = 0;
2883 gfc_expr_list *el
2884 = o->previous->tail->ext.omp_clauses->tile_list;
2885 for ( ; el; el = el->next)
2886 ++count;
2887 }
2888 else if (o->previous->tail->ext.omp_clauses->collapse > 1)
2889 count = o->previous->tail->ext.omp_clauses->collapse;
2890 }
2891 if (st == ST_EXIT && cnt <= count)
2892 {
2893 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2894 return MATCH_ERROR;
2895 }
2896 if (st == ST_CYCLE && cnt < count)
2897 {
2898 gfc_error (o->previous->tail->ext.omp_clauses->tile_list
2899 ? G_("CYCLE statement at %C to non-innermost tiled "
2900 "!$ACC LOOP loop")
2901 : G_("CYCLE statement at %C to non-innermost collapsed "
2902 "!$ACC LOOP loop"));
2903 return MATCH_ERROR;
2904 }
2905 break;
2906 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2907 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2908 case EXEC_OMP_TARGET_SIMD:
2909 case EXEC_OMP_TASKLOOP_SIMD:
2910 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2911 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
2912 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2913 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
2914 case EXEC_OMP_PARALLEL_DO_SIMD:
2915 case EXEC_OMP_DISTRIBUTE_SIMD:
2916 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2917 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2918 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2919 case EXEC_OMP_LOOP:
2920 case EXEC_OMP_PARALLEL_LOOP:
2921 case EXEC_OMP_TEAMS_LOOP:
2922 case EXEC_OMP_TARGET_PARALLEL_LOOP:
2923 case EXEC_OMP_TARGET_TEAMS_LOOP:
2924 case EXEC_OMP_DO:
2925 case EXEC_OMP_PARALLEL_DO:
2926 case EXEC_OMP_SIMD:
2927 case EXEC_OMP_DO_SIMD:
2928 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2929 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2930 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2931 case EXEC_OMP_TARGET_PARALLEL_DO:
2932 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2933
2934 gcc_assert (o->head->next != NULL
2935 && (o->head->next->op == EXEC_DO
2936 || o->head->next->op == EXEC_DO_WHILE)
2937 && o->previous != NULL
2938 && o->previous->tail->op == o->head->op);
2939 if (o->previous->tail->ext.omp_clauses != NULL)
2940 {
2941 if (o->previous->tail->ext.omp_clauses->collapse > 1)
2942 count = o->previous->tail->ext.omp_clauses->collapse;
2943 if (o->previous->tail->ext.omp_clauses->orderedc)
2944 count = o->previous->tail->ext.omp_clauses->orderedc;
2945 }
2946 if (st == ST_EXIT && cnt <= count)
2947 {
2948 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2949 return MATCH_ERROR;
2950 }
2951 if (st == ST_CYCLE && cnt < count)
2952 {
2953 gfc_error ("CYCLE statement at %C to non-innermost collapsed "
2954 "!$OMP DO loop");
2955 return MATCH_ERROR;
2956 }
2957 break;
2958 default:
2959 break;
2960 }
2961
2962 /* Save the first statement in the construct - needed by the backend. */
2963 new_st.ext.which_construct = p->construct;
2964
2965 new_st.op = op;
2966
2967 return MATCH_YES;
2968 }
2969
2970
2971 /* Match the EXIT statement. */
2972
2973 match
gfc_match_exit(void)2974 gfc_match_exit (void)
2975 {
2976 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2977 }
2978
2979
2980 /* Match the CYCLE statement. */
2981
2982 match
gfc_match_cycle(void)2983 gfc_match_cycle (void)
2984 {
2985 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2986 }
2987
2988
2989 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2990 requirements for a stop-code differ in the standards.
2991
2992 Fortran 95 has
2993
2994 R840 stop-stmt is STOP [ stop-code ]
2995 R841 stop-code is scalar-char-constant
2996 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2997
2998 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2999 Fortran 2008 has
3000
3001 R855 stop-stmt is STOP [ stop-code ]
3002 R856 allstop-stmt is ALL STOP [ stop-code ]
3003 R857 stop-code is scalar-default-char-constant-expr
3004 or scalar-int-constant-expr
3005 Fortran 2018 has
3006
3007 R1160 stop-stmt is STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
3008 R1161 error-stop-stmt is
3009 ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
3010 R1162 stop-code is scalar-default-char-expr
3011 or scalar-int-expr
3012
3013 For free-form source code, all standards contain a statement of the form:
3014
3015 A blank shall be used to separate names, constants, or labels from
3016 adjacent keywords, names, constants, or labels.
3017
3018 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
3019
3020 STOP123
3021
3022 is valid, but it is invalid Fortran 2008. */
3023
3024 static match
gfc_match_stopcode(gfc_statement st)3025 gfc_match_stopcode (gfc_statement st)
3026 {
3027 gfc_expr *e = NULL;
3028 gfc_expr *quiet = NULL;
3029 match m;
3030 bool f95, f03, f08;
3031 char c;
3032
3033 /* Set f95 for -std=f95. */
3034 f95 = (gfc_option.allow_std == GFC_STD_OPT_F95);
3035
3036 /* Set f03 for -std=f2003. */
3037 f03 = (gfc_option.allow_std == GFC_STD_OPT_F03);
3038
3039 /* Set f08 for -std=f2008. */
3040 f08 = (gfc_option.allow_std == GFC_STD_OPT_F08);
3041
3042 /* Plain STOP statement? */
3043 if (gfc_match_eos () == MATCH_YES)
3044 goto checks;
3045
3046 /* Look for a blank between STOP and the stop-code for F2008 or later.
3047 But allow for F2018's ,QUIET= specifier. */
3048 c = gfc_peek_ascii_char ();
3049
3050 if (gfc_current_form != FORM_FIXED && !(f95 || f03) && c != ',')
3051 {
3052 /* Look for end-of-statement. There is no stop-code. */
3053 if (c == '\n' || c == '!' || c == ';')
3054 goto done;
3055
3056 if (c != ' ')
3057 {
3058 gfc_error ("Blank required in %s statement near %C",
3059 gfc_ascii_statement (st));
3060 return MATCH_ERROR;
3061 }
3062 }
3063
3064 if (c == ' ')
3065 {
3066 gfc_gobble_whitespace ();
3067 c = gfc_peek_ascii_char ();
3068 }
3069 if (c != ',')
3070 {
3071 int stopcode;
3072 locus old_locus;
3073
3074 /* First look for the F95 or F2003 digit [...] construct. */
3075 old_locus = gfc_current_locus;
3076 m = gfc_match_small_int (&stopcode);
3077 if (m == MATCH_YES && (f95 || f03))
3078 {
3079 if (stopcode < 0)
3080 {
3081 gfc_error ("STOP code at %C cannot be negative");
3082 return MATCH_ERROR;
3083 }
3084
3085 if (stopcode > 99999)
3086 {
3087 gfc_error ("STOP code at %C contains too many digits");
3088 return MATCH_ERROR;
3089 }
3090 }
3091
3092 /* Reset the locus and now load gfc_expr. */
3093 gfc_current_locus = old_locus;
3094 m = gfc_match_expr (&e);
3095 if (m == MATCH_ERROR)
3096 goto cleanup;
3097 if (m == MATCH_NO)
3098 goto syntax;
3099 }
3100
3101 if (gfc_match (" , quiet = %e", &quiet) == MATCH_YES)
3102 {
3103 if (!gfc_notify_std (GFC_STD_F2018, "QUIET= specifier for %s at %L",
3104 gfc_ascii_statement (st), &quiet->where))
3105 goto cleanup;
3106 }
3107
3108 if (gfc_match_eos () != MATCH_YES)
3109 goto syntax;
3110
3111 checks:
3112
3113 if (gfc_pure (NULL))
3114 {
3115 if (st == ST_ERROR_STOP)
3116 {
3117 if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE "
3118 "procedure", gfc_ascii_statement (st)))
3119 goto cleanup;
3120 }
3121 else
3122 {
3123 gfc_error ("%s statement not allowed in PURE procedure at %C",
3124 gfc_ascii_statement (st));
3125 goto cleanup;
3126 }
3127 }
3128
3129 gfc_unset_implicit_pure (NULL);
3130
3131 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
3132 {
3133 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3134 goto cleanup;
3135 }
3136 if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
3137 {
3138 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3139 goto cleanup;
3140 }
3141
3142 if (e != NULL)
3143 {
3144 if (!gfc_simplify_expr (e, 0))
3145 goto cleanup;
3146
3147 /* Test for F95 and F2003 style STOP stop-code. */
3148 if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
3149 {
3150 gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
3151 "or digit[digit[digit[digit[digit]]]]", &e->where);
3152 goto cleanup;
3153 }
3154
3155 /* Use the machinery for an initialization expression to reduce the
3156 stop-code to a constant. */
3157 gfc_reduce_init_expr (e);
3158
3159 /* Test for F2008 style STOP stop-code. */
3160 if (e->expr_type != EXPR_CONSTANT && f08)
3161 {
3162 gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
3163 "INTEGER constant expression", &e->where);
3164 goto cleanup;
3165 }
3166
3167 if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
3168 {
3169 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3170 &e->where);
3171 goto cleanup;
3172 }
3173
3174 if (e->rank != 0)
3175 {
3176 gfc_error ("STOP code at %L must be scalar", &e->where);
3177 goto cleanup;
3178 }
3179
3180 if (e->ts.type == BT_CHARACTER
3181 && e->ts.kind != gfc_default_character_kind)
3182 {
3183 gfc_error ("STOP code at %L must be default character KIND=%d",
3184 &e->where, (int) gfc_default_character_kind);
3185 goto cleanup;
3186 }
3187
3188 if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind
3189 && !gfc_notify_std (GFC_STD_F2018,
3190 "STOP code at %L must be default integer KIND=%d",
3191 &e->where, (int) gfc_default_integer_kind))
3192 goto cleanup;
3193 }
3194
3195 if (quiet != NULL)
3196 {
3197 if (!gfc_simplify_expr (quiet, 0))
3198 goto cleanup;
3199
3200 if (quiet->rank != 0)
3201 {
3202 gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
3203 &quiet->where);
3204 goto cleanup;
3205 }
3206 }
3207
3208 done:
3209
3210 switch (st)
3211 {
3212 case ST_STOP:
3213 new_st.op = EXEC_STOP;
3214 break;
3215 case ST_ERROR_STOP:
3216 new_st.op = EXEC_ERROR_STOP;
3217 break;
3218 case ST_PAUSE:
3219 new_st.op = EXEC_PAUSE;
3220 break;
3221 default:
3222 gcc_unreachable ();
3223 }
3224
3225 new_st.expr1 = e;
3226 new_st.expr2 = quiet;
3227 new_st.ext.stop_code = -1;
3228
3229 return MATCH_YES;
3230
3231 syntax:
3232 gfc_syntax_error (st);
3233
3234 cleanup:
3235
3236 gfc_free_expr (e);
3237 gfc_free_expr (quiet);
3238 return MATCH_ERROR;
3239 }
3240
3241
3242 /* Match the (deprecated) PAUSE statement. */
3243
3244 match
gfc_match_pause(void)3245 gfc_match_pause (void)
3246 {
3247 match m;
3248
3249 m = gfc_match_stopcode (ST_PAUSE);
3250 if (m == MATCH_YES)
3251 {
3252 if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
3253 m = MATCH_ERROR;
3254 }
3255 return m;
3256 }
3257
3258
3259 /* Match the STOP statement. */
3260
3261 match
gfc_match_stop(void)3262 gfc_match_stop (void)
3263 {
3264 return gfc_match_stopcode (ST_STOP);
3265 }
3266
3267
3268 /* Match the ERROR STOP statement. */
3269
3270 match
gfc_match_error_stop(void)3271 gfc_match_error_stop (void)
3272 {
3273 if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
3274 return MATCH_ERROR;
3275
3276 return gfc_match_stopcode (ST_ERROR_STOP);
3277 }
3278
3279 /* Match EVENT POST/WAIT statement. Syntax:
3280 EVENT POST ( event-variable [, sync-stat-list] )
3281 EVENT WAIT ( event-variable [, wait-spec-list] )
3282 with
3283 wait-spec-list is sync-stat-list or until-spec
3284 until-spec is UNTIL_COUNT = scalar-int-expr
3285 sync-stat is STAT= or ERRMSG=. */
3286
3287 static match
event_statement(gfc_statement st)3288 event_statement (gfc_statement st)
3289 {
3290 match m;
3291 gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
3292 bool saw_until_count, saw_stat, saw_errmsg;
3293
3294 tmp = eventvar = until_count = stat = errmsg = NULL;
3295 saw_until_count = saw_stat = saw_errmsg = false;
3296
3297 if (gfc_pure (NULL))
3298 {
3299 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3300 st == ST_EVENT_POST ? "POST" : "WAIT");
3301 return MATCH_ERROR;
3302 }
3303
3304 gfc_unset_implicit_pure (NULL);
3305
3306 if (flag_coarray == GFC_FCOARRAY_NONE)
3307 {
3308 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3309 return MATCH_ERROR;
3310 }
3311
3312 if (gfc_find_state (COMP_CRITICAL))
3313 {
3314 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3315 st == ST_EVENT_POST ? "POST" : "WAIT");
3316 return MATCH_ERROR;
3317 }
3318
3319 if (gfc_find_state (COMP_DO_CONCURRENT))
3320 {
3321 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3322 "block", st == ST_EVENT_POST ? "POST" : "WAIT");
3323 return MATCH_ERROR;
3324 }
3325
3326 if (gfc_match_char ('(') != MATCH_YES)
3327 goto syntax;
3328
3329 if (gfc_match ("%e", &eventvar) != MATCH_YES)
3330 goto syntax;
3331 m = gfc_match_char (',');
3332 if (m == MATCH_ERROR)
3333 goto syntax;
3334 if (m == MATCH_NO)
3335 {
3336 m = gfc_match_char (')');
3337 if (m == MATCH_YES)
3338 goto done;
3339 goto syntax;
3340 }
3341
3342 for (;;)
3343 {
3344 m = gfc_match (" stat = %v", &tmp);
3345 if (m == MATCH_ERROR)
3346 goto syntax;
3347 if (m == MATCH_YES)
3348 {
3349 if (saw_stat)
3350 {
3351 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3352 goto cleanup;
3353 }
3354 stat = tmp;
3355 saw_stat = true;
3356
3357 m = gfc_match_char (',');
3358 if (m == MATCH_YES)
3359 continue;
3360
3361 tmp = NULL;
3362 break;
3363 }
3364
3365 m = gfc_match (" errmsg = %v", &tmp);
3366 if (m == MATCH_ERROR)
3367 goto syntax;
3368 if (m == MATCH_YES)
3369 {
3370 if (saw_errmsg)
3371 {
3372 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3373 goto cleanup;
3374 }
3375 errmsg = tmp;
3376 saw_errmsg = true;
3377
3378 m = gfc_match_char (',');
3379 if (m == MATCH_YES)
3380 continue;
3381
3382 tmp = NULL;
3383 break;
3384 }
3385
3386 m = gfc_match (" until_count = %e", &tmp);
3387 if (m == MATCH_ERROR || st == ST_EVENT_POST)
3388 goto syntax;
3389 if (m == MATCH_YES)
3390 {
3391 if (saw_until_count)
3392 {
3393 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3394 &tmp->where);
3395 goto cleanup;
3396 }
3397 until_count = tmp;
3398 saw_until_count = true;
3399
3400 m = gfc_match_char (',');
3401 if (m == MATCH_YES)
3402 continue;
3403
3404 tmp = NULL;
3405 break;
3406 }
3407
3408 break;
3409 }
3410
3411 if (m == MATCH_ERROR)
3412 goto syntax;
3413
3414 if (gfc_match (" )%t") != MATCH_YES)
3415 goto syntax;
3416
3417 done:
3418 switch (st)
3419 {
3420 case ST_EVENT_POST:
3421 new_st.op = EXEC_EVENT_POST;
3422 break;
3423 case ST_EVENT_WAIT:
3424 new_st.op = EXEC_EVENT_WAIT;
3425 break;
3426 default:
3427 gcc_unreachable ();
3428 }
3429
3430 new_st.expr1 = eventvar;
3431 new_st.expr2 = stat;
3432 new_st.expr3 = errmsg;
3433 new_st.expr4 = until_count;
3434
3435 return MATCH_YES;
3436
3437 syntax:
3438 gfc_syntax_error (st);
3439
3440 cleanup:
3441 if (until_count != tmp)
3442 gfc_free_expr (until_count);
3443 if (errmsg != tmp)
3444 gfc_free_expr (errmsg);
3445 if (stat != tmp)
3446 gfc_free_expr (stat);
3447
3448 gfc_free_expr (tmp);
3449 gfc_free_expr (eventvar);
3450
3451 return MATCH_ERROR;
3452
3453 }
3454
3455
3456 match
gfc_match_event_post(void)3457 gfc_match_event_post (void)
3458 {
3459 if (!gfc_notify_std (GFC_STD_F2018, "EVENT POST statement at %C"))
3460 return MATCH_ERROR;
3461
3462 return event_statement (ST_EVENT_POST);
3463 }
3464
3465
3466 match
gfc_match_event_wait(void)3467 gfc_match_event_wait (void)
3468 {
3469 if (!gfc_notify_std (GFC_STD_F2018, "EVENT WAIT statement at %C"))
3470 return MATCH_ERROR;
3471
3472 return event_statement (ST_EVENT_WAIT);
3473 }
3474
3475
3476 /* Match a FAIL IMAGE statement. */
3477
3478 match
gfc_match_fail_image(void)3479 gfc_match_fail_image (void)
3480 {
3481 if (!gfc_notify_std (GFC_STD_F2018, "FAIL IMAGE statement at %C"))
3482 return MATCH_ERROR;
3483
3484 if (gfc_match_char ('(') == MATCH_YES)
3485 goto syntax;
3486
3487 new_st.op = EXEC_FAIL_IMAGE;
3488
3489 return MATCH_YES;
3490
3491 syntax:
3492 gfc_syntax_error (ST_FAIL_IMAGE);
3493
3494 return MATCH_ERROR;
3495 }
3496
3497 /* Match a FORM TEAM statement. */
3498
3499 match
gfc_match_form_team(void)3500 gfc_match_form_team (void)
3501 {
3502 match m;
3503 gfc_expr *teamid,*team;
3504
3505 if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C"))
3506 return MATCH_ERROR;
3507
3508 if (gfc_match_char ('(') == MATCH_NO)
3509 goto syntax;
3510
3511 new_st.op = EXEC_FORM_TEAM;
3512
3513 if (gfc_match ("%e", &teamid) != MATCH_YES)
3514 goto syntax;
3515 m = gfc_match_char (',');
3516 if (m == MATCH_ERROR)
3517 goto syntax;
3518 if (gfc_match ("%e", &team) != MATCH_YES)
3519 goto syntax;
3520
3521 m = gfc_match_char (')');
3522 if (m == MATCH_NO)
3523 goto syntax;
3524
3525 new_st.expr1 = teamid;
3526 new_st.expr2 = team;
3527
3528 return MATCH_YES;
3529
3530 syntax:
3531 gfc_syntax_error (ST_FORM_TEAM);
3532
3533 return MATCH_ERROR;
3534 }
3535
3536 /* Match a CHANGE TEAM statement. */
3537
3538 match
gfc_match_change_team(void)3539 gfc_match_change_team (void)
3540 {
3541 match m;
3542 gfc_expr *team;
3543
3544 if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C"))
3545 return MATCH_ERROR;
3546
3547 if (gfc_match_char ('(') == MATCH_NO)
3548 goto syntax;
3549
3550 new_st.op = EXEC_CHANGE_TEAM;
3551
3552 if (gfc_match ("%e", &team) != MATCH_YES)
3553 goto syntax;
3554
3555 m = gfc_match_char (')');
3556 if (m == MATCH_NO)
3557 goto syntax;
3558
3559 new_st.expr1 = team;
3560
3561 return MATCH_YES;
3562
3563 syntax:
3564 gfc_syntax_error (ST_CHANGE_TEAM);
3565
3566 return MATCH_ERROR;
3567 }
3568
3569 /* Match a END TEAM statement. */
3570
3571 match
gfc_match_end_team(void)3572 gfc_match_end_team (void)
3573 {
3574 if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C"))
3575 return MATCH_ERROR;
3576
3577 if (gfc_match_char ('(') == MATCH_YES)
3578 goto syntax;
3579
3580 new_st.op = EXEC_END_TEAM;
3581
3582 return MATCH_YES;
3583
3584 syntax:
3585 gfc_syntax_error (ST_END_TEAM);
3586
3587 return MATCH_ERROR;
3588 }
3589
3590 /* Match a SYNC TEAM statement. */
3591
3592 match
gfc_match_sync_team(void)3593 gfc_match_sync_team (void)
3594 {
3595 match m;
3596 gfc_expr *team;
3597
3598 if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C"))
3599 return MATCH_ERROR;
3600
3601 if (gfc_match_char ('(') == MATCH_NO)
3602 goto syntax;
3603
3604 new_st.op = EXEC_SYNC_TEAM;
3605
3606 if (gfc_match ("%e", &team) != MATCH_YES)
3607 goto syntax;
3608
3609 m = gfc_match_char (')');
3610 if (m == MATCH_NO)
3611 goto syntax;
3612
3613 new_st.expr1 = team;
3614
3615 return MATCH_YES;
3616
3617 syntax:
3618 gfc_syntax_error (ST_SYNC_TEAM);
3619
3620 return MATCH_ERROR;
3621 }
3622
3623 /* Match LOCK/UNLOCK statement. Syntax:
3624 LOCK ( lock-variable [ , lock-stat-list ] )
3625 UNLOCK ( lock-variable [ , sync-stat-list ] )
3626 where lock-stat is ACQUIRED_LOCK or sync-stat
3627 and sync-stat is STAT= or ERRMSG=. */
3628
3629 static match
lock_unlock_statement(gfc_statement st)3630 lock_unlock_statement (gfc_statement st)
3631 {
3632 match m;
3633 gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
3634 bool saw_acq_lock, saw_stat, saw_errmsg;
3635
3636 tmp = lockvar = acq_lock = stat = errmsg = NULL;
3637 saw_acq_lock = saw_stat = saw_errmsg = false;
3638
3639 if (gfc_pure (NULL))
3640 {
3641 gfc_error ("Image control statement %s at %C in PURE procedure",
3642 st == ST_LOCK ? "LOCK" : "UNLOCK");
3643 return MATCH_ERROR;
3644 }
3645
3646 gfc_unset_implicit_pure (NULL);
3647
3648 if (flag_coarray == GFC_FCOARRAY_NONE)
3649 {
3650 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3651 return MATCH_ERROR;
3652 }
3653
3654 if (gfc_find_state (COMP_CRITICAL))
3655 {
3656 gfc_error ("Image control statement %s at %C in CRITICAL block",
3657 st == ST_LOCK ? "LOCK" : "UNLOCK");
3658 return MATCH_ERROR;
3659 }
3660
3661 if (gfc_find_state (COMP_DO_CONCURRENT))
3662 {
3663 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3664 st == ST_LOCK ? "LOCK" : "UNLOCK");
3665 return MATCH_ERROR;
3666 }
3667
3668 if (gfc_match_char ('(') != MATCH_YES)
3669 goto syntax;
3670
3671 if (gfc_match ("%e", &lockvar) != MATCH_YES)
3672 goto syntax;
3673 m = gfc_match_char (',');
3674 if (m == MATCH_ERROR)
3675 goto syntax;
3676 if (m == MATCH_NO)
3677 {
3678 m = gfc_match_char (')');
3679 if (m == MATCH_YES)
3680 goto done;
3681 goto syntax;
3682 }
3683
3684 for (;;)
3685 {
3686 m = gfc_match (" stat = %v", &tmp);
3687 if (m == MATCH_ERROR)
3688 goto syntax;
3689 if (m == MATCH_YES)
3690 {
3691 if (saw_stat)
3692 {
3693 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3694 goto cleanup;
3695 }
3696 stat = tmp;
3697 saw_stat = true;
3698
3699 m = gfc_match_char (',');
3700 if (m == MATCH_YES)
3701 continue;
3702
3703 tmp = NULL;
3704 break;
3705 }
3706
3707 m = gfc_match (" errmsg = %v", &tmp);
3708 if (m == MATCH_ERROR)
3709 goto syntax;
3710 if (m == MATCH_YES)
3711 {
3712 if (saw_errmsg)
3713 {
3714 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3715 goto cleanup;
3716 }
3717 errmsg = tmp;
3718 saw_errmsg = true;
3719
3720 m = gfc_match_char (',');
3721 if (m == MATCH_YES)
3722 continue;
3723
3724 tmp = NULL;
3725 break;
3726 }
3727
3728 m = gfc_match (" acquired_lock = %v", &tmp);
3729 if (m == MATCH_ERROR || st == ST_UNLOCK)
3730 goto syntax;
3731 if (m == MATCH_YES)
3732 {
3733 if (saw_acq_lock)
3734 {
3735 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3736 &tmp->where);
3737 goto cleanup;
3738 }
3739 acq_lock = tmp;
3740 saw_acq_lock = true;
3741
3742 m = gfc_match_char (',');
3743 if (m == MATCH_YES)
3744 continue;
3745
3746 tmp = NULL;
3747 break;
3748 }
3749
3750 break;
3751 }
3752
3753 if (m == MATCH_ERROR)
3754 goto syntax;
3755
3756 if (gfc_match (" )%t") != MATCH_YES)
3757 goto syntax;
3758
3759 done:
3760 switch (st)
3761 {
3762 case ST_LOCK:
3763 new_st.op = EXEC_LOCK;
3764 break;
3765 case ST_UNLOCK:
3766 new_st.op = EXEC_UNLOCK;
3767 break;
3768 default:
3769 gcc_unreachable ();
3770 }
3771
3772 new_st.expr1 = lockvar;
3773 new_st.expr2 = stat;
3774 new_st.expr3 = errmsg;
3775 new_st.expr4 = acq_lock;
3776
3777 return MATCH_YES;
3778
3779 syntax:
3780 gfc_syntax_error (st);
3781
3782 cleanup:
3783 if (acq_lock != tmp)
3784 gfc_free_expr (acq_lock);
3785 if (errmsg != tmp)
3786 gfc_free_expr (errmsg);
3787 if (stat != tmp)
3788 gfc_free_expr (stat);
3789
3790 gfc_free_expr (tmp);
3791 gfc_free_expr (lockvar);
3792
3793 return MATCH_ERROR;
3794 }
3795
3796
3797 match
gfc_match_lock(void)3798 gfc_match_lock (void)
3799 {
3800 if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
3801 return MATCH_ERROR;
3802
3803 return lock_unlock_statement (ST_LOCK);
3804 }
3805
3806
3807 match
gfc_match_unlock(void)3808 gfc_match_unlock (void)
3809 {
3810 if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
3811 return MATCH_ERROR;
3812
3813 return lock_unlock_statement (ST_UNLOCK);
3814 }
3815
3816
3817 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3818 SYNC ALL [(sync-stat-list)]
3819 SYNC MEMORY [(sync-stat-list)]
3820 SYNC IMAGES (image-set [, sync-stat-list] )
3821 with sync-stat is int-expr or *. */
3822
3823 static match
sync_statement(gfc_statement st)3824 sync_statement (gfc_statement st)
3825 {
3826 match m;
3827 gfc_expr *tmp, *imageset, *stat, *errmsg;
3828 bool saw_stat, saw_errmsg;
3829
3830 tmp = imageset = stat = errmsg = NULL;
3831 saw_stat = saw_errmsg = false;
3832
3833 if (gfc_pure (NULL))
3834 {
3835 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3836 return MATCH_ERROR;
3837 }
3838
3839 gfc_unset_implicit_pure (NULL);
3840
3841 if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
3842 return MATCH_ERROR;
3843
3844 if (flag_coarray == GFC_FCOARRAY_NONE)
3845 {
3846 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3847 "enable");
3848 return MATCH_ERROR;
3849 }
3850
3851 if (gfc_find_state (COMP_CRITICAL))
3852 {
3853 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3854 return MATCH_ERROR;
3855 }
3856
3857 if (gfc_find_state (COMP_DO_CONCURRENT))
3858 {
3859 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3860 return MATCH_ERROR;
3861 }
3862
3863 if (gfc_match_eos () == MATCH_YES)
3864 {
3865 if (st == ST_SYNC_IMAGES)
3866 goto syntax;
3867 goto done;
3868 }
3869
3870 if (gfc_match_char ('(') != MATCH_YES)
3871 goto syntax;
3872
3873 if (st == ST_SYNC_IMAGES)
3874 {
3875 /* Denote '*' as imageset == NULL. */
3876 m = gfc_match_char ('*');
3877 if (m == MATCH_ERROR)
3878 goto syntax;
3879 if (m == MATCH_NO)
3880 {
3881 if (gfc_match ("%e", &imageset) != MATCH_YES)
3882 goto syntax;
3883 }
3884 m = gfc_match_char (',');
3885 if (m == MATCH_ERROR)
3886 goto syntax;
3887 if (m == MATCH_NO)
3888 {
3889 m = gfc_match_char (')');
3890 if (m == MATCH_YES)
3891 goto done;
3892 goto syntax;
3893 }
3894 }
3895
3896 for (;;)
3897 {
3898 m = gfc_match (" stat = %e", &tmp);
3899 if (m == MATCH_ERROR)
3900 goto syntax;
3901 if (m == MATCH_YES)
3902 {
3903 if (saw_stat)
3904 {
3905 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3906 goto cleanup;
3907 }
3908 stat = tmp;
3909 saw_stat = true;
3910
3911 if (gfc_match_char (',') == MATCH_YES)
3912 continue;
3913
3914 tmp = NULL;
3915 break;
3916 }
3917
3918 m = gfc_match (" errmsg = %e", &tmp);
3919 if (m == MATCH_ERROR)
3920 goto syntax;
3921 if (m == MATCH_YES)
3922 {
3923 if (saw_errmsg)
3924 {
3925 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3926 goto cleanup;
3927 }
3928 errmsg = tmp;
3929 saw_errmsg = true;
3930
3931 if (gfc_match_char (',') == MATCH_YES)
3932 continue;
3933
3934 tmp = NULL;
3935 break;
3936 }
3937
3938 break;
3939 }
3940
3941 if (gfc_match (" )%t") != MATCH_YES)
3942 goto syntax;
3943
3944 done:
3945 switch (st)
3946 {
3947 case ST_SYNC_ALL:
3948 new_st.op = EXEC_SYNC_ALL;
3949 break;
3950 case ST_SYNC_IMAGES:
3951 new_st.op = EXEC_SYNC_IMAGES;
3952 break;
3953 case ST_SYNC_MEMORY:
3954 new_st.op = EXEC_SYNC_MEMORY;
3955 break;
3956 default:
3957 gcc_unreachable ();
3958 }
3959
3960 new_st.expr1 = imageset;
3961 new_st.expr2 = stat;
3962 new_st.expr3 = errmsg;
3963
3964 return MATCH_YES;
3965
3966 syntax:
3967 gfc_syntax_error (st);
3968
3969 cleanup:
3970 if (stat != tmp)
3971 gfc_free_expr (stat);
3972 if (errmsg != tmp)
3973 gfc_free_expr (errmsg);
3974
3975 gfc_free_expr (tmp);
3976 gfc_free_expr (imageset);
3977
3978 return MATCH_ERROR;
3979 }
3980
3981
3982 /* Match SYNC ALL statement. */
3983
3984 match
gfc_match_sync_all(void)3985 gfc_match_sync_all (void)
3986 {
3987 return sync_statement (ST_SYNC_ALL);
3988 }
3989
3990
3991 /* Match SYNC IMAGES statement. */
3992
3993 match
gfc_match_sync_images(void)3994 gfc_match_sync_images (void)
3995 {
3996 return sync_statement (ST_SYNC_IMAGES);
3997 }
3998
3999
4000 /* Match SYNC MEMORY statement. */
4001
4002 match
gfc_match_sync_memory(void)4003 gfc_match_sync_memory (void)
4004 {
4005 return sync_statement (ST_SYNC_MEMORY);
4006 }
4007
4008
4009 /* Match a CONTINUE statement. */
4010
4011 match
gfc_match_continue(void)4012 gfc_match_continue (void)
4013 {
4014 if (gfc_match_eos () != MATCH_YES)
4015 {
4016 gfc_syntax_error (ST_CONTINUE);
4017 return MATCH_ERROR;
4018 }
4019
4020 new_st.op = EXEC_CONTINUE;
4021 return MATCH_YES;
4022 }
4023
4024
4025 /* Match the (deprecated) ASSIGN statement. */
4026
4027 match
gfc_match_assign(void)4028 gfc_match_assign (void)
4029 {
4030 gfc_expr *expr;
4031 gfc_st_label *label;
4032
4033 if (gfc_match (" %l", &label) == MATCH_YES)
4034 {
4035 if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
4036 return MATCH_ERROR;
4037 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
4038 {
4039 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
4040 return MATCH_ERROR;
4041
4042 expr->symtree->n.sym->attr.assign = 1;
4043
4044 new_st.op = EXEC_LABEL_ASSIGN;
4045 new_st.label1 = label;
4046 new_st.expr1 = expr;
4047 return MATCH_YES;
4048 }
4049 }
4050 return MATCH_NO;
4051 }
4052
4053
4054 /* Match the GO TO statement. As a computed GOTO statement is
4055 matched, it is transformed into an equivalent SELECT block. No
4056 tree is necessary, and the resulting jumps-to-jumps are
4057 specifically optimized away by the back end. */
4058
4059 match
gfc_match_goto(void)4060 gfc_match_goto (void)
4061 {
4062 gfc_code *head, *tail;
4063 gfc_expr *expr;
4064 gfc_case *cp;
4065 gfc_st_label *label;
4066 int i;
4067 match m;
4068
4069 if (gfc_match (" %l%t", &label) == MATCH_YES)
4070 {
4071 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
4072 return MATCH_ERROR;
4073
4074 new_st.op = EXEC_GOTO;
4075 new_st.label1 = label;
4076 return MATCH_YES;
4077 }
4078
4079 /* The assigned GO TO statement. */
4080
4081 if (gfc_match_variable (&expr, 0) == MATCH_YES)
4082 {
4083 if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
4084 return MATCH_ERROR;
4085
4086 new_st.op = EXEC_GOTO;
4087 new_st.expr1 = expr;
4088
4089 if (gfc_match_eos () == MATCH_YES)
4090 return MATCH_YES;
4091
4092 /* Match label list. */
4093 gfc_match_char (',');
4094 if (gfc_match_char ('(') != MATCH_YES)
4095 {
4096 gfc_syntax_error (ST_GOTO);
4097 return MATCH_ERROR;
4098 }
4099 head = tail = NULL;
4100
4101 do
4102 {
4103 m = gfc_match_st_label (&label);
4104 if (m != MATCH_YES)
4105 goto syntax;
4106
4107 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
4108 goto cleanup;
4109
4110 if (head == NULL)
4111 head = tail = gfc_get_code (EXEC_GOTO);
4112 else
4113 {
4114 tail->block = gfc_get_code (EXEC_GOTO);
4115 tail = tail->block;
4116 }
4117
4118 tail->label1 = label;
4119 }
4120 while (gfc_match_char (',') == MATCH_YES);
4121
4122 if (gfc_match (" )%t") != MATCH_YES)
4123 goto syntax;
4124
4125 if (head == NULL)
4126 {
4127 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4128 goto syntax;
4129 }
4130 new_st.block = head;
4131
4132 return MATCH_YES;
4133 }
4134
4135 /* Last chance is a computed GO TO statement. */
4136 if (gfc_match_char ('(') != MATCH_YES)
4137 {
4138 gfc_syntax_error (ST_GOTO);
4139 return MATCH_ERROR;
4140 }
4141
4142 head = tail = NULL;
4143 i = 1;
4144
4145 do
4146 {
4147 m = gfc_match_st_label (&label);
4148 if (m != MATCH_YES)
4149 goto syntax;
4150
4151 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
4152 goto cleanup;
4153
4154 if (head == NULL)
4155 head = tail = gfc_get_code (EXEC_SELECT);
4156 else
4157 {
4158 tail->block = gfc_get_code (EXEC_SELECT);
4159 tail = tail->block;
4160 }
4161
4162 cp = gfc_get_case ();
4163 cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
4164 NULL, i++);
4165
4166 tail->ext.block.case_list = cp;
4167
4168 tail->next = gfc_get_code (EXEC_GOTO);
4169 tail->next->label1 = label;
4170 }
4171 while (gfc_match_char (',') == MATCH_YES);
4172
4173 if (gfc_match_char (')') != MATCH_YES)
4174 goto syntax;
4175
4176 if (head == NULL)
4177 {
4178 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4179 goto syntax;
4180 }
4181
4182 /* Get the rest of the statement. */
4183 gfc_match_char (',');
4184
4185 if (gfc_match (" %e%t", &expr) != MATCH_YES)
4186 goto syntax;
4187
4188 if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
4189 return MATCH_ERROR;
4190
4191 /* At this point, a computed GOTO has been fully matched and an
4192 equivalent SELECT statement constructed. */
4193
4194 new_st.op = EXEC_SELECT;
4195 new_st.expr1 = NULL;
4196
4197 /* Hack: For a "real" SELECT, the expression is in expr. We put
4198 it in expr2 so we can distinguish then and produce the correct
4199 diagnostics. */
4200 new_st.expr2 = expr;
4201 new_st.block = head;
4202 return MATCH_YES;
4203
4204 syntax:
4205 gfc_syntax_error (ST_GOTO);
4206 cleanup:
4207 gfc_free_statements (head);
4208 return MATCH_ERROR;
4209 }
4210
4211
4212 /* Frees a list of gfc_alloc structures. */
4213
4214 void
gfc_free_alloc_list(gfc_alloc * p)4215 gfc_free_alloc_list (gfc_alloc *p)
4216 {
4217 gfc_alloc *q;
4218
4219 for (; p; p = q)
4220 {
4221 q = p->next;
4222 gfc_free_expr (p->expr);
4223 free (p);
4224 }
4225 }
4226
4227
4228 /* Match an ALLOCATE statement. */
4229
4230 match
gfc_match_allocate(void)4231 gfc_match_allocate (void)
4232 {
4233 gfc_alloc *head, *tail;
4234 gfc_expr *stat, *errmsg, *tmp, *source, *mold;
4235 gfc_typespec ts;
4236 gfc_symbol *sym;
4237 match m;
4238 locus old_locus, deferred_locus, assumed_locus;
4239 bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
4240 bool saw_unlimited = false, saw_assumed = false;
4241
4242 head = tail = NULL;
4243 stat = errmsg = source = mold = tmp = NULL;
4244 saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
4245
4246 if (gfc_match_char ('(') != MATCH_YES)
4247 {
4248 gfc_syntax_error (ST_ALLOCATE);
4249 return MATCH_ERROR;
4250 }
4251
4252 /* Match an optional type-spec. */
4253 old_locus = gfc_current_locus;
4254 m = gfc_match_type_spec (&ts);
4255 if (m == MATCH_ERROR)
4256 goto cleanup;
4257 else if (m == MATCH_NO)
4258 {
4259 char name[GFC_MAX_SYMBOL_LEN + 3];
4260
4261 if (gfc_match ("%n :: ", name) == MATCH_YES)
4262 {
4263 gfc_error ("Error in type-spec at %L", &old_locus);
4264 goto cleanup;
4265 }
4266
4267 ts.type = BT_UNKNOWN;
4268 }
4269 else
4270 {
4271 /* Needed for the F2008:C631 check below. */
4272 assumed_locus = gfc_current_locus;
4273
4274 if (gfc_match (" :: ") == MATCH_YES)
4275 {
4276 if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
4277 &old_locus))
4278 goto cleanup;
4279
4280 if (ts.deferred)
4281 {
4282 gfc_error ("Type-spec at %L cannot contain a deferred "
4283 "type parameter", &old_locus);
4284 goto cleanup;
4285 }
4286
4287 if (ts.type == BT_CHARACTER)
4288 {
4289 if (!ts.u.cl->length)
4290 saw_assumed = true;
4291 else
4292 ts.u.cl->length_from_typespec = true;
4293 }
4294
4295 if (type_param_spec_list
4296 && gfc_spec_list_type (type_param_spec_list, NULL)
4297 == SPEC_DEFERRED)
4298 {
4299 gfc_error ("The type parameter spec list in the type-spec at "
4300 "%L cannot contain DEFERRED parameters", &old_locus);
4301 goto cleanup;
4302 }
4303 }
4304 else
4305 {
4306 ts.type = BT_UNKNOWN;
4307 gfc_current_locus = old_locus;
4308 }
4309 }
4310
4311 for (;;)
4312 {
4313 if (head == NULL)
4314 head = tail = gfc_get_alloc ();
4315 else
4316 {
4317 tail->next = gfc_get_alloc ();
4318 tail = tail->next;
4319 }
4320
4321 m = gfc_match_variable (&tail->expr, 0);
4322 if (m == MATCH_NO)
4323 goto syntax;
4324 if (m == MATCH_ERROR)
4325 goto cleanup;
4326
4327 if (tail->expr->expr_type == EXPR_CONSTANT)
4328 {
4329 gfc_error ("Unexpected constant at %C");
4330 goto cleanup;
4331 }
4332
4333 if (gfc_check_do_variable (tail->expr->symtree))
4334 goto cleanup;
4335
4336 bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
4337 if (impure && gfc_pure (NULL))
4338 {
4339 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4340 goto cleanup;
4341 }
4342
4343 if (impure)
4344 gfc_unset_implicit_pure (NULL);
4345
4346 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4347 asterisk if and only if each allocate-object is a dummy argument
4348 for which the corresponding type parameter is assumed. */
4349 if (saw_assumed
4350 && (tail->expr->ts.deferred
4351 || (tail->expr->ts.u.cl && tail->expr->ts.u.cl->length)
4352 || tail->expr->symtree->n.sym->attr.dummy == 0))
4353 {
4354 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4355 "type-spec at %L", &assumed_locus);
4356 goto cleanup;
4357 }
4358
4359 if (tail->expr->ts.deferred)
4360 {
4361 saw_deferred = true;
4362 deferred_locus = tail->expr->where;
4363 }
4364
4365 if (gfc_find_state (COMP_DO_CONCURRENT)
4366 || gfc_find_state (COMP_CRITICAL))
4367 {
4368 gfc_ref *ref;
4369 bool coarray = tail->expr->symtree->n.sym->attr.codimension;
4370 for (ref = tail->expr->ref; ref; ref = ref->next)
4371 if (ref->type == REF_COMPONENT)
4372 coarray = ref->u.c.component->attr.codimension;
4373
4374 if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
4375 {
4376 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4377 goto cleanup;
4378 }
4379 if (coarray && gfc_find_state (COMP_CRITICAL))
4380 {
4381 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4382 goto cleanup;
4383 }
4384 }
4385
4386 /* Check for F08:C628. */
4387 sym = tail->expr->symtree->n.sym;
4388 b1 = !(tail->expr->ref
4389 && (tail->expr->ref->type == REF_COMPONENT
4390 || tail->expr->ref->type == REF_ARRAY));
4391 if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
4392 b2 = !(CLASS_DATA (sym)->attr.allocatable
4393 || CLASS_DATA (sym)->attr.class_pointer);
4394 else
4395 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
4396 || sym->attr.proc_pointer);
4397 b3 = sym && sym->ns && sym->ns->proc_name
4398 && (sym->ns->proc_name->attr.allocatable
4399 || sym->ns->proc_name->attr.pointer
4400 || sym->ns->proc_name->attr.proc_pointer);
4401 if (b1 && b2 && !b3)
4402 {
4403 gfc_error ("Allocate-object at %L is neither a data pointer "
4404 "nor an allocatable variable", &tail->expr->where);
4405 goto cleanup;
4406 }
4407
4408 /* The ALLOCATE statement had an optional typespec. Check the
4409 constraints. */
4410 if (ts.type != BT_UNKNOWN)
4411 {
4412 /* Enforce F03:C624. */
4413 if (!gfc_type_compatible (&tail->expr->ts, &ts))
4414 {
4415 gfc_error ("Type of entity at %L is type incompatible with "
4416 "typespec", &tail->expr->where);
4417 goto cleanup;
4418 }
4419
4420 /* Enforce F03:C627. */
4421 if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
4422 {
4423 gfc_error ("Kind type parameter for entity at %L differs from "
4424 "the kind type parameter of the typespec",
4425 &tail->expr->where);
4426 goto cleanup;
4427 }
4428 }
4429
4430 if (tail->expr->ts.type == BT_DERIVED)
4431 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
4432
4433 if (type_param_spec_list)
4434 tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
4435
4436 saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
4437
4438 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
4439 {
4440 gfc_error ("Shape specification for allocatable scalar at %C");
4441 goto cleanup;
4442 }
4443
4444 if (gfc_match_char (',') != MATCH_YES)
4445 break;
4446
4447 alloc_opt_list:
4448
4449 m = gfc_match (" stat = %e", &tmp);
4450 if (m == MATCH_ERROR)
4451 goto cleanup;
4452 if (m == MATCH_YES)
4453 {
4454 /* Enforce C630. */
4455 if (saw_stat)
4456 {
4457 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4458 goto cleanup;
4459 }
4460
4461 stat = tmp;
4462 tmp = NULL;
4463 saw_stat = true;
4464
4465 if (stat->expr_type == EXPR_CONSTANT)
4466 {
4467 gfc_error ("STAT tag at %L cannot be a constant", &stat->where);
4468 goto cleanup;
4469 }
4470
4471 if (gfc_check_do_variable (stat->symtree))
4472 goto cleanup;
4473
4474 if (gfc_match_char (',') == MATCH_YES)
4475 goto alloc_opt_list;
4476 }
4477
4478 m = gfc_match (" errmsg = %e", &tmp);
4479 if (m == MATCH_ERROR)
4480 goto cleanup;
4481 if (m == MATCH_YES)
4482 {
4483 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
4484 goto cleanup;
4485
4486 /* Enforce C630. */
4487 if (saw_errmsg)
4488 {
4489 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4490 goto cleanup;
4491 }
4492
4493 errmsg = tmp;
4494 tmp = NULL;
4495 saw_errmsg = true;
4496
4497 if (gfc_match_char (',') == MATCH_YES)
4498 goto alloc_opt_list;
4499 }
4500
4501 m = gfc_match (" source = %e", &tmp);
4502 if (m == MATCH_ERROR)
4503 goto cleanup;
4504 if (m == MATCH_YES)
4505 {
4506 if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
4507 goto cleanup;
4508
4509 /* Enforce C630. */
4510 if (saw_source)
4511 {
4512 gfc_error ("Redundant SOURCE tag found at %L", &tmp->where);
4513 goto cleanup;
4514 }
4515
4516 /* The next 2 conditionals check C631. */
4517 if (ts.type != BT_UNKNOWN)
4518 {
4519 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4520 &tmp->where, &old_locus);
4521 goto cleanup;
4522 }
4523
4524 if (head->next
4525 && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
4526 " with more than a single allocate object",
4527 &tmp->where))
4528 goto cleanup;
4529
4530 source = tmp;
4531 tmp = NULL;
4532 saw_source = true;
4533
4534 if (gfc_match_char (',') == MATCH_YES)
4535 goto alloc_opt_list;
4536 }
4537
4538 m = gfc_match (" mold = %e", &tmp);
4539 if (m == MATCH_ERROR)
4540 goto cleanup;
4541 if (m == MATCH_YES)
4542 {
4543 if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
4544 goto cleanup;
4545
4546 /* Check F08:C636. */
4547 if (saw_mold)
4548 {
4549 gfc_error ("Redundant MOLD tag found at %L", &tmp->where);
4550 goto cleanup;
4551 }
4552
4553 /* Check F08:C637. */
4554 if (ts.type != BT_UNKNOWN)
4555 {
4556 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4557 &tmp->where, &old_locus);
4558 goto cleanup;
4559 }
4560
4561 mold = tmp;
4562 tmp = NULL;
4563 saw_mold = true;
4564 mold->mold = 1;
4565
4566 if (gfc_match_char (',') == MATCH_YES)
4567 goto alloc_opt_list;
4568 }
4569
4570 gfc_gobble_whitespace ();
4571
4572 if (gfc_peek_char () == ')')
4573 break;
4574 }
4575
4576 if (gfc_match (" )%t") != MATCH_YES)
4577 goto syntax;
4578
4579 /* Check F08:C637. */
4580 if (source && mold)
4581 {
4582 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4583 &mold->where, &source->where);
4584 goto cleanup;
4585 }
4586
4587 /* Check F03:C623, */
4588 if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
4589 {
4590 gfc_error ("Allocate-object at %L with a deferred type parameter "
4591 "requires either a type-spec or SOURCE tag or a MOLD tag",
4592 &deferred_locus);
4593 goto cleanup;
4594 }
4595
4596 /* Check F03:C625, */
4597 if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
4598 {
4599 for (tail = head; tail; tail = tail->next)
4600 {
4601 if (UNLIMITED_POLY (tail->expr))
4602 gfc_error ("Unlimited polymorphic allocate-object at %L "
4603 "requires either a type-spec or SOURCE tag "
4604 "or a MOLD tag", &tail->expr->where);
4605 }
4606 goto cleanup;
4607 }
4608
4609 new_st.op = EXEC_ALLOCATE;
4610 new_st.expr1 = stat;
4611 new_st.expr2 = errmsg;
4612 if (source)
4613 new_st.expr3 = source;
4614 else
4615 new_st.expr3 = mold;
4616 new_st.ext.alloc.list = head;
4617 new_st.ext.alloc.ts = ts;
4618
4619 if (type_param_spec_list)
4620 gfc_free_actual_arglist (type_param_spec_list);
4621
4622 return MATCH_YES;
4623
4624 syntax:
4625 gfc_syntax_error (ST_ALLOCATE);
4626
4627 cleanup:
4628 gfc_free_expr (errmsg);
4629 gfc_free_expr (source);
4630 gfc_free_expr (stat);
4631 gfc_free_expr (mold);
4632 if (tmp && tmp->expr_type) gfc_free_expr (tmp);
4633 gfc_free_alloc_list (head);
4634 if (type_param_spec_list)
4635 gfc_free_actual_arglist (type_param_spec_list);
4636 return MATCH_ERROR;
4637 }
4638
4639
4640 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4641 a set of pointer assignments to intrinsic NULL(). */
4642
4643 match
gfc_match_nullify(void)4644 gfc_match_nullify (void)
4645 {
4646 gfc_code *tail;
4647 gfc_expr *e, *p;
4648 match m;
4649
4650 tail = NULL;
4651
4652 if (gfc_match_char ('(') != MATCH_YES)
4653 goto syntax;
4654
4655 for (;;)
4656 {
4657 m = gfc_match_variable (&p, 0);
4658 if (m == MATCH_ERROR)
4659 goto cleanup;
4660 if (m == MATCH_NO)
4661 goto syntax;
4662
4663 if (gfc_check_do_variable (p->symtree))
4664 goto cleanup;
4665
4666 /* F2008, C1242. */
4667 if (gfc_is_coindexed (p))
4668 {
4669 gfc_error ("Pointer object at %C shall not be coindexed");
4670 goto cleanup;
4671 }
4672
4673 /* Check for valid array pointer object. Bounds remapping is not
4674 allowed with NULLIFY. */
4675 if (p->ref)
4676 {
4677 gfc_ref *remap = p->ref;
4678 for (; remap; remap = remap->next)
4679 if (!remap->next && remap->type == REF_ARRAY
4680 && remap->u.ar.type != AR_FULL)
4681 break;
4682 if (remap)
4683 {
4684 gfc_error ("NULLIFY does not allow bounds remapping for "
4685 "pointer object at %C");
4686 goto cleanup;
4687 }
4688 }
4689
4690 /* build ' => NULL() '. */
4691 e = gfc_get_null_expr (&gfc_current_locus);
4692
4693 /* Chain to list. */
4694 if (tail == NULL)
4695 {
4696 tail = &new_st;
4697 tail->op = EXEC_POINTER_ASSIGN;
4698 }
4699 else
4700 {
4701 tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
4702 tail = tail->next;
4703 }
4704
4705 tail->expr1 = p;
4706 tail->expr2 = e;
4707
4708 if (gfc_match (" )%t") == MATCH_YES)
4709 break;
4710 if (gfc_match_char (',') != MATCH_YES)
4711 goto syntax;
4712 }
4713
4714 return MATCH_YES;
4715
4716 syntax:
4717 gfc_syntax_error (ST_NULLIFY);
4718
4719 cleanup:
4720 gfc_free_statements (new_st.next);
4721 new_st.next = NULL;
4722 gfc_free_expr (new_st.expr1);
4723 new_st.expr1 = NULL;
4724 gfc_free_expr (new_st.expr2);
4725 new_st.expr2 = NULL;
4726 return MATCH_ERROR;
4727 }
4728
4729
4730 /* Match a DEALLOCATE statement. */
4731
4732 match
gfc_match_deallocate(void)4733 gfc_match_deallocate (void)
4734 {
4735 gfc_alloc *head, *tail;
4736 gfc_expr *stat, *errmsg, *tmp;
4737 gfc_symbol *sym;
4738 match m;
4739 bool saw_stat, saw_errmsg, b1, b2;
4740
4741 head = tail = NULL;
4742 stat = errmsg = tmp = NULL;
4743 saw_stat = saw_errmsg = false;
4744
4745 if (gfc_match_char ('(') != MATCH_YES)
4746 goto syntax;
4747
4748 for (;;)
4749 {
4750 if (head == NULL)
4751 head = tail = gfc_get_alloc ();
4752 else
4753 {
4754 tail->next = gfc_get_alloc ();
4755 tail = tail->next;
4756 }
4757
4758 m = gfc_match_variable (&tail->expr, 0);
4759 if (m == MATCH_ERROR)
4760 goto cleanup;
4761 if (m == MATCH_NO)
4762 goto syntax;
4763
4764 if (tail->expr->expr_type == EXPR_CONSTANT)
4765 {
4766 gfc_error ("Unexpected constant at %C");
4767 goto cleanup;
4768 }
4769
4770 if (gfc_check_do_variable (tail->expr->symtree))
4771 goto cleanup;
4772
4773 sym = tail->expr->symtree->n.sym;
4774
4775 bool impure = gfc_impure_variable (sym);
4776 if (impure && gfc_pure (NULL))
4777 {
4778 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4779 goto cleanup;
4780 }
4781
4782 if (impure)
4783 gfc_unset_implicit_pure (NULL);
4784
4785 if (gfc_is_coarray (tail->expr)
4786 && gfc_find_state (COMP_DO_CONCURRENT))
4787 {
4788 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4789 goto cleanup;
4790 }
4791
4792 if (gfc_is_coarray (tail->expr)
4793 && gfc_find_state (COMP_CRITICAL))
4794 {
4795 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4796 goto cleanup;
4797 }
4798
4799 /* FIXME: disable the checking on derived types. */
4800 b1 = !(tail->expr->ref
4801 && (tail->expr->ref->type == REF_COMPONENT
4802 || tail->expr->ref->type == REF_ARRAY));
4803 if (sym && sym->ts.type == BT_CLASS)
4804 b2 = !(CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.allocatable
4805 || CLASS_DATA (sym)->attr.class_pointer));
4806 else
4807 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
4808 || sym->attr.proc_pointer);
4809 if (b1 && b2)
4810 {
4811 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4812 "nor an allocatable variable");
4813 goto cleanup;
4814 }
4815
4816 if (gfc_match_char (',') != MATCH_YES)
4817 break;
4818
4819 dealloc_opt_list:
4820
4821 m = gfc_match (" stat = %e", &tmp);
4822 if (m == MATCH_ERROR)
4823 goto cleanup;
4824 if (m == MATCH_YES)
4825 {
4826 if (saw_stat)
4827 {
4828 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4829 gfc_free_expr (tmp);
4830 goto cleanup;
4831 }
4832
4833 stat = tmp;
4834 saw_stat = true;
4835
4836 if (gfc_check_do_variable (stat->symtree))
4837 goto cleanup;
4838
4839 if (gfc_match_char (',') == MATCH_YES)
4840 goto dealloc_opt_list;
4841 }
4842
4843 m = gfc_match (" errmsg = %e", &tmp);
4844 if (m == MATCH_ERROR)
4845 goto cleanup;
4846 if (m == MATCH_YES)
4847 {
4848 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
4849 goto cleanup;
4850
4851 if (saw_errmsg)
4852 {
4853 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4854 gfc_free_expr (tmp);
4855 goto cleanup;
4856 }
4857
4858 errmsg = tmp;
4859 saw_errmsg = true;
4860
4861 if (gfc_match_char (',') == MATCH_YES)
4862 goto dealloc_opt_list;
4863 }
4864
4865 gfc_gobble_whitespace ();
4866
4867 if (gfc_peek_char () == ')')
4868 break;
4869 }
4870
4871 if (gfc_match (" )%t") != MATCH_YES)
4872 goto syntax;
4873
4874 new_st.op = EXEC_DEALLOCATE;
4875 new_st.expr1 = stat;
4876 new_st.expr2 = errmsg;
4877 new_st.ext.alloc.list = head;
4878
4879 return MATCH_YES;
4880
4881 syntax:
4882 gfc_syntax_error (ST_DEALLOCATE);
4883
4884 cleanup:
4885 gfc_free_expr (errmsg);
4886 gfc_free_expr (stat);
4887 gfc_free_alloc_list (head);
4888 return MATCH_ERROR;
4889 }
4890
4891
4892 /* Match a RETURN statement. */
4893
4894 match
gfc_match_return(void)4895 gfc_match_return (void)
4896 {
4897 gfc_expr *e;
4898 match m;
4899 gfc_compile_state s;
4900
4901 e = NULL;
4902
4903 if (gfc_find_state (COMP_CRITICAL))
4904 {
4905 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4906 return MATCH_ERROR;
4907 }
4908
4909 if (gfc_find_state (COMP_DO_CONCURRENT))
4910 {
4911 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4912 return MATCH_ERROR;
4913 }
4914
4915 if (gfc_match_eos () == MATCH_YES)
4916 goto done;
4917
4918 if (!gfc_find_state (COMP_SUBROUTINE))
4919 {
4920 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4921 "a SUBROUTINE");
4922 goto cleanup;
4923 }
4924
4925 if (gfc_current_form == FORM_FREE)
4926 {
4927 /* The following are valid, so we can't require a blank after the
4928 RETURN keyword:
4929 return+1
4930 return(1) */
4931 char c = gfc_peek_ascii_char ();
4932 if (ISALPHA (c) || ISDIGIT (c))
4933 return MATCH_NO;
4934 }
4935
4936 m = gfc_match (" %e%t", &e);
4937 if (m == MATCH_YES)
4938 goto done;
4939 if (m == MATCH_ERROR)
4940 goto cleanup;
4941
4942 gfc_syntax_error (ST_RETURN);
4943
4944 cleanup:
4945 gfc_free_expr (e);
4946 return MATCH_ERROR;
4947
4948 done:
4949 gfc_enclosing_unit (&s);
4950 if (s == COMP_PROGRAM
4951 && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
4952 "main program at %C"))
4953 return MATCH_ERROR;
4954
4955 new_st.op = EXEC_RETURN;
4956 new_st.expr1 = e;
4957
4958 return MATCH_YES;
4959 }
4960
4961
4962 /* Match the call of a type-bound procedure, if CALL%var has already been
4963 matched and var found to be a derived-type variable. */
4964
4965 static match
match_typebound_call(gfc_symtree * varst)4966 match_typebound_call (gfc_symtree* varst)
4967 {
4968 gfc_expr* base;
4969 match m;
4970
4971 base = gfc_get_expr ();
4972 base->expr_type = EXPR_VARIABLE;
4973 base->symtree = varst;
4974 base->where = gfc_current_locus;
4975 gfc_set_sym_referenced (varst->n.sym);
4976
4977 m = gfc_match_varspec (base, 0, true, true);
4978 if (m == MATCH_NO)
4979 gfc_error ("Expected component reference at %C");
4980 if (m != MATCH_YES)
4981 {
4982 gfc_free_expr (base);
4983 return MATCH_ERROR;
4984 }
4985
4986 if (gfc_match_eos () != MATCH_YES)
4987 {
4988 gfc_error ("Junk after CALL at %C");
4989 gfc_free_expr (base);
4990 return MATCH_ERROR;
4991 }
4992
4993 if (base->expr_type == EXPR_COMPCALL)
4994 new_st.op = EXEC_COMPCALL;
4995 else if (base->expr_type == EXPR_PPC)
4996 new_st.op = EXEC_CALL_PPC;
4997 else
4998 {
4999 gfc_error ("Expected type-bound procedure or procedure pointer component "
5000 "at %C");
5001 gfc_free_expr (base);
5002 return MATCH_ERROR;
5003 }
5004 new_st.expr1 = base;
5005
5006 return MATCH_YES;
5007 }
5008
5009
5010 /* Match a CALL statement. The tricky part here are possible
5011 alternate return specifiers. We handle these by having all
5012 "subroutines" actually return an integer via a register that gives
5013 the return number. If the call specifies alternate returns, we
5014 generate code for a SELECT statement whose case clauses contain
5015 GOTOs to the various labels. */
5016
5017 match
gfc_match_call(void)5018 gfc_match_call (void)
5019 {
5020 char name[GFC_MAX_SYMBOL_LEN + 1];
5021 gfc_actual_arglist *a, *arglist;
5022 gfc_case *new_case;
5023 gfc_symbol *sym;
5024 gfc_symtree *st;
5025 gfc_code *c;
5026 match m;
5027 int i;
5028
5029 arglist = NULL;
5030
5031 m = gfc_match ("% %n", name);
5032 if (m == MATCH_NO)
5033 goto syntax;
5034 if (m != MATCH_YES)
5035 return m;
5036
5037 if (gfc_get_ha_sym_tree (name, &st))
5038 return MATCH_ERROR;
5039
5040 sym = st->n.sym;
5041
5042 /* If this is a variable of derived-type, it probably starts a type-bound
5043 procedure call. Associate variable targets have to be resolved for the
5044 target type. */
5045 if (((sym->attr.flavor != FL_PROCEDURE
5046 || gfc_is_function_return_value (sym, gfc_current_ns))
5047 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
5048 ||
5049 (sym->assoc && sym->assoc->target
5050 && gfc_resolve_expr (sym->assoc->target)
5051 && (sym->assoc->target->ts.type == BT_DERIVED
5052 || sym->assoc->target->ts.type == BT_CLASS)))
5053 return match_typebound_call (st);
5054
5055 /* If it does not seem to be callable (include functions so that the
5056 right association is made. They are thrown out in resolution.)
5057 ... */
5058 if (!sym->attr.generic
5059 && !sym->attr.subroutine
5060 && !sym->attr.function)
5061 {
5062 if (!(sym->attr.external && !sym->attr.referenced))
5063 {
5064 /* ...create a symbol in this scope... */
5065 if (sym->ns != gfc_current_ns
5066 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
5067 return MATCH_ERROR;
5068
5069 if (sym != st->n.sym)
5070 sym = st->n.sym;
5071 }
5072
5073 /* ...and then to try to make the symbol into a subroutine. */
5074 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5075 return MATCH_ERROR;
5076 }
5077
5078 gfc_set_sym_referenced (sym);
5079
5080 if (gfc_match_eos () != MATCH_YES)
5081 {
5082 m = gfc_match_actual_arglist (1, &arglist);
5083 if (m == MATCH_NO)
5084 goto syntax;
5085 if (m == MATCH_ERROR)
5086 goto cleanup;
5087
5088 if (gfc_match_eos () != MATCH_YES)
5089 goto syntax;
5090 }
5091
5092 /* Walk the argument list looking for invalid BOZ. */
5093 for (a = arglist; a; a = a->next)
5094 if (a->expr && a->expr->ts.type == BT_BOZ)
5095 {
5096 gfc_error ("A BOZ literal constant at %L cannot appear as an actual "
5097 "argument in a subroutine reference", &a->expr->where);
5098 goto cleanup;
5099 }
5100
5101
5102 /* If any alternate return labels were found, construct a SELECT
5103 statement that will jump to the right place. */
5104
5105 i = 0;
5106 for (a = arglist; a; a = a->next)
5107 if (a->expr == NULL)
5108 {
5109 i = 1;
5110 break;
5111 }
5112
5113 if (i)
5114 {
5115 gfc_symtree *select_st;
5116 gfc_symbol *select_sym;
5117 char name[GFC_MAX_SYMBOL_LEN + 1];
5118
5119 new_st.next = c = gfc_get_code (EXEC_SELECT);
5120 sprintf (name, "_result_%s", sym->name);
5121 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
5122
5123 select_sym = select_st->n.sym;
5124 select_sym->ts.type = BT_INTEGER;
5125 select_sym->ts.kind = gfc_default_integer_kind;
5126 gfc_set_sym_referenced (select_sym);
5127 c->expr1 = gfc_get_expr ();
5128 c->expr1->expr_type = EXPR_VARIABLE;
5129 c->expr1->symtree = select_st;
5130 c->expr1->ts = select_sym->ts;
5131 c->expr1->where = gfc_current_locus;
5132
5133 i = 0;
5134 for (a = arglist; a; a = a->next)
5135 {
5136 if (a->expr != NULL)
5137 continue;
5138
5139 if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
5140 continue;
5141
5142 i++;
5143
5144 c->block = gfc_get_code (EXEC_SELECT);
5145 c = c->block;
5146
5147 new_case = gfc_get_case ();
5148 new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
5149 new_case->low = new_case->high;
5150 c->ext.block.case_list = new_case;
5151
5152 c->next = gfc_get_code (EXEC_GOTO);
5153 c->next->label1 = a->label;
5154 }
5155 }
5156
5157 new_st.op = EXEC_CALL;
5158 new_st.symtree = st;
5159 new_st.ext.actual = arglist;
5160
5161 return MATCH_YES;
5162
5163 syntax:
5164 gfc_syntax_error (ST_CALL);
5165
5166 cleanup:
5167 gfc_free_actual_arglist (arglist);
5168 return MATCH_ERROR;
5169 }
5170
5171
5172 /* Given a name, return a pointer to the common head structure,
5173 creating it if it does not exist. If FROM_MODULE is nonzero, we
5174 mangle the name so that it doesn't interfere with commons defined
5175 in the using namespace.
5176 TODO: Add to global symbol tree. */
5177
5178 gfc_common_head *
gfc_get_common(const char * name,int from_module)5179 gfc_get_common (const char *name, int from_module)
5180 {
5181 gfc_symtree *st;
5182 static int serial = 0;
5183 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
5184
5185 if (from_module)
5186 {
5187 /* A use associated common block is only needed to correctly layout
5188 the variables it contains. */
5189 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
5190 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
5191 }
5192 else
5193 {
5194 st = gfc_find_symtree (gfc_current_ns->common_root, name);
5195
5196 if (st == NULL)
5197 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
5198 }
5199
5200 if (st->n.common == NULL)
5201 {
5202 st->n.common = gfc_get_common_head ();
5203 st->n.common->where = gfc_current_locus;
5204 strcpy (st->n.common->name, name);
5205 }
5206
5207 return st->n.common;
5208 }
5209
5210
5211 /* Match a common block name. */
5212
5213 match
gfc_match_common_name(char * name)5214 gfc_match_common_name (char *name)
5215 {
5216 match m;
5217
5218 if (gfc_match_char ('/') == MATCH_NO)
5219 {
5220 name[0] = '\0';
5221 return MATCH_YES;
5222 }
5223
5224 if (gfc_match_char ('/') == MATCH_YES)
5225 {
5226 name[0] = '\0';
5227 return MATCH_YES;
5228 }
5229
5230 m = gfc_match_name (name);
5231
5232 if (m == MATCH_ERROR)
5233 return MATCH_ERROR;
5234 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
5235 return MATCH_YES;
5236
5237 gfc_error ("Syntax error in common block name at %C");
5238 return MATCH_ERROR;
5239 }
5240
5241
5242 /* Match a COMMON statement. */
5243
5244 match
gfc_match_common(void)5245 gfc_match_common (void)
5246 {
5247 gfc_symbol *sym, **head, *tail, *other;
5248 char name[GFC_MAX_SYMBOL_LEN + 1];
5249 gfc_common_head *t;
5250 gfc_array_spec *as;
5251 gfc_equiv *e1, *e2;
5252 match m;
5253 char c;
5254
5255 /* COMMON has been matched. In free form source code, the next character
5256 needs to be whitespace or '/'. Check that here. Fixed form source
5257 code needs to be checked below. */
5258 c = gfc_peek_ascii_char ();
5259 if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '/')
5260 return MATCH_NO;
5261
5262 as = NULL;
5263
5264 for (;;)
5265 {
5266 m = gfc_match_common_name (name);
5267 if (m == MATCH_ERROR)
5268 goto cleanup;
5269
5270 if (name[0] == '\0')
5271 {
5272 t = &gfc_current_ns->blank_common;
5273 if (t->head == NULL)
5274 t->where = gfc_current_locus;
5275 }
5276 else
5277 {
5278 t = gfc_get_common (name, 0);
5279 }
5280 head = &t->head;
5281
5282 if (*head == NULL)
5283 tail = NULL;
5284 else
5285 {
5286 tail = *head;
5287 while (tail->common_next)
5288 tail = tail->common_next;
5289 }
5290
5291 /* Grab the list of symbols. */
5292 for (;;)
5293 {
5294 m = gfc_match_symbol (&sym, 0);
5295 if (m == MATCH_ERROR)
5296 goto cleanup;
5297 if (m == MATCH_NO)
5298 goto syntax;
5299
5300 /* See if we know the current common block is bind(c), and if
5301 so, then see if we can check if the symbol is (which it'll
5302 need to be). This can happen if the bind(c) attr stmt was
5303 applied to the common block, and the variable(s) already
5304 defined, before declaring the common block. */
5305 if (t->is_bind_c == 1)
5306 {
5307 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
5308 {
5309 /* If we find an error, just print it and continue,
5310 cause it's just semantic, and we can see if there
5311 are more errors. */
5312 gfc_error_now ("Variable %qs at %L in common block %qs "
5313 "at %C must be declared with a C "
5314 "interoperable kind since common block "
5315 "%qs is bind(c)",
5316 sym->name, &(sym->declared_at), t->name,
5317 t->name);
5318 }
5319
5320 if (sym->attr.is_bind_c == 1)
5321 gfc_error_now ("Variable %qs in common block %qs at %C cannot "
5322 "be bind(c) since it is not global", sym->name,
5323 t->name);
5324 }
5325
5326 if (sym->attr.in_common)
5327 {
5328 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5329 sym->name);
5330 goto cleanup;
5331 }
5332
5333 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
5334 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
5335 {
5336 if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
5337 "%C can only be COMMON in BLOCK DATA",
5338 sym->name))
5339 goto cleanup;
5340 }
5341
5342 /* F2018:R874: common-block-object is variable-name [ (array-spec) ]
5343 F2018:C8121: A variable-name shall not be a name made accessible
5344 by use association. */
5345 if (sym->attr.use_assoc)
5346 {
5347 gfc_error ("Symbol %qs at %C is USE associated from module %qs "
5348 "and cannot occur in COMMON", sym->name, sym->module);
5349 goto cleanup;
5350 }
5351
5352 /* Deal with an optional array specification after the
5353 symbol name. */
5354 m = gfc_match_array_spec (&as, true, true);
5355 if (m == MATCH_ERROR)
5356 goto cleanup;
5357
5358 if (m == MATCH_YES)
5359 {
5360 if (as->type != AS_EXPLICIT)
5361 {
5362 gfc_error ("Array specification for symbol %qs in COMMON "
5363 "at %C must be explicit", sym->name);
5364 goto cleanup;
5365 }
5366
5367 if (as->corank)
5368 {
5369 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5370 "coarray", sym->name);
5371 goto cleanup;
5372 }
5373
5374 if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
5375 goto cleanup;
5376
5377 if (sym->attr.pointer)
5378 {
5379 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5380 "POINTER array", sym->name);
5381 goto cleanup;
5382 }
5383
5384 sym->as = as;
5385 as = NULL;
5386
5387 }
5388
5389 /* Add the in_common attribute, but ignore the reported errors
5390 if any, and continue matching. */
5391 gfc_add_in_common (&sym->attr, sym->name, NULL);
5392
5393 sym->common_block = t;
5394 sym->common_block->refs++;
5395
5396 if (tail != NULL)
5397 tail->common_next = sym;
5398 else
5399 *head = sym;
5400
5401 tail = sym;
5402
5403 sym->common_head = t;
5404
5405 /* Check to see if the symbol is already in an equivalence group.
5406 If it is, set the other members as being in common. */
5407 if (sym->attr.in_equivalence)
5408 {
5409 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
5410 {
5411 for (e2 = e1; e2; e2 = e2->eq)
5412 if (e2->expr->symtree->n.sym == sym)
5413 goto equiv_found;
5414
5415 continue;
5416
5417 equiv_found:
5418
5419 for (e2 = e1; e2; e2 = e2->eq)
5420 {
5421 other = e2->expr->symtree->n.sym;
5422 if (other->common_head
5423 && other->common_head != sym->common_head)
5424 {
5425 gfc_error ("Symbol %qs, in COMMON block %qs at "
5426 "%C is being indirectly equivalenced to "
5427 "another COMMON block %qs",
5428 sym->name, sym->common_head->name,
5429 other->common_head->name);
5430 goto cleanup;
5431 }
5432 other->attr.in_common = 1;
5433 other->common_head = t;
5434 }
5435 }
5436 }
5437
5438
5439 gfc_gobble_whitespace ();
5440 if (gfc_match_eos () == MATCH_YES)
5441 goto done;
5442 c = gfc_peek_ascii_char ();
5443 if (c == '/')
5444 break;
5445 if (c != ',')
5446 {
5447 /* In Fixed form source code, gfortran can end up here for an
5448 expression of the form COMMONI = RHS. This may not be an
5449 error, so return MATCH_NO. */
5450 if (gfc_current_form == FORM_FIXED && c == '=')
5451 {
5452 gfc_free_array_spec (as);
5453 return MATCH_NO;
5454 }
5455 goto syntax;
5456 }
5457 else
5458 gfc_match_char (',');
5459
5460 gfc_gobble_whitespace ();
5461 if (gfc_peek_ascii_char () == '/')
5462 break;
5463 }
5464 }
5465
5466 done:
5467 return MATCH_YES;
5468
5469 syntax:
5470 gfc_syntax_error (ST_COMMON);
5471
5472 cleanup:
5473 gfc_free_array_spec (as);
5474 return MATCH_ERROR;
5475 }
5476
5477
5478 /* Match a BLOCK DATA program unit. */
5479
5480 match
gfc_match_block_data(void)5481 gfc_match_block_data (void)
5482 {
5483 char name[GFC_MAX_SYMBOL_LEN + 1];
5484 gfc_symbol *sym;
5485 match m;
5486
5487 if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L",
5488 &gfc_current_locus))
5489 return MATCH_ERROR;
5490
5491 if (gfc_match_eos () == MATCH_YES)
5492 {
5493 gfc_new_block = NULL;
5494 return MATCH_YES;
5495 }
5496
5497 m = gfc_match ("% %n%t", name);
5498 if (m != MATCH_YES)
5499 return MATCH_ERROR;
5500
5501 if (gfc_get_symbol (name, NULL, &sym))
5502 return MATCH_ERROR;
5503
5504 if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
5505 return MATCH_ERROR;
5506
5507 gfc_new_block = sym;
5508
5509 return MATCH_YES;
5510 }
5511
5512
5513 /* Free a namelist structure. */
5514
5515 void
gfc_free_namelist(gfc_namelist * name)5516 gfc_free_namelist (gfc_namelist *name)
5517 {
5518 gfc_namelist *n;
5519
5520 for (; name; name = n)
5521 {
5522 n = name->next;
5523 free (name);
5524 }
5525 }
5526
5527
5528 /* Free an OpenMP namelist structure. */
5529
5530 void
gfc_free_omp_namelist(gfc_omp_namelist * name,bool free_ns)5531 gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns)
5532 {
5533 gfc_omp_namelist *n;
5534
5535 for (; name; name = n)
5536 {
5537 gfc_free_expr (name->expr);
5538 if (free_ns)
5539 gfc_free_namespace (name->u2.ns);
5540 else if (name->u2.udr)
5541 {
5542 if (name->u2.udr->combiner)
5543 gfc_free_statement (name->u2.udr->combiner);
5544 if (name->u2.udr->initializer)
5545 gfc_free_statement (name->u2.udr->initializer);
5546 free (name->u2.udr);
5547 }
5548 n = name->next;
5549 free (name);
5550 }
5551 }
5552
5553
5554 /* Match a NAMELIST statement. */
5555
5556 match
gfc_match_namelist(void)5557 gfc_match_namelist (void)
5558 {
5559 gfc_symbol *group_name, *sym;
5560 gfc_namelist *nl;
5561 match m, m2;
5562
5563 m = gfc_match (" / %s /", &group_name);
5564 if (m == MATCH_NO)
5565 goto syntax;
5566 if (m == MATCH_ERROR)
5567 goto error;
5568
5569 for (;;)
5570 {
5571 if (group_name->ts.type != BT_UNKNOWN)
5572 {
5573 gfc_error ("Namelist group name %qs at %C already has a basic "
5574 "type of %s", group_name->name,
5575 gfc_typename (&group_name->ts));
5576 return MATCH_ERROR;
5577 }
5578
5579 if (group_name->attr.flavor == FL_NAMELIST
5580 && group_name->attr.use_assoc
5581 && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs "
5582 "at %C already is USE associated and can"
5583 "not be respecified.", group_name->name))
5584 return MATCH_ERROR;
5585
5586 if (group_name->attr.flavor != FL_NAMELIST
5587 && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
5588 group_name->name, NULL))
5589 return MATCH_ERROR;
5590
5591 for (;;)
5592 {
5593 m = gfc_match_symbol (&sym, 1);
5594 if (m == MATCH_NO)
5595 goto syntax;
5596 if (m == MATCH_ERROR)
5597 goto error;
5598
5599 if (sym->ts.type == BT_UNKNOWN)
5600 {
5601 if (gfc_current_ns->seen_implicit_none)
5602 {
5603 /* It is required that members of a namelist be declared
5604 before the namelist. We check this by checking if the
5605 symbol has a defined type for IMPLICIT NONE. */
5606 gfc_error ("Symbol %qs in namelist %qs at %C must be "
5607 "declared before the namelist is declared.",
5608 sym->name, group_name->name);
5609 gfc_error_check ();
5610 }
5611 else
5612 /* If the type is not set already, we set it here to the
5613 implicit default type. It is not allowed to set it
5614 later to any other type. */
5615 gfc_set_default_type (sym, 0, gfc_current_ns);
5616 }
5617 if (sym->attr.in_namelist == 0
5618 && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
5619 goto error;
5620
5621 /* Use gfc_error_check here, rather than goto error, so that
5622 these are the only errors for the next two lines. */
5623 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
5624 {
5625 gfc_error ("Assumed size array %qs in namelist %qs at "
5626 "%C is not allowed", sym->name, group_name->name);
5627 gfc_error_check ();
5628 }
5629
5630 nl = gfc_get_namelist ();
5631 nl->sym = sym;
5632 sym->refs++;
5633
5634 if (group_name->namelist == NULL)
5635 group_name->namelist = group_name->namelist_tail = nl;
5636 else
5637 {
5638 group_name->namelist_tail->next = nl;
5639 group_name->namelist_tail = nl;
5640 }
5641
5642 if (gfc_match_eos () == MATCH_YES)
5643 goto done;
5644
5645 m = gfc_match_char (',');
5646
5647 if (gfc_match_char ('/') == MATCH_YES)
5648 {
5649 m2 = gfc_match (" %s /", &group_name);
5650 if (m2 == MATCH_YES)
5651 break;
5652 if (m2 == MATCH_ERROR)
5653 goto error;
5654 goto syntax;
5655 }
5656
5657 if (m != MATCH_YES)
5658 goto syntax;
5659 }
5660 }
5661
5662 done:
5663 return MATCH_YES;
5664
5665 syntax:
5666 gfc_syntax_error (ST_NAMELIST);
5667
5668 error:
5669 return MATCH_ERROR;
5670 }
5671
5672
5673 /* Match a MODULE statement. */
5674
5675 match
gfc_match_module(void)5676 gfc_match_module (void)
5677 {
5678 match m;
5679
5680 m = gfc_match (" %s%t", &gfc_new_block);
5681 if (m != MATCH_YES)
5682 return m;
5683
5684 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
5685 gfc_new_block->name, NULL))
5686 return MATCH_ERROR;
5687
5688 return MATCH_YES;
5689 }
5690
5691
5692 /* Free equivalence sets and lists. Recursively is the easiest way to
5693 do this. */
5694
5695 void
gfc_free_equiv_until(gfc_equiv * eq,gfc_equiv * stop)5696 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
5697 {
5698 if (eq == stop)
5699 return;
5700
5701 gfc_free_equiv (eq->eq);
5702 gfc_free_equiv_until (eq->next, stop);
5703 gfc_free_expr (eq->expr);
5704 free (eq);
5705 }
5706
5707
5708 void
gfc_free_equiv(gfc_equiv * eq)5709 gfc_free_equiv (gfc_equiv *eq)
5710 {
5711 gfc_free_equiv_until (eq, NULL);
5712 }
5713
5714
5715 /* Match an EQUIVALENCE statement. */
5716
5717 match
gfc_match_equivalence(void)5718 gfc_match_equivalence (void)
5719 {
5720 gfc_equiv *eq, *set, *tail;
5721 gfc_ref *ref;
5722 gfc_symbol *sym;
5723 match m;
5724 gfc_common_head *common_head = NULL;
5725 bool common_flag;
5726 int cnt;
5727 char c;
5728
5729 /* EQUIVALENCE has been matched. After gobbling any possible whitespace,
5730 the next character needs to be '('. Check that here, and return
5731 MATCH_NO for a variable of the form equivalencej. */
5732 gfc_gobble_whitespace ();
5733 c = gfc_peek_ascii_char ();
5734 if (c != '(')
5735 return MATCH_NO;
5736
5737 tail = NULL;
5738
5739 for (;;)
5740 {
5741 eq = gfc_get_equiv ();
5742 if (tail == NULL)
5743 tail = eq;
5744
5745 eq->next = gfc_current_ns->equiv;
5746 gfc_current_ns->equiv = eq;
5747
5748 if (gfc_match_char ('(') != MATCH_YES)
5749 goto syntax;
5750
5751 set = eq;
5752 common_flag = FALSE;
5753 cnt = 0;
5754
5755 for (;;)
5756 {
5757 m = gfc_match_equiv_variable (&set->expr);
5758 if (m == MATCH_ERROR)
5759 goto cleanup;
5760 if (m == MATCH_NO)
5761 goto syntax;
5762
5763 /* count the number of objects. */
5764 cnt++;
5765
5766 if (gfc_match_char ('%') == MATCH_YES)
5767 {
5768 gfc_error ("Derived type component %C is not a "
5769 "permitted EQUIVALENCE member");
5770 goto cleanup;
5771 }
5772
5773 for (ref = set->expr->ref; ref; ref = ref->next)
5774 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
5775 {
5776 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5777 "be an array section");
5778 goto cleanup;
5779 }
5780
5781 sym = set->expr->symtree->n.sym;
5782
5783 if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
5784 goto cleanup;
5785 if (sym->ts.type == BT_CLASS
5786 && CLASS_DATA (sym)
5787 && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr,
5788 sym->name, NULL))
5789 goto cleanup;
5790
5791 if (sym->attr.in_common)
5792 {
5793 common_flag = TRUE;
5794 common_head = sym->common_head;
5795 }
5796
5797 if (gfc_match_char (')') == MATCH_YES)
5798 break;
5799
5800 if (gfc_match_char (',') != MATCH_YES)
5801 goto syntax;
5802
5803 set->eq = gfc_get_equiv ();
5804 set = set->eq;
5805 }
5806
5807 if (cnt < 2)
5808 {
5809 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5810 goto cleanup;
5811 }
5812
5813 /* If one of the members of an equivalence is in common, then
5814 mark them all as being in common. Before doing this, check
5815 that members of the equivalence group are not in different
5816 common blocks. */
5817 if (common_flag)
5818 for (set = eq; set; set = set->eq)
5819 {
5820 sym = set->expr->symtree->n.sym;
5821 if (sym->common_head && sym->common_head != common_head)
5822 {
5823 gfc_error ("Attempt to indirectly overlap COMMON "
5824 "blocks %s and %s by EQUIVALENCE at %C",
5825 sym->common_head->name, common_head->name);
5826 goto cleanup;
5827 }
5828 sym->attr.in_common = 1;
5829 sym->common_head = common_head;
5830 }
5831
5832 if (gfc_match_eos () == MATCH_YES)
5833 break;
5834 if (gfc_match_char (',') != MATCH_YES)
5835 {
5836 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5837 goto cleanup;
5838 }
5839 }
5840
5841 if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C"))
5842 return MATCH_ERROR;
5843
5844 return MATCH_YES;
5845
5846 syntax:
5847 gfc_syntax_error (ST_EQUIVALENCE);
5848
5849 cleanup:
5850 eq = tail->next;
5851 tail->next = NULL;
5852
5853 gfc_free_equiv (gfc_current_ns->equiv);
5854 gfc_current_ns->equiv = eq;
5855
5856 return MATCH_ERROR;
5857 }
5858
5859
5860 /* Check that a statement function is not recursive. This is done by looking
5861 for the statement function symbol(sym) by looking recursively through its
5862 expression(e). If a reference to sym is found, true is returned.
5863 12.5.4 requires that any variable of function that is implicitly typed
5864 shall have that type confirmed by any subsequent type declaration. The
5865 implicit typing is conveniently done here. */
5866 static bool
5867 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
5868
5869 static bool
check_stmt_fcn(gfc_expr * e,gfc_symbol * sym,int * f ATTRIBUTE_UNUSED)5870 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5871 {
5872
5873 if (e == NULL)
5874 return false;
5875
5876 switch (e->expr_type)
5877 {
5878 case EXPR_FUNCTION:
5879 if (e->symtree == NULL)
5880 return false;
5881
5882 /* Check the name before testing for nested recursion! */
5883 if (sym->name == e->symtree->n.sym->name)
5884 return true;
5885
5886 /* Catch recursion via other statement functions. */
5887 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
5888 && e->symtree->n.sym->value
5889 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
5890 return true;
5891
5892 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
5893 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
5894
5895 break;
5896
5897 case EXPR_VARIABLE:
5898 if (e->symtree && sym->name == e->symtree->n.sym->name)
5899 return true;
5900
5901 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
5902 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
5903 break;
5904
5905 default:
5906 break;
5907 }
5908
5909 return false;
5910 }
5911
5912
5913 static bool
recursive_stmt_fcn(gfc_expr * e,gfc_symbol * sym)5914 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
5915 {
5916 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
5917 }
5918
5919
5920 /* Match a statement function declaration. It is so easy to match
5921 non-statement function statements with a MATCH_ERROR as opposed to
5922 MATCH_NO that we suppress error message in most cases. */
5923
5924 match
gfc_match_st_function(void)5925 gfc_match_st_function (void)
5926 {
5927 gfc_error_buffer old_error;
5928 gfc_symbol *sym;
5929 gfc_expr *expr;
5930 match m;
5931 char name[GFC_MAX_SYMBOL_LEN + 1];
5932 locus old_locus;
5933 bool fcn;
5934 gfc_formal_arglist *ptr;
5935
5936 /* Read the possible statement function name, and then check to see if
5937 a symbol is already present in the namespace. Record if it is a
5938 function and whether it has been referenced. */
5939 fcn = false;
5940 ptr = NULL;
5941 old_locus = gfc_current_locus;
5942 m = gfc_match_name (name);
5943 if (m == MATCH_YES)
5944 {
5945 gfc_find_symbol (name, NULL, 1, &sym);
5946 if (sym && sym->attr.function && !sym->attr.referenced)
5947 {
5948 fcn = true;
5949 ptr = sym->formal;
5950 }
5951 }
5952
5953 gfc_current_locus = old_locus;
5954 m = gfc_match_symbol (&sym, 0);
5955 if (m != MATCH_YES)
5956 return m;
5957
5958 gfc_push_error (&old_error);
5959
5960 if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
5961 goto undo_error;
5962
5963 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
5964 goto undo_error;
5965
5966 m = gfc_match (" = %e%t", &expr);
5967 if (m == MATCH_NO)
5968 goto undo_error;
5969
5970 gfc_free_error (&old_error);
5971
5972 if (m == MATCH_ERROR)
5973 return m;
5974
5975 if (recursive_stmt_fcn (expr, sym))
5976 {
5977 gfc_error ("Statement function at %L is recursive", &expr->where);
5978 return MATCH_ERROR;
5979 }
5980
5981 if (fcn && ptr != sym->formal)
5982 {
5983 gfc_error ("Statement function %qs at %L conflicts with function name",
5984 sym->name, &expr->where);
5985 return MATCH_ERROR;
5986 }
5987
5988 sym->value = expr;
5989
5990 if ((gfc_current_state () == COMP_FUNCTION
5991 || gfc_current_state () == COMP_SUBROUTINE)
5992 && gfc_state_stack->previous->state == COMP_INTERFACE)
5993 {
5994 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5995 &expr->where);
5996 return MATCH_ERROR;
5997 }
5998
5999 if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
6000 return MATCH_ERROR;
6001
6002 return MATCH_YES;
6003
6004 undo_error:
6005 gfc_pop_error (&old_error);
6006 return MATCH_NO;
6007 }
6008
6009
6010 /* Match an assignment to a pointer function (F2008). This could, in
6011 general be ambiguous with a statement function. In this implementation
6012 it remains so if it is the first statement after the specification
6013 block. */
6014
6015 match
gfc_match_ptr_fcn_assign(void)6016 gfc_match_ptr_fcn_assign (void)
6017 {
6018 gfc_error_buffer old_error;
6019 locus old_loc;
6020 gfc_symbol *sym;
6021 gfc_expr *expr;
6022 match m;
6023 char name[GFC_MAX_SYMBOL_LEN + 1];
6024
6025 old_loc = gfc_current_locus;
6026 m = gfc_match_name (name);
6027 if (m != MATCH_YES)
6028 return m;
6029
6030 gfc_find_symbol (name, NULL, 1, &sym);
6031 if (sym && sym->attr.flavor != FL_PROCEDURE)
6032 return MATCH_NO;
6033
6034 gfc_push_error (&old_error);
6035
6036 if (sym && sym->attr.function)
6037 goto match_actual_arglist;
6038
6039 gfc_current_locus = old_loc;
6040 m = gfc_match_symbol (&sym, 0);
6041 if (m != MATCH_YES)
6042 return m;
6043
6044 if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
6045 goto undo_error;
6046
6047 match_actual_arglist:
6048 gfc_current_locus = old_loc;
6049 m = gfc_match (" %e", &expr);
6050 if (m != MATCH_YES)
6051 goto undo_error;
6052
6053 new_st.op = EXEC_ASSIGN;
6054 new_st.expr1 = expr;
6055 expr = NULL;
6056
6057 m = gfc_match (" = %e%t", &expr);
6058 if (m != MATCH_YES)
6059 goto undo_error;
6060
6061 new_st.expr2 = expr;
6062 return MATCH_YES;
6063
6064 undo_error:
6065 gfc_pop_error (&old_error);
6066 return MATCH_NO;
6067 }
6068
6069
6070 /***************** SELECT CASE subroutines ******************/
6071
6072 /* Free a single case structure. */
6073
6074 static void
free_case(gfc_case * p)6075 free_case (gfc_case *p)
6076 {
6077 if (p->low == p->high)
6078 p->high = NULL;
6079 gfc_free_expr (p->low);
6080 gfc_free_expr (p->high);
6081 free (p);
6082 }
6083
6084
6085 /* Free a list of case structures. */
6086
6087 void
gfc_free_case_list(gfc_case * p)6088 gfc_free_case_list (gfc_case *p)
6089 {
6090 gfc_case *q;
6091
6092 for (; p; p = q)
6093 {
6094 q = p->next;
6095 free_case (p);
6096 }
6097 }
6098
6099
6100 /* Match a single case selector. Combining the requirements of F08:C830
6101 and F08:C832 (R838) means that the case-value must have either CHARACTER,
6102 INTEGER, or LOGICAL type. */
6103
6104 static match
match_case_selector(gfc_case ** cp)6105 match_case_selector (gfc_case **cp)
6106 {
6107 gfc_case *c;
6108 match m;
6109
6110 c = gfc_get_case ();
6111 c->where = gfc_current_locus;
6112
6113 if (gfc_match_char (':') == MATCH_YES)
6114 {
6115 m = gfc_match_init_expr (&c->high);
6116 if (m == MATCH_NO)
6117 goto need_expr;
6118 if (m == MATCH_ERROR)
6119 goto cleanup;
6120
6121 if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER
6122 && c->high->ts.type != BT_CHARACTER)
6123 {
6124 gfc_error ("Expression in CASE selector at %L cannot be %s",
6125 &c->high->where, gfc_typename (&c->high->ts));
6126 goto cleanup;
6127 }
6128 }
6129 else
6130 {
6131 m = gfc_match_init_expr (&c->low);
6132 if (m == MATCH_ERROR)
6133 goto cleanup;
6134 if (m == MATCH_NO)
6135 goto need_expr;
6136
6137 if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER
6138 && c->low->ts.type != BT_CHARACTER)
6139 {
6140 gfc_error ("Expression in CASE selector at %L cannot be %s",
6141 &c->low->where, gfc_typename (&c->low->ts));
6142 goto cleanup;
6143 }
6144
6145 /* If we're not looking at a ':' now, make a range out of a single
6146 target. Else get the upper bound for the case range. */
6147 if (gfc_match_char (':') != MATCH_YES)
6148 c->high = c->low;
6149 else
6150 {
6151 m = gfc_match_init_expr (&c->high);
6152 if (m == MATCH_ERROR)
6153 goto cleanup;
6154 if (m == MATCH_YES
6155 && c->high->ts.type != BT_LOGICAL
6156 && c->high->ts.type != BT_INTEGER
6157 && c->high->ts.type != BT_CHARACTER)
6158 {
6159 gfc_error ("Expression in CASE selector at %L cannot be %s",
6160 &c->high->where, gfc_typename (c->high));
6161 goto cleanup;
6162 }
6163 /* MATCH_NO is fine. It's OK if nothing is there! */
6164 }
6165 }
6166
6167 if (c->low && c->low->rank != 0)
6168 {
6169 gfc_error ("Expression in CASE selector at %L must be scalar",
6170 &c->low->where);
6171 goto cleanup;
6172 }
6173 if (c->high && c->high->rank != 0)
6174 {
6175 gfc_error ("Expression in CASE selector at %L must be scalar",
6176 &c->high->where);
6177 goto cleanup;
6178 }
6179
6180 *cp = c;
6181 return MATCH_YES;
6182
6183 need_expr:
6184 gfc_error ("Expected initialization expression in CASE at %C");
6185
6186 cleanup:
6187 free_case (c);
6188 return MATCH_ERROR;
6189 }
6190
6191
6192 /* Match the end of a case statement. */
6193
6194 static match
match_case_eos(void)6195 match_case_eos (void)
6196 {
6197 char name[GFC_MAX_SYMBOL_LEN + 1];
6198 match m;
6199
6200 if (gfc_match_eos () == MATCH_YES)
6201 return MATCH_YES;
6202
6203 /* If the case construct doesn't have a case-construct-name, we
6204 should have matched the EOS. */
6205 if (!gfc_current_block ())
6206 return MATCH_NO;
6207
6208 gfc_gobble_whitespace ();
6209
6210 m = gfc_match_name (name);
6211 if (m != MATCH_YES)
6212 return m;
6213
6214 if (strcmp (name, gfc_current_block ()->name) != 0)
6215 {
6216 gfc_error ("Expected block name %qs of SELECT construct at %C",
6217 gfc_current_block ()->name);
6218 return MATCH_ERROR;
6219 }
6220
6221 return gfc_match_eos ();
6222 }
6223
6224
6225 /* Match a SELECT statement. */
6226
6227 match
gfc_match_select(void)6228 gfc_match_select (void)
6229 {
6230 gfc_expr *expr;
6231 match m;
6232
6233 m = gfc_match_label ();
6234 if (m == MATCH_ERROR)
6235 return m;
6236
6237 m = gfc_match (" select case ( %e )%t", &expr);
6238 if (m != MATCH_YES)
6239 return m;
6240
6241 new_st.op = EXEC_SELECT;
6242 new_st.expr1 = expr;
6243
6244 return MATCH_YES;
6245 }
6246
6247
6248 /* Transfer the selector typespec to the associate name. */
6249
6250 static void
copy_ts_from_selector_to_associate(gfc_expr * associate,gfc_expr * selector)6251 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
6252 {
6253 gfc_ref *ref;
6254 gfc_symbol *assoc_sym;
6255 int rank = 0;
6256
6257 assoc_sym = associate->symtree->n.sym;
6258
6259 /* At this stage the expression rank and arrayspec dimensions have
6260 not been completely sorted out. We must get the expr2->rank
6261 right here, so that the correct class container is obtained. */
6262 ref = selector->ref;
6263 while (ref && ref->next)
6264 ref = ref->next;
6265
6266 if (selector->ts.type == BT_CLASS
6267 && CLASS_DATA (selector)
6268 && CLASS_DATA (selector)->as
6269 && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK)
6270 {
6271 assoc_sym->attr.dimension = 1;
6272 assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
6273 goto build_class_sym;
6274 }
6275 else if (selector->ts.type == BT_CLASS
6276 && CLASS_DATA (selector)
6277 && CLASS_DATA (selector)->as
6278 && ref && ref->type == REF_ARRAY)
6279 {
6280 /* Ensure that the array reference type is set. We cannot use
6281 gfc_resolve_expr at this point, so the usable parts of
6282 resolve.cc(resolve_array_ref) are employed to do it. */
6283 if (ref->u.ar.type == AR_UNKNOWN)
6284 {
6285 ref->u.ar.type = AR_ELEMENT;
6286 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
6287 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
6288 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
6289 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6290 && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
6291 {
6292 ref->u.ar.type = AR_SECTION;
6293 break;
6294 }
6295 }
6296
6297 if (ref->u.ar.type == AR_FULL)
6298 selector->rank = CLASS_DATA (selector)->as->rank;
6299 else if (ref->u.ar.type == AR_SECTION)
6300 selector->rank = ref->u.ar.dimen;
6301 else
6302 selector->rank = 0;
6303
6304 rank = selector->rank;
6305 }
6306
6307 if (rank)
6308 {
6309 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
6310 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT
6311 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
6312 && ref->u.ar.end[i] == NULL
6313 && ref->u.ar.stride[i] == NULL))
6314 rank--;
6315
6316 if (rank)
6317 {
6318 assoc_sym->attr.dimension = 1;
6319 assoc_sym->as = gfc_get_array_spec ();
6320 assoc_sym->as->rank = rank;
6321 assoc_sym->as->type = AS_DEFERRED;
6322 }
6323 else
6324 assoc_sym->as = NULL;
6325 }
6326 else
6327 assoc_sym->as = NULL;
6328
6329 build_class_sym:
6330 if (selector->ts.type == BT_CLASS)
6331 {
6332 /* The correct class container has to be available. */
6333 assoc_sym->ts.type = BT_CLASS;
6334 assoc_sym->ts.u.derived = CLASS_DATA (selector)
6335 ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived;
6336 assoc_sym->attr.pointer = 1;
6337 gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
6338 }
6339 }
6340
6341
6342 /* Push the current selector onto the SELECT TYPE stack. */
6343
6344 static void
select_type_push(gfc_symbol * sel)6345 select_type_push (gfc_symbol *sel)
6346 {
6347 gfc_select_type_stack *top = gfc_get_select_type_stack ();
6348 top->selector = sel;
6349 top->tmp = NULL;
6350 top->prev = select_type_stack;
6351
6352 select_type_stack = top;
6353 }
6354
6355
6356 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6357
6358 static gfc_symtree *
select_intrinsic_set_tmp(gfc_typespec * ts)6359 select_intrinsic_set_tmp (gfc_typespec *ts)
6360 {
6361 char name[GFC_MAX_SYMBOL_LEN];
6362 gfc_symtree *tmp;
6363 HOST_WIDE_INT charlen = 0;
6364 gfc_symbol *selector = select_type_stack->selector;
6365 gfc_symbol *sym;
6366
6367 if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
6368 return NULL;
6369
6370 if (selector->ts.type == BT_CLASS && !selector->attr.class_ok)
6371 return NULL;
6372
6373 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6374 the values correspond to SELECT rank cases. */
6375 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
6376 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6377 charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
6378
6379 if (ts->type != BT_CHARACTER)
6380 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
6381 ts->kind);
6382 else
6383 snprintf (name, sizeof (name),
6384 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
6385 gfc_basic_typename (ts->type), charlen, ts->kind);
6386
6387 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
6388 sym = tmp->n.sym;
6389 gfc_add_type (sym, ts, NULL);
6390
6391 /* Copy across the array spec to the selector. */
6392 if (selector->ts.type == BT_CLASS
6393 && (CLASS_DATA (selector)->attr.dimension
6394 || CLASS_DATA (selector)->attr.codimension))
6395 {
6396 sym->attr.pointer = 1;
6397 sym->attr.dimension = CLASS_DATA (selector)->attr.dimension;
6398 sym->attr.codimension = CLASS_DATA (selector)->attr.codimension;
6399 sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
6400 }
6401
6402 gfc_set_sym_referenced (sym);
6403 gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
6404 sym->attr.select_type_temporary = 1;
6405
6406 return tmp;
6407 }
6408
6409
6410 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6411
6412 static void
select_type_set_tmp(gfc_typespec * ts)6413 select_type_set_tmp (gfc_typespec *ts)
6414 {
6415 char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
6416 gfc_symtree *tmp = NULL;
6417 gfc_symbol *selector = select_type_stack->selector;
6418 gfc_symbol *sym;
6419
6420 if (!ts)
6421 {
6422 select_type_stack->tmp = NULL;
6423 return;
6424 }
6425
6426 tmp = select_intrinsic_set_tmp (ts);
6427
6428 if (tmp == NULL)
6429 {
6430 if (!ts->u.derived)
6431 return;
6432
6433 if (ts->type == BT_CLASS)
6434 sprintf (name, "__tmp_class_%s", ts->u.derived->name);
6435 else
6436 sprintf (name, "__tmp_type_%s", ts->u.derived->name);
6437
6438 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
6439 sym = tmp->n.sym;
6440 gfc_add_type (sym, ts, NULL);
6441
6442 if (selector->ts.type == BT_CLASS && selector->attr.class_ok
6443 && selector->ts.u.derived && CLASS_DATA (selector))
6444 {
6445 sym->attr.pointer
6446 = CLASS_DATA (selector)->attr.class_pointer;
6447
6448 /* Copy across the array spec to the selector. */
6449 if (CLASS_DATA (selector)->attr.dimension
6450 || CLASS_DATA (selector)->attr.codimension)
6451 {
6452 sym->attr.dimension
6453 = CLASS_DATA (selector)->attr.dimension;
6454 sym->attr.codimension
6455 = CLASS_DATA (selector)->attr.codimension;
6456 if (CLASS_DATA (selector)->as->type != AS_EXPLICIT)
6457 sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
6458 else
6459 {
6460 sym->as = gfc_get_array_spec();
6461 sym->as->rank = CLASS_DATA (selector)->as->rank;
6462 sym->as->type = AS_DEFERRED;
6463 }
6464 }
6465 }
6466
6467 gfc_set_sym_referenced (sym);
6468 gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
6469 sym->attr.select_type_temporary = 1;
6470
6471 if (ts->type == BT_CLASS)
6472 gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
6473 }
6474 else
6475 sym = tmp->n.sym;
6476
6477
6478 /* Add an association for it, so the rest of the parser knows it is
6479 an associate-name. The target will be set during resolution. */
6480 sym->assoc = gfc_get_association_list ();
6481 sym->assoc->dangling = 1;
6482 sym->assoc->st = tmp;
6483
6484 select_type_stack->tmp = tmp;
6485 }
6486
6487
6488 /* Match a SELECT TYPE statement. */
6489
6490 match
gfc_match_select_type(void)6491 gfc_match_select_type (void)
6492 {
6493 gfc_expr *expr1, *expr2 = NULL;
6494 match m;
6495 char name[GFC_MAX_SYMBOL_LEN + 1];
6496 bool class_array;
6497 gfc_symbol *sym;
6498 gfc_namespace *ns = gfc_current_ns;
6499
6500 m = gfc_match_label ();
6501 if (m == MATCH_ERROR)
6502 return m;
6503
6504 m = gfc_match (" select type ( ");
6505 if (m != MATCH_YES)
6506 return m;
6507
6508 if (gfc_current_state() == COMP_MODULE
6509 || gfc_current_state() == COMP_SUBMODULE)
6510 {
6511 gfc_error ("SELECT TYPE at %C cannot appear in this scope");
6512 return MATCH_ERROR;
6513 }
6514
6515 gfc_current_ns = gfc_build_block_ns (ns);
6516 m = gfc_match (" %n => %e", name, &expr2);
6517 if (m == MATCH_YES)
6518 {
6519 expr1 = gfc_get_expr ();
6520 expr1->expr_type = EXPR_VARIABLE;
6521 expr1->where = expr2->where;
6522 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
6523 {
6524 m = MATCH_ERROR;
6525 goto cleanup;
6526 }
6527
6528 sym = expr1->symtree->n.sym;
6529 if (expr2->ts.type == BT_UNKNOWN)
6530 sym->attr.untyped = 1;
6531 else
6532 copy_ts_from_selector_to_associate (expr1, expr2);
6533
6534 sym->attr.flavor = FL_VARIABLE;
6535 sym->attr.referenced = 1;
6536 sym->attr.class_ok = 1;
6537 }
6538 else
6539 {
6540 m = gfc_match (" %e ", &expr1);
6541 if (m != MATCH_YES)
6542 {
6543 std::swap (ns, gfc_current_ns);
6544 gfc_free_namespace (ns);
6545 return m;
6546 }
6547 }
6548
6549 m = gfc_match (" )%t");
6550 if (m != MATCH_YES)
6551 {
6552 gfc_error ("parse error in SELECT TYPE statement at %C");
6553 goto cleanup;
6554 }
6555
6556 /* This ghastly expression seems to be needed to distinguish a CLASS
6557 array, which can have a reference, from other expressions that
6558 have references, such as derived type components, and are not
6559 allowed by the standard.
6560 TODO: see if it is sufficient to exclude component and substring
6561 references. */
6562 class_array = (expr1->expr_type == EXPR_VARIABLE
6563 && expr1->ts.type == BT_CLASS
6564 && CLASS_DATA (expr1)
6565 && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
6566 && (CLASS_DATA (expr1)->attr.dimension
6567 || CLASS_DATA (expr1)->attr.codimension)
6568 && expr1->ref
6569 && expr1->ref->type == REF_ARRAY
6570 && expr1->ref->u.ar.type == AR_FULL
6571 && expr1->ref->next == NULL);
6572
6573 /* Check for F03:C811 (F08:C835). */
6574 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
6575 || (!class_array && expr1->ref != NULL)))
6576 {
6577 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6578 "use associate-name=>");
6579 m = MATCH_ERROR;
6580 goto cleanup;
6581 }
6582
6583 new_st.op = EXEC_SELECT_TYPE;
6584 new_st.expr1 = expr1;
6585 new_st.expr2 = expr2;
6586 new_st.ext.block.ns = gfc_current_ns;
6587
6588 select_type_push (expr1->symtree->n.sym);
6589 gfc_current_ns = ns;
6590
6591 return MATCH_YES;
6592
6593 cleanup:
6594 gfc_free_expr (expr1);
6595 gfc_free_expr (expr2);
6596 gfc_undo_symbols ();
6597 std::swap (ns, gfc_current_ns);
6598 gfc_free_namespace (ns);
6599 return m;
6600 }
6601
6602
6603 /* Set the temporary for the current intrinsic SELECT RANK selector. */
6604
6605 static void
select_rank_set_tmp(gfc_typespec * ts,int * case_value)6606 select_rank_set_tmp (gfc_typespec *ts, int *case_value)
6607 {
6608 char name[2 * GFC_MAX_SYMBOL_LEN];
6609 char tname[GFC_MAX_SYMBOL_LEN + 7];
6610 gfc_symtree *tmp;
6611 gfc_symbol *selector = select_type_stack->selector;
6612 gfc_symbol *sym;
6613 gfc_symtree *st;
6614 HOST_WIDE_INT charlen = 0;
6615
6616 if (case_value == NULL)
6617 return;
6618
6619 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
6620 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6621 charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
6622
6623 if (ts->type == BT_CLASS)
6624 sprintf (tname, "class_%s", ts->u.derived->name);
6625 else if (ts->type == BT_DERIVED)
6626 sprintf (tname, "type_%s", ts->u.derived->name);
6627 else if (ts->type != BT_CHARACTER)
6628 sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind);
6629 else
6630 sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
6631 gfc_basic_typename (ts->type), charlen, ts->kind);
6632
6633 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6634 the values correspond to SELECT rank cases. */
6635 if (*case_value >=0)
6636 sprintf (name, "__tmp_%s_rank_%d", tname, *case_value);
6637 else
6638 sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value);
6639
6640 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
6641 if (st)
6642 return;
6643
6644 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
6645 sym = tmp->n.sym;
6646 gfc_add_type (sym, ts, NULL);
6647
6648 /* Copy across the array spec to the selector. */
6649 if (selector->ts.type == BT_CLASS)
6650 {
6651 sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
6652 sym->attr.pointer = CLASS_DATA (selector)->attr.pointer;
6653 sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable;
6654 sym->attr.target = CLASS_DATA (selector)->attr.target;
6655 sym->attr.class_ok = 0;
6656 if (case_value && *case_value != 0)
6657 {
6658 sym->attr.dimension = 1;
6659 sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
6660 if (*case_value > 0)
6661 {
6662 sym->as->type = AS_DEFERRED;
6663 sym->as->rank = *case_value;
6664 }
6665 else if (*case_value == -1)
6666 {
6667 sym->as->type = AS_ASSUMED_SIZE;
6668 sym->as->rank = 1;
6669 }
6670 }
6671 }
6672 else
6673 {
6674 sym->attr.pointer = selector->attr.pointer;
6675 sym->attr.allocatable = selector->attr.allocatable;
6676 sym->attr.target = selector->attr.target;
6677 if (case_value && *case_value != 0)
6678 {
6679 sym->attr.dimension = 1;
6680 sym->as = gfc_copy_array_spec (selector->as);
6681 if (*case_value > 0)
6682 {
6683 sym->as->type = AS_DEFERRED;
6684 sym->as->rank = *case_value;
6685 }
6686 else if (*case_value == -1)
6687 {
6688 sym->as->type = AS_ASSUMED_SIZE;
6689 sym->as->rank = 1;
6690 }
6691 }
6692 }
6693
6694 gfc_set_sym_referenced (sym);
6695 gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
6696 sym->attr.select_type_temporary = 1;
6697 if (case_value)
6698 sym->attr.select_rank_temporary = 1;
6699
6700 if (ts->type == BT_CLASS)
6701 gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
6702
6703 /* Add an association for it, so the rest of the parser knows it is
6704 an associate-name. The target will be set during resolution. */
6705 sym->assoc = gfc_get_association_list ();
6706 sym->assoc->dangling = 1;
6707 sym->assoc->st = tmp;
6708
6709 select_type_stack->tmp = tmp;
6710 }
6711
6712
6713 /* Match a SELECT RANK statement. */
6714
6715 match
gfc_match_select_rank(void)6716 gfc_match_select_rank (void)
6717 {
6718 gfc_expr *expr1, *expr2 = NULL;
6719 match m;
6720 char name[GFC_MAX_SYMBOL_LEN + 1];
6721 gfc_symbol *sym, *sym2;
6722 gfc_namespace *ns = gfc_current_ns;
6723 gfc_array_spec *as = NULL;
6724
6725 m = gfc_match_label ();
6726 if (m == MATCH_ERROR)
6727 return m;
6728
6729 m = gfc_match (" select rank ( ");
6730 if (m != MATCH_YES)
6731 return m;
6732
6733 if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C"))
6734 return MATCH_NO;
6735
6736 gfc_current_ns = gfc_build_block_ns (ns);
6737 m = gfc_match (" %n => %e", name, &expr2);
6738 if (m == MATCH_YES)
6739 {
6740 expr1 = gfc_get_expr ();
6741 expr1->expr_type = EXPR_VARIABLE;
6742 expr1->where = expr2->where;
6743 expr1->ref = gfc_copy_ref (expr2->ref);
6744 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
6745 {
6746 m = MATCH_ERROR;
6747 goto cleanup;
6748 }
6749
6750 sym = expr1->symtree->n.sym;
6751
6752 if (expr2->symtree)
6753 {
6754 sym2 = expr2->symtree->n.sym;
6755 as = (sym2->ts.type == BT_CLASS
6756 && CLASS_DATA (sym2)) ? CLASS_DATA (sym2)->as : sym2->as;
6757 }
6758
6759 if (expr2->expr_type != EXPR_VARIABLE
6760 || !(as && as->type == AS_ASSUMED_RANK))
6761 {
6762 gfc_error ("The SELECT RANK selector at %C must be an assumed "
6763 "rank variable");
6764 m = MATCH_ERROR;
6765 goto cleanup;
6766 }
6767
6768 if (expr2->ts.type == BT_CLASS && CLASS_DATA (sym2))
6769 {
6770 copy_ts_from_selector_to_associate (expr1, expr2);
6771
6772 sym->attr.flavor = FL_VARIABLE;
6773 sym->attr.referenced = 1;
6774 sym->attr.class_ok = 1;
6775 CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable;
6776 CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer;
6777 CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target;
6778 sym->attr.pointer = 1;
6779 }
6780 else
6781 {
6782 sym->ts = sym2->ts;
6783 sym->as = gfc_copy_array_spec (sym2->as);
6784 sym->attr.dimension = 1;
6785
6786 sym->attr.flavor = FL_VARIABLE;
6787 sym->attr.referenced = 1;
6788 sym->attr.class_ok = sym2->attr.class_ok;
6789 sym->attr.allocatable = sym2->attr.allocatable;
6790 sym->attr.pointer = sym2->attr.pointer;
6791 sym->attr.target = sym2->attr.target;
6792 }
6793 }
6794 else
6795 {
6796 m = gfc_match (" %e ", &expr1);
6797
6798 if (m != MATCH_YES)
6799 {
6800 gfc_undo_symbols ();
6801 std::swap (ns, gfc_current_ns);
6802 gfc_free_namespace (ns);
6803 return m;
6804 }
6805
6806 if (expr1->symtree)
6807 {
6808 sym = expr1->symtree->n.sym;
6809 as = (sym->ts.type == BT_CLASS
6810 && CLASS_DATA (sym)) ? CLASS_DATA (sym)->as : sym->as;
6811 }
6812
6813 if (expr1->expr_type != EXPR_VARIABLE
6814 || !(as && as->type == AS_ASSUMED_RANK))
6815 {
6816 gfc_error("The SELECT RANK selector at %C must be an assumed "
6817 "rank variable");
6818 m = MATCH_ERROR;
6819 goto cleanup;
6820 }
6821 }
6822
6823 m = gfc_match (" )%t");
6824 if (m != MATCH_YES)
6825 {
6826 gfc_error ("parse error in SELECT RANK statement at %C");
6827 goto cleanup;
6828 }
6829
6830 new_st.op = EXEC_SELECT_RANK;
6831 new_st.expr1 = expr1;
6832 new_st.expr2 = expr2;
6833 new_st.ext.block.ns = gfc_current_ns;
6834
6835 select_type_push (expr1->symtree->n.sym);
6836 gfc_current_ns = ns;
6837
6838 return MATCH_YES;
6839
6840 cleanup:
6841 gfc_free_expr (expr1);
6842 gfc_free_expr (expr2);
6843 gfc_undo_symbols ();
6844 std::swap (ns, gfc_current_ns);
6845 gfc_free_namespace (ns);
6846 return m;
6847 }
6848
6849
6850 /* Match a CASE statement. */
6851
6852 match
gfc_match_case(void)6853 gfc_match_case (void)
6854 {
6855 gfc_case *c, *head, *tail;
6856 match m;
6857
6858 head = tail = NULL;
6859
6860 if (gfc_current_state () != COMP_SELECT)
6861 {
6862 gfc_error ("Unexpected CASE statement at %C");
6863 return MATCH_ERROR;
6864 }
6865
6866 if (gfc_match ("% default") == MATCH_YES)
6867 {
6868 m = match_case_eos ();
6869 if (m == MATCH_NO)
6870 goto syntax;
6871 if (m == MATCH_ERROR)
6872 goto cleanup;
6873
6874 new_st.op = EXEC_SELECT;
6875 c = gfc_get_case ();
6876 c->where = gfc_current_locus;
6877 new_st.ext.block.case_list = c;
6878 return MATCH_YES;
6879 }
6880
6881 if (gfc_match_char ('(') != MATCH_YES)
6882 goto syntax;
6883
6884 for (;;)
6885 {
6886 if (match_case_selector (&c) == MATCH_ERROR)
6887 goto cleanup;
6888
6889 if (head == NULL)
6890 head = c;
6891 else
6892 tail->next = c;
6893
6894 tail = c;
6895
6896 if (gfc_match_char (')') == MATCH_YES)
6897 break;
6898 if (gfc_match_char (',') != MATCH_YES)
6899 goto syntax;
6900 }
6901
6902 m = match_case_eos ();
6903 if (m == MATCH_NO)
6904 goto syntax;
6905 if (m == MATCH_ERROR)
6906 goto cleanup;
6907
6908 new_st.op = EXEC_SELECT;
6909 new_st.ext.block.case_list = head;
6910
6911 return MATCH_YES;
6912
6913 syntax:
6914 gfc_error ("Syntax error in CASE specification at %C");
6915
6916 cleanup:
6917 gfc_free_case_list (head); /* new_st is cleaned up in parse.cc. */
6918 return MATCH_ERROR;
6919 }
6920
6921
6922 /* Match a TYPE IS statement. */
6923
6924 match
gfc_match_type_is(void)6925 gfc_match_type_is (void)
6926 {
6927 gfc_case *c = NULL;
6928 match m;
6929
6930 if (gfc_current_state () != COMP_SELECT_TYPE)
6931 {
6932 gfc_error ("Unexpected TYPE IS statement at %C");
6933 return MATCH_ERROR;
6934 }
6935
6936 if (gfc_match_char ('(') != MATCH_YES)
6937 goto syntax;
6938
6939 c = gfc_get_case ();
6940 c->where = gfc_current_locus;
6941
6942 m = gfc_match_type_spec (&c->ts);
6943 if (m == MATCH_NO)
6944 goto syntax;
6945 if (m == MATCH_ERROR)
6946 goto cleanup;
6947
6948 if (gfc_match_char (')') != MATCH_YES)
6949 goto syntax;
6950
6951 m = match_case_eos ();
6952 if (m == MATCH_NO)
6953 goto syntax;
6954 if (m == MATCH_ERROR)
6955 goto cleanup;
6956
6957 new_st.op = EXEC_SELECT_TYPE;
6958 new_st.ext.block.case_list = c;
6959
6960 if (c->ts.type == BT_DERIVED && c->ts.u.derived
6961 && (c->ts.u.derived->attr.sequence
6962 || c->ts.u.derived->attr.is_bind_c))
6963 {
6964 gfc_error ("The type-spec shall not specify a sequence derived "
6965 "type or a type with the BIND attribute in SELECT "
6966 "TYPE at %C [F2003:C815]");
6967 return MATCH_ERROR;
6968 }
6969
6970 if (c->ts.type == BT_DERIVED
6971 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
6972 && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
6973 != SPEC_ASSUMED)
6974 {
6975 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6976 "at %C must be ASSUMED");
6977 return MATCH_ERROR;
6978 }
6979
6980 /* Create temporary variable. */
6981 select_type_set_tmp (&c->ts);
6982
6983 return MATCH_YES;
6984
6985 syntax:
6986 gfc_error ("Syntax error in TYPE IS specification at %C");
6987
6988 cleanup:
6989 if (c != NULL)
6990 gfc_free_case_list (c); /* new_st is cleaned up in parse.cc. */
6991 return MATCH_ERROR;
6992 }
6993
6994
6995 /* Match a CLASS IS or CLASS DEFAULT statement. */
6996
6997 match
gfc_match_class_is(void)6998 gfc_match_class_is (void)
6999 {
7000 gfc_case *c = NULL;
7001 match m;
7002
7003 if (gfc_current_state () != COMP_SELECT_TYPE)
7004 return MATCH_NO;
7005
7006 if (gfc_match ("% default") == MATCH_YES)
7007 {
7008 m = match_case_eos ();
7009 if (m == MATCH_NO)
7010 goto syntax;
7011 if (m == MATCH_ERROR)
7012 goto cleanup;
7013
7014 new_st.op = EXEC_SELECT_TYPE;
7015 c = gfc_get_case ();
7016 c->where = gfc_current_locus;
7017 c->ts.type = BT_UNKNOWN;
7018 new_st.ext.block.case_list = c;
7019 select_type_set_tmp (NULL);
7020 return MATCH_YES;
7021 }
7022
7023 m = gfc_match ("% is");
7024 if (m == MATCH_NO)
7025 goto syntax;
7026 if (m == MATCH_ERROR)
7027 goto cleanup;
7028
7029 if (gfc_match_char ('(') != MATCH_YES)
7030 goto syntax;
7031
7032 c = gfc_get_case ();
7033 c->where = gfc_current_locus;
7034
7035 m = match_derived_type_spec (&c->ts);
7036 if (m == MATCH_NO)
7037 goto syntax;
7038 if (m == MATCH_ERROR)
7039 goto cleanup;
7040
7041 if (c->ts.type == BT_DERIVED)
7042 c->ts.type = BT_CLASS;
7043
7044 if (gfc_match_char (')') != MATCH_YES)
7045 goto syntax;
7046
7047 m = match_case_eos ();
7048 if (m == MATCH_NO)
7049 goto syntax;
7050 if (m == MATCH_ERROR)
7051 goto cleanup;
7052
7053 new_st.op = EXEC_SELECT_TYPE;
7054 new_st.ext.block.case_list = c;
7055
7056 /* Create temporary variable. */
7057 select_type_set_tmp (&c->ts);
7058
7059 return MATCH_YES;
7060
7061 syntax:
7062 gfc_error ("Syntax error in CLASS IS specification at %C");
7063
7064 cleanup:
7065 if (c != NULL)
7066 gfc_free_case_list (c); /* new_st is cleaned up in parse.cc. */
7067 return MATCH_ERROR;
7068 }
7069
7070
7071 /* Match a RANK statement. */
7072
7073 match
gfc_match_rank_is(void)7074 gfc_match_rank_is (void)
7075 {
7076 gfc_case *c = NULL;
7077 match m;
7078 int case_value;
7079
7080 if (gfc_current_state () != COMP_SELECT_RANK)
7081 {
7082 gfc_error ("Unexpected RANK statement at %C");
7083 return MATCH_ERROR;
7084 }
7085
7086 if (gfc_match ("% default") == MATCH_YES)
7087 {
7088 m = match_case_eos ();
7089 if (m == MATCH_NO)
7090 goto syntax;
7091 if (m == MATCH_ERROR)
7092 goto cleanup;
7093
7094 new_st.op = EXEC_SELECT_RANK;
7095 c = gfc_get_case ();
7096 c->ts.type = BT_UNKNOWN;
7097 c->where = gfc_current_locus;
7098 new_st.ext.block.case_list = c;
7099 select_type_stack->tmp = NULL;
7100 return MATCH_YES;
7101 }
7102
7103 if (gfc_match_char ('(') != MATCH_YES)
7104 goto syntax;
7105
7106 c = gfc_get_case ();
7107 c->where = gfc_current_locus;
7108 c->ts = select_type_stack->selector->ts;
7109
7110 m = gfc_match_expr (&c->low);
7111 if (m == MATCH_NO)
7112 {
7113 if (gfc_match_char ('*') == MATCH_YES)
7114 c->low = gfc_get_int_expr (gfc_default_integer_kind,
7115 NULL, -1);
7116 else
7117 goto syntax;
7118
7119 case_value = -1;
7120 }
7121 else if (m == MATCH_YES)
7122 {
7123 /* F2018: R1150 */
7124 if (c->low->expr_type != EXPR_CONSTANT
7125 || c->low->ts.type != BT_INTEGER
7126 || c->low->rank)
7127 {
7128 gfc_error ("The SELECT RANK CASE expression at %C must be a "
7129 "scalar, integer constant");
7130 goto cleanup;
7131 }
7132
7133 case_value = (int) mpz_get_si (c->low->value.integer);
7134 /* F2018: C1151 */
7135 if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS))
7136 {
7137 gfc_error ("The value of the SELECT RANK CASE expression at "
7138 "%C must not be less than zero or greater than %d",
7139 GFC_MAX_DIMENSIONS);
7140 goto cleanup;
7141 }
7142 }
7143 else
7144 goto cleanup;
7145
7146 if (gfc_match_char (')') != MATCH_YES)
7147 goto syntax;
7148
7149 m = match_case_eos ();
7150 if (m == MATCH_NO)
7151 goto syntax;
7152 if (m == MATCH_ERROR)
7153 goto cleanup;
7154
7155 new_st.op = EXEC_SELECT_RANK;
7156 new_st.ext.block.case_list = c;
7157
7158 /* Create temporary variable. Recycle the select type code. */
7159 select_rank_set_tmp (&c->ts, &case_value);
7160
7161 return MATCH_YES;
7162
7163 syntax:
7164 gfc_error ("Syntax error in RANK specification at %C");
7165
7166 cleanup:
7167 if (c != NULL)
7168 gfc_free_case_list (c); /* new_st is cleaned up in parse.cc. */
7169 return MATCH_ERROR;
7170 }
7171
7172 /********************* WHERE subroutines ********************/
7173
7174 /* Match the rest of a simple WHERE statement that follows an IF statement.
7175 */
7176
7177 static match
match_simple_where(void)7178 match_simple_where (void)
7179 {
7180 gfc_expr *expr;
7181 gfc_code *c;
7182 match m;
7183
7184 m = gfc_match (" ( %e )", &expr);
7185 if (m != MATCH_YES)
7186 return m;
7187
7188 m = gfc_match_assignment ();
7189 if (m == MATCH_NO)
7190 goto syntax;
7191 if (m == MATCH_ERROR)
7192 goto cleanup;
7193
7194 if (gfc_match_eos () != MATCH_YES)
7195 goto syntax;
7196
7197 c = gfc_get_code (EXEC_WHERE);
7198 c->expr1 = expr;
7199
7200 c->next = XCNEW (gfc_code);
7201 *c->next = new_st;
7202 c->next->loc = gfc_current_locus;
7203 gfc_clear_new_st ();
7204
7205 new_st.op = EXEC_WHERE;
7206 new_st.block = c;
7207
7208 return MATCH_YES;
7209
7210 syntax:
7211 gfc_syntax_error (ST_WHERE);
7212
7213 cleanup:
7214 gfc_free_expr (expr);
7215 return MATCH_ERROR;
7216 }
7217
7218
7219 /* Match a WHERE statement. */
7220
7221 match
gfc_match_where(gfc_statement * st)7222 gfc_match_where (gfc_statement *st)
7223 {
7224 gfc_expr *expr;
7225 match m0, m;
7226 gfc_code *c;
7227
7228 m0 = gfc_match_label ();
7229 if (m0 == MATCH_ERROR)
7230 return m0;
7231
7232 m = gfc_match (" where ( %e )", &expr);
7233 if (m != MATCH_YES)
7234 return m;
7235
7236 if (gfc_match_eos () == MATCH_YES)
7237 {
7238 *st = ST_WHERE_BLOCK;
7239 new_st.op = EXEC_WHERE;
7240 new_st.expr1 = expr;
7241 return MATCH_YES;
7242 }
7243
7244 m = gfc_match_assignment ();
7245 if (m == MATCH_NO)
7246 gfc_syntax_error (ST_WHERE);
7247
7248 if (m != MATCH_YES)
7249 {
7250 gfc_free_expr (expr);
7251 return MATCH_ERROR;
7252 }
7253
7254 /* We've got a simple WHERE statement. */
7255 *st = ST_WHERE;
7256 c = gfc_get_code (EXEC_WHERE);
7257 c->expr1 = expr;
7258
7259 /* Put in the assignment. It will not be processed by add_statement, so we
7260 need to copy the location here. */
7261
7262 c->next = XCNEW (gfc_code);
7263 *c->next = new_st;
7264 c->next->loc = gfc_current_locus;
7265 gfc_clear_new_st ();
7266
7267 new_st.op = EXEC_WHERE;
7268 new_st.block = c;
7269
7270 return MATCH_YES;
7271 }
7272
7273
7274 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
7275 new_st if successful. */
7276
7277 match
gfc_match_elsewhere(void)7278 gfc_match_elsewhere (void)
7279 {
7280 char name[GFC_MAX_SYMBOL_LEN + 1];
7281 gfc_expr *expr;
7282 match m;
7283
7284 if (gfc_current_state () != COMP_WHERE)
7285 {
7286 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
7287 return MATCH_ERROR;
7288 }
7289
7290 expr = NULL;
7291
7292 if (gfc_match_char ('(') == MATCH_YES)
7293 {
7294 m = gfc_match_expr (&expr);
7295 if (m == MATCH_NO)
7296 goto syntax;
7297 if (m == MATCH_ERROR)
7298 return MATCH_ERROR;
7299
7300 if (gfc_match_char (')') != MATCH_YES)
7301 goto syntax;
7302 }
7303
7304 if (gfc_match_eos () != MATCH_YES)
7305 {
7306 /* Only makes sense if we have a where-construct-name. */
7307 if (!gfc_current_block ())
7308 {
7309 m = MATCH_ERROR;
7310 goto cleanup;
7311 }
7312 /* Better be a name at this point. */
7313 m = gfc_match_name (name);
7314 if (m == MATCH_NO)
7315 goto syntax;
7316 if (m == MATCH_ERROR)
7317 goto cleanup;
7318
7319 if (gfc_match_eos () != MATCH_YES)
7320 goto syntax;
7321
7322 if (strcmp (name, gfc_current_block ()->name) != 0)
7323 {
7324 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
7325 name, gfc_current_block ()->name);
7326 goto cleanup;
7327 }
7328 }
7329
7330 new_st.op = EXEC_WHERE;
7331 new_st.expr1 = expr;
7332 return MATCH_YES;
7333
7334 syntax:
7335 gfc_syntax_error (ST_ELSEWHERE);
7336
7337 cleanup:
7338 gfc_free_expr (expr);
7339 return MATCH_ERROR;
7340 }
7341