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