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