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