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