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